--- /dev/null
+obj
+output
+ChangeLog
+local-target-features.lisp-expr
--- /dev/null
+REPORTING BUGS
+
+Bugs can be reported on the help mailing list
+ sbcl-help@lists.sourceforge.net
+or on the development mailing list
+ sbcl-devel@lists.sourceforge.net
+
+Please please please include enough information in a bug report
+that someone reading it can reproduce the problem, i.e. don't write
+ Subject: apparent bug in PRINT-OBJECT (or *PRINT-LENGTH*?)
+ PRINT-OBJECT doesn't seem to work with *PRINT-LENGTH*. Is this a bug?
+but instead
+ Subject: apparent bug in PRINT-OBJECT (or *PRINT-LENGTH*?)
+ Under sbcl-1.2.3, when I compile and load the file
+ (DEFSTRUCT (FOO (:PRINT-OBJECT (LAMBDA (X Y)
+ (LET ((*PRINT-LENGTH* 4))
+ (PRINT X Y)))))
+ X Y)
+ then at the command line type
+ (MAKE-FOO)
+ the program loops endlessly instead of printing the object.
+
+
+KNOWN PORT-SPECIFIC BUGS
+
+The breakpoint-based TRACE facility doesn't work properly in the
+OpenBSD port of sbcl-0.6.7.
+
+KNOWN BUGS
+
+(There is also some information on bugs in the manual page and in the
+TODO file. Eventually more such information may move here.)
+
+* (DESCRIBE NIL) causes an endless loop.
+
+* The FUNCTION special operator doesn't check properly whether its
+ argument is a function name. E.g. (FUNCTION (X Y)) returns a value
+ instead of failing with an error.
+
+* (DESCRIBE 'GF) fails where GF is the name of a generic function:
+ The function SB-IMPL::DESCRIBE-INSTANCE is undefined.
+
+* Failure in initialization files is not handled gracefully -- it's
+ a throw to TOP-LEVEL-CATCHER, which is not caught until we enter
+ TOPLEVEL-REPL. Code should be added to catch such THROWs even when
+ we're not in TOPLEVEL-REPL and do *something* with them (probably
+ complaining about an error outside TOPLEVEL-REPL, perhaps printing
+ a BACKTRACE, then terminating execution of SBCL).
+
+* COMPILED-FUNCTION-P bogusly reports T for interpreted functions:
+ * (DEFUN FOO (X) (- 12 X))
+ FOO
+ * (COMPILED-FUNCTION-P #'FOO)
+ T
+
+* The CL:STEP macro is undefined.
+
+* DEFSTRUCT should almost certainly overwrite the old LAYOUT information
+ instead of just punting when a contradictory structure definition
+ is loaded.
+
+* It should cause a STYLE-WARNING, not a full WARNING, when a structure
+ slot default value does not match the declared structure slot type.
+ (The current behavior is consistent with SBCL's behavior elsewhere,
+ and would not be a problem, except that the other behavior is
+ specifically required by the ANSI spec.)
+
+* It should cause a STYLE-WARNING, not a WARNING, when the system ignores
+ an FTYPE proclamation for a slot accessor.
+
+* Missing ordinary arguments in a macro call aren't reported when the
+ macro lambda list contains &KEY:
+ (DEFMACRO FOO (BAR &KEY) BAR) => FOO
+ (FOO) => NIL
+ Also in DESTRUCTURING-BIND:
+ (DESTRUCTURING-BIND (X Y &REST REST) '(1) (VECTOR X Y REST))
+ => #(1 NIL NIL)
+ Also with &REST lists:
+ (DEFMACRO FOO (BAR &REST REST) BAR) => FOO
+ (FOO) => NIL
+
+* Error reporting on various stream-requiring operations is not
+ very good when the stream argument has the wrong type, because
+ the operation tries to fall through to Gray stream code, and then
+ dies because it's undefined. E.g.
+ (PRINT-UNREADABLE-OBJECT (*STANDARD-OUTPUT* 1))
+ gives the error message
+ error in SB-KERNEL::UNDEFINED-SYMBOL-ERROR-HANDLER:
+ The function SB-IMPL::STREAM-WRITE-STRING is undefined.
+ It would be more useful and correct to signal a TYPE-ERROR:
+ not a STREAM: 1
+ (It wouldn't be terribly difficult to write stubs for all the
+ Gray stream functions that the old CMU CL code expects, with
+ each stub just raising the appropriate TYPE-ERROR.)
+
+* bogus warnings about undefined functions for magic functions like
+ SB!C::%%DEFUN and SB!C::%DEFCONSTANT when cross-compiling files
+ like src/code/float.lisp
+
+* The "byte compiling top-level form:" output ought to be condensed.
+ Perhaps any number of such consecutive lines ought to turn into a
+ single "byte compiling top-level forms:" line.
+
+* The handling of IGNORE declarations on lambda list arguments of DEFMETHOD
+ is at least weird, and in fact seems broken and useless. I should
+ fix up another layer of binding, declared IGNORABLE, for typed
+ lambda list arguments.
+
+* Compiling a file containing the erroneous program
+ (DEFSTRUCT FOO
+ A
+ B)
+ (DEFSTRUCT (BAR (:INCLUDE FOO))
+ A
+ B)
+ gives only the not-very-useful message
+ caught ERROR:
+ (during macroexpansion)
+ Condition PROGRAM-ERROR was signalled.
+ (The specific message which says that the problem was duplicate
+ slot names gets lost.)
+
+* The way that the compiler munges types with arguments together
+ with types with no arguments (in e.g. TYPE-EXPAND) leads to
+ weirdness visible to the user:
+ (DEFTYPE FOO () 'FIXNUM)
+ (TYPEP 11 'FOO) => T
+ (TYPEP 11 '(FOO)) => T, which seems weird
+ (TYPEP 11 'FIXNUM) => T
+ (TYPEP 11 '(FIXNUM)) signals an error, as it should
+ The situation is complicated by the presence of Common Lisp types
+ like UNSIGNED-BYTE (which can either be used in list form or alone)
+ so I'm not 100% sure that the behavior above is actually illegal.
+ But I'm 90+% sure, and someday perhaps I'll be motivated to look it up..
+
+* It would be nice if the
+ caught ERROR:
+ (during macroexpansion)
+ said what macroexpansion was at fault, e.g.
+ caught ERROR:
+ (during macroexpansion of IN-PACKAGE,
+ during macroexpansion of DEFFOO)
+
+* The type system doesn't understand the KEYWORD type very well:
+ (SUBTYPEP 'KEYWORD 'SYMBOL) => NIL, NIL
+ It might be possible to fix this by changing the definition of
+ KEYWORD to (AND SYMBOL (SATISFIES KEYWORDP)), but the type system
+ would need to be a bit smarter about AND types, too:
+ (SUBTYPEP '(AND SYMBOL KEYWORD) 'SYMBOL) => NIL, NIL
+ (The type system does know something about AND types already,
+ (SUBTYPEP '(AND INTEGER FLOAT) 'NUMBER) => T, T
+ (SUBTYPEP '(AND INTEGER FIXNUM) 'NUMBER) =>T, T
+ so likely this is a small patch.)
+
+* Floating point infinities are screwed up. [When I was converting CMU CL
+ to SBCL, I was looking for complexity to delete, and I thought it was safe
+ to just delete support for floating point infinities. It wasn't: they're
+ generated by the floating point hardware even when we remove support
+ for them in software. -- WHN] Support for them should be restored.
+
+* The ANSI syntax for non-STANDARD method combination types in CLOS is
+ (DEFGENERIC FOO (X) (:METHOD-COMBINATION PROGN))
+ (DEFMETHOD FOO PROGN ((X BAR)) (PRINT 'NUMBER))
+ If you mess this up, omitting the PROGN qualifier in in DEFMETHOD,
+ (DEFGENERIC FOO (X) (:METHOD-COMBINATION PROGN))
+ (DEFMETHOD FOO ((X BAR)) (PRINT 'NUMBER))
+ the error mesage is not easy to understand:
+ INVALID-METHOD-ERROR was called outside the dynamic scope
+ of a method combination function (inside the body of
+ DEFINE-METHOD-COMBINATION or a method on the generic
+ function COMPUTE-EFFECTIVE-METHOD).
+ It would be better if it were more informative, a la
+ The method combination type for this method (STANDARD) does
+ not match the method combination type for the generic function
+ (PROGN).
+ Also, after you make the mistake of omitting the PROGN qualifier
+ on a DEFMETHOD, doing a new DEFMETHOD with the correct qualifier
+ no longer works:
+ (DEFMETHOD FOO PROGN ((X BAR)) (PRINT 'NUMBER))
+ gives
+ INVALID-METHOD-ERROR was called outside the dynamic scope
+ of a method combination function (inside the body of
+ DEFINE-METHOD-COMBINATION or a method on the generic
+ function COMPUTE-EFFECTIVE-METHOD).
+ This is not very helpful..
+
+* The message "The top of the stack was encountered." from the debugger
+ is not helpful when I type "FRAME 0" -- I know I'm going to the top
+ of the stack.
+
+* (SUBTYPEP '(FUNCTION (T BOOLEAN) NIL)
+ '(FUNCTION (FIXNUM FIXNUM) NIL)) => T, T
+ (Also, when this is fixed, we can enable the code in PROCLAIM which
+ checks for incompatible FTYPE redeclarations.)
+
+* The ANSI spec says that CONS can be a compound type spec, e.g.
+ (CONS FIXNUM REAL). SBCL doesn't support this.
+
+* from Paolo Amoroso on the CMU CL mailing list 27 Feb 2000:
+ I use CMU CL 18b under Linux. When COMPILE-FILE is supplied a physical
+pathname, the type of the corresponding compiled file is X86F:
+ * (compile-file "/home/paolo/lisp/tools/foo")
+ Python version 1.0, VM version Intel x86 on 27 FEB 0 06:00:46 pm.
+ Compiling: /home/paolo/lisp/tools/foo.lisp 27 FEB 0 05:57:42 pm
+ Converted SQUARE.
+ Compiling DEFUN SQUARE:
+ Byte Compiling Top-Level Form:
+ /home/paolo/lisp/tools/foo.x86f written.
+ Compilation finished in 0:00:00.
+ #p"/home/paolo/lisp/tools/foo.x86f"
+ NIL
+ NIL
+But when the function is called with a logical pathname, the file type
+becomes FASL:
+ * (compile-file "tools:foo")
+ Python version 1.0, VM version Intel x86 on 27 FEB 0 06:01:04 pm.
+ Compiling: /home/paolo/lisp/tools/foo.lisp 27 FEB 0 05:57:42 pm
+ Converted SQUARE.
+ Compiling DEFUN SQUARE:
+ Byte Compiling Top-Level Form:
+ TOOLS:FOO.FASL written.
+ Compilation finished in 0:00:00.
+ #p"/home/paolo/lisp/tools/foo.fasl"
+ NIL
+ NIL
+
+* from DTC on the CMU CL mailing list 25 Feb 2000:
+;;; Compiler fails when this file is compiled.
+;;;
+;;; Problem shows up in delete-block within ir1util.lisp. The assertion
+;;; (assert (member (functional-kind lambda) '(:let :mv-let :assignment)))
+;;; fails within bind node branch.
+;;;
+;;; Note that if c::*check-consistency* is enabled then an un-reached
+;;; entry is also reported.
+;;;
+(defun foo (val)
+ (declare (values nil))
+ nil)
+(defun bug (val)
+ (multiple-value-call
+ #'(lambda (res)
+ (block nil
+ (tagbody
+ loop
+ (when res
+ (return nil))
+ (go loop))))
+ (foo val))
+ (catch 'ccc1
+ (throw 'ccc1
+ (block bbbb
+ (tagbody
+
+ (let ((ttt #'(lambda () (go cccc))))
+ (declare (special ttt))
+ (return-from bbbb nil))
+
+ cccc
+ (return-from bbbb nil))))))
+
+* (I *think* this is a bug. It certainly seems like strange behavior. But
+ the ANSI spec is scary, dark, and deep..)
+ (FORMAT NIL "~,1G" 1.4) => "1. "
+ (FORMAT NIL "~3,1G" 1.4) => "1. "
+
+* from Marco Antoniotti on cmucl-imp mailing list 1 Mar 2000:
+ (defclass ccc () ())
+ (setf (find-class 'ccc1) (find-class 'ccc))
+ (defmethod zut ((c ccc1)) 123)
+ DTC's recommended workaround from the mailing list 3 Mar 2000:
+ (setf (pcl::find-class 'ccc1) (pcl::find-class 'ccc))
+
+* There's probably a bug in the compiler handling of special variables
+ in closures, inherited from the CMU CL code, as reported on the
+ CMU CL mailing list. There's a patch for this on the CMU CL
+ mailing list too:
+ Message-ID: <38C8E188.A1E38B5E@jeack.com.au>
+ Date: Fri, 10 Mar 2000 22:50:32 +1100
+ From: "Douglas T. Crosher" <dtc@jeack.com.au>
+
+* The ANSI spec, in section "22.3.5.2 Tilde Less-Than-Sign: Logical Block",
+ says that an error is signalled if ~W, ~_, ~<...~:>, ~I, or ~:T is used
+ inside "~<..~>" (without the colon modifier on the closing syntax).
+ However, SBCL doesn't do this:
+ * (FORMAT T "~<munge~wegnum~>" 12)
+ munge12egnum
+ NIL
+
+* 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.
+
+* Right now, when COMPILE-FILE has a read error, it actually pops
+ you into the debugger before giving up on the file. It should
+ instead handle the error, perhaps issuing (and handling)
+ a secondary error "caught ERROR: unrecoverable error during compilation"
+ and then return with FAILURE-P true,
+
+* The print system doesn't conform to ANSI
+ "22.1.3.3.1 Package Prefixes for Symbols" for keywords printed when
+ *PACKAGE* is the KEYWORD package.
+
+ from a message by Ray Toy on CMU CL mailing list Fri, 28 Apr 2000:
+
+In a discussion on comp.lang.lisp, the following code was given (by
+Erik Naggum):
+
+(let ((*package* (find-package :keyword)))
+ (write-to-string object :readably t))
+
+If OBJECT is a keyword, CMUCL prints out the keyword, but without a
+colon. Hence, it's not readable, as requested.
+
+I think the following patch will make this work as expected. The
+patch just basically checks for the keyword package first before
+checking the current package.
+
+Ray
+
+--- ../cmucl-18c/src/code/print.lisp Wed Dec 8 14:33:47 1999
++++ ../cmucl-18c/new/code/print.lisp Fri Apr 28 09:21:29 2000
+@@ -605,12 +605,12 @@
+ (let ((package (symbol-package object))
+ (name (symbol-name object)))
+ (cond
+- ;; If the symbol's home package is the current one, then a
+- ;; prefix is never necessary.
+- ((eq package *package*))
+ ;; If the symbol is in the keyword package, output a colon.
+ ((eq package *keyword-package*)
+ (write-char #\: stream))
++ ;; If the symbol's home package is the current one, then a
++ ;; prefix is never necessary.
++ ((eq package *package*))
+ ;; Uninterned symbols print with a leading #:.
+ ((null package)
+ (when (or *print-gensym* *print-readably*)
+
+* from CMU CL mailing list 01 May 2000
+
+I realize I can take care of this by doing (proclaim (ignore pcl::.slots1.))
+but seeing as .slots0. is not-exported, shouldn't it be ignored within the
++expansion
+when not used?
+
+In: DEFMETHOD FOO-BAR-BAZ (RESOURCE-TYPE)
+ (DEFMETHOD FOO-BAR-BAZ
+ ((SELF RESOURCE-TYPE))
+ (SETF (SLOT-VALUE SELF 'NAME) 3))
+--> BLOCK MACROLET PCL::FAST-LEXICAL-METHOD-FUNCTIONS
+--> PCL::BIND-FAST-LEXICAL-METHOD-MACROS MACROLET
+--> PCL::BIND-LEXICAL-METHOD-FUNCTIONS LET PCL::BIND-ARGS LET* PCL::PV-BINDING
+--> PCL::PV-BINDING1 PCL::PV-ENV LET
+==>
+ (LET ((PCL::.SLOTS0. #))
+ (PROGN SELF)
+ (BLOCK FOO-BAR-BAZ
+ (LET #
+ #)))
+Warning: Variable PCL::.SLOTS0. defined but never used.
+
+Compilation unit finished.
+ 1 warning
+
+#<Standard-Method FOO-BAR-BAZ (RESOURCE-TYPE) {480918FD}>
+
+* 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.
+
+* Sometimes (SB-EXT:QUIT) fails with
+ Argh! maximum interrupt nesting depth (4096) exceeded, exiting
+ Process inferior-lisp exited abnormally with code 1
+ I haven't noticed a repeatable case of this yet.
+
+* The system accepts DECLAIM in most places where DECLARE would be
+ accepted, without even issuing a warning. ANSI allows this, but since
+ it's fairly easy to mistype DECLAIM instead of DECLARE, and the
+ meaning is rather different, and it's unlikely that the user
+ has a good reason for doing DECLAIM not at top level, it would be
+ good to issue a STYLE-WARNING when this happens. A possible
+ fix would be to issue STYLE-WARNINGs for DECLAIMs not at top level,
+ or perhaps to issue STYLE-WARNINGs for any EVAL-WHEN not at top level.
+
+* There seems to be some sort of bug in the interaction of the
+ normal compiler, the byte compiler, and type predicates.
+ Compiling and loading this file
+ (IN-PACKAGE :CL-USER)
+ (DEFSTRUCT FOO A B)
+ (PROGN
+ (DECLAIM (FTYPE (FUNCTION (FOO) FOO) FOO-BAR))
+ (DECLAIM (INLINE FOO-BAR))
+ (DEFUN FOO-BAR (FOO)
+ (DECLARE (TYPE FOO FOO))
+ (LET ((RESULT2605 (BLOCK FOO-BAR (PROGN (THE FOO (FOO-A FOO))))))
+ (UNLESS (TYPEP RESULT2605 'FOO)
+ (LOCALLY (ERROR "OOPS")))
+ (THE FOO RESULT2605)))
+ 'FOO-BAR)
+ (DEFPARAMETER *FOO* (MAKE-FOO :A (MAKE-FOO)))
+ (UNLESS (EQ *PRINT-LEVEL* 133)
+ (DEFUN CK? ()
+ (LABELS ((FLOOD ()
+ (WHEN (TYPEP *X* 'FOO)
+ (FOO-BAR *Y*))))))
+ (PRINT 11)
+ (PRINT (FOO-BAR *FOO*))
+ (PRINT 12))
+ in sbcl-0.6.5 (or also in CMU CL 18b for FreeBSD) gives a call
+ to the undefined function SB-C::%INSTANCE-TYPEP. %INSTANCE-TYPEP
+ is not defined as a function because it's supposed to
+ be transformed away. My guess is what's happening is that
+ the mixture of toplevel and non-toplevel stuff and inlining
+ is confusing the system into compiling an %INSTANCE-TYPEP
+ form into byte code, where the DEFTRANSFORM which is supposed
+ to get rid of such forms is not effective.
+
+* some sort of bug in inlining and RETURN-FROM in sbcl-0.6.5: Compiling
+ (DEFUN BAR? (X)
+ (OR (NAR? X)
+ (BLOCK USED-BY-SOME-Y?
+ (FLET ((FROB (STK)
+ (DOLIST (Y STK)
+ (UNLESS (REJECTED? Y)
+ (RETURN-FROM USED-BY-SOME-Y? T)))))
+ (DECLARE (INLINE FROB))
+ (FROB (RSTK X))
+ (FROB (MRSTK X)))
+ NIL)))
+ gives
+ error in function SB-KERNEL:ASSERT-ERROR:
+ The assertion (EQ (SB-C::CONTINUATION-KIND SB-C::CONT) :BLOCK-START) failed.
+
+* The CMU CL reader code takes liberties in binding the standard read table
+ when reading the names of characters. Tim Moore posted a patch to the
+ CMU CL mailing list Mon, 22 May 2000 21:30:41 -0700.
+
+* In some cases the compiler believes type declarations on array
+ elements without checking them, e.g.
+ (DECLAIM (OPTIMIZE (SAFETY 3) (SPEED 1) (SPACE 1)))
+ (DEFSTRUCT FOO A B)
+ (DEFUN BAR (X)
+ (DECLARE (TYPE (SIMPLE-ARRAY CONS 1) X))
+ (WHEN (CONSP (AREF X 0))
+ (PRINT (AREF X 0))))
+ (BAR (VECTOR (MAKE-FOO :A 11 :B 12)))
+ prints
+ #S(FOO :A 11 :B 12)
+ in SBCL 0.6.5 (and also in CMU CL 18b). This does not happen for
+ all cases, e.g. the type assumption *is* checked if the array
+ elements are declared to be of some structure type instead of CONS.
+
+* The printer doesn't report closures very well. This is true in
+ CMU CL 18b as well:
+ (PRINT #'CLASS-NAME)
+ gives
+ #<Closure Over Function "DEFUN STRUCTURE-SLOT-ACCESSOR" {134D1A1}>
+ It would be nice to make closures have a settable name slot,
+ and make things like DEFSTRUCT and FLET, which create closures,
+ set helpful values into this slot.
+
+* And as long as we're wishing, it would be awfully nice if INSPECT could
+ also report on closures, telling about the values of the bound variables.
+
+* as reported by Robert Strandh on the CMU CL mailing list 12 Jun 2000:
+ $ cat xx.lisp
+ (defconstant +a-constant+ (make-instance 'a-class))
+ (defconstant +another-constant+ (vector +a-constant+))
+ $ lisp
+ CMU Common Lisp release x86-linux 2.4.19 8 February 2000 build 456,
+ running on
+ bobby
+ Send bug reports and questions to your local CMU CL maintainer,
+ or to pvaneynd@debian.org
+ or to cmucl-help@cons.org. (prefered)
+ type (help) for help, (quit) to exit, and (demo) to see the demos
+ Loaded subsystems:
+ Python 1.0, target Intel x86
+ CLOS based on PCL version: September 16 92 PCL (f)
+ * (defclass a-class () ())
+ #<STANDARD-CLASS A-CLASS {48027BD5}>
+ * (compile-file "xx.lisp")
+ Python version 1.0, VM version Intel x86 on 12 JUN 00 08:12:55 am.
+ Compiling:
+ /home/strandh/Research/Functional/Common-Lisp/CLIM/Development/McCLIM
+ /xx.lisp 12 JUN 00 07:47:14 am
+ Compiling Load Time Value of (PCL::GET-MAKE-INSTANCE-FUNCTION-SYMBOL
+ '(A-CLASS NIL NIL)):
+ Byte Compiling Top-Level Form:
+ Error in function C::DUMP-STRUCTURE: Attempt to dump invalid
+ structure:
+ #<A-CLASS {4803A5B5}>
+ How did this happen?
+
+* The compiler assumes that any time a function of declared FTYPE
+ doesn't signal an error, its arguments were of the declared type.
+ E.g. compiling and loading
+ (DECLAIM (OPTIMIZE (SAFETY 3)))
+ (DEFUN FACTORIAL (X) (GAMMA (1+ X)))
+ (DECLAIM (FTYPE (FUNCTION (UNSIGNED-BYTE) FACTORIAL)))
+ (DEFUN FOO (X)
+ (COND ((> (FACTORIAL X) 1.0E6)
+ (FORMAT T "too big~%"))
+ ((INTEGERP X)
+ (FORMAT T "exactly ~S~%" (FACTORIAL X)))
+ (T
+ (FORMAT T "approximately ~S~%" (FACTORIAL X)))))
+ then executing
+ (FOO 1.5)
+ will cause the INTEGERP case to be selected, giving bogus output a la
+ exactly 1.33..
+ This violates the "declarations are assertions" principle.
+ According to the ANSI spec, in the section "System Class FUNCTION",
+ this is a case of "lying to the compiler", but the lying is done
+ by the code which calls FACTORIAL with non-UNSIGNED-BYTE arguments,
+ not by the unexpectedly general definition of FACTORIAL. In any case,
+ "declarations are assertions" means that lying to the compiler should
+ cause an error to be signalled, and should not cause a bogus
+ result to be returned. Thus, the compiler should not assume
+ 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.)
+
+* As pointed out by Martin Cracauer on the CMU CL mailing list
+ 13 Jun 2000, the :FILE-LENGTH operation for
+ FD-STREAM-MISC-ROUTINE is broken for large files: it says
+ (THE INDEX SIZE) even though SIZE can be larger than INDEX.
+
+* In SBCL 0.6.5 (and CMU CL 18b) compiling and loading
+ (in-package :cl-user)
+ (declaim (optimize (safety 3)
+ (debug 3)
+ (compilation-speed 2)
+ (space 1)
+ (speed 2)
+ #+nil (sb-ext:inhibit-warnings 2)))
+ (declaim (ftype (function * (values)) emptyvalues))
+ (defun emptyvalues (&rest rest) (declare (ignore rest)) (values))
+ (defstruct foo x y)
+ (defgeneric assertoid ((x t)))
+ (defmethod assertoid ((x t)) "just a placeholder")
+ (defun bar (ht)
+ (declare (type hash-table ht))
+ (let ((res
+ (block blockname
+ (progn
+ (prog1
+ (emptyvalues)
+ (assertoid (hash-table-count ht)))))))
+ (unless (typep res 'foo)
+ (locally
+ (common-lisp-user::bad-result-from-assertive-typed-fun
+ 'bar
+ res)))))
+ then executing
+ (bar (make-hash-table))
+ causes the failure
+ Error in KERNEL::UNDEFINED-SYMBOL-ERROR-HANDLER:
+ the function C::%INSTANCE-TYPEP is undefined.
+ %INSTANCE-TYPEP is always supposed to be IR1-transformed away, but for
+ some reason -- the (VALUES) return value declaration? -- the optimizer is
+ confused and compiles a full call to %INSTANCE-TYPEP (which doesn't exist
+ as a function) instead.
+
+* DEFMETHOD doesn't check the syntax of &REST argument lists properly,
+ accepting &REST even when it's not followed by an argument name:
+ (DEFMETHOD FOO ((X T) &REST) NIL)
+
+* On the CMU CL mailing list 26 June 2000, Douglas Crosher wrote
+
+ Hannu Rummukainen wrote:
+ ...
+ > There's something weird going on with the compilation of the attached
+ > code. Compiling and loading the file in a fresh lisp, then invoking
+ > (test-it) gives
+ Thanks for the bug report, nice to have this one fixed. It was a bug
+ in the x86 backend, the < VOP. A fix has been committed to the main
+ source, see the file compiler/x86/float.lisp.
+
+ Probably the same bug exists in SBCL.
+
+* TYPEP treats the result of UPGRADED-ARRAY-ELEMENT-TYPE as gospel,
+ so that (TYPEP (MAKE-ARRAY 3) '(VECTOR SOMETHING-NOT-DEFINED-YET))
+ returns (VALUES T T). Probably it should be an error instead,
+ complaining that the type SOMETHING-NOT-DEFINED-YET is not defined.
+
+* TYPEP of VALUES types is sometimes implemented very inefficiently, e.g. in
+ (DEFTYPE INDEXOID () '(INTEGER 0 1000))
+ (DEFUN FOO (X)
+ (DECLARE (TYPE INDEXOID X))
+ (THE (VALUES INDEXOID)
+ (VALUES X)))
+ where the implementation of the type check in function FOO
+ includes a full call to %TYPEP. There are also some fundamental problems
+ with the interpretation of VALUES types (inherited from CMU CL, and
+ from the ANSI CL standard) as discussed on the cmucl-imp@cons.org
+ mailing list, e.g. in Robert Maclachlan's post of 21 Jun 2000.
+
+* The definitions of SIGCONTEXT-FLOAT-REGISTER and
+ %SET-SIGCONTEXT-FLOAT-REGISTER in x86-vm.lisp say they're not
+ supported on FreeBSD because the floating point state is not saved,
+ but at least as of FreeBSD 4.0, the floating point state *is* saved,
+ so they could be supported after all. Very likely
+ SIGCONTEXT-FLOATING-POINT-MODES could now be supported, too.
+
+* (as discussed by Douglas Crosher on the cmucl-imp mailing list ca.
+ Aug. 10, 2000): CMUCL currently interprets 'member as '(member); same issue
+ with 'union, 'and, 'or etc. So even though according to the ANSI spec,
+ bare 'MEMBER, 'AND, and 'OR are not legal types, CMUCL (and now
+ SBCL) interpret them as legal types.
+
+* ANSI specifies DEFINE-SYMBOL-MACRO, but it's not defined in SBCL.
+ CMU CL added it ca. Aug 13, 2000, after some discussion on the mailing
+ list, and it is probably possible to use substantially the same
+ patches to add it to SBCL.
+
+* a slew of floating-point-related errors reported by Peter Van Eynde
+ on July 25, 2000:
+ * (SQRT -9.0) fails, because SB-KERNEL::COMPLEX-SQRT is undefined.
+ Similarly, COMPLEX-ASIN, COMPLEX-ACOS, COMPLEX-ACOSH, and others
+ aren't found.
+ * SBCL's value for LEAST-POSITIVE-SHORT-FLOAT is bogus, and
+ should probably be 1.4012985e-45. In SBCL,
+ (/ LEAST-POSITIVE-SHORT-FLOAT 2) returns a number smaller
+ than LEAST-POSITIVE-SHORT-FLOAT. Similar problems
+ exist for LEAST-NEGATIVE-SHORT-FLOAT, LEAST-POSITIVE-LONG-FLOAT,
+ and LEAST-NEGATIVE-LONG-FLOAT.
+ * Many expressions generate floating infinity:
+ (/ 1 0.0)
+ (/ 1 0.0d0)
+ (EXPT 10.0 1000)
+ (EXPT 10.0d0 1000)
+ PVE's regression tests want them to raise errors. SBCL
+ generates the infinities instead, which may or may not be
+ conforming behavior, but then blow it by being unable to
+ output the infinities, since support for infinities is generally
+ broken, and in particular SB-IMPL::OUTPUT-FLOAT-INFINITY is
+ undefined.
+ * (in section12.erg) various forms a la
+ (FLOAT 1 DOUBLE-FLOAT-EPSILON) don't give the right behavior.
+
+* type safety errors reported by Peter Van Eynde July 25, 2000:
+ * (COERCE (QUOTE (A B C)) (QUOTE (VECTOR * 4)))
+ => #(A B C)
+ In general lengths of array type specifications aren't
+ checked by COERCE, so it fails when the spec is
+ (VECTOR 4), (STRING 2), (SIMPLE-BIT-VECTOR 3), or whatever.
+ * CONCATENATE has the same problem of not checking the length
+ of specified output array types. MAKE-SEQUENCE and MAP and
+ MERGE also have the same problem.
+ * (COERCE 'AND 'FUNCTION) returns something related to
+ (MACRO-FUNCTION 'AND), but ANSI says it should raise an error.
+ * ELT signals SIMPLE-ERROR if its index argument
+ isn't a valid index for its sequence argument, but should
+ signal TYPE-ERROR instead.
+ * FILE-LENGTH is supposed to signal a type error when its
+ argument is not a stream associated with a file, but doesn't.
+ * (FLOAT-RADIX 2/3) should signal an error instead of
+ returning 2.
+ * (LOAD "*.lsp") should signal FILE-ERROR.
+ * (MAKE-CONCATENATED-STREAM (MAKE-STRING-OUTPUT-STREAM))
+ should signal TYPE-ERROR.
+ * MAKE-TWO-WAY-STREAM doesn't check that its arguments can
+ be used for input and output as needed. It should fail with
+ TYPE-ERROR when handed e.g. the results of MAKE-STRING-INPUT-STREAM
+ or MAKE-STRING-OUTPUT-STREAM in the inappropriate positions,
+ but doesn't.
+ * (PARSE-NAMESTRING (COERCE (LIST #\f #\o #\o (CODE-CHAR 0) #\4 #\8)
+ (QUOTE STRING)))
+ should probably signal an error instead of making a pathname with
+ a null byte in it.
+ * READ-BYTE is supposed to signal TYPE-ERROR when its argument is
+ not a binary input stream, but instead cheerfully reads from
+ character streams, e.g. (MAKE-STRING-INPUT-STREAM "abc").
+
+* DEFCLASS bugs reported by Peter Van Eynde July 25, 2000:
+ * (DEFCLASS FOO () (A B A)) should signal a PROGRAM-ERROR, and doesn't.
+ * (DEFCLASS FOO () (A B A) (:DEFAULT-INITARGS X A X B)) should
+ signal a PROGRAM-ERROR, and doesn't.
+ * (DEFCLASS FOO07 NIL ((A :ALLOCATION :CLASS :ALLOCATION :CLASS))),
+ and other DEFCLASS forms with duplicate specifications in their
+ slots, should signal a PROGRAM-ERROR, and doesn't.
+ * (DEFGENERIC IF (X)) should signal a PROGRAM-ERROR, but instead
+ causes a COMPILER-ERROR.
+
+* SYMBOL-MACROLET bugs reported by Peter Van Eynde July 25, 2000:
+ * (SYMBOL-MACROLET ((T TRUE)) ..) should probably signal
+ PROGRAM-ERROR, but SBCL accepts it instead.
+ * SYMBOL-MACROLET should refuse to bind something which is
+ declared as a global variable, signalling PROGRAM-ERROR.
+ * SYMBOL-MACROLET should signal PROGRAM-ERROR if something
+ it binds is declared SPECIAL inside.
+
+* LOOP bugs reported by Peter Van Eynde July 25, 2000:
+ * (LOOP WITH (A B) DO (PRINT 1)) is a syntax error according to
+ the definition of WITH clauses given in the ANSI spec, but
+ compiles and runs happily in SBCL.
+ * a messy one involving package iteration:
+interpreted Form: (LET ((PACKAGE (MAKE-PACKAGE "LOOP-TEST"))) (INTERN "blah" PACKAGE) (LET ((BLAH2 (INTERN "blah2" PACKAGE))) (EXPORT BLAH2 PACKAGE)) (LIST (SORT (LOOP FOR SYM BEING EACH PRESENT-SYMBOL OF PACKAGE FOR SYM-NAME = (SYMBOL-NAME SYM) COLLECT SYM-NAME) (FUNCTION STRING<)) (SORT (LOOP FOR SYM BEING EACH EXTERNAL-SYMBOL OF PACKAGE FOR SYM-NAME = (SYMBOL-NAME SYM) COLLECT SYM-NAME) (FUNCTION STRING<))))
+Should be: (("blah" "blah2") ("blah2"))
+SBCL: (("blah") ("blah2"))
+ * (LET ((X 1)) (LOOP FOR I BY (INCF X) FROM X TO 10 COLLECT I))
+ doesn't work -- SBCL's LOOP says BY isn't allowed in a FOR clause.
+
+* type system errors reported by Peter Van Eynde July 25, 2000:
+ * (SUBTYPEP 'BIGNUM 'INTEGER) => NIL, NIL
+ but should be (VALUES T T) instead.
+ * (SUBTYPEP 'EXTENDED-CHAR 'CHARACTER) => NIL, NIL
+ but should be (VALUES T T) instead.
+ * (SUBTYPEP '(INTEGER (0) (0)) 'NIL) dies with nested errors.
+ * In general, the system doesn't like '(INTEGER (0) (0)) -- it
+ blows up at the level of SPECIFIER-TYPE with
+ "Lower bound (0) is greater than upper bound (0)." Probably
+ SPECIFIER-TYPE should return NIL instead.
+ * (TYPEP 0 '(COMPLEX (EQL 0)) fails with
+ "Component type for Complex is not numeric: (EQL 0)."
+ This might be easy to fix; the type system already knows
+ that (SUBTYPEP '(EQL 0) 'NUMBER) is true.
+ * The type system doesn't know about the condition system,
+ so that e.g. (TYPEP 'SIMPLE-ERROR 'ERROR)=>NIL.
+ * The type system isn't all that smart about relationships
+ between hairy types, as shown in the type.erg test results,
+ e.g. (SUBTYPEP 'CONS '(NOT ATOM)) => NIL, NIL.
+
+* miscellaneous errors reported by Peter Van Eynde July 25, 2000:
+ * (PROGN
+ (DEFGENERIC FOO02 (X))
+ (DEFMETHOD FOO02 ((X NUMBER)) T)
+ (LET ((M (FIND-METHOD (FUNCTION FOO02)
+ NIL
+ (LIST (FIND-CLASS (QUOTE NUMBER))))))
+ (REMOVE-METHOD (FUNCTION FOO02) M)
+ (DEFGENERIC FOO03 (X))
+ (ADD-METHOD (FUNCTION FOO03) M)))
+ should give an error, but SBCL allows it.
+ * READ should probably return READER-ERROR, not the bare
+ arithmetic error, when input a la "1/0" or "1e1000" causes
+ an arithmetic error.
+ * There are several metaobject protocol "errors". (In order to fix
+ them, we might need to document exactly what metaobject
+ protocol specification we're following -- the current code is
+ just inherited from PCL.)
+ * (BUTLAST NIL) should return NIL. (This appears to be a compiler
+ bug, since the definition of BUTLAST, when interpreted, does
+ give (BUTLAST NIL)=>NIL.)
+
+* another error from Peter Van Eynde 5 September 2000:
+ (FORMAT NIL "~F" "FOO") should work, but instead reports an error.
+ PVE submitted a patch to deal with this bug, but it exposes other
+ comparably serious bugs, so I didn't apply it. It looks as though
+ the FORMAT code needs a fair amount of rewriting in order to comply
+ with the various details of the ANSI spec.
+
+* The bug discussed on the cmucl-imp@cons.org mailing list ca. 5 September,
+ simplified by Douglas Crosher down to
+ (defun tickle-bug ()
+ (labels ((fun1 ()
+ (fun2))
+ (fun2 ()
+ (when nil
+ (tagbody
+ tag
+ (fun2)
+ (go tag)))
+ (when nil
+ (tagbody
+ tag
+ (fun1)
+ (go tag)))))
+ (fun1)
+ nil))
+ causes the same problem on SBCL: compiling it fails with
+ :LET fell through ECASE expression.
+ Very likely the patch discussed there is appropriate for SBCL
+ as well, but I don't understand it, so I didn't apply it.
--- /dev/null
+SBCL is derived from CMU CL, which was released into the public
+domain, subject only to the BSD-style "free, but credit must be given
+and copyright notices must be retained" licenses in the LOOP macro
+(from MIT and Symbolics) and in the PCL implementation of CLOS (from
+Xerox).
+
+After CMU CL was was released into the public domain, it was
+maintained by volunteers, who continued the tradition of releasing
+their work into the public domain.
+
+All changes to SBCL since the fork from CMU CL have been released
+into the public domain.
+
+Thus, there are no known obstacles to copying, using, and modifying
+SBCL freely, as long as the MIT, Symbolics, and Xerox copyright
+notices are retained.
--- /dev/null
+
+ The programmers of old were mysterious and profound. We
+ cannot fathom their thoughts, so all we do is describe their
+ appearance.
+ Aware, like a fox crossing the water. Alert, like a general
+ on the battlefield. Kind, like a hostess greeting her guests.
+ Simple, like uncarved blocks of wood. Opaque, like black
+ pools in darkened caves.
+ Who can tell the secrets of their hearts and minds?
+ The answer exists only in the Tao.
+ -- Geoffrey James, "The Tao of Programming"
+
+
+BROAD OUTLINE
+
+SBCL is derived from the 18b version of CMU CL.
+
+Most of CMU CL was originally written as part of the CMU Common Lisp
+project at Carnegie Mellon University. According to the documentation
+in CMU CL 18b,
+ Organizationally, CMU Common Lisp was a small, mostly autonomous
+ part within the Mach operating system project. The CMU CL project
+ was more of a tool development effort than a research project.
+ The project started out as Spice Lisp, which provided a modern
+ Lisp implementation for use in the CMU community.
+and
+ CMU CL has been under continuous development since the early 1980's
+ (concurrent with the Common Lisp standardization effort.)
+Apparently most of the CMU Common Lisp implementors moved on to
+work on the Gwydion environment for Dylan.
+
+CMU CL's CLOS implementation is derived from the PCL reference
+implementation written at Xerox PARC.
+
+CMU CL's implementation of the LOOP macro was derived from code
+from Symbolics, which was derived from code from MIT.
+
+CMU CL had many individual author credits in the source files. In the
+sometimes-extensive rearrangements which were required to make SBCL
+bootstrap itself cleanly, it was tedious to try keep such credits
+attached to individual source files, so they have been moved here
+instead.
+
+William Harold Newman <william.newman@airmail.net> did this
+transformation, and so any errors made are probably his. Corrections
+would be appreciated.
+
+
+MORE DETAILS ON SBCL'S CLOS CODE
+
+The original headers of the PCL files contained the following text:
+
+;;; Any person obtaining a copy of this software is requested to send their
+;;; name and post office or electronic mail address to:
+;;; CommonLoops Coordinator
+;;; Xerox PARC
+;;; 3333 Coyote Hill Rd.
+;;; Palo Alto, CA 94304
+;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
+;;;
+;;; Suggestions, comments and requests for improvements are also welcome.
+
+This was intended for the original incarnation of the PCL code as a
+portable reference implementation. Since our version of the code has
+had its portability hacked out of it, it's no longer particularly
+relevant to any coordinated PCL effort (which probably doesn't exist
+any more anyway). Therefore, this contact information has been deleted
+from the PCL file headers.
+
+A few files in the original CMU CL 18b src/pcl/ directory did not
+carry such Xerox copyright notices:
+ * Some code was originally written by Douglas T. Crosher for CMU CL:
+ ** the Gray streams implementation
+ ** the implementation of DOCUMENTATION as methods of a generic
+ function
+ * generic-functions.lisp seems to have been machine-generated.
+
+The comments in the CMU CL 18b version of the PCL code walker,
+src/pcl/walk.lisp, said in part
+;;; a simple code walker, based IN PART on: (roll the credits)
+;;; Larry Masinter's Masterscope
+;;; Moon's Common Lisp code walker
+;;; Gary Drescher's code walker
+;;; Larry Masinter's simple code walker
+;;; .
+;;; .
+;;; boy, thats fair (I hope).
+
+
+MORE DETAILS ON SBCL'S LOOP CODE
+
+The src/code/loop.lisp file from CMU CL 18b had the following
+credits-related information in it:
+
+;;; The LOOP iteration macro is one of a number of pieces of code
+;;; originally developed at MIT for which free distribution has been
+;;; permitted, as long as the code is not sold for profit, and as long
+;;; as notification of MIT's interest in the code is preserved.
+;;;
+;;; This version of LOOP, which is almost entirely rewritten both as
+;;; clean-up and to conform with the ANSI Lisp LOOP standard, started
+;;; life as MIT LOOP version 829 (which was a part of NIL, possibly
+;;; never released).
+;;;
+;;; A "light revision" was performed by me (Glenn Burke) while at
+;;; Palladian Software in April 1986, to make the code run in Common
+;;; Lisp. This revision was informally distributed to a number of
+;;; people, and was sort of the "MIT" version of LOOP for running in
+;;; Common Lisp.
+;;;
+;;; A later more drastic revision was performed at Palladian perhaps a
+;;; year later. This version was more thoroughly Common Lisp in style,
+;;; with a few miscellaneous internal improvements and extensions. I
+;;; have lost track of this source, apparently never having moved it to
+;;; the MIT distribution point. I do not remember if it was ever
+;;; distributed.
+;;;
+;;; The revision for the ANSI standard is based on the code of my April
+;;; 1986 version, with almost everything redesigned and/or rewritten.
+
+The date of the M.I.T. copyright statement falls around the time
+described in these comments. The dates on the Symbolics copyright
+statement are all later -- the earliest is 1989.
+
+
+MORE DETAILS ON OTHER SBCL CODE FROM CMU CL
+
+CMU CL's symbol (but not package) code (code/symbol.lisp) was
+originally written by Scott Fahlman and updated and maintained
+by Skef Wholey.
+
+The CMU CL reader (code/reader.lisp) was originally the Spice Lisp
+reader, written by David Dill and with support for packages added by
+Lee Schumacher. David Dill also wrote the sharpmacro support
+(code/sharpm.lisp).
+
+CMU CL's package code was rewritten by Rob MacLachlan based on an
+earlier version by Lee Schumacher. It also includes DEFPACKAGE by Dan
+Zigmond, and WITH-PACKAGE-ITERATOR written by Blaine Burks. William
+Lott also rewrote the DEFPACKAGE and DO-FOO-SYMBOLS stuff.
+
+CMU CL's string code (code/string.lisp) was originally written by
+David Dill, then rewritten by Skef Wholey, Bill Chiles, and Rob
+MacLachlan.
+
+Various code in the system originated with "Spice Lisp", which was
+apparently a predecessor to the CMU CL project. Much of that was
+originally written by Skef Wholey:
+ code/seq.lisp, generic sequence functions, and COERCE
+ code/array.lisp, general array stuff
+ SXHASH
+ code/list.lisp, list functions (based on code from Joe Ginder and
+ Carl Ebeling)
+The CMU CL seq.lisp code also gave credits for later work by Jim Muller
+and Bill Chiles.
+
+The modules system (code/module.lisp, containing REQUIRE, PROVIDE,
+and friends, now deprecated by ANSI) was written by Jim Muller and
+rewritten by Bill Chiles.
+
+The CMU CL garbage collector was credited to "Christopher Hoover,
+Rob MacLachlan, Dave McDonald, et al." in the CMU CL code/gc.lisp file,
+with some extra code for the MIPS port credited to Christopher Hoover
+alone.
+
+Guy Steele wrote the original character functions
+ code/char.lisp
+They were subsequently rewritten by David Dill, speeded up by Scott Fahlman,
+and rewritten without fonts and with a new type system by Rob MachLachlan.
+
+Lee Schumacher made the Spice Lisp version of backquote. The comment
+in the CMU CL sources suggests he based it on someone else's code for
+some other Lisp system, but doesn't say which. A note in the CMU CL
+code to pretty-print backquote expressions says that unparsing support
+was provided by Miles Bader.
+
+The CMU implementations of the Common Lisp query functions Y-OR-N-P
+and YES-OR-NO-P were originally written by Walter van Roggen, and
+updated and modified by Rob MacLachlan and Bill Chiles.
+
+The CMU CL sort functions (code/sort.lisp) were written by Jim Large,
+hacked on and maintained by Skef Wholey, and rewritten by Bill Chiles.
+
+Most of the internals of the Python compiler seem to have been
+originally written by Robert MacLachlan:
+ the type system and associated "cold load hack magic"
+ code/typedefs.lisp
+ code/class.lisp
+ code/type-init.lisp
+ etc.
+ the lexical environment database
+ compiler/globaldb.lisp, etc.
+ the IR1 representation and optimizer
+ compiler/ir1*.lisp, etc.
+ the IR2 representation and optimizer
+ compiler/ir2*.lisp, etc.
+ many concrete optimizations
+ compiler/srctran.lisp (with some code adapted from
+ CLC by Wholey and Fahlman)
+ compiler/float-tran.lisp, etc.
+ information about optimization of known functions
+ compiler/fndb.lisp
+ debug information representation
+ compiler/debug.lisp, compiler/debug-dump.lisp
+ memory pools to reduce consing by reusing compiler objects
+ compiler/alloc.lisp
+ toplevel interface functions and drivers
+ compiler/main.lisp
+Besides writing the compiler, and various other work mentioned elsewhere,
+Robert MacLachlan was also credited with tuning the implementation of
+streams for Unix files, and writing
+ various floating point support code
+ code/float-trap.lisp, floating point traps
+ code/float.lisp, misc. support a la INTEGER-DECODE-FLOAT
+ low-level time functions
+ code/time.lisp
+
+William Lott is also credited with writing or heavily maintaining some
+parts of the CMU CL compiler. He was responsible for lifting
+compiler/meta-vmdef.lisp out of compiler/vmdef.lisp, and also wrote
+ various optimizations
+ compiler/array-tran.lisp
+ compiler/saptran.lisp
+ compiler/seqtran.lisp (with some code adapted from an older
+ seqtran written by Wholey and Fahlman)
+ the separable compiler backend
+ compiler/backend.lisp
+ compiler/generic/utils.lisp
+ the implementation of LOAD-TIME-VALUE
+ compiler/ltv.lisp
+ the most recent version of the assembler
+ compiler/new-assem.lisp
+ vop statistics gathering
+ compiler/statcount.lisp
+ centralized information about machine-dependent and..
+ ..machine-independent FOO, with
+ compiler/generic/vm-fndb.lisp, FOO=function signatures
+ compiler/generic/vm-typetran.lisp, FOO=type ops
+ compiler/generic/objdef.lisp, FOO=object representation
+ compiler/generic/primtype.lisp, FOO=primitive types
+Also, Christopher Hoover and William Lott wrote compiler/generic/vm-macs.lisp
+to centralize information about machine-dependent macros and constants.
+
+Sean Hallgren converted compiler/generic/primtype.lisp for the Alpha.
+
+The CMU CL machine-independent disassembler (compiler/disassem.lisp)
+was written by Miles Bader.
+
+Parts of the CMU CL system were credited to Skef Wholey and Rob
+MacLachlan jointly, perhaps because they were originally part of Spice
+Lisp and were then heavily modified:
+ code/load.lisp, the loader, including all the FASL stuff
+ code/macros.lisp, various fundamental macros
+ code/mipsstrops.lisp, primitives for hacking strings
+ code/purify.lisp, implementation of PURIFY
+ code/stream.lisp, stream functions
+ code/lispinit.lisp, cold startup
+ code/profile.lisp, the profiler
+
+Bill Chiles also modified code/macros.lisp. Much of the implementation
+of PURIFY was rewritten in C by William Lott.
+
+The CMU CL number functions (code/number.lisp) were written by Rob
+MacLachlan, but acknowledge much code "derived from code written by
+William Lott, Dave Mcdonald, Jim Large, Scott Fahlman, etc."
+
+CMU CL's weak pointer support (code/weak.lisp) was written by
+Christopher Hoover.
+
+The CMU CL DEFSTRUCT system was credited to Rob MacLachlan, William
+Lott and Skef Wholey jointly.
+
+The FDEFINITION system for handling arbitrary function names (a la
+(SETF FOO)) was originally written by Rob MacLachlan. It was modified
+by Bill Chiles to add encapsulation, and modified more by William Lott
+to add FDEFN objects.
+
+The CMU CL condition system (code/error.lisp) was based on
+some prototyping code written by Ken Pitman at Symbolics.
+
+The CMU CL HASH-TABLE system was originally written by Skef Wholey
+for Spice Lisp, then rewritten by William Lott, then rewritten
+again by Douglas T. Crosher.
+
+The support code for environment queries (a la LONG-SITE-NAME),
+the DOCUMENTATION function, and the DRIBBLE function was written
+and maintained "mostly by Skef Wholey and Rob MacLachlan. Scott
+Fahlman, Dan Aronson, and Steve Handerson did stuff here too."
+The same credit statement was given for the original Mach OS interface code.
+
+The CMU CL printer, print.lisp, was credited as "written by
+Neal Feinberg, Bill Maddox, Steven Handerson, and Skef Wholey, and
+modified by various CMU Common Lisp maintainers."
+
+The comments in the main body of the CMU CL debugger
+ code/debug.lisp
+say that it was written by Bill Chiles. Some other related files
+ code/debug-int.lisp, programmer's interface to the debugger
+ code/ntrace.lisp, tracing facility based on breakpoints
+say they were written by Bill Chiles and Rob MacLachlan.
+The related file
+ src/debug-vm.lisp, low-level support for :FUNCTION-END breakpoints
+was written by William Lott.
+
+The CMU CL GENESIS cold load system,
+compiler/generic/new-genesis.lisp, was originally written by Skef
+Wholey, then jazzed up for packages by Rob MacLachlan, then completely
+rewritten by William Lott for the MIPS port.
+
+The CMU CL IR1 interpreter was written by Bill Chiles and Robert
+MacLachlan.
+
+Various CMU CL support code was written by William Lott:
+ the bytecode interpreter
+ code/byte-interp.lisp
+ bitblt-ish operations a la SYSTEM-AREA-COPY
+ code/bit-bash.lisp
+ Unix interface
+ code/fd-stream.lisp, Unix file descriptors as Lisp streams
+ code/filesys.lisp, other Unix filesystem interface stuff
+ handling errors signalled from assembly code
+ code/interr.lisp
+ compiler/generic/interr.lisp
+ finalization based on weak pointers
+ code/final.lisp
+ irrational numeric functions
+ code/irrat.lisp
+ the pretty printer
+ code/pprint.lisp
+ predicates (both type predicates and EQUAL and friends)
+ code/pred.lisp
+ saving the current Lisp image as a core file
+ code/save.lisp
+ handling Unix signals
+ code/signal.lisp
+ implementing FORMAT
+ code/format.lisp
+
+The ALIEN facility seems to have been written largely by Rob
+MacLachlan and William Lott. The CMU CL comments say "rewritten again,
+this time by William Lott and Rob MacLachlan," but don't identify who
+else might have been involved in earlier versions.
+
+The comments in CMU CL's code/final.lisp say "the idea really was
+Chris Hoover's". The comments in CMU CL's code/pprint.lisp say "Algorithm
+stolen from Richard Waters' XP." The comments in CMU CL's code/format.lisp
+say "with lots of stuff stolen from the previous version by David Adam
+and later rewritten by Bill Maddox."
+
+Jim Muller was credited with fixing seq.lisp.
+
+CMU CL's time printing logic, in code/format-time.lisp, was written
+by Jim Healy.
+
+Bill Chiles was credited with fixing/updating seq.lisp after Jim Muller.
+
+The CMU CL machine/filesystem-independent pathname functions
+(code/pathname.lisp) were written by William Lott, Paul Gleichauf, and
+Rob MacLachlan, based on an earlier version written by Jim Large and
+Rob MacLachlan.
+
+Besides writing the original versions of the things credited to him
+above, William Lott rewrote, updated, and cleaned up various stuff:
+ code/array.lisp
+ code/serve-event.lisp
+
+The INSPECT function was originally written by Blaine Burks.
+
+The CMU CL DESCRIBE facility was originally written by "Skef Wholey or
+Rob MacLachlan", according to the comments in the CMU CL sources. It
+was cleaned up and reorganized by Blaine Burks, then ported and
+cleaned up more by Rob MacLachlan. Also, since the split from CMU CL,
+the SBCL DESCRIBE facility was rewritten as a generic function and so
+become entangled with some DESCRIBE code which was distributed as part
+of PCL.
+
+The implementation of the Mersenne Twister RNG used in SBCL is based
+on an implementation written by Douglas T. Crosher and Raymond Toy,
+which was placed in the public domain with permission from M.
+Matsumoto.
+
+Comments in the CMU CL version of FreeBSD-os.c said it came from
+an OSF version by Sean Hallgren, later hacked by Paul Werkowski,
+with generational conservative GC support added by Douglas Crosher.
+
+Comments in the CMU CL version of linux-os.c said it came from the
+FreeBSD-os.c version, morfed to Linux by Peter Van Eynde in July 1996.
+
+Comments in the CMU CL version of backtrace.c said it was "originally
+from Rob's version" (presumably Robert Maclachlan).
+
+Comments in the CMU CL version of purify.c said it had stack direction
+changes, x86/CGC stack scavenging, and static blue bag stuff (all for
+x86 port?) by Paul Werkowski, 1995, 1996; and bug fixes, x86 code
+movement support, and x86/gencgc stack scavenging by Douglas Crosher,
+1996, 1997, 1998.
+
+According to comments in the source files, much of the CMU CL version
+of the x86 support code
+ assembly/x86/alloc.lisp
+ assembly/x86/arith.lisp
+ assembly/x86/array.lisp
+ assembly/x86/assem-rtns.lisp
+ compiler/x86/alloc.lisp
+ compiler/x86/arith.lisp
+ compiler/x86/c-call.lisp
+ compiler/x86/call.lisp
+ compiler/x86/cell.lisp
+ compiler/x86/char.lisp
+ compiler/x86/debug.lisp
+ compiler/x86/float.lisp
+ compiler/x86/insts.lisp
+ compiler/x86/macros.lisp
+ compiler/x86/memory.lisp
+ compiler/x86/move.lisp
+ compiler/x86/nlx.lisp
+ compiler/x86/parms.lisp
+ compiler/x86/pred.lisp
+ compiler/x86/print.lisp
+ compiler/x86/sap.lisp
+ compiler/x86/static-fn.lisp
+ compiler/x86/subprim.lisp
+ compiler/x86/system.lisp
+ compiler/x86/type-vops.lisp
+ compiler/x86/values.lisp
+ compiler/x86/vm.lisp
+was originally written by William Lott, then debugged by Paul
+Werkowski, and in some cases later enhanced and further debugged by
+Douglas T. Crosher; and the x86 runtime support code,
+ x86-assem.S
+was written by Paul F. Werkowski and Douglas T. Crosher.
+
+The CMU CL user manual (doc/cmu-user/cmu-user.tex) says that the X86
+FreeBSD port was originally contributed by Paul Werkowski, and Peter
+VanEynde took the FreeBSD port and created a Linux version.
+
+According to comments in src/code/bsd-os.lisp, work on the generic BSD
+port was done by Skef Wholey, Rob MacLachlan, Scott Fahlman, Dan
+Aronson, and Steve Handerson.
+
+Douglas Crosher wrote code to support Gray streams, added X86 support
+for the debugger and relocatable code, wrote a conservative
+generational GC for the X86 port, and added X86-specific extensions to
+support stack groups and multiprocessing.
+
+The CMU CL user manual credits Robert MacLachlan as editor. A chapter
+on the CMU CL interprocess communication extensions (not supported in
+SBCL) was contributed by William Lott and Bill Chiles.
+
+Peter VanEynde also contributed a variety of #+HIGH-SECURITY patches
+to CMU CL, to provide additional safety, especially through runtime
+checking on various tricky cases of standard functions (e.g. MAP with
+complicated result types, and interactions of various variants of
+STREAM).
+
+Raymond Toy wrote the propagate-float-type extension and various
+other floating point optimizations.
+
+CMU CL's long float support was written by Douglas T. Crosher.
+
+Paul Werkowski turned the Mach OS support code into Linux OS support code.
+
+Versions of the RUN-PROGRAM extension were written first by David
+McDonald, then by Jim Healy and Bill Chiles, then by William Lott.
+
+
+MORE DETAILS ON THE TRANSITION FROM CMU CL
+
+Bill Newman did the original conversion from CMU CL 18b to a form
+which could bootstrap itself cleanly, on Linux/x86 only. Although they
+may not have realized it at the time, Rob Maclachlan and Peter Van
+Eynde were very helpful, RAM by posting a clear explanation of what
+GENESIS is supposed to be doing and PVE by maintaining a version of
+CMU CL which worked on Debian, so that I had something to refer to
+whenever I got stuck.
+
+
+CREDITS SINCE THE RELEASE OF SBCL
+
+The PSXHASH code used to implement EQUALP hash tables was originally
+copyright (C) 2000 by Cadabra, Inc., then released into the public
+domain.
+
+Daniel Barlow contributed sblisp.lisp, a set of patches to make SBCL
+play nicely with ILISP. (Those patches have since disappeared from the
+SBCL distribution because ILISP has since been patched to play nicely
+with SBCL.) He also figured out how to get the CMU CL dynamic object
+file loading code to work under SBCL.
+
+Raymond Wiker ported sbcl-0.6.3 back to FreeBSD, restoring the
+ancestral CMU CL support for FreeBSD and updating it for the changes
+made from FreeBSD version 3 to FreeBSD version 4.
+
--- /dev/null
+IF YOU HAVE A BINARY DISTRIBUTION:
+
+The two files that SBCL needs to run are sbcl and sbcl.core.
+They are in
+ src/runtime/sbcl
+and
+ output/sbcl.core
+
+sbcl is a standard executable, built by compiling and linking an
+ordinary C program. It provides the runtime environment for the
+running Lisp image, but it doesn't know much about high-level Lisp
+stuff (like symbols and printing and objects) so it's pretty useless
+by itself. sbcl.core is a dump file written in a special SBCL format
+which only sbcl understands, and it contains all the high-level Lisp
+stuff.
+
+In order to get a usable system, you need to run sbcl in a way that
+it can find sbcl.core. There are three ways for it to find
+sbcl.core:
+ 1. by default, in /usr/lib/sbcl.core or /usr/local/lib/sbcl.core
+ 2. by environment variable:
+ $ export SBCL_HOME=/foo/bar/
+ $ sbcl
+ 3. by command line option:
+ $ sbcl --core /foo/bar/sbcl.core"
+The usual, recommended approach is method #1. Method #2 is useful if
+you're installing SBCL on a system in your user account, instead of
+installing SBCL on an entire system. Method #3 is mostly useful for
+testing or other special cases.
+
+So: the standard installation procedure is
+ 1. Copy sbcl.core to /usr/lib or /usr/local/lib.
+ 2. Copy sbcl to /usr/bin or /usr/local/bin.
+ 3. Optionally copy sbcl.1 to /usr/man/man1 or /usr/local/man/man1.
+The script install.sh does these for you (choosing the /usr/local
+subdirectory) in each case.
+
+
+IF YOU HAVE A SOURCE DISTRIBUTION:
+
+This software has been built successfully on these systems:
+ cpu = x86 (Intel 386 or higher, or compatibles like the AMD K6)
+ os = Debian GNU/Linux 2.1 with libc >= 2.1
+ host lisp = CMU CL 2.4.17
+ host lisp = SBCL itself
+ os = RedHat Linux 6.2
+ host lisp = SBCL itself
+ os = FreeBSD 3.4 or 4.0
+ host lisp = CMU CL
+ host lisp = SBCL itself
+ os = OpenBSD 2.6
+ host lisp = SBCL itself
+It is known not to build under CLISP, because CLISP doesn't support
+MAKE-LOAD-FORM. Reports of other systems that it works on, or help in
+making it run on more systems, would be appreciated.
+
+ CAUTION CAUTION CAUTION CAUTION CAUTION
+ SBCL, like CMU CL, overcommits memory. That is, it
+ asks the OS for more virtual memory address space than
+ it actually intends to use, and the OS is expected to
+ optimistically give it this address space even if the OS
+ doesn't have enough RAM+swap to back it up. This works
+ fine as long as SBCL's memory usage pattern is sparse
+ enough that the OS can actually implement the requested
+ VM usage. Unfortunately, if the OS runs out of RAM+swap to
+ implement the requested VM usage, things get bad. On many
+ systems, including the Linux 2.2.13 kernel that I used for
+ development of SBCL up to version 0.6.0, the kernel kills
+ processes more-or-less randomly when it runs out of
+ resources. You may think your Linux box is very stable, but
+ it is unlikely to be stable if this happens.:-| So be sure
+ to have enough memory available when you build the system.
+ (This can be considered a bug in SBCL, or a bug in the
+ Unix overcommitment-of-memory architecture, or both. It's
+ not clear what the best fix is. On the SBCL side, Peter Van
+ Eynde has a lazy-allocation patch for CMU CL that lets
+ it run without overcommitting memory, and that could be
+ ported to SBCL, but unfortunately that might introduce
+ new issues, e.g. alien programs allocating memory in the
+ address space that SBCL thinks of as its own, and later
+ getting trashed when SBCL lazily allocates the memory.
+ On the OS side, there might be some way to address the
+ problem with quotas, I don't know.)
+
+To build the system binaries:
+ 1. Make sure that you have enough RAM+swap to build SBCL, as
+ per the CAUTION note above. (As of version 0.6.0, the most
+ memory-intensive operation in make.sh is the second call to
+ GENESIS, which makes the Lisp image grow to nearly 128 Mb RAM+swap.
+ This will probably be reduced somewhat in some later version
+ by allowing cold load of byte-compiled files, so that the cold
+ image can be smaller.)
+ 2. If the GNU make command is not available under the name "gmake",
+ then define the environment variable GNUMAKE to a name where it can
+ be found.
+ 3. If you like, you can edit the base-features.lisp-expr file
+ to customize the resulting Lisp system. By enabling or disabling
+ features in this file, you can create a smaller system, or one
+ with extra code for debugging output or error-checking or other things.
+ 4. Run "sh make.sh" in the same directory where you unpacked the
+ tarball. If you don't already have a SBCL binary installed
+ as "sbcl" in your path, you'll need to tell make.sh what Lisp
+ system to use as the cross-compilation host. (To use CMU CL
+ as the cross-compilation host, run "sh make.sh 'lisp -batch'",
+ assuming CMU CL has been installed under its default name "lisp".)
+ 5. Wait. This can be a slow process. On my test machines, the
+ wall clock time for a build of sbcl-0.6.7 was approximately
+ 1.5 hours on a 450MHz K6/3 with 248Mb RAM, running RH Linux 6.2;
+ 4 hours on a 200MHz Pentium (P54C) with 64Mb RAM, running FreeBSD 4.0;
+ 13 hours on a 133MHz Pentium (P54C) with 48Mb RAM, running OpenBSD 2.6.
+ Around the 48Mb mark, the build process is starved for RAM:
+ on my 48Mb OpenBSD machine with nothing else running, it
+ spent about 2/3 of its wall clock time swapping. Anything which
+ substantially increases memory use, like running X11, Emacs, or,
+ God forbid, Netscape, can increase the build time substantially.
+
+Now you should have the same src/runtime/sbcl and output/sbcl.core
+files that come with the binary distribution, and you can install
+them as in the "IF YOU HAVE A BINARY DISTRIBUTION" instructions (above).
+
+To convert the DocBook version of the system documentation (files
+ending in .sgml) to more-readable form (HTML or text):
+ DocBook is an abstract markup system based on SGML. It's intended
+ to be automatically translated to other formats. Tools to do this
+ exist on the web, and are becoming increasingly easy to find as
+ more free software projects move their documentation to DocBook.
+ Any one of these systems should work with the SBCL documentation.
+ If you'd like to have the documentation produced in the same
+ format as appears in the binary distribution, and you have
+ the jade binary and Norman Walsh's modular DSSSL stylesheets
+ installed, you can try the doc/make-doc.sh script. Otherwise,
+ your formatted copy of the SBCL documentation should have the
+ same content as in the binary distribution, but details of
+ presentation will probably vary.
--- /dev/null
+changes in sbcl-0.6.0 relative to sbcl-0.5.0:
+
+* tidied up "make.sh" script
+* tidied up system directory structure
+* better "clean.sh" behavior
+* added doc/FOR-CMUCL-DEVELOPERS
+* many many small tweaks to output format, e.g. removing possibly-confusing
+ trailing #\. character in DESCRIBE-INSTANCE
+* (EQUALP #\A 'A) no longer signals an error.
+* new hashing code, including EQUALP hashing
+* tidied up Lisp initialization and toplevel
+* initialization files (e.g. /etc/sbclrc and $HOME/.sbclrc)
+* command line argument processing
+* added POSIX-GETENV function to deal with Unix-ish environment variables
+* more-Unixy handling of *STANDARD-INPUT* and other Lisp streams, e.g.
+ terminating SBCL on EOF
+* non-verbose GC by default
+* There is no more "sbcl" shell script; the sbcl file is now the C
+ runtime executable (just like CMU CL).
+* removed some unused fops, e.g. FOP-UNIFORM-VECTOR, FOP-CHARACTER, and
+ FOP-POP-FOR-EFFECT
+* tweaked debug-info.lisp and debug-int.lisp to make the debugger store
+ symbol and package information as Lisp native symbol and package objects
+ instead of strings naming symbols and strings naming packages. This way,
+ whenever packages are renamed (as in warm init), debug information is
+ transformed along with everything else.
+* tweaked the optimization policy declarations which control the building
+ of SBCL itself. Now, among other things, the system no longer saves
+ source location debugging information. (This helps two problems at once
+ by reducing SBCL size and by keeping SBCL from trying to look for its
+ sources -- which may not exist -- when reporting errors.)
+* added src/cold/chill.lisp, to let SBCL read its own cold sources for
+ debugging and testing purposes
+* cleaned up printing, making the printer call PRINT-OBJECT for
+ instances, and using PRINT-UNREADABLE-OBJECT for most PRINT-OBJECT
+ methods, giving nearly-ANSI behavior
+* converted almost all special variables to use *FOO* naming convention
+* deleted PARSE-TIME functionality, since it can be done portably
+* moved some files out of cold init into warm init
+* deleted DEFUN UNDEFINED-VALUE, replaced (UNDEFINED-VALUE) forms
+ with (VALUES) forms
+* regularized formatting of source files
+* added an install.sh script
+* fixed ridiculous memory usage of cross-compiler by making
+ compiler/alloc.lisp not try to do pooling unless it can hook
+ itself into the GC of the cross-compilation host. Now the system
+ builds nicely on my old laptop.
+* added :SB-ALLOC in target-features.lisp-expr
+* deleted mention of :ANSI-DOC from target-features.lisp-expr (since it
+ was not implemented)
+* re-did condition handling and note reporting in the compiler. Notes
+ are no longer handled by signalling conditions. Style warnings
+ and warnings are handled more correctly and reported in such a way
+ that it's easy to find one or the other in your output (so that you
+ can e.g. figure out which of many problems caused COMPILE-FILE to
+ return FAILURE-P).
+* changed the severity of several compiler warnings from full WARNING
+ to STYLE-WARNING in order to conform with the ANSI spec; also changed
+ compiler note reporting so that it doesn't use the condition system
+ at all (and hence affects neither FAILURE-P nor WARNINGS-P in the
+ COMPILE-FILE command)
+* made PROCLAIM and DECLAIM conform to ANSI. PROCLAIM is now an ordinary
+ function. As a consequence, START-BLOCK and END-BLOCK declarations are
+ no longer supported, since their implementation was deeply intertwingled
+ with the magical, non-ANSI treatment that PROCLAIM received in CMU CL.
+* removed bogus "support" for compiler macros named (SETF FOO), and
+ removed the compiler macro for SETF INFO (but only after making a fool
+ of myself on the cmucl-imp mailing list by posting a bogus patch for
+ DEFINE-COMPILER-MACRO..)
+* Compiled files containing forms which have side effects on the Lisp
+ reader (such as DEFPACKAGE forms) are now handled more correctly.
+ (Compiler queuing of top level lambdas has been suppressed by setting
+ *TOP-LEVEL-LAMBDA-MAX* to 0. )
+* deleted various currently-unused source files, e.g. gengc.lisp. They
+ may be added back at some point e.g. when porting to other architectures,
+ but until they are it's distracting to distribute them and to try to
+ maintain them.
+* deleted "UNCROSS couldn't recurse through.." style warnings, since
+ there were so many of them they're just distractions, and UNCROSS is
+ known to be able to handle the current sources
+* moved PROFILE functionality into TRACE, so that it will be clear
+ how the wrapping and unwrapping of functions when you profile them
+ interacts with the wrapping and unwrapping of functions when you
+ trace them. (Actually, the functionality isn't there yet, but at least
+ the interface specification is there. Hopefully, the functionality will
+ arrive with some future maintenance release.)
+* removed host-oops.lisp
+* changed signature of QUIT function to allow UNIX-CODE argument
+* fixed READ-SEQUENCE bug
+* tweaked verbose GC output so that it looks more like the progress
+ output that ANSI specifies for functions like LOAD
+* set up the system on sourceforge.com, with home pages, mailing lists, etc.
+* added <http://sbcl.sourceforge.com> to the banner information printed by
+ the sbcl executable
+
+changes in sbcl-0.6.1 relative to sbcl-0.6.0:
+
+* changed build optimization from (SAFETY 1) to (SAFETY 3) as a short-term
+ fix for various type-unsafety bugs, e.g. failures with (LENGTH 123) and
+ (MAKE-LIST -1). In the longer term, it ought to become true
+ that declarations are assertions even at SAFETY 1. For now, it's not
+ quite true even at SAFETY 3, but it's at least more nearly true..
+ (Note that this change seems to increases the size of the system by
+ O(5%) and to decrease the speed of the compiler by 20% or more.)
+* changed ALIEN printing to be much more abbreviated, as a short-term fix
+ for the problem of printing dozens of lines of distracting information
+ about low-level system machinery as part of the top stack frame
+ on entry to the debugger when an undefined function was called.
+* tweaked the debugger's use of WITH-STANDARD-IO-SYNTAX so that *PACKAGE*
+ is not reset to COMMON-LISP-USER.
+* Compilation of stuff related to dyncount.lisp has been made conditional
+ on the :SB-DYNCOUNT target feature, so that the ordinary core system is
+ smaller. The various dyncount-related symbols have been moved into
+ a new "SB-DYNCOUNT" package.
+* tty-inspect.lisp has been renamed to inspect.lisp.
+* unix-glibc2.lisp has been renamed to unix.lisp, and the :GLIBC2
+ feature has gone away. (When we eventually port to other flavors of
+ libc and/or Unix, we'll try to make the differences between flavors
+ invisible at the user level.)
+* Various other *FEATURES* tags, and/or their associated conditionals,
+ have been removed if obsolescent, or given better documentation, or
+ sometimes given more-mnemonic names.
+
+changes in sbcl-0.6.2 relative to sbcl-0.6.1:
+
+* (Note that the way that the PCL macroexpansions were rewritten
+ to accommodate the change in DEFGENERIC below breaks binary
+ compatibility. That is, fasl files compiled under sbcl-0.6.1 may
+ not run under sbcl-0.6.2. Once we get out of alpha releases,
+ i.e. hit release 1.0.0, we'll probably try to maintain binary
+ compatibility between maintenance releases, e.g. between sbcl-1.4.3
+ and sbcl-1.4.4. Until then, however, it might be fairly common
+ for maintenance releases to break binary compatibility.)
+* A bug in the calculation of WARNINGS-P and FAILURE-P in COMPILE-FILE
+ has been fixed.
+* The reporting of unhandled signals has been changed to print some
+ explanatory text as well as the report form. (Previously only
+ the report form was printed.)
+* The macroexpansion for DEFGENERIC now DECLAIMs the function that
+ it defines, so that the compiler no longer issues undefined function
+ warnings for compiled-but-not-yet-loaded generic functions.
+* The CLTL-style "LISP" and "USER" nicknames for the "COMMON-LISP"
+ and "COMMON-LISP-USER" packages have been removed. Now only the "CL"
+ and "CL-USER" standard nicknames from the "11.1.2 Standardized Packages"
+ section of the ANSI spec are supported.
+* The "" nickname for the "KEYWORD" package has been removed.
+ The reader still handles symbol tokens which begin with a package marker
+ as keywords, but it doesn't expose its mechanism for doing so in the
+ (PACKAGE-NICKNAMES (FIND-PACKAGE "KEYWORD")) list.
+* The system now issues STYLE-WARNINGs for contradictory TYPE
+ proclamations. (Warnings for contradictory FTYPE proclamations would
+ be nice too, but those can't be done usefully unless the type system
+ is made smarter about FUNCTION types.)
+* The names of source files "*host-*.lisp" and "*target-*.lisp" have been
+ systematized, so that "*target-*.lisp is supposed to exist only on the
+ target and imply that there's a related file which exists on the
+ host, and *host-*.lisp is supposed to exist only on the host and imply
+ that there's a related file which exists on the target. This involves a
+ lot of renaming. Hopefully the acute confusion caused by the renaming
+ will be justified by the reduction in chronic confusion..
+ ** runtime-type.lisp -> early-target-type.lisp
+ ** target-type.lisp -> late-target-type.lisp
+ ** early-host-format.lisp -> early-format.lisp
+ ** late-host-format.lisp -> late-format.lisp
+ ** host-error.lisp -> misc-error.lisp
+ ** early-error.lisp -> early-target-error.lisp
+ ** late-error.lisp -> late-target-error.lisp
+ ** host-defboot.lisp -> early-defboot.lisp
+ ** code/misc.lisp -> code/target-misc.lisp
+ ** code/host-misc.lisp -> code/misc.lisp
+ ** code/numbers.lisp -> code/target-numbers.lisp
+ ** code/early-numbers.lisp -> numbers.lisp
+ ** early-host-type.lisp -> early-type.lisp
+ ** late-host-type.lisp -> late-type.lisp
+ ** host-typep.lisp -> typep.lisp
+ ** load.lisp -> target-load.lisp
+ ** host-load.lisp -> load.lisp
+ ** host-disassem.lisp -> disassem.lisp
+ ** host-insts.lisp -> insts.lisp
+ ** byte-comp.lisp -> target-byte-comp.lisp
+ ** host-byte-comp.lisp -> byte-comp.lisp
+ ** host-signal.lisp -> signal.lisp
+ ** host-defstruct.lisp -> defstruct.lisp
+ ** late-target-type.lisp -> deftypes-for-target.lisp
+ Furthermore, several other previously target-only files foo.lisp (e.g.
+ hash-table.lisp and random.lisp) have been split into a target-and-host
+ foo.lisp file and a target-only target-foo.lisp file, with their key type
+ definitions in the target-and-host part, so that the cross-compiler will
+ know more about target types.
+* DEFSTRUCT BACKEND, and the BACKEND-valued *BACKEND* variable, have
+ gone away. In their place are various *BACKEND-FOO* variables
+ corresponding to the slots of the old structure.
+* A bug which caused the SB-COLD bootstrap-time package to be propagated
+ into the target SBCL has been fixed.
+* The chill.lisp system for loading cold code into a running SBCL
+ now works better.
+* Support for the CMU CL "scavenger hook" extension has been removed.
+ (It was undocumented and unused in the CMU CL sources that SBCL was
+ derived from, and stale in sbcl-0.6.1.)
+* Various errors in the cross-compiler type system were detected
+ by running the cross-compiler with *TYPE-SYSTEM-INITIALIZED*
+ (enabling various consistency checks). Many of them were fixed,
+ but some hard problems remain, so the compiler is back to
+ running without *TYPE-SYSTEM-INITIALIZED* for now.
+* As part of the cross-compiler type system cleanup, I implemented
+ DEF!TYPE and got rid of early-ugly-duplicates.lisp.
+* I have started adding UNCROSS calls throughout the type system
+ and the INFO database. (Thus perhaps eventually the blanket UNCROSS
+ on cross-compiler input files will be able to go away, and various
+ kludges with it).
+* CONSTANTP now returns true for quoted forms (as explicitly required
+ by the ANSI spec).
+
+changes in sbcl-0.6.3 relative to sbcl-0.6.2:
+
+* The system still can't cross-compile itself with
+ *TYPE-SYSTEM-INITIALIZED* (and all the consistency checks that
+ entails), but at least it can compile more of itself that way
+ than it used to be able to, and various buglets which were uncovered
+ by trying to cross-compile itself that way have now been fixed.
+* This release breaks binary compatibility again. This time
+ at least I've incremented the FASL file format version to 2, so that the
+ problem can be detected reliably instead of just causing weird errors.
+* various new style warnings:
+ ** using DEFUN, DEFMETHOD, or DEFGENERIC to overwrite an old definition
+ ** using the deprecated EVAL/LOAD/COMPILE situation names in EVAL-WHEN
+ ** using the lexical binding of a variable named in the *FOO* style
+* DESCRIBE has been substantially rewritten. It now calls DESCRIBE-OBJECT
+ as specified by ANSI.
+* *RANDOM-STATE* is no longer automatically initialized from
+ (GET-UNIVERSAL-TIME), but instead from a constant seed. Thus, the
+ default behavior of the system is to repeat its behavior every time
+ it's run. If you'd like to change this behavior, you can always
+ explicitly set the seed from (GET-UNIVERSAL-TIME); whereas under the
+ old convention there was no comparably easy way to get the system to
+ repeat its behavior every time it was run.
+* Support for the pre-CLTL2 interpretation of FUNCTION declarations as
+ FTYPE declarations has been removed, in favor of their ANSI
+ interpretation as TYPE FUNCTION declarations. (See p. 228 of CLTL2.)
+* The quantifiers SOME, EVERY, NOTANY, and NOTEVERY no longer cons when
+ the types of their sequence arguments can be determined at compile time.
+ This is done through a new open code expansion for MAP which eliminates
+ consing for (MAP NIL ..), and reduces consing otherwise, when sequence
+ argument types can be determined at compile time.
+* The optimizer now transforms COERCE into an identity operation when it
+ can prove that the coerced object is already of the correct type. (This
+ can be a win for machine generated code, including the output of other
+ optimization transforms, such as the MAP transform above.)
+* Credit information has been moved from source file headers into CREDITS.
+* Source file headers have been made more standard.
+* The CASE macro now compiles without complaining even when it has
+ no clauses.
+
+changes in sbcl-0.6.4 relative to sbcl-0.6.3:
+
+* There is now a partial SBCL user manual (with some new text and some
+ text cribbed from the CMU CL manual).
+* The beginnings of a profiler have been added (starting with the
+ CMU CL profiler and simplifying and cleaning up). Eventually the
+ main interface should be through the TRACE macro, but for now,
+ it's still accessed through vaguely CMU-CL-style functions and macros
+ exported from the package SB-PROFILE.
+* Some problems left over from porting CMU CL to the new
+ cross-compilation bootstrap process have been cleaned up:
+ ** DISASSEMBLE now works. (There was a problem in using DEFMACRO
+ instead of SB!XC:DEFMACRO, compounded by an oversight on my
+ part when getting rid of the compiler *BACKEND* stuff.)
+ ** The value of *NULL-TYPE* was screwed up, because it was
+ being initialized before the type system knew the final
+ definition of the 'NULL type. This screwed up several key
+ optimizations in the compiler, causing inefficiency in all sorts
+ of places. (I found it because I wanted to understand why
+ GET-INTERNAL-RUN-TIME was consing.)
+* fixed a bug in DEFGENERIC which was causing it to overwrite preexisting
+ PROCLAIM FTYPE information. Unfortunately this broke binary
+ compatibility again, since now the forms output by DEFGENERIC
+ to refer to functions which didn't exist in 0.6.3.
+* added declarations so that SB-PCL::USE-CACHING-DFUN-P
+ can use the new (as of 0.6.3) transform for SOME into MAP into
+ inline code
+* changed (MOD 1000000) type declarations for Linux timeval.tv_usec slot
+ values to (INTEGER 0 1000000), so that the time code will no longer
+ occasionally get blown up by Linux returning 1000000 microseconds
+* PRINT-UNREADABLE-OBJECT has been tweaked to make the spacing of
+ its output conform to the ANSI spec. (Alas, this makes its output
+ uglier in the :TYPE T :IDENTITY NIL case, but them's the breaks.)
+* A full call to MAP NIL with a single sequence argument no longer conses.
+* fixes to problems pointed out by Martin Atzmueller:
+ * The manual page no longer talks about multiprocessing as though
+ it were currently supported.
+ * The ILISP support patches have been removed from the distribution,
+ because as of version 5.10.1, ILISP now supports SBCL without us
+ having to maintain patches.
+* added a modified version of Raymond Toy's recent CMU CL patch for
+ EQUALP comparison of HASH-TABLE
+
+changes in sbcl-0.6.5 relative to sbcl-0.6.4:
+
+* Raymond Wiker's patches to port the system to FreeBSD have been merged.
+* The build process now looks for GNU make under the default name "gmake",
+ instead of "make" as it used to. If GNU make is not available as "gmake"
+ on your system, you can change this default behavior by setting the
+ GNUMAKE environment variable.
+* Replace #+SB-DOC with #!+SB-DOC in seq.lisp so that the system
+ can build without error under CMU CL.
+
+changes in sbcl-0.6.6 relative to sbcl-0.6.5:
+
+* DESCRIBE no longer tries to call itself recursively to describe
+ bound/fbound values, so that it no longer fails on symbols which are
+ bound to themselves (like keywords, T, and NIL).
+* DESCRIBE now works on generic functions.
+* The printer now prints less-screwed-up representations of closures
+ (not naively trying to bogusly use the %FUNCTION-NAME accessor on them).
+* A private symbol is used instead of the :EMPTY keyword previously
+ used to mark empty slots in hash tables. Thus
+ (DEFVAR *HT* (MAKE-HASH-TABLE))
+ (SETF (GETHASH :EMPTY *HT*) :EMPTY)
+ (MAPHASH (LAMBDA (K V) (FORMAT T "~&~S ~S~%" K V)))
+ now does what ANSI says that it should. (You can still get
+ similar noncompliant behavior if bang on the hash table
+ implementation with all the symbols you get back from
+ DO-ALL-SYMBOLS, but at least that's a little harder to do.)
+ This breaks binary compatibility, since tests for equality to
+ :EMPTY are wired into things like the macroexpansion of
+ WITH-HASH-TABLE-ITERATOR in FASL files produced by earlier
+ implementations.
+* There's now a minimal placeholder implementation for CL:STEP,
+ as required by ANSI.
+* An obscure bug in the interaction of the normal compiler, the byte
+ compiler, inlining, and structure predicates has been patched
+ by setting the flags for the DEFTRANSFORM of %INSTANCE-TYPEP as
+ :WHEN :BOTH (as per Raymond Toy's suggestion on the cmucl-imp@cons.org
+ mailing list).
+* Missing ordinary arguments in a macro call are now detected even
+ when the macro lambda list contains &KEY or &REST.
+* The debugger no longer complains about encountering the top of the
+ stack when you type "FRAME 0" to explicitly instruct it to go to
+ the top of the stack. And it now prints the frame you request even
+ if it's the current frame (instead of saying "You are here.").
+* As specified by ANSI, the system now always prints keywords
+ as #\: followed by SYMBOL-NAME, even when *PACKAGE* is the
+ KEYWORD package.
+* The default initial SIZE of HASH-TABLEs is now smaller.
+* Type information from CLOS class dispatch is now propagated
+ into DEFMETHOD bodies, so that e.g.
+ (DEFMETHOD FOO ((X SINGLE-FLOAT))
+ (+ X 123.0))
+ is now basically equivalent to
+ (DEFMETHOD FOO ((X SINGLE-FLOAT))
+ (DECLARE (TYPE SINGLE-FLOAT X))
+ (+ X 123.0))
+ and the compiler can compile (+ X 123.0) as a SINGLE-FLOAT-only
+ operation, without having to do run-time type dispatch.
+* The macroexpansion of DEFMETHOD has been tweaked so that it has
+ reasonable behavior when arguments are declared IGNORE or IGNORABLE.
+* Since I don't seem to be making big file reorganizations very often
+ any more (and since my archive of sbcl-x.y.zv.tar.bz2 snapshots
+ is overflowing my ability to conveniently back them up), I've finally
+ checked the system into CVS. (The CVS repository is on my home system,
+ not at SourceForge -- putting it on SourceForge might come later.)
+* SB-EXT:*GC-NOTIFY-STREAM* has been added, to control where the
+ high-level GC-NOTIFY-FOO functions send their output. (There's
+ still very little control of where low-level verbose GC functions
+ send their output.) The SB-EXT:*GC-VERBOSE* variable now controls
+ less than it used to -- the GC-NOTIFY-FOO functions are now under
+ the control of *GC-NOTIFY-STREAM*, not *GC-VERBOSE*.
+* The system now stores the version string (LISP-IMPLEMENTATION-VERSION)
+ in only one place in the source code, and propagates it automatically
+ everywhere that it's needed. Thus e.g. when I bump the version from
+ 0.6.6 to 0.6.7, I'll only need to modify the sources in one place.
+* The C source files now include boilerplate legalese and documentation
+ at the head of each file (just as the Lisp source files already did).
+* At Dan Barlow's suggestion, the hyperlink from the SBCL website
+ to his page will be replaced with a link to his new CLiki service.
+
+changes in sbcl-0.6.7 relative to sbcl-0.6.6:
+
+* The system has been ported to OpenBSD.
+* The system now compiles with a simple "sh make.sh" on the systems
+ that it's supported on. I.e., now you no longer need to tweak
+ text in the target-features.lisp-expr and symlinks in src/runtime/
+ by hand, the make.sh takes care of it for you.
+* The system is no longer so grossly inefficient when compiling code
+ involving vectors implemented as general (not simple) vectors (VECTOR T),
+ so code which dares to use VECTOR-PUSH-EXTEND and FILL-POINTER, or
+ which dares to use the various sequence functions on non-simple
+ vectors, takes less of a performance hit.
+ * There is now a primitive type predicate VECTOR-T-P
+ to test for the (VECTOR T) type, so that e.g.
+ (DEFUN FOO (V) (DECLARE (TYPE (VECTOR T) V)) (AREF V 3))
+ can now be compiled with some semblance of efficiency. (The old code
+ turned the type declaration into a full call to %TYPEP at runtime!)
+ * AREF on (VECTOR T) is still not fast, since it's still compiled
+ as a full call to SB-KERNEL:DATA-VECTOR-REF, but at least the
+ ETYPECASE used in DATA-VECTOR-REF is now compiled reasonably
+ efficiently. (The old version made full calls to SUBTYPEP at runtime!)
+ * (MAKE-ARRAY 12 :FILL-POINTER T) is now executed less inefficiently,
+ without making full calls to SUBTYPEP at runtime.
+ (Some analogous efficiency issues for non-simple vectors specialized to
+ element types other than T, or for non-simple multidimensional arrays,
+ have not been addressed. They could almost certainly be handled the
+ same way if anyone is motivated to do so.)
+* The changes in array handling break binary compatibility, so
+ *BACKEND-FASL-FILE-VERSION* has been bumped to 4.
+* (TYPEP (MAKE-ARRAY 12 :FILL-POINTER 4) 'VECTOR) now returns (VALUES T)
+ instead of (VALUES T T).
+* By following the instructions that Dan Barlow posted to sbcl-devel
+ on 2 July 2000, I was able to enable primitive dynamic object
+ file loading code for Linux. The full-blown CMU CL LOAD-FOREIGN
+ functionality is not implemented (since it calls ld to resolve
+ library references automatically, requiring RUN-PROGRAM for its
+ implementation), but a simpler SB-EXT:LOAD-1-FOREIGN (which doesn't
+ try to resolve library references) is now supported.
+* The system now flushes the standard output streams when it terminates,
+ unless QUIT is used with the RECKLESSLY-P option set. It also flushes
+ them at several other probably-convenient times, e.g. in each pass of
+ the toplevel read-eval-print loop, and after evaluating a form given
+ as an "--eval" command-line option. (These changes were motivated by a
+ discussion of stream flushing issues on cmucl-imp in August 2000.)
+* The source transform for TYPEP of array types no longer assumes
+ that an array whose element type is a not-yet-defined type
+ is implemented as an array of T, but instead punts, so that the
+ type will be interpreted at runtime.
+* There is now some support for cross-compiling in make.sh: each of
+ the phases of make.sh has its own script. (This should be transparent
+ to people doing ordinary, non-cross-compile builds.)
+* Since my laptop doesn't have hundreds of megabytes of memory like
+ my desktop machine, I became more motivated to do some items on
+ my to-do list in order to reduce the size of the system a little:
+ ** Arrange for various needed-only-at-cold-init things to be
+ uninterned after cold init. To support this, those things have
+ been renamed from FOO and *FOO* to !FOO and *!FOO* (i.e., all
+ symbols with such names are now uninterned after cold init).
+ ** Bind SB!C::*TOP-LEVEL-LAMBDA-MAX* to a nonzero value when building
+ fasl files for cold load.
+ ** Remove the old compiler structure pooling code (which used to
+ be conditional on the target feature :SB-ALLOC) completely.
+ ** Redo the representation of some data in cold init to be more compact.
+ (I also looked into supporting byte compiled code at bootstrap time,
+ which would probably reduce the size of the system a lot, but that
+ looked too complicated, so I punted for now.)
+* The maximum signal nesting depth in the src/runtime/ support code has
+ been reduced from 4096 to 256. (I don't know any reason for the very
+ large old value. If the new smaller value turns out to break something,
+ I'll probably just bump it back up.)
+* PPRINT-LOGICAL-BLOCK is now pickier about the types of its arguments,
+ as per ANSI.
+* Many, many bugs reported by Peter Van Eynde have been added to
+ the BUGS list; some have even been fixed.
+* While enabling dynamic object file loading, I tried to make the
+ code easier to understand, renaming various functions and variables
+ with less ambiguous names, and changing some function calling
+ conventions to be Lispier (e.g. returning NIL instead of 0 for failure).
+* While trying to figure out how to do the OpenBSD port, I tried to
+ clean up some of the code in src/runtime/. In particular, I dropped
+ support for non-POSIX signal handling, added various comments,
+ tweaked the code to reduce the number of compilation warnings, and
+ renamed some files to increase consistency.
+* To support the new automatic configuration functionality in make.sh,
+ the source file target-features.lisp-expr has been replaced with the
+ source file base-target-features.lisp-expr and the machine-generated
+ file local-target-features.lisp-expr.
+* fixed a stupid quoting error in make.sh so that using CMU CL
+ "lisp -batch" as cross-compilation host works again
+
+changes in sbcl-0.6.8 relative to sbcl-0.6.7:
+
+?? The system is now under CVS at SourceForge (instead of the
+ CVS repository on my home machine).
+?? The INSTALL file has been updated with some information
+ about using anonymous CVS to download the most recent version
+ from SourceForge.
+?? There's now code in the tests/ subdirectory to run the system
+ through the clocc/ansi-tests/ suite, and to run additional
+ SBCL-specific regression tests as well. (It's not particularly
+ mature right now, but it's a start.)
+?? The system now uses code based on Colin Walters' O(N)
+ implementation of MAP (from the cmucl-imp@cons.org mailing
+ list, 2 September 2000) when it can't use a DEFTRANSFORM to
+ inline the MAP operation, and there is more than one
+ sequence argument to the MAP call (so that it can't just
+ do ETYPECASE once and for all based on the type of the
+ single sequence argument). (The old non-inline implementation
+ of the general M-argument sequence-of-length-N case required
+ O(M*N*N) time when any of the sequence arguments were LISTs.)
+?? Raymond Wiker's port of CMU CL's RUN-PROGRAM has been added.
+(?? Don't forget to mention Colin Walters and Raymond Wiker in the
+ CREDITS file.)
+?? The debugger now flushes standard output streams before it begins
+ its output ("debugger invoked" and so forth).
+?? The two problem cases reported by Peter Van Eynde on 8 Sep 2000,
+ (BUTLAST '(1 2 3) -1) and (MAKE-LIST -1), now work, and test cases
+ have now been added to the regression test suite to keep them
+ from appearing again. (This was a repeat appearance, alas!)
+ As the regression test system gets more mature, I intend to add
+ most future fixed bugs to it, but at this point I'm still playing
+ with it.
+?? The patch for the SUBSEQ bug reported on the cmucl-imp mailing
+ list 12 September 2000 has been applied to SBCL.
+?? Martin Atzmueller's versions of two CMU CL patches, as posted on
+ sbcl-devel 13 September 2000, have been installed. (The patches fix
+ a bug in SUBSEQ and <a bug in ??>.)
+?? A bug in signal handling which kept TRACE from working on OpenBSD
+ has been fixed.
+?? The signal handling bug reported by Martin Atzmueller on
+ sbcl-devel 13 September 2000, which caused the debugger to
+ get confused after a Ctrl-C interrupt under ILISP, has been fixed.
--- /dev/null
+"In truth, I found myself incorrigible with respect to *Order*; and
+now I am grown old and my memory bad, I feel very sensibly the want of
+it. But, on the whole, though I never arrived at the perfection I had
+been so ambitious of obtaining, but fell far short of it, yet I was,
+by the endeavour, a better and happier man than I otherwise should
+have been if I had not attempted it; as those who aim at perfect
+writing by imitating the engraved copies, though they never reach the
+wished-for excellence of those copies, their hand is mended by the
+endeavor, and is tolerable while it continues fair and legible."
+ -- Benjamin Franklin in his autobiography
+
+"'Signs make humans do things,' said Nisodemus, 'or stop doing things.
+So get to work, good Dorcas. Signs. Um. Signs that say *No*.'"
+ -- Terry Pratchett, _Diggers_
+
+There are some principles which I'd like to see used in the
+maintenance of SBCL:
+1. conforming to the standard
+2. being maintainable
+ a. removing stale code
+ b. When practical, important properties should be made manifest in
+ the code. (Putting them in the comments is a distant second best.)
+ i. Perhaps most importantly, things being the same (in the strong
+ sense that if you cut X, Y should bleed) should be manifest in
+ the code. Having code in more than one place to do the same
+ thing is bad. Having a bunch of manifest constants with hidden
+ relationships to each other is inexcusable. (Some current
+ heinous offenders against this principle are the memoizing
+ caches for various functions, and the LONG-FLOAT code.)
+ ii. Enforcing nontrivial invariants, e.g. by declaring the
+ types of variables, or by making assertions, can be very
+ helpful.
+ c. using clearer internal representations
+ i. clearer names
+ A. more-up-to-date names, e.g. PACKAGE-DESIGNATOR instead
+ of PACKAGELIKE (in order to match terminology used in ANSI spec)
+ B. more-informative names, e.g. SAVE-LISP-AND-DIE instead
+ of SAVE-LISP or WRAPPER-INVALID rather than WRAPPER-STATE
+ C. families of names which correctly suggest parallelism,
+ e.g. CONS-TO-CORE instead of ALLOCATE-CONS, in order to
+ suggest the parallelism with other FOO-TO-CORE functions
+ ii. clearer encodings, e.g. it's confusing that WRAPPER-STATE in PCL
+ returns T for valid and any other value for invalid; could
+ be clarified by changing to WRAPPER-INVALID returning a
+ generalized boolean; or e.g. it's confusing to encode things
+ as symbols and then use STRING= SYMBOL-NAME instead of EQ
+ to compare them.
+ iii. clearer implementations, e.g. cached functions being
+ done with HASH-TABLE instead of hand-coded caches
+ d. informative comments and other documentation
+ i. documenting things like the purposes and required properties
+ of functions, objects, *FEATURES* options, memory layouts, etc.
+ ii. not using terms like "new" without reference to when.
+ (A smart source code control system which would let you
+ find when the comment was written would help here, but
+ there's no reason to write comments that require a smart
+ source code control system to understand..)
+ e. using functions instead of macros where appropriate
+ f. maximizing the amount of stuff that's (broadly speaking) "table
+ driven". I find this particularly helpful when the table describes
+ the final shape of the result (e.g. the package-data-list.lisp-expr
+ file), replacing a recipe for constructing the result (e.g. various
+ in-the-flow-of-control package-manipulation forms) in which the
+ final shape of the result is only implicit. But it can also be very
+ helpful any time the table language can be just expressive enough
+ for the problem at hand.
+ g. using functional operators instead of side-effecting operators
+ where practical
+ h. making it easy to find things in the code
+ i. defining things using constructs which can be understood by etags
+ i. using the standard library where possible
+ i. instead of hand-coding stuff
+ (My package-data-list.lisp-expr stuff may be a bad example as of
+ 19991208, since the system has evolved to the point where it
+ might be possible to replace my hand-coded machinery with some
+ calls to DEFPACKAGE.)
+ j. more-ambitious dreams..
+ i. fixing the build process so that the system can be bootstrapped
+ from scratch, so that the source code alone, and not bits and
+ pieces inherited from the previous executable, determine the
+ properties of the new executable
+ ii. making package dependencies be a DAG instead of a mess, so
+ the system could be understood (and rebuilt) in pieces
+ iii. moving enough of the system into C code that the Common Lisp
+ LOAD operator (and all the symbol table and FOP and other
+ machinery that it depends on) is implemented entirely in C, so
+ that GENESIS would become unnecessary (because all files could
+ now be warm loaded)
+3. being portable
+ a. In this vale of tears, some tweaking may be unavoidably required
+ when making software run on more than one machine. But we should
+ try to minimize it, not embrace it. And to the extent that it's
+ unavoidable, where possible it should be handled by making an
+ abstract value or operation which is used on all systems, then
+ making separate implementations of those values and operations
+ for the various systems. (This is very analogous to object-oriented
+ programming, and is good for the same reasons that method dispatch
+ is better than a bunch of CASE statements.)
+4. making a better programming environment
+ a. Declarations *are* assertions! (For function return values, too!)
+ b. Making the debugger, the profiler, and TRACE work better.
+ c. Making extensions more comprehensible.
+ i. Making a smaller set of core extensions. IMHO the high level
+ ones like ONCE-ONLY and LETF belong in a portable library
+ somewhere, not in the core system.
+ ii. Making more-orthogonal extensions. (e.g. removing the
+ PURIFY option from SAVE-LISP-AND-DIE, on the theory that
+ you can always call PURIFY yourself if you like)
+ iii. If an extension must be complicated, if possible make the
+ complexity conform to some existing standard. (E.g. if SBCL
+ supplied a command-line argument parsing facility, I'd want
+ it to be as much like existing command-line parsing utilities
+ as possible.)
+5. other nice things
+ a. improving compiled code
+ i. faster CLOS
+ ii. bigger heap
+ iii. better compiler optimizations
+ iv. DYNAMIC-EXTENT
+ b. increasing the performance of the system
+ i. better GC
+ ii. improved ability to compile prototype programs fast, even
+ at the expense of performance of the compiled program
+ c. improving safety
+ i. more graceful handling of stack overflow and memory exhaustion
+ ii. improving interrupt safety by e.g. locking symbol tables
+ d. decreasing the size of the SBCL executable
+ e. not breaking old extensions which are likely to make it into the
+ new ANSI standard
+6. other maybe not-so-nice things
+ a. adding whizzy new features which make it harder to maintain core
+ code. (Support for the debugger is important enough that I'll
+ cheerfully make an exception. Multithreading might also be
+ sufficiently important that it's probably worth making an exception.)
+ The one other class of extensions that I am particularly interested
+ is CORBA or other standard interface support, so that programs can
+ more easily break out of the Lisp/GC box to do things like graphics.
+ ("So why did you drop all the socket support, Bill?" I hear you
+ ask. Fundamentally, because I have 'way too much to maintain
+ already; but also because I think it's too low-level to add much
+ value. People who are prepared to work at that level of abstraction
+ and non-portability could just code their own wrapper layer
+ in C and talk to it through the ALIEN stuff.)
+7. judgment calls
+ a. Sharp, rigid tools are safer than dull or floppy tools. I'm
+ inclined to avoid complicated defaulting behavior (e.g. trying
+ to decide what file to LOAD when extension is not specified) or
+ continuable errors, preferring functions which have simple behavior
+ with no surprises (even surprises which are arguably pleasant).
+
+CMU CL maintenance has been conservative in ways that I would prefer to
+be flexible, and flexible in ways that I'd prefer to be conservative.
+CMU CL maintainers have been conservative about keeping old code and
+maintaining the old structure, and flexible about allowing a bunch of
+additional stuff to be tacked onto the old structure.
+
+There are some good things about the way that CMU CL has been
+maintained that I nonetheless propose to jettison. In particular,
+binary compatibility between releases. This is a very handy feature,
+but it's a pain to maintain. At least for a while, I intend to just
+require that programs be recompiled any time they're to be used with a
+new version of the system. After a while things might settle down to
+where recompiles will only be required for new major releases, so
+either all 3.3.x fasl files will work with any 3.3.y runtime, or all
+3.w.x fasl files will work with any 3.y.z runtime. But before trying
+to achieve that kind of stability, I think it's more important to
+be able to clean up things about the internal structure of the system.
+Aiming for that kind of stability would impair our ability to make
+changes like
+ * cleaning up DEFUN and DEFMACRO to use EVAL-WHEN instead of IR1 magic;
+ * reducing the separation between PCL classes and COMMON-LISP classes;
+ * fixing bad FOPs (e.g. the CMU CL fops which interact with the *PACKAGE*
+ variable)
--- /dev/null
+Welcome to SBCL.
+
+To find out more about who created the system, see the "CREDITS" file.
+
+If you'd like information about the legalities of copying the system,
+see the "COPYING" file.
+
+If you'd like to install or build the system, see the "INSTALL" file.
+
+If you'd like more information about using the system, see the man
+page, "sbcl.1", or the user manual in the "doc/" subdirectory of the
+distribution. (The user manual is maintained as DocBook SGML in the
+source distribution; there is an HTML version in the binary
+distribution.)
+
+The system is a work in progress. See the "TODO" file in the source
+distribution for some highlights.
+
+If you'd like to make suggestions, report a bug, or help to improve the
+system, please send mail to one of the mailing lists:
+ sbcl-help@lists.sourceforge.net
+ sbcl-devel@lists.sourceforge.net
--- /dev/null
+Most of the style hints in the Lisp FAQ apply.
+
+When porting the system, I would really prefer code which factors
+dependencies into a set of interface functions and constants and
+includes implementations of the interface for the different systems.
+Patches which require conditional compilation (like all the old
+#T+HPUX or #T-X86 tests in the sources inherited from CMUCL) might be
+accepted if they're simple, in hopes of factoring out the differences
+more cleanly later, but even if accepted, such code may not be
+maintained for very long.
+
+grammatical fussiness:
+ Phrases are not capitalized.
+ Sentences are capitalized.
+ Periods terminate sentences.
+ Periods separate phrases from succeeding sentences, e.g.
+ ;;; the maximum number of transformations we'll make before
+ ;;; concluding we're in an infinite loop and bailing. This can
+ ;;; be changed, but it is an error to change it while we're
+ ;;; solving a system.
+ (defvar *max-n-transformations* 10)
+ Lisp in comments is capitalized.
+
+usage fussiness:
+ Function documentation can be a description of what the function
+ does, e.g.
+ ;;; Parse the arguments for a BDEFSTRUCT call, and return
+ ;;; (VALUES NAME DEFSTRUCT-ARGS MAKE-LOAD-FORM-FUN BDEFSTRUCT-STYPE),
+ ;;; where NAME is the name of the new type, DEFSTRUCT-ARGS is the
+ ;;; munged result suitable for passing on to DEFSTRUCT,
+ ;;; MAKE-LOAD-FORM-FUN is the make load form function, or NIL if
+ ;;; there's none, and BDEFSTRUCT-SUPERTYPE is the direct supertype
+ ;;; of the type if it is another BDEFSTRUCT-defined type, or NIL
+ ;;; otherwise.
+ (defun parse-bdefstruct-args (nameoid &rest rest)
+ ..)
+ or a remark about the function, e.g.
+ ;;; a helper function for BDEFSTRUCT in the #+XC-HOST case
+ (defun uncross-defstruct-args (defstruct-args)
+ ..)
+ If you're talking about what the function does, ordinarily you
+ should just say what the function does, e.g.
+ ;;; Return the first prime number greater than or equal to X.
+ (defun primify (x) ..)
+ instead of telling the reader that you're going to tell him what
+ the function does, e.g.
+ ;;; PRIMIFY returns the first prime number greater than or
+ ;;; equal to X.
+ (defun primify (x) ..)
+ or
+ ;;; When you call this function on X, you get back the first
+ ;;; prime number greater than or equal to X.
+ (defun primify (x) ..)
+
+In general, if you can express it in the code instead of the comments,
+do so. E.g. the old CMUCL code has many comments above functions foo
+that say things like
+ ;;; FOO -- interface
+If we were going to do something like that, we would prefer to do it by
+writing
+ (EXPORT 'FOO)
+(Instead, for various other reasons, we centralize all the exports
+in package declarations.) The old "FOO -- interface" comments are bad
+style because they duplicate information (and they illustrate one
+of the evils of duplicating information by the way that they have
+drifted out of sync with the code).
+
+There are a number of style practices on display in the code
+which are not good examples to follow:
+ * using conditional compilation to support different architectures,
+ instead of factoring the dependencies into interfaces and providing
+ implementations of the interface for different architectures;
+ * in conditional compilation, using a common subexpression over and
+ over again, e.g. #+(OR GENGC GENCGC), when the important thing is
+ that GENGC and GENCGC are (currently) the GCs which support scavenger
+ hooks. If you have to do that, define a SCAVHOOK feature,
+ write #+SCAVHOOK in many places, and arrange for the SCAVHOOK feature
+ to be set once and only once in terms of GENGC and GENCGC. (That way
+ future maintainers won't curse you.)
+ * putting the defined symbol, and information about whether it's
+ exported or not, into the comments around the definition of the symbol;
+ * naming anything DO-FOO if it isn't an iteration macro
+ * exposing a lot of high-level functionality not in the ANSI standard
+ to the user (as discussed above)
+ * not using a consistent abbreviation style in global names (e.g.
+ naming some things DEFINE-FOO and other things DEF-BAR, with
+ no rule to determine whether the abbreviation is used)
+ * using lots of single-colon package prefixes (distracting and hard
+ to read, and obstacles to reaching package nirvana where
+ package dependencies are a directed acyclic graph) or even
+ double-colon package prefixes (hard to understand and hard
+ to maintain). (One exception: I've sometimes been tempted to
+ add a CL: prefix to the definition of every CL symbol (e.g.
+ (DEFUN CL:CADDDR (..) ..) as reminders that they're required by
+ ANSI and can't be deleted no matter how obscure and useless some
+ of them might look.:-)
+Most of these are common in the code inherited from CMUCL. I've
+eliminated them in some places, but there's a *lot* of code inherited
+from CMUCL..
--- /dev/null
+ Accumulation of half-understood design decisions eventually
+ chokes a program as a water weed chokes a canal. By refactoring
+ you can ensure that your full understanding of how the program
+ should be designed is always reflected in the program. As a
+ water weed quickly spreads its tendrils, partially understood
+ design decisions quickly spread their effects throughout your
+ program. No one or two or even ten individual actions will be
+ enough to eradicate the problem.
+ -- Martin Fowler, _Refactoring: Improving the Design
+ of Existing Code_, p. 360
+===============================================================================
+some things that I'd like to do in 0.6.x, in no particular order:
+-------------------------------------------------------------------------------
+PROBLEM:
+ The batch-related command line options for SBCL don't work
+ properly.
+ A small part of making them work properly is making sure that
+ verbose GC messages end up piped to error output.
+ Make sure that when the system dies due to an unhandled error
+ in batch mode, the error is printed successfully, whether
+ FINISH-OUTPUT or an extra newline or whatever is required.
+ Make sure that make.sh dies gracefully when one of the SBCLs
+ it's running dies with an error.
+MUSING:
+ Actually, the ANSI *DEBUGGER-HOOK* variable might be a better
+ place to put the die-on-unhandled-error functionality.
+FIX:
+ ??
+-------------------------------------------------------------------------------
+PROBLEM:
+ As long as I'm working on the batch-related command-line options,
+ it would be reasonable to add one more option to "do what I'd want",
+ testing standard input for TTY-ness and running in no-programmer
+ mode if so.
+FIX:
+ ?? Do it.
+-------------------------------------------------------------------------------
+PROBLEM:
+ In order to make a well-behaved backtrace when a batch program
+ terminates abnormally, it should be limited in length.
+FIX:
+ ?? Add a *DEBUG-BACKTRACE-COUNT* variable, initially set to 64,
+ to provide a default for the COUNT argument to BACKTRACE.
+-------------------------------------------------------------------------------
+PROBLEM:
+ I used CMU CL for years, and dozens of times I cursed the
+ inadequate breakpoint-based TRACE facility which doesn't work on
+ some functions, and I never realized that there's a wrapper-based
+ facility too until I was wading through the source code for SBCL.
+ Yes, I know I should have RTFM, but there is a lot of M..
+FIX:
+ ?? possibility 1: Add error-handling code in ntrace.lisp to
+ catch failure to set breakpoints and retry using
+ wrapper-based tracing.
+ ?? possibility 2: Add error-handling code in ntrace.lisp to
+ catch failure to catch failure to set breakpoints and output
+ a message suggesting retrying with wrapper-based breakpoints
+ ?? possibility 3: Fix the breakpoint-based TRACE facility so that
+ it always works.
+-------------------------------------------------------------------------------
+PROBLEM:
+ When cross-compiling host-byte-comp.lisp, I get bogus
+ warnings
+ caught STYLE-WARNING:
+ undefined function: %%DEFCONSTANT
+ caught STYLE-WARNING:
+ This function is undefined:
+ %%DEFCONSTANT
+MUSING:
+ The best way to clean this up would be as a side-effect of
+ a larger cleanup, making all the %%DEFFOO stuff use EVAL-WHEN
+ instead of IR1 magic.
+ There's probably some way to do it with a quick local hack too.
+FIX:
+ ??
+-------------------------------------------------------------------------------
+PROBLEM:
+ My system of parallel build directories doesn't seem to add value.
+FIX:
+ ?? Replace it with a system where fasl output files live in the
+ same directories as the sources and have names a la
+ "foo.fasl-from-host and "foo.fasl-from-xc".
+-------------------------------------------------------------------------------
+PROBLEM:
+ It might be good to use the syntax (DEBUGGER-SPECIAL *PRINT-LEVEL*)
+ etc. to control the in-the-debug-context special variables. Then we
+ wouldn't have to pick and choose which variables we shadow in the
+ debugger.
+ The shadowing values could also be made persistent between
+ debugger invocations, so that entering the debugger, doing
+ (SETF *PRINT-LEVEL* 2), and exiting the debugger would leave
+ (DEBUGGER-SPECIAL *PRINT-LEVEL*) set to 2, and upon reentry to the
+ debugger, *PRINT-LEVEL* would be set back to 2.
+FIX:
+ ??
+-------------------------------------------------------------------------------
+PROBLEM:
+ The :SB-TEST target feature should do something.
+FIX:
+ ??
+-------------------------------------------------------------------------------
+PROBLEM:
+ I still haven't cleaned up the cut-and-paste programming in
+ * DEF-BOOLEAN-ATTRIBUTE, DELETEF-IN, and PUSH-IN
+ * SB!SYS:DEF!MACRO ASSEMBLE and SB!XC:DEFMACRO ASSEMBLE
+FIX:
+ ??
+-------------------------------------------------------------------------------
+PROBLEM:
+ We be able to get rid of the IR1 interpreter, which would
+ not only get rid of all the code in *eval*.lisp, but also allow us to
+ reduce the number of special cases elsewhere in the system. (Try
+ grepping for 'interpret' sometime.:-) Making this usable might
+ require cleaning up %DEFSTRUCT, %DEFUN, etc. to use EVAL-WHEN
+ instead of IR1 transform magic, which would be a good
+ thing in itself, but might be a fair amount of work.)
+FIX:
+ ?? Delete, delete, delete.
+-------------------------------------------------------------------------------
+PROBLEM:
+ The hashing code is new and should be tested.
+FIX:
+ ?? Enable the existing test code.
+-------------------------------------------------------------------------------
+PROBLEM:
+ My ad hoc system of revision control is looking pretty clunky,
+ and I've pretty much stopped doing stuff to confuse CVS (like moving
+ directories around).
+FIX:
+ ?? Check into CVS.
+ ?? Make sure that the tags in FILE-COMMENTs expand correctly.
+ ?? See about automatically propagating version information
+ from CVS into the runtime.c banner message and the
+ LISP-IMPLEMENTATION-VERSION string.
+===============================================================================
+other known issues with no particular target date:
+
+user manual including, at a minimum, updated versions of the
+CMU CL user manual information on the compiler and the alien
+interface
+
+bugs listed on the man page
+
+more regression tests
+
+various bugs fixed in CMUCL since this code was forked off of it
+ca. 19980801, since most of these haven't been fixed yet in SBCL
+
+byte compilation of appropriate parts of the system, so that the
+system core isn't so big
+
+uninterning needed-only-at-init-time stuff after init is complete,
+so that the system core isn't so big
+
+Search for unused external symbols (ones which are not bound, fbound,
+types, or whatever, and also have no other uses as e.g. flags) and
+delete them. This should make the system core a little smaller, but
+is mostly useful just to make the source code smaller and simpler.
+
+The eventual plan is for SBCL to bootstrap itself in two phases. In
+the first phase, the cross-compilation host is any old ANSI Common
+Lisp (not necessarily SBCL) and the cross-compiler won't handle some
+optimizations because the code it uses to implement them is not
+portable. In the second phase, the cross-compilation host will be
+required to be a compatible version of SBCL, and the cross-compiler
+will take advantage of that to implement all optimizations. The
+current version of SBCL only knows how to do the first of those two
+phases, with a fully-portable cross-compiler, so some optimizations
+are not done. Probably the most important consequence of this is that
+because the fully-portable cross-compiler isn't very smart about
+dealing with immediate values which are of specialized array type
+(e.g. (SIMPLE-ARRAY (UNSIGNED-BYTE 4) 1)) the system sometimes has to
+use unnecessarily-general array types internally.
+
+adding new FOPs to provide something like CMU CL's FOP-SYMBOL-SAVE and
+FOP-SMALL-SYMBOL-SAVE functionality, so that fasl files will be more
+compact. (FOP-SYMBOL-SAVE used *PACKAGE*, which was concise but allowed
+obscure bugs. Something like FOP-LAST-PACKAGE-SYMBOL-SAVE could have
+much of the same conciseness advantage without the bugs.)
+
+hundreds of FIXME notes in the sources from WHN
+
+various other unfinished business from CMU CL and before, marked with
+ "XX" or "XXX" or "###" or "***" or "???" or "pfw" or "@@@@" or "zzzzz"
+or probably also other codes that I haven't noticed or have forgotten.
+
+(Things marked as KLUDGE are in general things which are ugly or
+confusing, but that, for whatever reason, may stay that way
+indefinitely.)
--- /dev/null
+There are a number of hacks that I've used to make the system work
+that even I can see are ugly. Some which come to mind..
+
+It's dependent on being compiled in a rigid sequence, all in a single
+compilation pass, particularly in the cross-compilation phase.
+There's very little support for compiling modules in parallel
+or recompiling the system incrementally.
+
+The way the cross-compiler uses UNCROSS is ugly.
+
+The heavy use of %PYTHON:DEFMACRO to construct basic macros is
+arguably ugly. But it's better than what I tried before that, and the
+system is still slightly contaminated with fallout from what I tried..
+When I was first trying to bootstrap the system, I went off on a wild
+goose chase of trying to define everything (even fundamental macros
+like DEFUN and DEFMACRO) in terms of ordinary functions and Lisp
+special operators. I later realized that I could do without this, but
+a number of the changes that I made to the code while on that chase
+still live on, and the code is unnecessarily unclear because of them.
+
+The contrapuntal intertwingling of the cross-compiler and
+target Lisp build sequences is, well, baroque.
+
+Using host floating point numbers to represent target floating point
+numbers, or host characters to represent target characters, is theoretically
+shaky. (The characters are OK as long as the characters are
+in the ANSI-guaranteed character set, though.)
+
+Despite my attempts to make the compiler portable, it still makes assumptions
+about the cross-compilation host Common Lisp:
+ Simple bit vectors are distinct from simple vectors (in
+ DEFINE-STORAGE-BASE and elsewhere). (Actually, I'm not sure
+ that things would really break if this weren't so, but I
+ strongly suspect that they would.)
+ SINGLE-FLOAT is distinct from DOUBLE-FLOAT.
--- /dev/null
+;;;; tags which are set during the build process and which end up in
+;;;; CL:*FEATURES* in the target SBCL, plus some comments about other
+;;;; CL:*FEATURES* tags which have special meaning to SBCL or which
+;;;; have a special conventional meaning
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(
+ ;;
+ ;; features present in all builds
+ ;;
+
+ ;; our standard
+ :ansi-cl :common-lisp
+ ;; FIXME: Isn't there a :x3jsomething feature which we should set too?
+
+ ;; our dialect
+ :sbcl
+
+ ;; Douglas Thomas Crosher's conservative generational GC (the only one
+ ;; we currently support)
+ :gencgc
+
+ ;; We're running under a UNIX. This is sort of redundant, and it was also
+ ;; sort of redundant under CMU CL, which we inherited it from: neither SBCL
+ ;; nor CMU CL supports anything but UNIX (and "technically not UNIX"es
+ ;; such as *BSD and Linux). But someday, maybe we might, and in that case
+ ;; we'd presumably remove this, so its presence conveys the information
+ ;; that the system isn't one which follows such a change.
+ :unix
+
+ ;;
+ ;; features present in this particular build
+ ;;
+
+ ;; Setting this enables the compilation of documentation strings
+ ;; from the system sources into the target Lisp executable.
+ ;; Traditional Common Lisp folk will want this option set.
+ ;; I (WHN) made it optional because I came to Common Lisp from
+ ;; C++ through Scheme, so I'm accustomed to asking
+ ;; Emacs about things that I'm curious about instead of asking
+ ;; the executable I'm running.
+ :sb-doc
+
+ ;; When this is set, EVAL is implemented as an "IR1 interpreter":
+ ;; code is compiled into the compiler's first internal representation,
+ ;; then the IR1 is interpreted. When this is not set, EVAL is implemented
+ ;; as a little bit of hackery wrapped around a call to COMPILE, i.e.
+ ;; the system becomes a "compiler-only implementation" of Common Lisp.
+ ;; As of sbcl-0.6.7, the compiler-only implementation is prototype code,
+ ;; and much less mature than the old IR1 interpreter. Thus, the safe
+ ;; thing is to leave :SB-INTERPRETER set. However, the compiler-only
+ ;; system is noticeably smaller, so you might want to omit
+ ;; :SB-INTERPRETER if you have a small machine.
+ ;;
+ ;; Probably, the compiler-only implementation will become more
+ ;; stable someday, and support for the IR1 interpreter will then be
+ ;; dropped. This will make the system smaller and easier to maintain
+ ;; not only because we no longer need to support the interpreter,
+ ;; but because code elsewhere in the system (the dumper, the debugger,
+ ;; etc.) no longer needs special cases for interpreted code.
+ :sb-interpreter
+
+ ;; Do regression and other tests when building the system. You
+ ;; might or might not want this if you're not a developer,
+ ;; depending on how paranoid you are. You probably do want it if
+ ;; you are a developer.
+ :sb-test
+
+ ;; Setting this makes more debugging information available.
+ ;; If you aren't hacking or troubleshooting SBCL itself, you
+ ;; probably don't want this set.
+ ;;
+ ;; At least two varieties of debugging information are enabled by this
+ ;; option:
+ ;; * SBCL is compiled with a higher level of OPTIMIZE DEBUG, so that
+ ;; the debugger can tell more about the state of the system.
+ ;; * Various code to print debugging messages, and similar debugging code,
+ ;; is compiled only when this feature is present.
+ ;;
+ ;; Note that the extra information recorded by the compiler at
+ ;; this higher level of OPTIMIZE DEBUG includes the source location
+ ;; forms. In order for the debugger to use this information, it has to
+ ;; re-READ the source file. In an ordinary installation of SBCL, this
+ ;; re-READing may not work very well, for either of two reasons:
+ ;; * The sources aren't present on the system in the same location that
+ ;; they were on the system where SBCL was compiled.
+ ;; * SBCL is using the standard readtable, without the added hackage
+ ;; which allows it to handle things like target features.
+ ;; If you want to be able to use the extra debugging information,
+ ;; therefore, be sure to keep the sources around, and run with the
+ ;; readtable configured so that the system sources can be read.
+ ; :sb-show
+
+ ;; Enable extra debugging output in the assem.lisp assembler/scheduler
+ ;; code. (This is the feature which was called :DEBUG in the
+ ;; original CMU CL code.)
+ ; :sb-show-assem
+
+ ;; Setting this makes SBCL more "fluid", i.e. more amenable to
+ ;; modification at runtime, by suppressing various INLINE declarations,
+ ;; compiler macro definitions, FREEZE-TYPE declarations; and by
+ ;; suppressing various burning-our-ships-behind-us actions after
+ ;; initialization is complete; and so forth. This tends to clobber the
+ ;; performance of the system, so unless you have some special need for
+ ;; this when hacking SBCL itself, you don't want this set.
+ ; :sb-fluid
+
+ ;; Enable code for collecting statistics on usage of various operations,
+ ;; useful for performance tuning of the SBCL system itself. This code
+ ;; is probably pretty stale (having not been tested since the fork from
+ ;; base CMU CL) but might nonetheless be a useful starting point for
+ ;; anyone who wants to collect such statistics in the future.
+ ; :sb-dyncount
+
+ ;; Peter Van Eynde's increase-bulletproofness code
+ ;;
+ ;; This is not maintained or tested in current SBCL, but I haven't
+ ;; gone out of my way to remove or break it, either.
+ ;;
+ ; :high-security
+ ; :high-security-support
+
+ ;; multiprocessing support
+ ;;
+ ;; This is not maintained or tested in current SBCL. I haven't gone out
+ ;; of my way to break it, but since it's derived from an old version of
+ ;; CMU CL where multiprocessing was pretty shaky, it's likely to be very
+ ;; flaky now.
+ ;; :MP enables multiprocessing
+ ;; :MP-I486 is used, only within the multiprocessing code, to control
+ ;; what seems to control processor-version-specific code. It's
+ ;; probably for 486 or later, i.e. could be set as long as
+ ;; you know you're not running on a 386, but it doesn't seem
+ ;; to be documented anywhere, so that's just a guess.
+ ; :mp
+ ; :mp-i486
+
+ ;; KLUDGE: used to suppress stale code related to floating point infinities.
+ ;; I intend to delete this code completely some day, since it was a pain
+ ;; for me to try to work with and since all benefits it provides are
+ ;; non-portable. Until I actually pull the trigger, though, I've left
+ ;; various stale code in place protected with #!-SB-INFINITIES.
+ ; :sb-infinities
+
+ ;; This affects the definition of a lot of things in bignum.lisp. It
+ ;; doesn't seem to be documented anywhere what systems it might apply to.
+ ;; It doesn't seem to be needed for X86 systems anyway.
+ ; :32x16-divide
+
+ ;; This is probably true for some processor types, but not X86. It affects
+ ;; a lot of floating point code.
+ ; :negative-zero-is-not-zero
+
+ ;; This is mentioned in cmu-user.tex, which says that it enables
+ ;; the compiler to reason about integer arithmetic. It also seems to
+ ;; control other fancy numeric reasoning, e.g. knowing the result type of
+ ;; a remainder calculation given the type of its inputs.
+ ;;
+ ;; KLUDGE: Even when this is implemented for the target feature list,
+ ;; the code to implement this feature will not generated in the
+ ;; cross-compiler (i.e. will only be generated in the target compiler).
+ ;; The reason for this is that the interval arithmetic routines used
+ ;; to implement this feature are written under the assumption that
+ ;; Lisp arithmetic supports plus and minus infinity, which isn't guaranteed by
+ ;; ANSI Common Lisp. I've tried to mark the conditionals which implement
+ ;; this kludge with the string CROSS-FLOAT-INFINITY-KLUDGE so that
+ ;; sometime it might be possible to undo them (perhaps by using
+ ;; nice portable :PLUS-INFINITY and :MINUS-INFINITY values instead of
+ ;; implementation dependent floating infinity values, which would
+ ;; admittedly involve extra consing; or perhaps by finding some cleaner
+ ;; way of suppressing the construction of this code in the cross-compiler).
+ ;;
+ ;; KLUDGE: Even after doing the KLUDGE above, the cross-compiler doesn't work,
+ ;; because some interval operations are conditional on PROPAGATE-FUN-TYPE
+ ;; instead of PROPAGATE-FLOAT-TYPE. So for now, I've completely turned off
+ ;; both PROPAGATE-FUN-TYPE and PROPAGATE-FLOAT-TYPE. (After I build
+ ;; a compiler which works, then I can think about getting the optimization
+ ;; to work.) -- WHN 19990702
+ ; :propagate-float-type
+
+ ;; According to cmu-user.tex, this enables the compiler to infer result
+ ;; types for mathematical functions a la SQRT, EXPT, and LOG, allowing
+ ;; it to e.g. eliminate the possibility that a complex result will be
+ ;; generated.
+ ;;
+ ;; KLUDGE: turned off as per the comments for PROPAGATE-FLOAT-TYPE above
+ ; :propagate-fun-type
+
+ ;; It's unclear to me what this does (but it was enabled in the code that I
+ ;; picked up from Peter Van Eynde). -- WHN 19990224
+ :constrain-float-type
+
+ ;; This is set in classic CMU CL, and presumably there it means
+ ;; that the floating point arithmetic implementation
+ ;; conforms to IEEE's standard. Here it definitely means that the
+ ;; floating point arithmetic implementation conforms to IEEE's standard.
+ ;; I (WHN 19990702) haven't tried to verify
+ ;; that it does conform, but it should at least mostly conform (because
+ ;; the underlying x86 hardware tries).
+ :ieee-floating-point
+
+ ;; This seems to be the pre-GENCGC garbage collector for CMU CL, which was
+ ;; AFAIK never supported for the X86.
+ ; :gengc
+
+ ;; CMU CL had, and we inherited, code to support 80-bit LONG-FLOAT on the x86
+ ;; architecture. Nothing has been done to actively destroy the long float
+ ;; support, but it hasn't been thoroughly maintained, and needs at least
+ ;; some maintenance before it will work. (E.g. the LONG-FLOAT-only parts of
+ ;; genesis are still implemented in terms of unportable CMU CL functions
+ ;; which are not longer available at genesis time in SBCL.) A deeper
+ ;; problem is SBCL's bootstrap process implicitly assumes that the
+ ;; cross-compilation host will be able to make the same distinctions
+ ;; between floating point types that it does. This assumption is
+ ;; fundamentally sleazy, even though in practice it's unlikely to break down
+ ;; w.r.t. distinguishing SINGLE-FLOAT from DOUBLE-FLOAT; it's much more
+ ;; likely to break down w.r.t. distinguishing DOUBLE-FLOAT from LONG-FLOAT.
+ ;; Still it's likely to be quite doable to get LONG-FLOAT support working
+ ;; again, if anyone's sufficiently motivated.
+ ; :long-float
+
+ ;;
+ ;; miscellaneous notes on other things which could have special significance
+ ;; in the *FEATURES* list
+ ;;
+
+ ;; notes on the :NIL and :IGNORE features:
+ ;;
+ ;; #+NIL is used to comment out forms. Occasionally #+IGNORE is used
+ ;; for this too. So don't use :NIL or :IGNORE as the names of features..
+
+ ;; notes on :SB-XC and :SB-XC-HOST features (which aren't controlled by this
+ ;; file, but are instead temporarily pushed onto *FEATURES* or
+ ;; *TARGET-FEATURES* during some phases of cross-compilation):
+ ;;
+ ;; :SB-XC-HOST stands for "cross-compilation host" and is in *FEATURES*
+ ;; during the first phase of cross-compilation bootstrapping, when the
+ ;; host Lisp is being used to compile the cross-compiler.
+ ;;
+ ;; :SB-XC stands for "cross compiler", and is in *FEATURES* during the second
+ ;; phase of cross-compilation bootstrapping, when the cross-compiler is
+ ;; being used to create the first target Lisp.
+
+ ;; notes on the :SB-ASSEMBLING feature (which isn't controlled by
+ ;; this file):
+ ;;
+ ;; This is a flag for whether we're in the assembler. It's
+ ;; temporarily pushed onto the *FEATURES* list in the setup for
+ ;; the ASSEMBLE-FILE function. It would be a bad idea
+ ;; to use it as a name for a permanent feature.
+
+ ;; notes on local features (which are set automatically by the
+ ;; configuration script, and should not be set here unless you
+ ;; really, really know what you're doing):
+ ;;
+ ;; machine architecture features:
+ ;; :x86 ; any Intel 386 or better, or compatibles like the AMD K6 or K7
+ ;; (No others are supported by SBCL as of 0.6.7, but :alpha or
+ ;; :sparc support could be ported from CMU CL if anyone is
+ ;; sufficiently motivated to do so.)
+ ;; (CMU CL also had a :pentium feature, which affected the definition
+ ;; of some floating point vops. It was present but not enabled in the
+ ;; CMU CL code that SBCL is derived from, and is present but stale
+ ;; in SBCL as of 0.6.7.)
+ ;;
+ ;; operating system features:
+ ;; :linux = We're intended to run under some version of Linux.
+ ;; :bsd = We're intended to run under some version of BSD Unix. (This
+ ;; is not exclusive with the features which indicate which
+ ;; particular version of BSD we're intended to run under.)
+ ;; :freebsd = We're intended to run under FreeBSD.
+ ;; :openbsd = We're intended to run under FreeBSD.
+ ;; (No others are supported by SBCL as of 0.6.7, but :hpux or
+ ;; :solaris support could be ported from CMU CL if anyone is
+ ;; sufficiently motivated to do so.)
+ )
--- /dev/null
+#!/bin/sh
+
+# Create a binary distribution. (make.sh should be run first to create
+# the various binary files, and make-doc.sh, or possibly some other
+# DocBook-to-HTML converter, should also be run to create the
+# HTML version of the documentation.)
+
+tar cf ../sbcl-x.y.z-binary.tar \
+ output/sbcl.core src/runtime/sbcl \
+ BUGS COPYING CREDITS INSTALL NEWS README \
+ install.sh \
+ doc/sbcl.1 doc/cmucl/cmu-user doc/*.htm* \
+ pubring.pgp
--- /dev/null
+#!/bin/sh
+
+# Remove everything in directories which are only used for output.
+# In most cases, we can remove the directories, too.
+#
+# (We don't remove all the directories themselves for a stupid technical
+# reason: "gmake clean" in the src/runtime directory gets unhappy if the
+# output/ directory doesn't exist, because it tries to build Depends
+# before it cleans itself, and src/c-runtime/sbcl.h is a symlink into
+# the output/ directory, and it gets the gcc dependency processing gets
+# all confused trying to figure out a header file which is a symlink
+# into a directory which doesn't exist. We'd like to be able to run
+# this script (including "gmake clean" in the src/runtime directory)
+# several times in a row without failure.. so we leave the output/
+# directory in place.)
+rm -rf obj/* output/* doc/user-manual/ \
+ doc/user-manual.junk/ doc/DBTOHTML_OUTPUT_DIR*
+# (The doc/user-manual.junk/ and doc/DBTOHTML_OUTPUT_DIR* directories
+# are created when the Cygnus db2html script when it formats the the
+# user manual, and since this db2html script is the one which is
+# currently used to format the manual for the standard binary
+# distribution, we automatically clean up after it here in the
+# standard clean.sh file.)
+
+# Within other directories, remove things which don't look like source
+# files. Some explanations:
+# (symlinks)
+# are never in the sources; they must've been created
+# sbcl
+# the runtime environment, created by compiling C code
+# sbcl.h
+# information about Lisp code needed to build the runtime environment,
+# created by running GENESIS
+# Config, target
+# architecture-dependent or OS-dependent symlinks
+# *.htm, *.html
+# probably machine-generated translation of DocBook (*.sgml) files
+# core
+# probably a core dump -- not part of the sources anyway
+# *~, #*#, TAGS
+# common names for editor temporary files
+find . \( \
+ -type l -or \
+ -name '*~' -or \
+ -name '#*#' -or \
+ -name '?*.x86f' -or \
+ -name '?*.lbytef' -or \
+ -name 'core' -or \
+ -name '?*.core' -or \
+ -name '*.map' -or \
+ -name '*.nm' -or \
+ -name '*.host-obj' -or \
+ -name '*.lisp-obj' -or \
+ -name '*.target-obj' -or \
+ -name '*.lib' -or \
+ -name '*.tmp' -or \
+ -name '*.o' -or \
+ -name 'sbcl' -or \
+ -name 'sbcl.h' -or \
+ -name 'depend' -or \
+ -name '*.htm' -or \
+ -name '*.html' -or \
+ -name 'TAGS' -or \
+ -name 'local-target-features.lisp-expr' \) -print | xargs rm -f
--- /dev/null
+;;; symbols exported from the COMMON-LISP package (from the ANSI spec,
+;;; section 1.9, figures 1-4 to 1-15, inclusive)
+(
+ ;; from figure 1-4:
+ "&ALLOW-OTHER-KEYS" "*PRINT-MISER-WIDTH*"
+ "&AUX" "*PRINT-PPRINT-DISPATCH*"
+ "&BODY" "*PRINT-PRETTY*"
+ "&ENVIRONMENT" "*PRINT-RADIX*"
+ "&KEY" "*PRINT-READABLY*"
+ "&OPTIONAL" "*PRINT-RIGHT-MARGIN*"
+ "&REST" "*QUERY-IO*"
+ "&WHOLE" "*RANDOM-STATE*"
+ "*" "*READ-BASE*"
+ "**" "*READ-DEFAULT-FLOAT-FORMAT*"
+ "***" "*READ-EVAL*"
+ "*BREAK-ON-SIGNALS*" "*READ-SUPPRESS*"
+ "*COMPILE-FILE-PATHNAME*" "*READTABLE*"
+ "*COMPILE-FILE-TRUENAME*" "*STANDARD-INPUT*"
+ "*COMPILE-PRINT*" "*STANDARD-OUTPUT*"
+ "*COMPILE-VERBOSE*" "*TERMINAL-IO*"
+ "*DEBUG-IO*" "*TRACE-OUTPUT*"
+ "*DEBUGGER-HOOK*" "+"
+ "*DEFAULT-PATHNAME-DEFAULTS*" "++"
+ "*ERROR-OUTPUT*" "+++"
+ "*FEATURES*" "-"
+ "*GENSYM-COUNTER*" "/"
+ "*LOAD-PATHNAME*" "//"
+ "*LOAD-PRINT*" "///"
+ "*LOAD-TRUENAME*" "/="
+ "*LOAD-VERBOSE*" "1+"
+ "*MACROEXPAND-HOOK*" "1-"
+ "*MODULES*" "<"
+ "*PACKAGE*" "<="
+ "*PRINT-ARRAY*" "="
+ "*PRINT-BASE*" ">"
+ "*PRINT-CASE*" ">="
+ "*PRINT-CIRCLE*" "ABORT"
+ "*PRINT-ESCAPE*" "ABS"
+ "*PRINT-GENSYM*" "ACONS"
+ "*PRINT-LENGTH*" "ACOS"
+ "*PRINT-LEVEL*" "ACOSH"
+ "*PRINT-LINES*" "ADD-METHOD"
+
+ ;; from figure 1-5:
+ "ADJOIN" "ATOM" "BOUNDP"
+ "ADJUST-ARRAY" "BASE-CHAR" "BREAK"
+ "ADJUSTABLE-ARRAY-P" "BASE-STRING" "BROADCAST-STREAM"
+ "ALLOCATE-INSTANCE" "BIGNUM" "BROADCAST-STREAM-STREAMS"
+ "ALPHA-CHAR-P" "BIT" "BUILT-IN-CLASS"
+ "ALPHANUMERICP" "BIT-AND" "BUTLAST"
+ "AND" "BIT-ANDC1" "BYTE"
+ "APPEND" "BIT-ANDC2" "BYTE-POSITION"
+ "APPLY" "BIT-EQV" "BYTE-SIZE"
+ "APROPOS" "BIT-IOR" "CAAAAR"
+ "APROPOS-LIST" "BIT-NAND" "CAAADR"
+ "AREF" "BIT-NOR" "CAAAR"
+ "ARITHMETIC-ERROR" "BIT-NOT" "CAADAR"
+ "ARITHMETIC-ERROR-OPERANDS" "BIT-ORC1" "CAADDR"
+ "ARITHMETIC-ERROR-OPERATION" "BIT-ORC2" "CAADR"
+ "ARRAY" "BIT-VECTOR" "CAAR"
+ "ARRAY-DIMENSION" "BIT-VECTOR-P" "CADAAR"
+ "ARRAY-DIMENSION-LIMIT" "BIT-XOR" "CADADR"
+ "ARRAY-DIMENSIONS" "BLOCK" "CADAR"
+ "ARRAY-DISPLACEMENT" "BOOLE" "CADDAR"
+ "ARRAY-ELEMENT-TYPE" "BOOLE-1" "CADDDR"
+ "ARRAY-HAS-FILL-POINTER-P" "BOOLE-2" "CADDR"
+ "ARRAY-IN-BOUNDS-P" "BOOLE-AND" "CADR"
+ "ARRAY-RANK" "BOOLE-ANDC1" "CALL-ARGUMENTS-LIMIT"
+ "ARRAY-RANK-LIMIT" "BOOLE-ANDC2" "CALL-METHOD"
+ "ARRAY-ROW-MAJOR-INDEX" "BOOLE-C1" "CALL-NEXT-METHOD"
+ "ARRAY-TOTAL-SIZE" "BOOLE-C2" "CAR"
+ "ARRAY-TOTAL-SIZE-LIMIT" "BOOLE-CLR" "CASE"
+ "ARRAYP" "BOOLE-EQV" "CATCH"
+ "ASH" "BOOLE-IOR" "CCASE"
+ "ASIN" "BOOLE-NAND" "CDAAAR"
+ "ASINH" "BOOLE-NOR" "CDAADR"
+ "ASSERT" "BOOLE-ORC1" "CDAAR"
+ "ASSOC" "BOOLE-ORC2" "CDADAR"
+ "ASSOC-IF" "BOOLE-SET" "CDADDR"
+ "ASSOC-IF-NOT" "BOOLE-XOR" "CDADR"
+ "ATAN" "BOOLEAN" "CDAR"
+ "ATANH" "BOTH-CASE-P" "CDDAAR"
+
+ ;; from figure 1-6:
+ "CDDADR" "CLEAR-INPUT" "COPY-TREE"
+ "CDDAR" "CLEAR-OUTPUT" "COS"
+ "CDDDAR" "CLOSE" "COSH"
+ "CDDDDR" "CLRHASH" "COUNT"
+ "CDDDR" "CODE-CHAR" "COUNT-IF"
+ "CDDR" "COERCE" "COUNT-IF-NOT"
+ "CDR" "COMPILATION-SPEED" "CTYPECASE"
+ "CEILING" "COMPILE" "DEBUG"
+ "CELL-ERROR" "COMPILE-FILE" "DECF"
+ "CELL-ERROR-NAME" "COMPILE-FILE-PATHNAME" "DECLAIM"
+ "CERROR" "COMPILED-FUNCTION" "DECLARATION"
+ "CHANGE-CLASS" "COMPILED-FUNCTION-P" "DECLARE"
+ "CHAR" "COMPILER-MACRO" "DECODE-FLOAT"
+ "CHAR-CODE" "COMPILER-MACRO-FUNCTION" "DECODE-UNIVERSAL-TIME"
+ "CHAR-CODE-LIMIT" "COMPLEMENT" "DEFCLASS"
+ "CHAR-DOWNCASE" "COMPLEX" "DEFCONSTANT"
+ "CHAR-EQUAL" "COMPLEXP" "DEFGENERIC"
+ "CHAR-GREATERP" "COMPUTE-APPLICABLE-METHODS" "DEFINE-COMPILER-MACRO"
+ "CHAR-INT" "COMPUTE-RESTARTS" "DEFINE-CONDITION"
+ "CHAR-LESSP" "CONCATENATE" "DEFINE-METHOD-COMBINATION"
+ "CHAR-NAME" "CONCATENATED-STREAM" "DEFINE-MODIFY-MACRO"
+ "CHAR-NOT-EQUAL" "CONCATENATED-STREAM-STREAMS" "DEFINE-SETF-EXPANDER"
+ "CHAR-NOT-GREATERP" "COND" "DEFINE-SYMBOL-MACRO"
+ "CHAR-NOT-LESSP" "CONDITION" "DEFMACRO"
+ "CHAR-UPCASE" "CONJUGATE" "DEFMETHOD"
+ "CHAR/=" "CONS" "DEFPACKAGE"
+ "CHAR<" "CONSP" "DEFPARAMETER"
+ "CHAR<=" "CONSTANTLY" "DEFSETF"
+ "CHAR=" "CONSTANTP" "DEFSTRUCT"
+ "CHAR>" "CONTINUE" "DEFTYPE"
+ "CHAR>=" "CONTROL-ERROR" "DEFUN"
+ "CHARACTER" "COPY-ALIST" "DEFVAR"
+ "CHARACTERP" "COPY-LIST" "DELETE"
+ "CHECK-TYPE" "COPY-PPRINT-DISPATCH" "DELETE-DUPLICATES"
+ "CIS" "COPY-READTABLE" "DELETE-FILE"
+ "CLASS" "COPY-SEQ" "DELETE-IF"
+ "CLASS-NAME" "COPY-STRUCTURE" "DELETE-IF-NOT"
+ "CLASS-OF" "COPY-SYMBOL" "DELETE-PACKAGE"
+
+ ;; from figure 1-7:
+ "DENOMINATOR" "EQ"
+ "DEPOSIT-FIELD" "EQL"
+ "DESCRIBE" "EQUAL"
+ "DESCRIBE-OBJECT" "EQUALP"
+ "DESTRUCTURING-BIND" "ERROR"
+ "DIGIT-CHAR" "ETYPECASE"
+ "DIGIT-CHAR-P" "EVAL"
+ "DIRECTORY" "EVAL-WHEN"
+ "DIRECTORY-NAMESTRING" "EVENP"
+ "DISASSEMBLE" "EVERY"
+ "DIVISION-BY-ZERO" "EXP"
+ "DO" "EXPORT"
+ "DO*" "EXPT"
+ "DO-ALL-SYMBOLS" "EXTENDED-CHAR"
+ "DO-EXTERNAL-SYMBOLS" "FBOUNDP"
+ "DO-SYMBOLS" "FCEILING"
+ "DOCUMENTATION" "FDEFINITION"
+ "DOLIST" "FFLOOR"
+ "DOTIMES" "FIFTH"
+ "DOUBLE-FLOAT" "FILE-AUTHOR"
+ "DOUBLE-FLOAT-EPSILON" "FILE-ERROR"
+ "DOUBLE-FLOAT-NEGATIVE-EPSILON" "FILE-ERROR-PATHNAME"
+ "DPB" "FILE-LENGTH"
+ "DRIBBLE" "FILE-NAMESTRING"
+ "DYNAMIC-EXTENT" "FILE-POSITION"
+ "ECASE" "FILE-STREAM"
+ "ECHO-STREAM" "FILE-STRING-LENGTH"
+ "ECHO-STREAM-INPUT-STREAM" "FILE-WRITE-DATE"
+ "ECHO-STREAM-OUTPUT-STREAM" "FILL"
+ "ED" "FILL-POINTER"
+ "EIGHTH" "FIND"
+ "ELT" "FIND-ALL-SYMBOLS"
+ "ENCODE-UNIVERSAL-TIME" "FIND-CLASS"
+ "END-OF-FILE" "FIND-IF"
+ "ENDP" "FIND-IF-NOT"
+ "ENOUGH-NAMESTRING" "FIND-METHOD"
+ "ENSURE-DIRECTORIES-EXIST" "FIND-PACKAGE"
+ "ENSURE-GENERIC-FUNCTION" "FIND-RESTART"
+
+ ;; from figure 1-8:
+ "FIND-SYMBOL" "GET-INTERNAL-RUN-TIME"
+ "FINISH-OUTPUT" "GET-MACRO-CHARACTER"
+ "FIRST" "GET-OUTPUT-STREAM-STRING"
+ "FIXNUM" "GET-PROPERTIES"
+ "FLET" "GET-SETF-EXPANSION"
+ "FLOAT" "GET-UNIVERSAL-TIME"
+ "FLOAT-DIGITS" "GETF"
+ "FLOAT-PRECISION" "GETHASH"
+ "FLOAT-RADIX" "GO"
+ "FLOAT-SIGN" "GRAPHIC-CHAR-P"
+ "FLOATING-POINT-INEXACT" "HANDLER-BIND"
+ "FLOATING-POINT-INVALID-OPERATION" "HANDLER-CASE"
+ "FLOATING-POINT-OVERFLOW" "HASH-TABLE"
+ "FLOATING-POINT-UNDERFLOW" "HASH-TABLE-COUNT"
+ "FLOATP" "HASH-TABLE-P"
+ "FLOOR" "HASH-TABLE-REHASH-SIZE"
+ "FMAKUNBOUND" "HASH-TABLE-REHASH-THRESHOLD"
+ "FORCE-OUTPUT" "HASH-TABLE-SIZE"
+ "FORMAT" "HASH-TABLE-TEST"
+ "FORMATTER" "HOST-NAMESTRING"
+ "FOURTH" "IDENTITY"
+ "FRESH-LINE" "IF"
+ "FROUND" "IGNORABLE"
+ "FTRUNCATE" "IGNORE"
+ "FTYPE" "IGNORE-ERRORS"
+ "FUNCALL" "IMAGPART"
+ "FUNCTION" "IMPORT"
+ "FUNCTION-KEYWORDS" "IN-PACKAGE"
+ "FUNCTION-LAMBDA-EXPRESSION" "INCF"
+ "FUNCTIONP" "INITIALIZE-INSTANCE"
+ "GCD" "INLINE"
+ "GENERIC-FUNCTION" "INPUT-STREAM-P"
+ "GENSYM" "INSPECT"
+ "GENTEMP" "INTEGER"
+ "GET" "INTEGER-DECODE-FLOAT"
+ "GET-DECODED-TIME" "INTEGER-LENGTH"
+ "GET-DISPATCH-MACRO-CHARACTER" "INTEGERP"
+ "GET-INTERNAL-REAL-TIME" "INTERACTIVE-STREAM-P"
+
+ ;; from figure 1-9:
+ "INTERN" "LISP-IMPLEMENTATION-TYPE"
+ "INTERNAL-TIME-UNITS-PER-SECOND" "LISP-IMPLEMENTATION-VERSION"
+ "INTERSECTION" "LIST"
+ "INVALID-METHOD-ERROR" "LIST*"
+ "INVOKE-DEBUGGER" "LIST-ALL-PACKAGES"
+ "INVOKE-RESTART" "LIST-LENGTH"
+ "INVOKE-RESTART-INTERACTIVELY" "LISTEN"
+ "ISQRT" "LISTP"
+ "KEYWORD" "LOAD"
+ "KEYWORDP" "LOAD-LOGICAL-PATHNAME-TRANSLATIONS"
+ "LABELS" "LOAD-TIME-VALUE"
+ "LAMBDA" "LOCALLY"
+ "LAMBDA-LIST-KEYWORDS" "LOG"
+ "LAMBDA-PARAMETERS-LIMIT" "LOGAND"
+ "LAST" "LOGANDC1"
+ "LCM" "LOGANDC2"
+ "LDB" "LOGBITP"
+ "LDB-TEST" "LOGCOUNT"
+ "LDIFF" "LOGEQV"
+ "LEAST-NEGATIVE-DOUBLE-FLOAT" "LOGICAL-PATHNAME"
+ "LEAST-NEGATIVE-LONG-FLOAT" "LOGICAL-PATHNAME-TRANSLATIONS"
+ "LEAST-NEGATIVE-NORMALIZED-DOUBLE-FLOAT" "LOGIOR"
+ "LEAST-NEGATIVE-NORMALIZED-LONG-FLOAT" "LOGNAND"
+ "LEAST-NEGATIVE-NORMALIZED-SHORT-FLOAT" "LOGNOR"
+ "LEAST-NEGATIVE-NORMALIZED-SINGLE-FLOAT" "LOGNOT"
+ "LEAST-NEGATIVE-SHORT-FLOAT" "LOGORC1"
+ "LEAST-NEGATIVE-SINGLE-FLOAT" "LOGORC2"
+ "LEAST-POSITIVE-DOUBLE-FLOAT" "LOGTEST"
+ "LEAST-POSITIVE-LONG-FLOAT" "LOGXOR"
+ "LEAST-POSITIVE-NORMALIZED-DOUBLE-FLOAT" "LONG-FLOAT"
+ "LEAST-POSITIVE-NORMALIZED-LONG-FLOAT" "LONG-FLOAT-EPSILON"
+ "LEAST-POSITIVE-NORMALIZED-SHORT-FLOAT" "LONG-FLOAT-NEGATIVE-EPSILON"
+ "LEAST-POSITIVE-NORMALIZED-SINGLE-FLOAT" "LONG-SITE-NAME"
+ "LEAST-POSITIVE-SHORT-FLOAT" "LOOP"
+ "LEAST-POSITIVE-SINGLE-FLOAT" "LOOP-FINISH"
+ "LENGTH" "LOWER-CASE-P"
+ "LET" "MACHINE-INSTANCE"
+ "LET*" "MACHINE-TYPE"
+
+ ;; from figure 1-10:
+ "MACHINE-VERSION" "MASK-FIELD"
+ "MACRO-FUNCTION" "MAX"
+ "MACROEXPAND" "MEMBER"
+ "MACROEXPAND-1" "MEMBER-IF"
+ "MACROLET" "MEMBER-IF-NOT"
+ "MAKE-ARRAY" "MERGE"
+ "MAKE-BROADCAST-STREAM" "MERGE-PATHNAMES"
+ "MAKE-CONCATENATED-STREAM" "METHOD"
+ "MAKE-CONDITION" "METHOD-COMBINATION"
+ "MAKE-DISPATCH-MACRO-CHARACTER" "METHOD-COMBINATION-ERROR"
+ "MAKE-ECHO-STREAM" "METHOD-QUALIFIERS"
+ "MAKE-HASH-TABLE" "MIN"
+ "MAKE-INSTANCE" "MINUSP"
+ "MAKE-INSTANCES-OBSOLETE" "MISMATCH"
+ "MAKE-LIST" "MOD"
+ "MAKE-LOAD-FORM" "MOST-NEGATIVE-DOUBLE-FLOAT"
+ "MAKE-LOAD-FORM-SAVING-SLOTS" "MOST-NEGATIVE-FIXNUM"
+ "MAKE-METHOD" "MOST-NEGATIVE-LONG-FLOAT"
+ "MAKE-PACKAGE" "MOST-NEGATIVE-SHORT-FLOAT"
+ "MAKE-PATHNAME" "MOST-NEGATIVE-SINGLE-FLOAT"
+ "MAKE-RANDOM-STATE" "MOST-POSITIVE-DOUBLE-FLOAT"
+ "MAKE-SEQUENCE" "MOST-POSITIVE-FIXNUM"
+ "MAKE-STRING" "MOST-POSITIVE-LONG-FLOAT"
+ "MAKE-STRING-INPUT-STREAM" "MOST-POSITIVE-SHORT-FLOAT"
+ "MAKE-STRING-OUTPUT-STREAM" "MOST-POSITIVE-SINGLE-FLOAT"
+ "MAKE-SYMBOL" "MUFFLE-WARNING"
+ "MAKE-SYNONYM-STREAM" "MULTIPLE-VALUE-BIND"
+ "MAKE-TWO-WAY-STREAM" "MULTIPLE-VALUE-CALL"
+ "MAKUNBOUND" "MULTIPLE-VALUE-LIST"
+ "MAP" "MULTIPLE-VALUE-PROG1"
+ "MAP-INTO" "MULTIPLE-VALUE-SETQ"
+ "MAPC" "MULTIPLE-VALUES-LIMIT"
+ "MAPCAN" "NAME-CHAR"
+ "MAPCAR" "NAMESTRING"
+ "MAPCON" "NBUTLAST"
+ "MAPHASH" "NCONC"
+ "MAPL" "NEXT-METHOD-P"
+ "MAPLIST" "NIL"
+
+ ;; from figure 1-11:
+ "NINTERSECTION" "PACKAGE-ERROR"
+ "NINTH" "PACKAGE-ERROR-PACKAGE"
+ "NO-APPLICABLE-METHOD" "PACKAGE-NAME"
+ "NO-NEXT-METHOD" "PACKAGE-NICKNAMES"
+ "NOT" "PACKAGE-SHADOWING-SYMBOLS"
+ "NOTANY" "PACKAGE-USE-LIST"
+ "NOTEVERY" "PACKAGE-USED-BY-LIST"
+ "NOTINLINE" "PACKAGEP"
+ "NRECONC" "PAIRLIS"
+ "NREVERSE" "PARSE-ERROR"
+ "NSET-DIFFERENCE" "PARSE-INTEGER"
+ "NSET-EXCLUSIVE-OR" "PARSE-NAMESTRING"
+ "NSTRING-CAPITALIZE" "PATHNAME"
+ "NSTRING-DOWNCASE" "PATHNAME-DEVICE"
+ "NSTRING-UPCASE" "PATHNAME-DIRECTORY"
+ "NSUBLIS" "PATHNAME-HOST"
+ "NSUBST" "PATHNAME-MATCH-P"
+ "NSUBST-IF" "PATHNAME-NAME"
+ "NSUBST-IF-NOT" "PATHNAME-TYPE"
+ "NSUBSTITUTE" "PATHNAME-VERSION"
+ "NSUBSTITUTE-IF" "PATHNAMEP"
+ "NSUBSTITUTE-IF-NOT" "PEEK-CHAR"
+ "NTH" "PHASE"
+ "NTH-VALUE" "PI"
+ "NTHCDR" "PLUSP"
+ "NULL" "POP"
+ "NUMBER" "POSITION"
+ "NUMBERP" "POSITION-IF"
+ "NUMERATOR" "POSITION-IF-NOT"
+ "NUNION" "PPRINT"
+ "ODDP" "PPRINT-DISPATCH"
+ "OPEN" "PPRINT-EXIT-IF-LIST-EXHAUSTED"
+ "OPEN-STREAM-P" "PPRINT-FILL"
+ "OPTIMIZE" "PPRINT-INDENT"
+ "OR" "PPRINT-LINEAR"
+ "OTHERWISE" "PPRINT-LOGICAL-BLOCK"
+ "OUTPUT-STREAM-P" "PPRINT-NEWLINE"
+ "PACKAGE" "PPRINT-POP"
+
+ ;; from figure 1-12:
+ "PPRINT-TAB" "READ-CHAR"
+ "PPRINT-TABULAR" "READ-CHAR-NO-HANG"
+ "PRIN1" "READ-DELIMITED-LIST"
+ "PRIN1-TO-STRING" "READ-FROM-STRING"
+ "PRINC" "READ-LINE"
+ "PRINC-TO-STRING" "READ-PRESERVING-WHITESPACE"
+ "PRINT" "READ-SEQUENCE"
+ "PRINT-NOT-READABLE" "READER-ERROR"
+ "PRINT-NOT-READABLE-OBJECT" "READTABLE"
+ "PRINT-OBJECT" "READTABLE-CASE"
+ "PRINT-UNREADABLE-OBJECT" "READTABLEP"
+ "PROBE-FILE" "REAL"
+ "PROCLAIM" "REALP"
+ "PROG" "REALPART"
+ "PROG*" "REDUCE"
+ "PROG1" "REINITIALIZE-INSTANCE"
+ "PROG2" "REM"
+ "PROGN" "REMF"
+ "PROGRAM-ERROR" "REMHASH"
+ "PROGV" "REMOVE"
+ "PROVIDE" "REMOVE-DUPLICATES"
+ "PSETF" "REMOVE-IF"
+ "PSETQ" "REMOVE-IF-NOT"
+ "PUSH" "REMOVE-METHOD"
+ "PUSHNEW" "REMPROP"
+ "QUOTE" "RENAME-FILE"
+ "RANDOM" "RENAME-PACKAGE"
+ "RANDOM-STATE" "REPLACE"
+ "RANDOM-STATE-P" "REQUIRE"
+ "RASSOC" "REST"
+ "RASSOC-IF" "RESTART"
+ "RASSOC-IF-NOT" "RESTART-BIND"
+ "RATIO" "RESTART-CASE"
+ "RATIONAL" "RESTART-NAME"
+ "RATIONALIZE" "RETURN"
+ "RATIONALP" "RETURN-FROM"
+ "READ" "REVAPPEND"
+ "READ-BYTE" "REVERSE"
+
+ ;; from figure 1-13:
+ "ROOM" "SIMPLE-BIT-VECTOR"
+ "ROTATEF" "SIMPLE-BIT-VECTOR-P"
+ "ROUND" "SIMPLE-CONDITION"
+ "ROW-MAJOR-AREF" "SIMPLE-CONDITION-FORMAT-ARGUMENTS"
+ "RPLACA" "SIMPLE-CONDITION-FORMAT-CONTROL"
+ "RPLACD" "SIMPLE-ERROR"
+ "SAFETY" "SIMPLE-STRING"
+ "SATISFIES" "SIMPLE-STRING-P"
+ "SBIT" "SIMPLE-TYPE-ERROR"
+ "SCALE-FLOAT" "SIMPLE-VECTOR"
+ "SCHAR" "SIMPLE-VECTOR-P"
+ "SEARCH" "SIMPLE-WARNING"
+ "SECOND" "SIN"
+ "SEQUENCE" "SINGLE-FLOAT"
+ "SERIOUS-CONDITION" "SINGLE-FLOAT-EPSILON"
+ "SET" "SINGLE-FLOAT-NEGATIVE-EPSILON"
+ "SET-DIFFERENCE" "SINH"
+ "SET-DISPATCH-MACRO-CHARACTER" "SIXTH"
+ "SET-EXCLUSIVE-OR" "SLEEP"
+ "SET-MACRO-CHARACTER" "SLOT-BOUNDP"
+ "SET-PPRINT-DISPATCH" "SLOT-EXISTS-P"
+ "SET-SYNTAX-FROM-CHAR" "SLOT-MAKUNBOUND"
+ "SETF" "SLOT-MISSING"
+ "SETQ" "SLOT-UNBOUND"
+ "SEVENTH" "SLOT-VALUE"
+ "SHADOW" "SOFTWARE-TYPE"
+ "SHADOWING-IMPORT" "SOFTWARE-VERSION"
+ "SHARED-INITIALIZE" "SOME"
+ "SHIFTF" "SORT"
+ "SHORT-FLOAT" "SPACE"
+ "SHORT-FLOAT-EPSILON" "SPECIAL"
+ "SHORT-FLOAT-NEGATIVE-EPSILON" "SPECIAL-OPERATOR-P"
+ "SHORT-SITE-NAME" "SPEED"
+ "SIGNAL" "SQRT"
+ "SIGNED-BYTE" "STABLE-SORT"
+ "SIGNUM" "STANDARD"
+ "SIMPLE-ARRAY" "STANDARD-CHAR"
+ "SIMPLE-BASE-STRING" "STANDARD-CHAR-P"
+
+ ;; from figure 1-14:
+ "STANDARD-CLASS" "SUBLIS"
+ "STANDARD-GENERIC-FUNCTION" "SUBSEQ"
+ "STANDARD-METHOD" "SUBSETP"
+ "STANDARD-OBJECT" "SUBST"
+ "STEP" "SUBST-IF"
+ "STORAGE-CONDITION" "SUBST-IF-NOT"
+ "STORE-VALUE" "SUBSTITUTE"
+ "STREAM" "SUBSTITUTE-IF"
+ "STREAM-ELEMENT-TYPE" "SUBSTITUTE-IF-NOT"
+ "STREAM-ERROR" "SUBTYPEP"
+ "STREAM-ERROR-STREAM" "SVREF"
+ "STREAM-EXTERNAL-FORMAT" "SXHASH"
+ "STREAMP" "SYMBOL"
+ "STRING" "SYMBOL-FUNCTION"
+ "STRING-CAPITALIZE" "SYMBOL-MACROLET"
+ "STRING-DOWNCASE" "SYMBOL-NAME"
+ "STRING-EQUAL" "SYMBOL-PACKAGE"
+ "STRING-GREATERP" "SYMBOL-PLIST"
+ "STRING-LEFT-TRIM" "SYMBOL-VALUE"
+ "STRING-LESSP" "SYMBOLP"
+ "STRING-NOT-EQUAL" "SYNONYM-STREAM"
+ "STRING-NOT-GREATERP" "SYNONYM-STREAM-SYMBOL"
+ "STRING-NOT-LESSP" "T"
+ "STRING-RIGHT-TRIM" "TAGBODY"
+ "STRING-STREAM" "TAILP"
+ "STRING-TRIM" "TAN"
+ "STRING-UPCASE" "TANH"
+ "STRING/=" "TENTH"
+ "STRING<" "TERPRI"
+ "STRING<=" "THE"
+ "STRING=" "THIRD"
+ "STRING>" "THROW"
+ "STRING>=" "TIME"
+ "STRINGP" "TRACE"
+ "STRUCTURE" "TRANSLATE-LOGICAL-PATHNAME"
+ "STRUCTURE-CLASS" "TRANSLATE-PATHNAME"
+ "STRUCTURE-OBJECT" "TREE-EQUAL"
+ "STYLE-WARNING" "TRUENAME"
+
+ ;; from figure 1-15:
+ "TRUNCATE" "VALUES-LIST"
+ "TWO-WAY-STREAM" "VARIABLE"
+ "TWO-WAY-STREAM-INPUT-STREAM" "VECTOR"
+ "TWO-WAY-STREAM-OUTPUT-STREAM" "VECTOR-POP"
+ "TYPE" "VECTOR-PUSH"
+ "TYPE-ERROR" "VECTOR-PUSH-EXTEND"
+ "TYPE-ERROR-DATUM" "VECTORP"
+ "TYPE-ERROR-EXPECTED-TYPE" "WARN"
+ "TYPE-OF" "WARNING"
+ "TYPECASE" "WHEN"
+ "TYPEP" "WILD-PATHNAME-P"
+ "UNBOUND-SLOT" "WITH-ACCESSORS"
+ "UNBOUND-SLOT-INSTANCE" "WITH-COMPILATION-UNIT"
+ "UNBOUND-VARIABLE" "WITH-CONDITION-RESTARTS"
+ "UNDEFINED-FUNCTION" "WITH-HASH-TABLE-ITERATOR"
+ "UNEXPORT" "WITH-INPUT-FROM-STRING"
+ "UNINTERN" "WITH-OPEN-FILE"
+ "UNION" "WITH-OPEN-STREAM"
+ "UNLESS" "WITH-OUTPUT-TO-STRING"
+ "UNREAD-CHAR" "WITH-PACKAGE-ITERATOR"
+ "UNSIGNED-BYTE" "WITH-SIMPLE-RESTART"
+ "UNTRACE" "WITH-SLOTS"
+ "UNUSE-PACKAGE" "WITH-STANDARD-IO-SYNTAX"
+ "UNWIND-PROTECT" "WRITE"
+ "UPDATE-INSTANCE-FOR-DIFFERENT-CLASS" "WRITE-BYTE"
+ "UPDATE-INSTANCE-FOR-REDEFINED-CLASS" "WRITE-CHAR"
+ "UPGRADED-ARRAY-ELEMENT-TYPE" "WRITE-LINE"
+ "UPGRADED-COMPLEX-PART-TYPE" "WRITE-SEQUENCE"
+ "UPPER-CASE-P" "WRITE-STRING"
+ "USE-PACKAGE" "WRITE-TO-STRING"
+ "USE-VALUE" "Y-OR-N-P"
+ "USER-HOMEDIR-PATHNAME" "YES-OR-NO-P"
+ "VALUES" "ZEROP")
--- /dev/null
+This directory is for extensions to SBCL. They aren't necessary for
+core SBCL functionality, or else they'd be built into the main SBCL
+binary automatically. And they're not portable Common Lisp, or they'd
+be put elsewhere (e.g. http://clocc.sourceforge.net/).
+
+Some good candidates for future extensions here are:
+ * bindings to existing foreign libraries (e.g. to a regexp library
+ like PCRE, or to a compression library like zlib, or to a graphics
+ library like Tk)
+ * new libraries (e.g. a CORBA interface, or a port of the CMU CL
+ POSIX functions, or a new higher-level POSIX functions)
+ * low-level hooks into SBCL needed to interface it to some wrapper
+ system (e.g. to interface to a graphical debugger of some sort)
+ * a too-alpha-to-be-supported-yet tree shaker
+
+SBCL extensions of less general interest, e.g. a binding to the C
+interface of the Oracle RDBMS, or particularly large extensions, e.g.
+big graphics frameworks, can also be associated with the SBCL project,
+but instead of being included in this directory as part of the
+distribution, they will be made available on the SBCL project web
+site.
--- /dev/null
+From sbcl-devel-admin@lists.sourceforge.net Sun Jul 16 12:10:07 2000
+Received: from localhost (IDENT:newman@localhost.localdomain [127.0.0.1])
+ by rootless.localdomain (8.9.3/8.9.3) with ESMTP id MAA07245
+ for <newman@localhost>; Sun, 16 Jul 2000 12:10:05 -0500 (CDT)
+Received: from mail.airmail.net
+ by localhost with POP3 (fetchmail-5.1.1)
+ for newman@localhost (single-drop); Sun, 16 Jul 2000 12:10:06 -0500 (CDT)
+Received: from lists.sourceforge.net from [198.186.203.35] by mail.airmail.net
+ (/\##/\ Smail3.1.30.16 #30.438) with esmtp for <william.newman@airmail.net> sender: <sbcl-devel-admin@lists.sourceforge.net>
+ id <mn/13DanY-000GXOn@mail.airmail.net>; Sat, 15 Jul 2000 17:52:40 -0500 (CDT)
+Received: from mail1.sourceforge.net (localhost [127.0.0.1])
+ by lists.sourceforge.net (8.9.3/8.9.3) with ESMTP id PAA03497;
+ Sat, 15 Jul 2000 15:52:33 -0700
+Received: from tninkpad.telent.net (detached.demon.co.uk [194.222.13.128])
+ by lists.sourceforge.net (8.9.3/8.9.3) with ESMTP id PAA03477
+ for <sbcl-devel@lists.sourceforge.net>; Sat, 15 Jul 2000 15:52:28 -0700
+Received: from dan by tninkpad.telent.net with local (Exim 3.12 #1 (Debian))
+ id 13Daly-0002eu-00; Sat, 15 Jul 2000 23:51:02 +0100
+To: sbcl-devel@lists.sourceforge.net
+From: Daniel Barlow <dan@telent.net>
+Date: 15 Jul 2000 23:51:02 +0100
+Message-ID: <87og3zvwh5.fsf@tninkpad.telent.net>
+User-Agent: Gnus/5.0803 (Gnus v5.8.3) Emacs/20.7
+MIME-Version: 1.0
+Content-Type: multipart/mixed; boundary="=-=-="
+Subject: [Sbcl-devel] LINK-SYSTEM - "How big is a `hello world' program in SBCL?"
+Sender: sbcl-devel-admin@lists.sourceforge.net
+Errors-To: sbcl-devel-admin@lists.sourceforge.net
+X-Mailman-Version: 1.1
+Precedence: bulk
+List-Id: <sbcl-devel.lists.sourceforge.net>
+X-BeenThere: sbcl-devel@lists.sourceforge.net
+X-Airmail-Delivered: Sat, 15 Jul 2000 17:52:40 -0500 (CDT)
+X-Airmail-Spooled: Sat, 15 Jul 2000 17:52:40 -0500 (CDT)
+Status: RO
+Content-Length: 8179
+Lines: 80
+
+--=-=-=
+
+
+1103 bytes. :-)
+
+The problem I wanted to solve here is that of making sbcl programs
+that run from the command line and look superficially like normal unix
+executables (in, say, the same way as shell scripts or Perl programs
+do). The programs in question are expected to run on a system with
+sbcl installed (there's a core file, and a runtime, etc) but have to
+share the same core file and not each dump their own. Disk may be
+cheap but it's not _that_ cheap ...
+
+This is achieved using shell #! magic and concatenation of fasl files.
+
+STANDALONEIZE-FILE, given a collection of x86f files, makes a single
+file that can be run from the shell prompt. The file consists of
+the concatenation of all the x86f files, appended to #! magic which
+invokes sbcl on them.
+
+LINK-SYSTEM operates with mk-defsystem (get it from CLOCC) to build a similar
+file from a system definition. It currently breaks if the system has
+non-Lisp components (e.g. db-sockets, which loads .so objects)
+
+
+Here's how you use it:
+
+ :; cat hello.lisp
+ (in-package :cl-user)
+
+ (format t "hello world ~%")
+ (quit)
+
+ :; sbcl --noinform --core testcore.core --eval '(progn (compile-file "hello.lisp") (standaloneize:standaloneize-file "hello" "hello.x86f") (quit))'
+ compiling "/home/dan/src/telent/lisploader/hello.lisp" (written 15 JUL 2000 10:27:45 PM):
+
+ byte compiling top-level form:
+ byte compiling top-level form:
+ byte compiling top-level form:
+
+ hello.x86f written
+ compilation finished in 0:00:00
+
+ :; ls -l hello
+ -rwxr-xr-x 1 dan dan 1103 Jul 15 22:43 hello
+
+ :; time ./hello
+ hello world
+
+ real 0m0.116s
+ user 0m0.040s
+ sys 0m0.060s
+
+It also understands search paths ...
+
+ :; cp hello ~/bin
+ :; type hello
+ hello is /home/dan/bin/hello
+ :; hello
+ hello world
+
+So how about that? 1k executables and 1/10th second startup times.
+It helps that I already have another instance of sbcl open, of course :-)
+
+The whole thing is only about 5k, so I enclose it here as an
+attachment. Build instructions are in the comment at the top. You
+have to dump a core file with it compiled in, but the point is that
+you only have to do so once per sbcl, not once per application.
+
+I hope this will (eventually, anyway) encourage use of SBCL by people
+wanting to solve "scripting" problems. The unix shell may be ugly,
+but it's not going away any time soon, so it helps if we play nice
+with it.
+
+
+--=-=-=
+Content-Disposition: attachment; filename=heuristic-fasload.lisp
+
+(eval-when (:compile-toplevel :load-toplevel)
+ (defpackage "STANDALONEIZE"
+ (:use :sb-alien :sb-c-call :common-lisp)
+ (:export standaloneize-file)))
+(in-package :standaloneize)
+
+;;;; Functions useful for making sbcl do sensible stuff with #!
+;;;; (STANDALONEIZE-FILE output-file input-files) gloms the input files
+;;;; together and sticks shell magic on top. FIND-AND-LOAD-FASL and its
+;;;; supporting functions are called when the file is executed
+
+;;;; How to use it. Compile this file. Load it into a fresh SBCL image.
+;;;; Dump a core file. Use that core file.
+
+(defun find-fasl-in-stream (stream)
+ "Search forwards in STREAM for a line starting with the value of sb-c:*fasl-header-string-start-string*. Leave the stream at the offset of the start of that line, and return the offset"
+ (let ((fasl-cookie sb-c:*fasl-header-string-start-string*))
+ (loop for position = (file-position stream)
+ for text = (read-line stream)
+ ;;do (format t "~A ~A ~A ~%" position text fasl-cookie)
+ if (and text
+ (>= (length (the simple-string text))
+ (length fasl-cookie))
+ (string= text fasl-cookie :end1 (length fasl-cookie)))
+ return (progn (file-position stream position) position))))
+
+
+;;; This courtesy of Pierre Mai in comp.lang.lisp 08 Jan 1999 00:51:44 +0100
+;;; Message-ID: <87lnjebq0f.fsf@orion.dent.isdn.cs.tu-berlin.de>
+
+(defun split (string &optional max (ws '(#\Space #\Tab)))
+ "Split `string' along whitespace as defined by the sequence `ws'.
+The whitespace is elided from the result. The whole string will be
+split, unless `max' is a non-negative integer, in which case the
+string will be split into `max' tokens at most, the last one
+containing the whole rest of the given `string', if any."
+ (flet ((is-ws (char) (find char ws)))
+ (loop for start = (position-if-not #'is-ws string)
+ then (position-if-not #'is-ws string :start index)
+ for index = (and start
+ (if (and max (= (1+ word-count) max))
+ nil
+ (position-if #'is-ws string :start start)))
+ while start
+ collect (subseq string start index)
+ count 1 into word-count
+ while index)))
+
+(defun find-name-on-path (name)
+ (let* ((search-string (or (sb-ext:posix-getenv "PATH")
+ ":/bin:/usr/bin"))
+ (search-list (split search-string nil '(#\:))))
+ (or
+ (loop for p in search-list
+ for directory = (merge-pathnames (make-pathname :directory p))
+ if (probe-file (merge-pathnames name directory))
+ return (merge-pathnames name directory))
+ name)))
+
+(defun find-and-load-fasl (name)
+ "Attempt to find and load a FASL file from NAME. FASL data in the file may be preceded by any number of lines of arbitrary text. If NAME contains no directory portion, it is searched for on the system path in a manner similar to that of execvp(3)"
+ (let ((path
+ (if (pathname-directory name)
+ name
+ (find-name-on-path name))))
+ (with-open-file (i path :direction :input)
+ (find-fasl-in-stream i)
+ (sb-impl::fasload i nil nil))))
+
+;;;; and now some functions for more easily creating these scuffed fasl files
+
+(defun copy-stream (from to)
+ "Copy into TO from FROM until end of file, without translating or otherwise mauling anything"
+ (let ((buf (make-array 4096 :element-type (stream-element-type from)
+ :initial-element #\Space)))
+ (do ((pos (read-sequence buf from) (read-sequence buf from)))
+ ((= 0 pos) nil)
+ (write-sequence buf to :end pos))))
+
+(defparameter *standalone-magic*
+ "#!/bin/sh
+exec /usr/local/bin/sbcl --core testcore.core --noinform --noprint --eval \"(standaloneize::find-and-load-fasl \\\"$0\\\")\" $*
+"
+ "This text is prepended to the output file created by STANDALONEIZE-FILE")
+
+;;; this syscall seems to have been removed from SBCL.
+(def-alien-routine chmod int (path c-string) (mode int))
+
+(defun standaloneize-file (output-filename &rest objects)
+ "Make a standalone executable(sic) called OUTPUT-FILENAME out of OBJECTS, through the magic of hash bang."
+ (with-open-file (out output-filename :direction :output)
+ (write-sequence *standalone-magic* out)
+ (dolist (obj objects)
+ (with-open-file (in obj)
+ (copy-stream in out))))
+ (chmod (namestring output-filename) #o755))
+
+;;;; Another way of doing it would be to create a "link" operation for
+;;;; systems defined with mk-defsystem -
+
+#+mk-defsystem
+(defun print-binary-file-operation (component force)
+ "Spit the binary file associated with COMPONENT to *STANDARD-OUTPUT*"
+ (with-open-file (i (compile-file-pathname
+ (make::component-pathname component :binary))
+ :direction :input)
+ (copy-stream i *standard-output*))
+ nil)
+
+#+mk-defsystem
+(defun link-system (system output-file)
+ "Create a single executable file from all the files in SYSTEM"
+ (make::component-operation 'print-binary 'print-binary-file-operation)
+ (with-open-file (o output-file :direction :output
+ :if-exists :rename)
+ (write-sequence *standalone-magic* o)
+ (let ((*standard-output* o))
+ (make::operate-on-system system 'print-binary))))
+
+
+--=-=-=
+
+
+
+-dan
+
+--
+ http://ww.telent.net/cliki/ - CLiki: CL/Unix free software link farm
+
+--=-=-=--
+
+_______________________________________________
+Sbcl-devel mailing list
+Sbcl-devel@lists.sourceforge.net
+http://lists.sourceforge.net/mailman/listinfo/sbcl-devel
+
--- /dev/null
+This document was motivated by a request from Paolo Amoroso for notes
+or other documentation on my work on SBCL. It's intended for
+developers who are familiar with the guts of CMU CL, as an overview of
+the changes made to CMU CL in order to produce SBCL. It was written
+for the initial release (sbcl-0.5.0) and has not been updated since
+then.
+
+There are two sections in this report:
+ I. non-fundamental changes
+ II. fundamental changes
+In this context, fundamental changes are changes which were
+directly driven by the goal of making the system bootstrap itself.
+
+
+Section I: non-fundamental changes
+
+Before I describe the fundamental changes I had to make in order to
+get the system to bootstrap itself, let me emphasize that there are
+many non-fundamental changes as well. I won't try to summarize them
+all, but I'll mention some to give some idea. (Some more information
+about why I made some of these changes is in the PRINCIPLES file in
+the distribution.)
+
+Many, many extensions have been removed.
+
+Packages have all been renamed; in the final system,
+the system packages have names which begin with "SB-".
+Mostly these correspond closely to CMU CL packages,
+e.g. the "C" package of CMU CL has become the "SB-C" package,
+and the "EXTENSIONS" package of CMU CL has become the "SB-EXT"
+package.
+
+Some other definitions and declarations have been centralized, too.
+E.g. the build order is defined in one place, and all the COMMON-LISP
+special variables are declared in one place.
+
+I've made various reformatting changes in the comments, and
+added a number of comments.
+
+INFO is now implemented as a function instead of a macro,
+using keywords as its first and second arguments, and is
+no longer in the extensions package, but is considered a
+private implementation detail.
+
+The expected Lisp function arguments and command line arguments
+for SAVE-LISP (now called SAVE-LISP-AND-DIE) and loading
+the core back into a new Lisp have changed completely.
+
+The SB-UNIX package no longer attempts to be a complete user interface
+to Unix. Instead, it's considered a private part of the implementation
+of SBCL, and tries to implement only what's needed by the current
+implementation of SBCL.
+
+Lots of stale conditional code was deleted, e.g. code to support
+portability to archaic systems in the LOOP and PCL packages. (The
+SB-PCL and SB-LOOP packages no longer aspire to portability.)
+
+Various internal symbols, and even some externally-visible extensions,
+have been given less-ambiguous or more-modern names, with more to
+follow. (E.g. SAVE-LISP becoming SAVE-LISP-AND-DIE, both to avoid
+surprising the user and to reserve the name SAVE-LISP in case we ever
+manage to implement a SAVE-LISP which doesn't cause the system to die
+afterwards. And GIVE-UP and ABORT-TRANSFORM have been renamed
+to GIVE-UP-IR1-TRANSFORM and ABORT-IR1-TRANSFORM. And so on.)
+
+Various internal names "NEW-FOO" have been changed to FOO, generally
+after deleting the obsolete old version of FOO. This has happened both
+with names at the Lisp level (e.g. "NEW-ASSEM") and at the Unix
+filesystem level (e.g. "new-hash.lisp" and "new-assem.lisp").
+
+A cultural change, rather than a technical one: The system no longer
+tries to be binary compatible between releases.
+
+Per-file credits for programs should move into a single
+centralized CREDITS file Real Soon Now.
+
+A lot of spelling errors have been corrected.:-)
+
+
+Section II. fundamental changes
+
+There were a number of things which I changed in order to get the
+system to boot itself.
+
+The source files have been extensively reordered to fix broken forward
+references. In many cases, this required breaking one CMU CL source
+file into more than one SBCL source file, and scattering the multiple
+SBCL source files into multiple places in the build order. (Some of
+the breakups were motivated by reasons which no longer exist, and
+could be undone now, e.g. "class.lisp" could probably go back into
+"classes.lisp". But I think most of the reasons still apply.)
+
+The assembler and genesis were rewritten for portability, using
+vectors for scratch space instead of using SAPs.
+
+We define new readmacro syntax #!+ and #!- which acts like
+the standard #+ and #- syntax, except that it switches on the
+target feature list instead of the host feature list. We also
+introduce temporary new features like :XC-HOST ("in the cross-compilation
+host") and :XC ("in the cross-compiler") which will be used
+to control some of the behavior below.
+
+A new package SB-XC ("cross-compiler") was introduced to hold
+affecting-the-target versions of various things like DEFMACRO,
+DEFTYPE, FIND-CLASS, CONSTANTP, CLASS, etc. So e.g. when you're
+building the cross-compiler in the cross-compilation host Lisp,
+SB-XC:DEFMACRO defines a macro in the target Lisp; SB-XC:CONSTANTP
+tells you whether something is known to be constant in the target
+Lisp; and SB-XC:CLASS is the class of an object which represents a
+class in the target Lisp. In order to make everything work out later
+when running the cross-compiler to produce code for the target Lisp,
+SB-XC turns into a sort of nickname for the COMMON-LISP package.
+Except it's a little more complicated than that..
+
+It doesn't quite work to make SB-XC into a nickname for COMMON-LISP
+while building code for the target, because then much of the code in
+EVAL-WHEN (:COMPILE-TOPLEVEL :EXECUTE) forms would break. Instead, we
+read in code using the ordinary SB-XC package, and then when we
+process code in any situation other than :COMPILE-TOPLEVEL, we run it
+through the function UNCROSS to translate any SB-XC symbols into the
+corresponding CL symbols. (This doesn't seem like a very elegant
+solution, but it does seem to work.:-)
+
+Even after we've implemented the UNCROSS hack, a lot of the code inside
+EVAL-WHEN forms is still broken, because it does things like CL:DEFMACRO
+to define macros which are intended to show up in the target, and
+under the new system we really need it to do SB-XC:DEFMACRO instead
+in order to achieve the desired effect. So we have to go through
+all the EVAL-WHEN forms and convert various CL:FOO operations
+to the corresponding SB-XC:FOO operations. Or sometimes instead we
+convert code a la
+ (EVAL-WHEN (COMPILE EVAL)
+ (DEFMACRO FOO ..))
+ (code-using-foo)
+into code a la
+ (MACROLET ((FOO ..))
+ (code-using-foo))
+Or sometimes we even give up and write
+ (DEFMACRO FOO ..)
+ (code-using-foo)
+instead, figuring it's not *that* important to try to save a few bytes
+in the target Lisp by keeping FOO from being defined. And in a few
+shameful instances we even did things like
+ #+XC (DEFMACRO FOO ..)
+ #-XC (DEFMACRO FOO ..
+or
+ #+XC (code-using-foo)
+ #-XC (other-code-using-foo)
+even though we know that we will burn in hell for it. (The really
+horribly unmaintainable stuff along those lines is three compiler-building
+macros which I hope to fix before anyone else notices them.:-)
+
+In order to avoid trashing the host Common Lisp when cross-compiling
+under another instance of ourself (and in order to avoid coming to
+depend on its internals in various weird ways, like some systems we
+could mention but won't:-) we make the system use different package
+names at cold init time than afterwards. The internal packages are
+named "SB!FOO" while we're building the system, and "SB-FOO"
+afterwards.
+
+In order to make the system work even when we're renaming its packages
+out from underneath it, we need to seek out and destroy any nasty
+hacks which refer to particular package names, like the one in
+%PRIMITIVE which wants to reintern the symbols in its arguments into
+the "C"/"SB-C"/"SB!C" package.
+
+Incidentally, because of the #! readmacros and the "SB!FOO" package
+names, the system sources are unreadable to the running system. (The
+undefined readmacros and package names cause READ-ERRORs.) I'd like
+to make a little hack to fix this for use when experimenting with
+and maintaining the system, but I haven't gotten around to it,
+despite several false starts. Real Soon Now..
+
+In order to keep track of layouts and other type and structure
+information set up under the cross-compiler, we use a system built
+around the DEF!STRUCT macro. (The #\! character is used to name a lot
+of cold-boot-related stuff.) When building the cross-compiler, the
+DEF!STRUCT macro is a wrapper around portable DEFSTRUCT which builds
+its own portable information about the structures being created, and
+arranges for host Lisp instances of the structures to be dumpable as
+target Lisp instances as necessary. (This system uses MAKE-LOAD-FORM
+heavily and is the reason that I say that bootstrapping under CLISP is
+not likely to happen until CLISP supports MAKE-LOAD-FORM.) When
+running the cross-compiler, DEF!STRUCT basically reduces to the
+DEFSTRUCT macro.
+
+In order to be able to make this system handle target Lisp code,
+we need to be able to test whether a host Lisp value matches a
+target Lisp type specifier. With the information available from
+DEF!STRUCT, and various hackery, we can do that, implementing things
+like SB-XC:TYPEP.
+
+Now that we know how to represent target Lisp objects in the
+cross-compiler running under vanilla ANSI Common Lisp, we need to make
+the dump code portable. This is not too hard given that the cases
+which would be hard tend not to be used in the implementation of SBCL
+itself, so the cross-compiler doesn't need to be able to handle them
+anyway. Specialized arrays are an exception, and currently we dodge
+the issue by making the compiler use not-as-specialized-as-possible
+array values. Probably this is fixable by bootstrapping in two passes,
+one pass under vanilla ANSI Common Lisp and then another under the
+SBCL created by the first pass. That way, the problem goes away in the
+second pass pass, since we know that all types represented by the
+target SBCL can be represented in the cross-compilation host SBCL.
--- /dev/null
+SBCL is -- ahem! -- not particularly well documented at this point.
+What can I say? Help with documentation might not be refused.:-)
+
+The old CMUCL documentation, in the cmucl/ subdirectory, is still
+somewhat useful. The old user's manual is very useful. Most of the
+CMUCL extensions to Common Lisp have gone away, but the general
+information about how to use the Python compiler is still very
+relevant.
--- /dev/null
+<chapter id="beyond-ansi"><title>Beyond the &ANSI; Standard</>
+
+<para>Besides &ANSI;, we have other stuff..</para>
+
+<sect1 id="non-conformance"><title>Non-Conformance with the &ANSI; Standard</>
+
+<para>&SBCL; is derived from code which was written before the &ANSI;
+standard, and some incompatibilities remain.</para>
+
+<para>The &ANSI; standard defines constructs like
+<function>defstruct</>, <function>defun</>, and <function>declaim</>
+so that they can be implemented as macros which expand into ordinary
+code wrapped in <function>eval-when</> forms. However, the pre-&ANSI;
+&CMUCL; implementation handled these (and some related functions like
+<function>proclaim</>) as special cases in the compiler, with subtly
+(or sometimes not-so-subtly) different semantics. Much of this
+weirdness has been removed in the years since the &ANSI; standard was
+released, but bits and pieces remain, so that e.g., as of &SBCL; 0.6.3
+compiling the function
+
+<programlisting>(defun foo () (defstruct bar))</>
+
+will cause the class <type>BAR</> to be defined, even when the
+function is not executed. These remaining nonconforming behaviors are
+considered bugs, and clean patches will be gratefully accepted, but as
+long as they don't cause as many problems in practice as other known
+issues, they tend not to be actively fixed.</para>
+
+<para>More than any other &Lisp; system I am aware of, &SBCL; (and its
+parent &CMUCL;) store and use a lot of compile-time static type
+information. By and large they conform to the standard in doing so,
+but in one regard they do not — they consider <function>defun</>s to,
+in effect, implicitly <function>proclaim</> type information about the
+signature of the function being defined. Thus, if you compile and load
+
+<programlisting>(defun foo-p (x)
+ (error "stub, foo-p ~s isn't implemented yet!" x))
+(defun foolike-p (x)
+ (or (foo-p x) (foo-p (car x))))</programlisting>
+
+everything will appear to work correctly, but if you subsequently
+redefine <function>foo-p</>
+
+<programlisting>(defun foo-p (x) (or (null x) (symbolp (car x))))</>
+
+and call
+
+<programlisting>(foolike-p nil)</>
+
+you will not get the correct result, but an error,
+
+<screen>debugger invoked on SB-DEBUG::*DEBUG-CONDITION* of type
+SB-KERNEL:SIMPLE-CONTROL-ERROR:
+ A function with declared result type NIL returned:
+ FOO-P</screen>
+
+because when &SBCL; compiled <function>foolike-p</>, &SBCL; thought it
+knew that <function>foo-p</> would never return. More insidious
+problems are quite possible when &SBCL; thinks it can optimize away e.g.
+particular branches of a <function>case</> because of what it's proved
+to itself about the function's return type. This will probably be
+fixed in the foreseeable future, either with a quick fix, or ideally
+in conjunction with some related fixes to generalize the principle
+that declarations are assertions (see below). But for now it remains a
+gross violation of the &ANSI; spec (and reasonable user
+expectations).</para>
+
+<para>The &CMUCL; <function>defstruct</> implementation treated
+structure accessors and other <function>defstruct</>-related functions
+(e.g. predicates) as having some special properties, not quite like
+ordinary functions. This specialness has been reduced in &SBCL;, but
+some still remains. In particular, redefining a structure accessor
+function may magically cause the entire structure class to be deleted.
+This, too, will probably be fixed in the foreseeable future.</para>
+
+<para>The CLOS implementation used in &SBCL; is based on the
+<application>Portable Common Loops</> (PCL) reference implementation
+from Xerox. Unfortunately, PCL seems never to have quite conformed to
+the final CLOS specification. Moreover, despite the "Portable" in its
+name, it wasn't quite portable. Various implementation-specific hacks
+were made to make it run on &CMUCL;, and then more hacks were added to
+make it less inefficient. The result is a system with mostly tolerable
+performance which mostly conforms to the standard, but which has a few
+remaining weirdnesses which seem to be hard to fix. The most important
+remaining weirdness is that the <type>CL:CLASS</> class is not the
+same as the <type>SB-PCL:CLASS</> type used internally in PCL; and
+there are several other symbols maintained in parallel (e.g.
+<type>SB-PCL:FIND-CLASS</> vs. <type>CL:FIND-CLASS</>). So far, any
+problems this has caused have had workarounds involving consistently
+using the SB-PCL versions or the CL versions of the class hierarchy.
+This is admittedly ugly, but it may not be fixed in the foreseeable
+future, since the required cleanup looks nontrivial, and we don't have
+anyone sufficiently motivated to do it.</para>
+
+</sect1>
+
+<sect1 id="idiosyncrasies"><title>Idiosyncrasies</>
+
+<para>Declarations are generally treated as assertions. This general
+principle, and its implications, and the bugs which still keep the
+compiler from quite satisfying this principle, are discussed in the
+<link linkend="compiler">chapter on the compiler</link>.</para>
+
+<note><para>It's not an idiosyncrasy yet, since we haven't done
+it, but someday soon &SBCL; may become a compiler-only implementation.
+That is, essentially, <function>eval</> will be defined to create
+a lambda expression, call <function>compile</> on the lambda
+expression to create a compiled function, and then
+<function>funcall</> the resulting function. This would allow
+a variety of simplifications in the implementation, while introducing
+some other complexities. It remains to be seen when it will be
+possible to try this, or whether it will work well when it's tried,
+but it looks appealing right now.</para></note>
+
+</sect1>
+
+<sect1 id="extensions"><title>Extensions</>
+
+<para>&SBCL; is derived from &CMUCL;, which implements many extensions to the
+&ANSI; standard. &SBCL; doesn't support as many extensions as &CMUCL;, but
+it still has quite a few.</para>
+
+<sect2><title>Things Which Might Be in the Next &ANSI; Standard</>
+
+<para>&SBCL; provides extensive support for
+calling external C code, described
+<link linkend="ffi">in its own chapter</link>.</para>
+
+<para>&SBCL; provides additional garbage collection functionality not
+specified by &ANSI;. Weak pointers allow references to objects to be
+maintained without keeping them from being GCed. And "finalization"
+hooks are available to cause code to be executed when an object is
+GCed.</para>
+
+<para>&SBCL; does not currently provide Gray streams, but may do so in
+the near future. (It has unmaintained code inherited from &CMUCL; to
+do so.) <!-- FIXME: Add citation to Gray streams.-->
+</para>
+
+<para>&SBCL; does not currently support multithreading (traditionally
+called <wordasword>multiprocessing</> in &Lisp;) but contains unmaintained
+code from &CMUCL; to do so. A sufficiently motivated maintainer
+could probably make it work.</para>
+
+</sect2>
+
+<sect2><title>Support for Unix</>
+
+<para>The UNIX command line can be read from the variable
+<varname>sb-ext:*posix-argv*</>. The UNIX environment can be queried with the
+<function>sb-ext:posix-getenv</> function.</para>
+
+<para>The &SBCL; system can be terminated with <function>sb-ext:quit</>,
+optionally returning a specified numeric value to the calling Unix
+process. The normal Unix idiom of terminating on end of file on input
+is also supported.</para>
+
+</sect2>
+
+<sect2><title>Tools to Help Developers</title>
+
+<para>&SBCL; provides a profiler and other extensions to the &ANSI;
+<function>trace</> facility. See the online function documentation for
+<function>trace</> for more information.</para>
+
+<para>The debugger supports a number of options. Its documentation is
+accessed by typing <userinput>help</> at the debugger prompt.</para>
+
+<para>Documentation for <function>inspect</> is accessed by typing
+<userinput>help</> at the <function>inspect</> prompt.</para>
+
+</sect2>
+
+<sect2><title>Interface to Low-Level &SBCL; Implementation</title>
+
+<para>&SBCL; has the ability to save its state as a file for later
+execution. This functionality is important for its bootstrapping
+process, and is also provided as an extension to the user See the
+documentation for <function>sb-ext:save-lisp-and-die</> for more
+information.</para>
+
+<note><para>&SBCL; has inherited from &CMUCL; various hooks to allow
+the user to tweak and monitor the garbage collection process. These
+are somewhat stale code, and their interface might need to be cleaned
+up. If you have urgent need of them, look at the code in
+<filename>src/code/gc.lisp</filename> and bring it up on the
+developers' mailing list.</para></note>
+
+<note><para>&SBCL; has various hooks inherited from &CMUCL;, like
+<function>sb-ext:float-denormalized-p</>, to allow a program to take
+advantage of &IEEE; floating point arithmetic properties which aren't
+conveniently or efficiently expressible using the &ANSI; standard. These
+look good, and their interface looks good, but &IEEE; support is
+slightly broken due to a stupid decision to remove some support for
+infinities (because it wasn't in the &ANSI; spec and it didn't occur to
+me that it was in the &IEEE; spec). If you need this stuff, take a look
+at the ecode and bring it up on the developers' mailing
+list.</para></note>
+
+</sect2>
+
+<sect2><title>Efficiency Hacks</title>
+
+<para>The <function>sb-ext:purify</function> function causes &SBCL;
+first to collect all garbage, then to mark all uncollected objects as
+permanent, never again attempting to collect them as garbage. (This
+can cause a large increase in efficiency when using a primitive
+garbage collector, but is less important with modern generational
+garbage collectors.)</para>
+
+<para>The <function>sb-ext:truly-the</> operator does what the
+<function>cl:the</> operator does in a more conventional
+implementation of &CommonLisp;, declaring the type of its argument
+without any runtime checks. (Ordinarily in &SBCL;, any type declaration
+is treated as an assertion and checked at runtime.)</para>
+
+<para>The <function>sb-ext:freeze-type</> declaration declares that a
+type will never change, which can make type testing
+(<function>typep</>, etc.) more efficient for structure types.</para>
+
+<para>The <function>sb-ext:constant-function</> declaration specifies
+that a function will always return the same value for the same
+arguments. This is appropriate for functions like <function>sqrt</>.
+It is not appropriate for functions like <function>aref</>, which can
+change their return values when the underlying data are
+changed.</para>
+
+</sect2>
+
+</sect1>
+
+</chapter>
\ No newline at end of file
--- /dev/null
+'BAR
+VARREF
+'TEST
+UPCASE
+ENDLISP
+SUBSEQ
+ENDDEFUN
+FUNARGS
+GENSYM
+VARS
+UNINTERNED
+VAR
+VSOURCE
+CLISP
+COND
+MYSTUFF
+TRADEOFFS
+PATHNAME
+LLISP
+CMUCL
+REF
+YETMOREKEYS
+CLEANUP
+ARGS
+DEFUN
+ZOQ
+FOO
+'S
+CLTL
+MACROEXPANDS
+MACROEXPANSION
+PROXY
+ERRORFUL
+EQ
+ECASE
+PYTHON
+DEFMACRO
+PROMISCUOUS
+FLAMAGE
+DEBUGGABILITY
+FEATUREFULNESS
+DEBUGGABLE
+ENDDEFVAR
+MACROEXPANDED
+DEFVAR
+ENDDEFMAC
+KWD
+MGROUP
+MSTAR
+DEFMAC
+OFFS
+NOTINLINE
+TRADEOFF
+FUNCALL
+SOMEVAL
+SOMEFUN
+CM
+DEFTYPE
+CONSING
+FIXNUMS
+BIGNUMS
+FROB
+'FOO
+RECOMPILES
+FTYPE
+TYPECASE
+TYPEP
+UNTYPED
+UNIONED
+GLOBALS
+MODICUM
+MACREF
+SLEAZING
+ES
+STEELE
+ETYPECASE
+'EQL
+'IDENTITY
+'FUN
+LOCALFUN
+ISQRT
+ODDP
+MYFUN
+POS
+ZOW
+YOW
+'YOW
+CADR
+ZEROP
+RES
+EXPT
+PARED
+PUSHING
+'ING
+RPLACD
+IOTA
+NTHCDR
+NTH
+CADDDR
+RPLACA
+CADDR
+FIENDS
+SQRT
+'SQRT
+LISPY
+BLANKSPACE
+MYCHAPTER
+UNENCAPSULATED
+ENCAPSULATIONS
+UNENCAPSULATE
+UNTRACED
+UNTRACE
+EVALED
+SPEC
+PUSHES
+TRUENAME
+MYMAC
+UNINFORMATIVE
+FOOBAR
+BAZ
+BACKQUOTE
+MALFORMED
+MOREKEYS
+FUNREF
+QUIRKS
+UNDILUTED
+DISASSEMBLY
+NAN
+DENORMALIZED
+ENDDEFCONST
+DEFCONST
+HASHTABLES
+EFF
+OBFUSCATING
+SNOC
+GRUE
+GORP
+FLO
+NUM
+VEC
+MULTBY
+SOMEOTHERFUN
+'CHAR
+NOTP
+TESTP
+FUNVAR
+RAZ
+ZUG
+XFF
+IO
+GC'ING
+EXT
+MEGABYTE
+SYS
+UX
+ED
+MATCHMAKER
+DIRED
+PCL
+CLOS
+CONFORMANCE
+ENDDEFCON
+DEFCON
+DECLAIM
+DEFSTRUCT
+ENUM
+EXTERN
+LOWERCASING
+DEREFERENCED
+MOPT
+STRUCT
+DEFTP
+ENDDEFTP
+MALLOC
+CSH
+PXLREF
+ATYPE
+CONSTRUCTUED
+ANAME
+PXREF
+ENV
+ONECOLUMN
+TP
+VR
+FN
+PRINTINDEX
+UNNUMBERED
+TWOCOLUMN
+TLF
+UNCOMPILED
+DEACTIVATE
+CALLABLE
+UNREFERENCED
+SUPPLIEDP
+INTERNING
+UNHANDLED
+BACKTRACING
+TEX
+OOB
+OBJ
+PRIN
+OBJS
+GP
+LINKERS
+CC
+AR
+CFUN
+INTS
+SIZEOF
+PRINTF
+CFOO
+SUBFORM
+SVREF
+STASH
+FOOS
+LC
+LD
+'N
+'X
+ERRNO
+UPPERCASING
+EXPR
+ADDR
+'STR
+STR
+DEREF
+PTR
+SWINDOW
+IWINDOW
+'SLIDER
+DRAWABLE
+'KEY
+'EXT
+TIMEOUTS
+'MY
+ID
+PIXMAPS
+'EQ
+FUNCALLED
+XWINDOW
+'IH
+SIGSTOP
+GETPID
+SIGTSTP
+SCP
+SIGINT
+IH
+CNT
+GENERALRETURN
+DEFMACX
+'NUKEGARBAGE
+GR
+HASSLE
+PREPENDS
+TIMEOUT
+FD
+MSG
+SYSCALL
+UNHELPFUL
+PREPENDED
+VM
+PAGEREF
+INT
+PORTSID
+PORTSNAME
+SERVPORT
+KERN
+DATATYPES
+TTY
+STDERR
+STDOUT
+STDIN
+CMD
+AUX
+PS
+UNACCOUNTED
+RUNTIMES
+PROFILER
+UNPROFILE
+REPROFILED
+UNPROFILED
+CF
+ELT
+VOPS
+MAPCAR
+OPTIONALS
+CONSES
+CONTORTIONS
+ALISTS
+ALIST
+ASSOC
+EXP
+MYEXP
+DEFCONSTANT
+INCF
+MEMQ
+COERCIONS
+EQL
+LOGAND
+AREF
+CONSP
+TYPEN
+LOGIOR
+EQUIV
+SUPERTYPE
+DEFMETHOD
+SUBFORMS
+CERROR
+PSETQ
+TAGBODY
+DOTIMES
+PLOQ
+ROQ
+SPECS
+MPLUS
+STEPPER
+FDEFINITION
+FUNCALLABLE
+ST
+BR
+DB
+LB
+LL
+HFILL
+PP
+VPRINT
+TH
+ARGLISTS
+SETQ
+NAMESPACE
+SUBFUNCTION
+BACKTRACE
+'B
+FLET
+ARG
+'A
+CPSUBINDEX
+PROGN
+CONTRIB
+WEEKDAYS
+GREENWICH
+TIMEZONE
+DEST
+WEEKDAY
+JAN
+CINDEX
+NAMESTRING
+PATHNAMES
+FASL
+SIGSEGV
+PLIST
+'ABLE
+SETF
+PID
+EXECVE
+DEV
+SUBPROCESS
+PTY
+'TH
+UNSUPPLIED
+DEFVARX
+GCS
+CONSED
+GC'ED
+GC
+TRASHING
+XLIB
+CL
+HI
+COMMONLOOPS
+CTRL
+XLREF
+DEFUNX
+DEFCONSTX
+SUBSUBSECTION
+VINDEXED
+TINDEXED
+RESEARCHCREDIT
+EM
+WHOLEY
+SKEF
+KAUFMANN
+TODD
+KOLOJEJCHICK
+BUSDIECKER
+''
+NOINDENT
+MOORE
+TIM
+LOTT
+LEINEN
+HALLGREN
+GLEICHAUF
+DUNNING
+TED
+BADER
+MYLISP
+NOINIT
+FINDEXED
+INIT
+EVAL
+SUBDIRECTORIES
+COPYRIGHTED
+FTP
+LANG
+COMP
+MEG
+MEGABYTES
+UNCOMPRESS
+CD
+OS
+USERNAME
+SLISP
+RT
+LIB
+SETENV
+SAMP
+SETPATH
+LOGIN
+MISC
+USR
+MODMISC
+TXT
+DOC
+EXECUTABLES
+PERQ
+UNTAGGED
+BENCHMARKING
+WINDOWING
+INTRO
+DOCS
+EDU
+AFS
+VSPACE
+IFINFO
+DIR
+SETFILENAME
+TABLEOFCONTENTS
+PAGENUMBERING
+CLEARPAGE
+MAKETITLE
+ARPASUPPORT
+CITATIONINFO
+TRNUMBER
+IFTEX
+SUNOS
+SPARC
+DECSTATIONS
+THEABSTRACT
+DEF
+KY
+CP
+NEWINDEX
+ALWAYSREFILL
+PAGESTYLE
+CMULISP
+TITLEPAGE
+ELISP
+LATEXINFO
+DOCUMENTSTYLE
--- /dev/null
+%% CMU Common Lisp User's Manual.
+%%
+%% Aug 97 Raymond Toy
+%% This is a modified version of the original CMUCL User's Manual.
+%% The key changes are modification of this file to use standard
+%% LaTeX2e. This means latexinfo isn't going to work anymore.
+%% However, Latex2html support has been added.
+%%
+%% Jan 1998 Paul Werkowski
+%% A few of the packages below are not part of the standard LaTeX2e
+%% distribution, and must be obtained from a repository. At this time
+%% I was able to fetch from
+%% ftp.cdrom.com:pub/tex/ctan/macros/latex/contrib/supported/
+%% camel/index.ins
+%% camel/index.dtx
+%% calc/calc.ins
+%% calc/calc.dtx
+%% changebar/changebar.ins
+%% changebar/changebar.dtx
+%% One runs latex on the .ins file to produce .tex and/or .sty
+%% files that must be put in a path searched by latex.
+%%
+\documentclass{report}
+\usepackage{changebar}
+\usepackage{xspace}
+\usepackage{alltt}
+\usepackage{index}
+\usepackage{verbatim}
+\usepackage{ifthen}
+\usepackage{calc}
+%\usepackage{html2e}
+\usepackage{html,color}
+\usepackage{varioref}
+
+%% Define the indices. We need one for Types, Variables, Functions,
+%% and a general concept index.
+\makeindex
+\newindex{types}{tdx}{tnd}{Type Index}
+\newindex{vars}{vdx}{vnd}{Variable Index}
+\newindex{funs}{fdx}{fnd}{Function Index}
+\newindex{concept}{cdx}{cnd}{Concept Index}
+
+\newcommand{\tindexed}[1]{\index[types]{#1}\textsf{#1}}
+\newcommand{\findexed}[1]{\index[funs]{#1}\textsf{#1}}
+\newcommand{\vindexed}[1]{\index[vars]{#1}\textsf{*#1*}}
+\newcommand{\cindex}[1]{\index[concept]{#1}}
+\newcommand{\cpsubindex}[2]{\index[concept]{#1!#2}}
+
+%% This code taken from the LaTeX companion. It's meant as a
+%% replacement for the description environment. We want one that
+%% prints description items in a fixed size box and puts the
+%% description itself on the same line or the next depending on the
+%% size of the item.
+\newcommand{\entrylabel}[1]{\mbox{#1}\hfil}
+\newenvironment{entry}{%
+ \begin{list}{}%
+ {\renewcommand{\makelabel}{\entrylabel}%
+ \setlength{\labelwidth}{45pt}%
+ \setlength{\leftmargin}{\labelwidth+\labelsep}}}%
+ {\end{list}}
+
+\newlength{\Mylen}
+\newcommand{\Lentrylabel}[1]{%
+ \settowidth{\Mylen}{#1}%
+ \ifthenelse{\lengthtest{\Mylen > \labelwidth}}%
+ {\parbox[b]{\labelwidth}% term > labelwidth
+ {\makebox[0pt][l]{#1}\\}}%
+ {#1}%
+ \hfil\relax}
+\newenvironment{Lentry}{%
+ \renewcommand{\entrylabel}{\Lentrylabel}
+ \begin{entry}}%
+ {\end{entry}}
+
+\newcommand{\fcntype}[1]{\textit{#1}}
+\newcommand{\argtype}[1]{\textit{#1}}
+\newcommand{\fcnname}[1]{\textsf{#1}}
+
+\newlength{\formnamelen} % length of a name of a form
+\newlength{\pboxargslen} % length of parbox for arguments
+\newlength{\typelen} % length of the type label for the form
+
+\newcommand{\args}[1]{#1}
+\newcommand{\keys}[1]{\textsf{\&key} \= #1}
+\newcommand{\morekeys}[1]{\\ \> #1}
+\newcommand{\yetmorekeys}[1]{\\ \> #1}
+
+\newcommand{\defunvspace}{\ifhmode\unskip \par\fi\addvspace{18pt plus 12pt minus 6pt}}
+
+
+%% \layout[pkg]{name}{param list}{type}
+%%
+%% This lays out a entry like so:
+%%
+%% pkg:name arg1 arg2 [Function]
+%%
+%% where [Function] is flush right.
+%%
+\newcommand{\layout}[4][\mbox{}]{%
+ \par\noindent
+ \fcnname{#1#2\hspace{1em}}%
+ \settowidth{\formnamelen}{\fcnname{#1#2\hspace{1em}}}%
+ \settowidth{\typelen}{[\argtype{#4}]}%
+ \setlength{\pboxargslen}{\linewidth}%
+ \addtolength{\pboxargslen}{-1\formnamelen}%
+ \addtolength{\pboxargslen}{-1\typelen}%
+ \begin{minipage}[t]{\pboxargslen}
+ \begin{tabbing}
+ #3
+ \end{tabbing}
+ \end{minipage}
+ \hfill[\fcntype{#4}]%
+ \par\addvspace{2pt plus 2pt minus 2pt}}
+
+\newcommand{\vrindexbold}[1]{\index[vars]{#1|textbf}}
+\newcommand{\fnindexbold}[1]{\index[funs]{#1|textbf}}
+
+%% Define a new type
+%%
+%% \begin{deftp}{typeclass}{typename}{args}
+%% some description
+%% \end{deftp}
+\newenvironment{deftp}[3]{%
+ \par\bigskip\index[types]{#2|textbf}%
+ \layout{#2}{\var{#3}}{#1}
+ }{}
+
+%% Define a function
+%%
+%% \begin{defun}{pkg}{name}{params}
+%% \defunx[pkg]{name}{params}
+%% description of function
+%% \end{defun}
+\newenvironment{defun}[3]{%
+ \par\defunvspace\fnindexbold{#2}\label{FN:#2}%
+ \layout[#1]{#2}{#3}{Function}
+ }{}
+\newcommand{\defunx}[3][\mbox{}]{%
+ \par\fnindexbold{#2}\label{FN:#2}%
+ \layout[#1]{#2}{#3}{Function}}
+
+%% Define a macro
+%%
+%% \begin{defmac}{pkg}{name}{params}
+%% \defmacx[pkg]{name}{params}
+%% description of macro
+%% \end{defmac}
+\newenvironment{defmac}[3]{%
+ \par\defunvspace\fnindexbold{#2}\label{FN:#2}%
+ \layout[#1]{#2}{#3}{Macro}}{}
+\newcommand{\defmacx}[3][\mbox{}]{%
+ \par\fnindexbold{#2}\label{FN:#2}%
+ \layout[#1]{#2}{#3}{Function}}
+
+%% Define a variable
+%%
+%% \begin{defvar}{pkg}{name}
+%% \defvarx[pkg]{name}
+%% description of defvar
+%% \end{defvar}
+\newenvironment{defvar}[2]{%
+ \par\defunvspace\vrindexbold{#2}\label{VR:#2}
+ \layout[#1]{*#2*}{}{Variable}}{}
+\newcommand{\defvarx}[2][\mbox{}]{%
+ \par\vrindexbold{#2}\label{VR:#2}
+ \layout[#1]{*#2*}{}{Variable}}
+
+%% Define a constant
+%%
+%% \begin{defconst}{pkg}{name}
+%% \ddefconstx[pkg]{name}
+%% description of defconst
+%% \end{defconst}
+\newcommand{\defconstx}[2][\mbox{}]{%
+ \layout[#1]{#2}{}{Constant}}
+\newenvironment{defconst}[2]{%
+ \defunvspace\defconstx[#1]{#2}}
+
+\newenvironment{example}{\begin{quote}\begin{alltt}}{\end{alltt}\end{quote}}
+\newenvironment{lisp}{\begin{example}}{\end{example}}
+\newenvironment{display}{\begin{quote}\begin{alltt}}{\end{alltt}\end{quote}}
+
+\newcommand{\hide}[1]{}
+\newcommand{\trnumber}[1]{#1}
+\newcommand{\citationinfo}[1]{#1}
+\newcommand{\var}[1]{{\textsf{\textsl{#1}}\xspace}}
+\newcommand{\code}[1]{\textnormal{{\sffamily #1}}}
+\newcommand{\file}[1]{`\texttt{#1}'}
+\newcommand{\samp}[1]{`\texttt{#1}'}
+\newcommand{\kwd}[1]{\code{:#1}}
+\newcommand{\F}[1]{\code{#1}}
+\newcommand{\w}[1]{\hbox{#1}}
+\renewcommand{\b}[1]{\textrm{\textbf{#1}}}
+\renewcommand{\i}[1]{\textit{#1}}
+\newcommand{\ctrl}[1]{$\uparrow$\textsf{#1}}
+\newcommand{\result}{$\Rightarrow$}
+\newcommand{\myequiv}{$\equiv$}
+\newcommand{\back}[1]{\(\backslash\)#1}
+\newcommand{\pxlref}[1]{see section~\ref{#1}, page~\pageref{#1}}
+\newcommand{\xlref}[1]{See section~\ref{#1}, page~\pageref{#1}}
+
+\newcommand{\false}{\textsf{nil}}
+\newcommand{\true}{\textsf{t}}
+\newcommand{\nil}{\textsf{nil}}
+\newcommand{\FALSE}{\textsf{nil}}
+\newcommand{\TRUE}{\textsf{t}}
+\newcommand{\NIL}{\textsf{nil}}
+
+\newcommand{\ampoptional}{\textsf{\&optional}}
+\newcommand{\amprest}{\textsf{\&rest}}
+\newcommand{\ampbody}{\textsf{\&body}}
+\newcommand{\mopt}[1]{{$\,\{$}\textnormal{\textsf{\textsl{#1\/}}}{$\}\,$}}
+\newcommand{\mstar}[1]{{$\,\{$}\textnormal{\textsf{\textsl{#1\/}}}{$\}^*\,$}}
+\newcommand{\mplus}[1]{{$\,\{$}\textnormal{\textsf{\textsl{#1\/}}}{$\}^+\,$}}
+\newcommand{\mgroup}[1]{{$\,\{$}\textnormal{\textsf{\textsl{#1\/}}}{$\}\,$}}
+\newcommand{\mor}{$|$}
+
+\newcommand{\funref}[1]{\findexed{#1} (page~\pageref{FN:#1})}
+\newcommand{\specref}[1]{\findexed{#1} (page~\pageref{FN:#1})}
+\newcommand{\macref}[1]{\findexed{#1} (page~\pageref{FN:#1})}
+\newcommand{\varref}[1]{\vindexed{#1} (page~\pageref{VR:#1})}
+\newcommand{\conref}[1]{\conindexed{#1} (page~\pageref{VR:#1})}
+
+%% Some common abbreviations
+\newcommand{\clisp}{Common Lisp}
+\newcommand{\dash}{---}
+\newcommand{\alien}{Alien}
+\newcommand{\aliens}{Aliens}
+\newcommand{\Aliens}{Aliens}
+\newcommand{\Alien}{Alien}
+\newcommand{\Hemlock}{Hemlock}
+\newcommand{\hemlock}{Hemlock}
+\newcommand{\python}{Python}
+\newcommand{\Python}{Python}
+\newcommand{\cmucl}{CMU Common Lisp}
+\newcommand{\llisp}{Common Lisp}
+\newcommand{\Llisp}{Common Lisp}
+\newcommand{\cltl}{\emph{Common Lisp: The Language}}
+\newcommand{\cltltwo}{\emph{Common Lisp: The Language 2}}
+
+%% Replacement commands when we run latex2html. This should be last
+%% so that latex2html uses these commands instead of the LaTeX
+%% commands above.
+\begin{htmlonly}
+ \usepackage{makeidx}
+
+ \newcommand{\var}[1]{\textnormal{\textit{#1}}}
+ \newcommand{\code}[1]{\textnormal{\texttt{#1}}}
+ %%\newcommand{\printindex}[1][\mbox{}]{}
+
+ %% We need the quote environment because the alltt is broken. The
+ %% quote environment helps us in postprocessing to result to get
+ %% what we want.
+ \newenvironment{example}{\begin{quote}\begin{alltt}}{\end{alltt}\end{quote}}
+ \newenvironment{display}{\begin{quote}\begin{alltt}}{\end{alltt}\end{quote}}
+
+ \newcommand{\textnormal}[1]{\rm #1}
+ \newcommand{\hbox}[1]{\mbox{#1}}
+ \newcommand{\xspace}{}
+ \newcommand{newindex}[4]{}
+
+ \newcommand{\pxlref}[1]{see section~\ref{#1}}
+ \newcommand{\xlref}[1]{See section~\ref{#1}}
+
+ \newcommand{\tindexed}[1]{\index{#1}\texttt{#1}}
+ \newcommand{\findexed}[1]{\index{#1}\texttt{#1}}
+ \newcommand{\vindexed}[1]{\index{#1}\texttt{*#1*}}
+ \newcommand{\cindex}[1]{\index{#1}}
+ \newcommand{\cpsubindex}[2]{\index{#1!#2}}
+
+ \newcommand{\keys}[1]{\texttt{\&key} #1}
+ \newcommand{\morekeys}[1]{#1}
+ \newcommand{\yetmorekeys}[1]{#1}
+
+ \newenvironment{defun}[3]{%
+ \textbf{[Function]}\\
+ \texttt{#1#2} \emph{#3}\\}{}
+ \newcommand{\defunx}[3][\mbox{}]{%
+ \texttt{#1#2} {\em #3}\\}
+ \newenvironment{defmac}[3]{%
+ \textbf{[Macro]}\\
+ \texttt{#1#2} \emph{#3}\\}{}
+ \newcommand{\defmacx}[3][\mbox{}]{%
+ \texttt{#1#2} {\em #3}\\}
+ \newenvironment{defvar}[2]{%
+ \textbf{[Variable]}\\
+ \texttt{#1*#2*}\\ \\}{}
+ \newcommand{\defvarx}[2][\mbox{}]{%
+ \texttt{#1*#2*}\\}
+ \newenvironment{defconst}[2]{%
+ \textbf{[Constant]}\\
+ \texttt{#1#2}\\}{}
+ \newcommand{\defconstx}[2][\mbox{}]{\texttt{#1#2}\\}
+ \newenvironment{deftp}[3]{%
+ \textbf{[#1]}\\
+ \texttt{#2} \textit{#3}\\}{}
+ \newenvironment{Lentry}{\begin{description}}{\end{description}}
+\end{htmlonly}
+
+%% Set up margins
+\setlength{\oddsidemargin}{-10pt}
+\setlength{\evensidemargin}{-10pt}
+\setlength{\topmargin}{-40pt}
+\setlength{\headheight}{12pt}
+\setlength{\headsep}{25pt}
+\setlength{\footskip}{30pt}
+\setlength{\textheight}{9.25in}
+\setlength{\textwidth}{6.75in}
+\setlength{\columnsep}{0.375in}
+\setlength{\columnseprule}{0pt}
+
+
+\setcounter{tocdepth}{2}
+\setcounter{secnumdepth}{3}
+\def\textfraction{.1}
+\def\bottomfraction{.9} % was .3
+\def\topfraction{.9}
+
+\pagestyle{headings}
+
+\begin{document}
+%%\alwaysrefill
+\relax
+%%\newindex{cp}
+%%\newindex{ky}
+
+\newcommand{\theabstract}{%
+
+ CMU Common Lisp is an implementation of that Common Lisp runs on
+ various Unix workstations. See the README file in the distribution
+ for current platforms. The largest single part of this document
+ describes the Python compiler and the programming styles and
+ techniques that the compiler encourages. The rest of the document
+ describes extensions and the implementation dependent choices made
+ in developing this implementation of Common Lisp. We have added
+ several extensions, including a source level debugger, an interface
+ to Unix system calls, a foreign function call interface, support for
+ interprocess communication and remote procedure call, and other
+ features that provide a good environment for developing Lisp code.
+ }
+
+\newcommand{\researchcredit}{%
+ This research was sponsored by the Defense Advanced Research
+ Projects Agency, Information Science and Technology Office, under
+ the title \emph{Research on Parallel Computing} issued by DARPA/CMO
+ under Contract MDA972-90-C-0035 ARPA Order No. 7330.
+
+ The views and conclusions contained in this document are those of
+ the authors and should not be interpreted as representing the
+ official policies, either expressed or implied, of the Defense
+ Advanced Research Projects Agency or the U.S. government.}
+
+\pagestyle{empty}
+\title{CMU Common Lisp User's Manual}
+
+%%\author{Robert A. MacLachlan, \var{Editor}}
+%%\date{July 1992}
+%%\trnumber{CMU-CS-92-161}
+%%\citationinfo{
+%%\begin{center}
+%%Supersedes Technical Reports CMU-CS-87-156 and CMU-CS-91-108.
+%%\end{center}
+%%}
+%%%%\arpasupport{strategic}
+%%\abstract{\theabstract}
+%%%%\keywords{lisp, Common Lisp, manual, compiler,
+%%%% programming language implementation, programming environment}
+
+%%\maketitle
+\begin{latexonly}
+
+%% \title{CMU Common Lisp User's Manual}
+
+ \author{Robert A. MacLachlan,
+ \emph{Editor}%
+ \thanks{\small This research was sponsored by the Defense Advanced
+ Research Projects Agency, Information Science and Technology
+ Office, under the title \emph{Research on Parallel Computing}
+ issued by DARPA/CMO under Contract MDA972-90-C-0035 ARPA Order No.
+ 7330. The views and conclusions contained in this document are
+ those of the authors and should not be interpreted as representing
+ the official policies, either expressed or implied, of the Defense
+ Advanced Research Projects Agency or the U.S. government.}}
+
+
+
+\date{\bigskip
+ July 1992 \\ CMU-CS-92-161 \\
+ \vspace{0.25in}
+ October 31, 1997 \\
+ Net Version \\
+ \vspace{0.75in} {\small
+ School of Computer Science \\
+ Carnegie Mellon University \\
+ Pittsburgh, PA 15213} \\
+ \vspace{0.5in} \small Supersedes Technical Reports CMU-CS-87-156 and
+ CMU-CS-91-108.\\
+ \vspace{0.5in} \textbf{Abstract} \medskip
+ \begin{quote}
+ \theabstract
+ \end{quote}
+ }
+
+\maketitle
+\end{latexonly}
+
+%% Nice HTML version of the title page
+\begin{rawhtml}
+
+ <h1 align=center>CMU Common Lisp User's Manual</h1>
+
+ <p align=center>Robert A. MacLachlan, <EM>Editor</EM>
+ </p>
+ <p align=center>
+ July 1992 <BR>
+ CMU-CS-92-161 <BR>
+ </p>
+ <br>
+ <p align=center>
+ July 1997 <BR>
+ Net Version <BR>
+ </p>
+
+ <p align=center>
+ School of Computer Science <BR>
+ Carnegie Mellon University <BR>
+ Pittsburgh, PA 15213 <BR>
+ </p>
+ <br>
+ <p>
+ Supersedes Technical Reports CMU-CS-87-156 and
+ CMU-CS-91-108.<BR>
+ </p>
+
+ <p align=center>
+ <b>Abstract</b>
+ <blockquote>
+ CMU Common Lisp is an implementation of that Common Lisp runs on
+ various Unix workstations. See the README file in the
+ distribution for current platforms. The largest single part of
+ this document describes the Python compiler and the programming
+ styles and techniques that the compiler encourages. The rest of
+ the document describes extensions and the implementation
+ dependent choices made in developing this implementation of
+ Common Lisp. We have added several extensions, including a
+ source level debugger, an interface to Unix system calls, a
+ foreign function call interface, support for interprocess
+ communication and remote procedure call, and other features that
+ provide a good environment for developing Lisp code.
+ </blockquote>
+ </p>
+ <blockquote><font size=-1>
+ This research was sponsored by the Defense Advanced Research
+ Projects Agency, Information Science and Technology Office, under
+ the title <em>Research on Parallel Computing</em> issued by DARPA/CMO
+ under Contract MDA972-90-C-0035 ARPA Order No. 7330.
+ <p>
+ The views and conclusions contained in this document are those of
+ the authors and should not be interpreted as representing the
+ official policies, either expressed or implied, of the Defense
+ Advanced Research Projects Agency or the U.S. government.
+ </p></font>
+ </blockquote>
+ </p>
+\end{rawhtml}
+\clearpage
+\vspace*{\fill}
+\textbf{Keywords:} lisp, Common Lisp, manual, compiler,
+programming language implementation, programming environment
+\clearpage
+\pagestyle{headings}
+\pagenumbering{roman}
+\tableofcontents
+
+\clearpage
+\pagenumbering{arabic}
+%%\end{iftex}
+
+%%\setfilename{cmu-user.info}
+%%\node Top, Introduction, (dir), (dir)
+
+
+\hide{File:/afs/cs.cmu.edu/project/clisp/hackers/ram/docs/cmu-user/intro.ms}
+
+
+
+\hide{ -*- Dictionary: cmu-user -*- }
+\begin{comment}
+* Introduction::
+* Design Choices and Extensions::
+* The Debugger::
+* The Compiler::
+* Advanced Compiler Use and Efficiency Hints::
+* UNIX Interface::
+* Event Dispatching with SERVE-EVENT::
+* Alien Objects::
+* Interprocess Communication under LISP::
+* Debugger Programmer's Interface::
+* Function Index::
+* Variable Index::
+* Type Index::
+* Concept Index::
+
+ --- The Detailed Node Listing ---
+
+Introduction
+
+* Support::
+* Local Distribution of CMU Common Lisp::
+* Net Distribution of CMU Common Lisp::
+* Source Availability::
+* Command Line Options::
+* Credits::
+
+Design Choices and Extensions
+
+* Data Types::
+* Default Interrupts for Lisp::
+* Packages::
+* The Editor::
+* Garbage Collection::
+* Describe::
+* The Inspector::
+* Load::
+* The Reader::
+* Running Programs from Lisp::
+* Saving a Core Image::
+* Pathnames::
+* Filesystem Operations::
+* Time Parsing and Formatting::
+* Lisp Library::
+
+Data Types
+
+* Symbols::
+* Integers::
+* Floats::
+* Characters::
+* Array Initialization::
+
+Floats
+
+* IEEE Special Values::
+* Negative Zero::
+* Denormalized Floats::
+* Floating Point Exceptions::
+* Floating Point Rounding Mode::
+* Accessing the Floating Point Modes::
+
+The Inspector
+
+* The Graphical Interface::
+* The TTY Inspector::
+
+Running Programs from Lisp
+
+* Process Accessors::
+
+Pathnames
+
+* Unix Pathnames::
+* Wildcard Pathnames::
+* Logical Pathnames::
+* Search Lists::
+* Predefined Search-Lists::
+* Search-List Operations::
+* Search List Example::
+
+Logical Pathnames
+
+* Search Lists::
+* Search List Example::
+
+Search-List Operations
+
+* Search List Example::
+
+Filesystem Operations
+
+* Wildcard Matching::
+* File Name Completion::
+* Miscellaneous Filesystem Operations::
+
+The Debugger
+
+* Debugger Introduction::
+* The Command Loop::
+* Stack Frames::
+* Variable Access::
+* Source Location Printing::
+* Compiler Policy Control::
+* Exiting Commands::
+* Information Commands::
+* Breakpoint Commands::
+* Function Tracing::
+* Specials::
+
+Stack Frames
+
+* Stack Motion::
+* How Arguments are Printed::
+* Function Names::
+* Funny Frames::
+* Debug Tail Recursion::
+* Unknown Locations and Interrupts::
+
+Variable Access
+
+* Variable Value Availability::
+* Note On Lexical Variable Access::
+
+Source Location Printing
+
+* How the Source is Found::
+* Source Location Availability::
+
+Breakpoint Commands
+
+* Breakpoint Example::
+
+Function Tracing
+
+* Encapsulation Functions::
+
+The Compiler
+
+* Compiler Introduction::
+* Calling the Compiler::
+* Compilation Units::
+* Interpreting Error Messages::
+* Types in Python::
+* Getting Existing Programs to Run::
+* Compiler Policy::
+* Open Coding and Inline Expansion::
+
+Compilation Units
+
+* Undefined Warnings::
+
+Interpreting Error Messages
+
+* The Parts of the Error Message::
+* The Original and Actual Source::
+* The Processing Path::
+* Error Severity::
+* Errors During Macroexpansion::
+* Read Errors::
+* Error Message Parameterization::
+
+Types in Python
+
+* Compile Time Type Errors::
+* Precise Type Checking::
+* Weakened Type Checking::
+
+Compiler Policy
+
+* The Optimize Declaration::
+* The Optimize-Interface Declaration::
+
+Advanced Compiler Use and Efficiency Hints
+
+* Advanced Compiler Introduction::
+* More About Types in Python::
+* Type Inference::
+* Source Optimization::
+* Tail Recursion::
+* Local Call::
+* Block Compilation::
+* Inline Expansion::
+* Byte Coded Compilation::
+* Object Representation::
+* Numbers::
+* General Efficiency Hints::
+* Efficiency Notes::
+* Profiling::
+
+Advanced Compiler Introduction
+
+* Types::
+* Optimization::
+* Function Call::
+* Representation of Objects::
+* Writing Efficient Code::
+
+More About Types in Python
+
+* More Types Meaningful::
+* Canonicalization::
+* Member Types::
+* Union Types::
+* The Empty Type::
+* Function Types::
+* The Values Declaration::
+* Structure Types::
+* The Freeze-Type Declaration::
+* Type Restrictions::
+* Type Style Recommendations::
+
+Type Inference
+
+* Variable Type Inference::
+* Local Function Type Inference::
+* Global Function Type Inference::
+* Operation Specific Type Inference::
+* Dynamic Type Inference::
+* Type Check Optimization::
+
+Source Optimization
+
+* Let Optimization::
+* Constant Folding::
+* Unused Expression Elimination::
+* Control Optimization::
+* Unreachable Code Deletion::
+* Multiple Values Optimization::
+* Source to Source Transformation::
+* Style Recommendations::
+
+Tail Recursion
+
+* Tail Recursion Exceptions::
+
+Local Call
+
+* Self-Recursive Calls::
+* Let Calls::
+* Closures::
+* Local Tail Recursion::
+* Return Values::
+
+Block Compilation
+
+* Block Compilation Semantics::
+* Block Compilation Declarations::
+* Compiler Arguments::
+* Practical Difficulties::
+* Context Declarations::
+* Context Declaration Example::
+
+Inline Expansion
+
+* Inline Expansion Recording::
+* Semi-Inline Expansion::
+* The Maybe-Inline Declaration::
+
+Object Representation
+
+* Think Before You Use a List::
+* Structure Representation::
+* Arrays::
+* Vectors::
+* Bit-Vectors::
+* Hashtables::
+
+Numbers
+
+* Descriptors::
+* Non-Descriptor Representations::
+* Variables::
+* Generic Arithmetic::
+* Fixnums::
+* Word Integers::
+* Floating Point Efficiency::
+* Specialized Arrays::
+* Specialized Structure Slots::
+* Interactions With Local Call::
+* Representation of Characters::
+
+General Efficiency Hints
+
+* Compile Your Code::
+* Avoid Unnecessary Consing::
+* Complex Argument Syntax::
+* Mapping and Iteration::
+* Trace Files and Disassembly::
+
+Efficiency Notes
+
+* Type Uncertainty::
+* Efficiency Notes and Type Checking::
+* Representation Efficiency Notes::
+* Verbosity Control::
+
+Profiling
+
+* Profile Interface::
+* Profiling Techniques::
+* Nested or Recursive Calls::
+* Clock resolution::
+* Profiling overhead::
+* Additional Timing Utilities::
+* A Note on Timing::
+* Benchmarking Techniques::
+
+UNIX Interface
+
+* Reading the Command Line::
+* Lisp Equivalents for C Routines::
+* Type Translations::
+* System Area Pointers::
+* Unix System Calls::
+* File Descriptor Streams::
+* Making Sense of Mach Return Codes::
+* Unix Interrupts::
+
+Unix Interrupts
+
+* Changing Interrupt Handlers::
+* Examples of Signal Handlers::
+
+Event Dispatching with SERVE-EVENT
+
+* Object Sets::
+* The SERVE-EVENT Function::
+* Using SERVE-EVENT with Unix File Descriptors::
+* Using SERVE-EVENT with the CLX Interface to X::
+* A SERVE-EVENT Example::
+
+Using SERVE-EVENT with the CLX Interface to X
+
+* Without Object Sets::
+* With Object Sets::
+
+A SERVE-EVENT Example
+
+* Without Object Sets Example::
+* With Object Sets Example::
+
+Alien Objects
+
+* Introduction to Aliens::
+* Alien Types::
+* Alien Operations::
+* Alien Variables::
+* Alien Data Structure Example::
+* Loading Unix Object Files::
+* Alien Function Calls::
+* Step-by-Step Alien Example::
+
+Alien Types
+
+* Defining Alien Types::
+* Alien Types and Lisp Types::
+* Alien Type Specifiers::
+* The C-Call Package::
+
+Alien Operations
+
+* Alien Access Operations::
+* Alien Coercion Operations::
+* Alien Dynamic Allocation::
+
+Alien Variables
+
+* Local Alien Variables::
+* External Alien Variables::
+
+Alien Function Calls
+
+* alien-funcall:: The alien-funcall Primitive
+* def-alien-routine:: The def-alien-routine Macro
+* def-alien-routine Example::
+* Calling Lisp from C::
+
+Interprocess Communication under LISP
+
+* The REMOTE Package::
+* The WIRE Package::
+* Out-Of-Band Data::
+
+The REMOTE Package
+
+* Connecting Servers and Clients::
+* Remote Evaluations::
+* Remote Objects::
+* Host Addresses::
+
+The WIRE Package
+
+* Untagged Data::
+* Tagged Data::
+* Making Your Own Wires::
+
+Debugger Programmer's Interface
+
+* DI Exceptional Conditions::
+* Debug-variables::
+* Frames::
+* Debug-functions::
+* Debug-blocks::
+* Breakpoints::
+* Code-locations::
+* Debug-sources::
+* Source Translation Utilities::
+
+DI Exceptional Conditions
+
+* Debug-conditions::
+* Debug-errors::
+\end{comment}
+
+%%\node Introduction, Design Choices and Extensions, Top, Top
+\chapter{Introduction}
+
+CMU Common Lisp is a public-domain implementation of Common Lisp developed in
+the Computer Science Department of Carnegie Mellon University. \cmucl{} runs
+on various Unix workstations---see the README file in the distribution for
+current platforms. This document describes the implementation based on the
+Python compiler. Previous versions of CMU Common Lisp ran on the IBM RT PC
+and (when known as Spice Lisp) on the Perq workstation. See \code{man cmucl}
+(\file{man/man1/cmucl.1}) for other general information.
+
+\cmucl{} sources and executables are freely available via anonymous FTP; this
+software is ``as is'', and has no warranty of any kind. CMU and the
+authors assume no responsibility for the consequences of any use of this
+software. See \file{doc/release-notes.txt} for a description of the
+state of the release you have.
+
+\begin{comment}
+* Support::
+* Local Distribution of CMU Common Lisp::
+* Net Distribution of CMU Common Lisp::
+* Source Availability::
+* Command Line Options::
+* Credits::
+\end{comment}
+
+%%\node Support, Local Distribution of CMU Common Lisp, Introduction, Introduction
+\section{Support}
+
+The CMU Common Lisp project is no longer funded, so only minimal support is
+being done at CMU. There is a net community of \cmucl{} users and maintainers
+who communicate via comp.lang.lisp and the cmucl-bugs@cs.cmu.edu
+\begin{changebar}
+ cmucl-imp@cons.org
+\end{changebar}
+mailing lists.
+
+This manual contains only implementation-specific information about
+\cmucl. Users will also need a separate manual describing the
+\clisp{} standard. \clisp{} was initially defined in \i{Common Lisp:
+ The Language}, by Guy L. Steele Jr. \clisp{} is now undergoing
+standardization by the X3J13 committee of ANSI. The X3J13 spec is not
+yet completed, but a number of clarifications and modification have
+been approved. We intend that \cmucl{} will eventually adhere to the
+X3J13 spec, and we have already implemented many of the changes
+approved by X3J13.
+
+Until the X3J13 standard is completed, the second edition of
+\cltltwo{} is probably the best available manual for the language and
+for our implementation of it. This book has no official role in the
+standardization process, but it does include many of the changes
+adopted since the first edition was completed.
+
+In addition to the language itself, this document describes a number
+of useful library modules that run in \cmucl. \hemlock, an Emacs-like
+text editor, is included as an integral part of the \cmucl{}
+environment. Two documents describe \hemlock{}: the \i{Hemlock User's
+ Manual}, and the \i{Hemlock Command Implementor's Manual}.
+
+%%\node Local Distribution of CMU Common Lisp, Net Distribution of CMU Common Lisp, Support, Introduction
+\section{Local Distribution of CMU Common Lisp}
+
+In CMU CS, \cmucl{} should be runnable as \file{/usr/local/bin/cmucl}.
+The full binary distribution should appear under
+\file{/usr/local/lib/cmucl/}. Note that the first time you run Lisp,
+it will take AFS several minutes to copy the image into its local
+cache. Subsequent starts will be much faster.
+
+Or, you can run directly out of the AFS release area (which may be
+necessary on SunOS machines). Put this in your \file{.login} shell
+script:
+\begin{example}
+setenv CMUCLLIB "/afs/cs/misc/cmucl/@sys/beta/lib"
+setenv PATH \${PATH}:/afs/cs/misc/cmucl/@sys/beta/bin
+\end{example}
+
+If you also set \code{MANPATH} or \code{MPATH} (depending on the Unix)
+to point to \file{/usr/local/lib/cmucl/man/}, then `\code{man cmucl}'
+will give an introduction to CMU CL and \samp{man lisp} will describe
+command line options. For installation notes, see the \file{README}
+file in the release area.
+
+See \file{/usr/local/lib/cmucl/doc} for release notes and
+documentation. Hardcopy documentation is available in the document
+room. Documentation supplements may be available for recent
+additions: see the \file{README} file.
+
+Send bug reports and questions to \samp{cmucl-bugs@cs.cmu.edu}. If
+you send a bug report to \samp{gripe} or \samp{help}, they will just
+forward it to this mailing list.
+
+%%\node Net Distribution of CMU Common Lisp, Source Availability, Local Distribution of CMU Common Lisp, Introduction
+\section{Net Distribution of CMU Common Lisp}
+
+\subsection{CMU Distribution}
+Externally, CMU Common Lisp is only available via anonymous FTP. We
+don't have the manpower to make tapes. These are our distribution
+machines:
+\begin{example}
+lisp-rt1.slisp.cs.cmu.edu (128.2.217.9)
+lisp-rt2.slisp.cs.cmu.edu (128.2.217.10)
+\end{example}
+
+Log in with the user \samp{anonymous} and \samp{username@host} as
+password (i.e. your EMAIL address.) When you log in, the current
+directory should be set to the \cmucl{} release area. If you have any
+trouble with FTP access, please send mail to \samp{slisp@cs.cmu.edu}.
+
+The release area holds compressed tar files with names of the form:
+\begin{example}
+\var{version}-\var{machine}_\var{os}.tar.Z
+\end{example}
+FTP compressed tar archives in binary mode. To extract, \samp{cd} to
+the directory that is to be the root of the tree, then type:
+\begin{example}
+uncompress <file.tar.Z | tar xf - .
+\end{example}
+The resulting tree is about 23 megabytes. For installation
+directions, see the section ``site initialization'' in README file at
+the root of the tree.
+
+If poor network connections make it difficult to transfer a 10 meg
+file, the release is also available split into five parts, with the
+suffix \file{.0} to \file{.4}. To extract from multiple files, use:
+\begin{example}
+cat file.tar.Z.* | uncompress | tar xf - .
+\end{example}
+
+The release area also contains source distributions and other binary
+distributions. A listing of the current contents of the release area
+is in \file{FILES}. Major release announcements will be made to
+\code{comp.lang.lisp} until there is enough volume to warrant a
+\code{comp.lang.lisp.cmu}.
+
+\begin{changebar}
+\subsection{Net Distribution}
+Although the CMU Common Lisp project is no longer actively developed
+by CMU, development has continued. You can obtain this version from
+either
+\begin{example}
+ ftp://ftp2.cons.org/pub/languages/lisp/cmucl
+ http://www2.cons.org:8000/ftp-area/cmucl/
+\end{example}
+Further information can be found via the World Wide Web at
+\begin{example}
+ http://www.cons.org/cmucl
+\end{example}
+\end{changebar}
+%%\node Source Availability, Command Line Options, Net Distribution of CMU Common Lisp, Introduction
+\section{Source Availability}
+
+Lisp and documentation sources are available via anonymous FTP ftp to
+any CMU CS machine. All CMU written code is public domain, but CMU CL
+also makes use of two imported packages: PCL and CLX. Although these
+packages are copyrighted, they may be freely distributed without any
+licensing agreement or fee. See the \file{README} file in the binary
+distribution for up-to-date source pointers.
+
+The release area contains a source distribution, which is an image of
+all the \file{.lisp} source files used to build a particular system
+\var{version}:
+\begin{example}
+\var{version}-source.tar.Z (3.6 meg)
+\end{example}
+
+All of our files (including the release area) are actually in the AFS
+file system. On the release machines, the FTP server's home is the
+release directory: \file{/afs/cs.cmu.edu/project/clisp/release}. The
+actual working source areas are in other subdirectories of
+\file{clisp}, and you can directly ``cd'' to those directories if you
+know the name. Due to the way anonymous FTP access control is done,
+it is important to ``cd'' to the source directory with a single
+command, and then do a ``get'' operation.
+
+\begin{changebar}
+ Alternatively, you can obtain the current sources via WWW at
+ \begin{example}
+ http://www.cons.org/cmucl
+ \end{example}
+ which contains pointers on how to get a \code{tar} file of the
+ current sources or how to get an individual file from the sources.
+ Binary versions for selected platforms are also available as well.
+\end{changebar}
+
+%%\node Command Line Options, Credits, Source Availability, Introduction
+\section{Command Line Options}
+
+The command line syntax and environment is described in the lisp(1)
+man page in the man/man1 directory of the distribution. See also
+cmucl(1). Currently Lisp accepts the following switches:
+\begin{Lentry}
+ \begin{changebar}
+ \item[\code{-batch}] specifies batch mode, where all input is
+ directed from standard-input. An error code of 0 is returned upon
+ encountering an EOF and 1 otherwise.
+ \end{changebar}
+\item[\code{-core}] requires an argument that should be the name of a
+ core file. Rather than using the default core file
+ (\file{lib/lisp.core}), the specified core file is loaded.
+
+\item[\code{-edit}] specifies to enter Hemlock. A file to edit may be
+ specified by placing the name of the file between the program name
+ (usually \file{lisp}) and the first switch.
+
+\item[\code{-eval}] accepts one argument which should be a Lisp form
+ to evaluate during the start up sequence. The value of the form
+ will not be printed unless it is wrapped in a form that does output.
+
+\item[\code{-hinit}] accepts an argument that should be the name of
+ the hemlock init file to load the first time the function
+ \findexed{ed} is invoked. The default is to load
+ \file{hemlock-init.\var{object-type}}, or if that does not exist,
+ \file{hemlock-init.lisp} from the user's home directory. If the
+ file is not in the user's home directory, the full path must be
+ specified.
+
+\item[\code{-init}] accepts an argument that should be the name of an
+ init file to load during the normal start up sequence. The default
+ is to load \file{init.\var{object-type}} or, if that does not exist,
+ \file{init.lisp} from the user's home directory. If the file is not
+ in the user's home directory, the full path must be specified.
+
+\item[\code{-noinit}] accepts no arguments and specifies that an init
+ file should not be loaded during the normal start up sequence.
+ Also, this switch suppresses the loading of a hemlock init file when
+ Hemlock is started up with the \code{-edit} switch.
+
+\item[\code{-load}] accepts an argument which should be the name of a
+ file to load into Lisp before entering Lisp's read-eval-print loop.
+
+\item[\code{-slave}] specifies that Lisp should start up as a
+ \i{slave} Lisp and try to connect to an editor Lisp. The name of
+ the editor to connect to must be specified\dash{}to find the
+ editor's name, use the \hemlock{} ``\code{Accept Slave
+ Connections}'' command. The name for the editor Lisp is of the
+ form:
+ \begin{example}
+ \var{machine-name}\code{:}\var{socket}
+ \end{example}
+ where \var{machine-name} is the internet host name for the machine
+ and \var{socket} is the decimal number of the socket to connect to.
+\end{Lentry}
+For more details on the use of the \code{-edit} and \code{-slave}
+switches, see the \i{Hemlock User's Manual}.
+
+Arguments to the above switches can be specified in one of two ways:
+\w{\var{switch}\code{=}\var{value}} or
+\w{\var{switch}<\var{space}>\var{value}}. For example, to start up
+the saved core file mylisp.core use either of the following two
+commands:
+\begin{example}
+\code{lisp -core=mylisp.core
+lisp -core mylisp.core}
+\end{example}
+
+%%\node Credits, , Command Line Options, Introduction
+\section{Credits}
+
+Since 1981 many people have contributed to the development of CMU
+Common Lisp. The currently active members are:
+\begin{display}
+Marco Antoniotti
+David Axmark
+Miles Bader
+Casper Dik
+Scott Fahlman * (fearless leader)
+Paul Gleichauf *
+Richard Harris
+Joerg-Cyril Hoehl
+Chris Hoover
+Simon Leinen
+Sandra Loosemore
+William Lott *
+Robert A. Maclachlan *
+\end{display}
+\noindent
+Many people are voluntarily working on improving CMU Common Lisp. ``*''
+means a full-time CMU employee, and ``+'' means a part-time student
+employee. A partial listing of significant past contributors follows:
+\begin{display}
+Tim Moore
+Sean Hallgren +
+Mike Garland +
+Ted Dunning
+Rick Busdiecker
+Bill Chiles *
+John Kolojejchick
+Todd Kaufmann +
+Dave McDonald *
+Skef Wholey *
+\end{display}
+
+
+\vspace{2 em}
+\researchcredit
+
+\begin{changebar}
+ From 1995, development of CMU Common Lisp has been continued by a
+ group of volunteers. A partial list of volunteers includes the
+ following
+ \begin{table}[h]
+ \begin{center}
+ \begin{tabular}{ll}
+ Paul Werkowski & pw@snoopy.mv.com \\
+ Peter VanEynde & s950045@uia.ua.ac.be \\
+ Marco Antoniotti & marcoxa@PATH.Berkeley.EDU\\
+ Martin Cracauer & cracauer@cons.org\\
+ Douglas Thomas Crosher & dtc@scrooge.ee.swin.oz.au\\
+ Simon Leinen & simon@switch.ch\\
+ Rob MacLachlan & ram+@CS.cmu.edu\\
+ Raymond Toy & toy@rtp.ericsson.se
+ \end{tabular}
+ \end{center}
+ \end{table}
+
+ In particular Paul Werkowski completed the port for the x86
+ architecture for FreeBSD. Peter VanEnyde took the FreeBSD port and
+ created a Linux version.
+\end{changebar}
+
+
+\hide{File:/afs/cs.cmu.edu/project/clisp/hackers/ram/docs/cmu-user/design.ms}
+
+\hide{ -*- Dictionary: cmu-user -*- }
+%%\node Design Choices and Extensions, The Debugger, Introduction, Top
+\chapter{Design Choices and Extensions}
+
+Several design choices in Common Lisp are left to the individual
+implementation, and some essential parts of the programming environment
+are left undefined. This chapter discusses the most important design
+choices and extensions.
+
+\begin{comment}
+* Data Types::
+* Default Interrupts for Lisp::
+* Packages::
+* The Editor::
+* Garbage Collection::
+* Describe::
+* The Inspector::
+* Load::
+* The Reader::
+* Running Programs from Lisp::
+* Saving a Core Image::
+* Pathnames::
+* Filesystem Operations::
+* Time Parsing and Formatting::
+* Lisp Library::
+\end{comment}
+
+%%\node Data Types, Default Interrupts for Lisp, Design Choices and Extensions, Design Choices and Extensions
+\section{Data Types}
+
+\begin{comment}
+* Symbols::
+* Integers::
+* Floats::
+* Characters::
+* Array Initialization::
+\end{comment}
+
+%%\node Symbols, Integers, Data Types, Data Types
+\subsection{Symbols}
+
+As in \cltl, all symbols and package names are printed in lower case, as
+a user is likely to type them. Internally, they are normally stored
+upper case only.
+
+%%\node Integers, Floats, Symbols, Data Types
+\subsection{Integers}
+
+The \tindexed{fixnum} type is equivalent to \code{(signed-byte 30)}.
+Integers outside this range are represented as a \tindexed{bignum} or
+a word integer (\pxlref{word-integers}.) Almost all integers that
+appear in programs can be represented as a \code{fixnum}, so integer
+number consing is rare.
+
+%%\node Floats, Characters, Integers, Data Types
+\subsection{Floats}
+\label{ieee-float}
+
+\cmucl{} supports two floating point formats: \tindexed{single-float}
+and \tindexed{double-float}. These are implemented with IEEE single
+and double float arithmetic, respectively. \code{short-float} is a
+synonym for \code{single-float}, and \code{long-float} is a synonym
+for \code{double-float}. The initial value of
+\vindexed{read-default-float-format} is \code{single-float}.
+
+Both \code{single-float} and \code{double-float} are represented with
+a pointer descriptor, so float operations can cause number consing.
+Number consing is greatly reduced if programs are written to allow the
+use of non-descriptor representations (\pxlref{numeric-types}.)
+
+
+\begin{comment}
+* IEEE Special Values::
+* Negative Zero::
+* Denormalized Floats::
+* Floating Point Exceptions::
+* Floating Point Rounding Mode::
+* Accessing the Floating Point Modes::
+\end{comment}
+
+%%\node IEEE Special Values, Negative Zero, Floats, Floats
+\subsubsection{IEEE Special Values}
+
+\cmucl{} supports the IEEE infinity and NaN special values. These
+non-numeric values will only be generated when trapping is disabled
+for some floating point exception (\pxlref{float-traps}), so users of
+the default configuration need not concern themselves with special
+values.
+
+\begin{defconst}{extensions:}{short-float-positive-infinity}
+ \defconstx[extensions:]{short-float-negative-infinity}
+ \defconstx[extensions:]{single-float-positive-infinity}
+ \defconstx[extensions:]{single-float-negative-infinity}
+ \defconstx[extensions:]{double-float-positive-infinity}
+ \defconstx[extensions:]{double-float-negative-infinity}
+ \defconstx[extensions:]{long-float-positive-infinity}
+ \defconstx[extensions:]{long-float-negative-infinity}
+
+ The values of these constants are the IEEE positive and negative
+ infinity objects for each float format.
+\end{defconst}
+
+\begin{defun}{extensions:}{float-infinity-p}{\args{\var{x}}}
+
+ This function returns true if \var{x} is an IEEE float infinity (of
+ either sign.) \var{x} must be a float.
+\end{defun}
+
+\begin{defun}{extensions:}{float-nan-p}{\args{\var{x}}}
+ \defunx[extensions:]{float-trapping-nan-p}{\args{\var{x}}}
+
+ \code{float-nan-p} returns true if \var{x} is an IEEE NaN (Not A
+ Number) object. \code{float-trapping-nan-p} returns true only if
+ \var{x} is a trapping NaN. With either function, \var{x} must be a
+ float.
+\end{defun}
+
+%%\node Negative Zero, Denormalized Floats, IEEE Special Values, Floats
+\subsubsection{Negative Zero}
+
+The IEEE float format provides for distinct positive and negative
+zeros. To test the sign on zero (or any other float), use the
+\clisp{} \findexed{float-sign} function. Negative zero prints as
+\code{-0.0f0} or \code{-0.0d0}.
+
+%%\node Denormalized Floats, Floating Point Exceptions, Negative Zero, Floats
+\subsubsection{Denormalized Floats}
+
+\cmucl{} supports IEEE denormalized floats. Denormalized floats
+provide a mechanism for gradual underflow. The \clisp{}
+\findexed{float-precision} function returns the actual precision of a
+denormalized float, which will be less than \findexed{float-digits}.
+Note that in order to generate (or even print) denormalized floats,
+trapping must be disabled for the underflow exception
+(\pxlref{float-traps}.) The \clisp{}
+\w{\code{least-positive-}\var{format}-\code{float}} constants are
+denormalized.
+
+\begin{defun}{extensions:}{float-normalized-p}{\args{\var{x}}}
+
+ This function returns true if \var{x} is a denormalized float.
+ \var{x} must be a float.
+\end{defun}
+
+%%\node Floating Point Exceptions, Floating Point Rounding Mode, Denormalized Floats, Floats
+\subsubsection{Floating Point Exceptions}
+\label{float-traps}
+
+The IEEE floating point standard defines several exceptions that occur
+when the result of a floating point operation is unclear or
+undesirable. Exceptions can be ignored, in which case some default
+action is taken, such as returning a special value. When trapping is
+enabled for an exception, a error is signalled whenever that exception
+occurs. These are the possible floating point exceptions:
+\begin{Lentry}
+
+\item[\kwd{underflow}] This exception occurs when the result of an
+ operation is too small to be represented as a normalized float in
+ its format. If trapping is enabled, the
+ \tindexed{floating-point-underflow} condition is signalled.
+ Otherwise, the operation results in a denormalized float or zero.
+
+\item[\kwd{overflow}] This exception occurs when the result of an
+ operation is too large to be represented as a float in its format.
+ If trapping is enabled, the \tindexed{floating-point-overflow}
+ exception is signalled. Otherwise, the operation results in the
+ appropriate infinity.
+
+\item[\kwd{inexact}] This exception occurs when the result of a
+ floating point operation is not exact, i.e. the result was rounded.
+ If trapping is enabled, the \code{extensions:floating-point-inexact}
+ condition is signalled. Otherwise, the rounded result is returned.
+
+\item[\kwd{invalid}] This exception occurs when the result of an
+ operation is ill-defined, such as \code{\w{(/ 0.0 0.0)}}. If
+ trapping is enabled, the \code{extensions:floating-point-invalid}
+ condition is signalled. Otherwise, a quiet NaN is returned.
+
+\item[\kwd{divide-by-zero}] This exception occurs when a float is
+ divided by zero. If trapping is enabled, the
+ \tindexed{divide-by-zero} condition is signalled. Otherwise, the
+ appropriate infinity is returned.
+\end{Lentry}
+
+%%\node Floating Point Rounding Mode, Accessing the Floating Point Modes, Floating Point Exceptions, Floats
+\subsubsection{Floating Point Rounding Mode}
+\label{float-rounding-modes}
+
+IEEE floating point specifies four possible rounding modes:
+\begin{Lentry}
+
+\item[\kwd{nearest}] In this mode, the inexact results are rounded to
+ the nearer of the two possible result values. If the neither
+ possibility is nearer, then the even alternative is chosen. This
+ form of rounding is also called ``round to even'', and is the form
+ of rounding specified for the \clisp{} \findexed{round} function.
+
+\item[\kwd{positive-infinity}] This mode rounds inexact results to the
+ possible value closer to positive infinity. This is analogous to
+ the \clisp{} \findexed{ceiling} function.
+
+\item[\kwd{negative-infinity}] This mode rounds inexact results to the
+ possible value closer to negative infinity. This is analogous to
+ the \clisp{} \findexed{floor} function.
+
+\item[\kwd{zero}] This mode rounds inexact results to the possible
+ value closer to zero. This is analogous to the \clisp{}
+ \findexed{truncate} function.
+\end{Lentry}
+
+\paragraph{Warning:}
+
+Although the rounding mode can be changed with
+\code{set-floating-point-modes}, use of any value other than the
+default (\kwd{nearest}) can cause unusual behavior, since it will
+affect rounding done by \llisp{} system code as well as rounding in
+user code. In particular, the unary \code{round} function will stop
+doing round-to-nearest on floats, and instead do the selected form of
+rounding.
+
+%%\node Accessing the Floating Point Modes, , Floating Point Rounding Mode, Floats
+\subsubsection{Accessing the Floating Point Modes}
+
+These functions can be used to modify or read the floating point modes:
+
+\begin{defun}{extensions:}{set-floating-point-modes}{%
+ \keys{\kwd{traps} \kwd{rounding-mode}}
+ \morekeys{\kwd{fast-mode} \kwd{accrued-exceptions}}
+ \yetmorekeys{\kwd{current-exceptions}}}
+ \defunx[extensions:]{get-floating-point-modes}{}
+
+ The keyword arguments to \code{set-floating-point-modes} set various
+ modes controlling how floating point arithmetic is done:
+ \begin{Lentry}
+
+ \item[\kwd{traps}] A list of the exception conditions that should
+ cause traps. Possible exceptions are \kwd{underflow},
+ \kwd{overflow}, \kwd{inexact}, \kwd{invalid} and
+ \kwd{divide-by-zero}. Initially all traps except \kwd{inexact}
+ are enabled. \xlref{float-traps}.
+
+ \item[\kwd{rounding-mode}] The rounding mode to use when the result
+ is not exact. Possible values are \kwd{nearest},
+ \latex{\kwd{positive\-infinity}}\html{\kwd{positive-infinity}},
+ \kwd{negative-infinity} and \kwd{zero}. Initially, the rounding
+ mode is \kwd{nearest}. See the warning in section
+ \ref{float-rounding-modes} about use of other rounding modes.
+
+ \item[\kwd{current-exceptions}, \kwd{accrued-exceptions}] Lists of
+ exception keywords used to set the exception flags. The
+ \var{current-exceptions} are the exceptions for the previous
+ operation, so setting it is not very useful. The
+ \var{accrued-exceptions} are a cumulative record of the exceptions
+ that occurred since the last time these flags were cleared.
+ Specifying \code{()} will clear any accrued exceptions.
+
+ \item[\kwd{fast-mode}] Set the hardware's ``fast mode'' flag, if
+ any. When set, IEEE conformance or debuggability may be impaired.
+ Some machines may not have this feature, in which case the value
+ is always \false. No currently supported machines have a fast
+ mode.
+ \end{Lentry}
+ If a keyword argument is not supplied, then the associated state is
+ not changed.
+
+ \code{get-floating-point-modes} returns a list representing the
+ state of the floating point modes. The list is in the same format
+ as the keyword arguments to \code{set-floating-point-modes}, so
+ \code{apply} could be used with \code{set-floating-point-modes} to
+ restore the modes in effect at the time of the call to
+ \code{get-floating-point-modes}.
+\end{defun}
+
+\begin{changebar}
+To make handling control of floating-point exceptions, the following
+macro is useful.
+
+\begin{defmac}{ext:}{with-float-traps-masked}{traps \ampbody\ body}
+ \code{body} is executed with the selected floating-point exceptions
+ given by \code{traps} masked out (disabled). \code{traps} should be
+ a list of possible floating-point exceptions that should be ignored.
+ Possible values are \kwd{underflow}, \kwd{overflow}, \kwd{inexact},
+ \kwd{invalid} and \kwd{divide-by-zero}.
+
+ This is equivalent to saving the current traps from
+ \code{get-floating-point-modes}, setting the floating-point modes to
+ the desired exceptions, running the \code{body}, and restoring the
+ saved floating-point modes. The advantage of this macro is that it
+ causes less consing to occur.
+
+ Some points about the with-float-traps-masked:
+
+ \begin{itemize}
+ \item Two approaches are available for detecting FP exceptions:
+ \begin{enumerate}
+ \item enabling the traps and handling the exceptions
+ \item disabling the traps and either handling the return values or
+ checking the accrued exceptions.
+ \end{enumerate}
+ Of these the latter is the most portable because on the alpha port
+ it is not possible to enable some traps at run-time.
+
+ \item To assist the checking of the exceptions within the body any
+ accrued exceptions matching the given traps are cleared at the
+ start of the body when the traps are masked.
+
+ \item To allow the macros to be nested these accrued exceptions are
+ restored at the end of the body to their values at the start of
+ the body. Thus any exceptions that occurred within the body will
+ not affect the accrued exceptions outside the macro.
+
+ \item Note that only the given exceptions are restored at the end of
+ the body so other exception will be visible in the accrued
+ exceptions outside the body.
+
+ \item On the x86, setting the accrued exceptions of an unmasked
+ exception would cause a FP trap. The macro behaviour of restoring
+ the accrued exceptions ensures than if an accrued exception is
+ initially not flagged and occurs within the body it will be
+ restored/cleared at the exit of the body and thus not cause a
+ trap.
+
+ \item On the x86, and, perhaps, the hppa, the FP exceptions may be
+ delivered at the next FP instruction which requires a FP
+ \code{wait} instruction (\code{%vm::float-wait}) if using the lisp
+ conditions to catch trap within a \code{handler-bind}. The
+ \code{handler-bind} macro does the right thing and inserts a
+ float-wait (at the end of its body on the x86). The masking and
+ noting of exceptions is also safe here.
+
+ \item The setting of the FP flags uses the
+ \code{(floating-point-modes)} and the \code{(set
+ (floating-point-modes)\ldots)} VOPs. These VOPs blindly update
+ the flags which may include other state. We assume this state
+ hasn't changed in between getting and setting the state. For
+ example, if you used the FP unit between the above calls, the
+ state may be incorrectly restored! The
+ \code{with-float-traps-masked} macro keeps the intervening code to
+ a minimum and uses only integer operations.
+ %% Safe byte-compiled?
+ %% Perhaps the VOPs (x86) should be smarter and only update some of
+ %% the flags, the trap masks and exceptions?
+ \end{itemize}
+
+\end{defmac}
+\end{changebar}
+
+%%\node Characters, Array Initialization, Floats, Data Types
+\subsection{Characters}
+
+\cmucl{} implements characters according to \i{Common Lisp: the
+ Language II}. The main difference from the first version is that
+character bits and font have been eliminated, and the names of the
+types have been changed. \tindexed{base-character} is the new
+equivalent of the old \tindexed{string-char}. In this implementation,
+all characters are base characters (there are no extended characters.)
+Character codes range between \code{0} and \code{255}, using the ASCII
+encoding.
+\begin{changebar}
+ Table~\ref{tbl:chars}~\vpageref{tbl:chars} shows characters
+ recognized by \cmucl.
+\end{changebar}
+
+\begin{changebar}
+\begin{table}[tbhp]
+ \begin{center}
+ \begin{tabular}{|c|c|l|l|l|l|}
+ \hline
+ \multicolumn{2}{|c|}{ASCII} & \multicolumn{1}{|c}{Lisp} &
+ \multicolumn{3}{|c|}{} \\
+ \cline{1-2}
+ Name & Code & \multicolumn{1}{|c|}{Name} & \multicolumn{3}{|c|}{\raisebox{1.5ex}{Alternatives}}\\
+ \hline
+ \hline
+ \code{nul} & 0 & \code{\#\back{NULL}} & \code{\#\back{NUL}} & &\\
+ \code{bel} & 7 & \code{\#\back{BELL}} & & &\\
+ \code{bs} & 8 & \code{\#\back{BACKSPACE}} & \code{\#\back{BS}} & &\\
+ \code{tab} & 9 & \code{\#\back{TAB}} & & &\\
+ \code{lf} & 10 & \code{\#\back{NEWLINE}} & \code{\#\back{NL}} & \code{\#\back{LINEFEED}} & \code{\#\back{LF}}\\
+ \code{ff} & 11 & \code{\#\back{VT}} & \code{\#\back{PAGE}} & \code{\#\back{FORM}} &\\
+ \code{cr} & 13 & \code{\#\back{RETURN}} & \code{\#\back{CR}} & &\\
+ \code{esc} & 27 & \code{\#\back{ESCAPE}} & \code{\#\back{ESC}} & \code{\#\back{ALTMODE}} & \code{\#\back{ALT}}\\
+ \code{sp} & 32 & \code{\#\back{SPACE}} & \code{\#\back{SP}} & &\\
+ \code{del} & 127 & \code{\#\back{DELETE}} & \code{\#\back{RUBOUT}} & &\\
+ \hline
+ \end{tabular}
+ \caption{Characters recognized by \cmucl}
+ \label{tbl:chars}
+ \end{center}
+\end{table}
+\end{changebar}
+
+%%\node Array Initialization, , Characters, Data Types
+\subsection{Array Initialization}
+
+If no \kwd{initial-value} is specified, arrays are initialized to zero.
+
+
+%%\node Default Interrupts for Lisp, Packages, Data Types, Design Choices and Extensions
+\section{Default Interrupts for Lisp}
+
+CMU Common Lisp has several interrupt handlers defined when it starts up,
+as follows:
+\begin{Lentry}
+
+\item[\code{SIGINT} (\ctrl{c})] causes Lisp to enter a break loop.
+ This puts you into the debugger which allows you to look at the
+ current state of the computation. If you proceed from the break
+ loop, the computation will proceed from where it was interrupted.
+
+\item[\code{SIGQUIT} (\ctrl{L})] causes Lisp to do a throw to the
+ top-level. This causes the current computation to be aborted, and
+ control returned to the top-level read-eval-print loop.
+
+\item[\code{SIGTSTP} (\ctrl{z})] causes Lisp to suspend execution and
+ return to the Unix shell. If control is returned to Lisp, the
+ computation will proceed from where it was interrupted.
+
+\item[\code{SIGILL}, \code{SIGBUS}, \code{SIGSEGV}, and \code{SIGFPE}]
+ cause Lisp to signal an error.
+\end{Lentry}
+For keyboard interrupt signals, the standard interrupt character is in
+parentheses. Your \file{.login} may set up different interrupt
+characters. When a signal is generated, there may be some delay before
+it is processed since Lisp cannot be interrupted safely in an arbitrary
+place. The computation will continue until a safe point is reached and
+then the interrupt will be processed. \xlref{signal-handlers} to define
+your own signal handlers.
+
+%%\node Packages, The Editor, Default Interrupts for Lisp, Design Choices and Extensions
+\section{Packages}
+
+When CMU Common Lisp is first started up, the default package is the
+\code{user} package. The \code{user} package uses the
+\code{common-lisp}, \code{extensions}, and \code{pcl} packages. The
+symbols exported from these three packages can be referenced without
+package qualifiers. This section describes packages which have
+exported interfaces that may concern users. The numerous internal
+packages which implement parts of the system are not described here.
+Package nicknames are in parenthesis after the full name.
+\begin{Lentry}
+\item[\code{alien}, \code{c-call}] Export the features of the Alien
+ foreign data structure facility (\pxlref{aliens}.)
+
+\item[\code{pcl}] This package contains PCL (Portable CommonLoops),
+ which is a portable implementation of CLOS (the Common Lisp Object
+ System.) This implements most (but not all) of the features in the
+ CLOS chapter of \cltltwo.
+
+\item[\code{debug}] The \code{debug} package contains the command-line
+ oriented debugger. It exports utility various functions and
+ switches.
+
+\item[\code{debug-internals}] The \code{debug-internals} package
+ exports the primitives used to write debuggers.
+ \xlref{debug-internals}.
+
+\item[\code{extensions (ext)}] The \code{extensions} packages exports
+ local extensions to Common Lisp that are documented in this manual.
+ Examples include the \code{save-lisp} function and time parsing.
+
+\item[\code{hemlock (ed)}] The \code{hemlock} package contains all the
+ code to implement Hemlock commands. The \code{hemlock} package
+ currently exports no symbols.
+
+\item[\code{hemlock-internals (hi)}] The \code{hemlock-internals}
+ package contains code that implements low level primitives and
+ exports those symbols used to write Hemlock commands.
+
+\item[\code{keyword}] The \code{keyword} package contains keywords
+ (e.g., \kwd{start}). All symbols in the \code{keyword} package are
+ exported and evaluate to themselves (i.e., the value of the symbol
+ is the symbol itself).
+
+\item[\code{profile}] The \code{profile} package exports a simple
+ run-time profiling facility (\pxlref{profiling}).
+
+\item[\code{common-lisp (cl lisp)}] The \code{common-lisp} package
+ exports all the symbols defined by \i{Common Lisp: the Language} and
+ only those symbols. Strictly portable Lisp code will depend only on
+ the symbols exported from the \code{lisp} package.
+
+\item[\code{unix}, \code{mach}] These packages export system call
+ interfaces to generic BSD Unix and Mach (\pxlref{unix-interface}).
+
+\item[\code{system (sys)}] The \code{system} package contains
+ functions and information necessary for system interfacing. This
+ package is used by the \code{lisp} package and exports several
+ symbols that are necessary to interface to system code.
+
+\item[\code{common-lisp-user (user cl-user)}] The
+ \code{common-lisp-user} package is the default package and is where
+ a user's code and data is placed unless otherwise specified. This
+ package exports no symbols.
+
+\item[\code{xlib}] The \code{xlib} package contains the Common Lisp X
+ interface (CLX) to the X11 protocol. This is mostly Lisp code with
+ a couple of functions that are defined in C to connect to the
+ server.
+
+\item[\code{wire}] The \code{wire} package exports a remote procedure
+ call facility (\pxlref{remote}).
+\end{Lentry}
+
+
+%%\node The Editor, Garbage Collection, Packages, Design Choices and Extensions
+\section{The Editor}
+
+The \code{ed} function invokes the Hemlock editor which is described
+in \i{Hemlock User's Manual} and \i{Hemlock Command Implementor's
+ Manual}. Most users at CMU prefer to use Hemlock's slave \Llisp{}
+mechanism which provides an interactive buffer for the
+\code{read-eval-print} loop and editor commands for evaluating and
+compiling text from a buffer into the slave \Llisp. Since the editor
+runs in the \Llisp, using slaves keeps users from trashing their
+editor by developing in the same \Llisp{} with \Hemlock.
+
+
+%%\node Garbage Collection, Describe, The Editor, Design Choices and Extensions
+\section{Garbage Collection}
+
+CMU Common Lisp uses a stop-and-copy garbage collector that compacts
+the items in dynamic space every time it runs. Most users cause the
+system to garbage collect (GC) frequently, long before space is
+exhausted. With 16 or 24 megabytes of memory, causing GC's more
+frequently on less garbage allows the system to GC without much (if
+any) paging.
+
+\hide{
+With the default value for the following variable, you can expect a GC to take
+about one minute of elapsed time on a 6 megabyte machine running X as well as
+Lisp. On machines with 8 megabytes or more of memory a GC should run without
+much (if any) paging. GC's run more frequently but tend to take only about 5
+seconds.
+}
+
+The following functions invoke the garbage collector or control whether
+automatic garbage collection is in effect:
+
+\begin{defun}{extensions:}{gc}{}
+
+ This function runs the garbage collector. If
+ \code{ext:*gc-verbose*} is non-\nil, then it invokes
+ \code{ext:*gc-notify-before*} before GC'ing and
+ \code{ext:*gc-notify-after*} afterwards.
+\end{defun}
+
+\begin{defun}{extensions:}{gc-off}{}
+
+ This function inhibits automatic garbage collection. After calling
+ it, the system will not GC unless you call \code{ext:gc} or
+ \code{ext:gc-on}.
+\end{defun}
+
+\begin{defun}{extensions:}{gc-on}{}
+
+ This function reinstates automatic garbage collection. If the
+ system would have GC'ed while automatic GC was inhibited, then this
+ will call \code{ext:gc}.
+\end{defun}
+
+%%\node
+\subsection{GC Parameters}
+The following variables control the behavior of the garbage collector:
+
+\begin{defvar}{extensions:}{bytes-consed-between-gcs}
+
+ CMU Common Lisp automatically GC's whenever the amount of memory
+ allocated to dynamic objects exceeds the value of an internal
+ variable. After each GC, the system sets this internal variable to
+ the amount of dynamic space in use at that point plus the value of
+ the variable \code{ext:*bytes-consed-between-gcs*}. The default
+ value is 2000000.
+\end{defvar}
+
+\begin{defvar}{extensions:}{gc-verbose}
+
+ This variable controls whether \code{ext:gc} invokes the functions
+ in \code{ext:*gc-notify-before*} and
+ \code{ext:*gc-notify-after*}. If \code{*gc-verbose*} is \nil,
+ \code{ext:gc} foregoes printing any messages. The default value is
+ \code{T}.
+\end{defvar}
+
+\begin{defvar}{extensions:}{gc-notify-before}
+
+ This variable's value is a function that should notify the user that
+ the system is about to GC. It takes one argument, the amount of
+ dynamic space in use before the GC measured in bytes. The default
+ value of this variable is a function that prints a message similar
+ to the following:
+\begin{display}
+ \b{[GC threshold exceeded with 2,107,124 bytes in use. Commencing GC.]}
+\end{display}
+\end{defvar}
+
+\begin{defvar}{extensions:}{gc-notify-after}
+
+ This variable's value is a function that should notify the user when
+ a GC finishes. The function must take three arguments, the amount
+ of dynamic spaced retained by the GC, the amount of dynamic space
+ freed, and the new threshold which is the minimum amount of space in
+ use before the next GC will occur. All values are byte quantities.
+ The default value of this variable is a function that prints a
+ message similar to the following:
+ \begin{display}
+ \b{[GC completed with 25,680 bytes retained and 2,096,808 bytes freed.]}
+ \b{[GC will next occur when at least 2,025,680 bytes are in use.]}
+ \end{display}
+\end{defvar}
+
+Note that a garbage collection will not happen at exactly the new
+threshold printed by the default \code{ext:*gc-notify-after*}
+function. The system periodically checks whether this threshold has
+been exceeded, and only then does a garbage collection.
+
+\begin{defvar}{extensions:}{gc-inhibit-hook}
+
+ This variable's value is either a function of one argument or \nil.
+ When the system has triggered an automatic GC, if this variable is a
+ function, then the system calls the function with the amount of
+ dynamic space currently in use (measured in bytes). If the function
+ returns \nil, then the GC occurs; otherwise, the system inhibits
+ automatic GC as if you had called \code{ext:gc-off}. The writer of
+ this hook is responsible for knowing when automatic GC has been
+ turned off and for calling or providing a way to call
+ \code{ext:gc-on}. The default value of this variable is \nil.
+\end{defvar}
+
+\begin{defvar}{extensions:}{before-gc-hooks}
+ \defvarx[extensions:]{after-gc-hooks}
+
+ These variables' values are lists of functions to call before or
+ after any GC occurs. The system provides these purely for
+ side-effect, and the functions take no arguments.
+\end{defvar}
+
+%%\node
+\subsection{Weak Pointers}
+
+A weak pointer provides a way to maintain a reference to an object
+without preventing an object from being garbage collected. If the
+garbage collector discovers that the only pointers to an object are
+weak pointers, then it breaks the weak pointers and deallocates the
+object.
+
+\begin{defun}{extensions:}{make-weak-pointer}{\args{\var{object}}}
+ \defunx[extensions:]{weak-pointer-value}{\args{\var{weak-pointer}}}
+
+ \code{make-weak-pointer} returns a weak pointer to an object.
+ \code{weak-pointer-value} follows a weak pointer, returning the two
+ values: the object pointed to (or \false{} if broken) and a boolean
+ value which is true if the pointer has been broken.
+\end{defun}
+
+%%\node
+\subsection{Finalization}
+
+Finalization provides a ``hook'' that is triggered when the garbage
+collector reclaims an object. It is usually used to recover non-Lisp
+resources that were allocated to implement the finalized Lisp object.
+For example, when a unix file-descriptor stream is collected,
+finalization is used to close the underlying file descriptor.
+
+\begin{defun}{extensions:}{finalize}{\args{\var{object} \var{function}}}
+
+ This function registers \var{object} for finalization.
+ \var{function} is called with no arguments when \var{object} is
+ reclaimed. Normally \var{function} will be a closure over the
+ underlying state that needs to be freed, e.g. the unix file
+ descriptor in the fd-stream case. Note that \var{function} must not
+ close over \var{object} itself, as this prevents the object from
+ ever becoming garbage.
+\end{defun}
+
+\begin{defun}{extensions:}{cancel-finalization}{\args{\var{object}}}
+
+ This function cancel any finalization request for \var{object}.
+\end{defun}
+
+%%\node Describe, The Inspector, Garbage Collection, Design Choices and Extensions
+\section{Describe}
+
+In addition to the basic function described below, there are a number of
+switches and other things that can be used to control \code{describe}'s
+behavior.
+
+\begin{defun}{}{describe}{ \args{\var{object} \&optional{} \var{stream}}}
+
+ The \code{describe} function prints useful information about
+ \var{object} on \var{stream}, which defaults to
+ \code{*standard-output*}. For any object, \code{describe} will
+ print out the type. Then it prints other information based on the
+ type of \var{object}. The types which are presently handled are:
+
+ \begin{Lentry}
+
+ \item[\tindexed{hash-table}] \code{describe} prints the number of
+ entries currently in the hash table and the number of buckets
+ currently allocated.
+
+ \item[\tindexed{function}] \code{describe} prints a list of the
+ function's name (if any) and its formal parameters. If the name
+ has function documentation, then it will be printed. If the
+ function is compiled, then the file where it is defined will be
+ printed as well.
+
+ \item[\tindexed{fixnum}] \code{describe} prints whether the integer
+ is prime or not.
+
+ \item[\tindexed{symbol}] The symbol's value, properties, and
+ documentation are printed. If the symbol has a function
+ definition, then the function is described.
+ \end{Lentry}
+ If there is anything interesting to be said about some component of
+ the object, describe will invoke itself recursively to describe that
+ object. The level of recursion is indicated by indenting output.
+\end{defun}
+
+\begin{defvar}{extensions:}{describe-level}
+
+ The maximum level of recursive description allowed. Initially two.
+\end{defvar}
+
+\begin{defvar}{extensions:}{describe-indentation}
+
+The number of spaces to indent for each level of recursive
+description, initially three.
+\end{defvar}
+
+\begin{defvar}{extensions:}{describe-print-level}
+ \defvarx[extensions:]{describe-print-length}
+
+ The values of \code{*print-level*} and \code{*print-length*} during
+ description. Initially two and five.
+\end{defvar}
+
+%%\node The Inspector, Load, Describe, Design Choices and Extensions
+\section{The Inspector}
+
+\cmucl{} has both a graphical inspector that uses X windows and a simple
+terminal-based inspector.
+
+\begin{defun}{}{inspect}{ \args{\ampoptional{} \var{object}}}
+
+ \code{inspect} calls the inspector on the optional argument
+ \var{object}. If \var{object} is unsupplied, \code{inspect}
+ immediately returns \false. Otherwise, the behavior of inspect
+ depends on whether Lisp is running under X. When \code{inspect} is
+ eventually exited, it returns some selected Lisp object.
+\end{defun}
+
+\begin{comment}
+* The Graphical Interface::
+* The TTY Inspector::
+\end{comment}
+
+%%\node The Graphical Interface, The TTY Inspector, The Inspector, The Inspector
+\subsection{The Graphical Interface}
+\label{motif-interface}
+
+CMU Common Lisp has an interface to Motif which is functionally similar to
+CLM, but works better in CMU CL. See:
+\begin{example}
+\file{doc/motif-toolkit.doc}
+\file{doc/motif-internals.doc}
+\end{example}
+
+This motif interface has been used to write the inspector and graphical
+debugger. There is also a Lisp control panel with a simple file management
+facility, apropos and inspector dialogs, and controls for setting global
+options. See the \code{interface} and \code{toolkit} packages.
+
+\begin{defun}{interface:}{lisp-control-panel}{}
+
+ This function creates a control panel for the Lisp process.
+\end{defun}
+
+\begin{defvar}{interface:}{interface-style}
+
+ When the graphical interface is loaded, this variable controls
+ whether it is used by \code{inspect} and the error system. If the
+ value is \kwd{graphics} (the default) and the \code{DISPLAY}
+ environment variable is defined, the graphical inspector and
+ debugger will be invoked by \findexed{inspect} or when an error is
+ signalled. Possible values are \kwd{graphics} and {tty}. If the
+ value is \kwd{graphics}, but there is no X display, then we quietly
+ use the TTY interface.
+\end{defvar}
+
+%%\node The TTY Inspector, , The Graphical Interface, The Inspector
+\subsection{The TTY Inspector}
+
+If X is unavailable, a terminal inspector is invoked. The TTY inspector
+is a crude interface to \code{describe} which allows objects to be
+traversed and maintains a history. This inspector prints information
+about and object and a numbered list of the components of the object.
+The command-line based interface is a normal
+\code{read}--\code{eval}--\code{print} loop, but an integer \var{n}
+descends into the \var{n}'th component of the current object, and
+symbols with these special names are interpreted as commands:
+\begin{Lentry}
+\item[U] Move back to the enclosing object. As you descend into the
+components of an object, a stack of all the objects previously seen is
+kept. This command pops you up one level of this stack.
+
+\item[Q, E] Return the current object from \code{inspect}.
+
+\item[R] Recompute object display, and print again. Useful if the
+object may have changed.
+
+\item[D] Display again without recomputing.
+
+\item[H, ?] Show help message.
+\end{Lentry}
+
+%%\node Load, The Reader, The Inspector, Design Choices and Extensions
+\section{Load}
+
+\begin{defun}{}{load}{%
+ \args{\var{filename}
+ \keys{\kwd{verbose} \kwd{print} \kwd{if-does-not-exist}}
+ \morekeys{\kwd{if-source-newer} \kwd{contents}}}}
+
+ As in standard Common Lisp, this function loads a file containing
+ source or object code into the running Lisp. Several CMU extensions
+ have been made to \code{load} to conveniently support a variety of
+ program file organizations. \var{filename} may be a wildcard
+ pathname such as \file{*.lisp}, in which case all matching files are
+ loaded.
+
+ If \var{filename} has a \code{pathname-type} (or extension), then
+ that exact file is loaded. If the file has no extension, then this
+ tells \code{load} to use a heuristic to load the ``right'' file.
+ The \code{*load-source-types*} and \code{*load-object-types*}
+ variables below are used to determine the default source and object
+ file types. If only the source or the object file exists (but not
+ both), then that file is quietly loaded. Similarly, if both the
+ source and object file exist, and the object file is newer than the
+ source file, then the object file is loaded. The value of the
+ \var{if-source-newer} argument is used to determine what action to
+ take when both the source and object files exist, but the object
+ file is out of date:
+ \begin{Lentry}
+ \item[\kwd{load-object}] The object file is loaded even though the
+ source file is newer.
+
+ \item[\kwd{load-source}] The source file is loaded instead of the
+ older object file.
+
+ \item[\kwd{compile}] The source file is compiled and then the new
+ object file is loaded.
+
+ \item[\kwd{query}] The user is asked a yes or no question to
+ determine whether the source or object file is loaded.
+ \end{Lentry}
+ This argument defaults to the value of
+ \code{ext:*load-if-source-newer*} (initially \kwd{load-object}.)
+
+ The \var{contents} argument can be used to override the heuristic
+ (based on the file extension) that normally determines whether to
+ load the file as a source file or an object file. If non-null, this
+ argument must be either \kwd{source} or \kwd{binary}, which forces
+ loading in source and binary mode, respectively. You really
+ shouldn't ever need to use this argument.
+\end{defun}
+
+\begin{defvar}{extensions:}{load-source-types}
+ \defvarx[extensions:]{load-object-types}
+
+ These variables are lists of possible \code{pathname-type} values
+ for source and object files to be passed to \code{load}. These
+ variables are only used when the file passed to \code{load} has no
+ type; in this case, the possible source and object types are used to
+ default the type in order to determine the names of the source and
+ object files.
+\end{defvar}
+
+\begin{defvar}{extensions:}{load-if-source-newer}
+
+ This variable determines the default value of the
+ \var{if-source-newer} argument to \code{load}. Its initial value is
+ \kwd{load-object}.
+\end{defvar}
+
+%%\node The Reader, Stream Extensions, Load, Design Choices and Extensions
+\section{The Reader}
+
+\begin{defvar}{extensions:}{ignore-extra-close-parentheses}
+
+ If this variable is \true{} (the default), then the reader merely
+ prints a warning when an extra close parenthesis is detected
+ (instead of signalling an error.)
+\end{defvar}
+
+%%\node Stream Extensions, Running Programs from Lisp, The Reader, Design Choices and Extensions
+\section{Stream Extensions}
+\begin{defun}{extensions:}{read-n-bytes}{%
+ \args{\var{stream buffer start numbytes}
+ \ampoptional{} \var{eof-error-p}}}
+
+ On streams that support it, this function reads multiple bytes of
+ data into a buffer. The buffer must be a \code{simple-string} or
+ \code{(simple-array (unsigned-byte 8) (*))}. The argument
+ \var{nbytes} specifies the desired number of bytes, and the return
+ value is the number of bytes actually read.
+ \begin{itemize}
+ \item If \var{eof-error-p} is true, an \tindexed{end-of-file}
+ condition is signalled if end-of-file is encountered before
+ \var{count} bytes have been read.
+
+ \item If \var{eof-error-p} is false, \code{read-n-bytes reads} as
+ much data is currently available (up to count bytes.) On pipes or
+ similar devices, this function returns as soon as any data is
+ available, even if the amount read is less than \var{count} and
+ eof has not been hit. See also \funref{make-fd-stream}.
+ \end{itemize}
+\end{defun}
+%%\node Running Programs from Lisp, Saving a Core Image, The Reader, Design Choices and Extensions
+\section{Running Programs from Lisp}
+
+It is possible to run programs from Lisp by using the following function.
+
+\begin{defun}{extensions:}{run-program}{%
+ \args{\var{program} \var{args}
+ \keys{\kwd{env} \kwd{wait} \kwd{pty} \kwd{input}}
+ \morekeys{\kwd{if-input-does-not-exist}}
+ \yetmorekeys{\kwd{output} \kwd{if-output-exists}}
+ \yetmorekeys{\kwd{error} \kwd{if-error-exists}}
+ \yetmorekeys{\kwd{status-hook} \kwd{before-execve}}}}
+
+ \code{run-program} runs \var{program} in a child process.
+ \var{Program} should be a pathname or string naming the program.
+ \var{Args} should be a list of strings which this passes to
+ \var{program} as normal Unix parameters. For no arguments, specify
+ \var{args} as \nil. The value returned is either a process
+ structure or \nil. The process interface follows the description of
+ \code{run-program}. If \code{run-program} fails to fork the child
+ process, it returns \nil.
+
+ Except for sharing file descriptors as explained in keyword argument
+ descriptions, \code{run-program} closes all file descriptors in the
+ child process before running the program. When you are done using a
+ process, call \code{process-close} to reclaim system resources. You
+ only need to do this when you supply \kwd{stream} for one of
+ \kwd{input}, \kwd{output}, or \kwd{error}, or you supply \kwd{pty}
+ non-\nil. You can call \code{process-close} regardless of whether
+ you must to reclaim resources without penalty if you feel safer.
+
+ \code{run-program} accepts the following keyword arguments:
+ \begin{Lentry}
+
+ \item[\kwd{env}] This is an a-list mapping keywords and
+ simple-strings. The default is \code{ext:*environment-list*}. If
+ \kwd{env} is specified, \code{run-program} uses the value given
+ and does not combine the environment passed to Lisp with the one
+ specified.
+
+ \item[\kwd{wait}] If non-\nil{} (the default), wait until the child
+ process terminates. If \nil, continue running Lisp while the
+ child process runs.
+
+ \item[\kwd{pty}] This should be one of \true, \nil, or a stream. If
+ specified non-\nil, the subprocess executes under a Unix \i{PTY}.
+ If specified as a stream, the system collects all output to this
+ pty and writes it to this stream. If specified as \true, the
+ \code{process-pty} slot contains a stream from which you can read
+ the program's output and to which you can write input for the
+ program. The default is \nil.
+
+ \item[\kwd{input}] This specifies how the program gets its input.
+ If specified as a string, it is the name of a file that contains
+ input for the child process. \code{run-program} opens the file as
+ standard input. If specified as \nil{} (the default), then
+ standard input is the file \file{/dev/null}. If specified as
+ \true, the program uses the current standard input. This may
+ cause some confusion if \kwd{wait} is \nil{} since two processes
+ may use the terminal at the same time. If specified as
+ \kwd{stream}, then the \code{process-input} slot contains an
+ output stream. Anything written to this stream goes to the
+ program as input. \kwd{input} may also be an input stream that
+ already contains all the input for the process. In this case
+ \code{run-program} reads all the input from this stream before
+ returning, so this cannot be used to interact with the process.
+
+ \item[\kwd{if-input-does-not-exist}] This specifies what to do if
+ the input file does not exist. The following values are valid:
+ \nil{} (the default) causes \code{run-program} to return \nil{}
+ without doing anything; \kwd{create} creates the named file; and
+ \kwd{error} signals an error.
+
+ \item[\kwd{output}] This specifies what happens with the program's
+ output. If specified as a pathname, it is the name of a file that
+ contains output the program writes to its standard output. If
+ specified as \nil{} (the default), all output goes to
+ \file{/dev/null}. If specified as \true, the program writes to
+ the Lisp process's standard output. This may cause confusion if
+ \kwd{wait} is \nil{} since two processes may write to the terminal
+ at the same time. If specified as \kwd{stream}, then the
+ \code{process-output} slot contains an input stream from which you
+ can read the program's output.
+
+ \item[\kwd{if-output-exists}] This specifies what to do if the
+ output file already exists. The following values are valid:
+ \nil{} causes \code{run-program} to return \nil{} without doing
+ anything; \kwd{error} (the default) signals an error;
+ \kwd{supersede} overwrites the current file; and \kwd{append}
+ appends all output to the file.
+
+ \item[\kwd{error}] This is similar to \kwd{output}, except the file
+ becomes the program's standard error. Additionally, \kwd{error}
+ can be \kwd{output} in which case the program's error output is
+ routed to the same place specified for \kwd{output}. If specified
+ as \kwd{stream}, the \code{process-error} contains a stream
+ similar to the \code{process-output} slot when specifying the
+ \kwd{output} argument.
+
+ \item[\kwd{if-error-exists}] This specifies what to do if the error
+ output file already exists. It accepts the same values as
+ \kwd{if-output-exists}.
+
+ \item[\kwd{status-hook}] This specifies a function to call whenever
+ the process changes status. This is especially useful when
+ specifying \kwd{wait} as \nil. The function takes the process as
+ a required argument.
+
+ \item[\kwd{before-execve}] This specifies a function to run in the
+ child process before it becomes the program to run. This is
+ useful for actions such as authenticating the child process
+ without modifying the parent Lisp process.
+ \end{Lentry}
+\end{defun}
+
+
+\begin{comment}
+* Process Accessors::
+\end{comment}
+
+%%\node Process Accessors, , Running Programs from Lisp, Running Programs from Lisp
+\subsection{Process Accessors}
+
+The following functions interface the process returned by \code{run-program}:
+
+\begin{defun}{extensions:}{process-p}{\args{\var{thing}}}
+
+ This function returns \true{} if \var{thing} is a process.
+ Otherwise it returns \nil{}
+\end{defun}
+
+\begin{defun}{extensions:}{process-pid}{\args{\var{process}}}
+
+ This function returns the process ID, an integer, for the
+ \var{process}.
+\end{defun}
+
+\begin{defun}{extensions:}{process-status}{\args{\var{process}}}
+
+ This function returns the current status of \var{process}, which is
+ one of \kwd{running}, \kwd{stopped}, \kwd{exited}, or
+ \kwd{signaled}.
+\end{defun}
+
+\begin{defun}{extensions:}{process-exit-code}{\args{\var{process}}}
+
+ This function returns either the exit code for \var{process}, if it
+ is \kwd{exited}, or the termination signal \var{process} if it is
+ \kwd{signaled}. The result is undefined for processes that are
+ still alive.
+\end{defun}
+
+\begin{defun}{extensions:}{process-core-dumped}{\args{\var{process}}}
+
+ This function returns \true{} if someone used a Unix signal to
+ terminate the \var{process} and caused it to dump a Unix core image.
+\end{defun}
+
+\begin{defun}{extensions:}{process-pty}{\args{\var{process}}}
+
+ This function returns either the two-way stream connected to
+ \var{process}'s Unix \i{PTY} connection or \nil{} if there is none.
+\end{defun}
+
+\begin{defun}{extensions:}{process-input}{\args{\var{process}}}
+ \defunx[extensions:]{process-output}{\args{\var{process}}}
+ \defunx[extensions:]{process-error}{\args{\var{process}}}
+
+ If the corresponding stream was created, these functions return the
+ input, output or error file descriptor. \nil{} is returned if there
+ is no stream.
+\end{defun}
+
+\begin{defun}{extensions:}{process-status-hook}{\args{\var{process}}}
+
+ This function returns the current function to call whenever
+ \var{process}'s status changes. This function takes the
+ \var{process} as a required argument. \code{process-status-hook} is
+ \code{setf}'able.
+\end{defun}
+
+\begin{defun}{extensions:}{process-plist}{\args{\var{process}}}
+
+ This function returns annotations supplied by users, and it is
+ \code{setf}'able. This is available solely for users to associate
+ information with \var{process} without having to build a-lists or
+ hash tables of process structures.
+\end{defun}
+
+\begin{defun}{extensions:}{process-wait}{
+ \args{\var{process} \ampoptional{} \var{check-for-stopped}}}
+
+ This function waits for \var{process} to finish. If
+ \var{check-for-stopped} is non-\nil, this also returns when
+ \var{process} stops.
+\end{defun}
+
+\begin{defun}{extensions:}{process-kill}{%
+ \args{\var{process} \var{signal} \ampoptional{} \var{whom}}}
+
+ This function sends the Unix \var{signal} to \var{process}.
+ \var{Signal} should be the number of the signal or a keyword with
+ the Unix name (for example, \kwd{sigsegv}). \var{Whom} should be
+ one of the following:
+ \begin{Lentry}
+
+ \item[\kwd{pid}] This is the default, and it indicates sending the
+ signal to \var{process} only.
+
+ \item[\kwd{process-group}] This indicates sending the signal to
+ \var{process}'s group.
+
+ \item[\kwd{pty-process-group}] This indicates sending the signal to
+ the process group currently in the foreground on the Unix \i{PTY}
+ connected to \var{process}. This last option is useful if the
+ running program is a shell, and you wish to signal the program
+ running under the shell, not the shell itself. If
+ \code{process-pty} of \var{process} is \nil, using this option is
+ an error.
+ \end{Lentry}
+\end{defun}
+
+\begin{defun}{extensions:}{process-alive-p}{\args{\var{process}}}
+
+ This function returns \true{} if \var{process}'s status is either
+ \kwd{running} or \kwd{stopped}.
+\end{defun}
+
+\begin{defun}{extensions:}{process-close}{\args{\var{process}}}
+
+ This function closes all the streams associated with \var{process}.
+ When you are done using a process, call this to reclaim system
+ resources.
+\end{defun}
+
+
+%%\node Saving a Core Image, Pathnames, Running Programs from Lisp, Design Choices and Extensions
+\section{Saving a Core Image}
+
+A mechanism has been provided to save a running Lisp core image and to
+later restore it. This is convenient if you don't want to load several files
+into a Lisp when you first start it up. The main problem is the large
+size of each saved Lisp image, typically at least 20 megabytes.
+
+\begin{defun}{extensions:}{save-lisp}{%
+ \args{\var{file}
+ \keys{\kwd{purify} \kwd{root-structures} \kwd{init-function}}
+ \morekeys{\kwd{load-init-file} \kwd{print-herald} \kwd{site-init}}
+ \yetmorekeys{\kwd{process-command-line}}}}
+
+ The \code{save-lisp} function saves the state of the currently
+ running Lisp core image in \var{file}. The keyword arguments have
+ the following meaning:
+ \begin{Lentry}
+
+ \item[\kwd{purify}] If non-NIL (the default), the core image is
+ purified before it is saved (see \funref{purify}.) This reduces
+ the amount of work the garbage collector must do when the
+ resulting core image is being run. Also, if more than one Lisp is
+ running on the same machine, this maximizes the amount of memory
+ that can be shared between the two processes.
+
+ \item[\kwd{root-structures}]
+ \begin{changebar}
+ This should be a list of the main entry points in any newly
+ loaded systems. This need not be supplied, but locality and/or
+ GC performance will be better if they are. Meaningless if
+ \kwd{purify} is \nil. See \funref{purify}.
+ \end{changebar}
+
+ \item[\kwd{init-function}] This is the function that starts running
+ when the created core file is resumed. The default function
+ simply invokes the top level read-eval-print loop. If the
+ function returns the lisp will exit.
+
+ \item[\kwd{load-init-file}] If non-NIL, then load an init file;
+ either the one specified on the command line or
+ ``\w{\file{init.}\var{fasl-type}}'', or, if
+ ``\w{\file{init.}\var{fasl-type}}'' does not exist,
+ \code{init.lisp} from the user's home directory. If the init file
+ is found, it is loaded into the resumed core file before the
+ read-eval-print loop is entered.
+
+ \item[\kwd{site-init}] If non-NIL, the name of the site init file to
+ quietly load. The default is \file{library:site-init}. No error
+ is signalled if the file does not exist.
+
+ \item[\kwd{print-herald}] If non-NIL (the default), then print out
+ the standard Lisp herald when starting.
+
+ \item[\kwd{process-command-line}] If non-NIL (the default),
+ processes the command line switches and performs the appropriate
+ actions.
+ \end{Lentry}
+\end{defun}
+
+To resume a saved file, type:
+\begin{example}
+lisp -core file
+\end{example}
+
+\begin{defun}{extensions:}{purify}{
+ \args{\var{file}
+ \keys{\kwd{root-structures} \kwd{environment-name}}}}
+
+ This function optimizes garbage collection by moving all currently
+ live objects into non-collected storage. Once statically allocated,
+ the objects can never be reclaimed, even if all pointers to them are
+ dropped. This function should generally be called after a large
+ system has been loaded and initialized.
+
+ \begin{Lentry}
+ \item[\kwd{root-structures}] is an optional list of objects which
+ should be copied first to maximize locality. This should be a
+ list of the main entry points for the resulting core image. The
+ purification process tries to localize symbols, functions, etc.,
+ in the core image so that paging performance is improved. The
+ default value is NIL which means that Lisp objects will still be
+ localized but probably not as optimally as they could be.
+
+ \var{defstruct} structures defined with the \code{(:pure t)}
+ option are moved into read-only storage, further reducing GC cost.
+ List and vector slots of pure structures are also moved into
+ read-only storage.
+
+ \item[\kwd{environment-name}] is gratuitous documentation for the
+ compacted version of the current global environment (as seen in
+ \code{c::*info-environment*}.) If \false{} is supplied, then
+ environment compaction is inhibited.
+ \end{Lentry}
+\end{defun}
+
+%%\node Pathnames, Filesystem Operations, Saving a Core Image, Design Choices and Extensions
+\section{Pathnames}
+
+In \clisp{} quite a few aspects of \tindexed{pathname} semantics are left to
+the implementation.
+
+\begin{comment}
+* Unix Pathnames::
+* Wildcard Pathnames::
+* Logical Pathnames::
+* Search Lists::
+* Predefined Search-Lists::
+* Search-List Operations::
+* Search List Example::
+\end{comment}
+
+%%\node Unix Pathnames, Wildcard Pathnames, Pathnames, Pathnames
+\subsection{Unix Pathnames}
+\cpsubindex{unix}{pathnames}
+
+Unix pathnames are always parsed with a \code{unix-host} object as the host and
+\code{nil} as the device. The last two dots (\code{.}) in the namestring mark
+the type and version, however if the first character is a dot, it is considered
+part of the name. If the last character is a dot, then the pathname has the
+empty-string as its type. The type defaults to \code{nil} and the version
+defaults to \kwd{newest}.
+\begin{example}
+(defun parse (x)
+ (values (pathname-name x) (pathname-type x) (pathname-version x)))
+
+(parse "foo") \result "foo", NIL, :NEWEST
+(parse "foo.bar") \result "foo", "bar", :NEWEST
+(parse ".foo") \result ".foo", NIL, :NEWEST
+(parse ".foo.bar") \result ".foo", "bar", :NEWEST
+(parse "..") \result ".", "", :NEWEST
+(parse "foo.") \result "foo", "", :NEWEST
+(parse "foo.bar.1") \result "foo", "bar", 1
+(parse "foo.bar.baz") \result "foo.bar", "baz", :NEWEST
+\end{example}
+
+The directory of pathnames beginning with a slash (or a search-list,
+\pxlref{search-lists}) is starts \kwd{absolute}, others start with
+\kwd{relative}. The \code{..} directory is parsed as \kwd{up}; there is no
+namestring for \kwd{back}:
+\begin{example}
+(pathname-directory "/usr/foo/bar.baz") \result (:ABSOLUTE "usr" "foo")
+(pathname-directory "../foo/bar.baz") \result (:RELATIVE :UP "foo")
+\end{example}
+
+%%\node Wildcard Pathnames, Logical Pathnames, Unix Pathnames, Pathnames
+\subsection{Wildcard Pathnames}
+
+Wildcards are supported in Unix pathnames. If `\code{*}' is specified for a
+part of a pathname, that is parsed as \kwd{wild}. `\code{**}' can be used as a
+directory name to indicate \kwd{wild-inferiors}. Filesystem operations
+treat \kwd{wild-inferiors} the same as\ \kwd{wild}, but pathname pattern
+matching (e.g. for logical pathname translation, \pxlref{logical-pathnames})
+matches any number of directory parts with `\code{**}' (see
+\pxlref{wildcard-matching}.)
+
+
+`\code{*}' embedded in a pathname part matches any number of characters.
+Similarly, `\code{?}' matches exactly one character, and `\code{[a,b]}'
+matches the characters `\code{a}' or `\code{b}'. These pathname parts are
+parsed as \code{pattern} objects.
+
+Backslash can be used as an escape character in namestring
+parsing to prevent the next character from being treated as a wildcard. Note
+that if typed in a string constant, the backslash must be doubled, since the
+string reader also uses backslash as a quote:
+\begin{example}
+(pathname-name "foo\(\backslash\backslash\)*bar") => "foo*bar"
+\end{example}
+
+%%\node Logical Pathnames, Search Lists, Wildcard Pathnames, Pathnames
+\subsection{Logical Pathnames}
+\cindex{logical pathnames}
+\label{logical-pathnames}
+
+If a namestring begins with the name of a defined logical pathname
+host followed by a colon, then it will be parsed as a logical
+pathname. Both `\code{*}' and `\code{**}' wildcards are implemented.
+\findexed{load-logical-pathname-defaults} on \var{name} looks for a
+logical host definition file in
+\w{\file{library:\var{name}.translations}}. Note that \file{library:}
+designates the search list (\pxlref{search-lists}) initialized to the
+\cmucl{} \file{lib/} directory, not a logical pathname. The format of
+the file is a single list of two-lists of the from and to patterns:
+\begin{example}
+(("foo;*.text" "/usr/ram/foo/*.txt")
+ ("foo;*.lisp" "/usr/ram/foo/*.l"))
+\end{example}
+
+\begin{comment}
+* Search Lists::
+* Search List Example::
+\end{comment}
+
+%%\node Search Lists, Predefined Search-Lists, Logical Pathnames, Pathnames
+\subsection{Search Lists}
+\cindex{search lists}
+\label{search-lists}
+
+Search lists are an extension to Common Lisp pathnames. They serve a function
+somewhat similar to Common Lisp logical pathnames, but work more like Unix PATH
+variables. Search lists are used for two purposes:
+\begin{itemize}
+\item They provide a convenient shorthand for commonly used directory names,
+and
+
+\item They allow the abstract (directory structure independent) specification
+of file locations in program pathname constants (similar to logical pathnames.)
+\end{itemize}
+Each search list has an associated list of directories (represented as
+pathnames with no name or type component.) The namestring for any relative
+pathname may be prefixed with ``\var{slist}\code{:}'', indicating that the
+pathname is relative to the search list \var{slist} (instead of to the current
+working directory.) Once qualified with a search list, the pathname is no
+longer considered to be relative.
+
+When a search list qualified pathname is passed to a file-system operation such
+as \code{open}, \code{load} or \code{truename}, each directory in the search
+list is successively used as the root of the pathname until the file is
+located. When a file is written to a search list directory, the file is always
+written to the first directory in the list.
+
+%%\node Predefined Search-Lists, Search-List Operations, Search Lists, Pathnames
+\subsection{Predefined Search-Lists}
+
+These search-lists are initialized from the Unix environment or when Lisp was
+built:
+\begin{Lentry}
+\item[\code{default:}] The current directory at startup.
+
+\item[\code{home:}] The user's home directory.
+
+\item[\code{library:}] The \cmucl{} \file{lib/} directory (\code{CMUCLLIB} environment
+variable.)
+
+\item[\code{path:}] The Unix command path (\code{PATH} environment variable.)
+
+\item[\code{target:}] The root of the tree where \cmucl{} was compiled.
+\end{Lentry}
+It can be useful to redefine these search-lists, for example, \file{library:}
+can be augmented to allow logical pathname translations to be located, and
+\file{target:} can be redefined to point to where \cmucl{} system sources are
+locally installed.
+
+%%\node Search-List Operations, Search List Example, Predefined Search-Lists, Pathnames
+\subsection{Search-List Operations}
+
+These operations define and access search-list definitions. A search-list name
+may be parsed into a pathname before the search-list is actually defined, but
+the search-list must be defined before it can actually be used in a filesystem
+operation.
+
+\begin{defun}{extensions:}{search-list}{\var{name}}
+
+ This function returns the list of directories associated with the
+ search list \var{name}. If \var{name} is not a defined search list,
+ then an error is signaled. When set with \code{setf}, the list of
+ directories is changed to the new value. If the new value is just a
+ namestring or pathname, then it is interpreted as a one-element
+ list. Note that (unlike Unix pathnames), search list names are
+ case-insensitive.
+\end{defun}
+
+\begin{defun}{extensions:}{search-list-defined-p}{\var{name}}
+ \defunx[extensions:]{clear-search-list}{\var{name}}
+
+ \code{search-list-defined-p} returns \true{} if \var{name} is a
+ defined search list name, \false{} otherwise.
+ \code{clear-search-list} make the search list \var{name} undefined.
+\end{defun}
+
+\begin{defmac}{extensions:}{enumerate-search-list}{%
+ \args{(\var{var} \var{pathname} \mopt{result}) \mstar{form}}}
+
+ This macro provides an interface to search list resolution. The
+ body \var{forms} are executed with \var{var} bound to each
+ successive possible expansion for \var{name}. If \var{name} does
+ not contain a search-list, then the body is executed exactly once.
+ Everything is wrapped in a block named \nil, so \code{return} can be
+ used to terminate early. The \var{result} form (default \nil) is
+ evaluated to determine the result of the iteration.
+\end{defmac}
+
+\begin{comment}
+* Search List Example::
+\end{comment}
+
+%%\node Search List Example, , Search-List Operations, Pathnames
+\subsection{Search List Example}
+
+The search list \code{code:} can be defined as follows:
+\begin{example}
+(setf (ext:search-list "code:") '("/usr/lisp/code/"))
+\end{example}
+It is now possible to use \code{code:} as an abbreviation for the directory
+\file{/usr/lisp/code/} in all file operations. For example, you can now specify
+\code{code:eval.lisp} to refer to the file \file{/usr/lisp/code/eval.lisp}.
+
+To obtain the value of a search-list name, use the function search-list
+as follows:
+\begin{example}
+(ext:search-list \var{name})
+\end{example}
+Where \var{name} is the name of a search list as described above. For example,
+calling \code{ext:search-list} on \code{code:} as follows:
+\begin{example}
+(ext:search-list "code:")
+\end{example}
+returns the list \code{("/usr/lisp/code/")}.
+
+%%\node Filesystem Operations, Time Parsing and Formatting, Pathnames, Design Choices and Extensions
+\section{Filesystem Operations}
+
+\cmucl{} provides a number of extensions and optional features beyond those
+require by \clisp.
+
+\begin{comment}
+* Wildcard Matching::
+* File Name Completion::
+* Miscellaneous Filesystem Operations::
+\end{comment}
+
+%%\node Wildcard Matching, File Name Completion, Filesystem Operations, Filesystem Operations
+\subsection{Wildcard Matching}
+\label{wildcard-matching}
+
+Unix filesystem operations such as \code{open} will accept wildcard pathnames
+that match a single file (of course, \code{directory} allows any number of
+matches.) Filesystem operations treat \kwd{wild-inferiors} the same as\
+\kwd{wild}.
+
+\begin{defun}{}{directory}{\var{wildname} \keys{\kwd{all} \kwd{check-for-subdirs}}
+ \morekeys{\kwd{follow-links}}}
+
+ The keyword arguments to this \clisp{} function are a CMU extension.
+ The arguments (all default to \code{t}) have the following
+ functions:
+ \begin{Lentry}
+ \item[\kwd{all}] Include files beginning with dot such as
+ \file{.login}, similar to ``\code{ls -a}''.
+
+ \item[\kwd{check-for-subdirs}] Test whether files are directories,
+ similar to ``\code{ls -F}''.
+
+ \item[\kwd{follow-links}] Call \code{truename} on each file, which
+ expands out all symbolic links. Note that this option can easily
+ result in pathnames being returned which have a different
+ directory from the one in the \var{wildname} argument.
+ \end{Lentry}
+\end{defun}
+
+\begin{defun}{extensions:}{print-directory}{%
+ \args{\var{wildname}
+ \ampoptional{} \var{stream}
+ \keys{\kwd{all} \kwd{verbose}}
+ \morekeys{\kwd{return-list}}}}
+
+ Print a directory of \var{wildname} listing to \var{stream} (default
+ \code{*standard-output*}.) \kwd{all} and \kwd{verbose} both default
+ to \false{} and correspond to the ``\code{-a}'' and ``\code{-l}''
+ options of \file{ls}. Normally this function returns \false{}, but
+ if \kwd{return-list} is true, a list of the matched pathnames are
+ returned.
+\end{defun}
+
+%%\node File Name Completion, Miscellaneous Filesystem Operations, Wildcard Matching, Filesystem Operations
+\subsection{File Name Completion}
+
+\begin{defun}{extensions:}{complete-file}{%
+ \args{\var{pathname}
+ \keys{\kwd{defaults} \kwd{ignore-types}}}}
+
+ Attempt to complete a file name to the longest unambiguous prefix.
+ If supplied, directory from \kwd{defaults} is used as the ``working
+ directory'' when doing completion. \kwd{ignore-types} is a list of
+ strings of the pathname types (a.k.a. extensions) that should be
+ disregarded as possible matches (binary file names, etc.)
+\end{defun}
+
+\begin{defun}{extensions:}{ambiguous-files}{%
+ \args{\var{pathname}
+ \ampoptional{} \var{defaults}}}
+
+ Return a list of pathnames for all the possible completions of
+ \var{pathname} with respect to \var{defaults}.
+\end{defun}
+
+%%\node Miscellaneous Filesystem Operations, , File Name Completion, Filesystem Operations
+\subsection{Miscellaneous Filesystem Operations}
+
+\begin{defun}{extensions:}{default-directory}{}
+
+ Return the current working directory as a pathname. If set with
+ \code{setf}, set the working directory.
+\end{defun}
+
+\begin{defun}{extensions:}{file-writable}{\var{name}}
+
+ This function accepts a pathname and returns \true{} if the current
+ process can write it, and \false{} otherwise.
+\end{defun}
+
+\begin{defun}{extensions:}{unix-namestring}{%
+ \args{\var{pathname}
+ \ampoptional{} \var{for-input}}}
+
+ This function converts \var{pathname} into a string that can be used
+ with UNIX system calls. Search-lists and wildcards are expanded.
+ \var{for-input} controls the treatment of search-lists: when true
+ (the default) and the file exists anywhere on the search-list, then
+ that absolute pathname is returned; otherwise the first element of
+ the search-list is used as the directory.
+\end{defun}
+
+%%\node Time Parsing and Formatting, Lisp Library, Filesystem Operations, Design Choices and Extensions
+\section{Time Parsing and Formatting}
+
+\cindex{time parsing} \cindex{time formatting}
+Functions are provided to allow parsing strings containing time information
+and printing time in various formats are available.
+
+\begin{defun}{extensions:}{parse-time}{%
+ \args{\var{time-string}
+ \keys{\kwd{error-on-mismatch} \kwd{default-seconds}}
+ \morekeys{\kwd{default-minutes} \kwd{default-hours}}
+ \yetmorekeys{\kwd{default-day} \kwd{default-month}}
+ \yetmorekeys{\kwd{default-year} \kwd{default-zone}}
+ \yetmorekeys{\kwd{default-weekday}}}}
+
+ \code{parse-time} accepts a string containing a time (e.g.,
+ \w{"\code{Jan 12, 1952}"}) and returns the universal time if it is
+ successful. If it is unsuccessful and the keyword argument
+ \kwd{error-on-mismatch} is non-\FALSE, it signals an error.
+ Otherwise it returns \FALSE. The other keyword arguments have the
+ following meaning:
+ \begin{Lentry}
+
+ \item[\kwd{default-seconds}] specifies the default value for the
+ seconds value if one is not provided by \var{time-string}. The
+ default value is 0.
+
+ \item[\kwd{default-minutes}] specifies the default value for the
+ minutes value if one is not provided by \var{time-string}. The
+ default value is 0.
+
+ \item[\kwd{default-hours}] specifies the default value for the hours
+ value if one is not provided by \var{time-string}. The default
+ value is 0.
+
+ \item[\kwd{default-day}] specifies the default value for the day
+ value if one is not provided by \var{time-string}. The default
+ value is the current day.
+
+ \item[\kwd{default-month}] specifies the default value for the month
+ value if one is not provided by \var{time-string}. The default
+ value is the current month.
+
+ \item[\kwd{default-year}] specifies the default value for the year
+ value if one is not provided by \var{time-string}. The default
+ value is the current year.
+
+ \item[\kwd{default-zone}] specifies the default value for the time
+ zone value if one is not provided by \var{time-string}. The
+ default value is the current time zone.
+
+ \item[\kwd{default-weekday}] specifies the default value for the day
+ of the week if one is not provided by \var{time-string}. The
+ default value is the current day of the week.
+ \end{Lentry}
+ Any of the above keywords can be given the value \kwd{current} which
+ means to use the current value as determined by a call to the
+ operating system.
+\end{defun}
+
+\begin{defun}{extensions:}{format-universal-time}{
+ \args{\var{dest} \var{universal-time}
+ \\
+ \keys{\kwd{timezone}}
+ \morekeys{\kwd{style} \kwd{date-first}}
+ \yetmorekeys{\kwd{print-seconds} \kwd{print-meridian}}
+ \yetmorekeys{\kwd{print-timezone} \kwd{print-weekday}}}}
+ \defunx[extensions:]{format-decoded-time}{
+ \args{\var{dest} \var{seconds} \var{minutes} \var{hours} \var{day} \var{month} \var{year}
+ \\
+ \keys{\kwd{timezone}}
+ \morekeys{\kwd{style} \kwd{date-first}}
+ \yetmorekeys{\kwd{print-seconds} \kwd{print-meridian}}
+ \yetmorekeys{\kwd{print-timezone} \kwd{print-weekday}}}}
+
+ \code{format-universal-time} formats the time specified by
+ \var{universal-time}. \code{format-decoded-time} formats the time
+ specified by \var{seconds}, \var{minutes}, \var{hours}, \var{day},
+ \var{month}, and \var{year}. \var{Dest} is any destination
+ accepted by the \code{format} function. The keyword arguments have
+ the following meaning:
+ \begin{Lentry}
+
+ \item[\kwd{timezone}] is an integer specifying the hours west of
+ Greenwich. \kwd{timezone} defaults to the current time zone.
+
+ \item[\kwd{style}] specifies the style to use in formatting the
+ time. The legal values are:
+ \begin{Lentry}
+
+ \item[\kwd{short}] specifies to use a numeric date.
+
+ \item[\kwd{long}] specifies to format months and weekdays as
+ words instead of numbers.
+
+ \item[\kwd{abbreviated}] is similar to long except the words are
+ abbreviated.
+
+ \item[\kwd{government}] is similar to abbreviated, except the
+ date is of the form ``day month year'' instead of ``month day,
+ year''.
+ \end{Lentry}
+
+ \item[\kwd{date-first}] if non-\false{} (default) will place the
+ date first. Otherwise, the time is placed first.
+
+ \item[\kwd{print-seconds}] if non-\false{} (default) will format
+ the seconds as part of the time. Otherwise, the seconds will be
+ omitted.
+
+ \item[\kwd{print-meridian}] if non-\false{} (default) will format
+ ``AM'' or ``PM'' as part of the time. Otherwise, the ``AM'' or
+ ``PM'' will be omitted.
+
+ \item[\kwd{print-timezone}] if non-\false{} (default) will format
+ the time zone as part of the time. Otherwise, the time zone will
+ be omitted.
+
+ %%\item[\kwd{print-seconds}]
+ %%if non-\false{} (default) will format the seconds as part of
+ %%the time. Otherwise, the seconds will be omitted.
+
+ \item[\kwd{print-weekday}] if non-\false{} (default) will format
+ the weekday as part of date. Otherwise, the weekday will be
+ omitted.
+ \end{Lentry}
+\end{defun}
+
+%% New stuff
+\begin{changebar}
+\section{Random Number Generation}
+\cindex{random number generation}
+
+\clisp{} includes a random number generator as a standard part of the
+language; however, the implementation of the generator is not
+specified. Two random number generators are available in \cmucl{},
+depending on the version.
+
+\subsection{Original Generator}
+\cpsubindex{random number generation}{original generator}
+The default random number generator uses a lagged Fibonacci generator
+given by
+\begin{displaymath}
+ z[i] = z[i - 24] - z[i - 55] \bmod 536870908
+\end{displaymath}
+where $z[i]$ is the $i$'th random number. This generator produces
+small integer-valued numbers. For larger integer, the small random
+integers are concatenated to produce larger integers. For
+floating-point numbers, the bits from this generator are used as the
+bits of the floating-point significand.
+
+\subsection{New Generator}
+\cpsubindex{random number generation}{new generator}
+
+In some versions of \cmucl{}, the original generator above has been
+replaced with a subtract-with-borrow generator
+combined with a Weyl generator.\footnote{The generator described here
+ is available if the feature \kwd{new-random} is available.} The
+reason for the change was to use a documented generator which has
+passed tests for randomness.
+
+The subtract-with-borrow generator is described by the following
+equation
+\begin{displaymath}
+ z[i] = z[i + 20] - z[i + 5] - b
+\end{displaymath}
+where $z[i]$ is the $i$'th random number, which is a
+\code{double-float}. All of the indices in this equation are
+interpreted modulo 32. The quantity $b$ is carried over from the
+previous iteration and is either 0 or \code{double-float-epsilon}. If
+$z[i]$ is positive, $b$ is set to zero. Otherwise, $b$ is set to
+\code{double-float-epsilon}.
+
+To increase the randomness of this generator, this generator is
+combined with a Weyl generator defined by
+\begin{displaymath}
+ x[i] = x[i - 1] - y \bmod 1,
+\end{displaymath}
+where $y = 7097293079245107 \times 2^{-53}$. Thus, the resulting
+random number $r[i]$ is
+\begin{displaymath}
+ r[i] = (z[i] - x[i]) \bmod 1
+\end{displaymath}
+
+This generator has been tested by Peter VanEynde using Marsaglia's
+diehard test suite for random number generators; this generator
+passes the test suite.
+
+This generator is designed for generating floating-point random
+numbers. To obtain integers, the bits from the significand of the
+floating-point number are used as the bits of the integer. As many
+floating-point numbers as needed are generated to obtain the desired
+number of bits in the random integer.
+
+For floating-point numbers, this generator can by significantly faster
+than the original generator.
+\end{changebar}
+
+%%\node Lisp Library, , Time Parsing and Formatting, Design Choices and Extensions
+\section{Lisp Library}
+\label{lisp-lib}
+
+The CMU Common Lisp project maintains a collection of useful or interesting
+programs written by users of our system. The library is in
+\file{lib/contrib/}. Two files there that users should read are:
+\begin{Lentry}
+
+\item[CATALOG.TXT]
+This file contains a page for each entry in the library. It
+contains information such as the author, portability or dependency issues, how
+to load the entry, etc.
+
+\item[READ-ME.TXT]
+This file describes the library's organization and all the
+possible pieces of information an entry's catalog description could contain.
+\end{Lentry}
+
+Hemlock has a command \F{Library Entry} that displays a list of the current
+library entries in an editor buffer. There are mode specific commands that
+display catalog descriptions and load entries. This is a simple and convenient
+way to browse the library.
+
+
+\hide{File:/afs/cs.cmu.edu/project/clisp/hackers/ram/docs/cmu-user/debug.ms}
+
+
+
+%%\node The Debugger, The Compiler, Design Choices and Extensions, Top
+\chapter{The Debugger} \hide{-*- Dictionary: cmu-user -*-}
+\begin{center}
+\b{By Robert MacLachlan}
+\end{center}
+\cindex{debugger}
+\label{debugger}
+
+\begin{comment}
+* Debugger Introduction::
+* The Command Loop::
+* Stack Frames::
+* Variable Access::
+* Source Location Printing::
+* Compiler Policy Control::
+* Exiting Commands::
+* Information Commands::
+* Breakpoint Commands::
+* Function Tracing::
+* Specials::
+\end{comment}
+
+%%\node Debugger Introduction, The Command Loop, The Debugger, The Debugger
+\section{Debugger Introduction}
+
+The \cmucl{} debugger is unique in its level of support for source-level
+debugging of compiled code. Although some other debuggers allow access of
+variables by name, this seems to be the first \llisp{} debugger that:
+\begin{itemize}
+
+\item
+Tells you when a variable doesn't have a value because it hasn't been
+initialized yet or has already been deallocated, or
+
+\item
+Can display the precise source location corresponding to a code
+location in the debugged program.
+\end{itemize}
+These features allow the debugging of compiled code to be made almost
+indistinguishable from interpreted code debugging.
+
+The debugger is an interactive command loop that allows a user to examine
+the function call stack. The debugger is invoked when:
+\begin{itemize}
+
+\item
+A \tindexed{serious-condition} is signaled, and it is not handled, or
+
+\item
+\findexed{error} is called, and the condition it signals is not handled, or
+
+\item
+The debugger is explicitly invoked with the \clisp{} \findexed{break}
+or \findexed{debug} functions.
+\end{itemize}
+
+{\it Note: there are two debugger interfaces in CMU CL: the TTY debugger
+(described below) and the Motif debugger. Since the difference is only in the
+user interface, much of this chapter also applies to the Motif version.
+\xlref{motif-interface} for a very brief discussion of the graphical
+interface.}
+
+When you enter the TTY debugger, it looks something like this:
+\begin{example}
+Error in function CAR.
+Wrong type argument, 3, should have been of type LIST.
+
+Restarts:
+ 0: Return to Top-Level.
+
+Debug (type H for help)
+
+(CAR 3)
+0]
+\end{example}
+The first group of lines describe what the error was that put us in the
+debugger. In this case \code{car} was called on \code{3}. After \code{Restarts:}
+is a list of all the ways that we can restart execution after this error. In
+this case, the only option is to return to top-level. After printing its
+banner, the debugger prints the current frame and the debugger prompt.
+
+%%\f
+%%\node The Command Loop, Stack Frames, Debugger Introduction, The Debugger
+\section{The Command Loop}
+
+The debugger is an interactive read-eval-print loop much like the normal
+top-level, but some symbols are interpreted as debugger commands instead
+of being evaluated. A debugger command starts with the symbol name of
+the command, possibly followed by some arguments on the same line. Some
+commands prompt for additional input. Debugger commands can be
+abbreviated by any unambiguous prefix: \code{help} can be typed as
+\code{h}, \code{he}, etc. For convenience, some commands have
+ambiguous one-letter abbreviations: \code{f} for \code{frame}.
+
+The package is not significant in debugger commands; any symbol with the
+name of a debugger command will work. If you want to show the value of
+a variable that happens also to be the name of a debugger command, you
+can use the \code{list-locals} command or the \code{debug:var}
+function, or you can wrap the variable in a \code{progn} to hide it from
+the command loop.
+
+The debugger prompt is ``\var{frame}\code{]}'', where \var{frame} is the number
+of the current frame. Frames are numbered starting from zero at the top (most
+recent call), increasing down to the bottom. The current frame is the frame
+that commands refer to. The current frame also provides the lexical
+environment for evaluation of non-command forms.
+
+\cpsubindex{evaluation}{debugger} The debugger evaluates forms in the lexical
+environment of the functions being debugged. The debugger can only
+access variables. You can't \code{go} or \code{return-from} into a
+function, and you can't call local functions. Special variable
+references are evaluated with their current value (the innermost binding
+around the debugger invocation)\dash{}you don't get the value that the
+special had in the current frame. \xlref{debug-vars} for more
+information on debugger variable access.
+
+%%\f
+%%\node Stack Frames, Variable Access, The Command Loop, The Debugger
+\section{Stack Frames}
+\cindex{stack frames} \cpsubindex{frames}{stack}
+
+A stack frame is the run-time representation of a call to a function;
+the frame stores the state that a function needs to remember what it is
+doing. Frames have:
+\begin{itemize}
+
+\item
+Variables (\pxlref{debug-vars}), which are the values being operated
+on, and
+
+\item
+Arguments to the call (which are really just particularly interesting
+variables), and
+
+\item
+A current location (\pxlref{source-locations}), which is the place in
+the program where the function was running when it stopped to call another
+function, or because of an interrupt or error.
+\end{itemize}
+
+
+%%\f
+\begin{comment}
+* Stack Motion::
+* How Arguments are Printed::
+* Function Names::
+* Funny Frames::
+* Debug Tail Recursion::
+* Unknown Locations and Interrupts::
+\end{comment}
+
+%%\node Stack Motion, How Arguments are Printed, Stack Frames, Stack Frames
+\subsection{Stack Motion}
+
+These commands move to a new stack frame and print the name of the function
+and the values of its arguments in the style of a Lisp function call:
+\begin{Lentry}
+
+\item[\code{up}]
+Move up to the next higher frame. More recent function calls are considered
+to be higher on the stack.
+
+\item[\code{down}]
+Move down to the next lower frame.
+
+\item[\code{top}]
+Move to the highest frame.
+
+\item[\code{bottom}]
+Move to the lowest frame.
+
+\item[\code{frame} [\textit{n}]]
+Move to the frame with the specified number. Prompts for the number if not
+supplied.
+
+\begin{comment}
+\key{S} [\var{function-name} [\var{n}]]
+
+\item
+Search down the stack for function. Prompts for the function name if not
+supplied. Searches an optional number of times, but doesn't prompt for
+this number; enter it following the function.
+
+\item[\key{R} [\var{function-name} [\var{n}]]]
+Search up the stack for function. Prompts for the function name if not
+supplied. Searches an optional number of times, but doesn't prompt for
+this number; enter it following the function.
+\end{comment}
+\end{Lentry}
+%%\f
+%%\node How Arguments are Printed, Function Names, Stack Motion, Stack Frames
+\subsection{How Arguments are Printed}
+
+A frame is printed to look like a function call, but with the actual argument
+values in the argument positions. So the frame for this call in the source:
+\begin{lisp}
+(myfun (+ 3 4) 'a)
+\end{lisp}
+would look like this:
+\begin{example}
+(MYFUN 7 A)
+\end{example}
+All keyword and optional arguments are displayed with their actual
+values; if the corresponding argument was not supplied, the value will
+be the default. So this call:
+\begin{lisp}
+(subseq "foo" 1)
+\end{lisp}
+would look like this:
+\begin{example}
+(SUBSEQ "foo" 1 3)
+\end{example}
+And this call:
+\begin{lisp}
+(string-upcase "test case")
+\end{lisp}
+would look like this:
+\begin{example}
+(STRING-UPCASE "test case" :START 0 :END NIL)
+\end{example}
+
+The arguments to a function call are displayed by accessing the argument
+variables. Although those variables are initialized to the actual argument
+values, they can be set inside the function; in this case the new value will be
+displayed.
+
+\code{\amprest} arguments are handled somewhat differently. The value of
+the rest argument variable is displayed as the spread-out arguments to
+the call, so:
+\begin{lisp}
+(format t "~A is a ~A." "This" 'test)
+\end{lisp}
+would look like this:
+\begin{example}
+(FORMAT T "~A is a ~A." "This" 'TEST)
+\end{example}
+Rest arguments cause an exception to the normal display of keyword
+arguments in functions that have both \code{\amprest} and \code{\&key}
+arguments. In this case, the keyword argument variables are not
+displayed at all; the rest arg is displayed instead. So for these
+functions, only the keywords actually supplied will be shown, and the
+values displayed will be the argument values, not values of the
+(possibly modified) variables.
+
+If the variable for an argument is never referenced by the function, it will be
+deleted. The variable value is then unavailable, so the debugger prints
+\code{<unused-arg>} instead of the value. Similarly, if for any of a number of
+reasons (described in more detail in section \ref{debug-vars}) the value of the
+variable is unavailable or not known to be available, then
+\code{<unavailable-arg>} will be printed instead of the argument value.
+
+Printing of argument values is controlled by \code{*debug-print-level*} and
+\varref{debug-print-length}.
+
+%%\f
+%%\node Function Names, Funny Frames, How Arguments are Printed, Stack Frames
+\subsection{Function Names}
+\cpsubindex{function}{names}
+\cpsubindex{names}{function}
+
+If a function is defined by \code{defun}, \code{labels}, or \code{flet}, then the
+debugger will print the actual function name after the open parenthesis, like:
+\begin{example}
+(STRING-UPCASE "test case" :START 0 :END NIL)
+((SETF AREF) \#\back{a} "for" 1)
+\end{example}
+Otherwise, the function name is a string, and will be printed in quotes:
+\begin{example}
+("DEFUN MYFUN" BAR)
+("DEFMACRO DO" (DO ((I 0 (1+ I))) ((= I 13))) NIL)
+("SETQ *GC-NOTIFY-BEFORE*")
+\end{example}
+This string name is derived from the \w{\code{def}\var{mumble}} form that encloses
+or expanded into the lambda, or the outermost enclosing form if there is no
+\w{\code{def}\var{mumble}}.
+
+%%\f
+%%\node Funny Frames, Debug Tail Recursion, Function Names, Stack Frames
+\subsection{Funny Frames}
+\cindex{external entry points}
+\cpsubindex{entry points}{external}
+\cpsubindex{block compilation}{debugger implications}
+\cpsubindex{external}{stack frame kind}
+\cpsubindex{optional}{stack frame kind}
+\cpsubindex{cleanup}{stack frame kind}
+
+Sometimes the evaluator introduces new functions that are used to implement a
+user function, but are not directly specified in the source. The main place
+this is done is for checking argument type and syntax. Usually these functions
+do their thing and then go away, and thus are not seen on the stack in the
+debugger. But when you get some sort of error during lambda-list processing,
+you end up in the debugger on one of these funny frames.
+
+These funny frames are flagged by printing ``\code{[}\var{keyword}\code{]}'' after the
+parentheses. For example, this call:
+\begin{lisp}
+(car 'a 'b)
+\end{lisp}
+will look like this:
+\begin{example}
+(CAR 2 A) [:EXTERNAL]
+\end{example}
+And this call:
+\begin{lisp}
+(string-upcase "test case" :end)
+\end{lisp}
+would look like this:
+\begin{example}
+("DEFUN STRING-UPCASE" "test case" 335544424 1) [:OPTIONAL]
+\end{example}
+
+As you can see, these frames have only a vague resemblance to the original
+call. Fortunately, the error message displayed when you enter the debugger
+will usually tell you what problem is (in these cases, too many arguments
+and odd keyword arguments.) Also, if you go down the stack to the frame for
+the calling function, you can display the original source (\pxlref{source-locations}.)
+
+With recursive or block compiled functions (\pxlref{block-compilation}), an \kwd{EXTERNAL} frame may appear before the frame
+representing the first call to the recursive function or entry to the compiled
+block. This is a consequence of the way the compiler does block compilation:
+there is nothing odd with your program. You will also see \kwd{CLEANUP} frames
+during the execution of \code{unwind-protect} cleanup code. Note that inline
+expansion and open-coding affect what frames are present in the debugger, see
+sections \ref{debugger-policy} and \ref{open-coding}.
+
+%%\f
+%%\node Debug Tail Recursion, Unknown Locations and Interrupts, Funny Frames, Stack Frames
+\subsection{Debug Tail Recursion}
+\label{debug-tail-recursion}
+\cindex{tail recursion}
+\cpsubindex{recursion}{tail}
+
+Both the compiler and the interpreter are ``properly tail recursive.'' If a
+function call is in a tail-recursive position, the stack frame will be
+deallocated \i{at the time of the call}, rather than after the call returns.
+Consider this backtrace:
+\begin{example}
+(BAR ...)
+(FOO ...)
+\end{example}
+Because of tail recursion, it is not necessarily the case that
+\code{FOO} directly called \code{BAR}. It may be that \code{FOO} called
+some other function \code{FOO2} which then called \code{BAR}
+tail-recursively, as in this example:
+\begin{example}
+(defun foo ()
+ ...
+ (foo2 ...)
+ ...)
+
+(defun foo2 (...)
+ ...
+ (bar ...))
+
+(defun bar (...)
+ ...)
+\end{example}
+
+Usually the elimination of tail-recursive frames makes debugging more
+pleasant, since these frames are mostly uninformative. If there is any
+doubt about how one function called another, it can usually be
+eliminated by finding the source location in the calling frame (section
+\ref{source-locations}.)
+
+For a more thorough discussion of tail recursion, \pxlref{tail-recursion}.
+
+%%\f
+%%\node Unknown Locations and Interrupts, , Debug Tail Recursion, Stack Frames
+\subsection{Unknown Locations and Interrupts}
+\label{unknown-locations}
+\cindex{unknown code locations}
+\cpsubindex{locations}{unknown}
+\cindex{interrupts}
+\cpsubindex{errors}{run-time}
+
+The debugger operates using special debugging information attached to
+the compiled code. This debug information tells the debugger what it
+needs to know about the locations in the code where the debugger can be
+invoked. If the debugger somehow encounters a location not described in
+the debug information, then it is said to be \var{unknown}. If the code
+location for a frame is unknown, then some variables may be
+inaccessible, and the source location cannot be precisely displayed.
+
+There are three reasons why a code location could be unknown:
+\begin{itemize}
+
+\item
+There is inadequate debug information due to the value of the \code{debug}
+optimization quality. \xlref{debugger-policy}.
+
+\item
+The debugger was entered because of an interrupt such as \code{$\hat{ }C$}.
+
+\item
+A hardware error such as ``\code{bus error}'' occurred in code that was
+compiled unsafely due to the value of the \code{safety} optimization
+quality. \xlref{optimize-declaration}.
+\end{itemize}
+
+In the last two cases, the values of argument variables are accessible,
+but may be incorrect. \xlref{debug-var-validity} for more details on
+when variable values are accessible.
+
+It is possible for an interrupt to happen when a function call or return is in
+progress. The debugger may then flame out with some obscure error or insist
+that the bottom of the stack has been reached, when the real problem is that
+the current stack frame can't be located. If this happens, return from the
+interrupt and try again.
+
+When running interpreted code, all locations should be known. However,
+an interrupt might catch some subfunction of the interpreter at an
+unknown location. In this case, you should be able to go up the stack a
+frame or two and reach an interpreted frame which can be debugged.
+
+%%\f
+%%\node Variable Access, Source Location Printing, Stack Frames, The Debugger
+\section{Variable Access}
+\label{debug-vars}
+\cpsubindex{variables}{debugger access}
+\cindex{debug variables}
+
+There are three ways to access the current frame's local variables in the
+debugger. The simplest is to type the variable's name into the debugger's
+read-eval-print loop. The debugger will evaluate the variable reference as
+though it had appeared inside that frame.
+
+The debugger doesn't really understand lexical scoping; it has just one
+namespace for all the variables in a function. If a symbol is the name of
+multiple variables in the same function, then the reference appears ambiguous,
+even though lexical scoping specifies which value is visible at any given
+source location. If the scopes of the two variables are not nested, then the
+debugger can resolve the ambiguity by observing that only one variable is
+accessible.
+
+When there are ambiguous variables, the evaluator assigns each one a
+small integer identifier. The \code{debug:var} function and the
+\code{list-locals} command use this identifier to distinguish between
+ambiguous variables:
+\begin{Lentry}
+
+\item[\code{list-locals} \mopt{\var{prefix}}]%%\hfill\\
+This command prints the name and value of all variables in the current
+frame whose name has the specified \var{prefix}. \var{prefix} may be a
+string or a symbol. If no \var{prefix} is given, then all available
+variables are printed. If a variable has a potentially ambiguous name,
+then the name is printed with a ``\code{\#}\var{identifier}'' suffix, where
+\var{identifier} is the small integer used to make the name unique.
+\end{Lentry}
+
+\begin{defun}{debug:}{var}{\args{\var{name} \ampoptional{} \var{identifier}}}
+
+ This function returns the value of the variable in the current frame
+ with the specified \var{name}. If supplied, \var{identifier}
+ determines which value to return when there are ambiguous variables.
+
+ When \var{name} is a symbol, it is interpreted as the symbol name of
+ the variable, i.e. the package is significant. If \var{name} is an
+ uninterned symbol (gensym), then return the value of the uninterned
+ variable with the same name. If \var{name} is a string,
+ \code{debug:var} interprets it as the prefix of a variable name, and
+ must unambiguously complete to the name of a valid variable.
+
+ This function is useful mainly for accessing the value of uninterned
+ or ambiguous variables, since most variables can be evaluated
+ directly.
+\end{defun}
+
+%%\f
+\begin{comment}
+* Variable Value Availability::
+* Note On Lexical Variable Access::
+\end{comment}
+
+%%\node Variable Value Availability, Note On Lexical Variable Access, Variable Access, Variable Access
+\subsection{Variable Value Availability}
+\label{debug-var-validity}
+\cindex{availability of debug variables}
+\cindex{validity of debug variables}
+\cindex{debug optimization quality}
+
+The value of a variable may be unavailable to the debugger in portions of the
+program where \clisp{} says that the variable is defined. If a variable value is
+not available, the debugger will not let you read or write that variable. With
+one exception, the debugger will never display an incorrect value for a
+variable. Rather than displaying incorrect values, the debugger tells you the
+value is unavailable.
+
+The one exception is this: if you interrupt (e.g., with \code{$\hat{ }C$}) or if there is
+an unexpected hardware error such as ``\code{bus error}'' (which should only happen
+in unsafe code), then the values displayed for arguments to the interrupted
+frame might be incorrect.\footnote{Since the location of an interrupt or hardware
+error will always be an unknown location (\pxlref{unknown-locations}),
+non-argument variable values will never be available in the interrupted frame.}
+This exception applies only to the interrupted frame: any frame farther down
+the stack will be fine.
+
+The value of a variable may be unavailable for these reasons:
+\begin{itemize}
+
+\item
+The value of the \code{debug} optimization quality may have omitted debug
+information needed to determine whether the variable is available.
+Unless a variable is an argument, its value will only be available when
+\code{debug} is at least \code{2}.
+
+\item
+The compiler did lifetime analysis and determined that the value was no longer
+needed, even though its scope had not been exited. Lifetime analysis is
+inhibited when the \code{debug} optimization quality is \code{3}.
+
+\item
+The variable's name is an uninterned symbol (gensym). To save space, the
+compiler only dumps debug information about uninterned variables when the
+\code{debug} optimization quality is \code{3}.
+
+\item
+The frame's location is unknown (\pxlref{unknown-locations}) because
+the debugger was entered due to an interrupt or unexpected hardware error.
+Under these conditions the values of arguments will be available, but might be
+incorrect. This is the exception above.
+
+\item
+The variable was optimized out of existence. Variables with no reads are
+always optimized away, even in the interpreter. The degree to which the
+compiler deletes variables will depend on the value of the \code{compile-speed}
+optimization quality, but most source-level optimizations are done under all
+compilation policies.
+\end{itemize}
+
+
+Since it is especially useful to be able to get the arguments to a function,
+argument variables are treated specially when the \code{speed} optimization
+quality is less than \code{3} and the \code{debug} quality is at least \code{1}.
+With this compilation policy, the values of argument variables are almost
+always available everywhere in the function, even at unknown locations. For
+non-argument variables, \code{debug} must be at least \code{2} for values to be
+available, and even then, values are only available at known locations.
+
+%%\f
+%%\node Note On Lexical Variable Access, , Variable Value Availability, Variable Access
+\subsection{Note On Lexical Variable Access}
+\cpsubindex{evaluation}{debugger}
+
+When the debugger command loop establishes variable bindings for available
+variables, these variable bindings have lexical scope and dynamic
+extent.\footnote{The variable bindings are actually created using the \clisp{}
+\code{symbol-macro-let} special form.} You can close over them, but such closures
+can't be used as upward funargs.
+
+You can also set local variables using \code{setq}, but if the variable was closed
+over in the original source and never set, then setting the variable in the
+debugger may not change the value in all the functions the variable is defined
+in. Another risk of setting variables is that you may assign a value of a type
+that the compiler proved the variable could never take on. This may result in
+bad things happening.
+
+%%\f
+%%\node Source Location Printing, Compiler Policy Control, Variable Access, The Debugger
+\section{Source Location Printing}
+\label{source-locations}
+\cpsubindex{source location printing}{debugger}
+
+One of CMU \clisp{}'s unique capabilities is source level debugging of compiled
+code. These commands display the source location for the current frame:
+\begin{Lentry}
+
+\item[\code{source} \mopt{\var{context}}]%%\hfill\\
+This command displays the file that the current frame's function was defined
+from (if it was defined from a file), and then the source form responsible for
+generating the code that the current frame was executing. If \var{context} is
+specified, then it is an integer specifying the number of enclosing levels of
+list structure to print.
+
+\item[\code{vsource} \mopt{\var{context}}]%%\hfill\\
+This command is identical to \code{source}, except that it uses the
+global values of \code{*print-level*} and \code{*print-length*} instead
+of the debugger printing control variables \code{*debug-print-level*}
+and \code{*debug-print-length*}.
+\end{Lentry}
+
+The source form for a location in the code is the innermost list present
+in the original source that encloses the form responsible for generating
+that code. If the actual source form is not a list, then some enclosing
+list will be printed. For example, if the source form was a reference
+to the variable \code{*some-random-special*}, then the innermost
+enclosing evaluated form will be printed. Here are some possible
+enclosing forms:
+\begin{example}
+(let ((a *some-random-special*))
+ ...)
+
+(+ *some-random-special* ...)
+\end{example}
+
+If the code at a location was generated from the expansion of a macro or a
+source-level compiler optimization, then the form in the original source that
+expanded into that code will be printed. Suppose the file
+\file{/usr/me/mystuff.lisp} looked like this:
+\begin{example}
+(defmacro mymac ()
+ '(myfun))
+
+(defun foo ()
+ (mymac)
+ ...)
+\end{example}
+If \code{foo} has called \code{myfun}, and is waiting for it to return, then the
+\code{source} command would print:
+\begin{example}
+; File: /usr/me/mystuff.lisp
+
+(MYMAC)
+\end{example}
+Note that the macro use was printed, not the actual function call form,
+\code{(myfun)}.
+
+If enclosing source is printed by giving an argument to \code{source} or
+\code{vsource}, then the actual source form is marked by wrapping it in a list
+whose first element is \code{\#:***HERE***}. In the previous example,
+\w{\code{source 1}} would print:
+\begin{example}
+; File: /usr/me/mystuff.lisp
+
+(DEFUN FOO ()
+ (#:***HERE***
+ (MYMAC))
+ ...)
+\end{example}
+
+%%\f
+\begin{comment}
+* How the Source is Found::
+* Source Location Availability::
+\end{comment}
+
+%%\node How the Source is Found, Source Location Availability, Source Location Printing, Source Location Printing
+\subsection{How the Source is Found}
+
+If the code was defined from \llisp{} by \code{compile} or
+\code{eval}, then the source can always be reliably located. If the
+code was defined from a \code{fasl} file created by
+\findexed{compile-file}, then the debugger gets the source forms it
+prints by reading them from the original source file. This is a
+potential problem, since the source file might have moved or changed
+since the time it was compiled.
+
+The source file is opened using the \code{truename} of the source file
+pathname originally given to the compiler. This is an absolute pathname
+with all logical names and symbolic links expanded. If the file can't
+be located using this name, then the debugger gives up and signals an
+error.
+
+If the source file can be found, but has been modified since the time it was
+compiled, the debugger prints this warning:
+\begin{example}
+; File has been modified since compilation:
+; \var{filename}
+; Using form offset instead of character position.
+\end{example}
+where \var{filename} is the name of the source file. It then proceeds using a
+robust but not foolproof heuristic for locating the source. This heuristic
+works if:
+\begin{itemize}
+
+\item
+No top-level forms before the top-level form containing the source have been
+added or deleted, and
+
+\item
+The top-level form containing the source has not been modified much. (More
+precisely, none of the list forms beginning before the source form have been
+added or deleted.)
+\end{itemize}
+
+If the heuristic doesn't work, the displayed source will be wrong, but will
+probably be near the actual source. If the ``shape'' of the top-level form in
+the source file is too different from the original form, then an error will be
+signaled. When the heuristic is used, the the source location commands are
+noticeably slowed.
+
+Source location printing can also be confused if (after the source was
+compiled) a read-macro you used in the code was redefined to expand into
+something different, or if a read-macro ever returns the same \code{eq}
+list twice. If you don't define read macros and don't use \code{\#\#} in
+perverted ways, you don't need to worry about this.
+
+%%\f
+%%\node Source Location Availability, , How the Source is Found, Source Location Printing
+\subsection{Source Location Availability}
+
+\cindex{debug optimization quality}
+Source location information is only available when the \code{debug}
+optimization quality is at least \code{2}. If source location information is
+unavailable, the source commands will give an error message.
+
+If source location information is available, but the source location is
+unknown because of an interrupt or unexpected hardware error
+(\pxlref{unknown-locations}), then the command will print:
+\begin{example}
+Unknown location: using block start.
+\end{example}
+and then proceed to print the source location for the start of the \i{basic
+block} enclosing the code location. \cpsubindex{block}{basic}
+\cpsubindex{block}{start location}
+It's a bit complicated to explain exactly what a basic block is, but
+here are some properties of the block start location:
+\begin{itemize}
+
+\item The block start location may be the same as the true location.
+
+\item The block start location will never be later in the the
+ program's flow of control than the true location.
+
+\item No conditional control structures (such as \code{if},
+ \code{cond}, \code{or}) will intervene between the block start and
+ the true location (but note that some conditionals present in the
+ original source could be optimized away.) Function calls \i{do not}
+ end basic blocks.
+
+\item The head of a loop will be the start of a block.
+
+\item The programming language concept of ``block structure'' and the
+ \clisp{} \code{block} special form are totally unrelated to the
+ compiler's basic block.
+\end{itemize}
+
+In other words, the true location lies between the printed location and the
+next conditional (but watch out because the compiler may have changed the
+program on you.)
+
+%%\f
+%%\node Compiler Policy Control, Exiting Commands, Source Location Printing, The Debugger
+\section{Compiler Policy Control}
+\label{debugger-policy}
+\cpsubindex{policy}{debugger}
+\cindex{debug optimization quality}
+\cindex{optimize declaration}
+
+The compilation policy specified by \code{optimize} declarations affects the
+behavior seen in the debugger. The \code{debug} quality directly affects the
+debugger by controlling the amount of debugger information dumped. Other
+optimization qualities have indirect but observable effects due to changes in
+the way compilation is done.
+
+Unlike the other optimization qualities (which are compared in relative value
+to evaluate tradeoffs), the \code{debug} optimization quality is directly
+translated to a level of debug information. This absolute interpretation
+allows the user to count on a particular amount of debug information being
+available even when the values of the other qualities are changed during
+compilation. These are the levels of debug information that correspond to the
+values of the \code{debug} quality:
+\begin{Lentry}
+
+\item[\code{0}]
+Only the function name and enough information to allow the stack to
+be parsed.
+
+\item[\code{\w{$>$ 0}}]
+Any level greater than \code{0} gives level \code{0} plus all
+argument variables. Values will only be accessible if the argument
+variable is never set and
+\code{speed} is not \code{3}. \cmucl{} allows any real value for optimization
+qualities. It may be useful to specify \code{0.5} to get backtrace argument
+display without argument documentation.
+
+\item[\code{1}] Level \code{1} provides argument documentation
+(printed arglists) and derived argument/result type information.
+This makes \findexed{describe} more informative, and allows the
+compiler to do compile-time argument count and type checking for any
+calls compiled at run-time.
+
+\item[\code{2}]
+Level \code{1} plus all interned local variables, source location
+information, and lifetime information that tells the debugger when arguments
+are available (even when \code{speed} is \code{3} or the argument is set.) This is
+the default.
+
+\item[\code{3}]
+Level \code{2} plus all uninterned variables. In addition, lifetime
+analysis is disabled (even when \code{speed} is \code{3}), ensuring that all variable
+values are available at any known location within the scope of the binding.
+This has a speed penalty in addition to the obvious space penalty.
+\end{Lentry}
+
+As you can see, if the \code{speed} quality is \code{3}, debugger performance is
+degraded. This effect comes from the elimination of argument variable
+special-casing (\pxlref{debug-var-validity}.) Some degree of
+speed/debuggability tradeoff is unavoidable, but the effect is not too drastic
+when \code{debug} is at least \code{2}.
+
+\cindex{inline expansion}
+\cindex{semi-inline expansion}
+In addition to \code{inline} and \code{notinline} declarations, the relative values
+of the \code{speed} and \code{space} qualities also change whether functions are
+inline expanded (\pxlref{inline-expansion}.) If a function is inline
+expanded, then there will be no frame to represent the call, and the arguments
+will be treated like any other local variable. Functions may also be
+``semi-inline'', in which case there is a frame to represent the call, but the
+call is to an optimized local version of the function, not to the original
+function.
+
+%%\f
+%%\node Exiting Commands, Information Commands, Compiler Policy Control, The Debugger
+\section{Exiting Commands}
+
+These commands get you out of the debugger.
+
+\begin{Lentry}
+
+\item[\code{quit}]
+Throw to top level.
+
+\item[\code{restart} \mopt{\var{n}}]%%\hfill\\
+Invokes the \var{n}th restart case as displayed by the \code{error}
+command. If \var{n} is not specified, the available restart cases are
+reported.
+
+\item[\code{go}]
+Calls \code{continue} on the condition given to \code{debug}. If there is no
+restart case named \var{continue}, then an error is signaled.
+
+\item[\code{abort}]
+Calls \code{abort} on the condition given to \code{debug}. This is
+useful for popping debug command loop levels or aborting to top level,
+as the case may be.
+
+\begin{comment}
+(\code{debug:debug-return} \var{expression} \mopt{\var{frame}})
+
+\item
+From the current or specified frame, return the result of evaluating
+expression. If multiple values are expected, then this function should be
+called for multiple values.
+\end{comment}
+\end{Lentry}
+
+%%\f
+%%\node Information Commands, Breakpoint Commands, Exiting Commands, The Debugger
+\section{Information Commands}
+
+Most of these commands print information about the current frame or
+function, but a few show general information.
+
+\begin{Lentry}
+
+\item[\code{help}, \code{?}]
+Displays a synopsis of debugger commands.
+
+\item[\code{describe}]
+Calls \code{describe} on the current function, displays number of local
+variables, and indicates whether the function is compiled or interpreted.
+
+\item[\code{print}]
+Displays the current function call as it would be displayed by moving to
+this frame.
+
+\item[\code{vprint} (or \code{pp}) \mopt{\var{verbosity}}]%%\hfill\\
+Displays the current function call using \code{*print-level*} and
+\code{*print-length*} instead of \code{*debug-print-level*} and
+\code{*debug-print-length*}. \var{verbosity} is a small integer
+(default 2) that controls other dimensions of verbosity.
+
+\item[\code{error}]
+Prints the condition given to \code{invoke-debugger} and the active
+proceed cases.
+
+\item[\code{backtrace} \mopt{\var{n}}]\hfill\\
+Displays all the frames from the current to the bottom. Only shows
+\var{n} frames if specified. The printing is controlled by
+\code{*debug-print-level*} and \code{*debug-print-length*}.
+
+\begin{comment}
+(\code{debug:debug-function} \mopt{\var{n}})
+
+\item
+Returns the function from the current or specified frame.
+
+\item[(\code{debug:function-name} \mopt{\var{n}])]
+Returns the function name from the current or specified frame.
+
+\item[(\code{debug:pc} \mopt{\var{frame}})]
+Returns the index of the instruction for the function in the current or
+specified frame. This is useful in conjunction with \code{disassemble}.
+The pc returned points to the instruction after the one that was fatal.
+\end{comment}
+\end{Lentry}
+
+%%\f
+%%\node Breakpoint Commands, Function Tracing, Information Commands, The Debugger
+\section{Breakpoint Commands}
+
+\cmucl{} supports setting of breakpoints inside compiled functions and
+stepping of compiled code. Breakpoints can only be set at at known
+locations (\pxlref{unknown-locations}), so these commands are largely
+useless unless the \code{debug} optimize quality is at least \code{2}
+(\pxlref{debugger-policy}). These commands manipulate breakpoints:
+\begin{Lentry}
+\item[\code{breakpoint} \var{location} \mstar{\var{option} \var{value}}]
+%%\hfill\\
+Set a breakpoint in some function. \var{location} may be an integer
+code location number (as displayed by \code{list-locations}) or a
+keyword. The keyword can be used to indicate setting a breakpoint at
+the function start (\kwd{start}, \kwd{s}) or function end
+(\kwd{end}, \kwd{e}). The \code{breakpoint} command has
+\kwd{condition}, \kwd{break}, \kwd{print} and \kwd{function}
+options which work similarly to the \code{trace} options.
+
+\item[\code{list-locations} (or \code{ll}) \mopt{\var{function}}]%%\hfill\\
+List all the code locations in the current frame's function, or in
+\var{function} if it is supplied. The display format is the code
+location number, a colon and then the source form for that location:
+\begin{example}
+3: (1- N)
+\end{example}
+If consecutive locations have the same source, then a numeric range like
+\code{3-5:} will be printed. For example, a default function call has a
+known location both immediately before and after the call, which would
+result in two code locations with the same source. The listed function
+becomes the new default function for breakpoint setting (via the
+\code{breakpoint}) command.
+
+\item[\code{list-breakpoints} (or \code{lb})]%%\hfill\\
+List all currently active breakpoints with their breakpoint number.
+
+\item[\code{delete-breakpoint} (or \code{db}) \mopt{\var{number}}]%%\hfill\\
+Delete a breakpoint specified by its breakpoint number. If no number is
+specified, delete all breakpoints.
+
+\item[\code{step}]%%\hfill\\
+Step to the next possible breakpoint location in the current function.
+This always steps over function calls, instead of stepping into them
+\end{Lentry}
+
+\begin{comment}
+* Breakpoint Example::
+\end{comment}
+
+%%\node Breakpoint Example, , Breakpoint Commands, Breakpoint Commands
+\subsection{Breakpoint Example}
+
+Consider this definition of the factorial function:
+\begin{lisp}
+(defun ! (n)
+ (if (zerop n)
+ 1
+ (* n (! (1- n)))))
+\end{lisp}
+This debugger session demonstrates the use of breakpoints:
+\begin{example}
+common-lisp-user> (break) ; Invoke debugger
+
+Break
+
+Restarts:
+ 0: [CONTINUE] Return from BREAK.
+ 1: [ABORT ] Return to Top-Level.
+
+Debug (type H for help)
+
+(INTERACTIVE-EVAL (BREAK))
+0] ll #'!
+0: #'(LAMBDA (N) (BLOCK ! (IF # 1 #)))
+1: (ZEROP N)
+2: (* N (! (1- N)))
+3: (1- N)
+4: (! (1- N))
+5: (* N (! (1- N)))
+6: #'(LAMBDA (N) (BLOCK ! (IF # 1 #)))
+0] br 2
+(* N (! (1- N)))
+1: 2 in !
+Added.
+0] q
+
+common-lisp-user> (! 10) ; Call the function
+
+*Breakpoint hit*
+
+Restarts:
+ 0: [CONTINUE] Return from BREAK.
+ 1: [ABORT ] Return to Top-Level.
+
+Debug (type H for help)
+
+(! 10) ; We are now in first call (arg 10) before the multiply
+Source: (* N (! (1- N)))
+3] st
+
+*Step*
+
+(! 10) ; We have finished evaluation of (1- n)
+Source: (1- N)
+3] st
+
+*Breakpoint hit*
+
+Restarts:
+ 0: [CONTINUE] Return from BREAK.
+ 1: [ABORT ] Return to Top-Level.
+
+Debug (type H for help)
+
+(! 9) ; We hit the breakpoint in the recursive call
+Source: (* N (! (1- N)))
+3]
+\end{example}
+
+
+
+%%\f
+%%\node Function Tracing, Specials, Breakpoint Commands, The Debugger
+\section{Function Tracing}
+\cindex{tracing}
+\cpsubindex{function}{tracing}
+
+The tracer causes selected functions to print their arguments and
+their results whenever they are called. Options allow conditional
+printing of the trace information and conditional breakpoints on
+function entry or exit.
+
+\begin{defmac}{}{trace}{%
+ \args{\mstar{option global-value} \mstar{name \mstar{option
+ value}}}}
+
+ \code{trace} is a debugging tool that prints information when
+ specified functions are called. In its simplest form:
+ \begin{example}
+ (trace \var{name-1} \var{name-2} ...)
+ \end{example}
+ \code{trace} causes a printout on \vindexed{trace-output} each time
+ that one of the named functions is entered or returns (the
+ \var{names} are not evaluated.) Trace output is indented according
+ to the number of pending traced calls, and this trace depth is
+ printed at the beginning of each line of output. Printing verbosity
+ of arguments and return values is controlled by
+ \vindexed{debug-print-level} and \vindexed{debug-print-length}.
+
+ If no \var{names} or \var{options} are are given, \code{trace}
+ returns the list of all currently traced functions,
+ \code{*traced-function-list*}.
+
+ Trace options can cause the normal printout to be suppressed, or
+ cause extra information to be printed. Each option is a pair of an
+ option keyword and a value form. Options may be interspersed with
+ function names. Options only affect tracing of the function whose
+ name they appear immediately after. Global options are specified
+ before the first name, and affect all functions traced by a given
+ use of \code{trace}. If an already traced function is traced again,
+ any new options replace the old options. The following options are
+ defined:
+ \begin{Lentry}
+ \item[\kwd{condition} \var{form}, \kwd{condition-after} \var{form},
+ \kwd{condition-all} \var{form}] If \kwd{condition} is specified,
+ then \code{trace} does nothing unless \var{form} evaluates to true
+ at the time of the call. \kwd{condition-after} is similar, but
+ suppresses the initial printout, and is tested when the function
+ returns. \kwd{condition-all} tries both before and after.
+
+ \item[\kwd{wherein} \var{names}] If specified, \var{names} is a
+ function name or list of names. \code{trace} does nothing unless
+ a call to one of those functions encloses the call to this
+ function (i.e. it would appear in a backtrace.) Anonymous
+ functions have string names like \code{"DEFUN FOO"}.
+
+ \item[\kwd{break} \var{form}, \kwd{break-after} \var{form},
+ \kwd{break-all} \var{form}] If specified, and \var{form} evaluates
+ to true, then the debugger is invoked at the start of the
+ function, at the end of the function, or both, according to the
+ respective option.
+
+ \item[\kwd{print} \var{form}, \kwd{print-after} \var{form},
+ \kwd{print-all} \var{form}] In addition to the usual printout, the
+ result of evaluating \var{form} is printed at the start of the
+ function, at the end of the function, or both, according to the
+ respective option. Multiple print options cause multiple values
+ to be printed.
+
+ \item[\kwd{function} \var{function-form}] This is a not really an
+ option, but rather another way of specifying what function to
+ trace. The \var{function-form} is evaluated immediately, and the
+ resulting function is traced.
+
+ \item[\kwd{encapsulate \mgroup{:default | t | nil}}] In \cmucl,
+ tracing can be done either by temporarily redefining the function
+ name (encapsulation), or using breakpoints. When breakpoints are
+ used, the function object itself is destructively modified to
+ cause the tracing action. The advantage of using breakpoints is
+ that tracing works even when the function is anonymously called
+ via \code{funcall}.
+
+ When \kwd{encapsulate} is true, tracing is done via encapsulation.
+ \kwd{default} is the default, and means to use encapsulation for
+ interpreted functions and funcallable instances, breakpoints
+ otherwise. When encapsulation is used, forms are {\it not}
+ evaluated in the function's lexical environment, but
+ \code{debug:arg} can still be used.
+ \end{Lentry}
+
+ \kwd{condition}, \kwd{break} and \kwd{print} forms are evaluated in
+ the lexical environment of the called function; \code{debug:var} and
+ \code{debug:arg} can be used. The \code{-after} and \code{-all}
+ forms are evaluated in the null environment.
+\end{defmac}
+
+\begin{defmac}{}{untrace}{ \args{\amprest{} \var{function-names}}}
+
+ This macro turns off tracing for the specified functions, and
+ removes their names from \code{*traced-function-list*}. If no
+ \var{function-names} are given, then all currently traced functions
+ are untraced.
+\end{defmac}
+
+\begin{defvar}{extensions:}{traced-function-list}
+
+ A list of function names maintained and used by \code{trace},
+ \code{untrace}, and \code{untrace-all}. This list should contain
+ the names of all functions currently being traced.
+\end{defvar}
+
+\begin{defvar}{extensions:}{max-trace-indentation}
+
+ The maximum number of spaces which should be used to indent trace
+ printout. This variable is initially set to 40.
+\end{defvar}
+
+\begin{comment}
+* Encapsulation Functions::
+\end{comment}
+
+%%\node Encapsulation Functions, , Function Tracing, Function Tracing
+\subsection{Encapsulation Functions}
+\cindex{encapsulation}
+\cindex{advising}
+
+The encapsulation functions provide a mechanism for intercepting the
+arguments and results of a function. \code{encapsulate} changes the
+function definition of a symbol, and saves it so that it can be
+restored later. The new definition normally calls the original
+definition. The \clisp{} \findexed{fdefinition} function always returns
+the original definition, stripping off any encapsulation.
+
+The original definition of the symbol can be restored at any time by
+the \code{unencapsulate} function. \code{encapsulate} and \code{unencapsulate}
+allow a symbol to be multiply encapsulated in such a way that different
+encapsulations can be completely transparent to each other.
+
+Each encapsulation has a type which may be an arbitrary lisp object.
+If a symbol has several encapsulations of different types, then any
+one of them can be removed without affecting more recent ones.
+A symbol may have more than one encapsulation of the same type, but
+only the most recent one can be undone.
+
+\begin{defun}{extensions:}{encapsulate}{%
+ \args{\var{symbol} \var{type} \var{body}}}
+
+ Saves the current definition of \var{symbol}, and replaces it with a
+ function which returns the result of evaluating the form,
+ \var{body}. \var{Type} is an arbitrary lisp object which is the
+ type of encapsulation.
+
+ When the new function is called, the following variables are bound
+ for the evaluation of \var{body}:
+ \begin{Lentry}
+
+ \item[\code{extensions:argument-list}] A list of the arguments to
+ the function.
+
+ \item[\code{extensions:basic-definition}] The unencapsulated
+ definition of the function.
+ \end{Lentry}
+ The unencapsulated definition may be called with the original
+ arguments by including the form
+ \begin{lisp}
+ (apply extensions:basic-definition extensions:argument-list)
+ \end{lisp}
+
+ \code{encapsulate} always returns \var{symbol}.
+\end{defun}
+
+\begin{defun}{extensions:}{unencapsulate}{\args{\var{symbol} \var{type}}}
+
+ Undoes \var{symbol}'s most recent encapsulation of type \var{type}.
+ \var{Type} is compared with \code{eq}. Encapsulations of other
+ types are left in place.
+\end{defun}
+
+\begin{defun}{extensions:}{encapsulated-p}{%
+ \args{\var{symbol} \var{type}}}
+
+ Returns \true{} if \var{symbol} has an encapsulation of type
+ \var{type}. Returns \nil{} otherwise. \var{type} is compared with
+ \code{eq}.
+\end{defun}
+
+%%\f
+\begin{comment}
+section{The Single Stepper}
+
+\begin{defmac}{}{step}{ \args{\var{form}}}
+
+ Evaluates form with single stepping enabled or if \var{form} is
+ \code{T}, enables stepping until explicitly disabled. Stepping can
+ be disabled by quitting to the lisp top level, or by evaluating the
+ form \w{\code{(step ())}}.
+
+ While stepping is enabled, every call to eval will prompt the user
+ for a single character command. The prompt is the form which is
+ about to be \code{eval}ed. It is printed with \code{*print-level*}
+ and \code{*print-length*} bound to \code{*step-print-level*} and
+ \code{*step-print-length*}. All interaction is done through the
+ stream \code{*query-io*}. Because of this, the stepper can not be
+ used in Hemlock eval mode. When connected to a slave Lisp, the
+ stepper can be used from Hemlock.
+
+ The commands are:
+ \begin{Lentry}
+
+ \item[\key{n} (next)] Evaluate the expression with stepping still
+ enabled.
+
+ \item[\key{s} (skip)] Evaluate the expression with stepping
+ disabled.
+
+ \item[\key{q} (quit)] Evaluate the expression, but disable all
+ further stepping inside the current call to \code{step}.
+
+ \item[\key{p} (print)] Print current form. (does not use
+ \code{*step-print-level*} or \code{*step-print-length*}.)
+
+ \item[\key{b} (break)] Enter break loop, and then prompt for the
+ command again when the break loop returns.
+
+ \item[\key{e} (eval)] Prompt for and evaluate an arbitrary
+ expression. The expression is evaluated with stepping disabled.
+
+ \item[\key{?} (help)] Prints a brief list of the commands.
+
+ \item[\key{r} (return)] Prompt for an arbitrary value to return as
+ result of the current call to eval.
+
+ \item[\key{g}] Throw to top level.
+ \end{Lentry}
+\end{defmac}
+
+\begin{defvar}{extensions:}{step-print-level}
+ \defvarx[extensions:]{step-print-length}
+
+ \code{*print-level*} and \code{*print-length*} are bound to these
+ values while printing the current form. \code{*step-print-level*}
+ and \code{*step-print-length*} are initially bound to 4 and 5,
+ respectively.
+\end{defvar}
+
+\begin{defvar}{extensions:}{max-step-indentation}
+
+ Step indents the prompts to highlight the nesting of the evaluation.
+ This variable contains the maximum number of spaces to use for
+ indenting. Initially set to 40.
+\end{defvar}
+
+\end{comment}
+
+%%\f
+%%\node Specials, , Function Tracing, The Debugger
+\section{Specials}
+These are the special variables that control the debugger action.
+
+\begin{changebar}
+\begin{defvar}{debug:}{debug-print-level}
+ \defvarx[debug:]{debug-print-length}
+
+ \code{*print-level*} and \code{*print-length*} are bound to these
+ values during the execution of some debug commands. When evaluating
+ arbitrary expressions in the debugger, the normal values of
+ \code{*print-level*} and \code{*print-length*} are in effect. These
+ variables are initially set to 3 and 5, respectively.
+\end{defvar}
+\end{changebar}
+
+%%\f
+\hide{File:/afs/cs.cmu.edu/project/clisp/hackers/ram/docs/cmu-user/compiler.ms}
+
+
+%%\node The Compiler, Advanced Compiler Use and Efficiency Hints, The Debugger, Top
+\chapter{The Compiler} \hide{ -*- Dictionary: cmu-user -*-}
+
+\begin{comment}
+* Compiler Introduction::
+* Calling the Compiler::
+* Compilation Units::
+* Interpreting Error Messages::
+* Types in Python::
+* Getting Existing Programs to Run::
+* Compiler Policy::
+* Open Coding and Inline Expansion::
+\end{comment}
+
+%%\node Compiler Introduction, Calling the Compiler, The Compiler, The Compiler
+\section{Compiler Introduction}
+
+This chapter contains information about the compiler that every \cmucl{} user
+should be familiar with. Chapter \ref{advanced-compiler} goes into greater
+depth, describing ways to use more advanced features.
+
+The \cmucl{} compiler (also known as \Python{}) has many features
+that are seldom or never supported by conventional \llisp{}
+compilers:
+\begin{itemize}
+
+\item Source level debugging of compiled code (see chapter
+ \ref{debugger}.)
+
+\item Type error compiler warnings for type errors detectable at
+ compile time.
+
+\item Compiler error messages that provide a good indication of where
+ the error appeared in the source.
+
+\item Full run-time checking of all potential type errors, with
+ optimization of type checks to minimize the cost.
+
+\item Scheme-like features such as proper tail recursion and extensive
+ source-level optimization.
+
+\item Advanced tuning and optimization features such as comprehensive
+ efficiency notes, flow analysis, and untagged number representations
+ (see chapter \ref{advanced-compiler}.)
+\end{itemize}
+
+
+%%\f
+%%\node Calling the Compiler, Compilation Units, Compiler Introduction, The Compiler
+\section{Calling the Compiler}
+\cindex{compiling}
+Functions may be compiled using \code{compile}, \code{compile-file}, or
+\code{compile-from-stream}.
+
+\begin{defun}{}{compile}{ \args{\var{name} \ampoptional{} \var{definition}}}
+
+ This function compiles the function whose name is \var{name}. If
+ \var{name} is \false, the compiled function object is returned. If
+ \var{definition} is supplied, it should be a lambda expression that
+ is to be compiled and then placed in the function cell of
+ \var{name}. As per the proposed X3J13 cleanup
+ ``compile-argument-problems'', \var{definition} may also be an
+ interpreted function.
+
+ The return values are as per the proposed X3J13 cleanup
+ ``compiler-diagnostics''. The first value is the function name or
+ function object. The second value is \false{} if no compiler
+ diagnostics were issued, and \true{} otherwise. The third value is
+ \false{} if no compiler diagnostics other than style warnings were
+ issued. A non-\false{} value indicates that there were ``serious''
+ compiler diagnostics issued, or that other conditions of type
+ \tindexed{error} or \tindexed{warning} (but not
+ \tindexed{style-warning}) were signaled during compilation.
+\end{defun}
+
+
+\begin{defun}{}{compile-file}{
+ \args{\var{input-pathname}
+ \keys{\kwd{output-file} \kwd{error-file} \kwd{trace-file}}
+ \morekeys{\kwd{error-output} \kwd{verbose} \kwd{print} \kwd{progress}}
+ \yetmorekeys{\kwd{load} \kwd{block-compile} \kwd{entry-points}}
+ \yetmorekeys{\kwd{byte-compile}}}}
+
+ The \cmucl{} \code{compile-file} is extended through the addition of
+ several new keywords and an additional interpretation of
+ \var{input-pathname}:
+ \begin{Lentry}
+
+ \item[\var{input-pathname}] If this argument is a list of input
+ files, rather than a single input pathname, then all the source
+ files are compiled into a single object file. In this case, the
+ name of the first file is used to determine the default output
+ file names. This is especially useful in combination with
+ \var{block-compile}.
+
+ \item[\kwd{output-file}] This argument specifies the name of the
+ output file. \true{} gives the default name, \false{} suppresses
+ the output file.
+
+ \item[\kwd{error-file}] A listing of all the error output is
+ directed to this file. If there are no errors, then no error file
+ is produced (and any existing error file is deleted.) \true{}
+ gives \w{"\var{name}\code{.err}"} (the default), and \false{}
+ suppresses the output file.
+
+ \item[\kwd{error-output}] If \true{} (the default), then error
+ output is sent to \code{*error-output*}. If a stream, then output
+ is sent to that stream instead. If \false, then error output is
+ suppressed. Note that this error output is in addition to (but
+ the same as) the output placed in the \var{error-file}.
+
+ \item[\kwd{verbose}] If \true{} (the default), then the compiler
+ prints to error output at the start and end of compilation of each
+ file. See \varref{compile-verbose}.
+
+ \item[\kwd{print}] If \true{} (the default), then the compiler
+ prints to error output when each function is compiled. See
+ \varref{compile-print}.
+
+ \item[\kwd{progress}] If \true{} (default \false{}), then the
+ compiler prints to error output progress information about the
+ phases of compilation of each function. This is a CMU extension
+ that is useful mainly in large block compilations. See
+ \varref{compile-progress}.
+
+ \item[\kwd{trace-file}] If \true{}, several of the intermediate
+ representations (including annotated assembly code) are dumped out
+ to this file. \true{} gives \w{"\var{name}\code{.trace}"}. Trace
+ output is off by default. \xlref{trace-files}.
+
+ \item[\kwd{load}] If \true{}, load the resulting output file.
+
+ \item[\kwd{block-compile}] Controls the compile-time resolution of
+ function calls. By default, only self-recursive calls are
+ resolved, unless an \code{ext:block-start} declaration appears in
+ the source file. \xlref{compile-file-block}.
+
+ \item[\kwd{entry-points}] If non-null, then this is a list of the
+ names of all functions in the file that should have global
+ definitions installed (because they are referenced in other
+ files.) \xlref{compile-file-block}.
+
+ \item[\kwd{byte-compile}] If \true{}, compiling to a compact
+ interpreted byte code is enabled. Possible values are \true{},
+ \false{}, and \kwd{maybe} (the default.) See
+ \varref{byte-compile-default} and \xlref{byte-compile}.
+ \end{Lentry}
+
+ The return values are as per the proposed X3J13 cleanup
+ ``compiler-diagnostics''. The first value from \code{compile-file}
+ is the truename of the output file, or \false{} if the file could
+ not be created. The interpretation of the second and third values
+ is described above for \code{compile}.
+\end{defun}
+
+\begin{defvar}{}{compile-verbose}
+ \defvarx{compile-print}
+ \defvarx{compile-progress}
+
+ These variables determine the default values for the \kwd{verbose},
+ \kwd{print} and \kwd{progress} arguments to \code{compile-file}.
+\end{defvar}
+
+\begin{defun}{extensions:}{compile-from-stream}{%
+ \args{\var{input-stream}
+ \keys{\kwd{error-stream}}
+ \morekeys{\kwd{trace-stream}}
+ \yetmorekeys{\kwd{block-compile} \kwd{entry-points}}
+ \yetmorekeys{\kwd{byte-compile}}}}
+
+ This function is similar to \code{compile-file}, but it takes all
+ its arguments as streams. It reads \llisp{} code from
+ \var{input-stream} until end of file is reached, compiling into the
+ current environment. This function returns the same two values as
+ the last two values of \code{compile}. No output files are
+ produced.
+\end{defun}
+
+
+%%\f
+%%\node Compilation Units, Interpreting Error Messages, Calling the Compiler, The Compiler
+\section{Compilation Units}
+\cpsubindex{compilation}{units}
+
+\cmucl{} supports the \code{with-compilation-unit} macro added to the
+language by the proposed X3J13 ``with-compilation-unit'' compiler
+cleanup. This provides a mechanism for eliminating spurious undefined
+warnings when there are forward references across files, and also
+provides a standard way to access compiler extensions.
+
+\begin{defmac}{}{with-compilation-unit}{%
+ \args{(\mstar{\var{key} \var{value}}) \mstar{\var{form}}}}
+
+ This macro evaluates the \var{forms} in an environment that causes
+ warnings for undefined variables, functions and types to be delayed
+ until all the forms have been evaluated. Each keyword \var{value}
+ is an evaluated form. These keyword options are recognized:
+ \begin{Lentry}
+
+ \item[\kwd{override}] If uses of \code{with-compilation-unit} are
+ dynamically nested, the outermost use will take precedence,
+ suppressing printing of undefined warnings by inner uses.
+ However, when the \code{override} option is true this shadowing is
+ inhibited; an inner use will print summary warnings for the
+ compilations within the inner scope.
+
+ \item[\kwd{optimize}] This is a CMU extension that specifies of the
+ ``global'' compilation policy for the dynamic extent of the body.
+ The argument should evaluate to an \code{optimize} declare form,
+ like:
+ \begin{lisp}
+ (optimize (speed 3) (safety 0))
+ \end{lisp}
+ \xlref{optimize-declaration}
+
+ \item[\kwd{optimize-interface}] Similar to \kwd{optimize}, but
+ specifies the compilation policy for function interfaces (argument
+ count and type checking) for the dynamic extent of the body.
+ \xlref{optimize-interface-declaration}.
+
+ \item[\kwd{context-declarations}] This is a CMU extension that
+ pattern-matches on function names, automatically splicing in any
+ appropriate declarations at the head of the function definition.
+ \xlref{context-declarations}.
+ \end{Lentry}
+\end{defmac}
+
+\begin{comment}
+* Undefined Warnings::
+\end{comment}
+
+%%\node Undefined Warnings, , Compilation Units, Compilation Units
+\subsection{Undefined Warnings}
+
+\cindex{undefined warnings}
+Warnings about undefined variables, functions and types are delayed until the
+end of the current compilation unit. The compiler entry functions
+(\code{compile}, etc.) implicitly use \code{with-compilation-unit}, so undefined
+warnings will be printed at the end of the compilation unless there is an
+enclosing \code{with-compilation-unit}. In order the gain the benefit of this
+mechanism, you should wrap a single \code{with-compilation-unit} around the calls
+to \code{compile-file}, i.e.:
+\begin{lisp}
+(with-compilation-unit ()
+ (compile-file "file1")
+ (compile-file "file2")
+ ...)
+\end{lisp}
+
+Unlike for functions and types, undefined warnings for variables are
+not suppressed when a definition (e.g. \code{defvar}) appears after
+the reference (but in the same compilation unit.) This is because
+doing special declarations out of order just doesn't
+work\dash{}although early references will be compiled as special,
+bindings will be done lexically.
+
+Undefined warnings are printed with full source context
+(\pxlref{error-messages}), which tremendously simplifies the problem
+of finding undefined references that resulted from macroexpansion.
+After printing detailed information about the undefined uses of each
+name, \code{with-compilation-unit} also prints summary listings of the
+names of all the undefined functions, types and variables.
+
+\begin{defvar}{}{undefined-warning-limit}
+
+ This variable controls the number of undefined warnings for each
+ distinct name that are printed with full source context when the
+ compilation unit ends. If there are more undefined references than
+ this, then they are condensed into a single warning:
+ \begin{example}
+ Warning: \var{count} more uses of undefined function \var{name}.
+ \end{example}
+ When the value is \code{0}, then the undefined warnings are not
+ broken down by name at all: only the summary listing of undefined
+ names is printed.
+\end{defvar}
+
+%%\f
+%%\node Interpreting Error Messages, Types in Python, Compilation Units, The Compiler
+\section{Interpreting Error Messages}
+\label{error-messages}
+\cpsubindex{error messages}{compiler}
+\cindex{compiler error messages}
+
+One of \Python{}'s unique features is the level of source location
+information it provides in error messages. The error messages contain
+a lot of detail in a terse format, to they may be confusing at first.
+Error messages will be illustrated using this example program:
+\begin{lisp}
+(defmacro zoq (x)
+ `(roq (ploq (+ ,x 3))))
+
+(defun foo (y)
+ (declare (symbol y))
+ (zoq y))
+\end{lisp}
+The main problem with this program is that it is trying to add \code{3} to a
+symbol. Note also that the functions \code{roq} and \code{ploq} aren't defined
+anywhere.
+
+\begin{comment}
+* The Parts of the Error Message::
+* The Original and Actual Source::
+* The Processing Path::
+* Error Severity::
+* Errors During Macroexpansion::
+* Read Errors::
+* Error Message Parameterization::
+\end{comment}
+
+%%\node The Parts of the Error Message, The Original and Actual Source, Interpreting Error Messages, Interpreting Error Messages
+\subsection{The Parts of the Error Message}
+
+The compiler will produce this warning:
+\begin{example}
+File: /usr/me/stuff.lisp
+
+In: DEFUN FOO
+ (ZOQ Y)
+--> ROQ PLOQ +
+==>
+ Y
+Warning: Result is a SYMBOL, not a NUMBER.
+\end{example}
+In this example we see each of the six possible parts of a compiler error
+message:
+\begin{Lentry}
+
+\item[\w{\code{File: /usr/me/stuff.lisp}}] This is the \var{file} that
+ the compiler read the relevant code from. The file name is
+ displayed because it may not be immediately obvious when there is an
+ error during compilation of a large system, especially when
+ \code{with-compilation-unit} is used to delay undefined warnings.
+
+\item[\w{\code{In: DEFUN FOO}}] This is the \var{definition} or
+ top-level form responsible for the error. It is obtained by taking
+ the first two elements of the enclosing form whose first element is
+ a symbol beginning with ``\code{DEF}''. If there is no enclosing
+ \w{\var{def}mumble}, then the outermost form is used. If there are
+ multiple \w{\var{def}mumbles}, then they are all printed from the
+ out in, separated by \code{$=>$}'s. In this example, the problem
+ was in the \code{defun} for \code{foo}.
+
+\item[\w{\code{(ZOQ Y)}}] This is the \i{original source} form
+ responsible for the error. Original source means that the form
+ directly appeared in the original input to the compiler, i.e. in the
+ lambda passed to \code{compile} or the top-level form read from the
+ source file. In this example, the expansion of the \code{zoq} macro
+ was responsible for the error.
+
+\item[\w{\code{--$>$ ROQ PLOQ +}} ] This is the \i{processing path}
+ that the compiler used to produce the errorful code. The processing
+ path is a representation of the evaluated forms enclosing the actual
+ source that the compiler encountered when processing the original
+ source. The path is the first element of each form, or the form
+ itself if the form is not a list. These forms result from the
+ expansion of macros or source-to-source transformation done by the
+ compiler. In this example, the enclosing evaluated forms are the
+ calls to \code{roq}, \code{ploq} and \code{+}. These calls resulted
+ from the expansion of the \code{zoq} macro.
+
+\item[\code{==$>$ Y}] This is the \i{actual source} responsible for
+ the error. If the actual source appears in the explanation, then we
+ print the next enclosing evaluated form, instead of printing the
+ actual source twice. (This is the form that would otherwise have
+ been the last form of the processing path.) In this example, the
+ problem is with the evaluation of the reference to the variable
+ \code{y}.
+
+\item[\w{\code{Warning: Result is a SYMBOL, not a NUMBER.}}] This is
+ the \var{explanation} the problem. In this example, the problem is
+ that \code{y} evaluates to a \code{symbol}, but is in a context
+ where a number is required (the argument to \code{+}).
+\end{Lentry}
+
+Note that each part of the error message is distinctively marked:
+\begin{itemize}
+
+\item \code{File:} and \code{In:} mark the file and definition,
+ respectively.
+
+\item The original source is an indented form with no prefix.
+
+\item Each line of the processing path is prefixed with \code{--$>$}.
+
+\item The actual source form is indented like the original source, but
+ is marked by a preceding \code{==$>$} line. This is like the
+ ``macroexpands to'' notation used in \cltl.
+
+\item The explanation is prefixed with the error severity
+ (\pxlref{error-severity}), either \code{Error:}, \code{Warning:}, or
+ \code{Note:}.
+\end{itemize}
+
+
+Each part of the error message is more specific than the preceding
+one. If consecutive error messages are for nearby locations, then the
+front part of the error messages would be the same. In this case, the
+compiler omits as much of the second message as in common with the
+first. For example:
+\begin{example}
+File: /usr/me/stuff.lisp
+
+In: DEFUN FOO
+ (ZOQ Y)
+--> ROQ
+==>
+ (PLOQ (+ Y 3))
+Warning: Undefined function: PLOQ
+
+==>
+ (ROQ (PLOQ (+ Y 3)))
+Warning: Undefined function: ROQ
+\end{example}
+In this example, the file, definition and original source are
+identical for the two messages, so the compiler omits them in the
+second message. If consecutive messages are entirely identical, then
+the compiler prints only the first message, followed by:
+\begin{example}
+[Last message occurs \var{repeats} times]
+\end{example}
+where \var{repeats} is the number of times the message was given.
+
+If the source was not from a file, then no file line is printed. If
+the actual source is the same as the original source, then the
+processing path and actual source will be omitted. If no forms
+intervene between the original source and the actual source, then the
+processing path will also be omitted.
+
+%%\f
+%%\node The Original and Actual Source, The Processing Path, The Parts of the Error Message, Interpreting Error Messages
+\subsection{The Original and Actual Source}
+\cindex{original source}
+\cindex{actual source}
+
+The \i{original source} displayed will almost always be a list. If the actual
+source for an error message is a symbol, the original source will be the
+immediately enclosing evaluated list form. So even if the offending symbol
+does appear in the original source, the compiler will print the enclosing list
+and then print the symbol as the actual source (as though the symbol were
+introduced by a macro.)
+
+When the \i{actual source} is displayed (and is not a symbol), it will always
+be code that resulted from the expansion of a macro or a source-to-source
+compiler optimization. This is code that did not appear in the original
+source program; it was introduced by the compiler.
+
+Keep in mind that when the compiler displays a source form in an error message,
+it always displays the most specific (innermost) responsible form. For
+example, compiling this function:
+\begin{lisp}
+(defun bar (x)
+ (let (a)
+ (declare (fixnum a))
+ (setq a (foo x))
+ a))
+\end{lisp}
+Gives this error message:
+\begin{example}
+In: DEFUN BAR
+ (LET (A) (DECLARE (FIXNUM A)) (SETQ A (FOO X)) A)
+Warning: The binding of A is not a FIXNUM:
+ NIL
+\end{example}
+This error message is not saying ``there's a problem somewhere in this
+\code{let}''\dash{}it is saying that there is a problem with the
+\code{let} itself. In this example, the problem is that \code{a}'s
+\false{} initial value is not a \code{fixnum}.
+
+%%\f
+%%\node The Processing Path, Error Severity, The Original and Actual Source, Interpreting Error Messages
+\subsection{The Processing Path}
+\cindex{processing path}
+\cindex{macroexpansion}
+\cindex{source-to-source transformation}
+
+The processing path is mainly useful for debugging macros, so if you don't
+write macros, you can ignore the processing path. Consider this example:
+\begin{lisp}
+(defun foo (n)
+ (dotimes (i n *undefined*)))
+\end{lisp}
+Compiling results in this error message:
+\begin{example}
+In: DEFUN FOO
+ (DOTIMES (I N *UNDEFINED*))
+--> DO BLOCK LET TAGBODY RETURN-FROM
+==>
+ (PROGN *UNDEFINED*)
+Warning: Undefined variable: *UNDEFINED*
+\end{example}
+Note that \code{do} appears in the processing path. This is because \code{dotimes}
+expands into:
+\begin{lisp}
+(do ((i 0 (1+ i)) (#:g1 n))
+ ((>= i #:g1) *undefined*)
+ (declare (type unsigned-byte i)))
+\end{lisp}
+The rest of the processing path results from the expansion of \code{do}:
+\begin{lisp}
+(block nil
+ (let ((i 0) (#:g1 n))
+ (declare (type unsigned-byte i))
+ (tagbody (go #:g3)
+ #:g2 (psetq i (1+ i))
+ #:g3 (unless (>= i #:g1) (go #:g2))
+ (return-from nil (progn *undefined*)))))
+\end{lisp}
+In this example, the compiler descended into the \code{block},
+\code{let}, \code{tagbody} and \code{return-from} to reach the
+\code{progn} printed as the actual source. This is a place where the
+``actual source appears in explanation'' rule was applied. The
+innermost actual source form was the symbol \code{*undefined*} itself,
+but that also appeared in the explanation, so the compiler backed out
+one level.
+
+%%\f
+%%\node Error Severity, Errors During Macroexpansion, The Processing Path, Interpreting Error Messages
+\subsection{Error Severity}
+\label{error-severity}
+\cindex{severity of compiler errors}
+\cindex{compiler error severity}
+
+There are three levels of compiler error severity:
+\begin{Lentry}
+
+\item[Error] This severity is used when the compiler encounters a
+ problem serious enough to prevent normal processing of a form.
+ Instead of compiling the form, the compiler compiles a call to
+ \code{error}. Errors are used mainly for signaling syntax errors.
+ If an error happens during macroexpansion, the compiler will handle
+ it. The compiler also handles and attempts to proceed from read
+ errors.
+
+\item[Warning] Warnings are used when the compiler can prove that
+ something bad will happen if a portion of the program is executed,
+ but the compiler can proceed by compiling code that signals an error
+ at runtime if the problem has not been fixed:
+ \begin{itemize}
+
+ \item Violation of type declarations, or
+
+ \item Function calls that have the wrong number of arguments or
+ malformed keyword argument lists, or
+
+ \item Referencing a variable declared \code{ignore}, or unrecognized
+ declaration specifiers.
+ \end{itemize}
+
+ In the language of the \clisp{} standard, these are situations where
+ the compiler can determine that a situation with undefined
+ consequences or that would cause an error to be signaled would
+ result at runtime.
+
+\item[Note] Notes are used when there is something that seems a bit
+ odd, but that might reasonably appear in correct programs.
+\end{Lentry}
+Note that the compiler does not fully conform to the proposed X3J13
+``compiler-diagnostics'' cleanup. Errors, warnings and notes mostly
+correspond to errors, warnings and style-warnings, but many things
+that the cleanup considers to be style-warnings are printed as
+warnings rather than notes. Also, warnings, style-warnings and most
+errors aren't really signaled using the condition system.
+
+%%\f
+%%\node Errors During Macroexpansion, Read Errors, Error Severity, Interpreting Error Messages
+\subsection{Errors During Macroexpansion}
+\cpsubindex{macroexpansion}{errors during}
+
+The compiler handles errors that happen during macroexpansion, turning
+them into compiler errors. If you want to debug the error (to debug a
+macro), you can set \code{*break-on-signals*} to \code{error}. For
+example, this definition:
+\begin{lisp}
+(defun foo (e l)
+ (do ((current l (cdr current))
+ ((atom current) nil))
+ (when (eq (car current) e) (return current))))
+\end{lisp}
+gives this error:
+\begin{example}
+In: DEFUN FOO
+ (DO ((CURRENT L #) (# NIL)) (WHEN (EQ # E) (RETURN CURRENT)) )
+Error: (during macroexpansion)
+
+Error in function LISP::DO-DO-BODY.
+DO step variable is not a symbol: (ATOM CURRENT)
+\end{example}
+
+
+%%\f
+%%\node Read Errors, Error Message Parameterization, Errors During Macroexpansion, Interpreting Error Messages
+\subsection{Read Errors}
+\cpsubindex{read errors}{compiler}
+
+The compiler also handles errors while reading the source. For example:
+\begin{example}
+Error: Read error at 2:
+ "(,/\back{foo})"
+Error in function LISP::COMMA-MACRO.
+Comma not inside a backquote.
+\end{example}
+The ``\code{at 2}'' refers to the character position in the source file at
+which the error was signaled, which is generally immediately after the
+erroneous text. The next line, ``\code{(,/\back{foo})}'', is the line in
+the source that contains the error file position. The ``\code{/\back{} }''
+indicates the error position within that line (in this example,
+immediately after the offending comma.)
+
+When in \hemlock{} (or any other EMACS-like editor), you can go to a
+character position with:
+\begin{example}
+M-< C-u \var{position} C-f
+\end{example}
+Note that if the source is from a \hemlock{} buffer, then the position
+is relative to the start of the compiled region or \code{defun}, not the
+file or buffer start.
+
+After printing a read error message, the compiler attempts to recover from the
+error by backing up to the start of the enclosing top-level form and reading
+again with \code{*read-suppress*} true. If the compiler can recover from the
+error, then it substitutes a call to \code{cerror} for the unreadable form and
+proceeds to compile the rest of the file normally.
+
+If there is a read error when the file position is at the end of the file
+(i.e., an unexpected EOF error), then the error message looks like this:
+\begin{example}
+Error: Read error in form starting at 14:
+ "(defun test ()"
+Error in function LISP::FLUSH-WHITESPACE.
+EOF while reading #<Stream for file "/usr/me/test.lisp">
+\end{example}
+In this case, ``\code{starting at 14}'' indicates the character
+position at which the compiler started reading, i.e. the position
+before the start of the form that was missing the closing delimiter.
+The line \w{"\code{(defun test ()}"} is first line after the starting
+position that the compiler thinks might contain the unmatched open
+delimiter.
+
+%%\f
+%%\node Error Message Parameterization, , Read Errors, Interpreting Error Messages
+\subsection{Error Message Parameterization}
+\cpsubindex{error messages}{verbosity}
+\cpsubindex{verbosity}{of error messages}
+
+There is some control over the verbosity of error messages. See also
+\varref{undefined-warning-limit}, \code{*efficiency-note-limit*} and
+\varref{efficiency-note-cost-threshold}.
+
+\begin{defvar}{}{enclosing-source-cutoff}
+
+ This variable specifies the number of enclosing actual source forms
+ that are printed in full, rather than in the abbreviated processing
+ path format. Increasing the value from its default of \code{1}
+ allows you to see more of the guts of the macroexpanded source,
+ which is useful when debugging macros.
+\end{defvar}
+
+\begin{defvar}{}{error-print-length}
+ \defvarx{error-print-level}
+
+ These variables are the print level and print length used in
+ printing error messages. The default values are \code{5} and
+ \code{3}. If null, the global values of \code{*print-level*} and
+ \code{*print-length*} are used.
+\end{defvar}
+
+\begin{defmac}{extensions:}{def-source-context}{%
+ \args{\var{name} \var{lambda-list} \mstar{form}}}
+
+ This macro defines how to extract an abbreviated source context from
+ the \var{name}d form when it appears in the compiler input.
+ \var{lambda-list} is a \code{defmacro} style lambda-list used to
+ parse the arguments. The \var{body} should return a list of
+ subforms that can be printed on about one line. There are
+ predefined methods for \code{defstruct}, \code{defmethod}, etc. If
+ no method is defined, then the first two subforms are returned.
+ Note that this facility implicitly determines the string name
+ associated with anonymous functions.
+\end{defmac}
+
+%%\f
+%%\node Types in Python, Getting Existing Programs to Run, Interpreting Error Messages, The Compiler
+\section{Types in Python}
+\cpsubindex{types}{in python}
+
+A big difference between \Python{} and all other \llisp{} compilers
+is the approach to type checking and amount of knowledge about types:
+\begin{itemize}
+
+\item \Python{} treats type declarations much differently that other
+ Lisp compilers do. \Python{} doesn't blindly believe type
+ declarations; it considers them assertions about the program that
+ should be checked.
+
+\item \Python{} also has a tremendously greater knowledge of the
+ \clisp{} type system than other compilers. Support is incomplete
+ only for the \code{not}, \code{and} and \code{satisfies} types.
+\end{itemize}
+See also sections \ref{advanced-type-stuff} and \ref{type-inference}.
+
+%%\f
+\begin{comment}
+* Compile Time Type Errors::
+* Precise Type Checking::
+* Weakened Type Checking::
+\end{comment}
+
+%%\node Compile Time Type Errors, Precise Type Checking, Types in Python, Types in Python
+\subsection{Compile Time Type Errors}
+\cindex{compile time type errors}
+\cpsubindex{type checking}{at compile time}
+
+If the compiler can prove at compile time that some portion of the
+program cannot be executed without a type error, then it will give a
+warning at compile time. It is possible that the offending code would
+never actually be executed at run-time due to some higher level
+consistency constraint unknown to the compiler, so a type warning
+doesn't always indicate an incorrect program. For example, consider
+this code fragment:
+\begin{lisp}
+(defun raz (foo)
+ (let ((x (case foo
+ (:this 13)
+ (:that 9)
+ (:the-other 42))))
+ (declare (fixnum x))
+ (foo x)))
+\end{lisp}
+Compilation produces this warning:
+\begin{example}
+In: DEFUN RAZ
+ (CASE FOO (:THIS 13) (:THAT 9) (:THE-OTHER 42))
+--> LET COND IF COND IF COND IF
+==>
+ (COND)
+Warning: This is not a FIXNUM:
+ NIL
+\end{example}
+In this case, the warning is telling you that if \code{foo} isn't any
+of \kwd{this}, \kwd{that} or \kwd{the-other}, then \code{x} will be
+initialized to \false, which the \code{fixnum} declaration makes
+illegal. The warning will go away if \code{ecase} is used instead of
+\code{case}, or if \kwd{the-other} is changed to \true.
+
+This sort of spurious type warning happens moderately often in the
+expansion of complex macros and in inline functions. In such cases,
+there may be dead code that is impossible to correctly execute. The
+compiler can't always prove this code is dead (could never be
+executed), so it compiles the erroneous code (which will always signal
+an error if it is executed) and gives a warning.
+
+\begin{defun}{extensions:}{required-argument}{}
+
+ This function can be used as the default value for keyword arguments
+ that must always be supplied. Since it is known by the compiler to
+ never return, it will avoid any compile-time type warnings that
+ would result from a default value inconsistent with the declared
+ type. When this function is called, it signals an error indicating
+ that a required keyword argument was not supplied. This function is
+ also useful for \code{defstruct} slot defaults corresponding to
+ required arguments. \xlref{empty-type}.
+
+ Although this function is a CMU extension, it is relatively harmless
+ to use it in otherwise portable code, since you can easily define it
+ yourself:
+ \begin{lisp}
+ (defun required-argument ()
+ (error "A required keyword argument was not supplied."))
+ \end{lisp}
+\end{defun}
+
+Type warnings are inhibited when the
+\code{extensions:inhibit-warnings} optimization quality is \code{3}
+(\pxlref{compiler-policy}.) This can be used in a local declaration
+to inhibit type warnings in a code fragment that has spurious
+warnings.
+
+%%\f
+%%\node Precise Type Checking, Weakened Type Checking, Compile Time Type Errors, Types in Python
+\subsection{Precise Type Checking}
+\label{precise-type-checks}
+\cindex{precise type checking}
+\cpsubindex{type checking}{precise}
+
+With the default compilation policy, all type
+assertions\footnote{There are a few circumstances where a type
+ declaration is discarded rather than being used as type assertion.
+ This doesn't affect safety much, since such discarded declarations
+ are also not believed to be true by the compiler.} are precisely
+checked. Precise checking means that the check is done as though
+\code{typep} had been called with the exact type specifier that
+appeared in the declaration. \Python{} uses \var{policy} to determine
+whether to trust type assertions (\pxlref{compiler-policy}). Type
+assertions from declarations are indistinguishable from the type
+assertions on arguments to built-in functions. In \Python, adding
+type declarations makes code safer.
+
+If a variable is declared to be \w{\code{(integer 3 17)}}, then its
+value must always always be an integer between \code{3} and \code{17}.
+If multiple type declarations apply to a single variable, then all the
+declarations must be correct; it is as though all the types were
+intersected producing a single \code{and} type specifier.
+
+Argument type declarations are automatically enforced. If you declare
+the type of a function argument, a type check will be done when that
+function is called. In a function call, the called function does the
+argument type checking, which means that a more restrictive type
+assertion in the calling function (e.g., from \code{the}) may be lost.
+
+The types of structure slots are also checked. The value of a
+structure slot must always be of the type indicated in any \kwd{type}
+slot option.\footnote{The initial value need not be of this type as
+ long as the corresponding argument to the constructor is always
+ supplied, but this will cause a compile-time type warning unless
+ \code{required-argument} is used.} Because of precise type checking,
+the arguments to slot accessors are checked to be the correct type of
+structure.
+
+In traditional \llisp{} compilers, not all type assertions are
+checked, and type checks are not precise. Traditional compilers
+blindly trust explicit type declarations, but may check the argument
+type assertions for built-in functions. Type checking is not precise,
+since the argument type checks will be for the most general type legal
+for that argument. In many systems, type declarations suppress what
+little type checking is being done, so adding type declarations makes
+code unsafe. This is a problem since it discourages writing type
+declarations during initial coding. In addition to being more error
+prone, adding type declarations during tuning also loses all the
+benefits of debugging with checked type assertions.
+
+To gain maximum benefit from \Python{}'s type checking, you should
+always declare the types of function arguments and structure slots as
+precisely as possible. This often involves the use of \code{or},
+\code{member} and other list-style type specifiers. Paradoxically,
+even though adding type declarations introduces type checks, it
+usually reduces the overall amount of type checking. This is
+especially true for structure slot type declarations.
+
+\Python{} uses the \code{safety} optimization quality (rather than
+presence or absence of declarations) to choose one of three levels of
+run-time type error checking: \pxlref{optimize-declaration}.
+\xlref{advanced-type-stuff} for more information about types in
+\Python.
+
+%%\f
+%%\node Weakened Type Checking, , Precise Type Checking, Types in Python
+\subsection{Weakened Type Checking}
+\label{weakened-type-checks}
+\cindex{weakened type checking}
+\cpsubindex{type checking}{weakened}
+
+When the value for the \code{speed} optimization quality is greater
+than \code{safety}, and \code{safety} is not \code{0}, then type
+checking is weakened to reduce the speed and space penalty. In
+structure-intensive code this can double the speed, yet still catch
+most type errors. Weakened type checks provide a level of safety
+similar to that of ``safe'' code in other \llisp{} compilers.
+
+A type check is weakened by changing the check to be for some
+convenient supertype of the asserted type. For example,
+\code{\w{(integer 3 17)}} is changed to \code{fixnum},
+\code{\w{(simple-vector 17)}} to \code{simple-vector}, and structure
+types are changed to \code{structure}. A complex check like:
+\begin{example}
+(or node hunk (member :foo :bar :baz))
+\end{example}
+will be omitted entirely (i.e., the check is weakened to \code{*}.) If
+a precise check can be done for no extra cost, then no weakening is
+done.
+
+Although weakened type checking is similar to type checking done by
+other compilers, it is sometimes safer and sometimes less safe.
+Weakened checks are done in the same places is precise checks, so all
+the preceding discussion about where checking is done still applies.
+Weakened checking is sometimes somewhat unsafe because although the
+check is weakened, the precise type is still input into type
+inference. In some contexts this will result in type inferences not
+justified by the weakened check, and hence deletion of some type
+checks that would be done by conventional compilers.
+
+For example, if this code was compiled with weakened checks:
+\begin{lisp}
+(defstruct foo
+ (a nil :type simple-string))
+
+(defstruct bar
+ (a nil :type single-float))
+
+(defun myfun (x)
+ (declare (type bar x))
+ (* (bar-a x) 3.0))
+\end{lisp}
+and \code{myfun} was passed a \code{foo}, then no type error would be
+signaled, and we would try to multiply a \code{simple-vector} as
+though it were a float (with unpredictable results.) This is because
+the check for \code{bar} was weakened to \code{structure}, yet when
+compiling the call to \code{bar-a}, the compiler thinks it knows it
+has a \code{bar}.
+
+Note that normally even weakened type checks report the precise type
+in error messages. For example, if \code{myfun}'s \code{bar} check is
+weakened to \code{structure}, and the argument is \false{}, then the
+error will be:
+\begin{example}
+Type-error in MYFUN:
+ NIL is not of type BAR
+\end{example}
+However, there is some speed and space cost for signaling a precise
+error, so the weakened type is reported if the \code{speed}
+optimization quality is \code{3} or \code{debug} quality is less than
+\code{1}:
+\begin{example}
+Type-error in MYFUN:
+ NIL is not of type STRUCTURE
+\end{example}
+\xlref{optimize-declaration} for further discussion of the
+\code{optimize} declaration.
+
+%%\f
+%%\node Getting Existing Programs to Run, Compiler Policy, Types in Python, The Compiler
+\section{Getting Existing Programs to Run}
+\cpsubindex{existing programs}{to run}
+\cpsubindex{types}{portability}
+\cindex{compatibility with other Lisps}
+
+Since \Python{} does much more comprehensive type checking than other
+Lisp compilers, \Python{} will detect type errors in many programs
+that have been debugged using other compilers. These errors are
+mostly incorrect declarations, although compile-time type errors can
+find actual bugs if parts of the program have never been tested.
+
+Some incorrect declarations can only be detected by run-time type
+checking. It is very important to initially compile programs with
+full type checks and then test this version. After the checking
+version has been tested, then you can consider weakening or
+eliminating type checks. \b{This applies even to previously debugged
+ programs.} \Python{} does much more type inference than other
+\llisp{} compilers, so believing an incorrect declaration does much
+more damage.
+
+The most common problem is with variables whose initial value doesn't
+match the type declaration. Incorrect initial values will always be
+flagged by a compile-time type error, and they are simple to fix once
+located. Consider this code fragment:
+\begin{example}
+(prog (foo)
+ (declare (fixnum foo))
+ (setq foo ...)
+ ...)
+\end{example}
+Here the variable \code{foo} is given an initial value of \false, but
+is declared to be a \code{fixnum}. Even if it is never read, the
+initial value of a variable must match the declared type. There are
+two ways to fix this problem. Change the declaration:
+\begin{example}
+(prog (foo)
+ (declare (type (or fixnum null) foo))
+ (setq foo ...)
+ ...)
+\end{example}
+or change the initial value:
+\begin{example}
+(prog ((foo 0))
+ (declare (fixnum foo))
+ (setq foo ...)
+ ...)
+\end{example}
+It is generally preferable to change to a legal initial value rather
+than to weaken the declaration, but sometimes it is simpler to weaken
+the declaration than to try to make an initial value of the
+appropriate type.
+
+
+Another declaration problem occasionally encountered is incorrect
+declarations on \code{defmacro} arguments. This probably usually
+happens when a function is converted into a macro. Consider this
+macro:
+\begin{lisp}
+(defmacro my-1+ (x)
+ (declare (fixnum x))
+ `(the fixnum (1+ ,x)))
+\end{lisp}
+Although legal and well-defined \clisp, this meaning of this
+definition is almost certainly not what the writer intended. For
+example, this call is illegal:
+\begin{lisp}
+(my-1+ (+ 4 5))
+\end{lisp}
+The call is illegal because the argument to the macro is \w{\code{(+ 4
+ 5)}}, which is a \code{list}, not a \code{fixnum}. Because of
+macro semantics, it is hardly ever useful to declare the types of
+macro arguments. If you really want to assert something about the
+type of the result of evaluating a macro argument, then put a
+\code{the} in the expansion:
+\begin{lisp}
+(defmacro my-1+ (x)
+ `(the fixnum (1+ (the fixnum ,x))))
+\end{lisp}
+In this case, it would be stylistically preferable to change this
+macro back to a function and declare it inline. Macros have no
+efficiency advantage over inline functions when using \Python.
+\xlref{inline-expansion}.
+
+
+Some more subtle problems are caused by incorrect declarations that
+can't be detected at compile time. Consider this code:
+\begin{example}
+(do ((pos 0 (position #\back{a} string :start (1+ pos))))
+ ((null pos))
+ (declare (fixnum pos))
+ ...)
+\end{example}
+Although \code{pos} is almost always a \code{fixnum}, it is \false{}
+at the end of the loop. If this example is compiled with full type
+checks (the default), then running it will signal a type error at the
+end of the loop. If compiled without type checks, the program will go
+into an infinite loop (or perhaps \code{position} will complain
+because \w{\code{(1+ nil)}} isn't a sensible start.) Why? Because if
+you compile without type checks, the compiler just quietly believes
+the type declaration. Since \code{pos} is always a \code{fixnum}, it
+is never \nil, so \w{\code{(null pos)}} is never true, and the loop
+exit test is optimized away. Such errors are sometimes flagged by
+unreachable code notes (\pxlref{dead-code-notes}), but it is still
+important to initially compile any system with full type checks, even
+if the system works fine when compiled using other compilers.
+
+In this case, the fix is to weaken the type declaration to
+\w{\code{(or fixnum null)}}.\footnote{Actually, this declaration is
+ totally unnecessary in \Python, since it already knows
+ \code{position} returns a non-negative \code{fixnum} or \false.}
+Note that there is usually little performance penalty for weakening a
+declaration in this way. Any numeric operations in the body can still
+assume the variable is a \code{fixnum}, since \false{} is not a legal
+numeric argument. Another possible fix would be to say:
+\begin{example}
+(do ((pos 0 (position #\back{a} string :start (1+ pos))))
+ ((null pos))
+ (let ((pos pos))
+ (declare (fixnum pos))
+ ...))
+\end{example}
+This would be preferable in some circumstances, since it would allow a
+non-standard representation to be used for the local \code{pos}
+variable in the loop body (see section \ref{ND-variables}.)
+
+In summary, remember that \i{all} values that a variable \i{ever}
+has must be of the declared type, and that you should test using safe
+code initially.
+%%\f
+%%\node Compiler Policy, Open Coding and Inline Expansion, Getting Existing Programs to Run, The Compiler
+\section{Compiler Policy}
+\label{compiler-policy}
+\cpsubindex{policy}{compiler}
+\cindex{compiler policy}
+
+The policy is what tells the compiler \var{how} to compile a program.
+This is logically (and often textually) distinct from the program
+itself. Broad control of policy is provided by the \code{optimize}
+declaration; other declarations and variables control more specific
+aspects of compilation.
+
+%%\f
+\begin{comment}
+* The Optimize Declaration::
+* The Optimize-Interface Declaration::
+\end{comment}
+
+%%\node The Optimize Declaration, The Optimize-Interface Declaration, Compiler Policy, Compiler Policy
+\subsection{The Optimize Declaration}
+\label{optimize-declaration}
+\cindex{optimize declaration}
+\cpsubindex{declarations}{\code{optimize}}
+
+The \code{optimize} declaration recognizes six different
+\var{qualities}. The qualities are conceptually independent aspects
+of program performance. In reality, increasing one quality tends to
+have adverse effects on other qualities. The compiler compares the
+relative values of qualities when it needs to make a trade-off; i.e.,
+if \code{speed} is greater than \code{safety}, then improve speed at
+the cost of safety.
+
+The default for all qualities (except \code{debug}) is \code{1}.
+Whenever qualities are equal, ties are broken according to a broad
+idea of what a good default environment is supposed to be. Generally
+this downplays \code{speed}, \code{compile-speed} and \code{space} in
+favor of \code{safety} and \code{debug}. Novice and casual users
+should stick to the default policy. Advanced users often want to
+improve speed and memory usage at the cost of safety and
+debuggability.
+
+If the value for a quality is \code{0} or \code{3}, then it may have a
+special interpretation. A value of \code{0} means ``totally
+unimportant'', and a \code{3} means ``ultimately important.'' These
+extreme optimization values enable ``heroic'' compilation strategies
+that are not always desirable and sometimes self-defeating.
+Specifying more than one quality as \code{3} is not desirable, since
+it doesn't tell the compiler which quality is most important.
+
+
+These are the optimization qualities:
+\begin{Lentry}
+
+\item[\code{speed}] \cindex{speed optimization quality}How fast the
+ program should is run. \code{speed 3} enables some optimizations
+ that hurt debuggability.
+
+\item[\code{compilation-speed}] \cindex{compilation-speed optimization
+ quality}How fast the compiler should run. Note that increasing
+ this above \code{safety} weakens type checking.
+
+\item[\code{space}] \cindex{space optimization quality}How much space
+ the compiled code should take up. Inline expansion is mostly
+ inhibited when \code{space} is greater than \code{speed}. A value
+ of \code{0} enables promiscuous inline expansion. Wide use of a
+ \code{0} value is not recommended, as it may waste so much space
+ that run time is slowed. \xlref{inline-expansion} for a discussion
+ of inline expansion.
+
+\item[\code{debug}] \cindex{debug optimization quality}How debuggable
+ the program should be. The quality is treated differently from the
+ other qualities: each value indicates a particular level of debugger
+ information; it is not compared with the other qualities.
+ \xlref{debugger-policy} for more details.
+
+\item[\code{safety}] \cindex{safety optimization quality}How much
+ error checking should be done. If \code{speed}, \code{space} or
+ \code{compilation-speed} is more important than \code{safety}, then
+ type checking is weakened (\pxlref{weakened-type-checks}). If
+ \code{safety} if \code{0}, then no run time error checking is done.
+ In addition to suppressing type checks, \code{0} also suppresses
+ argument count checking, unbound-symbol checking and array bounds
+ checks.
+
+\item[\code{extensions:inhibit-warnings}] \cindex{inhibit-warnings
+ optimization quality}This is a CMU extension that determines how
+ little (or how much) diagnostic output should be printed during
+ compilation. This quality is compared to other qualities to
+ determine whether to print style notes and warnings concerning those
+ qualities. If \code{speed} is greater than \code{inhibit-warnings},
+ then notes about how to improve speed will be printed, etc. The
+ default value is \code{1}, so raising the value for any standard
+ quality above its default enables notes for that quality. If
+ \code{inhibit-warnings} is \code{3}, then all notes and most
+ non-serious warnings are inhibited. This is useful with
+ \code{declare} to suppress warnings about unavoidable problems.
+\end{Lentry}
+
+%%\node The Optimize-Interface Declaration, , The Optimize Declaration, Compiler Policy
+\subsection{The Optimize-Interface Declaration}
+\label{optimize-interface-declaration}
+\cindex{optimize-interface declaration}
+\cpsubindex{declarations}{\code{optimize-interface}}
+
+The \code{extensions:optimize-interface} declaration is identical in
+syntax to the \code{optimize} declaration, but it specifies the policy
+used during compilation of code the compiler automatically generates
+to check the number and type of arguments supplied to a function. It
+is useful to specify this policy separately, since even thoroughly
+debugged functions are vulnerable to being passed the wrong arguments.
+The \code{optimize-interface} declaration can specify that arguments
+should be checked even when the general \code{optimize} policy is
+unsafe.
+
+Note that this argument checking is the checking of user-supplied
+arguments to any functions defined within the scope of the
+declaration, \code{not} the checking of arguments to \llisp{}
+primitives that appear in those definitions.
+
+The idea behind this declaration is that it allows the definition of
+functions that appear fully safe to other callers, but that do no
+internal error checking. Of course, it is possible that arguments may
+be invalid in ways other than having incorrect type. Functions
+compiled unsafely must still protect themselves against things like
+user-supplied array indices that are out of bounds and improper lists.
+See also the \kwd{context-declarations} option to
+\macref{with-compilation-unit}.
+
+%%\f
+%%\node Open Coding and Inline Expansion, , Compiler Policy, The Compiler
+\section{Open Coding and Inline Expansion}
+\label{open-coding}
+\cindex{open-coding}
+\cindex{inline expansion}
+\cindex{static functions}
+
+Since \clisp{} forbids the redefinition of standard functions\footnote{See the
+proposed X3J13 ``lisp-symbol-redefinition'' cleanup.}, the compiler can have
+special knowledge of these standard functions embedded in it. This special
+knowledge is used in various ways (open coding, inline expansion, source
+transformation), but the implications to the user are basically the same:
+\begin{itemize}
+
+\item Attempts to redefine standard functions may be frustrated, since
+ the function may never be called. Although it is technically
+ illegal to redefine standard functions, users sometimes want to
+ implicitly redefine these functions when they are debugging using
+ the \code{trace} macro. Special-casing of standard functions can be
+ inhibited using the \code{notinline} declaration.
+
+\item The compiler can have multiple alternate implementations of
+ standard functions that implement different trade-offs of speed,
+ space and safety. This selection is based on the compiler policy,
+ \pxlref{compiler-policy}.
+\end{itemize}
+
+
+When a function call is \i{open coded}, inline code whose effect is
+equivalent to the function call is substituted for that function call.
+When a function call is \i{closed coded}, it is usually left as is,
+although it might be turned into a call to a different function with
+different arguments. As an example, if \code{nthcdr} were to be open
+coded, then
+\begin{lisp}
+(nthcdr 4 foobar)
+\end{lisp}
+might turn into
+\begin{lisp}
+(cdr (cdr (cdr (cdr foobar))))
+\end{lisp}
+or even
+\begin{lisp}
+(do ((i 0 (1+ i))
+ (list foobar (cdr foobar)))
+ ((= i 4) list))
+\end{lisp}
+
+If \code{nth} is closed coded, then
+\begin{lisp}
+(nth x l)
+\end{lisp}
+might stay the same, or turn into something like:
+\begin{lisp}
+(car (nthcdr x l))
+\end{lisp}
+
+In general, open coding sacrifices space for speed, but some functions (such as
+\code{car}) are so simple that they are always open-coded. Even when not
+open-coded, a call to a standard function may be transformed into a different
+function call (as in the last example) or compiled as \i{static call}. Static
+function call uses a more efficient calling convention that forbids
+redefinition.
+
+\hide{File:/afs/cs.cmu.edu/project/clisp/hackers/ram/docs/cmu-user/efficiency.ms}
+
+
+
+\hide{ -*- Dictionary: cmu-user -*- }
+%%\node Advanced Compiler Use and Efficiency Hints, UNIX Interface, The Compiler, Top
+\chapter{Advanced Compiler Use and Efficiency Hints}
+\begin{center}
+\b{By Robert MacLachlan}
+\end{center}
+\vspace{1 cm}
+\label{advanced-compiler}
+
+\begin{comment}
+* Advanced Compiler Introduction::
+* More About Types in Python::
+* Type Inference::
+* Source Optimization::
+* Tail Recursion::
+* Local Call::
+* Block Compilation::
+* Inline Expansion::
+* Byte Coded Compilation::
+* Object Representation::
+* Numbers::
+* General Efficiency Hints::
+* Efficiency Notes::
+* Profiling::
+\end{comment}
+
+%%\node Advanced Compiler Introduction, More About Types in Python, Advanced Compiler Use and Efficiency Hints, Advanced Compiler Use and Efficiency Hints
+\section{Advanced Compiler Introduction}
+
+In \cmucl, as is any language on any computer, the path to efficient
+code starts with good algorithms and sensible programming techniques,
+but to avoid inefficiency pitfalls, you need to know some of this
+implementation's quirks and features. This chapter is mostly a fairly
+long and detailed overview of what optimizations \python{} does.
+Although there are the usual negative suggestions of inefficient
+features to avoid, the main emphasis is on describing the things that
+programmers can count on being efficient.
+
+The optimizations described here can have the effect of speeding up
+existing programs written in conventional styles, but the potential
+for new programming styles that are clearer and less error-prone is at
+least as significant. For this reason, several sections end with a
+discussion of the implications of these optimizations for programming
+style.
+
+\begin{comment}
+* Types::
+* Optimization::
+* Function Call::
+* Representation of Objects::
+* Writing Efficient Code::
+\end{comment}
+
+%%\node Types, Optimization, Advanced Compiler Introduction, Advanced Compiler Introduction
+\subsection{Types}
+
+Python's support for types is unusual in three major ways:
+\begin{itemize}
+
+\item Precise type checking encourages the specific use of type
+ declarations as a form of run-time consistency checking. This
+ speeds development by localizing type errors and giving more
+ meaningful error messages. \xlref{precise-type-checks}. \python{}
+ produces completely safe code; optimized type checking maintains
+ reasonable efficiency on conventional hardware
+ (\pxlref{type-check-optimization}.)
+
+\item Comprehensive support for the \clisp{} type system makes complex
+ type specifiers useful. Using type specifiers such as \code{or} and
+ \code{member} has both efficiency and robustness advantages.
+ \xlref{advanced-type-stuff}.
+
+\item Type inference eliminates the need for some declarations, and
+ also aids compile-time detection of type errors. Given detailed
+ type declarations, type inference can often eliminate type checks
+ and enable more efficient object representations and code sequences.
+ Checking all types results in fewer type checks. See sections
+ \ref{type-inference} and \ref{non-descriptor}.
+\end{itemize}
+
+
+%%\node Optimization, Function Call, Types, Advanced Compiler Introduction
+\subsection{Optimization}
+
+The main barrier to efficient Lisp programs is not that there is no
+efficient way to code the program in Lisp, but that it is difficult to
+arrive at that efficient coding. Common Lisp is a highly complex
+language, and usually has many semantically equivalent ``reasonable''
+ways to code a given problem. It is desirable to make all of these
+equivalent solutions have comparable efficiency so that programmers
+don't have to waste time discovering the most efficient solution.
+
+Source level optimization increases the number of efficient ways to
+solve a problem. This effect is much larger than the increase in the
+efficiency of the ``best'' solution. Source level optimization
+transforms the original program into a more efficient (but equivalent)
+program. Although the optimizer isn't doing anything the programmer
+couldn't have done, this high-level optimization is important because:
+\begin{itemize}
+
+\item The programmer can code simply and directly, rather than
+ obfuscating code to please the compiler.
+
+\item When presented with a choice of similar coding alternatives, the
+ programmer can chose whichever happens to be most convenient,
+ instead of worrying about which is most efficient.
+\end{itemize}
+
+Source level optimization eliminates the need for macros to optimize
+their expansion, and also increases the effectiveness of inline
+expansion. See sections \ref{source-optimization} and
+\ref{inline-expansion}.
+
+Efficient support for a safer programming style is the biggest
+advantage of source level optimization. Existing tuned programs
+typically won't benefit much from source optimization, since their
+source has already been optimized by hand. However, even tuned
+programs tend to run faster under \python{} because:
+\begin{itemize}
+
+\item Low level optimization and register allocation provides modest
+ speedups in any program.
+
+\item Block compilation and inline expansion can reduce function call
+ overhead, but may require some program restructuring. See sections
+ \ref{inline-expansion}, \ref{local-call} and
+ \ref{block-compilation}.
+
+\item Efficiency notes will point out important type declarations that
+ are often missed even in highly tuned programs.
+ \xlref{efficiency-notes}.
+
+\item Existing programs can be compiled safely without prohibitive
+ speed penalty, although they would be faster and safer with added
+ declarations. \xlref{type-check-optimization}.
+
+\item The context declaration mechanism allows both space and runtime
+ of large systems to be reduced without sacrificing robustness by
+ semi-automatically varying compilation policy without addition any
+ \code{optimize} declarations to the source.
+ \xlref{context-declarations}.
+
+\item Byte compilation can be used to dramatically reduce the size of
+ code that is not speed-critical. \xlref{byte-compile}
+\end{itemize}
+
+
+%%\node Function Call, Representation of Objects, Optimization, Advanced Compiler Introduction
+\subsection{Function Call}
+
+The sort of symbolic programs generally written in \llisp{} often
+favor recursion over iteration, or have inner loops so complex that
+they involve multiple function calls. Such programs spend a larger
+fraction of their time doing function calls than is the norm in other
+languages; for this reason \llisp{} implementations strive to make the
+general (or full) function call as inexpensive as possible. \python{}
+goes beyond this by providing two good alternatives to full call:
+\begin{itemize}
+
+\item Local call resolves function references at compile time,
+ allowing better calling sequences and optimization across function
+ calls. \xlref{local-call}.
+
+\item Inline expansion totally eliminates call overhead and allows
+ many context dependent optimizations. This provides a safe and
+ efficient implementation of operations with function semantics,
+ eliminating the need for error-prone macro definitions or manual
+ case analysis. Although most \clisp{} implementations support
+ inline expansion, it becomes a more powerful tool with \python{}'s
+ source level optimization. See sections \ref{source-optimization}
+ and \ref{inline-expansion}.
+\end{itemize}
+
+
+Generally, \python{} provides simple implementations for simple uses
+of function call, rather than having only a single calling convention.
+These features allow a more natural programming style:
+\begin{itemize}
+
+\item Proper tail recursion. \xlref{tail-recursion}
+
+\item Relatively efficient closures.
+
+\item A \code{funcall} that is as efficient as normal named call.
+
+\item Calls to local functions such as from \code{labels} are
+ optimized:
+\begin{itemize}
+
+\item Control transfer is a direct jump.
+
+\item The closure environment is passed in registers rather than heap
+ allocated.
+
+\item Keyword arguments and multiple values are implemented more
+ efficiently.
+\end{itemize}
+
+\xlref{local-call}.
+\end{itemize}
+
+%%\node Representation of Objects, Writing Efficient Code, Function Call, Advanced Compiler Introduction
+\subsection{Representation of Objects}
+
+Sometimes traditional \llisp{} implementation techniques compare so
+poorly to the techniques used in other languages that \llisp{} can
+become an impractical language choice. Terrible inefficiencies appear
+in number-crunching programs, since \llisp{} numeric operations often
+involve number-consing and generic arithmetic. \python{} supports
+efficient natural representations for numbers (and some other types),
+and allows these efficient representations to be used in more
+contexts. \python{} also provides good efficiency notes that warn
+when a crucial declaration is missing.
+
+See section \ref{non-descriptor} for more about object representations and
+numeric types. Also \pxlref{efficiency-notes} about efficiency notes.
+
+%%\node Writing Efficient Code, , Representation of Objects, Advanced Compiler Introduction
+\subsection{Writing Efficient Code}
+\label{efficiency-overview}
+
+Writing efficient code that works is a complex and prolonged process.
+It is important not to get so involved in the pursuit of efficiency
+that you lose sight of what the original problem demands. Remember
+that:
+\begin{itemize}
+
+\item The program should be correct\dash{}it doesn't matter how
+ quickly you get the wrong answer.
+
+\item Both the programmer and the user will make errors, so the
+ program must be robust\dash{}it must detect errors in a way that
+ allows easy correction.
+
+\item A small portion of the program will consume most of the
+ resources, with the bulk of the code being virtually irrelevant to
+ efficiency considerations. Even experienced programmers familiar
+ with the problem area cannot reliably predict where these ``hot
+ spots'' will be.
+\end{itemize}
+
+
+
+The best way to get efficient code that is still worth using, is to separate
+coding from tuning. During coding, you should:
+\begin{itemize}
+
+\item Use a coding style that aids correctness and robustness without
+ being incompatible with efficiency.
+
+\item Choose appropriate data structures that allow efficient
+ algorithms and object representations
+ (\pxlref{object-representation}). Try to make interfaces abstract
+ enough so that you can change to a different representation if
+ profiling reveals a need.
+
+\item Whenever you make an assumption about a function argument or
+ global data structure, add consistency assertions, either with type
+ declarations or explicit uses of \code{assert}, \code{ecase}, etc.
+\end{itemize}
+
+During tuning, you should:
+\begin{itemize}
+
+\item Identify the hot spots in the program through profiling (section
+ \ref{profiling}.)
+
+\item Identify inefficient constructs in the hot spot with efficiency
+ notes, more profiling, or manual inspection of the source. See
+ sections \ref{general-efficiency} and \ref{efficiency-notes}.
+
+\item Add declarations and consider the application of optimizations.
+ See sections \ref{local-call}, \ref{inline-expansion} and
+ \ref{non-descriptor}.
+
+\item If all else fails, consider algorithm or data structure changes.
+ If you did a good job coding, changes will be easy to introduce.
+\end{itemize}
+
+
+
+%%\f
+%%\node More About Types in Python, Type Inference, Advanced Compiler Introduction, Advanced Compiler Use and Efficiency Hints
+\section{More About Types in Python}
+\label{advanced-type-stuff}
+\cpsubindex{types}{in python}
+
+This section goes into more detail describing what types and declarations are
+recognized by \python. The area where \python{} differs most radically from
+previous \llisp{} compilers is in its support for types:
+\begin{itemize}
+
+\item Precise type checking helps to find bugs at run time.
+
+\item Compile-time type checking helps to find bugs at compile time.
+
+\item Type inference minimizes the need for generic operations, and
+ also increases the efficiency of run time type checking and the
+ effectiveness of compile time type checking.
+
+\item Support for detailed types provides a wealth of opportunity for
+ operation-specific type inference and optimization.
+\end{itemize}
+
+
+
+\begin{comment}
+* More Types Meaningful::
+* Canonicalization::
+* Member Types::
+* Union Types::
+* The Empty Type::
+* Function Types::
+* The Values Declaration::
+* Structure Types::
+* The Freeze-Type Declaration::
+* Type Restrictions::
+* Type Style Recommendations::
+\end{comment}
+
+%%\node More Types Meaningful, Canonicalization, More About Types in Python, More About Types in Python
+\subsection{More Types Meaningful}
+
+\clisp{} has a very powerful type system, but conventional \llisp{}
+implementations typically only recognize the small set of types
+special in that implementation. In these systems, there is an
+unfortunate paradox: a declaration for a relatively general type like
+\code{fixnum} will be recognized by the compiler, but a highly
+specific declaration such as \code{\w{(integer 3 17)}} is totally
+ignored.
+
+This is obviously a problem, since the user has to know how to specify
+the type of an object in the way the compiler wants it. A very
+minimal (but rarely satisfied) criterion for type system support is
+that it be no worse to make a specific declaration than to make a
+general one. \python{} goes beyond this by exploiting a number of
+advantages obtained from detailed type information.
+
+Using more restrictive types in declarations allows the compiler to do
+better type inference and more compile-time type checking. Also, when
+type declarations are considered to be consistency assertions that
+should be verified (conditional on policy), then complex types are
+useful for making more detailed assertions.
+
+Python ``understands'' the list-style \code{or}, \code{member},
+\code{function}, array and number type specifiers. Understanding
+means that:
+\begin{itemize}
+
+\item If the type contains more information than is used in a
+ particular context, then the extra information is simply ignored,
+ rather than derailing type inference.
+
+\item In many contexts, the extra information from these type
+ specifier is used to good effect. In particular, type checking in
+ \code{Python} is \var{precise}, so these complex types can be used
+ in declarations to make interesting assertions about functions and
+ data structures (\pxlref{precise-type-checks}.) More specific
+ declarations also aid type inference and reduce the cost for type
+ checking.
+\end{itemize}
+
+For related information, \pxlref{numeric-types} for numeric types, and
+section \ref{array-types} for array types.
+
+
+%%\node Canonicalization, Member Types, More Types Meaningful, More About Types in Python
+\subsection{Canonicalization}
+\cpsubindex{types}{equivalence}
+\cindex{canonicalization of types}
+\cindex{equivalence of types}
+
+When given a type specifier, \python{} will often rewrite it into a
+different (but equivalent) type. This is the mechanism that \python{}
+uses for detecting type equivalence. For example, in \python{}'s
+canonical representation, these types are equivalent:
+\begin{example}
+(or list (member :end)) \myequiv (or cons (member nil :end))
+\end{example}
+This has two implications for the user:
+\begin{itemize}
+
+\item The standard symbol type specifiers for \code{atom},
+ \code{null}, \code{fixnum}, etc., are in no way magical. The
+ \tindexed{null} type is actually defined to be \code{\w{(member
+ nil)}}, \tindexed{list} is \code{\w{(or cons null)}}, and
+ \tindexed{fixnum} is \code{\w{(signed-byte 30)}}.
+
+\item When the compiler prints out a type, it may not look like the
+ type specifier that originally appeared in the program. This is
+ generally not a problem, but it must be taken into consideration
+ when reading compiler error messages.
+\end{itemize}
+
+
+%%\node Member Types, Union Types, Canonicalization, More About Types in Python
+\subsection{Member Types}
+\cindex{member types}
+
+The \tindexed{member} type specifier can be used to represent
+``symbolic'' values, analogous to the enumerated types of Pascal. For
+example, the second value of \code{find-symbol} has this type:
+\begin{lisp}
+(member :internal :external :inherited nil)
+\end{lisp}
+Member types are very useful for expressing consistency constraints on data
+structures, for example:
+\begin{lisp}
+(defstruct ice-cream
+ (flavor :vanilla :type (member :vanilla :chocolate :strawberry)))
+\end{lisp}
+Member types are also useful in type inference, as the number of members can
+sometimes be pared down to one, in which case the value is a known constant.
+
+%%\node Union Types, The Empty Type, Member Types, More About Types in Python
+\subsection{Union Types}
+\cindex{union (\code{or}) types}
+\cindex{or (union) types}
+
+The \tindexed{or} (union) type specifier is understood, and is
+meaningfully applied in many contexts. The use of \code{or} allows
+assertions to be made about types in dynamically typed programs. For
+example:
+\begin{lisp}
+(defstruct box
+ (next nil :type (or box null))
+ (top :removed :type (or box-top (member :removed))))
+\end{lisp}
+The type assertion on the \code{top} slot ensures that an error will be signaled
+when there is an attempt to store an illegal value (such as \kwd{rmoved}.)
+Although somewhat weak, these union type assertions provide a useful input into
+type inference, allowing the cost of type checking to be reduced. For example,
+this loop is safely compiled with no type checks:
+\begin{lisp}
+(defun find-box-with-top (box)
+ (declare (type (or box null) box))
+ (do ((current box (box-next current)))
+ ((null current))
+ (unless (eq (box-top current) :removed)
+ (return current))))
+\end{lisp}
+
+Union types are also useful in type inference for representing types that are
+partially constrained. For example, the result of this expression:
+\begin{lisp}
+(if foo
+ (logior x y)
+ (list x y))
+\end{lisp}
+can be expressed as \code{\w{(or integer cons)}}.
+
+%%\node The Empty Type, Function Types, Union Types, More About Types in Python
+\subsection{The Empty Type}
+\label{empty-type}
+\cindex{NIL type}
+\cpsubindex{empty type}{the}
+\cpsubindex{errors}{result type of}
+
+The type \false{} is also called the empty type, since no object is of
+type \false{}. The union of no types, \code{(or)}, is also empty.
+\python{}'s interpretation of an expression whose type is \false{} is
+that the expression never yields any value, but rather fails to
+terminate, or is thrown out of. For example, the type of a call to
+\code{error} or a use of \code{return} is \false{}. When the type of
+an expression is empty, compile-time type warnings about its value are
+suppressed; presumably somebody else is signaling an error. If a
+function is declared to have return type \false{}, but does in fact
+return, then (in safe compilation policies) a ``\code{NIL Function
+ returned}'' error will be signaled. See also the function
+\funref{required-argument}.
+
+%%\node Function Types, The Values Declaration, The Empty Type, More About Types in Python
+\subsection{Function Types}
+\label{function-types}
+\cpsubindex{function}{types}
+\cpsubindex{types}{function}
+
+\findexed{function} types are understood in the restrictive sense, specifying:
+\begin{itemize}
+
+\item The argument syntax that the function must be called with. This
+ is information about what argument counts are acceptable, and which
+ keyword arguments are recognized. In \python, warnings about
+ argument syntax are a consequence of function type checking.
+
+\item The types of the argument values that the caller must pass. If
+ the compiler can prove that some argument to a call is of a type
+ disallowed by the called function's type, then it will give a
+ compile-time type warning. In addition to being used for
+ compile-time type checking, these type assertions are also used as
+ output type assertions in code generation. For example, if
+ \code{foo} is declared to have a \code{fixnum} argument, then the
+ \code{1+} in \w{\code{(foo (1+ x))}} is compiled with knowledge that
+ the result must be a fixnum.
+
+\item The types the values that will be bound to argument variables in
+ the function's definition. Declaring a function's type with
+ \code{ftype} implicitly declares the types of the arguments in the
+ definition. \python{} checks for consistency between the definition
+ and the \code{ftype} declaration. Because of precise type checking,
+ an error will be signaled when a function is called with an
+ argument of the wrong type.
+
+\item The type of return value(s) that the caller can expect. This
+ information is a useful input to type inference. For example, if a
+ function is declared to return a \code{fixnum}, then when a call to
+ that function appears in an expression, the expression will be
+ compiled with knowledge that the call will return a \code{fixnum}.
+
+\item The type of return value(s) that the definition must return.
+ The result type in an \code{ftype} declaration is treated like an
+ implicit \code{the} wrapped around the body of the definition. If
+ the definition returns a value of the wrong type, an error will be
+ signaled. If the compiler can prove that the function returns the
+ wrong type, then it will give a compile-time warning.
+\end{itemize}
+
+This is consistent with the new interpretation of function types and
+the \code{ftype} declaration in the proposed X3J13
+``function-type-argument-type-semantics'' cleanup. Note also, that if
+you don't explicitly declare the type of a function using a global
+\code{ftype} declaration, then \python{} will compute a function type
+from the definition, providing a degree of inter-routine type
+inference, \pxlref{function-type-inference}.
+
+%%\node The Values Declaration, Structure Types, Function Types, More About Types in Python
+\subsection{The Values Declaration}
+\cindex{values declaration}
+
+\cmucl{} supports the \code{values} declaration as an extension to
+\clisp. The syntax is {\code{(values \var{type1}
+ \var{type2}$\ldots$\var{typen})}}. This declaration is
+semantically equivalent to a \code{the} form wrapped around the body
+of the special form in which the \code{values} declaration appears.
+The advantage of \code{values} over \findexed{the} is purely
+syntactic\dash{}it doesn't introduce more indentation. For example:
+\begin{example}
+(defun foo (x)
+ (declare (values single-float))
+ (ecase x
+ (:this ...)
+ (:that ...)
+ (:the-other ...)))
+\end{example}
+is equivalent to:
+\begin{example}
+(defun foo (x)
+ (the single-float
+ (ecase x
+ (:this ...)
+ (:that ...)
+ (:the-other ...))))
+\end{example}
+and
+\begin{example}
+(defun floor (number &optional (divisor 1))
+ (declare (values integer real))
+ ...)
+\end{example}
+is equivalent to:
+\begin{example}
+(defun floor (number &optional (divisor 1))
+ (the (values integer real)
+ ...))
+\end{example}
+In addition to being recognized by \code{lambda} (and hence by
+\code{defun}), the \code{values} declaration is recognized by all the
+other special forms with bodies and declarations: \code{let},
+\code{let*}, \code{labels} and \code{flet}. Macros with declarations
+usually splice the declarations into one of the above forms, so they
+will accept this declaration too, but the exact effect of a
+\code{values} declaration will depend on the macro.
+
+If you declare the types of all arguments to a function, and also
+declare the return value types with \code{values}, you have described
+the type of the function. \python{} will use this argument and result
+type information to derive a function type that will then be applied
+to calls of the function (\pxlref{function-types}.) This provides a
+way to declare the types of functions that is much less syntactically
+awkward than using the \code{ftype} declaration with a \code{function}
+type specifier.
+
+Although the \code{values} declaration is non-standard, it is
+relatively harmless to use it in otherwise portable code, since any
+warning in non-CMU implementations can be suppressed with the standard
+\code{declaration} proclamation.
+
+%%\node Structure Types, The Freeze-Type Declaration, The Values Declaration, More About Types in Python
+\subsection{Structure Types}
+\label{structure-types}
+\cindex{structure types}
+\cindex{defstruct types}
+\cpsubindex{types}{structure}
+
+Because of precise type checking, structure types are much better supported by
+Python than by conventional compilers:
+\begin{itemize}
+
+\item The structure argument to structure accessors is precisely
+ checked\dash{}if you call \code{foo-a} on a \code{bar}, an error
+ will be signaled.
+
+\item The types of slot values are precisely checked\dash{}if you pass
+ the wrong type argument to a constructor or a slot setter, then an
+ error will be signaled.
+\end{itemize}
+This error checking is tremendously useful for detecting bugs in
+programs that manipulate complex data structures.
+
+An additional advantage of checking structure types and enforcing slot
+types is that the compiler can safely believe slot type declarations.
+\python{} effectively moves the type checking from the slot access to
+the slot setter or constructor call. This is more efficient since
+caller of the setter or constructor often knows the type of the value,
+entirely eliminating the need to check the value's type. Consider
+this example:
+\begin{lisp}
+(defstruct coordinate
+ (x nil :type single-float)
+ (y nil :type single-float))
+
+(defun make-it ()
+ (make-coordinate :x 1.0 :y 1.0))
+
+(defun use-it (it)
+ (declare (type coordinate it))
+ (sqrt (expt (coordinate-x it) 2) (expt (coordinate-y it) 2)))
+\end{lisp}
+\code{make-it} and \code{use-it} are compiled with no checking on the
+types of the float slots, yet \code{use-it} can use
+\code{single-float} arithmetic with perfect safety. Note that
+\code{make-coordinate} must still check the values of \code{x} and
+\code{y} unless the call is block compiled or inline expanded
+(\pxlref{local-call}.) But even without this advantage, it is almost
+always more efficient to check slot values on structure
+initialization, since slots are usually written once and read many
+times.
+
+%%\node The Freeze-Type Declaration, Type Restrictions, Structure Types, More About Types in Python
+\subsection{The Freeze-Type Declaration}
+\cindex{freeze-type declaration}
+\label{freeze-type}
+
+The \code{extensions:freeze-type} declaration is a CMU extension that
+enables more efficient compilation of user-defined types by asserting
+that the definition is not going to change. This declaration may only
+be used globally (with \code{declaim} or \code{proclaim}). Currently
+\code{freeze-type} only affects structure type testing done by
+\code{typep}, \code{typecase}, etc. Here is an example:
+\begin{lisp}
+(declaim (freeze-type foo bar))
+\end{lisp}
+This asserts that the types \code{foo} and \code{bar} and their
+subtypes are not going to change. This allows more efficient type
+testing, since the compiler can open-code a test for all possible
+subtypes, rather than having to examine the type hierarchy at
+run-time.
+
+%%\node Type Restrictions, Type Style Recommendations, The Freeze-Type Declaration, More About Types in Python
+\subsection{Type Restrictions}
+\cpsubindex{types}{restrictions on}
+
+Avoid use of the \code{and}, \code{not} and \code{satisfies} types in
+declarations, since type inference has problems with them. When these
+types do appear in a declaration, they are still checked precisely,
+but the type information is of limited use to the compiler.
+\code{and} types are effective as long as the intersection can be
+canonicalized to a type that doesn't use \code{and}. For example:
+\begin{example}
+(and fixnum unsigned-byte)
+\end{example}
+is fine, since it is the same as:
+\begin{example}
+(integer 0 \var{most-positive-fixnum})
+\end{example}
+but this type:
+\begin{example}
+(and symbol (not (member :end)))
+\end{example}
+will not be fully understood by type interference since the \code{and}
+can't be removed by canonicalization.
+
+Using any of these type specifiers in a type test with \code{typep} or
+\code{typecase} is fine, since as tests, these types can be translated
+into the \code{and} macro, the \code{not} function or a call to the
+satisfies predicate.
+
+%%\node Type Style Recommendations, , Type Restrictions, More About Types in Python
+\subsection{Type Style Recommendations}
+\cindex{style recommendations}
+
+Python provides good support for some currently unconventional ways of
+using the \clisp{} type system. With \python, it is desirable to make
+declarations as precise as possible, but type inference also makes
+some declarations unnecessary. Here are some general guidelines for
+maximum robustness and efficiency:
+\begin{itemize}
+
+\item Declare the types of all function arguments and structure slots
+ as precisely as possible (while avoiding \code{not}, \code{and} and
+ \code{satisfies}). Put these declarations in during initial coding
+ so that type assertions can find bugs for you during debugging.
+
+\item Use the \tindexed{member} type specifier where there are a small
+ number of possible symbol values, for example: \w{\code{(member :red
+ :blue :green)}}.
+
+\item Use the \tindexed{or} type specifier in situations where the
+ type is not certain, but there are only a few possibilities, for
+ example: \w{\code{(or list vector)}}.
+
+\item Declare integer types with the tightest bounds that you can,
+ such as \code{\w{(integer 3 7)}}.
+
+\item Define \findexed{deftype} or \findexed{defstruct} types before
+ they are used. Definition after use is legal (producing no
+ ``undefined type'' warnings), but type tests and structure
+ operations will be compiled much less efficiently.
+
+\item Use the \code{extensions:freeze-type} declaration to speed up
+ type testing for structure types which won't have new subtypes added
+ later. \xlref{freeze-type}
+
+\item In addition to declaring the array element type and simpleness,
+ also declare the dimensions if they are fixed, for example:
+ \begin{example}
+ (simple-array single-float (1024 1024))
+ \end{example}
+ This bounds information allows array indexing for multi-dimensional
+ arrays to be compiled much more efficiently, and may also allow
+ array bounds checking to be done at compile time.
+ \xlref{array-types}.
+
+\item Avoid use of the \findexed{the} declaration within expressions.
+ Not only does it clutter the code, but it is also almost worthless
+ under safe policies. If the need for an output type assertion is
+ revealed by efficiency notes during tuning, then you can consider
+ \code{the}, but it is preferable to constrain the argument types
+ more, allowing the compiler to prove the desired result type.
+
+\item Don't bother declaring the type of \findexed{let} or other
+ non-argument variables unless the type is non-obvious. If you
+ declare function return types and structure slot types, then the
+ type of a variable is often obvious both to the programmer and to
+ the compiler. An important case where the type isn't obvious, and a
+ declaration is appropriate, is when the value for a variable is
+ pulled out of untyped structure (e.g., the result of \code{car}), or
+ comes from some weakly typed function, such as \code{read}.
+
+\item Declarations are sometimes necessary for integer loop variables,
+ since the compiler can't always prove that the value is of a good
+ integer type. These declarations are best added during tuning, when
+ an efficiency note indicates the need.
+\end{itemize}
+
+
+%%\f
+%%\node Type Inference, Source Optimization, More About Types in Python, Advanced Compiler Use and Efficiency Hints
+\section{Type Inference}
+\label{type-inference}
+\cindex{type inference}
+\cindex{inference of types}
+\cindex{derivation of types}
+
+Type inference is the process by which the compiler tries to figure
+out the types of expressions and variables, given an inevitable lack
+of complete type information. Although \python{} does much more type
+inference than most \llisp{} compilers, remember that the more precise
+and comprehensive type declarations are, the more type inference will
+be able to do.
+
+\begin{comment}
+* Variable Type Inference::
+* Local Function Type Inference::
+* Global Function Type Inference::
+* Operation Specific Type Inference::
+* Dynamic Type Inference::
+* Type Check Optimization::
+\end{comment}
+
+%%\node Variable Type Inference, Local Function Type Inference, Type Inference, Type Inference
+\subsection{Variable Type Inference}
+\label{variable-type-inference}
+
+The type of a variable is the union of the types of all the
+definitions. In the degenerate case of a let, the type of the
+variable is the type of the initial value. This inferred type is
+intersected with any declared type, and is then propagated to all the
+variable's references. The types of \findexed{multiple-value-bind}
+variables are similarly inferred from the types of the individual
+values of the values form.
+
+If multiple type declarations apply to a single variable, then all the
+declarations must be correct; it is as though all the types were intersected
+producing a single \tindexed{and} type specifier. In this example:
+\begin{example}
+(defmacro my-dotimes ((var count) &body body)
+ `(do ((,var 0 (1+ ,var)))
+ ((>= ,var ,count))
+ (declare (type (integer 0 *) ,var))
+ ,@body))
+
+(my-dotimes (i ...)
+ (declare (fixnum i))
+ ...)
+\end{example}
+the two declarations for \code{i} are intersected, so \code{i} is
+known to be a non-negative fixnum.
+
+In practice, this type inference is limited to lets and local
+functions, since the compiler can't analyze all the calls to a global
+function. But type inference works well enough on local variables so
+that it is often unnecessary to declare the type of local variables.
+This is especially likely when function result types and structure
+slot types are declared. The main areas where type inference breaks
+down are:
+\begin{itemize}
+
+\item When the initial value of a variable is a untyped expression,
+ such as \code{\w{(car x)}}, and
+
+\item When the type of one of the variable's definitions is a function
+ of the variable's current value, as in: \code{(setq x (1+ x))}
+\end{itemize}
+
+
+%%\node Local Function Type Inference, Global Function Type Inference, Variable Type Inference, Type Inference
+\subsection{Local Function Type Inference}
+\cpsubindex{local call}{type inference}
+
+The types of arguments to local functions are inferred in the same was
+as any other local variable; the type is the union of the argument
+types across all the calls to the function, intersected with the
+declared type. If there are any assignments to the argument
+variables, the type of the assigned value is unioned in as well.
+
+The result type of a local function is computed in a special way that
+takes tail recursion (\pxlref{tail-recursion}) into consideration.
+The result type is the union of all possible return values that aren't
+tail-recursive calls. For example, \python{} will infer that the
+result type of this function is \code{integer}:
+\begin{lisp}
+(defun ! (n res)
+ (declare (integer n res))
+ (if (zerop n)
+ res
+ (! (1- n) (* n res))))
+\end{lisp}
+Although this is a rather obvious result, it becomes somewhat less
+trivial in the presence of mutual tail recursion of multiple
+functions. Local function result type inference interacts with the
+mechanisms for ensuring proper tail recursion mentioned in section
+\ref{local-call-return}.
+
+%%\node Global Function Type Inference, Operation Specific Type Inference, Local Function Type Inference, Type Inference
+\subsection{Global Function Type Inference}
+\label{function-type-inference}
+\cpsubindex{function}{type inference}
+
+As described in section \ref{function-types}, a global function type
+(\tindexed{ftype}) declaration places implicit type assertions on the
+call arguments, and also guarantees the type of the return value. So
+wherever a call to a declared function appears, there is no doubt as
+to the types of the arguments and return value. Furthermore,
+\python{} will infer a function type from the function's definition if
+there is no \code{ftype} declaration. Any type declarations on the
+argument variables are used as the argument types in the derived
+function type, and the compiler's best guess for the result type of
+the function is used as the result type in the derived function type.
+
+This method of deriving function types from the definition implicitly assumes
+that functions won't be redefined at run-time. Consider this example:
+\begin{lisp}
+(defun foo-p (x)
+ (let ((res (and (consp x) (eq (car x) 'foo))))
+ (format t "It is ~:[not ~;~]foo." res)))
+
+(defun frob (it)
+ (if (foo-p it)
+ (setf (cadr it) 'yow!)
+ (1+ it)))
+\end{lisp}
+
+Presumably, the programmer really meant to return \code{res} from
+\code{foo-p}, but he seems to have forgotten. When he tries to call
+do \code{\w{(frob (list 'foo nil))}}, \code{frob} will flame out when
+it tries to add to a \code{cons}. Realizing his error, he fixes
+\code{foo-p} and recompiles it. But when he retries his test case, he
+is baffled because the error is still there. What happened in this
+example is that \python{} proved that the result of \code{foo-p} is
+\code{null}, and then proceeded to optimize away the \code{setf} in
+\code{frob}.
+
+Fortunately, in this example, the error is detected at compile time
+due to notes about unreachable code (\pxlref{dead-code-notes}.)
+Still, some users may not want to worry about this sort of problem
+during incremental development, so there is a variable to control
+deriving function types.
+
+\begin{defvar}{extensions:}{derive-function-types}
+
+ If true (the default), argument and result type information derived
+ from compilation of \code{defun}s is used when compiling calls to
+ that function. If false, only information from \code{ftype}
+ proclamations will be used.
+\end{defvar}
+
+%%\node Operation Specific Type Inference, Dynamic Type Inference, Global Function Type Inference, Type Inference
+\subsection{Operation Specific Type Inference}
+\label{operation-type-inference}
+\cindex{operation specific type inference}
+\cindex{arithmetic type inference}
+\cpsubindex{numeric}{type inference}
+
+Many of the standard \clisp{} functions have special type inference
+procedures that determine the result type as a function of the
+argument types. For example, the result type of \code{aref} is the
+array element type. Here are some other examples of type inferences:
+\begin{lisp}
+(logand x #xFF) \result{} (unsigned-byte 8)
+
+(+ (the (integer 0 12) x) (the (integer 0 1) y)) \result{} (integer 0 13)
+
+(ash (the (unsigned-byte 16) x) -8) \result{} (unsigned-byte 8)
+\end{lisp}
+
+%%\node Dynamic Type Inference, Type Check Optimization, Operation Specific Type Inference, Type Inference
+\subsection{Dynamic Type Inference}
+\label{constraint-propagation}
+\cindex{dynamic type inference}
+\cindex{conditional type inference}
+\cpsubindex{type inference}{dynamic}
+
+Python uses flow analysis to infer types in dynamically typed
+programs. For example:
+\begin{example}
+(ecase x
+ (list (length x))
+ ...)
+\end{example}
+Here, the compiler knows the argument to \code{length} is a list,
+because the call to \code{length} is only done when \code{x} is a
+list. The most significant efficiency effect of inference from
+assertions is usually in type check optimization.
+
+
+Dynamic type inference has two inputs: explicit conditionals and
+implicit or explicit type assertions. Flow analysis propagates these
+constraints on variable type to any code that can be executed only
+after passing though the constraint. Explicit type constraints come
+from \findexed{if}s where the test is either a lexical variable or a
+function of lexical variables and constants, where the function is
+either a type predicate, a numeric comparison or \code{eq}.
+
+If there is an \code{eq} (or \code{eql}) test, then the compiler will
+actually substitute one argument for the other in the true branch.
+For example:
+\begin{lisp}
+(when (eq x :yow!) (return x))
+\end{lisp}
+becomes:
+\begin{lisp}
+(when (eq x :yow!) (return :yow!))
+\end{lisp}
+This substitution is done when one argument is a constant, or one
+argument has better type information than the other. This
+transformation reveals opportunities for constant folding or
+type-specific optimizations. If the test is against a constant, then
+the compiler can prove that the variable is not that constant value in
+the false branch, or \w{\code{(not (member :yow!))}} in the example
+above. This can eliminate redundant tests, for example:
+\begin{example}
+(if (eq x nil)
+ ...
+ (if x a b))
+\end{example}
+is transformed to this:
+\begin{example}
+(if (eq x nil)
+ ...
+ a)
+\end{example}
+Variables appearing as \code{if} tests are interpreted as
+\code{\w{(not (eq \var{var} nil))}} tests. The compiler also converts
+\code{=} into \code{eql} where possible. It is difficult to do
+inference directly on \code{=} since it does implicit coercions.
+
+When there is an explicit \code{$<$} or \code{$>$} test on
+\begin{changebar}
+ numeric
+\end{changebar}
+variables, the compiler makes inferences about the ranges the
+variables can assume in the true and false branches. This is mainly
+useful when it proves that the values are small enough in magnitude to
+allow open-coding of arithmetic operations. For example, in many uses
+of \code{dotimes} with a \code{fixnum} repeat count, the compiler
+proves that fixnum arithmetic can be used.
+
+Implicit type assertions are quite common, especially if you declare
+function argument types. Dynamic inference from implicit type
+assertions sometimes helps to disambiguate programs to a useful
+degree, but is most noticeable when it detects a dynamic type error.
+For example:
+\begin{lisp}
+(defun foo (x)
+ (+ (car x) x))
+\end{lisp}
+results in this warning:
+\begin{example}
+In: DEFUN FOO
+ (+ (CAR X) X)
+==>
+ X
+Warning: Result is a LIST, not a NUMBER.
+\end{example}
+
+Note that \llisp{}'s dynamic type checking semantics make dynamic type
+inference useful even in programs that aren't really dynamically
+typed, for example:
+\begin{lisp}
+(+ (car x) (length x))
+\end{lisp}
+Here, \code{x} presumably always holds a list, but in the absence of a
+declaration the compiler cannot assume \code{x} is a list simply
+because list-specific operations are sometimes done on it. The
+compiler must consider the program to be dynamically typed until it
+proves otherwise. Dynamic type inference proves that the argument to
+\code{length} is always a list because the call to \code{length} is
+only done after the list-specific \code{car} operation.
+
+
+%%\node Type Check Optimization, , Dynamic Type Inference, Type Inference
+\subsection{Type Check Optimization}
+\label{type-check-optimization}
+\cpsubindex{type checking}{optimization}
+\cpsubindex{optimization}{type check}
+
+Python backs up its support for precise type checking by minimizing
+the cost of run-time type checking. This is done both through type
+inference and though optimizations of type checking itself.
+
+Type inference often allows the compiler to prove that a value is of
+the correct type, and thus no type check is necessary. For example:
+\begin{lisp}
+(defstruct foo a b c)
+(defstruct link
+ (foo (required-argument) :type foo)
+ (next nil :type (or link null)))
+
+(foo-a (link-foo x))
+\end{lisp}
+Here, there is no need to check that the result of \code{link-foo} is
+a \code{foo}, since it always is. Even when some type checks are
+necessary, type inference can often reduce the number:
+\begin{example}
+(defun test (x)
+ (let ((a (foo-a x))
+ (b (foo-b x))
+ (c (foo-c x)))
+ ...))
+\end{example}
+In this example, only one \w{\code{(foo-p x)}} check is needed. This
+applies to a lesser degree in list operations, such as:
+\begin{lisp}
+(if (eql (car x) 3) (cdr x) y)
+\end{lisp}
+Here, we only have to check that \code{x} is a list once.
+
+Since \python{} recognizes explicit type tests, code that explicitly
+protects itself against type errors has little introduced overhead due
+to implicit type checking. For example, this loop compiles with no
+implicit checks checks for \code{car} and \code{cdr}:
+\begin{lisp}
+(defun memq (e l)
+ (do ((current l (cdr current)))
+ ((atom current) nil)
+ (when (eq (car current) e) (return current))))
+\end{lisp}
+
+\cindex{complemented type checks}
+Python reduces the cost of checks that must be done through an
+optimization called \var{complementing}. A complemented check for
+\var{type} is simply a check that the value is not of the type
+\w{\code{(not \var{type})}}. This is only interesting when something
+is known about the actual type, in which case we can test for the
+complement of \w{\code{(and \var{known-type} (not \var{type}))}}, or
+the difference between the known type and the assertion. An example:
+\begin{lisp}
+(link-foo (link-next x))
+\end{lisp}
+Here, we change the type check for \code{link-foo} from a test for
+\code{foo} to a test for:
+\begin{lisp}
+(not (and (or foo null) (not foo)))
+\end{lisp}
+or more simply \w{\code{(not null)}}. This is probably the most
+important use of complementing, since the situation is fairly common,
+and a \code{null} test is much cheaper than a structure type test.
+
+Here is a more complicated example that illustrates the combination of
+complementing with dynamic type inference:
+\begin{lisp}
+(defun find-a (a x)
+ (declare (type (or link null) x))
+ (do ((current x (link-next current)))
+ ((null current) nil)
+ (let ((foo (link-foo current)))
+ (when (eq (foo-a foo) a) (return foo)))))
+\end{lisp}
+This loop can be compiled with no type checks. The \code{link} test
+for \code{link-foo} and \code{link-next} is complemented to
+\w{\code{(not null)}}, and then deleted because of the explicit
+\code{null} test. As before, no check is necessary for \code{foo-a},
+since the \code{link-foo} is always a \code{foo}. This sort of
+situation shows how precise type checking combined with precise
+declarations can actually result in reduced type checking.
+
+%%\f
+%%\node Source Optimization, Tail Recursion, Type Inference, Advanced Compiler Use and Efficiency Hints
+\section{Source Optimization}
+\label{source-optimization}
+\cindex{optimization}
+
+This section describes source-level transformations that \python{} does on
+programs in an attempt to make them more efficient. Although source-level
+optimizations can make existing programs more efficient, the biggest advantage
+of this sort of optimization is that it makes it easier to write efficient
+programs. If a clean, straightforward implementation is can be transformed
+into an efficient one, then there is no need for tricky and dangerous hand
+optimization.
+
+\begin{comment}
+* Let Optimization::
+* Constant Folding::
+* Unused Expression Elimination::
+* Control Optimization::
+* Unreachable Code Deletion::
+* Multiple Values Optimization::
+* Source to Source Transformation::
+* Style Recommendations::
+\end{comment}
+
+%%\node Let Optimization, Constant Folding, Source Optimization, Source Optimization
+\subsection{Let Optimization}
+\label{let-optimization}
+
+\cindex{let optimization} \cpsubindex{optimization}{let}
+
+The primary optimization of let variables is to delete them when they
+are unnecessary. Whenever the value of a let variable is a constant,
+a constant variable or a constant (local or non-notinline) function,
+the variable is deleted, and references to the variable are replaced
+with references to the constant expression. This is useful primarily
+in the expansion of macros or inline functions, where argument values
+are often constant in any given call, but are in general non-constant
+expressions that must be bound to preserve order of evaluation. Let
+variable optimization eliminates the need for macros to carefully
+avoid spurious bindings, and also makes inline functions just as
+efficient as macros.
+
+A particularly interesting class of constant is a local function.
+Substituting for lexical variables that are bound to a function can
+substantially improve the efficiency of functional programming styles,
+for example:
+\begin{lisp}
+(let ((a #'(lambda (x) (zow x))))
+ (funcall a 3))
+\end{lisp}
+effectively transforms to:
+\begin{lisp}
+(zow 3)
+\end{lisp}
+This transformation is done even when the function is a closure, as in:
+\begin{lisp}
+(let ((a (let ((y (zug)))
+ #'(lambda (x) (zow x y)))))
+ (funcall a 3))
+\end{lisp}
+becoming:
+\begin{lisp}
+(zow 3 (zug))
+\end{lisp}
+
+A constant variable is a lexical variable that is never assigned to,
+always keeping its initial value. Whenever possible, avoid setting
+lexical variables\dash{}instead bind a new variable to the new value.
+Except for loop variables, it is almost always possible to avoid
+setting lexical variables. This form:
+\begin{example}
+(let ((x (f x)))
+ ...)
+\end{example}
+is \var{more} efficient than this form:
+\begin{example}
+(setq x (f x))
+...
+\end{example}
+Setting variables makes the program more difficult to understand, both
+to the compiler and to the programmer. \python{} compiles assignments
+at least as efficiently as any other \llisp{} compiler, but most let
+optimizations are only done on constant variables.
+
+Constant variables with only a single use are also optimized away,
+even when the initial value is not constant.\footnote{The source
+ transformation in this example doesn't represent the preservation of
+ evaluation order implicit in the compiler's internal representation.
+ Where necessary, the back end will reintroduce temporaries to
+ preserve the semantics.} For example, this expansion of
+\code{incf}:
+\begin{lisp}
+(let ((#:g3 (+ x 1)))
+ (setq x #:G3))
+\end{lisp}
+becomes:
+\begin{lisp}
+(setq x (+ x 1))
+\end{lisp}
+The type semantics of this transformation are more important than the
+elimination of the variable itself. Consider what happens when
+\code{x} is declared to be a \code{fixnum}; after the transformation,
+the compiler can compile the addition knowing that the result is a
+\code{fixnum}, whereas before the transformation the addition would
+have to allow for fixnum overflow.
+
+Another variable optimization deletes any variable that is never read.
+This causes the initial value and any assigned values to be unused,
+allowing those expressions to be deleted if they have no side-effects.
+
+Note that a let is actually a degenerate case of local call
+(\pxlref{let-calls}), and that let optimization can be done on calls
+that weren't created by a let. Also, local call allows an applicative
+style of iteration that is totally assignment free.
+
+%%\node Constant Folding, Unused Expression Elimination, Let Optimization, Source Optimization
+\subsection{Constant Folding}
+\cindex{constant folding}
+\cpsubindex{folding}{constant}
+
+Constant folding is an optimization that replaces a call of constant
+arguments with the constant result of that call. Constant folding is
+done on all standard functions for which it is legal. Inline
+expansion allows folding of any constant parts of the definition, and
+can be done even on functions that have side-effects.
+
+It is convenient to rely on constant folding when programming, as in this
+example:
+\begin{example}
+(defconstant limit 42)
+
+(defun foo ()
+ (... (1- limit) ...))
+\end{example}
+Constant folding is also helpful when writing macros or inline
+functions, since it usually eliminates the need to write a macro that
+special-cases constant arguments.
+
+\cindex{constant-function declaration} Constant folding of a user
+defined function is enabled by the \code{extensions:constant-function}
+proclamation. In this example:
+\begin{example}
+(declaim (ext:constant-function myfun))
+(defun myexp (x y)
+ (declare (single-float x y))
+ (exp (* (log x) y)))
+
+ ... (myexp 3.0 1.3) ...
+\end{example}
+The call to \code{myexp} is constant-folded to \code{4.1711674}.
+
+
+%%\node Unused Expression Elimination, Control Optimization, Constant Folding, Source Optimization
+\subsection{Unused Expression Elimination}
+\cindex{unused expression elimination}
+\cindex{dead code elimination}
+
+If the value of any expression is not used, and the expression has no
+side-effects, then it is deleted. As with constant folding, this
+optimization applies most often when cleaning up after inline
+expansion and other optimizations. Any function declared an
+\code{extensions:constant-function} is also subject to unused
+expression elimination.
+
+Note that \python{} will eliminate parts of unused expressions known
+to be side-effect free, even if there are other unknown parts. For
+example:
+\begin{lisp}
+(let ((a (list (foo) (bar))))
+ (if t
+ (zow)
+ (raz a)))
+\end{lisp}
+becomes:
+\begin{lisp}
+(progn (foo) (bar))
+(zow)
+\end{lisp}
+
+
+%%\node Control Optimization, Unreachable Code Deletion, Unused Expression Elimination, Source Optimization
+\subsection{Control Optimization}
+\cindex{control optimization}
+\cpsubindex{optimization}{control}
+
+The most important optimization of control is recognizing when an
+\findexed{if} test is known at compile time, then deleting the
+\code{if}, the test expression, and the unreachable branch of the
+\code{if}. This can be considered a special case of constant folding,
+although the test doesn't have to be truly constant as long as it is
+definitely not \false. Note also, that type inference propagates the
+result of an \code{if} test to the true and false branches,
+\pxlref{constraint-propagation}.
+
+A related \code{if} optimization is this transformation:\footnote{Note
+ that the code for \code{x} and \code{y} isn't actually replicated.}
+\begin{lisp}
+(if (if a b c) x y)
+\end{lisp}
+into:
+\begin{lisp}
+(if a
+ (if b x y)
+ (if c x y))
+\end{lisp}
+The opportunity for this sort of optimization usually results from a
+conditional macro. For example:
+\begin{lisp}
+(if (not a) x y)
+\end{lisp}
+is actually implemented as this:
+\begin{lisp}
+(if (if a nil t) x y)
+\end{lisp}
+which is transformed to this:
+\begin{lisp}
+(if a
+ (if nil x y)
+ (if t x y))
+\end{lisp}
+which is then optimized to this:
+\begin{lisp}
+(if a y x)
+\end{lisp}
+Note that due to \python{}'s internal representations, the
+\code{if}\dash{}\code{if} situation will be recognized even if other
+forms are wrapped around the inner \code{if}, like:
+\begin{example}
+(if (let ((g ...))
+ (loop
+ ...
+ (return (not g))
+ ...))
+ x y)
+\end{example}
+
+In \python, all the \clisp{} macros really are macros, written in
+terms of \code{if}, \code{block} and \code{tagbody}, so user-defined
+control macros can be just as efficient as the standard ones.
+\python{} emits basic blocks using a heuristic that minimizes the
+number of unconditional branches. The code in a \code{tagbody} will
+not be emitted in the order it appeared in the source, so there is no
+point in arranging the code to make control drop through to the
+target.
+
+%%\node Unreachable Code Deletion, Multiple Values Optimization, Control Optimization, Source Optimization
+\subsection{Unreachable Code Deletion}
+\label{dead-code-notes}
+\cindex{unreachable code deletion}
+\cindex{dead code elimination}
+
+Python will delete code whenever it can prove that the code can never be
+executed. Code becomes unreachable when:
+\begin{itemize}
+
+\item
+An \code{if} is optimized away, or
+
+\item
+There is an explicit unconditional control transfer such as \code{go} or
+\code{return-from}, or
+
+\item
+The last reference to a local function is deleted (or there never was any
+reference.)
+\end{itemize}
+
+
+When code that appeared in the original source is deleted, the compiler prints
+a note to indicate a possible problem (or at least unnecessary code.) For
+example:
+\begin{lisp}
+(defun foo ()
+ (if t
+ (write-line "True.")
+ (write-line "False.")))
+\end{lisp}
+will result in this note:
+\begin{example}
+In: DEFUN FOO
+ (WRITE-LINE "False.")
+Note: Deleting unreachable code.
+\end{example}
+
+It is important to pay attention to unreachable code notes, since they often
+indicate a subtle type error. For example:
+\begin{example}
+(defstruct foo a b)
+
+(defun lose (x)
+ (let ((a (foo-a x))
+ (b (if x (foo-b x) :none)))
+ ...))
+\end{example}
+results in this note:
+\begin{example}
+In: DEFUN LOSE
+ (IF X (FOO-B X) :NONE)
+==>
+ :NONE
+Note: Deleting unreachable code.
+\end{example}
+The \kwd{none} is unreachable, because type inference knows that the argument
+to \code{foo-a} must be a \code{foo}, and thus can't be \false. Presumably the
+programmer forgot that \code{x} could be \false{} when he wrote the binding for
+\code{a}.
+
+Here is an example with an incorrect declaration:
+\begin{lisp}
+(defun count-a (string)
+ (do ((pos 0 (position #\back{a} string :start (1+ pos)))
+ (count 0 (1+ count)))
+ ((null pos) count)
+ (declare (fixnum pos))))
+\end{lisp}
+This time our note is:
+\begin{example}
+In: DEFUN COUNT-A
+ (DO ((POS 0 #) (COUNT 0 #))
+ ((NULL POS) COUNT)
+ (DECLARE (FIXNUM POS)))
+--> BLOCK LET TAGBODY RETURN-FROM PROGN
+==>
+ COUNT
+Note: Deleting unreachable code.
+\end{example}
+The problem here is that \code{pos} can never be null since it is declared a
+\code{fixnum}.
+
+It takes some experience with unreachable code notes to be able to
+tell what they are trying to say. In non-obvious cases, the best
+thing to do is to call the function in a way that should cause the
+unreachable code to be executed. Either you will get a type error, or
+you will find that there truly is no way for the code to be executed.
+
+Not all unreachable code results in a note:
+\begin{itemize}
+
+\item A note is only given when the unreachable code textually appears
+ in the original source. This prevents spurious notes due to the
+ optimization of macros and inline functions, but sometimes also
+ foregoes a note that would have been useful.
+
+\item Since accurate source information is not available for non-list
+ forms, there is an element of heuristic in determining whether or
+ not to give a note about an atom. Spurious notes may be given when
+ a macro or inline function defines a variable that is also present
+ in the calling function. Notes about \false{} and \true{} are never
+ given, since it is too easy to confuse these constants in expanded
+ code with ones in the original source.
+
+\item Notes are only given about code unreachable due to control flow.
+ There is no note when an expression is deleted because its value is
+ unused, since this is a common consequence of other optimizations.
+\end{itemize}
+
+
+Somewhat spurious unreachable code notes can also result when a macro
+inserts multiple copies of its arguments in different contexts, for
+example:
+\begin{lisp}
+(defmacro t-and-f (var form)
+ `(if ,var ,form ,form))
+
+(defun foo (x)
+ (t-and-f x (if x "True." "False.")))
+\end{lisp}
+results in these notes:
+\begin{example}
+In: DEFUN FOO
+ (IF X "True." "False.")
+==>
+ "False."
+Note: Deleting unreachable code.
+
+==>
+ "True."
+Note: Deleting unreachable code.
+\end{example}
+It seems like it has deleted both branches of the \code{if}, but it has really
+deleted one branch in one copy, and the other branch in the other copy. Note
+that these messages are only spurious in not satisfying the intent of the rule
+that notes are only given when the deleted code appears in the original source;
+there is always \var{some} code being deleted when a unreachable code note is
+printed.
+
+
+%%\node Multiple Values Optimization, Source to Source Transformation, Unreachable Code Deletion, Source Optimization
+\subsection{Multiple Values Optimization}
+\cindex{multiple value optimization}
+\cpsubindex{optimization}{multiple value}
+
+Within a function, \python{} implements uses of multiple values
+particularly efficiently. Multiple values can be kept in arbitrary
+registers, so using multiple values doesn't imply stack manipulation
+and representation conversion. For example, this code:
+\begin{example}
+(let ((a (if x (foo x) u))
+ (b (if x (bar x) v)))
+ ...)
+\end{example}
+is actually more efficient written this way:
+\begin{example}
+(multiple-value-bind
+ (a b)
+ (if x
+ (values (foo x) (bar x))
+ (values u v))
+ ...)
+\end{example}
+
+Also, \pxlref{local-call-return} for information on how local call
+provides efficient support for multiple function return values.
+
+
+%%\node Source to Source Transformation, Style Recommendations, Multiple Values Optimization, Source Optimization
+\subsection{Source to Source Transformation}
+\cindex{source-to-source transformation}
+\cpsubindex{transformation}{source-to-source}
+
+The compiler implements a number of operation-specific optimizations as
+source-to-source transformations. You will often see unfamiliar code in error
+messages, for example:
+\begin{lisp}
+(defun my-zerop () (zerop x))
+\end{lisp}
+gives this warning:
+\begin{example}
+In: DEFUN MY-ZEROP
+ (ZEROP X)
+==>
+ (= X 0)
+Warning: Undefined variable: X
+\end{example}
+The original \code{zerop} has been transformed into a call to
+\code{=}. This transformation is indicated with the same \code{==$>$}
+used to mark macro and function inline expansion. Although it can be
+confusing, display of the transformed source is important, since
+warnings are given with respect to the transformed source. This a
+more obscure example:
+\begin{lisp}
+(defun foo (x) (logand 1 x))
+\end{lisp}
+gives this efficiency note:
+\begin{example}
+In: DEFUN FOO
+ (LOGAND 1 X)
+==>
+ (LOGAND C::Y C::X)
+Note: Forced to do static-function Two-arg-and (cost 53).
+ Unable to do inline fixnum arithmetic (cost 1) because:
+ The first argument is a INTEGER, not a FIXNUM.
+ etc.
+\end{example}
+Here, the compiler commuted the call to \code{logand}, introducing
+temporaries. The note complains that the \var{first} argument is not
+a \code{fixnum}, when in the original call, it was the second
+argument. To make things more confusing, the compiler introduced
+temporaries called \code{c::x} and \code{c::y} that are bound to
+\code{y} and \code{1}, respectively.
+
+You will also notice source-to-source optimizations when efficiency
+notes are enabled (\pxlref{efficiency-notes}.) When the compiler is
+unable to do a transformation that might be possible if there was more
+information, then an efficiency note is printed. For example,
+\code{my-zerop} above will also give this efficiency note:
+\begin{example}
+In: DEFUN FOO
+ (ZEROP X)
+==>
+ (= X 0)
+Note: Unable to optimize because:
+ Operands might not be the same type, so can't open code.
+\end{example}
+
+%%\node Style Recommendations, , Source to Source Transformation, Source Optimization
+\subsection{Style Recommendations}
+\cindex{style recommendations}
+
+Source level optimization makes possible a clearer and more relaxed programming
+style:
+\begin{itemize}
+
+\item Don't use macros purely to avoid function call. If you want an
+ inline function, write it as a function and declare it inline. It's
+ clearer, less error-prone, and works just as well.
+
+\item Don't write macros that try to ``optimize'' their expansion in
+ trivial ways such as avoiding binding variables for simple
+ expressions. The compiler does these optimizations too, and is less
+ likely to make a mistake.
+
+\item Make use of local functions (i.e., \code{labels} or \code{flet})
+ and tail-recursion in places where it is clearer. Local function
+ call is faster than full call.
+
+\item Avoid setting local variables when possible. Binding a new
+ \code{let} variable is at least as efficient as setting an existing
+ variable, and is easier to understand, both for the compiler and the
+ programmer.
+
+\item Instead of writing similar code over and over again so that it
+ can be hand customized for each use, define a macro or inline
+ function, and let the compiler do the work.
+\end{itemize}
+
+
+%%\f
+%%\node Tail Recursion, Local Call, Source Optimization, Advanced Compiler Use and Efficiency Hints
+\section{Tail Recursion}
+\label{tail-recursion}
+\cindex{tail recursion}
+\cindex{recursion}
+
+A call is tail-recursive if nothing has to be done after the the call
+returns, i.e. when the call returns, the returned value is immediately
+returned from the calling function. In this example, the recursive
+call to \code{myfun} is tail-recursive:
+\begin{lisp}
+(defun myfun (x)
+ (if (oddp (random x))
+ (isqrt x)
+ (myfun (1- x))))
+\end{lisp}
+
+Tail recursion is interesting because it is form of recursion that can be
+implemented much more efficiently than general recursion. In general, a
+recursive call requires the compiler to allocate storage on the stack at
+run-time for every call that has not yet returned. This memory consumption
+makes recursion unacceptably inefficient for representing repetitive algorithms
+having large or unbounded size. Tail recursion is the special case of
+recursion that is semantically equivalent to the iteration constructs normally
+used to represent repetition in programs. Because tail recursion is equivalent
+to iteration, tail-recursive programs can be compiled as efficiently as
+iterative programs.
+
+So why would you want to write a program recursively when you can write it
+using a loop? Well, the main answer is that recursion is a more general
+mechanism, so it can express some solutions simply that are awkward to write as
+a loop. Some programmers also feel that recursion is a stylistically
+preferable way to write loops because it avoids assigning variables.
+For example, instead of writing:
+\begin{lisp}
+(defun fun1 (x)
+ something-that-uses-x)
+
+(defun fun2 (y)
+ something-that-uses-y)
+
+(do ((x something (fun2 (fun1 x))))
+ (nil))
+\end{lisp}
+You can write:
+\begin{lisp}
+(defun fun1 (x)
+ (fun2 something-that-uses-x))
+
+(defun fun2 (y)
+ (fun1 something-that-uses-y))
+
+(fun1 something)
+\end{lisp}
+The tail-recursive definition is actually more efficient, in addition to being
+(arguably) clearer. As the number of functions and the complexity of their
+call graph increases, the simplicity of using recursion becomes compelling.
+Consider the advantages of writing a large finite-state machine with separate
+tail-recursive functions instead of using a single huge \code{prog}.
+
+It helps to understand how to use tail recursion if you think of a
+tail-recursive call as a \code{psetq} that assigns the argument values to the
+called function's variables, followed by a \code{go} to the start of the called
+function. This makes clear an inherent efficiency advantage of tail-recursive
+call: in addition to not having to allocate a stack frame, there is no need to
+prepare for the call to return (e.g., by computing a return PC.)
+
+Is there any disadvantage to tail recursion? Other than an increase
+in efficiency, the only way you can tell that a call has been compiled
+tail-recursively is if you use the debugger. Since a tail-recursive
+call has no stack frame, there is no way the debugger can print out
+the stack frame representing the call. The effect is that backtrace
+will not show some calls that would have been displayed in a
+non-tail-recursive implementation. In practice, this is not as bad as
+it sounds\dash{}in fact it isn't really clearly worse, just different.
+\xlref{debug-tail-recursion} for information about the debugger
+implications of tail recursion.
+
+In order to ensure that tail-recursion is preserved in arbitrarily
+complex calling patterns across separately compiled functions, the
+compiler must compile any call in a tail-recursive position as a
+tail-recursive call. This is done regardless of whether the program
+actually exhibits any sort of recursive calling pattern. In this
+example, the call to \code{fun2} will always be compiled as a
+tail-recursive call:
+\begin{lisp}
+(defun fun1 (x)
+ (fun2 x))
+\end{lisp}
+So tail recursion doesn't necessarily have anything to do with recursion
+as it is normally thought of. \xlref{local-tail-recursion} for more
+discussion of using tail recursion to implement loops.
+
+\begin{comment}
+* Tail Recursion Exceptions::
+\end{comment}
+
+%%\node Tail Recursion Exceptions, , Tail Recursion, Tail Recursion
+\subsection{Tail Recursion Exceptions}
+
+Although \python{} is claimed to be ``properly'' tail-recursive, some
+might dispute this, since there are situations where tail recursion is
+inhibited:
+\begin{itemize}
+
+\item When the call is enclosed by a special binding, or
+
+\item When the call is enclosed by a \code{catch} or
+ \code{unwind-protect}, or
+
+\item When the call is enclosed by a \code{block} or \code{tagbody}
+ and the block name or \code{go} tag has been closed over.
+\end{itemize}
+These dynamic extent binding forms inhibit tail recursion because they
+allocate stack space to represent the binding. Shallow-binding
+implementations of dynamic scoping also require cleanup code to be
+evaluated when the scope is exited.
+
+%%\f
+%%\node Local Call, Block Compilation, Tail Recursion, Advanced Compiler Use and Efficiency Hints
+\section{Local Call}
+\label{local-call}
+\cindex{local call}
+\cpsubindex{call}{local}
+\cpsubindex{function call}{local}
+
+Python supports two kinds of function call: full call and local call.
+Full call is the standard calling convention; its late binding and
+generality make \llisp{} what it is, but create unavoidable overheads.
+When the compiler can compile the calling function and the called
+function simultaneously, it can use local call to avoid some of the
+overhead of full call. Local call is really a collection of
+compilation strategies. If some aspect of call overhead is not needed
+in a particular local call, then it can be omitted. In some cases,
+local call can be totally free. Local call provides two main
+advantages to the user:
+\begin{itemize}
+
+\item Local call makes the use of the lexical function binding forms
+ \findexed{flet} and \findexed{labels} much more efficient. A local
+ call is always faster than a full call, and in many cases is much
+ faster.
+
+\item Local call is a natural approach to \i{block compilation}, a
+ compilation technique that resolves function references at compile
+ time. Block compilation speeds function call, but increases
+ compilation times and prevents function redefinition.
+\end{itemize}
+
+
+\begin{comment}
+* Self-Recursive Calls::
+* Let Calls::
+* Closures::
+* Local Tail Recursion::
+* Return Values::
+\end{comment}
+
+%%\node Self-Recursive Calls, Let Calls, Local Call, Local Call
+\subsection{Self-Recursive Calls}
+\cpsubindex{recursion}{self}
+
+Local call is used when a function defined by \code{defun} calls itself. For
+example:
+\begin{lisp}
+(defun fact (n)
+ (if (zerop n)
+ 1
+ (* n (fact (1- n)))))
+\end{lisp}
+This use of local call speeds recursion, but can also complicate
+debugging, since \findexed{trace} will only show the first call to
+\code{fact}, and not the recursive calls. This is because the
+recursive calls directly jump to the start of the function, and don't
+indirect through the \code{symbol-function}. Self-recursive local
+call is inhibited when the \kwd{block-compile} argument to
+\code{compile-file} is \false{} (\pxlref{compile-file-block}.)
+
+%%\node Let Calls, Closures, Self-Recursive Calls, Local Call
+\subsection{Let Calls}
+\label{let-calls}
+Because local call avoids unnecessary call overheads, the compiler
+internally uses local call to implement some macros and special forms
+that are not normally thought of as involving a function call. For
+example, this \code{let}:
+\begin{example}
+(let ((a (foo))
+ (b (bar)))
+ ...)
+\end{example}
+is internally represented as though it was macroexpanded into:
+\begin{example}
+(funcall #'(lambda (a b)
+ ...)
+ (foo)
+ (bar))
+\end{example}
+This implementation is acceptable because the simple cases of local
+call (equivalent to a \code{let}) result in good code. This doesn't
+make \code{let} any more efficient, but does make local calls that are
+semantically the same as \code{let} much more efficient than full
+calls. For example, these definitions are all the same as far as the
+compiler is concerned:
+\begin{example}
+(defun foo ()
+ ...some other stuff...
+ (let ((a something))
+ ...some stuff...))
+
+(defun foo ()
+ (flet ((localfun (a)
+ ...some stuff...))
+ ...some other stuff...
+ (localfun something)))
+
+(defun foo ()
+ (let ((funvar #'(lambda (a)
+ ...some stuff...)))
+ ...some other stuff...
+ (funcall funvar something)))
+\end{example}
+
+Although local call is most efficient when the function is called only
+once, a call doesn't have to be equivalent to a \code{let} to be more
+efficient than full call. All local calls avoid the overhead of
+argument count checking and keyword argument parsing, and there are a
+number of other advantages that apply in many common situations.
+\xlref{let-optimization} for a discussion of the optimizations done on
+let calls.
+
+%%\node Closures, Local Tail Recursion, Let Calls, Local Call
+\subsection{Closures}
+\cindex{closures}
+
+Local call allows for much more efficient use of closures, since the
+closure environment doesn't need to be allocated on the heap, or even
+stored in memory at all. In this example, there is no penalty for
+\code{localfun} referencing \code{a} and \code{b}:
+\begin{lisp}
+(defun foo (a b)
+ (flet ((localfun (x)
+ (1+ (* a b x))))
+ (if (= a b)
+ (localfun (- x))
+ (localfun x))))
+\end{lisp}
+In local call, the compiler effectively passes closed-over values as
+extra arguments, so there is no need for you to ``optimize'' local
+function use by explicitly passing in lexically visible values.
+Closures may also be subject to let optimization
+(\pxlref{let-optimization}.)
+
+Note: indirect value cells are currently always allocated on the heap
+when a variable is both assigned to (with \code{setq} or \code{setf})
+and closed over, regardless of whether the closure is a local function
+or not. This is another reason to avoid setting variables when you
+don't have to.
+
+%%\node Local Tail Recursion, Return Values, Closures, Local Call
+\subsection{Local Tail Recursion}
+\label{local-tail-recursion}
+\cindex{tail recursion}
+\cpsubindex{recursion}{tail}
+
+Tail-recursive local calls are particularly efficient, since they are
+in effect an assignment plus a control transfer. Scheme programmers
+write loops with tail-recursive local calls, instead of using the
+imperative \code{go} and \code{setq}. This has not caught on in the
+\clisp{} community, since conventional \llisp{} compilers don't
+implement local call. In \python, users can choose to write loops
+such as:
+\begin{lisp}
+(defun ! (n)
+ (labels ((loop (n total)
+ (if (zerop n)
+ total
+ (loop (1- n) (* n total)))))
+ (loop n 1)))
+\end{lisp}
+
+\begin{defmac}{extensions:}{iterate}{%
+ \args{\var{name} (\mstar{(\var{var} \var{initial-value})})
+ \mstar{\var{declaration}} \mstar{\var{form}}}}
+
+ This macro provides syntactic sugar for using \findexed{labels} to
+ do iteration. It creates a local function \var{name} with the
+ specified \var{var}s as its arguments and the \var{declaration}s and
+ \var{form}s as its body. This function is then called with the
+ \var{initial-values}, and the result of the call is return from the
+ macro.
+
+ Here is our factorial example rewritten using \code{iterate}:
+
+ \begin{lisp}
+ (defun ! (n)
+ (iterate loop
+ ((n n)
+ (total 1))
+ (if (zerop n)
+ total
+ (loop (1- n) (* n total)))))
+ \end{lisp}
+
+ The main advantage of using \code{iterate} over \code{do} is that
+ \code{iterate} naturally allows stepping to be done differently
+ depending on conditionals in the body of the loop. \code{iterate}
+ can also be used to implement algorithms that aren't really
+ iterative by simply doing a non-tail call. For example, the
+ standard recursive definition of factorial can be written like this:
+\begin{lisp}
+(iterate fact
+ ((n n))
+ (if (zerop n)
+ 1
+ (* n (fact (1- n)))))
+\end{lisp}
+\end{defmac}
+
+%%\node Return Values, , Local Tail Recursion, Local Call
+\subsection{Return Values}
+\label{local-call-return}
+\cpsubindex{return values}{local call}
+\cpsubindex{local call}{return values}
+
+One of the more subtle costs of full call comes from allowing
+arbitrary numbers of return values. This overhead can be avoided in
+local calls to functions that always return the same number of values.
+For efficiency reasons (as well as stylistic ones), you should write
+functions so that they always return the same number of values. This
+may require passing extra \false{} arguments to \code{values} in some
+cases, but the result is more efficient, not less so.
+
+When efficiency notes are enabled (\pxlref{efficiency-notes}), and the
+compiler wants to use known values return, but can't prove that the
+function always returns the same number of values, then it will print
+a note like this:
+\begin{example}
+In: DEFUN GRUE
+ (DEFUN GRUE (X) (DECLARE (FIXNUM X)) (COND (# #) (# NIL) (T #)))
+Note: Return type not fixed values, so can't use known return convention:
+ (VALUES (OR (INTEGER -536870912 -1) NULL) &REST T)
+\end{example}
+
+In order to implement proper tail recursion in the presence of known
+values return (\pxlref{tail-recursion}), the compiler sometimes must
+prove that multiple functions all return the same number of values.
+When this can't be proven, the compiler will print a note like this:
+\begin{example}
+In: DEFUN BLUE
+ (DEFUN BLUE (X) (DECLARE (FIXNUM X)) (COND (# #) (# #) (# #) (T #)))
+Note: Return value count mismatch prevents known return from
+ these functions:
+ BLUE
+ SNOO
+\end{example}
+\xlref{number-local-call} for the interaction between local call
+and the representation of numeric types.
+
+%%\f
+%%\node Block Compilation, Inline Expansion, Local Call, Advanced Compiler Use and Efficiency Hints
+\section{Block Compilation}
+\label{block-compilation}
+\cindex{block compilation}
+\cpsubindex{compilation}{block}
+
+Block compilation allows calls to global functions defined by
+\findexed{defun} to be compiled as local calls. The function call
+can be in a different top-level form than the \code{defun}, or even in a
+different file.
+
+In addition, block compilation allows the declaration of the \i{entry points}
+to the block compiled portion. An entry point is any function that may be
+called from outside of the block compilation. If a function is not an entry
+point, then it can be compiled more efficiently, since all calls are known at
+compile time. In particular, if a function is only called in one place, then
+it will be let converted. This effectively inline expands the function, but
+without the code duplication that results from defining the function normally
+and then declaring it inline.
+
+The main advantage of block compilation is that it it preserves efficiency in
+programs even when (for readability and syntactic convenience) they are broken
+up into many small functions. There is absolutely no overhead for calling a
+non-entry point function that is defined purely for modularity (i.e. called
+only in one place.)
+
+Block compilation also allows the use of non-descriptor arguments and return
+values in non-trivial programs (\pxlref{number-local-call}).
+
+\begin{comment}
+* Block Compilation Semantics::
+* Block Compilation Declarations::
+* Compiler Arguments::
+* Practical Difficulties::
+* Context Declarations::
+* Context Declaration Example::
+\end{comment}
+
+%%\node Block Compilation Semantics, Block Compilation Declarations, Block Compilation, Block Compilation
+\subsection{Block Compilation Semantics}
+
+The effect of block compilation can be envisioned as the compiler turning all
+the \code{defun}s in the block compilation into a single \code{labels} form:
+\begin{example}
+(declaim (start-block fun1 fun3))
+
+(defun fun1 ()
+ ...)
+
+(defun fun2 ()
+ ...
+ (fun1)
+ ...)
+
+(defun fun3 (x)
+ (if x
+ (fun1)
+ (fun2)))
+
+(declaim (end-block))
+\end{example}
+becomes:
+\begin{example}
+(labels ((fun1 ()
+ ...)
+ (fun2 ()
+ ...
+ (fun1)
+ ...)
+ (fun3 (x)
+ (if x
+ (fun1)
+ (fun2))))
+ (setf (fdefinition 'fun1) #'fun1)
+ (setf (fdefinition 'fun3) #'fun3))
+\end{example}
+Calls between the block compiled functions are local calls, so changing the
+global definition of \code{fun1} will have no effect on what \code{fun2} does;
+\code{fun2} will keep calling the old \code{fun1}.
+
+The entry points \code{fun1} and \code{fun3} are still installed in
+the \code{symbol-function} as the global definitions of the functions,
+so a full call to an entry point works just as before. However,
+\code{fun2} is not an entry point, so it is not globally defined. In
+addition, \code{fun2} is only called in one place, so it will be let
+converted.
+
+
+%%\node Block Compilation Declarations, Compiler Arguments, Block Compilation Semantics, Block Compilation
+\subsection{Block Compilation Declarations}
+\cpsubindex{declarations}{block compilation}
+\cindex{start-block declaration}
+\cindex{end-block declaration}
+
+The \code{extensions:start-block} and \code{extensions:end-block}
+declarations allow fine-grained control of block compilation. These
+declarations are only legal as a global declarations (\code{declaim}
+or \code{proclaim}).
+
+\noindent
+\vspace{1 em}
+The \code{start-block} declaration has this syntax:
+\begin{example}
+(start-block \mstar{\var{entry-point-name}})
+\end{example}
+When processed by the compiler, this declaration marks the start of
+block compilation, and specifies the entry points to that block. If
+no entry points are specified, then \var{all} functions are made into
+entry points. If already block compiling, then the compiler ends the
+current block and starts a new one.
+
+\noindent
+\vspace{1 em}
+The \code{end-block} declaration has no arguments:
+\begin{lisp}
+(end-block)
+\end{lisp}
+The \code{end-block} declaration ends a block compilation unit without
+starting a new one. This is useful mainly when only a portion of a file
+is worth block compiling.
+
+%%\node Compiler Arguments, Practical Difficulties, Block Compilation Declarations, Block Compilation
+\subsection{Compiler Arguments}
+\label{compile-file-block}
+\cpsubindex{compile-file}{block compilation arguments}
+
+The \kwd{block-compile} and \kwd{entry-points} arguments to
+\code{extensions:compile-from-stream} and \funref{compile-file} provide overall
+control of block compilation, and allow block compilation without requiring
+modification of the program source.
+
+There are three possible values of the \kwd{block-compile} argument:
+\begin{Lentry}
+
+\item[\false{}] Do no compile-time resolution of global function
+ names, not even for self-recursive calls. This inhibits any
+ \code{start-block} declarations appearing in the file, allowing all
+ functions to be incrementally redefined.
+
+\item[\true{}] Start compiling in block compilation mode. This is
+ mainly useful for block compiling small files that contain no
+ \code{start-block} declarations. See also the \kwd{entry-points}
+ argument.
+
+\item[\kwd{specified}] Start compiling in form-at-a-time mode, but
+ exploit \code{start-block} declarations and compile self-recursive
+ calls as local calls. Normally \kwd{specified} is the default for
+ this argument (see \varref{block-compile-default}.)
+\end{Lentry}
+
+The \kwd{entry-points} argument can be used in conjunction with
+\w{\kwd{block-compile} \true{}} to specify the entry-points to a
+block-compiled file. If not specified or \nil, all global functions
+will be compiled as entry points. When \kwd{block-compile} is not
+\true, this argument is ignored.
+
+\begin{defvar}{}{block-compile-default}
+
+ This variable determines the default value for the
+ \kwd{block-compile} argument to \code{compile-file} and
+ \code{compile-from-stream}. The initial value of this variable is
+ \kwd{specified}, but \false{} is sometimes useful for totally
+ inhibiting block compilation.
+\end{defvar}
+
+%%\node Practical Difficulties, Context Declarations, Compiler Arguments, Block Compilation
+\subsection{Practical Difficulties}
+
+The main problem with block compilation is that the compiler uses
+large amounts of memory when it is block compiling. This places an
+upper limit on the amount of code that can be block compiled as a
+unit. To make best use of block compilation, it is necessary to
+locate the parts of the program containing many internal calls, and
+then add the appropriate \code{start-block} declarations. When writing
+new code, it is a good idea to put in block compilation declarations
+from the very beginning, since writing block declarations correctly
+requires accurate knowledge of the program's function call structure.
+If you want to initially develop code with full incremental
+redefinition, you can compile with \varref{block-compile-default} set to
+\false.
+
+Note if a \code{defun} appears in a non-null lexical environment, then
+calls to it cannot be block compiled.
+
+Unless files are very small, it is probably impractical to block compile
+multiple files as a unit by specifying a list of files to \code{compile-file}.
+Semi-inline expansion (\pxlref{semi-inline}) provides another way to
+extend block compilation across file boundaries.
+%%\f
+%%\node Context Declarations, Context Declaration Example, Practical Difficulties, Block Compilation
+\subsection{Context Declarations}
+\label{context-declarations}
+\cindex{context sensitive declarations}
+\cpsubindex{declarations}{context-sensitive}
+
+\cmucl{} has a context-sensitive declaration mechanism which is useful
+because it allows flexible control of the compilation policy in large
+systems without requiring changes to the source files. The primary
+use of this feature is to allow the exported interfaces of a system to
+be compiled more safely than the system internals. The context used
+is the name being defined and the kind of definition (function, macro,
+etc.)
+
+The \kwd{context-declarations} option to \macref{with-compilation-unit} has
+dynamic scope, affecting all compilation done during the evaluation of the
+body. The argument to this option should evaluate to a list of lists of the
+form:
+\begin{example}
+(\var{context-spec} \mplus{\var{declare-form}})
+\end{example}
+In the indicated context, the specified declare forms are inserted at
+the head of each definition. The declare forms for all contexts that
+match are appended together, with earlier declarations getting
+precedence over later ones. A simple example:
+\begin{example}
+ :context-declarations
+ '((:external (declare (optimize (safety 2)))))
+\end{example}
+This will cause all functions that are named by external symbols to be
+compiled with \code{safety 2}.
+
+The full syntax of context specs is:
+\begin{Lentry}
+
+\item[\kwd{internal}, \kwd{external}] True if the symbol is internal
+ (external) in its home package.
+
+\item[\kwd{uninterned}] True if the symbol has no home package.
+
+\item[\code{\w{(:package \mstar{\var{package-name}})}}] True if the
+ symbol's home package is in any of the named packages (false if
+ uninterned.)
+
+\item[\kwd{anonymous}] True if the function doesn't have any
+ interesting name (not \code{defmacro}, \code{defun}, \code{labels}
+ or \code{flet}).
+
+\item[\kwd{macro}, \kwd{function}] \kwd{macro} is a global
+ (\code{defmacro}) macro. \kwd{function} is anything else.
+
+\item[\kwd{local}, \kwd{global}] \kwd{local} is a \code{labels} or
+ \code{flet}. \kwd{global} is anything else.
+
+\item[\code{\w{(:or \mstar{\var{context-spec}})}}] True when any
+ supplied \var{context-spec} is true.
+
+\item[\code{\w{(:and \mstar{\var{context-spec}})}}] True only when all
+ supplied \var{context-spec}s are true.
+
+\item[\code{\w{(:not \mstar{\var{context-spec}})}}] True when
+ \var{context-spec} is false.
+
+\item[\code{\w{(:member \mstar{\var{name}})}}] True when the defined
+ name is one of these names (\code{equal} test.)
+
+\item[\code{\w{(:match \mstar{\var{pattern}})}}] True when any of the
+ patterns is a substring of the name. The name is wrapped with
+ \code{\$}'s, so ``\code{\$FOO}'' matches names beginning with
+ ``\code{FOO}'', etc.
+\end{Lentry}
+
+%%\node Context Declaration Example, , Context Declarations, Block Compilation
+\subsection{Context Declaration Example}
+
+Here is a more complex example of \code{with-compilation-unit} options:
+\begin{example}
+:optimize '(optimize (speed 2) (space 2) (inhibit-warnings 2)
+ (debug 1) (safety 0))
+:optimize-interface '(optimize-interface (safety 1) (debug 1))
+:context-declarations
+'(((:or :external (:and (:match "\%") (:match "SET")))
+ (declare (optimize-interface (safety 2))))
+ ((:or (:and :external :macro)
+ (:match "\$PARSE-"))
+ (declare (optimize (safety 2)))))
+\end{example}
+The \code{optimize} and \code{extensions:optimize-interface}
+declarations (\pxlref{optimize-declaration}) set up the global
+compilation policy. The bodies of functions are to be compiled
+completely unsafe (\code{safety 0}), but argument count and weakened
+argument type checking is to be done when a function is called
+(\code{speed 2 safety 1}).
+
+The first declaration specifies that all functions that are external
+or whose names contain both ``\code{\%}'' and ``\code{SET}'' are to be
+compiled compiled with completely safe interfaces (\code{safety 2}).
+The reason for this particular \kwd{match} rule is that \code{setf}
+inverse functions in this system tend to have both strings in their
+name somewhere. We want \code{setf} inverses to be safe because they
+are implicitly called by users even though their name is not exported.
+
+The second declaration makes external macros or functions whose names
+start with ``\code{PARSE-}'' have safe bodies (as well as interfaces).
+This is desirable because a syntax error in a macro may cause a type
+error inside the body. The \kwd{match} rule is used because macros
+often have auxiliary functions whose names begin with this string.
+
+This particular example is used to build part of the standard \cmucl{}
+system. Note however, that context declarations must be set up
+according to the needs and coding conventions of a particular system;
+different parts of \cmucl{} are compiled with different context
+declarations, and your system will probably need its own declarations.
+In particular, any use of the \kwd{match} option depends on naming
+conventions used in coding.
+
+%%\f
+%%\node Inline Expansion, Byte Coded Compilation, Block Compilation, Advanced Compiler Use and Efficiency Hints
+\section{Inline Expansion}
+\label{inline-expansion}
+\cindex{inline expansion}
+\cpsubindex{expansion}{inline}
+\cpsubindex{call}{inline}
+\cpsubindex{function call}{inline}
+\cpsubindex{optimization}{function call}
+
+Python can expand almost any function inline, including functions
+with keyword arguments. The only restrictions are that keyword
+argument keywords in the call must be constant, and that global
+function definitions (\code{defun}) must be done in a null lexical
+environment (not nested in a \code{let} or other binding form.) Local
+functions (\code{flet}) can be inline expanded in any environment.
+Combined with \python{}'s source-level optimization, inline expansion
+can be used for things that formerly required macros for efficient
+implementation. In \python, macros don't have any efficiency
+advantage, so they need only be used where a macro's syntactic
+flexibility is required.
+
+Inline expansion is a compiler optimization technique that reduces
+the overhead of a function call by simply not doing the call:
+instead, the compiler effectively rewrites the program to appear as
+though the definition of the called function was inserted at each
+call site. In \llisp, this is straightforwardly expressed by
+inserting the \code{lambda} corresponding to the original definition:
+\begin{lisp}
+(proclaim '(inline my-1+))
+(defun my-1+ (x) (+ x 1))
+
+(my-1+ someval) \result{} ((lambda (x) (+ x 1)) someval)
+\end{lisp}
+
+When the function expanded inline is large, the program after inline
+expansion may be substantially larger than the original program. If
+the program becomes too large, inline expansion hurts speed rather
+than helping it, since hardware resources such as physical memory and
+cache will be exhausted. Inline expansion is called for:
+\begin{itemize}
+
+\item When profiling has shown that a relatively simple function is
+ called so often that a large amount of time is being wasted in the
+ calling of that function (as opposed to running in that function.)
+ If a function is complex, it will take a long time to run relative
+ the time spent in call, so the speed advantage of inline expansion
+ is diminished at the same time the space cost of inline expansion is
+ increased. Of course, if a function is rarely called, then the
+ overhead of calling it is also insignificant.
+
+\item With functions so simple that they take less space to inline
+ expand than would be taken to call the function (such as
+ \code{my-1+} above.) It would require intimate knowledge of the
+ compiler to be certain when inline expansion would reduce space, but
+ it is generally safe to inline expand functions whose definition is
+ a single function call, or a few calls to simple \clisp{} functions.
+\end{itemize}
+
+
+In addition to this speed/space tradeoff from inline expansion's
+avoidance of the call, inline expansion can also reveal opportunities
+for optimization. \python{}'s extensive source-level optimization can
+make use of context information from the caller to tremendously
+simplify the code resulting from the inline expansion of a function.
+
+The main form of caller context is local information about the actual
+argument values: what the argument types are and whether the arguments
+are constant. Knowledge about argument types can eliminate run-time
+type tests (e.g., for generic arithmetic.) Constant arguments in a
+call provide opportunities for constant folding optimization after
+inline expansion.
+
+A hidden way that constant arguments are often supplied to functions
+is through the defaulting of unsupplied optional or keyword arguments.
+There can be a huge efficiency advantage to inline expanding functions
+that have complex keyword-based interfaces, such as this definition of
+the \code{member} function:
+\begin{lisp}
+(proclaim '(inline member))
+(defun member (item list &key
+ (key #'identity)
+ (test #'eql testp)
+ (test-not nil notp))
+ (do ((list list (cdr list)))
+ ((null list) nil)
+ (let ((car (car list)))
+ (if (cond (testp
+ (funcall test item (funcall key car)))
+ (notp
+ (not (funcall test-not item (funcall key car))))
+ (t
+ (funcall test item (funcall key car))))
+ (return list)))))
+
+\end{lisp}
+After inline expansion, this call is simplified to the obvious code:
+\begin{lisp}
+(member a l :key #'foo-a :test #'char=) \result{}
+
+(do ((list list (cdr list)))
+ ((null list) nil)
+ (let ((car (car list)))
+ (if (char= item (foo-a car))
+ (return list))))
+\end{lisp}
+In this example, there could easily be more than an order of magnitude
+improvement in speed. In addition to eliminating the original call to
+\code{member}, inline expansion also allows the calls to \code{char=}
+and \code{foo-a} to be open-coded. We go from a loop with three tests
+and two calls to a loop with one test and no calls.
+
+\xlref{source-optimization} for more discussion of source level
+optimization.
+
+\begin{comment}
+* Inline Expansion Recording::
+* Semi-Inline Expansion::
+* The Maybe-Inline Declaration::
+\end{comment}
+
+%%\node Inline Expansion Recording, Semi-Inline Expansion, Inline Expansion, Inline Expansion
+\subsection{Inline Expansion Recording}
+\cindex{recording of inline expansions}
+
+Inline expansion requires that the source for the inline expanded function to
+be available when calls to the function are compiled. The compiler doesn't
+remember the inline expansion for every function, since that would take an
+excessive about of space. Instead, the programmer must tell the compiler to
+record the inline expansion before the definition of the inline expanded
+function is compiled. This is done by globally declaring the function inline
+before the function is defined, by using the \code{inline} and
+\code{extensions:maybe-inline} (\pxlref{maybe-inline-declaration})
+declarations.
+
+In addition to recording the inline expansion of inline functions at the time
+the function is compiled, \code{compile-file} also puts the inline expansion in
+the output file. When the output file is loaded, the inline expansion is made
+available for subsequent compilations; there is no need to compile the
+definition again to record the inline expansion.
+
+If a function is declared inline, but no expansion is recorded, then the
+compiler will give an efficiency note like:
+\begin{example}
+Note: MYFUN is declared inline, but has no expansion.
+\end{example}
+When you get this note, check that the \code{inline} declaration and the
+definition appear before the calls that are to be inline expanded. This note
+will also be given if the inline expansion for a \code{defun} could not be
+recorded because the \code{defun} was in a non-null lexical environment.
+
+%%\node Semi-Inline Expansion, The Maybe-Inline Declaration, Inline Expansion Recording, Inline Expansion
+\subsection{Semi-Inline Expansion}
+\label{semi-inline}
+
+Python supports \var{semi-inline} functions. Semi-inline expansion
+shares a single copy of a function across all the calls in a component
+by converting the inline expansion into a local function
+(\pxlref{local-call}.) This takes up less space when there are
+multiple calls, but also provides less opportunity for context
+dependent optimization. When there is only one call, the result is
+identical to normal inline expansion. Semi-inline expansion is done
+when the \code{space} optimization quality is \code{0}, and the
+function has been declared \code{extensions:maybe-inline}.
+
+This mechanism of inline expansion combined with local call also
+allows recursive functions to be inline expanded. If a recursive
+function is declared \code{inline}, calls will actually be compiled
+semi-inline. Although recursive functions are often so complex that
+there is little advantage to semi-inline expansion, it can still be
+useful in the same sort of cases where normal inline expansion is
+especially advantageous, i.e. functions where the calling context can
+help a lot.
+
+%%\node The Maybe-Inline Declaration, , Semi-Inline Expansion, Inline Expansion
+\subsection{The Maybe-Inline Declaration}
+\label{maybe-inline-declaration}
+\cindex{maybe-inline declaration}
+
+The \code{extensions:maybe-inline} declaration is a \cmucl{}
+extension. It is similar to \code{inline}, but indicates that inline
+expansion may sometimes be desirable, rather than saying that inline
+expansion should almost always be done. When used in a global
+declaration, \code{extensions:maybe-inline} causes the expansion for
+the named functions to be recorded, but the functions aren't actually
+inline expanded unless \code{space} is \code{0} or the function is
+eventually (perhaps locally) declared \code{inline}.
+
+Use of the \code{extensions:maybe-inline} declaration followed by the
+\code{defun} is preferable to the standard idiom of:
+\begin{lisp}
+(proclaim '(inline myfun))
+(defun myfun () ...)
+(proclaim '(notinline myfun))
+
+;;; \i{Any calls to \code{myfun} here are not inline expanded.}
+
+(defun somefun ()
+ (declare (inline myfun))
+ ;;
+ ;; \i{Calls to \code{myfun} here are inline expanded.}
+ ...)
+\end{lisp}
+The problem with using \code{notinline} in this way is that in
+\clisp{} it does more than just suppress inline expansion, it also
+forbids the compiler to use any knowledge of \code{myfun} until a
+later \code{inline} declaration overrides the \code{notinline}. This
+prevents compiler warnings about incorrect calls to the function, and
+also prevents block compilation.
+
+The \code{extensions:maybe-inline} declaration is used like this:
+\begin{lisp}
+(proclaim '(extensions:maybe-inline myfun))
+(defun myfun () ...)
+
+;;; \i{Any calls to \code{myfun} here are not inline expanded.}
+
+(defun somefun ()
+ (declare (inline myfun))
+ ;;
+ ;; \i{Calls to \code{myfun} here are inline expanded.}
+ ...)
+
+(defun someotherfun ()
+ (declare (optimize (space 0)))
+ ;;
+ ;; \i{Calls to \code{myfun} here are expanded semi-inline.}
+ ...)
+\end{lisp}
+In this example, the use of \code{extensions:maybe-inline} causes the
+expansion to be recorded when the \code{defun} for \code{somefun} is
+compiled, and doesn't waste space through doing inline expansion by
+default. Unlike \code{notinline}, this declaration still allows the
+compiler to assume that the known definition really is the one that
+will be called when giving compiler warnings, and also allows the
+compiler to do semi-inline expansion when the policy is appropriate.
+
+When the goal is merely to control whether inline expansion is done by
+default, it is preferable to use \code{extensions:maybe-inline} rather
+than \code{notinline}. The \code{notinline} declaration should be
+reserved for those special occasions when a function may be redefined
+at run-time, so the compiler must be told that the obvious definition
+of a function is not necessarily the one that will be in effect at the
+time of the call.
+
+%%\f
+%%\node Byte Coded Compilation, Object Representation, Inline Expansion, Advanced Compiler Use and Efficiency Hints
+\section{Byte Coded Compilation}
+\label{byte-compile}
+\cindex{byte coded compilation}
+\cindex{space optimization}
+
+\Python{} supports byte compilation to reduce the size of Lisp
+programs by allowing functions to be compiled more compactly. Byte
+compilation provides an extreme speed/space tradeoff: byte code is
+typically six times more compact than native code, but runs fifty
+times (or more) slower. This is about ten times faster than the
+standard interpreter, which is itself considered fast in comparison to
+other \clisp{} interpreters.
+
+Large Lisp systems (such as \cmucl{} itself) often have large amounts
+of user-interface code, compile-time (macro) code, debugging code, or
+rarely executed special-case code. This code is a good target for
+byte compilation: very little time is spent running in it, but it can
+take up quite a bit of space. Straight-line code with many function
+calls is much more suitable than inner loops.
+
+When byte-compiling, the compiler compiles about twice as fast, and
+can produce a hardware independent object file (\file{.bytef} type.)
+This file can be loaded like a normal fasl file on any implementation
+of CMU CL with the same byte-ordering (DEC PMAX has \file{.lbytef}
+type.)
+
+The decision to byte compile or native compile can be done on a
+per-file or per-code-object basis. The \kwd{byte-compile} argument to
+\funref{compile-file} has these possible values:
+\begin{Lentry}
+\item[\false{}] Don't byte compile anything in this file.
+
+\item[\true{}] Byte compile everything in this file and produce a
+ processor-independent \file{.bytef} file.
+
+\item[\kwd{maybe}] Produce a normal fasl file, but byte compile any
+ functions for which the \code{speed} optimization quality is
+ \code{0} and the \code{debug} quality is not greater than \code{1}.
+\end{Lentry}
+
+\begin{defvar}{extensions:}{byte-compile-top-level}
+
+ If this variable is true (the default) and the \kwd{byte-compile}
+ argument to \code{compile-file} is \kwd{maybe}, then byte compile
+ top-level code (code outside of any \code{defun}, \code{defmethod},
+ etc.)
+\end{defvar}
+
+\begin{defvar}{extensions:}{byte-compile-default}
+
+ This variable determines the default value for the
+ \kwd{byte-compile} argument to \code{compile-file}, initially
+ \kwd{maybe}.
+\end{defvar}
+
+%%\f
+%%\node Object Representation, Numbers, Byte Coded Compilation, Advanced Compiler Use and Efficiency Hints
+\section{Object Representation}
+\label{object-representation}
+\cindex{object representation}
+\cpsubindex{representation}{object}
+\cpsubindex{efficiency}{of objects}
+
+A somewhat subtle aspect of writing efficient \clisp{} programs is
+choosing the correct data structures so that the underlying objects
+can be implemented efficiently. This is partly because of the need
+for multiple representations for a given value
+(\pxlref{non-descriptor}), but is also due to the sheer number of
+object types that \clisp{} has built in. The number of possible
+representations complicates the choice of a good representation
+because semantically similar objects may vary in their efficiency
+depending on how the program operates on them.
+
+\begin{comment}
+* Think Before You Use a List::
+* Structure Representation::
+* Arrays::
+* Vectors::
+* Bit-Vectors::
+* Hashtables::
+\end{comment}
+
+%%\node Think Before You Use a List, Structure Representation, Object Representation, Object Representation
+\subsection{Think Before You Use a List}
+\cpsubindex{lists}{efficiency of}
+
+Although Lisp's creator seemed to think that it was for LISt Processing, the
+astute observer may have noticed that the chapter on list manipulation makes up
+less that three percent of \i{Common Lisp: the Language II}. The language has
+grown since Lisp 1.5\dash{}new data types supersede lists for many purposes.
+
+%%\node Structure Representation, Arrays, Think Before You Use a List, Object Representation
+\subsection{Structure Representation}
+\cpsubindex{structure types}{efficiency of} One of the best ways of
+building complex data structures is to define appropriate structure
+types using \findexed{defstruct}. In \python, access of structure
+slots is always at least as fast as list or vector access, and is
+usually faster. In comparison to a list representation of a tuple,
+structures also have a space advantage.
+
+Even if structures weren't more efficient than other representations, structure
+use would still be attractive because programs that use structures in
+appropriate ways are much more maintainable and robust than programs written
+using only lists. For example:
+\begin{lisp}
+(rplaca (caddr (cadddr x)) (caddr y))
+\end{lisp}
+could have been written using structures in this way:
+\begin{lisp}
+(setf (beverage-flavor (astronaut-beverage x)) (beverage-flavor y))
+\end{lisp}
+The second version is more maintainable because it is easier to
+understand what it is doing. It is more robust because structures
+accesses are type checked. An \code{astronaut} will never be confused
+with a \code{beverage}, and the result of \code{beverage-flavor} is
+always a flavor. See sections \ref{structure-types} and
+\ref{freeze-type} for more information about structure types.
+\xlref{type-inference} for a number of examples that make clear the
+advantages of structure typing.
+
+Note that the structure definition should be compiled before any uses
+of its accessors or type predicate so that these function calls can be
+efficiently open-coded.
+
+%%\node Arrays, Vectors, Structure Representation, Object Representation
+\subsection{Arrays}
+\label{array-types}
+\cpsubindex{arrays}{efficiency of}
+
+Arrays are often the most efficient representation for collections of objects
+because:
+\begin{itemize}
+
+\item Array representations are often the most compact. An array is
+ always more compact than a list containing the same number of
+ elements.
+
+\item Arrays allow fast constant-time access.
+
+\item Arrays are easily destructively modified, which can reduce
+ consing.
+
+\item Array element types can be specialized, which reduces both
+ overall size and consing (\pxlref{specialized-array-types}.)
+\end{itemize}
+
+
+Access of arrays that are not of type \code{simple-array} is less
+efficient, so declarations are appropriate when an array is of a
+simple type like \code{simple-string} or \code{simple-bit-vector}.
+Arrays are almost always simple, but the compiler may not be able to
+prove simpleness at every use. The only way to get a non-simple array
+is to use the \kwd{displaced-to}, \kwd{fill-pointer} or
+\code{adjustable} arguments to \code{make-array}. If you don't use
+these hairy options, then arrays can always be declared to be simple.
+
+Because of the many specialized array types and the possibility of
+non-simple arrays, array access is much like generic arithmetic
+(\pxlref{generic-arithmetic}). In order for array accesses to be
+efficiently compiled, the element type and simpleness of the array
+must be known at compile time. If there is inadequate information,
+the compiler is forced to call a generic array access routine. You
+can detect inefficient array accesses by enabling efficiency notes,
+\pxlref{efficiency-notes}.
+
+%%\node Vectors, Bit-Vectors, Arrays, Object Representation
+\subsection{Vectors}
+\cpsubindex{vectors}{efficiency of}
+
+Vectors (one dimensional arrays) are particularly useful, since in
+addition to their obvious array-like applications, they are also well
+suited to representing sequences. In comparison to a list
+representation, vectors are faster to access and take up between two
+and sixty-four times less space (depending on the element type.) As
+with arbitrary arrays, the compiler needs to know that vectors are not
+complex, so you should use \code{simple-string} in preference to
+\code{string}, etc.
+
+The only advantage that lists have over vectors for representing
+sequences is that it is easy to change the length of a list, add to it
+and remove items from it. Likely signs of archaic, slow lisp code are
+\code{nth} and \code{nthcdr}. If you are using these functions you
+should probably be using a vector.
+
+%%\node Bit-Vectors, Hashtables, Vectors, Object Representation
+\subsection{Bit-Vectors}
+\cpsubindex{bit-vectors}{efficiency of}
+
+Another thing that lists have been used for is set manipulation. In
+applications where there is a known, reasonably small universe of
+items bit-vectors can be used to improve performance. This is much
+less convenient than using lists, because instead of symbols, each
+element in the universe must be assigned a numeric index into the bit
+vector. Using a bit-vector will nearly always be faster, and can be
+tremendously faster if the number of elements in the set is not small.
+The logical operations on \code{simple-bit-vector}s are efficient,
+since they operate on a word at a time.
+
+
+%%\node Hashtables, , Bit-Vectors, Object Representation
+\subsection{Hashtables}
+\cpsubindex{hash-tables}{efficiency of}
+
+Hashtables are an efficient and general mechanism for maintaining associations
+such as the association between an object and its name. Although hashtables
+are usually the best way to maintain associations, efficiency and style
+considerations sometimes favor the use of an association list (a-list).
+
+\code{assoc} is fairly fast when the \var{test} argument is \code{eq}
+or \code{eql} and there are only a few elements, but the time goes up
+in proportion with the number of elements. In contrast, the
+hash-table lookup has a somewhat higher overhead, but the speed is
+largely unaffected by the number of entries in the table. For an
+\code{equal} hash-table or alist, hash-tables have an even greater
+advantage, since the test is more expensive. Whatever you do, be sure
+to use the most restrictive test function possible.
+
+The style argument observes that although hash-tables and alists
+overlap in function, they do not do all things equally well.
+\begin{itemize}
+
+\item Alists are good for maintaining scoped environments. They were
+ originally invented to implement scoping in the Lisp interpreter,
+ and are still used for this in \python. With an alist one can
+ non-destructively change an association simply by consing a new
+ element on the front. This is something that cannot be done with
+ hash-tables.
+
+\item Hashtables are good for maintaining a global association. The
+ value associated with an entry can easily be changed with
+ \code{setf}. With an alist, one has to go through contortions,
+ either \code{rplacd}'ing the cons if the entry exists, or pushing a
+ new one if it doesn't. The side-effecting nature of hash-table
+ operations is an advantage here.
+\end{itemize}
+
+
+Historically, symbol property lists were often used for global name
+associations. Property lists provide an awkward and error-prone
+combination of name association and record structure. If you must use
+the property list, please store all the related values in a single
+structure under a single property, rather than using many properties.
+This makes access more efficient, and also adds a modicum of typing
+and abstraction. \xlref{advanced-type-stuff} for information on types
+in \cmucl.
+
+%%\f
+%%\node Numbers, General Efficiency Hints, Object Representation, Advanced Compiler Use and Efficiency Hints
+\section{Numbers}
+\label{numeric-types}
+\cpsubindex{numeric}{types}
+\cpsubindex{types}{numeric}
+
+Numbers are interesting because numbers are one of the few \llisp{} data types
+that have direct support in conventional hardware. If a number can be
+represented in the way that the hardware expects it, then there is a big
+efficiency advantage.
+
+Using hardware representations is problematical in \llisp{} due to
+dynamic typing (where the type of a value may be unknown at compile
+time.) It is possible to compile code for statically typed portions
+of a \llisp{} program with efficiency comparable to that obtained in
+statically typed languages such as C, but not all \llisp{}
+implementations succeed. There are two main barriers to efficient
+numerical code in \llisp{}:
+\begin{itemize}
+
+\item The compiler must prove that the numerical expression is in fact
+ statically typed, and
+
+\item The compiler must be able to somehow reconcile the conflicting
+ demands of the hardware mandated number representation with the
+ \llisp{} requirements of dynamic typing and garbage-collecting
+ dynamic storage allocation.
+\end{itemize}
+
+Because of its type inference (\pxlref{type-inference}) and efficiency
+notes (\pxlref{efficiency-notes}), \python{} is better than
+conventional \llisp{} compilers at ensuring that numerical expressions
+are statically typed. Python also goes somewhat farther than existing
+compilers in the area of allowing native machine number
+representations in the presence of garbage collection.
+
+\begin{comment}
+* Descriptors::
+* Non-Descriptor Representations::
+* Variables::
+* Generic Arithmetic::
+* Fixnums::
+* Word Integers::
+* Floating Point Efficiency::
+* Specialized Arrays::
+* Specialized Structure Slots::
+* Interactions With Local Call::
+* Representation of Characters::
+\end{comment}
+
+%%\node Descriptors, Non-Descriptor Representations, Numbers, Numbers
+\subsection{Descriptors}
+\cpsubindex{descriptors}{object}
+\cindex{object representation}
+\cpsubindex{representation}{object}
+\cpsubindex{consing}{overhead of}
+
+\llisp{}'s dynamic typing requires that it be possible to represent
+any value with a fixed length object, known as a \var{descriptor}.
+This fixed-length requirement is implicit in features such as:
+\begin{itemize}
+
+\item Data types (like \code{simple-vector}) that can contain any type
+ of object, and that can be destructively modified to contain
+ different objects (of possibly different types.)
+
+\item Functions that can be called with any type of argument, and that
+ can be redefined at run time.
+\end{itemize}
+
+In order to save space, a descriptor is invariably represented as a
+single word. Objects that can be directly represented in the
+descriptor itself are said to be \var{immediate}. Descriptors for
+objects larger than one word are in reality pointers to the memory
+actually containing the object.
+
+Representing objects using pointers has two major disadvantages:
+\begin{itemize}
+
+\item The memory pointed to must be allocated on the heap, so it must
+ eventually be freed by the garbage collector. Excessive heap
+ allocation of objects (or ``consing'') is inefficient in several
+ ways. \xlref{consing}.
+
+\item Representing an object in memory requires the compiler to emit
+ additional instructions to read the actual value in from memory, and
+ then to write the value back after operating on it.
+\end{itemize}
+
+The introduction of garbage collection makes things even worse, since
+the garbage collector must be able to determine whether a descriptor
+is an immediate object or a pointer. This requires that a few bits in
+each descriptor be dedicated to the garbage collector. The loss of a
+few bits doesn't seem like much, but it has a major efficiency
+implication\dash{}objects whose natural machine representation is a
+full word (integers and single-floats) cannot have an immediate
+representation. So the compiler is forced to use an unnatural
+immediate representation (such as \code{fixnum}) or a natural pointer
+representation (with the attendant consing overhead.)
+
+
+%%\node Non-Descriptor Representations, Variables, Descriptors, Numbers
+\subsection{Non-Descriptor Representations}
+\label{non-descriptor}
+\cindex{non-descriptor representations}
+\cindex{stack numbers}
+
+From the discussion above, we can see that the standard descriptor
+representation has many problems, the worst being number consing.
+\llisp{} compilers try to avoid these descriptor efficiency problems by using
+\var{non-descriptor} representations. A compiler that uses non-descriptor
+representations can compile this function so that it does no number consing:
+\begin{lisp}
+(defun multby (vec n)
+ (declare (type (simple-array single-float (*)) vec)
+ (single-float n))
+ (dotimes (i (length vec))
+ (setf (aref vec i)
+ (* n (aref vec i)))))
+\end{lisp}
+If a descriptor representation were used, each iteration of the loop might
+cons two floats and do three times as many memory references.
+
+As its negative definition suggests, the range of possible non-descriptor
+representations is large. The performance improvement from non-descriptor
+representation depends upon both the number of types that have non-descriptor
+representations and the number of contexts in which the compiler is forced to
+use a descriptor representation.
+
+Many \llisp{} compilers support non-descriptor representations for
+float types such as \code{single-float} and \code{double-float}
+(section \ref{float-efficiency}.) \python{} adds support for full
+word integers (\pxlref{word-integers}), characters
+(\pxlref{characters}) and system-area pointers (unconstrained
+pointers, \pxlref{system-area-pointers}.) Many \llisp{} compilers
+support non-descriptor representations for variables (section
+\ref{ND-variables}) and array elements (section
+\ref{specialized-array-types}.) \python{} adds support for
+non-descriptor arguments and return values in local call
+(\pxlref{number-local-call}) and structure slots (\pxlref{raw-slots}).
+
+%%\node Variables, Generic Arithmetic, Non-Descriptor Representations, Numbers
+\subsection{Variables}
+\label{ND-variables}
+\cpsubindex{variables}{non-descriptor}
+\cpsubindex{type declarations}{variable}
+\cpsubindex{efficiency}{of numeric variables}
+
+In order to use a non-descriptor representation for a variable or
+expression intermediate value, the compiler must be able to prove that
+the value is always of a particular type having a non-descriptor
+representation. Type inference (\pxlref{type-inference}) often needs
+some help from user-supplied declarations. The best kind of type
+declaration is a variable type declaration placed at the binding
+point:
+\begin{lisp}
+(let ((x (car l)))
+ (declare (single-float x))
+ ...)
+\end{lisp}
+Use of \code{the}, or of variable declarations not at the binding form
+is insufficient to allow non-descriptor representation of the
+variable\dash{}with these declarations it is not certain that all
+values of the variable are of the right type. It is sometimes useful
+to introduce a gratuitous binding that allows the compiler to change
+to a non-descriptor representation, like:
+\begin{lisp}
+(etypecase x
+ ((signed-byte 32)
+ (let ((x x))
+ (declare (type (signed-byte 32) x))
+ ...))
+ ...)
+\end{lisp}
+The declaration on the inner \code{x} is necessary here due to a phase
+ordering problem. Although the compiler will eventually prove that
+the outer \code{x} is a \w{\code{(signed-byte 32)}} within that
+\code{etypecase} branch, the inner \code{x} would have been optimized
+away by that time. Declaring the type makes let optimization more
+cautious.
+
+Note that storing a value into a global (or \code{special}) variable
+always forces a descriptor representation. Wherever possible, you
+should operate only on local variables, binding any referenced globals
+to local variables at the beginning of the function, and doing any
+global assignments at the end.
+
+Efficiency notes signal use of inefficient representations, so
+programmer's needn't continuously worry about the details of
+representation selection (\pxlref{representation-eff-note}.)
+
+%%\node Generic Arithmetic, Fixnums, Variables, Numbers
+\subsection{Generic Arithmetic}
+\label{generic-arithmetic}
+\cindex{generic arithmetic}
+\cpsubindex{arithmetic}{generic}
+\cpsubindex{numeric}{operation efficiency}
+
+In \clisp, arithmetic operations are \var{generic}.\footnote{As Steele
+ notes in CLTL II, this is a generic conception of generic, and is
+ not to be confused with the CLOS concept of a generic function.}
+The \code{+} function can be passed \code{fixnum}s, \code{bignum}s,
+\code{ratio}s, and various kinds of \code{float}s and
+\code{complex}es, in any combination. In addition to the inherent
+complexity of \code{bignum} and \code{ratio} operations, there is also
+a lot of overhead in just figuring out which operation to do and what
+contagion and canonicalization rules apply. The complexity of generic
+arithmetic is so great that it is inconceivable to open code it.
+Instead, the compiler does a function call to a generic arithmetic
+routine, consuming many instructions before the actual computation
+even starts.
+
+This is ridiculous, since even \llisp{} programs do a lot of
+arithmetic, and the hardware is capable of doing operations on small
+integers and floats with a single instruction. To get acceptable
+efficiency, the compiler special-cases uses of generic arithmetic that
+are directly implemented in the hardware. In order to open code
+arithmetic, several constraints must be met:
+\begin{itemize}
+
+\item All the arguments must be known to be a good type of number.
+
+\item The result must be known to be a good type of number.
+
+\item Any intermediate values such as the result of \w{\code{(+ a b)}}
+ in the call \w{\code{(+ a b c)}} must be known to be a good type of
+ number.
+
+\item All the above numbers with good types must be of the \var{same}
+ good type. Don't try to mix integers and floats or different float
+ formats.
+\end{itemize}
+
+The ``good types'' are \w{\code{(signed-byte 32)}},
+\w{\code{(unsigned-byte 32)}}, \code{single-float} and
+\code{double-float}. See sections \ref{fixnums}, \ref{word-integers}
+and \ref{float-efficiency} for more discussion of good numeric types.
+
+\code{float} is not a good type, since it might mean either
+\code{single-float} or \code{double-float}. \code{integer} is not a
+good type, since it might mean \code{bignum}. \code{rational} is not
+a good type, since it might mean \code{ratio}. Note however that
+these types are still useful in declarations, since type inference may
+be able to strengthen a weak declaration into a good one, when it
+would be at a loss if there was no declaration at all
+(\pxlref{type-inference}). The \code{integer} and
+\code{unsigned-byte} (or non-negative integer) types are especially
+useful in this regard, since they can often be strengthened to a good
+integer type.
+
+Arithmetic with \code{complex} numbers is inefficient in comparison to
+float and integer arithmetic. Complex numbers are always represented
+with a pointer descriptor (causing consing overhead), and complex
+arithmetic is always closed coded using the general generic arithmetic
+functions. But arithmetic with complex types such as:
+\begin{lisp}
+(complex float)
+(complex fixnum)
+\end{lisp}
+is still faster than \code{bignum} or \code{ratio} arithmetic, since the
+implementation is much simpler.
+
+Note: don't use \code{/} to divide integers unless you want the
+overhead of rational arithmetic. Use \code{truncate} even when you
+know that the arguments divide evenly.
+
+You don't need to remember all the rules for how to get open-coded
+arithmetic, since efficiency notes will tell you when and where there
+is a problem\dash{}\pxlref{efficiency-notes}.
+
+
+%%\node Fixnums, Word Integers, Generic Arithmetic, Numbers
+\subsection{Fixnums}
+\label{fixnums}
+\cindex{fixnums}
+\cindex{bignums}
+
+A fixnum is a ``FIXed precision NUMber''. In modern \llisp{}
+implementations, fixnums can be represented with an immediate
+descriptor, so operating on fixnums requires no consing or memory
+references. Clever choice of representations also allows some
+arithmetic operations to be done on fixnums using hardware supported
+word-integer instructions, somewhat reducing the speed penalty for
+using an unnatural integer representation.
+
+It is useful to distinguish the \code{fixnum} type from the fixnum
+representation of integers. In \python, there is absolutely nothing
+magical about the \code{fixnum} type in comparison to other finite
+integer types. \code{fixnum} is equivalent to (is defined with
+\code{deftype} to be) \w{\code{(signed-byte 30)}}. \code{fixnum} is
+simply the largest subset of integers that \i{can be represented}
+using an immediate fixnum descriptor.
+
+Unlike in other \clisp{} compilers, it is in no way desirable to use
+the \code{fixnum} type in declarations in preference to more
+restrictive integer types such as \code{bit}, \w{\code{(integer -43
+ 7)}} and \w{\code{(unsigned-byte 8)}}. Since Python does
+understand these integer types, it is preferable to use the more
+restrictive type, as it allows better type inference
+(\pxlref{operation-type-inference}.)
+
+The small, efficient fixnum is contrasted with bignum, or ``BIG
+NUMber''. This is another descriptor representation for integers, but
+this time a pointer representation that allows for arbitrarily large
+integers. Bignum operations are less efficient than fixnum
+operations, both because of the consing and memory reference overheads
+of a pointer descriptor, and also because of the inherent complexity
+of extended precision arithmetic. While fixnum operations can often
+be done with a single instruction, bignum operations are so complex
+that they are always done using generic arithmetic.
+
+A crucial point is that the compiler will use generic arithmetic if it
+can't \var{prove} that all the arguments, intermediate values, and
+results are fixnums. With bounded integer types such as
+\code{fixnum}, the result type proves to be especially problematical,
+since these types are not closed under common arithmetic operations
+such as \code{+}, \code{-}, \code{*} and \code{/}. For example,
+\w{\code{(1+ (the fixnum x))}} does not necessarily evaluate to a
+\code{fixnum}. Bignums were added to \llisp{} to get around this
+problem, but they really just transform the correctness problem ``if
+this add overflows, you will get the wrong answer'' to the efficiency
+problem ``if this add \var{might} overflow then your program will run
+slowly (because of generic arithmetic.)''
+
+There is just no getting around the fact that the hardware only
+directly supports short integers. To get the most efficient open
+coding, the compiler must be able to prove that the result is a good
+integer type. This is an argument in favor of using more restrictive
+integer types: \w{\code{(1+ (the fixnum x))}} may not always be a
+\code{fixnum}, but \w{\code{(1+ (the (unsigned-byte 8) x))}} always
+is. Of course, you can also assert the result type by putting in lots
+of \code{the} declarations and then compiling with \code{safety}
+\code{0}.
+
+%%\node Word Integers, Floating Point Efficiency, Fixnums, Numbers
+\subsection{Word Integers}
+\label{word-integers}
+\cindex{word integers}
+
+Python is unique in its efficient implementation of arithmetic
+on full-word integers through non-descriptor representations and open coding.
+Arithmetic on any subtype of these types:
+\begin{lisp}
+(signed-byte 32)
+(unsigned-byte 32)
+\end{lisp}
+is reasonably efficient, although subtypes of \code{fixnum} remain
+somewhat more efficient.
+
+If a word integer must be represented as a descriptor, then the
+\code{bignum} representation is used, with its associated consing
+overhead. The support for word integers in no way changes the
+language semantics, it just makes arithmetic on small bignums vastly
+more efficient. It is fine to do arithmetic operations with mixed
+\code{fixnum} and word integer operands; just declare the most
+specific integer type you can, and let the compiler decide what
+representation to use.
+
+In fact, to most users, the greatest advantage of word integer
+arithmetic is that it effectively provides a few guard bits on the
+fixnum representation. If there are missing assertions on
+intermediate values in a fixnum expression, the intermediate results
+can usually be proved to fit in a word. After the whole expression is
+evaluated, there will often be a fixnum assertion on the final result,
+allowing creation of a fixnum result without even checking for
+overflow.
+
+The remarks in section \ref{fixnums} about fixnum result type also
+apply to word integers; you must be careful to give the compiler
+enough information to prove that the result is still a word integer.
+This time, though, when we blow out of word integers we land in into
+generic bignum arithmetic, which is much worse than sleazing from
+\code{fixnum}s to word integers. Note that mixing
+\w{\code{(unsigned-byte 32)}} arguments with arguments of any signed
+type (such as \code{fixnum}) is a no-no, since the result might not be
+unsigned.
+
+%%\node Floating Point Efficiency, Specialized Arrays, Word Integers, Numbers
+\subsection{Floating Point Efficiency}
+\label{float-efficiency}
+\cindex{floating point efficiency}
+
+Arithmetic on objects of type \code{single-float} and \code{double-float} is
+efficiently implemented using non-descriptor representations and open coding.
+As for integer arithmetic, the arguments must be known to be of the same float
+type. Unlike for integer arithmetic, the results and intermediate values
+usually take care of themselves due to the rules of float contagion, i.e.
+\w{\code{(1+ (the single-float x))}} is always a \code{single-float}.
+
+Although they are not specially implemented, \code{short-float} and
+\code{long-float} are also acceptable in declarations, since they are
+synonyms for the \code{single-float} and \code{double-float} types,
+respectively.
+
+\begin{changebar}
+ Some versions of CMU Common Lisp include extra support for floating
+ point arithmetic. In particular, if \code{*features*} includes
+ \kwd{propagate-float-type}, list-style float type specifiers such as
+ \w{\code{(single-float 0.0 1.0)}} will be used to good effect.
+
+ For example, in this function,
+ \begin{example}
+ (defun square (x)
+ (declare (type (single-float 0f0 10f0)))
+ (* x x))
+ \end{example}
+ \Python{} can deduce that the
+ return type of the function \code{square} is \w{\code{(single-float
+ 0f0 100f0)}}.
+
+ Many union types are also supported so that
+ \begin{example}
+ (+ (the (or (integer 1 1) (integer 5 5)) x)
+ (the (or (integer 10 10) (integer 20 20)) y))
+ \end{example}
+ has the inferred type \code{(or (integer 11 11) (integer 15 15)
+ (integer 21 21) (integer 25 25))}. This also works for
+ floating-point numbers. Member types, however, are not because in
+ general the member elements do not have to be numbers. Thus,
+ instead of \code{(member 1 4)}, you should write \code{(or (integer
+ 1 1) (integer 4 4))}.
+
+ In addition, if \kwd{propagate-fun-type} is in \code{*features*},
+ \Python{} knows how to infer types for many mathematical functions
+ including square root, exponential and logarithmic functions,
+ trignometric functions and their inverses, and hyperbolic functions
+ and their inverses. For numeric code, this can greatly enhance
+ efficiency by allowing the compiler to use specialized versions of
+ the functions instead of the generic versions. The greatest benefit
+ of this type inference is determining that the result of the
+ function is real-valued number instead of possibly being
+ a complex-valued number.
+
+ For example, consider the function
+ \begin{example}
+ (defun fun (x)
+ (declare (type (single-float 0f0 100f0) x))
+ (values (sqrt x) (log x 10f0)))
+ \end{example}
+ With this declaration, the compiler can determine that the argument
+ to \code{sqrt} and \code{log} are always non-negative so that the result
+ is always a \code{single-float}. In fact, the return type for this
+ function is derived to be \code{(values (single-float 0f0 10f0)
+ (single-float * 2f0))}.
+
+ If the declaration were reduced to just \w{\code{(declare
+ single-float x)}}, the argument to \code{sqrt} and \code{log}
+ could be negative. This forces the use of the generic versions of
+ these functions because the result could be a complex number.
+
+ Union types are not yet supported for functions.
+
+ We note, however, that proper interval arithmetic is not fully
+ implemented in the compiler so the inferred types may be slightly in
+ error due to round-off errors. This round-off error could
+ accumulate to cause the compiler to erroneously deduce the result
+ type and cause code to be removed as being
+ unreachable.\footnote{This, however, has not actually happened, but
+ it is a possibility.}%
+ Thus, the declarations should only be precise enough for the
+ compiler to deduce that a real-valued argument to a function would
+ produce a real-valued result. The efficiency notes
+ (\pxlref{representation-eff-note}) from the compiler will guide you
+ on what declarations might be useful.
+\end{changebar}
+
+When a float must be represented as a descriptor, a pointer representation is
+used, creating consing overhead. For this reason, you should try to avoid
+situations (such as full call and non-specialized data structures) that force a
+descriptor representation. See sections \ref{specialized-array-types},
+\ref{raw-slots} and \ref{number-local-call}.
+
+\xlref{ieee-float} for information on the extensions to support IEEE
+floating point.
+
+%%\node Specialized Arrays, Specialized Structure Slots, Floating Point Efficiency, Numbers
+\subsection{Specialized Arrays}
+\label{specialized-array-types}
+\cindex{specialized array types}
+\cpsubindex{array types}{specialized}
+\cpsubindex{types}{specialized array}
+
+\clisp{} supports specialized array element types through the
+\kwd{element-type} argument to \code{make-array}. When an array has a
+specialized element type, only elements of that type can be stored in
+the array. From this restriction comes two major efficiency
+advantages:
+\begin{itemize}
+
+\item A specialized array can save space by packing multiple elements
+ into a single word. For example, a \code{base-char} array can have
+ 4 elements per word, and a \code{bit} array can have 32. This
+ space-efficient representation is possible because it is not
+ necessary to separately indicate the type of each element.
+
+\item The elements in a specialized array can be given the same
+ non-descriptor representation as the one used in registers and on
+ the stack, eliminating the need for representation conversions when
+ reading and writing array elements. For objects with pointer
+ descriptor representations (such as floats and word integers) there
+ is also a substantial consing reduction because it is not necessary
+ to allocate a new object every time an array element is modified.
+\end{itemize}
+
+
+These are the specialized element types currently supported:
+\begin{lisp}
+bit
+(unsigned-byte 2)
+(unsigned-byte 4)
+(unsigned-byte 8)
+(unsigned-byte 16)
+(unsigned-byte 32)
+base-character
+single-float
+double-float
+\end{lisp}
+\begin{changebar}
+%% New stuff
+Some versions of \cmucl{}\footnote{Currently, this includes the X86
+ and Sparc versions which are compiled with the \kwd{signed-array}
+ feature.} also support the following specialized element types:
+\begin{lisp}
+(signed-byte 8)
+(signed-byte 16)
+(signed-byte 30)
+(signed-byte 32)
+\end{lisp}
+\end{changebar}
+Although a \code{simple-vector} can hold any type of object, \true{}
+should still be considered a specialized array type, since arrays with
+element type \true{} are specialized to hold descriptors.
+
+
+
+When using non-descriptor representations, it is particularly
+important to make sure that array accesses are open-coded, since in
+addition to the generic operation overhead, efficiency is lost when
+the array element is converted to a descriptor so that it can be
+passed to (or from) the generic access routine. You can detect
+inefficient array accesses by enabling efficiency notes,
+\pxlref{efficiency-notes}. \xlref{array-types}.
+
+%%\node Specialized Structure Slots, Interactions With Local Call, Specialized Arrays, Numbers
+\subsection{Specialized Structure Slots}
+\label{raw-slots}
+\cpsubindex{structure types}{numeric slots}
+\cindex{specialized structure slots}
+
+Structure slots declared by the \kwd{type} \code{defstruct} slot option
+to have certain known numeric types are also given non-descriptor
+representations. These types (and subtypes of these types) are supported:
+\begin{lisp}
+(unsigned-byte 32)
+single-float
+double-float
+\end{lisp}
+
+The primary advantage of specialized slot representations is a large
+reduction spurious memory allocation and access overhead of programs
+that intensively use these types.
+
+%%\node Interactions With Local Call, Representation of Characters, Specialized Structure Slots, Numbers
+\subsection{Interactions With Local Call}
+\label{number-local-call}
+\cpsubindex{local call}{numeric operands}
+\cpsubindex{call}{numeric operands}
+\cindex{numbers in local call}
+
+Local call has many advantages (\pxlref{local-call}); one relevant to
+our discussion here is that local call extends the usefulness of
+non-descriptor representations. If the compiler knows from the
+argument type that an argument has a non-descriptor representation,
+then the argument will be passed in that representation. The easiest
+way to ensure that the argument type is known at compile time is to
+always declare the argument type in the called function, like:
+\begin{lisp}
+(defun 2+f (x)
+ (declare (single-float x))
+ (+ x 2.0))
+\end{lisp}
+The advantages of passing arguments and return values in a non-descriptor
+representation are the same as for non-descriptor representations in general:
+reduced consing and memory access (\pxlref{non-descriptor}.) This
+extends the applicative programming styles discussed in section
+\ref{local-call} to numeric code. Also, if source files are kept reasonably
+small, block compilation can be used to reduce number consing to a minimum.
+
+Note that non-descriptor return values can only be used with the known return
+convention (section \ref{local-call-return}.) If the compiler can't prove that
+a function always returns the same number of values, then it must use the
+unknown values return convention, which requires a descriptor representation.
+Pay attention to the known return efficiency notes to avoid number consing.
+
+%%\node Representation of Characters, , Interactions With Local Call, Numbers
+\subsection{Representation of Characters}
+\label{characters}
+\cindex{characters}
+\cindex{strings}
+
+Python also uses a non-descriptor representation for characters when
+convenient. This improves the efficiency of string manipulation, but is
+otherwise pretty invisible; characters have an immediate descriptor
+representation, so there is not a great penalty for converting a character to a
+descriptor. Nonetheless, it may sometimes be helpful to declare
+character-valued variables as \code{base-character}.
+
+%%\f
+%%\node General Efficiency Hints, Efficiency Notes, Numbers, Advanced Compiler Use and Efficiency Hints
+\section{General Efficiency Hints}
+\label{general-efficiency}
+\cpsubindex{efficiency}{general hints}
+
+This section is a summary of various implementation costs and ways to get
+around them. These hints are relatively unrelated to the use of the \python{}
+compiler, and probably also apply to most other \llisp{} implementations. In
+each section, there are references to related in-depth discussion.
+
+\begin{comment}
+* Compile Your Code::
+* Avoid Unnecessary Consing::
+* Complex Argument Syntax::
+* Mapping and Iteration::
+* Trace Files and Disassembly::
+\end{comment}
+
+%%\node Compile Your Code, Avoid Unnecessary Consing, General Efficiency Hints, General Efficiency Hints
+\subsection{Compile Your Code}
+\cpsubindex{compilation}{why to}
+
+At this point, the advantages of compiling code relative to running it
+interpreted probably need not be emphasized too much, but remember that
+in \cmucl, compiled code typically runs hundreds of times faster than
+interpreted code. Also, compiled (\code{fasl}) files load significantly faster
+than source files, so it is worthwhile compiling files which are loaded many
+times, even if the speed of the functions in the file is unimportant.
+
+Even disregarding the efficiency advantages, compiled code is as good or better
+than interpreted code. Compiled code can be debugged at the source level (see
+chapter \ref{debugger}), and compiled code does more error checking. For these
+reasons, the interpreter should be regarded mainly as an interactive command
+interpreter, rather than as a programming language implementation.
+
+\b{Do not} be concerned about the performance of your program until you
+see its speed compiled. Some techniques that make compiled code run
+faster make interpreted code run slower.
+
+%%\node Avoid Unnecessary Consing, Complex Argument Syntax, Compile Your Code, General Efficiency Hints
+\subsection{Avoid Unnecessary Consing}
+\label{consing}
+\cindex{consing}
+\cindex{garbage collection}
+\cindex{memory allocation}
+\cpsubindex{efficiency}{of memory use}
+
+
+Consing is another name for allocation of storage, as done by the
+\code{cons} function (hence its name.) \code{cons} is by no means the
+only function which conses\dash{}so does \code{make-array} and many
+other functions. Arithmetic and function call can also have hidden
+consing overheads. Consing hurts performance in the following ways:
+\begin{itemize}
+
+\item Consing reduces memory access locality, increasing paging
+ activity.
+
+\item Consing takes time just like anything else.
+
+\item Any space allocated eventually needs to be reclaimed, either by
+ garbage collection or by starting a new \code{lisp} process.
+\end{itemize}
+
+
+Consing is not undiluted evil, since programs do things other than
+consing, and appropriate consing can speed up the real work. It would
+certainly save time to allocate a vector of intermediate results that
+are reused hundreds of times. Also, if it is necessary to copy a
+large data structure many times, it may be more efficient to update
+the data structure non-destructively; this somewhat increases update
+overhead, but makes copying trivial.
+
+Note that the remarks in section \ref{efficiency-overview} about the
+importance of separating tuning from coding also apply to consing
+overhead. The majority of consing will be done by a small portion of
+the program. The consing hot spots are even less predictable than the
+CPU hot spots, so don't waste time and create bugs by doing
+unnecessary consing optimization. During initial coding, avoid
+unnecessary side-effects and cons where it is convenient. If
+profiling reveals a consing problem, \var{then} go back and fix the
+hot spots.
+
+\xlref{non-descriptor} for a discussion of how to avoid number consing
+in \python.
+
+
+%%\node Complex Argument Syntax, Mapping and Iteration, Avoid Unnecessary Consing, General Efficiency Hints
+\subsection{Complex Argument Syntax}
+\cpsubindex{argument syntax}{efficiency}
+\cpsubindex{efficiency}{of argument syntax}
+\cindex{keyword argument efficiency}
+\cindex{rest argument efficiency}
+
+Common Lisp has very powerful argument passing mechanisms. Unfortunately, two
+of the most powerful mechanisms, rest arguments and keyword arguments, have a
+significant performance penalty:
+\begin{itemize}
+
+\item
+With keyword arguments, the called function has to parse the supplied keywords
+by iterating over them and checking them against the desired keywords.
+
+\item
+With rest arguments, the function must cons a list to hold the arguments. If a
+function is called many times or with many arguments, large amounts of memory
+will be allocated.
+\end{itemize}
+
+Although rest argument consing is worse than keyword parsing, neither problem
+is serious unless thousands of calls are made to such a function. The use of
+keyword arguments is strongly encouraged in functions with many arguments or
+with interfaces that are likely to be extended, and rest arguments are often
+natural in user interface functions.
+
+Optional arguments have some efficiency advantage over keyword
+arguments, but their syntactic clumsiness and lack of extensibility
+has caused many \clisp{} programmers to abandon use of optionals
+except in functions that have obviously simple and immutable
+interfaces (such as \code{subseq}), or in functions that are only
+called in a few places. When defining an interface function to be
+used by other programmers or users, use of only required and keyword
+arguments is recommended.
+
+Parsing of \code{defmacro} keyword and rest arguments is done at
+compile time, so a macro can be used to provide a convenient syntax
+with an efficient implementation. If the macro-expanded form contains
+no keyword or rest arguments, then it is perfectly acceptable in inner
+loops.
+
+Keyword argument parsing overhead can also be avoided by use of inline
+expansion (\pxlref{inline-expansion}) and block compilation (section
+\ref{block-compilation}.)
+
+Note: the compiler open-codes most heavily used system functions which have
+keyword or rest arguments, so that no run-time overhead is involved.
+
+%%\node Mapping and Iteration, Trace Files and Disassembly, Complex Argument Syntax, General Efficiency Hints
+\subsection{Mapping and Iteration}
+\cpsubindex{mapping}{efficiency of}
+
+One of the traditional \llisp{} programming styles is a highly applicative one,
+involving the use of mapping functions and many lists to store intermediate
+results. To compute the sum of the square-roots of a list of numbers, one
+might say:
+\begin{lisp}
+(apply #'+ (mapcar #'sqrt list-of-numbers))
+\end{lisp}
+
+This programming style is clear and elegant, but unfortunately results
+in slow code. There are two reasons why:
+\begin{itemize}
+
+\item The creation of lists of intermediate results causes much
+ consing (see \ref{consing}).
+
+\item Each level of application requires another scan down the list.
+ Thus, disregarding other effects, the above code would probably take
+ twice as long as a straightforward iterative version.
+\end{itemize}
+
+
+An example of an iterative version of the same code:
+\begin{lisp}
+(do ((num list-of-numbers (cdr num))
+ (sum 0 (+ (sqrt (car num)) sum)))
+ ((null num) sum))
+\end{lisp}
+
+See sections \ref{variable-type-inference} and \ref{let-optimization}
+for a discussion of the interactions of iteration constructs with type
+inference and variable optimization. Also, section
+\ref{local-tail-recursion} discusses an applicative style of
+iteration.
+
+%%\node Trace Files and Disassembly, , Mapping and Iteration, General Efficiency Hints
+\subsection{Trace Files and Disassembly}
+\label{trace-files}
+\cindex{trace files}
+\cindex{assembly listing}
+\cpsubindex{listing files}{trace}
+\cindex{Virtual Machine (VM, or IR2) representation}
+\cindex{implicit continuation representation (IR1)}
+\cpsubindex{continuations}{implicit representation}
+
+In order to write efficient code, you need to know the relative costs
+of different operations. The main reason why writing efficient
+\llisp{} code is difficult is that there are so many operations, and
+the costs of these operations vary in obscure context-dependent ways.
+Although efficiency notes point out some problem areas, the only way
+to ensure generation of the best code is to look at the assembly code
+output.
+
+The \code{disassemble} function is a convenient way to get the assembly code for a
+function, but it can be very difficult to interpret, since the correspondence
+with the original source code is weak. A better (but more awkward) option is
+to use the \kwd{trace-file} argument to \code{compile-file} to generate a trace
+file.
+
+A trace file is a dump of the compiler's internal representations,
+including annotated assembly code. Each component in the program gets
+four pages in the trace file (separated by ``\code{$\hat{ }L$}''):
+\begin{itemize}
+
+\item The implicit-continuation (or IR1) representation of the
+ optimized source. This is a dump of the flow graph representation
+ used for ``source level'' optimizations. As you will quickly
+ notice, it is not really very close to the source. This
+ representation is not very useful to even sophisticated users.
+
+\item The Virtual Machine (VM, or IR2) representation of the program.
+ This dump represents the generated code as sequences of ``Virtual
+ OPerations'' (VOPs.) This representation is intermediate between
+ the source and the assembly code\dash{}each VOP corresponds fairly
+ directly to some primitive function or construct, but a given VOP
+ also has a fairly predictable instruction sequence. An operation
+ (such as \code{+}) may have multiple implementations with different
+ cost and applicability. The choice of a particular VOP such as
+ \code{+/fixnum} or \code{+/single-float} represents this choice of
+ implementation. Once you are familiar with it, the VM
+ representation is probably the most useful for determining what
+ implementation has been used.
+
+\item An assembly listing, annotated with the VOP responsible for
+ generating the instructions. This listing is useful for figuring
+ out what a VOP does and how it is implemented in a particular
+ context, but its large size makes it more difficult to read.
+
+\item A disassembly of the generated code, which has all
+ pseudo-operations expanded out, but is not annotated with VOPs.
+\end{itemize}
+
+
+Note that trace file generation takes much space and time, since the trace file
+is tens of times larger than the source file. To avoid huge confusing trace
+files and much wasted time, it is best to separate the critical program portion
+into its own file and then generate the trace file from this small file.
+
+%%\f
+%%\node Efficiency Notes, Profiling, General Efficiency Hints, Advanced Compiler Use and Efficiency Hints
+\section{Efficiency Notes}
+\label{efficiency-notes}
+\cindex{efficiency notes}
+\cpsubindex{notes}{efficiency}
+\cindex{tuning}
+
+Efficiency notes are messages that warn the user that the compiler has
+chosen a relatively inefficient implementation for some operation.
+Usually an efficiency note reflects the compiler's desire for more
+type information. If the type of the values concerned is known to the
+programmer, then additional declarations can be used to get a more
+efficient implementation.
+
+Efficiency notes are controlled by the
+\code{extensions:inhibit-warnings} (\pxlref{optimize-declaration})
+optimization quality. When \code{speed} is greater than
+\code{extensions:inhibit-warnings}, efficiency notes are enabled.
+Note that this implicitly enables efficiency notes whenever
+\code{speed} is increased from its default of \code{1}.
+
+Consider this program with an obscure missing declaration:
+\begin{lisp}
+(defun eff-note (x y z)
+ (declare (fixnum x y z))
+ (the fixnum (+ x y z)))
+\end{lisp}
+If compiled with \code{\w{(speed 3) (safety 0)}}, this note is given:
+\begin{example}
+In: DEFUN EFF-NOTE
+ (+ X Y Z)
+==>
+ (+ (+ X Y) Z)
+Note: Forced to do inline (signed-byte 32) arithmetic (cost 3).
+ Unable to do inline fixnum arithmetic (cost 2) because:
+ The first argument is a (INTEGER -1073741824 1073741822),
+ not a FIXNUM.
+\end{example}
+This efficiency note tells us that the result of the intermediate
+computation \code{\w{(+ x y)}} is not known to be a \code{fixnum}, so
+the addition of the intermediate sum to \code{z} must be done less
+efficiently. This can be fixed by changing the definition of
+\code{eff-note}:
+\begin{lisp}
+(defun eff-note (x y z)
+ (declare (fixnum x y z))
+ (the fixnum (+ (the fixnum (+ x y)) z)))
+\end{lisp}
+
+\begin{comment}
+* Type Uncertainty::
+* Efficiency Notes and Type Checking::
+* Representation Efficiency Notes::
+* Verbosity Control::
+\end{comment}
+
+%%\node Type Uncertainty, Efficiency Notes and Type Checking, Efficiency Notes, Efficiency Notes
+\subsection{Type Uncertainty}
+\cpsubindex{types}{uncertainty}
+\cindex{uncertainty of types}
+
+The main cause of inefficiency is the compiler's lack of adequate
+information about the types of function argument and result values.
+Many important operations (such as arithmetic) have an inefficient
+general (generic) case, but have efficient implementations that can
+usually be used if there is sufficient argument type information.
+
+Type efficiency notes are given when a value's type is uncertain.
+There is an important distinction between values that are \i{not
+ known} to be of a good type (uncertain) and values that are \i{known
+ not} to be of a good type. Efficiency notes are given mainly for
+the first case (uncertain types.) If it is clear to the compiler that
+that there is not an efficient implementation for a particular
+function call, then an efficiency note will only be given if the
+\code{extensions:inhibit-warnings} optimization quality is \code{0}
+(\pxlref{optimize-declaration}.)
+
+In other words, the default efficiency notes only suggest that you add
+declarations, not that you change the semantics of your program so
+that an efficient implementation will apply. For example, compilation
+of this form will not give an efficiency note:
+\begin{lisp}
+(elt (the list l) i)
+\end{lisp}
+even though a vector access is more efficient than indexing a list.
+
+%%\node Efficiency Notes and Type Checking, Representation Efficiency Notes, Type Uncertainty, Efficiency Notes
+\subsection{Efficiency Notes and Type Checking}
+\cpsubindex{type checking}{efficiency of}
+\cpsubindex{efficiency}{of type checking}
+\cpsubindex{optimization}{type check}
+
+It is important that the \code{eff-note} example above used
+\w{\code{(safety 0)}}. When type checking is enabled, you may get apparently
+spurious efficiency notes. With \w{\code{(safety 1)}}, the note has this extra
+line on the end:
+\begin{example}
+The result is a (INTEGER -1610612736 1610612733), not a FIXNUM.
+\end{example}
+This seems strange, since there is a \code{the} declaration on the result of that
+second addition.
+
+In fact, the inefficiency is real, and is a consequence of \python{}'s
+treating declarations as assertions to be verified. The compiler
+can't assume that the result type declaration is true\dash{}it must
+generate the result and then test whether it is of the appropriate
+type.
+
+In practice, this means that when you are tuning a program to run
+without type checks, you should work from the efficiency notes
+generated by unsafe compilation. If you want code to run efficiently
+with type checking, then you should pay attention to all the
+efficiency notes that you get during safe compilation. Since user
+supplied output type assertions (e.g., from \code{the}) are
+disregarded when selecting operation implementations for safe code,
+you must somehow give the compiler information that allows it to prove
+that the result truly must be of a good type. In our example, it
+could be done by constraining the argument types more:
+\begin{lisp}
+(defun eff-note (x y z)
+ (declare (type (unsigned-byte 18) x y z))
+ (+ x y z))
+\end{lisp}
+Of course, this declaration is acceptable only if the arguments to \code{eff-note}
+always \var{are} \w{\code{(unsigned-byte 18)}} integers.
+
+%%\node Representation Efficiency Notes, Verbosity Control, Efficiency Notes and Type Checking, Efficiency Notes
+\subsection{Representation Efficiency Notes}
+\label{representation-eff-note}
+\cindex{representation efficiency notes}
+\cpsubindex{efficiency notes}{for representation}
+\cindex{object representation efficiency notes}
+\cindex{stack numbers}
+\cindex{non-descriptor representations}
+\cpsubindex{descriptor representations}{forcing of}
+
+When operating on values that have non-descriptor representations
+(\pxlref{non-descriptor}), there can be a substantial time and consing
+penalty for converting to and from descriptor representations. For
+this reason, the compiler gives an efficiency note whenever it is
+forced to do a representation coercion more expensive than
+\varref{efficiency-note-cost-threshold}.
+
+Inefficient representation coercions may be due to type uncertainty,
+as in this example:
+\begin{lisp}
+(defun set-flo (x)
+ (declare (single-float x))
+ (prog ((var 0.0))
+ (setq var (gorp))
+ (setq var x)
+ (return var)))
+\end{lisp}
+which produces this efficiency note:
+\begin{example}
+In: DEFUN SET-FLO
+ (SETQ VAR X)
+Note: Doing float to pointer coercion (cost 13) from X to VAR.
+\end{example}
+The variable \code{var} is not known to always hold values of type
+\code{single-float}, so a descriptor representation must be used for its value.
+In sort of situation, and adding a declaration will eliminate the inefficiency.
+
+Often inefficient representation conversions are not due to type
+uncertainty\dash{}instead, they result from evaluating a
+non-descriptor expression in a context that requires a descriptor
+result:
+\begin{itemize}
+
+\item Assignment to or initialization of any data structure other than
+ a specialized array (\pxlref{specialized-array-types}), or
+
+\item Assignment to a \code{special} variable, or
+
+\item Passing as an argument or returning as a value in any function
+ call that is not a local call (\pxlref{number-local-call}.)
+\end{itemize}
+
+If such inefficient coercions appear in a ``hot spot'' in the program, data
+structures redesign or program reorganization may be necessary to improve
+efficiency. See sections \ref{block-compilation}, \ref{numeric-types} and
+\ref{profiling}.
+
+Because representation selection is done rather late in compilation,
+the source context in these efficiency notes is somewhat vague, making
+interpretation more difficult. This is a fairly straightforward
+example:
+\begin{lisp}
+(defun cf+ (x y)
+ (declare (single-float x y))
+ (cons (+ x y) t))
+\end{lisp}
+which gives this efficiency note:
+\begin{example}
+In: DEFUN CF+
+ (CONS (+ X Y) T)
+Note: Doing float to pointer coercion (cost 13), for:
+ The first argument of CONS.
+\end{example}
+The source context form is almost always the form that receives the value being
+coerced (as it is in the preceding example), but can also be the source form
+which generates the coerced value. Compiling this example:
+\begin{lisp}
+(defun if-cf+ (x y)
+ (declare (single-float x y))
+ (cons (if (grue) (+ x y) (snoc)) t))
+\end{lisp}
+produces this note:
+\begin{example}
+In: DEFUN IF-CF+
+ (+ X Y)
+Note: Doing float to pointer coercion (cost 13).
+\end{example}
+
+In either case, the note's text explanation attempts to include
+additional information about what locations are the source and
+destination of the coercion. Here are some example notes:
+\begin{example}
+ (IF (GRUE) X (SNOC))
+Note: Doing float to pointer coercion (cost 13) from X.
+
+ (SETQ VAR X)
+Note: Doing float to pointer coercion (cost 13) from X to VAR.
+\end{example}
+Note that the return value of a function is also a place to which coercions may
+have to be done:
+\begin{example}
+ (DEFUN F+ (X Y) (DECLARE (SINGLE-FLOAT X Y)) (+ X Y))
+Note: Doing float to pointer coercion (cost 13) to "<return value>".
+\end{example}
+Sometimes the compiler is unable to determine a name for the source or
+destination, in which case the source context is the only clue.
+
+
+%%\node Verbosity Control, , Representation Efficiency Notes, Efficiency Notes
+\subsection{Verbosity Control}
+\cpsubindex{verbosity}{of efficiency notes}
+\cpsubindex{efficiency notes}{verbosity}
+
+These variables control the verbosity of efficiency notes:
+
+\begin{defvar}{}{efficiency-note-cost-threshold}
+
+ Before printing some efficiency notes, the compiler compares the
+ value of this variable to the difference in cost between the chosen
+ implementation and the best potential implementation. If the
+ difference is not greater than this limit, then no note is printed.
+ The units are implementation dependent; the initial value suppresses
+ notes about ``trivial'' inefficiencies. A value of \code{1} will
+ note any inefficiency.
+\end{defvar}
+
+\begin{defvar}{}{efficiency-note-limit}
+
+ When printing some efficiency notes, the compiler reports possible
+ efficient implementations. The initial value of \code{2} prevents
+ excessively long efficiency notes in the common case where there is
+ no type information, so all implementations are possible.
+\end{defvar}
+
+%%\f
+%%\node Profiling, , Efficiency Notes, Advanced Compiler Use and Efficiency Hints
+\section{Profiling}
+
+\cindex{profiling}
+\cindex{timing}
+\cindex{consing}
+\cindex{tuning}
+\label{profiling}
+
+The first step in improving a program's performance is to profile the
+activity of the program to find where it spends its time. The best
+way to do this is to use the profiling utility found in the
+\code{profile} package. This package provides a macro \code{profile}
+that encapsulates functions with statistics gathering code.
+
+\begin{comment}
+* Profile Interface::
+* Profiling Techniques::
+* Nested or Recursive Calls::
+* Clock resolution::
+* Profiling overhead::
+* Additional Timing Utilities::
+* A Note on Timing::
+* Benchmarking Techniques::
+\end{comment}
+
+%%\node Profile Interface, Profiling Techniques, Profiling, Profiling
+\subsection{Profile Interface}
+
+\begin{defvar}{profile:}{timed-functions}
+
+ This variable holds a list of all functions that are currently being
+ profiled.
+\end{defvar}
+
+\begin{defmac}{profile:}{profile}{%
+ \args{\mstar{\var{name} \mor \kwd{callers} \code{t}}}}
+
+ This macro wraps profiling code around the named functions. As in
+ \code{trace}, the \var{name}s are not evaluated. If a function is
+ already profiled, then the function is unprofiled and reprofiled
+ (useful to notice function redefinition.) A warning is printed for
+ each name that is not a defined function.
+
+ If \kwd{callers \var{t}} is specified, then each function that calls
+ this function is recorded along with the number of calls made.
+\end{defmac}
+
+\begin{defmac}{profile:}{unprofile}{%
+ \args{\mstar{\var{name}}}}
+
+ This macro removes profiling code from the named functions. If no
+ \var{name}s are supplied, all currently profiled functions are
+ unprofiled.
+\end{defmac}
+
+\begin{changebar}
+ \begin{defmac}{profile:}{profile-all}{%
+ \args{\keys{\kwd{package} \kwd{callers-p}}}}
+
+ This macro in effect calls \code{profile:profile} for each
+ function in the specified package which defaults to
+ \code{*package*}. \kwd{callers-p} has the same meaning as in
+ \code{profile:profile}.
+ \end{defmac}
+\end{changebar}
+
+\begin{defmac}{profile:}{report-time}{\args{\mstar{\var{name}}}}
+
+ This macro prints a report for each \var{name}d function of the
+ following information:
+ \begin{itemize}
+ \item The total CPU time used in that function for all calls,
+
+ \item the total number of bytes consed in that function for all
+ calls,
+
+ \item the total number of calls,
+
+ \item the average amount of CPU time per call.
+ \end{itemize}
+ Summary totals of the CPU time, consing and calls columns are
+ printed. An estimate of the profiling overhead is also printed (see
+ below). If no \var{name}s are supplied, then the times for all
+ currently profiled functions are printed.
+\end{defmac}
+
+\begin{defmac}{}{reset-time}{\args{\mstar{\var{name}}}}
+
+ This macro resets the profiling counters associated with the
+ \var{name}d functions. If no \var{name}s are supplied, then all
+ currently profiled functions are reset.
+\end{defmac}
+
+
+%%\node Profiling Techniques, Nested or Recursive Calls, Profile Interface, Profiling
+\subsection{Profiling Techniques}
+
+Start by profiling big pieces of a program, then carefully choose which
+functions close to, but not in, the inner loop are to be profiled next.
+Avoid profiling functions that are called by other profiled functions, since
+this opens the possibility of profiling overhead being included in the reported
+times.
+
+If the per-call time reported is less than 1/10 second, then consider the clock
+resolution and profiling overhead before you believe the time. It may be that
+you will need to run your program many times in order to average out to a
+higher resolution.
+
+
+%%\node Nested or Recursive Calls, Clock resolution, Profiling Techniques, Profiling
+\subsection{Nested or Recursive Calls}
+
+The profiler attempts to compensate for nested or recursive calls. Time and
+consing overhead will be charged to the dynamically innermost (most recent)
+call to a profiled function. So profiling a subfunction of a profiled function
+will cause the reported time for the outer function to decrease. However if an
+inner function has a large number of calls, some of the profiling overhead may
+``leak'' into the reported time for the outer function. In general, be wary of
+profiling short functions that are called many times.
+
+%%\node Clock resolution, Profiling overhead, Nested or Recursive Calls, Profiling
+\subsection{Clock resolution}
+
+Unless you are very lucky, the length of your machine's clock ``tick'' is
+probably much longer than the time it takes simple function to run. For
+example, on the IBM RT, the clock resolution is 1/50 second. This means that
+if a function is only called a few times, then only the first couple decimal
+places are really meaningful.
+
+Note however, that if a function is called many times, then the statistical
+averaging across all calls should result in increased resolution. For example,
+on the IBM RT, if a function is called a thousand times, then a resolution of
+tens of microseconds can be expected.
+
+%%\node Profiling overhead, Additional Timing Utilities, Clock resolution, Profiling
+\subsection{Profiling overhead}
+
+The added profiling code takes time to run every time that the profiled
+function is called, which can disrupt the attempt to collect timing
+information. In order to avoid serious inflation of the times for functions
+that take little time to run, an estimate of the overhead due to profiling is
+subtracted from the times reported for each function.
+
+Although this correction works fairly well, it is not totally accurate,
+resulting in times that become increasingly meaningless for functions with
+short runtimes. This is only a concern when the estimated profiling overhead
+is many times larger than reported total CPU time.
+
+The estimated profiling overhead is not represented in the reported total CPU
+time. The sum of total CPU time and the estimated profiling overhead should be
+close to the total CPU time for the entire profiling run (as determined by the
+\code{time} macro.) Time unaccounted for is probably being used by functions that
+you forgot to profile.
+
+%%\node Additional Timing Utilities, A Note on Timing, Profiling overhead, Profiling
+\subsection{Additional Timing Utilities}
+
+\begin{defmac}{}{time}{ \args{\var{form}}}
+
+ This macro evaluates \var{form}, prints some timing and memory
+ allocation information to \code{*trace-output*}, and returns any
+ values that \var{form} returns. The timing information includes
+ real time, user run time, and system run time. This macro executes
+ a form and reports the time and consing overhead. If the
+ \code{time} form is not compiled (e.g. it was typed at top-level),
+ then \code{compile} will be called on the form to give more accurate
+ timing information. If you really want to time interpreted speed,
+ you can say:
+\begin{lisp}
+(time (eval '\var{form}))
+\end{lisp}
+Things that execute fairly quickly should be timed more than once,
+since there may be more paging overhead in the first timing. To
+increase the accuracy of very short times, you can time multiple
+evaluations:
+\begin{lisp}
+(time (dotimes (i 100) \var{form}))
+\end{lisp}
+\end{defmac}
+
+\begin{defun}{extensions:}{get-bytes-consed}{}
+
+ This function returns the number of bytes allocated since the first
+ time you called it. The first time it is called it returns zero.
+ The above profiling routines use this to report consing information.
+\end{defun}
+
+\begin{defvar}{extensions:}{gc-run-time}
+
+ This variable accumulates the run-time consumed by garbage
+ collection, in the units returned by
+ \findexed{get-internal-run-time}.
+\end{defvar}
+
+\begin{defconst}{}{internal-time-units-per-second}
+The value of internal-time-units-per-second is 100.
+\end{defconst}
+
+%%\node A Note on Timing, Benchmarking Techniques, Additional Timing Utilities, Profiling
+\subsection{A Note on Timing}
+\cpsubindex{CPU time}{interpretation of}
+\cpsubindex{run time}{interpretation of}
+\cindex{interpretation of run time}
+
+There are two general kinds of timing information provided by the
+\code{time} macro and other profiling utilities: real time and run
+time. Real time is elapsed, wall clock time. It will be affected in
+a fairly obvious way by any other activity on the machine. The more
+other processes contending for CPU and memory, the more real time will
+increase. This means that real time measurements are difficult to
+replicate, though this is less true on a dedicated workstation. The
+advantage of real time is that it is real. It tells you really how
+long the program took to run under the benchmarking conditions. The
+problem is that you don't know exactly what those conditions were.
+
+Run time is the amount of time that the processor supposedly spent
+running the program, as opposed to waiting for I/O or running other
+processes. ``User run time'' and ``system run time'' are numbers
+reported by the Unix kernel. They are supposed to be a measure of how
+much time the processor spent running your ``user'' program (which
+will include GC overhead, etc.), and the amount of time that the
+kernel spent running ``on your behalf.''
+
+Ideally, user time should be totally unaffected by benchmarking
+conditions; in reality user time does depend on other system activity,
+though in rather non-obvious ways.
+
+System time will clearly depend on benchmarking conditions. In Lisp
+benchmarking, paging activity increases system run time (but not by as much
+as it increases real time, since the kernel spends some time waiting for
+the disk, and this is not run time, kernel or otherwise.)
+
+In my experience, the biggest trap in interpreting kernel/user run time is
+to look only at user time. In reality, it seems that the \var{sum} of kernel
+and user time is more reproducible. The problem is that as system activity
+increases, there is a spurious \var{decrease} in user run time. In effect, as
+paging, etc., increases, user time leaks into system time.
+
+So, in practice, the only way to get truly reproducible results is to run
+with the same competing activity on the system. Try to run on a machine
+with nobody else logged in, and check with ``ps aux'' to see if there are any
+system processes munching large amounts of CPU or memory. If the ratio
+between real time and the sum of user and system time varies much between
+runs, then you have a problem.
+
+%%\node Benchmarking Techniques, , A Note on Timing, Profiling
+\subsection{Benchmarking Techniques}
+\cindex{benchmarking techniques}
+
+Given these imperfect timing tools, how do should you do benchmarking? The
+answer depends on whether you are trying to measure improvements in the
+performance of a single program on the same hardware, or if you are trying to
+compare the performance of different programs and/or different hardware.
+
+For the first use (measuring the effect of program modifications with
+constant hardware), you should look at \var{both} system+user and real time to
+understand what effect the change had on CPU use, and on I/O (including
+paging.) If you are working on a CPU intensive program, the change in
+system+user time will give you a moderately reproducible measure of
+performance across a fairly wide range of system conditions. For a CPU
+intensive program, you can think of system+user as ``how long it would have
+taken to run if I had my own machine.'' So in the case of comparing CPU
+intensive programs, system+user time is relatively real, and reasonable to
+use.
+
+For programs that spend a substantial amount of their time paging, you
+really can't predict elapsed time under a given operating condition without
+benchmarking in that condition. User or system+user time may be fairly
+reproducible, but it is also relatively meaningless, since in a paging or
+I/O intensive program, the program is spending its time waiting, not
+running, and system time and user time are both measures of run time.
+A change that reduces run time might increase real time by increasing
+paging.
+
+Another common use for benchmarking is comparing the performance of
+the same program on different hardware. You want to know which
+machine to run your program on. For comparing different machines
+(operating systems, etc.), the only way to compare that makes sense is
+to set up the machines in \var{exactly} the way that they will
+\var{normally} be run, and then measure \var{real} time. If the
+program will normally be run along with X, then run X. If the program
+will normally be run on a dedicated workstation, then be sure nobody
+else is on the benchmarking machine. If the program will normally be
+run on a machine with three other Lisp jobs, then run three other Lisp
+jobs. If the program will normally be run on a machine with 8meg of
+memory, then run with 8meg. Here, ``normal'' means ``normal for that
+machine''. If you the choice of an unloaded RT or a heavily loaded
+PMAX, do your benchmarking on an unloaded RT and a heavily loaded
+PMAX.
+
+If you have a program you believe to be CPU intensive, then you might be
+tempted to compare ``run'' times across systems, hoping to get a meaningful
+result even if the benchmarking isn't done under the expected running
+condition. Don't to this, for two reasons:
+\begin{itemize}
+
+\item The operating systems might not compute run time in the same
+ way.
+
+\item Under the real running condition, the program might not be CPU
+ intensive after all.
+\end{itemize}
+
+
+In the end, only real time means anything\dash{}it is the amount of time you
+have to wait for the result. The only valid uses for run time are:
+\begin{itemize}
+
+\item To develop insight into the program. For example, if run time
+ is much less than elapsed time, then you are probably spending lots
+ of time paging.
+
+\item To evaluate the relative performance of CPU intensive programs
+ in the same environment.
+\end{itemize}
+
+
+\hide{File:/afs/cs.cmu.edu/project/clisp/hackers/ram/docs/cmu-user/Unix.ms}
+
+
+
+%%\node UNIX Interface, Event Dispatching with SERVE-EVENT, Advanced Compiler Use and Efficiency Hints, Top
+\chapter{UNIX Interface}
+\label{unix-interface}
+\begin{center}
+\b{By Robert MacLachlan, Skef Wholey,}
+\end{center}
+\begin{center}
+\b{Bill Chiles, and William Lott}
+\end{center}
+
+CMU Common Lisp attempts to make the full power of the underlying
+environment available to the Lisp programmer. This is done using
+combination of hand-coded interfaces and foreign function calls to C
+libraries. Although the techniques differ, the style of interface is
+similar. This chapter provides an overview of the facilities
+available and general rules for using them, as well as describing
+specific features in detail. It is assumed that the reader has a
+working familiarity with Mach, Unix and X, as well as access to the
+standard system documentation.
+
+\begin{comment}
+* Reading the Command Line::
+* Lisp Equivalents for C Routines::
+* Type Translations::
+* System Area Pointers::
+* Unix System Calls::
+* File Descriptor Streams::
+* Making Sense of Mach Return Codes::
+* Unix Interrupts::
+\end{comment}
+
+
+%%\node Reading the Command Line, Useful Variables, UNIX Interface, UNIX Interface
+\section{Reading the Command Line}
+
+The shell parses the command line with which Lisp is invoked, and
+passes a data structure containing the parsed information to Lisp.
+This information is then extracted from that data structure and put
+into a set of Lisp data structures.
+
+\begin{defvar}{extensions:}{command-line-strings}
+ \defvarx[extensions:]{command-line-utility-name}
+ \defvarx[extensions:]{command-line-words}
+ \defvarx[extensions:]{command-line-switches}
+
+ The value of \code{*command-line-words*} is a list of strings that
+ make up the command line, one word per string. The first word on
+ the command line, i.e. the name of the program invoked (usually
+ \code{lisp}) is stored in \code{*command-line-utility-name*}. The
+ value of \code{*command-line-switches*} is a list of
+ \code{command-line-switch} structures, with a structure for each
+ word on the command line starting with a hyphen. All the command
+ line words between the program name and the first switch are stored
+ in \code{*command-line-words*}.
+\end{defvar}
+
+The following functions may be used to examine \code{command-line-switch}
+structures.
+\begin{defun}{extensions:}{cmd-switch-name}{\args{\var{switch}}}
+
+ Returns the name of the switch, less the preceding hyphen and
+ trailing equal sign (if any).
+\end{defun}
+\begin{defun}{extensions:}{cmd-switch-value}{\args{\var{switch}}}
+
+ Returns the value designated using an embedded equal sign, if any.
+ If the switch has no equal sign, then this is null.
+\end{defun}
+\begin{defun}{extensions:}{cmd-switch-words}{\args{\var{switch}}}
+
+ Returns a list of the words between this switch and the next switch
+ or the end of the command line.
+\end{defun}
+\begin{defun}{extensions:}{cmd-switch-arg}{\args{\var{switch}}}
+
+ Returns the first non-null value from \code{cmd-switch-value}, the
+ first element in \code{cmd-switch-words}, or the first word in
+ \var{command-line-words}.
+\end{defun}
+
+\begin{defun}{extensions:}{get-command-line-switch}{\args{\var{sname}}}
+
+ This function takes the name of a switch as a string and returns the
+ value of the switch given on the command line. If no value was
+ specified, then any following words are returned. If there are no
+ following words, then \true{} is returned. If the switch was not
+ specified, then \false{} is returned.
+\end{defun}
+
+\begin{defmac}{extensions:}{defswitch}{%
+ \args{\var{name} \ampoptional{} \var{function}}}
+
+ This macro causes \var{function} to be called when the switch
+ \var{name} appears in the command line. Name is a simple-string
+ that does not begin with a hyphen (unless the switch name really
+ does begin with one.)
+
+ If \var{function} is not supplied, then the switch is parsed into
+ \var{command-line-switches}, but otherwise ignored. This suppresses
+ the undefined switch warning which would otherwise take place. THe
+ warning can also be globally suppressed by
+ \var{complain-about-illegal-switches}.
+\end{defmac}
+
+%%\node Useful Variables, Lisp Equivalents for C Routines, Reading the Command Line, UNIX Interface
+
+\section{Useful Variables}
+
+\begin{defvar}{system:}{stdin}
+ \defvarx[system:]{stdout} \defvarx[system:]{stderr}
+
+ Streams connected to the standard input, output and error file
+ descriptors.
+\end{defvar}
+
+\begin{defvar}{system:}{tty}
+
+ A stream connected to \file{/dev/tty}.
+\end{defvar}
+
+%%\node Lisp Equivalents for C Routines, Type Translations, Useful Variables, UNIX Interface
+\section{Lisp Equivalents for C Routines}
+
+The UNIX documentation describes the system interface in terms of C
+procedure headers. The corresponding Lisp function will have a somewhat
+different interface, since Lisp argument passing conventions and
+datatypes are different.
+
+The main difference in the argument passing conventions is that Lisp does not
+support passing values by reference. In Lisp, all argument and results are
+passed by value. Interface functions take some fixed number of arguments and
+return some fixed number of values. A given ``parameter'' in the C
+specification will appear as an argument, return value, or both, depending on
+whether it is an In parameter, Out parameter, or In/Out parameter. The basic
+transformation one makes to come up with the Lisp equivalent of a C routine is
+to remove the Out parameters from the call, and treat them as extra return
+values. In/Out parameters appear both as arguments and return values. Since
+Out and In/Out parameters are only conventions in C, you must determine the
+usage from the documentation.
+
+
+Thus, the C routine declared as
+\begin{example}
+kern_return_t lookup(servport, portsname, portsid)
+ port servport;
+ char *portsname;
+ int *portsid; /* out */
+ {
+ ...
+ *portsid = <expression to compute portsid field>
+ return(KERN_SUCCESS);
+ }
+\end{example}
+has as its Lisp equivalent something like
+\begin{lisp}
+(defun lookup (ServPort PortsName)
+ ...
+ (values
+ success
+ <expression to compute portsid field>))
+\end{lisp}
+If there are multiple out or in-out arguments, then there are multiple
+additional returns values.
+
+Fortunately, CMU Common Lisp programmers rarely have to worry about the
+nuances of this translation process, since the names of the arguments and
+return values are documented in a way so that the \code{describe} function
+(and the \Hemlock{} \code{Describe Function Call} command, invoked with
+\b{C-M-Shift-A}) will list this information. Since the names of arguments
+and return values are usually descriptive, the information that
+\code{describe} prints is usually all one needs to write a
+call. Most programmers use this on-line documentation nearly
+all of the time, and thereby avoid the need to handle bulky
+manuals and perform the translation from barbarous tongues.
+
+%%\node Type Translations, System Area Pointers, Lisp Equivalents for C Routines, UNIX Interface
+\section{Type Translations}
+\cindex{aliens}
+\cpsubindex{types}{alien}
+\cpsubindex{types}{foreign language}
+
+Lisp data types have very different representations from those used by
+conventional languages such as C. Since the system interfaces are
+designed for conventional languages, Lisp must translate objects to and
+from the Lisp representations. Many simple objects have a direct
+translation: integers, characters, strings and floating point numbers
+are translated to the corresponding Lisp object. A number of types,
+however, are implemented differently in Lisp for reasons of clarity and
+efficiency.
+
+Instances of enumerated types are expressed as keywords in Lisp.
+Records, arrays, and pointer types are implemented with the \Alien{}
+facility (see page \pageref{aliens}.) Access functions are defined
+for these types which convert fields of records, elements of arrays,
+or data referenced by pointers into Lisp objects (possibly another
+object to be referenced with another access function).
+
+One should dispose of \Alien{} objects created by constructor
+functions or returned from remote procedure calls when they are no
+longer of any use, freeing the virtual memory associated with that
+object. Since \alien{}s contain pointers to non-Lisp data, the
+garbage collector cannot do this itself. If the memory
+was obtained from \funref{make-alien} or from a foreign function call
+to a routine that used \code{malloc}, then \funref{free-alien} should
+be used. If the \alien{} was created
+using MACH memory allocation (e.g. \code{vm\_allocate}), then the
+storage should be freed using \code{vm\_deallocate}.
+
+%%\node System Area Pointers, Unix System Calls, Type Translations, UNIX Interface
+\section{System Area Pointers}
+\label{system-area-pointers}
+
+\cindex{pointers}\cpsubindex{malloc}{C function}\cpsubindex{free}{C function}
+Note that in some cases an address is represented by a Lisp integer, and in
+other cases it is represented by a real pointer. Pointers are usually used
+when an object in the current address space is being referred to. The MACH
+virtual memory manipulation calls must use integers, since in principle the
+address could be in any process, and Lisp cannot abide random pointers.
+Because these types are represented differently in Lisp, one must explicitly
+coerce between these representations.
+
+System Area Pointers (SAPs) provide a mechanism that bypasses the
+\Alien{} type system and accesses virtual memory directly. A SAP is a
+raw byte pointer into the \code{lisp} process address space. SAPs are
+represented with a pointer descriptor, so SAP creation can cause
+consing. However, the compiler uses a non-descriptor representation
+for SAPs when possible, so the consing overhead is generally minimal.
+\xlref{non-descriptor}.
+
+\begin{defun}{system:}{sap-int}{\args{\var{sap}}}
+ \defunx[system:]{int-sap}{\args{\var{int}}}
+
+ The function \code{sap-int} is used to generate an integer
+ corresponding to the system area pointer, suitable for passing to
+ the kernel interfaces (which want all addresses specified as
+ integers). The function \code{int-sap} is used to do the opposite
+ conversion. The integer representation of a SAP is the byte offset
+ of the SAP from the start of the address space.
+\end{defun}
+
+\begin{defun}{system:}{sap+}{\args{\var{sap} \var{offset}}}
+
+ This function adds a byte \var{offset} to \var{sap}, returning a new
+ SAP.
+\end{defun}
+
+\begin{defun}{system:}{sap-ref-8}{\args{\var{sap} \var{offset}}}
+ \defunx[system:]{sap-ref-16}{\args{\var{sap} \var{offset}}}
+ \defunx[system:]{sap-ref-32}{\args{\var{sap} \var{offset}}}
+
+ These functions return the 8, 16 or 32 bit unsigned integer at
+ \var{offset} from \var{sap}. The \var{offset} is always a byte
+ offset, regardless of the number of bits accessed. \code{setf} may
+ be used with the these functions to deposit values into virtual
+ memory.
+\end{defun}
+
+\begin{defun}{system:}{signed-sap-ref-8}{\args{\var{sap} \var{offset}}}
+ \defunx[system:]{signed-sap-ref-16}{\args{\var{sap} \var{offset}}}
+ \defunx[system:]{signed-sap-ref-32}{\args{\var{sap} \var{offset}}}
+
+ These functions are the same as the above unsigned operations,
+ except that they sign-extend, returning a negative number if the
+ high bit is set.
+\end{defun}
+
+%%\node Unix System Calls, File Descriptor Streams, System Area Pointers, UNIX Interface
+\section{Unix System Calls}
+
+You probably won't have much cause to use them, but all the Unix system
+calls are available. The Unix system call functions are in the
+\code{Unix} package. The name of the interface for a particular system
+call is the name of the system call prepended with \code{unix-}. The
+system usually defines the associated constants without any prefix name.
+To find out how to use a particular system call, try using
+\code{describe} on it. If that is unhelpful, look at the source in
+\file{syscall.lisp} or consult your system maintainer.
+
+The Unix system calls indicate an error by returning \false{} as the
+first value and the Unix error number as the second value. If the call
+succeeds, then the first value will always be non-\nil, often \code{t}.
+
+\begin{defun}{Unix:}{get-unix-error-msg}{\args{\var{error}}}
+
+ This function returns a string describing the Unix error number
+ \var{error}.
+\end{defun}
+
+%%\node File Descriptor Streams, Making Sense of Mach Return Codes, Unix System Calls, UNIX Interface
+\section{File Descriptor Streams}
+
+Many of the UNIX system calls return file descriptors. Instead of using other
+UNIX system calls to perform I/O on them, you can create a stream around them.
+For this purpose, fd-streams exist. See also \funref{read-n-bytes}.
+
+\begin{defun}{system:}{make-fd-stream}{%
+ \args{\var{descriptor}} \keys{\kwd{input} \kwd{output}
+ \kwd{element-type}} \morekeys{\kwd{buffering} \kwd{name}
+ \kwd{file} \kwd{original}} \yetmorekeys{\kwd{delete-original}
+ \kwd{auto-close}} \yetmorekeys{\kwd{timeout} \kwd{pathname}}}
+
+ This function creates a file descriptor stream using
+ \var{descriptor}. If \kwd{input} is non-\nil, input operations are
+ allowed. If \kwd{output} is non-\nil, output operations are
+ allowed. The default is input only. These keywords are defined:
+ \begin{Lentry}
+ \item[\kwd{element-type}] is the type of the unit of transaction for
+ the stream, which defaults to \code{string-char}. See the Common
+ Lisp description of \code{open} for valid values.
+
+ \item[\kwd{buffering}] is the kind of output buffering desired for
+ the stream. Legal values are \kwd{none} for no buffering,
+ \kwd{line} for buffering up to each newline, and \kwd{full} for
+ full buffering.
+
+ \item[\kwd{name}] is a simple-string name to use for descriptive
+ purposes when the system prints an fd-stream. When printing
+ fd-streams, the system prepends the streams name with \code{Stream
+ for }. If \var{name} is unspecified, it defaults to a string
+ containing \var{file} or \var{descriptor}, in order of preference.
+
+ \item[\kwd{file}, \kwd{original}] \var{file} specifies the defaulted
+ namestring of the associated file when creating a file stream
+ (must be a \code{simple-string}). \var{original} is the
+ \code{simple-string} name of a backup file containing the original
+ contents of \var{file} while writing \var{file}.
+
+ When you abort the stream by passing \true{} to \code{close} as
+ the second argument, if you supplied both \var{file} and
+ \var{original}, \code{close} will rename the \var{original} name
+ to the \var{file} name. When you \code{close} the stream
+ normally, if you supplied \var{original}, and
+ \var{delete-original} is non-\nil, \code{close} deletes
+ \var{original}. If \var{auto-close} is true (the default), then
+ \var{descriptor} will be closed when the stream is garbage
+ collected.
+
+ \item[\kwd{pathname}]: The original pathname passed to open and
+ returned by \code{pathname}; not defaulted or translated.
+
+ \item[\kwd{timeout}] if non-null, then \var{timeout} is an integer
+ number of seconds after which an input wait should time out. If a
+ read does time out, then the \code{system:io-timeout} condition is
+ signalled.
+ \end{Lentry}
+\end{defun}
+
+\begin{defun}{system:}{fd-stream-p}{\args{\var{object}}}
+
+ This function returns \true{} if \var{object} is an fd-stream, and
+ \nil{} if not. Obsolete: use the portable \code{(typep x
+ 'file-stream)}.
+\end{defun}
+
+\begin{defun}{system:}{fd-stream-fd}{\args{\var{stream}}}
+
+ This returns the file descriptor associated with \var{stream}.
+\end{defun}
+
+
+%%\node Making Sense of Mach Return Codes, Unix Interrupts, File Descriptor Streams, UNIX Interface
+\section{Making Sense of Mach Return Codes}
+
+Whenever a remote procedure call returns a Unix error code (such as
+\code{kern\_return\_t}), it is usually prudent to check that code to
+see if the call was successful. To relieve the programmer of the
+hassle of testing this value himself, and to centralize the
+information about the meaning of non-success return codes, CMU Common
+Lisp provides a number of macros and functions. See also
+\funref{get-unix-error-msg}.
+
+\begin{defun}{system:}{gr-error}{%
+ \args{\var{function} \var{gr} \ampoptional{} \var{context}}}
+
+ Signals a Lisp error, printing a message indicating that the call to
+ the specified \var{function} failed, with the return code \var{gr}.
+ If supplied, the \var{context} string is printed after the
+ \var{function} name and before the string associated with the
+ \var{gr}. For example:
+\begin{example}
+* (gr-error 'nukegarbage 3 "lost big")
+
+Error in function GR-ERROR:
+NUKEGARBAGE lost big, no space.
+Proceed cases:
+0: Return to Top-Level.
+Debug (type H for help)
+(Signal #<Conditions:Simple-Error.5FDE0>)
+0]
+\end{example}
+\end{defun}
+
+\begin{defmac}{system:}{gr-call}{\args{\var{function} \amprest{} \var{args}}}
+ \defmacx[system:]{gr-call*}{\args{\var{function} \amprest{} \var{args}}}
+
+ These macros can be used to call a function and automatically check
+ the GeneralReturn code and signal an appropriate error in case of
+ non-successful return. \code{gr-call} returns \false{} if no error
+ occurs, while \code{gr-call*} returns the second value of the
+ function called.
+\begin{example}
+* (gr-call mach:port_allocate *task-self*)
+NIL
+*
+\end{example}
+\end{defmac}
+
+\begin{defmac}{system:}{gr-bind}{
+ \args{\code{(}\mstar{\var{var}}\code{)}
+ \code{(}\var{function} \mstar{\var{arg}}\code{)}
+ \mstar{\var{form}}}}
+
+ This macro can be used much like \code{multiple-value-bind} to bind
+ the \var{var}s to return values resulting from calling the
+ \var{function} with the given \var{arg}s. The first return value is
+ not bound to a variable, but is checked as a GeneralReturn code, as
+ in \code{gr-call}.
+\begin{example}
+* (gr-bind (port_list port_list_cnt)
+ (mach:port_select *task-self*)
+ (format t "The port count is ~S." port_list_cnt)
+ port_list)
+The port count is 0.
+#<Alien value>
+*
+\end{example}
+\end{defmac}
+
+%%\node Unix Interrupts, , Making Sense of Mach Return Codes, UNIX Interface
+\section{Unix Interrupts}
+
+\cindex{unix interrupts} \cindex{interrupts}
+CMU Common Lisp allows access to all the Unix signals that can be generated
+under Unix. It should be noted that if this capability is abused, it is
+possible to completely destroy the running Lisp. The following macros and
+functions allow access to the Unix interrupt system. The signal names as
+specified in section 2 of the \i{Unix Programmer's Manual} are exported
+from the Unix package.
+
+\begin{comment}
+* Changing Interrupt Handlers::
+* Examples of Signal Handlers::
+\end{comment}
+
+%%\node Changing Interrupt Handlers, Examples of Signal Handlers, Unix Interrupts, Unix Interrupts
+\subsection{Changing Interrupt Handlers}
+\label{signal-handlers}
+
+\begin{defmac}{system:}{with-enabled-interrupts}{
+ \args{\var{specs} \amprest{} \var{body}}}
+
+ This macro should be called with a list of signal specifications,
+ \var{specs}. Each element of \var{specs} should be a list of
+ two\hide{ or three} elements: the first should be the Unix signal
+ for which a handler should be established, the second should be a
+ function to be called when the signal is received\hide{, and the
+ third should be an optional character used to generate the signal
+ from the keyboard. This last item is only useful for the SIGINT,
+ SIGQUIT, and SIGTSTP signals.} One or more signal handlers can be
+ established in this way. \code{with-enabled-interrupts} establishes
+ the correct signal handlers and then executes the forms in
+ \var{body}. The forms are executed in an unwind-protect so that the
+ state of the signal handlers will be restored to what it was before
+ the \code{with-enabled-interrupts} was entered. A signal handler
+ function specified as NIL will set the Unix signal handler to the
+ default which is normally either to ignore the signal or to cause a
+ core dump depending on the particular signal.
+\end{defmac}
+
+\begin{defmac}{system:}{without-interrupts}{\args{\amprest{} \var{body}}}
+
+ It is sometimes necessary to execute a piece a code that can not be
+ interrupted. This macro the forms in \var{body} with interrupts
+ disabled. Note that the Unix interrupts are not actually disabled,
+ rather they are queued until after \var{body} has finished
+ executing.
+\end{defmac}
+
+\begin{defmac}{system:}{with-interrupts}{\args{\amprest{} \var{body}}}
+
+ When executing an interrupt handler, the system disables interrupts,
+ as if the handler was wrapped in in a \code{without-interrupts}.
+ The macro \code{with-interrupts} can be used to enable interrupts
+ while the forms in \var{body} are evaluated. This is useful if
+ \var{body} is going to enter a break loop or do some long
+ computation that might need to be interrupted.
+\end{defmac}
+
+\begin{defmac}{system:}{without-hemlock}{\args{\amprest{} \var{body}}}
+
+ For some interrupts, such as SIGTSTP (suspend the Lisp process and
+ return to the Unix shell) it is necessary to leave Hemlock and then
+ return to it. This macro executes the forms in \var{body} after
+ exiting Hemlock. When \var{body} has been executed, control is
+ returned to Hemlock.
+\end{defmac}
+
+\begin{defun}{system:}{enable-interrupt}{%
+ \args{\var{signal} \var{function}\hide{ \ampoptional{}
+ \var{character}}}}
+
+ This function establishes \var{function} as the handler for
+ \var{signal}.
+ \hide{The optional \var{character} can be specified
+ for the SIGINT, SIGQUIT, and SIGTSTP signals and causes that
+ character to generate the appropriate signal from the keyboard.}
+ Unless you want to establish a global signal handler, you should use
+ the macro \code{with-enabled-interrupts} to temporarily establish a
+ signal handler. \hide{Without \var{character},}
+ \code{enable-interrupt} returns the old function associated with the
+ signal. \hide{When \var{character} is specified for SIGINT,
+ SIGQUIT, or SIGTSTP, it returns the old character code.}
+\end{defun}
+
+\begin{defun}{system:}{ignore-interrupt}{\args{\var{signal}}}
+
+ Ignore-interrupt sets the Unix signal mechanism to ignore
+ \var{signal} which means that the Lisp process will never see the
+ signal. Ignore-interrupt returns the old function associated with
+ the signal or \false{} if none is currently defined.
+\end{defun}
+
+\begin{defun}{system:}{default-interrupt}{\args{\var{signal}}}
+
+ Default-interrupt can be used to tell the Unix signal mechanism to
+ perform the default action for \var{signal}. For details on what
+ the default action for a signal is, see section 2 of the \i{Unix
+ Programmer's Manual}. In general, it is likely to ignore the
+ signal or to cause a core dump.
+\end{defun}
+
+%%\node Examples of Signal Handlers, , Changing Interrupt Handlers, Unix Interrupts
+\subsection{Examples of Signal Handlers}
+
+The following code is the signal handler used by the Lisp system for the
+SIGINT signal.
+\begin{lisp}
+(defun ih-sigint (signal code scp)
+ (declare (ignore signal code scp))
+ (without-hemlock
+ (with-interrupts
+ (break "Software Interrupt" t))))
+\end{lisp}
+The \code{without-hemlock} form is used to make sure that Hemlock is exited before
+a break loop is entered. The \code{with-interrupts} form is used to enable
+interrupts because the user may want to generate an interrupt while in the
+break loop. Finally, break is called to enter a break loop, so the user
+can look at the current state of the computation. If the user proceeds
+from the break loop, the computation will be restarted from where it was
+interrupted.
+
+The following function is the Lisp signal handler for the SIGTSTP signal
+which suspends a process and returns to the Unix shell.
+\begin{lisp}
+(defun ih-sigtstp (signal code scp)
+ (declare (ignore signal code scp))
+ (without-hemlock
+ (Unix:unix-kill (Unix:unix-getpid) Unix:sigstop)))
+\end{lisp}
+Lisp uses this interrupt handler to catch the SIGTSTP signal because it is
+necessary to get out of Hemlock in a clean way before returning to the shell.
+
+To set up these interrupt handlers, the following is recommended:
+\begin{lisp}
+(with-enabled-interrupts ((Unix:SIGINT #'ih-sigint)
+ (Unix:SIGTSTP #'ih-sigtstp))
+ <user code to execute with the above signal handlers enabled.>
+)
+\end{lisp}
+
+
+\hide{File:/afs/cs.cmu.edu/project/clisp/hackers/ram/docs/cmu-user/server.ms}
+
+%%\node Event Dispatching with SERVE-EVENT, Alien Objects, UNIX Interface, Top
+\chapter{Event Dispatching with SERVE-EVENT}
+\begin{center}
+\b{By Bill Chiles and Robert MacLachlan}
+\end{center}
+
+It is common to have multiple activities simultaneously operating in the same
+Lisp process. Furthermore, Lisp programmers tend to expect a flexible
+development environment. It must be possible to load and modify application
+programs without requiring modifications to other running programs. CMU Common
+Lisp achieves this by having a central scheduling mechanism based on an
+event-driven, object-oriented paradigm.
+
+An \var{event} is some interesting happening that should cause the Lisp process
+to wake up and do something. These events include X events and activity on
+Unix file descriptors. The object-oriented mechanism is only available with
+the first two, and it is optional with X events as described later in this
+chapter. In an X event, the window ID is the object capability and the X event
+type is the operation code. The Unix file descriptor input mechanism simply
+consists of an association list of a handler to call when input shows up on a
+particular file descriptor.
+
+
+\begin{comment}
+* Object Sets::
+* The SERVE-EVENT Function::
+* Using SERVE-EVENT with Unix File Descriptors::
+* Using SERVE-EVENT with the CLX Interface to X::
+* A SERVE-EVENT Example::
+\end{comment}
+
+%%\node Object Sets, The SERVE-EVENT Function, Event Dispatching with SERVE-EVENT, Event Dispatching with SERVE-EVENT
+\section{Object Sets}
+\label{object-sets}
+\cindex{object sets}
+An \i{object set} is a collection of objects that have the same implementation
+for each operation. Externally the object is represented by the object
+capability and the operation is represented by the operation code. Within
+Lisp, the object is represented by an arbitrary Lisp object, and the
+implementation for the operation is represented by an arbitrary Lisp function.
+The object set mechanism maintains this translation from the external to the
+internal representation.
+
+\begin{defun}{system:}{make-object-set}{%
+ \args{\var{name} \ampoptional{} \var{default-handler}}}
+
+ This function makes a new object set. \var{Name} is a string used
+ only for purposes of identifying the object set when it is printed.
+ \var{Default-handler} is the function used as a handler when an
+ undefined operation occurs on an object in the set. You can define
+ operations with the \code{serve-}\var{operation} functions exported
+ the \code{extensions} package for X events
+ (\pxlref{x-serve-mumbles}). Objects are added with
+ \code{system:add-xwindow-object}. Initially the object set has no
+ objects and no defined operations.
+\end{defun}
+
+\begin{defun}{system:}{object-set-operation}{%
+ \args{\var{object-set} \var{operation-code}}}
+
+ This function returns the handler function that is the
+ implementation of the operation corresponding to
+ \var{operation-code} in \var{object-set}. When set with
+ \code{setf}, the setter function establishes the new handler. The
+ \code{serve-}\var{operation} functions exported from the
+ \code{extensions} package for X events (\pxlref{x-serve-mumbles})
+ call this on behalf of the user when announcing a new operation for
+ an object set.
+\end{defun}
+
+\begin{defun}{system:}{add-xwindow-object}{%
+ \args{\var{window} \var{object} \var{object-set}}}
+
+ These functions add \var{port} or \var{window} to \var{object-set}.
+ \var{Object} is an arbitrary Lisp object that is associated with the
+ \var{port} or \var{window} capability. \var{Window} is a CLX
+ window. When an event occurs, \code{system:serve-event} passes
+ \var{object} as an argument to the handler function.
+\end{defun}
+
+
+%%\node The SERVE-EVENT Function, Using SERVE-EVENT with Unix File Descriptors, Object Sets, Event Dispatching with SERVE-EVENT
+\section{The SERVE-EVENT Function}
+
+The \code{system:serve-event} function is the standard way for an application
+to wait for something to happen. For example, the Lisp system calls
+\code{system:serve-event} when it wants input from X or a terminal stream.
+The idea behind \code{system:serve-event} is that it knows the appropriate
+action to take when any interesting event happens. If an application calls
+\code{system:serve-event} when it is idle, then any other applications with
+pending events can run. This allows several applications to run ``at the
+same time'' without interference, even though there is only one thread of
+control. Note that if an application is waiting for input of any kind,
+then other applications will get events.
+
+\begin{defun}{system:}{serve-event}{\args{\ampoptional{} \var{timeout}}}
+
+ This function waits for an event to happen and then dispatches to
+ the correct handler function. If specified, \var{timeout} is the
+ number of seconds to wait before timing out. A time out of zero
+ seconds is legal and causes \code{system:serve-event} to poll for
+ any events immediately available for processing.
+ \code{system:serve-event} returns \true{} if it serviced at least
+ one event, and \nil{} otherwise. Depending on the application, when
+ \code{system:serve-event} returns \true, you might want to call it
+ repeatedly with a timeout of zero until it returns \nil.
+
+ If input is available on any designated file descriptor, then this
+ calls the appropriate handler function supplied by
+ \code{system:add-fd-handler}.
+
+ Since events for many different applications may arrive
+ simultaneously, an application waiting for a specific event must
+ loop on \code{system:serve-event} until the desired event happens.
+ Since programs such as \hemlock{} call \code{system:serve-event} for
+ input, applications usually do not need to call
+ \code{system:serve-event} at all; \hemlock{} allows other
+ application's handlers to run when it goes into an input wait.
+\end{defun}
+
+\begin{defun}{system:}{serve-all-events}{\args{\ampoptional{} \var{timeout}}}
+
+ This function is similar to \code{system:serve-event}, except it
+ serves all the pending events rather than just one. It returns
+ \true{} if it serviced at least one event, and \nil{} otherwise.
+\end{defun}
+
+
+%%\node Using SERVE-EVENT with Unix File Descriptors, Using SERVE-EVENT with the CLX Interface to X, The SERVE-EVENT Function, Event Dispatching with SERVE-EVENT
+\section{Using SERVE-EVENT with Unix File Descriptors}
+Object sets are not available for use with file descriptors, as there are
+only two operations possible on file descriptors: input and output.
+Instead, a handler for either input or output can be registered with
+\code{system:serve-event} for a specific file descriptor. Whenever any input
+shows up, or output is possible on this file descriptor, the function
+associated with the handler for that descriptor is funcalled with the
+descriptor as it's single argument.
+
+\begin{defun}{system:}{add-fd-handler}{%
+ \args{\var{fd} \var{direction} \var{function}}}
+
+ This function installs and returns a new handler for the file
+ descriptor \var{fd}. \var{direction} can be either \kwd{input} if
+ the system should invoke the handler when input is available or
+ \kwd{output} if the system should invoke the handler when output is
+ possible. This returns a unique object representing the handler,
+ and this is a suitable argument for \code{system:remove-fd-handler}
+ \var{function} must take one argument, the file descriptor.
+\end{defun}
+
+\begin{defun}{system:}{remove-fd-handler}{\args{\var{handler}}}
+
+ This function removes \var{handler}, that \code{add-fd-handler} must
+ have previously returned.
+\end{defun}
+
+\begin{defmac}{system:}{with-fd-handler}{%
+ \args{(\var{direction} \var{fd} \var{function})
+ \mstar{\var{form}}}}
+
+ This macro executes the supplied forms with a handler installed
+ using \var{fd}, \var{direction}, and \var{function}. See
+ \code{system:add-fd-handler}.
+\end{defmac}
+
+\begin{defun}{system:}{wait-until-fd-usable}{%
+ \args{\var{direction} \var{fd} \ampoptional{} \var{timeout}}}
+
+ This function waits for up to \var{timeout} seconds for \var{fd} to
+ become usable for \var{direction} (either \kwd{input} or
+ \kwd{output}). If \var{timeout} is \nil{} or unspecified, this
+ waits forever.
+\end{defun}
+
+\begin{defun}{system:}{invalidate-descriptor}{\args{\var{fd}}}
+
+ This function removes all handlers associated with \var{fd}. This
+ should only be used in drastic cases (such as I/O errors, but not
+ necessarily EOF). Normally, you should use \code{remove-fd-handler}
+ to remove the specific handler.
+\end{defun}
+
+\begin{comment}
+
+section{Using SERVE-EVENT with Matchmaker Interfaces}
+\label{ipc-serve-mumbles}
+Remember from section \ref{object-sets}, an object set is a collection of
+objects, ports in this case, with some set of operations, message ID's, with
+corresponding implementations, the same handler functions.
+
+Matchmaker uses the object set operations to implement servers. For
+each server interface \i{XXX}, Matchmaker defines a function,
+\code{serve-}\i{XXX}, of two arguments, an object set and a function.
+The \code{serve-}\i{XXX} function establishes the function as the
+implementation of the \i{XXX} operation in the object set. Recall
+from section \ref{object-sets}, \code{system:add-port-object}
+associates some Lisp object with a port in an object set. When
+\code{system:serve-event} notices activity on a port, it calls the
+function given to \code{serve-}\i{XXX} with the object given to
+\code{system:add-port-object} and the input parameters specified in
+the message definition. The return values from the function are used
+as the output parameters for the message, if any.
+\code{serve-}\i{XXX} functions are also generated for each \i{server
+ message} and asynchronous user interface.
+
+To use a Lisp server:
+\begin{itemize}
+
+\item Create an object set.
+
+\item Define some operations on it using the \code{serve-}\i{XXX}
+ functions.
+
+\item Create an object for every port on which you receive requests.
+
+\item Call \code{system:serve-event} to service an RPC request.
+\end{itemize}
+
+
+Object sets allow many servers in the same Lisp to operate without knowing
+about each other. There can be multiple implementations of the same interface
+with different operation handlers established in distinct object sets. This
+property is especially useful when handling emergency messages.
+
+\end{comment}
+
+%%\node Using SERVE-EVENT with the CLX Interface to X, A SERVE-EVENT Example, Using SERVE-EVENT with Unix File Descriptors, Event Dispatching with SERVE-EVENT
+\section{Using SERVE-EVENT with the CLX Interface to X}
+\label{x-serve-mumbles}
+Remember from section \ref{object-sets}, an object set is a collection of
+objects, CLX windows in this case, with some set of operations, event keywords,
+with corresponding implementations, the same handler functions. Since X allows
+multiple display connections from a given process, you can avoid using object
+sets if every window in an application or display connection behaves the same.
+If a particular X application on a single display connection has windows that
+want to handle certain events differently, then using object sets is a
+convenient way to organize this since you need some way to map the window/event
+combination to the appropriate functionality.
+
+The following is a discussion of functions exported from the \code{extensions}
+package that facilitate handling CLX events through \code{system:serve-event}.
+The first two routines are useful regardless of whether you use
+\code{system:serve-event}:
+\begin{defun}{ext:}{open-clx-display}{%
+ \args{\ampoptional{} \var{string}}}
+
+ This function parses \var{string} for an X display specification
+ including display and screen numbers. \var{String} defaults to the
+ following:
+ \begin{example}
+ (cdr (assoc :display ext:*environment-list* :test #'eq))
+ \end{example}
+ If any field in the display specification is missing, this signals
+ an error. \code{ext:open-clx-display} returns the CLX display and
+ screen.
+\end{defun}
+
+\begin{defun}{ext:}{flush-display-events}{\args{\var{display}}}
+
+ This function flushes all the events in \var{display}'s event queue
+ including the current event, in case the user calls this from within
+ an event handler.
+\end{defun}
+
+
+\begin{comment}
+* Without Object Sets::
+* With Object Sets::
+\end{comment}
+
+%%\node Without Object Sets, With Object Sets, Using SERVE-EVENT with the CLX Interface to X, Using SERVE-EVENT with the CLX Interface to X
+\subsection{Without Object Sets}
+Since most applications that use CLX, can avoid the complexity of object sets,
+these routines are described in a separate section. The routines described in
+the next section that use the object set mechanism are based on these
+interfaces.
+
+\begin{defun}{ext:}{enable-clx-event-handling}{%
+ \args{\var{display} \var{handler}}}
+
+ This function causes \code{system:serve-event} to notice when there
+ is input on \var{display}'s connection to the X11 server. When this
+ happens, \code{system:serve-event} invokes \var{handler} on
+ \var{display} in a dynamic context with an error handler bound that
+ flushes all events from \var{display} and returns. By returning,
+ the error handler declines to handle the error, but it will have
+ cleared all events; thus, entering the debugger will not result in
+ infinite errors due to streams that wait via
+ \code{system:serve-event} for input. Calling this repeatedly on the
+ same \var{display} establishes \var{handler} as a new handler,
+ replacing any previous one for \var{display}.
+\end{defun}
+
+\begin{defun}{ext:}{disable-clx-event-handling}{\args{\var{display}}}
+
+ This function undoes the effect of
+ \code{ext:enable-clx-event-handling}.
+\end{defun}
+
+\begin{defmac}{ext:}{with-clx-event-handling}{%
+ \args{(\var{display} \var{handler}) \mstar{form}}}
+
+ This macro evaluates each \var{form} in a context where
+ \code{system:serve-event} invokes \var{handler} on \var{display}
+ whenever there is input on \var{display}'s connection to the X
+ server. This destroys any previously established handler for
+ \var{display}.
+\end{defmac}
+
+
+%%\node With Object Sets, , Without Object Sets, Using SERVE-EVENT with the CLX Interface to X
+\subsection{With Object Sets}
+This section discusses the use of object sets and
+\code{system:serve-event} to handle CLX events. This is necessary
+when a single X application has distinct windows that want to handle
+the same events in different ways. Basically, you need some way of
+asking for a given window which way you want to handle some event
+because this event is handled differently depending on the window.
+Object sets provide this feature.
+
+For each CLX event-key symbol-name \i{XXX} (for example,
+\var{key-press}), there is a function \code{serve-}\i{XXX} of two
+arguments, an object set and a function. The \code{serve-}\i{XXX}
+function establishes the function as the handler for the \kwd{XXX}
+event in the object set. Recall from section \ref{object-sets},
+\code{system:add-xwindow-object} associates some Lisp object with a
+CLX window in an object set. When \code{system:serve-event} notices
+activity on a window, it calls the function given to
+\code{ext:enable-clx-event-handling}. If this function is
+\code{ext:object-set-event-handler}, it calls the function given to
+\code{serve-}\i{XXX}, passing the object given to
+\code{system:add-xwindow-object} and the event's slots as well as a
+couple other arguments described below.
+
+To use object sets in this way:
+\begin{itemize}
+
+\item Create an object set.
+
+\item Define some operations on it using the \code{serve-}\i{XXX}
+ functions.
+
+\item Add an object for every window on which you receive requests.
+ This can be the CLX window itself or some structure more meaningful
+ to your application.
+
+\item Call \code{system:serve-event} to service an X event.
+\end{itemize}
+
+
+\begin{defun}{ext:}{object-set-event-handler}{%
+ \args{\var{display}}}
+
+ This function is a suitable argument to
+ \code{ext:enable-clx-event-handling}. The actual event handlers
+ defined for particular events within a given object set must take an
+ argument for every slot in the appropriate event. In addition to
+ the event slots, \code{ext:object-set-event-handler} passes the
+ following arguments:
+ \begin{itemize}
+ \item The object, as established by
+ \code{system:add-xwindow-object}, on which the event occurred.
+ \item event-key, see \code{xlib:event-case}.
+ \item send-event-p, see \code{xlib:event-case}.
+ \end{itemize}
+
+ Describing any \code{ext:serve-}\var{event-key-name} function, where
+ \var{event-key-name} is an event-key symbol-name (for example,
+ \code{ext:serve-key-press}), indicates exactly what all the
+ arguments are in their correct order.
+
+%% \begin{comment}
+%% \code{ext:object-set-event-handler} ignores \kwd{no-exposure}
+%% events on pixmaps, issuing a warning if one occurs. It is only
+%% prepared to dispatch events for windows.
+%% \end{comment}
+
+ When creating an object set for use with
+ \code{ext:object-set-event-handler}, specify
+ \code{ext:default-clx-event-handler} as the default handler for
+ events in that object set. If no default handler is specified, and
+ the system invokes the default default handler, it will cause an
+ error since this function takes arguments suitable for handling port
+ messages.
+\end{defun}
+
+
+%%\node A SERVE-EVENT Example, , Using SERVE-EVENT with the CLX Interface to X, Event Dispatching with SERVE-EVENT
+\section{A SERVE-EVENT Example}
+This section contains two examples using \code{system:serve-event}. The first
+one does not use object sets, and the second, slightly more complicated one
+does.
+
+
+\begin{comment}
+* Without Object Sets Example::
+* With Object Sets Example::
+\end{comment}
+
+%%\node Without Object Sets Example, With Object Sets Example, A SERVE-EVENT Example, A SERVE-EVENT Example
+\subsection{Without Object Sets Example}
+This example defines an input handler for a CLX display connection. It only
+recognizes \kwd{key-press} events. The body of the example loops over
+\code{system:serve-event} to get input.
+
+\begin{lisp}
+(in-package "SERVER-EXAMPLE")
+
+(defun my-input-handler (display)
+ (xlib:event-case (display :timeout 0)
+ (:key-press (event-window code state)
+ (format t "KEY-PRESSED (Window = ~D) = ~S.~%"
+ (xlib:window-id event-window)
+ ;; See Hemlock Command Implementor's Manual for convenient
+ ;; input mapping function.
+ (ext:translate-character display code state))
+ ;; Make XLIB:EVENT-CASE discard the event.
+ t)))
+\end{lisp}
+\begin{lisp}
+(defun server-example ()
+ "An example of using the SYSTEM:SERVE-EVENT function and object sets to
+ handle CLX events."
+ (let* ((display (ext:open-clx-display))
+ (screen (display-default-screen display))
+ (black (screen-black-pixel screen))
+ (white (screen-white-pixel screen))
+ (window (create-window :parent (screen-root screen)
+ :x 0 :y 0 :width 200 :height 200
+ :background white :border black
+ :border-width 2
+ :event-mask
+ (xlib:make-event-mask :key-press))))
+ ;; Wrap code in UNWIND-PROTECT, so we clean up after ourselves.
+ (unwind-protect
+ (progn
+ ;; Enable event handling on the display.
+ (ext:enable-clx-event-handling display #'my-input-handler)
+ ;; Map the windows to the screen.
+ (map-window window)
+ ;; Make sure we send all our requests.
+ (display-force-output display)
+ ;; Call serve-event for 100,000 events or immediate timeouts.
+ (dotimes (i 100000) (system:serve-event)))
+ ;; Disable event handling on this display.
+ (ext:disable-clx-event-handling display)
+ ;; Get rid of the window.
+ (destroy-window window)
+ ;; Pick off any events the X server has already queued for our
+ ;; windows, so we don't choke since SYSTEM:SERVE-EVENT is no longer
+ ;; prepared to handle events for us.
+ (loop
+ (unless (deleting-window-drop-event *display* window)
+ (return)))
+ ;; Close the display.
+ (xlib:close-display display))))
+
+(defun deleting-window-drop-event (display win)
+ "Check for any events on win. If there is one, remove it from the
+ event queue and return t; otherwise, return nil."
+ (xlib:display-finish-output display)
+ (let ((result nil))
+ (xlib:process-event
+ display :timeout 0
+ :handler #'(lambda (&key event-window &allow-other-keys)
+ (if (eq event-window win)
+ (setf result t)
+ nil)))
+ result))
+\end{lisp}
+
+
+%%\node With Object Sets Example, , Without Object Sets Example, A SERVE-EVENT Example
+\subsection{With Object Sets Example}
+This example involves more work, but you get a little more for your effort. It
+defines two objects, \code{input-box} and \code{slider}, and establishes a
+\kwd{key-press} handler for each object, \code{key-pressed} and
+\code{slider-pressed}. We have two object sets because we handle events on the
+windows manifesting these objects differently, but the events come over the
+same display connection.
+
+\begin{lisp}
+(in-package "SERVER-EXAMPLE")
+
+(defstruct (input-box (:print-function print-input-box)
+ (:constructor make-input-box (display window)))
+ "Our program knows about input-boxes, and it doesn't care how they
+ are implemented."
+ display ; The CLX display on which my input-box is displayed.
+ window) ; The CLX window in which the user types.
+;;;
+(defun print-input-box (object stream n)
+ (declare (ignore n))
+ (format stream "#<Input-Box ~S>" (input-box-display object)))
+
+(defvar *input-box-windows*
+ (system:make-object-set "Input Box Windows"
+ #'ext:default-clx-event-handler))
+
+(defun key-pressed (input-box event-key event-window root child
+ same-screen-p x y root-x root-y modifiers time
+ key-code send-event-p)
+ "This is our :key-press event handler."
+ (declare (ignore event-key root child same-screen-p x y
+ root-x root-y time send-event-p))
+ (format t "KEY-PRESSED (Window = ~D) = ~S.~%"
+ (xlib:window-id event-window)
+ ;; See Hemlock Command Implementor's Manual for convenient
+ ;; input mapping function.
+ (ext:translate-character (input-box-display input-box)
+ key-code modifiers)))
+;;;
+(ext:serve-key-press *input-box-windows* #'key-pressed)
+\end{lisp}
+\begin{lisp}
+(defstruct (slider (:print-function print-slider)
+ (:include input-box)
+ (:constructor %make-slider
+ (display window window-width max)))
+ "Our program knows about sliders too, and these provide input values
+ zero to max."
+ bits-per-value ; bits per discrete value up to max.
+ max) ; End value for slider.
+;;;
+(defun print-slider (object stream n)
+ (declare (ignore n))
+ (format stream "#<Slider ~S 0..~D>"
+ (input-box-display object)
+ (1- (slider-max object))))
+;;;
+(defun make-slider (display window max)
+ (%make-slider display window
+ (truncate (xlib:drawable-width window) max)
+ max))
+
+(defvar *slider-windows*
+ (system:make-object-set "Slider Windows"
+ #'ext:default-clx-event-handler))
+
+(defun slider-pressed (slider event-key event-window root child
+ same-screen-p x y root-x root-y modifiers time
+ key-code send-event-p)
+ "This is our :key-press event handler for sliders. Probably this is
+ a mouse thing, but for simplicity here we take a character typed."
+ (declare (ignore event-key root child same-screen-p x y
+ root-x root-y time send-event-p))
+ (format t "KEY-PRESSED (Window = ~D) = ~S --> ~D.~%"
+ (xlib:window-id event-window)
+ ;; See Hemlock Command Implementor's Manual for convenient
+ ;; input mapping function.
+ (ext:translate-character (input-box-display slider)
+ key-code modifiers)
+ (truncate x (slider-bits-per-value slider))))
+;;;
+(ext:serve-key-press *slider-windows* #'slider-pressed)
+\end{lisp}
+\begin{lisp}
+(defun server-example ()
+ "An example of using the SYSTEM:SERVE-EVENT function and object sets to
+ handle CLX events."
+ (let* ((display (ext:open-clx-display))
+ (screen (display-default-screen display))
+ (black (screen-black-pixel screen))
+ (white (screen-white-pixel screen))
+ (iwindow (create-window :parent (screen-root screen)
+ :x 0 :y 0 :width 200 :height 200
+ :background white :border black
+ :border-width 2
+ :event-mask
+ (xlib:make-event-mask :key-press)))
+ (swindow (create-window :parent (screen-root screen)
+ :x 0 :y 300 :width 200 :height 50
+ :background white :border black
+ :border-width 2
+ :event-mask
+ (xlib:make-event-mask :key-press)))
+ (input-box (make-input-box display iwindow))
+ (slider (make-slider display swindow 15)))
+ ;; Wrap code in UNWIND-PROTECT, so we clean up after ourselves.
+ (unwind-protect
+ (progn
+ ;; Enable event handling on the display.
+ (ext:enable-clx-event-handling display
+ #'ext:object-set-event-handler)
+ ;; Add the windows to the appropriate object sets.
+ (system:add-xwindow-object iwindow input-box
+ *input-box-windows*)
+ (system:add-xwindow-object swindow slider
+ *slider-windows*)
+ ;; Map the windows to the screen.
+ (map-window iwindow)
+ (map-window swindow)
+ ;; Make sure we send all our requests.
+ (display-force-output display)
+ ;; Call server for 100,000 events or immediate timeouts.
+ (dotimes (i 100000) (system:serve-event)))
+ ;; Disable event handling on this display.
+ (ext:disable-clx-event-handling display)
+ (delete-window iwindow display)
+ (delete-window swindow display)
+ ;; Close the display.
+ (xlib:close-display display))))
+\end{lisp}
+\begin{lisp}
+(defun delete-window (window display)
+ ;; Remove the windows from the object sets before destroying them.
+ (system:remove-xwindow-object window)
+ ;; Destroy the window.
+ (destroy-window window)
+ ;; Pick off any events the X server has already queued for our
+ ;; windows, so we don't choke since SYSTEM:SERVE-EVENT is no longer
+ ;; prepared to handle events for us.
+ (loop
+ (unless (deleting-window-drop-event display window)
+ (return))))
+
+(defun deleting-window-drop-event (display win)
+ "Check for any events on win. If there is one, remove it from the
+ event queue and return t; otherwise, return nil."
+ (xlib:display-finish-output display)
+ (let ((result nil))
+ (xlib:process-event
+ display :timeout 0
+ :handler #'(lambda (&key event-window &allow-other-keys)
+ (if (eq event-window win)
+ (setf result t)
+ nil)))
+ result))
+\end{lisp}
+
+\hide{File:/afs/cs.cmu.edu/project/clisp/hackers/ram/docs/cmu-user/alien.ms}
+
+%%\node Alien Objects, Interprocess Communication under LISP, Event Dispatching with SERVE-EVENT, Top
+\chapter{Alien Objects}
+\label{aliens}
+\begin{center}
+\b{By Robert MacLachlan and William Lott}
+\end{center}
+\vspace{1 cm}
+
+\begin{comment}
+* Introduction to Aliens::
+* Alien Types::
+* Alien Operations::
+* Alien Variables::
+* Alien Data Structure Example::
+* Loading Unix Object Files::
+* Alien Function Calls::
+* Step-by-Step Alien Example::
+\end{comment}
+
+%%\node Introduction to Aliens, Alien Types, Alien Objects, Alien Objects
+\section{Introduction to Aliens}
+
+Because of Lisp's emphasis on dynamic memory allocation and garbage
+collection, Lisp implementations use unconventional memory representations
+for objects. This representation mismatch creates problems when a Lisp
+program must share objects with programs written in another language. There
+are three different approaches to establishing communication:
+\begin{itemize}
+\item The burden can be placed on the foreign program (and programmer) by
+requiring the use of Lisp object representations. The main difficulty with
+this approach is that either the foreign program must be written with Lisp
+interaction in mind, or a substantial amount of foreign ``glue'' code must be
+written to perform the translation.
+
+\item The Lisp system can automatically convert objects back and forth
+between the Lisp and foreign representations. This is convenient, but
+translation becomes prohibitively slow when large or complex data structures
+must be shared.
+
+\item The Lisp program can directly manipulate foreign objects through the
+use of extensions to the Lisp language. Most Lisp systems make use of
+this approach, but the language for describing types and expressing
+accesses is often not powerful enough for complex objects to be easily
+manipulated.
+\end{itemize}
+\cmucl{} relies primarily on the automatic conversion and direct manipulation
+approaches: Aliens of simple scalar types are automatically converted,
+while complex types are directly manipulated in their foreign
+representation. Any foreign objects that can't automatically be
+converted into Lisp values are represented by objects of type
+\code{alien-value}. Since Lisp is a dynamically typed language, even
+foreign objects must have a run-time type; this type information is
+provided by encapsulating the raw pointer to the foreign data within an
+\code{alien-value} object.
+
+The Alien type language and operations are most similar to those of the
+C language, but Aliens can also be used when communicating with most
+other languages that can be linked with C.
+
+%%\f
+%%\node Alien Types, Alien Operations, Introduction to Aliens, Alien Objects
+\section{Alien Types}
+
+Alien types have a description language based on nested list structure. For
+example:
+\begin{example}
+struct foo \{
+ int a;
+ struct foo *b[100];
+\};
+\end{example}
+has the corresponding Alien type:
+\begin{lisp}
+(struct foo
+ (a int)
+ (b (array (* (struct foo)) 100)))
+\end{lisp}
+
+
+\begin{comment}
+* Defining Alien Types::
+* Alien Types and Lisp Types::
+* Alien Type Specifiers::
+* The C-Call Package::
+\end{comment}
+
+%%\node Defining Alien Types, Alien Types and Lisp Types, Alien Types, Alien Types
+\subsection{Defining Alien Types}
+
+Types may be either named or anonymous. With structure and union
+types, the name is part of the type specifier, allowing recursively
+defined types such as:
+\begin{lisp}
+(struct foo (a (* (struct foo))))
+\end{lisp}
+An anonymous structure or union type is specified by using the name
+\nil. The \funref{with-alien} macro defines a local scope which
+``captures'' any named type definitions. Other types are not
+inherently named, but can be given named abbreviations using
+\code{def-alien-type}.
+
+\begin{defmac}{alien:}{def-alien-type}{name type}
+
+ This macro globally defines \var{name} as a shorthand for the Alien
+ type \var{type}. When introducing global structure and union type
+ definitions, \var{name} may be \nil, in which case the name to
+ define is taken from the type's name.
+\end{defmac}
+
+
+%%\node Alien Types and Lisp Types, Alien Type Specifiers, Defining Alien Types, Alien Types
+\subsection{Alien Types and Lisp Types}
+
+The Alien types form a subsystem of the \cmucl{} type system. An
+\code{alien} type specifier provides a way to use any Alien type as a
+Lisp type specifier. For example
+\begin{lisp}
+(typep foo '(alien (* int)))
+\end{lisp}
+can be used to determine whether \code{foo} is a pointer to an
+\code{int}. \code{alien} type specifiers can be used in the same ways
+as ordinary type specifiers (like \code{string}.) Alien type
+declarations are subject to the same precise type checking as any
+other declaration (section \xlref{precise-type-checks}.)
+
+Note that the Alien type system overlaps with normal Lisp type
+specifiers in some cases. For example, the type specifier
+\code{(alien single-float)} is identical to \code{single-float}, since
+Alien floats are automatically converted to Lisp floats. When
+\code{type-of} is called on an Alien value that is not automatically
+converted to a Lisp value, then it will return an \code{alien} type
+specifier.
+
+%%\node Alien Type Specifiers, The C-Call Package, Alien Types and Lisp Types, Alien Types
+\subsection{Alien Type Specifiers}
+
+Some Alien type names are \clisp symbols, but the names are
+still exported from the \code{alien} package, so it is legal to say
+\code{alien:single-float}. These are the basic Alien type specifiers:
+
+\begin{deftp}{Alien type}{*}{%
+ \args{\var{type}}}
+
+ A pointer to an object of the specified \var{type}. If \var{type}
+ is \true, then it means a pointer to anything, similar to
+ ``\code{void *}'' in ANSI C. Currently, the only way to detect a
+ null pointer is:
+\begin{lisp}
+ (zerop (sap-int (alien-sap \var{ptr})))
+\end{lisp}
+\xlref{system-area-pointers}
+\end{deftp}
+
+\begin{deftp}{Alien type}{array}{\var{type} \mstar{\var{dimension}}}
+
+ An array of the specified \var{dimensions}, holding elements of type
+ \var{type}. Note that \code{(* int)} and \code{(array int)} are
+ considered to be different types when type checking is done; pointer
+ and array types must be explicitly coerced using \code{cast}.
+
+ Arrays are accessed using \code{deref}, passing the indices as
+ additional arguments. Elements are stored in column-major order (as
+ in C), so the first dimension determines only the size of the memory
+ block, and not the layout of the higher dimensions. An array whose
+ first dimension is variable may be specified by using \nil{} as the
+ first dimension. Fixed-size arrays can be allocated as array
+ elements, structure slots or \code{with-alien} variables. Dynamic
+ arrays can only be allocated using \funref{make-alien}.
+\end{deftp}
+
+\begin{deftp}{Alien type}{struct}{\var{name}
+ \mstar{(\var{field} \var{type} \mopt{\var{bits}})}}
+
+ A structure type with the specified \var{name} and \var{fields}.
+ Fields are allocated at the same positions used by the
+ implementation's C compiler. \var{bits} is intended for C-like bit
+ field support, but is currently unused. If \var{name} is \false,
+ then the type is anonymous.
+
+ If a named Alien \code{struct} specifier is passed to
+ \funref{def-alien-type} or \funref{with-alien}, then this defines,
+ respectively, a new global or local Alien structure type. If no
+ \var{fields} are specified, then the fields are taken from the
+ current (local or global) Alien structure type definition of
+ \var{name}.
+\end{deftp}
+
+\begin{deftp}{Alien type}{union}{\var{name}
+ \mstar{(\var{field} \var{type} \mopt{\var{bits}})}}
+
+ Similar to \code{struct}, but defines a union type. All fields are
+ allocated at the same offset, and the size of the union is the size
+ of the largest field. The programmer must determine which field is
+ active from context.
+\end{deftp}
+
+\begin{deftp}{Alien type}{enum}{\var{name} \mstar{\var{spec}}}
+
+ An enumeration type that maps between integer values and keywords.
+ If \var{name} is \false, then the type is anonymous. Each
+ \var{spec} is either a keyword, or a list \code{(\var{keyword}
+ \var{value})}. If \var{integer} is not supplied, then it defaults
+ to one greater than the value for the preceding spec (or to zero if
+ it is the first spec.)
+\end{deftp}
+
+\begin{deftp}{Alien type}{signed}{\mopt{\var{bits}}}
+ A signed integer with the specified number of bits precision. The
+ upper limit on integer precision is determined by the machine's word
+ size. If no size is specified, the maximum size will be used.
+\end{deftp}
+
+\begin{deftp}{Alien type}{integer}{\mopt{\var{bits}}}
+ Identical to \code{signed}---the distinction between \code{signed}
+ and \code{integer} is purely stylistic.
+\end{deftp}
+
+\begin{deftp}{Alien type}{unsigned}{\mopt{\var{bits}}}
+ Like \code{signed}, but specifies an unsigned integer.
+\end{deftp}
+
+\begin{deftp}{Alien type}{boolean}{\mopt{\var{bits}}}
+ Similar to an enumeration type that maps \code{0} to \false{} and
+ all other values to \true. \var{bits} determines the amount of
+ storage allocated to hold the truth value.
+\end{deftp}
+
+\begin{deftp}{Alien type}{single-float}{}
+ A floating-point number in IEEE single format.
+\end{deftp}
+
+\begin{deftp}{Alien type}{double-float}{}
+ A floating-point number in IEEE double format.
+\end{deftp}
+
+\begin{deftp}{Alien type}{function}{\var{result-type} \mstar{\var{arg-type}}}
+ \label{alien-function-types}
+ A Alien function that takes arguments of the specified
+ \var{arg-types} and returns a result of type \var{result-type}.
+ Note that the only context where a \code{function} type is directly
+ specified is in the argument to \code{alien-funcall} (see section
+ \funref{alien-funcall}.) In all other contexts, functions are
+ represented by function pointer types: \code{(* (function ...))}.
+\end{deftp}
+
+\begin{deftp}{Alien type}{system-area-pointer}{}
+ A pointer which is represented in Lisp as a
+ \code{system-area-pointer} object (\pxlref{system-area-pointers}.)
+\end{deftp}
+
+%%\node The C-Call Package, , Alien Type Specifiers, Alien Types
+\subsection{The C-Call Package}
+
+The \code{c-call} package exports these type-equivalents to the C type
+of the same name: \code{char}, \code{short}, \code{int}, \code{long},
+\code{unsigned-char}, \code{unsigned-short}, \code{unsigned-int},
+\code{unsigned-long}, \code{float}, \code{double}. \code{c-call} also
+exports these types:
+
+\begin{deftp}{Alien type}{void}{}
+ This type is used in function types to declare that no useful value
+ is returned. Evaluation of an \code{alien-funcall} form will return
+ zero values.
+\end{deftp}
+
+\begin{deftp}{Alien type}{c-string}{}
+ This type is similar to \code{(* char)}, but is interpreted as a
+ null-terminated string, and is automatically converted into a Lisp
+ string when accessed. If the pointer is C \code{NULL} (or 0), then
+ accessing gives Lisp \false.
+
+ Assigning a Lisp string to a \code{c-string} structure field or
+ variable stores the contents of the string to the memory already
+ pointed to by that variable. When an Alien of type \code{(* char)}
+ is assigned to a \code{c-string}, then the \code{c-string} pointer
+ is assigned to. This allows \code{c-string} pointers to be
+ initialized. For example:
+\begin{lisp}
+ (def-alien-type nil (struct foo (str c-string)))
+
+ (defun make-foo (str) (let ((my-foo (make-alien (struct foo))))
+ (setf (slot my-foo 'str) (make-alien char (length str))) (setf (slot
+ my-foo 'str) str) my-foo))
+\end{lisp}
+Storing Lisp \false{} writes C \code{NULL} to the \code{c-string}
+pointer.
+\end{deftp}
+
+%%\f
+%%\node Alien Operations, Alien Variables, Alien Types, Alien Objects
+\section{Alien Operations}
+
+This section describes the basic operations on Alien values.
+
+\begin{comment}
+* Alien Access Operations::
+* Alien Coercion Operations::
+* Alien Dynamic Allocation::
+\end{comment}
+
+%%\node Alien Access Operations, Alien Coercion Operations, Alien Operations, Alien Operations
+\subsection{Alien Access Operations}
+
+\begin{defun}{alien:}{deref}{\args{\var{pointer-or-array} \amprest \var{indices}}}
+
+ This function returns the value pointed to by an Alien pointer or
+ the value of an Alien array element. If a pointer, an optional
+ single index can be specified to give the equivalent of C pointer
+ arithmetic; this index is scaled by the size of the type pointed to.
+ If an array, the number of indices must be the same as the number of
+ dimensions in the array type. \code{deref} can be set with
+ \code{setf} to assign a new value.
+\end{defun}
+
+\begin{defun}{alien:}{slot}{\args{\var{struct-or-union} \var{slot-name}}}
+
+ This function extracts the value of slot \var{slot-name} from the an
+ Alien \code{struct} or \code{union}. If \var{struct-or-union} is a
+ pointer to a structure or union, then it is automatically
+ dereferenced. This can be set with \code{setf} to assign a new
+ value. Note that \var{slot-name} is evaluated, and need not be a
+ compile-time constant (but only constant slot accesses are
+ efficiently compiled.)
+\end{defun}
+
+%%\node Alien Coercion Operations, Alien Dynamic Allocation, Alien Access Operations, Alien Operations
+\subsection{Alien Coercion Operations}
+
+\begin{defmac}{alien:}{addr}{\var{alien-expr}}
+
+ This macro returns a pointer to the location specified by
+ \var{alien-expr}, which must be either an Alien variable, a use of
+ \code{deref}, a use of \code{slot}, or a use of
+ \funref{extern-alien}.
+\end{defmac}
+
+\begin{defmac}{alien:}{cast}{\var{alien} \var{new-type}}
+
+ This macro converts \var{alien} to a new Alien with the specified
+ \var{new-type}. Both types must be an Alien pointer, array or
+ function type. Note that the result is not \code{eq} to the
+ argument, but does refer to the same data bits.
+\end{defmac}
+
+\begin{defmac}{alien:}{sap-alien}{\var{sap} \var{type}}
+ \defunx[alien:]{alien-sap}{\var{alien-value}}
+
+ \code{sap-alien} converts \var{sap} (a system area pointer
+ \pxlref{system-area-pointers}) to an Alien value with the specified
+ \var{type}. \var{type} is not evaluated.
+
+\code{alien-sap} returns the SAP which points to \var{alien-value}'s
+data.
+
+The \var{type} to \code{sap-alien} and the type of the \var{alien-value} to
+\code{alien-sap} must some Alien pointer, array or record type.
+\end{defmac}
+
+%%\node Alien Dynamic Allocation, , Alien Coercion Operations, Alien Operations
+\subsection{Alien Dynamic Allocation}
+
+Dynamic Aliens are allocated using the \code{malloc} library, so foreign code
+can call \code{free} on the result of \code{make-alien}, and Lisp code can
+call \code{free-alien} on objects allocated by foreign code.
+
+\begin{defmac}{alien:}{make-alien}{\var{type} \mopt{\var{size}}}
+
+ This macro returns a dynamically allocated Alien of the specified
+ \var{type} (which is not evaluated.) The allocated memory is not
+ initialized, and may contain arbitrary junk. If supplied,
+ \var{size} is an expression to evaluate to compute the size of the
+ allocated object. There are two major cases:
+ \begin{itemize}
+ \item When \var{type} is an array type, an array of that type is
+ allocated and a \var{pointer} to it is returned. Note that you
+ must use \code{deref} to change the result to an array before you
+ can use \code{deref} to read or write elements:
+ \begin{lisp}
+ (defvar *foo* (make-alien (array char 10)))
+
+ (type-of *foo*) \result{} (alien (* (array (signed 8) 10)))
+
+ (setf (deref (deref foo) 0) 10) \result{} 10
+ \end{lisp}
+ If supplied, \var{size} is used as the first dimension for the
+ array.
+
+ \item When \var{type} is any other type, then then an object for
+ that type is allocated, and a \var{pointer} to it is returned. So
+ \code{(make-alien int)} returns a \code{(* int)}. If \var{size}
+ is specified, then a block of that many objects is allocated, with
+ the result pointing to the first one.
+ \end{itemize}
+\end{defmac}
+
+\begin{defun}{alien:}{free-alien}{\var{alien}}
+
+ This function frees the storage for \var{alien} (which must have
+ been allocated with \code{make-alien} or \code{malloc}.)
+\end{defun}
+
+See also \funref{with-alien}, which stack-allocates Aliens.
+
+%%\f
+%%\node Alien Variables, Alien Data Structure Example, Alien Operations, Alien Objects
+\section{Alien Variables}
+
+Both local (stack allocated) and external (C global) Alien variables are
+supported.
+
+\begin{comment}
+* Local Alien Variables::
+* External Alien Variables::
+\end{comment}
+
+%%\node Local Alien Variables, External Alien Variables, Alien Variables, Alien Variables
+\subsection{Local Alien Variables}
+
+\begin{defmac}{alien:}{with-alien}{\mstar{(\var{name} \var{type}
+ \mopt{\var{initial-value}})} \mstar{form}}
+
+ This macro establishes local alien variables with the specified
+ Alien types and names for dynamic extent of the body. The variable
+ \var{names} are established as symbol-macros; the bindings have
+ lexical scope, and may be assigned with \code{setq} or \code{setf}.
+ This form is analogous to defining a local variable in C: additional
+ storage is allocated, and the initial value is copied.
+
+ \code{with-alien} also establishes a new scope for named structures
+ and unions. Any \var{type} specified for a variable may contain
+ name structure or union types with the slots specified. Within the
+ lexical scope of the binding specifiers and body, a locally defined
+ structure type \var{foo} can be referenced by its name using:
+\begin{lisp}
+ (struct foo)
+\end{lisp}
+\end{defmac}
+
+%%\node External Alien Variables, , Local Alien Variables, Alien Variables
+\subsection{External Alien Variables}
+\label{external-aliens}
+
+External Alien names are strings, and Lisp names are symbols. When an
+external Alien is represented using a Lisp variable, there must be a
+way to convert from one name syntax into the other. The macros
+\code{extern-alien}, \code{def-alien-variable} and
+\funref{def-alien-routine} use this conversion heuristic:
+\begin{itemize}
+\item Alien names are converted to Lisp names by uppercasing and
+ replacing underscores with hyphens.
+
+\item Conversely, Lisp names are converted to Alien names by
+ lowercasing and replacing hyphens with underscores.
+
+\item Both the Lisp symbol and Alien string names may be separately
+ specified by using a list of the form:
+\begin{lisp}
+ (\var{alien-string} \var{lisp-symbol})
+\end{lisp}
+\end{itemize}
+
+\begin{defmac}{alien:}{def-alien-variable}{\var{name} \var{type}}
+
+ This macro defines \var{name} as an external Alien variable of the
+ specified Alien \var{type}. \var{name} and \var{type} are not
+ evaluated. The Lisp name of the variable (see above) becomes a
+ global Alien variable in the Lisp namespace. Global Alien variables
+ are effectively ``global symbol macros''; a reference to the
+ variable fetches the contents of the external variable. Similarly,
+ setting the variable stores new contents---the new contents must be
+ of the declared \var{type}.
+
+ For example, it is often necessary to read the global C variable
+ \code{errno} to determine why a particular function call failed. It
+ is possible to define errno and make it accessible from Lisp by the
+ following:
+\begin{lisp}
+(def-alien-variable "errno" int)
+
+;; Now it is possible to get the value of the C variable errno simply by
+;; referencing that Lisp variable:
+;;
+(print errno)
+\end{lisp}
+\end{defmac}
+
+\begin{defmac}{alien:}{extern-alien}{\var{name} \var{type}}
+
+ This macro returns an Alien with the specified \var{type} which
+ points to an externally defined value. \var{name} is not evaluated,
+ and may be specified either as a string or a symbol. \var{type} is
+ an unevaluated Alien type specifier.
+\end{defmac}
+
+%%\f
+%%\node Alien Data Structure Example, Loading Unix Object Files, Alien Variables, Alien Objects
+\section{Alien Data Structure Example}
+
+Now that we have Alien types, operations and variables, we can manipulate
+foreign data structures. This C declaration can be translated into the
+following Alien type:
+\begin{lisp}
+struct foo \{
+ int a;
+ struct foo *b[100];
+\};
+
+ \myequiv
+
+(def-alien-type nil
+ (struct foo
+ (a int)
+ (b (array (* (struct foo)) 100))))
+\end{lisp}
+
+With this definition, the following C expression can be translated in this way:
+\begin{example}
+struct foo f;
+f.b[7].a
+
+ \myequiv
+
+(with-alien ((f (struct foo)))
+ (slot (deref (slot f 'b) 7) 'a)
+ ;;
+ ;; Do something with f...
+ )
+\end{example}
+
+
+Or consider this example of an external C variable and some accesses:
+\begin{example}
+struct c_struct \{
+ short x, y;
+ char a, b;
+ int z;
+ c_struct *n;
+\};
+
+extern struct c_struct *my_struct;
+
+my_struct->x++;
+my_struct->a = 5;
+my_struct = my_struct->n;
+\end{example}
+which can be made be manipulated in Lisp like this:
+\begin{lisp}
+(def-alien-type nil
+ (struct c-struct
+ (x short)
+ (y short)
+ (a char)
+ (b char)
+ (z int)
+ (n (* c-struct))))
+
+(def-alien-variable "my_struct" (* c-struct))
+
+(incf (slot my-struct 'x))
+(setf (slot my-struct 'a) 5)
+(setq my-struct (slot my-struct 'n))
+\end{lisp}
+
+
+%%\f
+%%\node Loading Unix Object Files, Alien Function Calls, Alien Data Structure Example, Alien Objects
+\section{Loading Unix Object Files}
+
+Foreign object files are loaded into the running Lisp process by
+\code{load-foreign}. First, it runs the linker on the files and
+libraries, creating an absolute Unix object file. This object file is
+then loaded into into the currently running Lisp. The external
+symbols defining routines and variables are made available for future
+external references (e.g. by \code{extern-alien}.)
+\code{load-foreign} must be run before any of the defined symbols are
+referenced.
+
+Note that if a Lisp core image is saved (using \funref{save-lisp}), all
+loaded foreign code is lost when the image is restarted.
+
+\begin{defun}{alien:}{load-foreign}{%
+ \args{\var{files} \keys{\kwd{libraries} \kwd{base-file} \kwd{env}}}}
+
+ \var{files} is a \code{simple-string} or list of
+ \code{simple-string}s specifying the names of the object files.
+ \var{libraries} is a list of \code{simple-string}s specifying
+ libraries in a format that \code{ld}, the Unix linker, expects. The
+ default value for \var{libraries} is \code{("-lc")} (i.e., the
+ standard C library). \var{base-file} is the file to use for the
+ initial symbol table information. The default is the Lisp start up
+ code: \file{path:lisp}. \var{env} should be a list of simple
+ strings in the format of Unix environment variables (i.e.,
+ \code{\var{A}=\var{B}}, where \var{A} is an environment variable and
+ \var{B} is its value). The default value for \var{env} is the
+ environment information available at the time Lisp was invoked.
+ Unless you are certain that you want to change this, you should just
+ use the default.
+\end{defun}
+
+%%\f
+%%\node Alien Function Calls, Step-by-Step Alien Example, Loading Unix Object Files, Alien Objects
+\section{Alien Function Calls}
+
+The foreign function call interface allows a Lisp program to call functions
+written in other languages. The current implementation of the foreign
+function call interface assumes a C calling convention and thus routines
+written in any language that adheres to this convention may be called from
+Lisp.
+
+Lisp sets up various interrupt handling routines and other environment
+information when it first starts up, and expects these to be in place at all
+times. The C functions called by Lisp should either not change the
+environment, especially the interrupt entry points, or should make sure
+that these entry points are restored when the C function returns to Lisp.
+If a C function makes changes without restoring things to the way they were
+when the C function was entered, there is no telling what will happen.
+
+\begin{comment}
+* alien-funcall:: The alien-funcall Primitive
+* def-alien-routine:: The def-alien-routine Macro
+* def-alien-routine Example::
+* Calling Lisp from C::
+\end{comment}
+
+%%\node alien-funcall, def-alien-routine, Alien Function Calls, Alien Function Calls
+\subsection{The alien-funcall Primitive}
+
+\begin{defun}{alien:}{alien-funcall}{%
+ \args{\var{alien-function} \amprest{} \var{arguments}}}
+
+ This function is the foreign function call primitive:
+ \var{alien-function} is called with the supplied \var{arguments} and
+ its value is returned. The \var{alien-function} is an arbitrary
+ run-time expression; to call a constant function, use
+ \funref{extern-alien} or \code{def-alien-routine}.
+
+ The type of \var{alien-function} must be \code{(alien (function
+ ...))} or \code{(alien (* (function ...)))},
+ \xlref{alien-function-types}. The function type is used to
+ determine how to call the function (as though it was declared with
+ a prototype.) The type need not be known at compile time, but only
+ known-type calls are efficiently compiled. Limitations:
+ \begin{itemize}
+ \item Structure type return values are not implemented.
+ \item Passing of structures by value is not implemented.
+ \end{itemize}
+\end{defun}
+
+Here is an example which allocates a \code{(struct foo)}, calls a foreign
+function to initialize it, then returns a Lisp vector of all the
+\code{(* (struct foo))} objects filled in by the foreign call:
+\begin{lisp}
+;;
+;; Allocate a foo on the stack.
+(with-alien ((f (struct foo)))
+ ;;
+ ;; Call some C function to fill in foo fields.
+ (alien-funcall (extern-alien "mangle_foo" (function void (* foo)))
+ (addr f))
+ ;;
+ ;; Find how many foos to use by getting the A field.
+ (let* ((num (slot f 'a))
+ (result (make-array num)))
+ ;;
+ ;; Get a pointer to the array so that we don't have to keep extracting it:
+ (with-alien ((a (* (array (* (struct foo)) 100)) (addr (slot f 'b))))
+ ;;
+ ;; Loop over the first N elements and stash them in the result vector.
+ (dotimes (i num)
+ (setf (svref result i) (deref (deref a) i)))
+ result)))
+\end{lisp}
+
+%%\node def-alien-routine, def-alien-routine Example, alien-funcall, Alien Function Calls
+\subsection{The def-alien-routine Macro}
+
+
+\begin{defmac}{alien:}{def-alien-routine}{\var{name} \var{result-type}
+ \mstar{(\var{aname} \var{atype} \mopt{style})}}
+
+ This macro is a convenience for automatically generating Lisp
+ interfaces to simple foreign functions. The primary feature is the
+ parameter style specification, which translates the C
+ pass-by-reference idiom into additional return values.
+
+ \var{name} is usually a string external symbol, but may also be a
+ symbol Lisp name or a list of the foreign name and the Lisp name.
+ If only one name is specified, the other is automatically derived,
+ (\pxlref{external-aliens}.)
+
+ \var{result-type} is the Alien type of the return value. Each
+ remaining subform specifies an argument to the foreign function.
+ \var{aname} is the symbol name of the argument to the constructed
+ function (for documentation) and \var{atype} is the Alien type of
+ corresponding foreign argument. The semantics of the actual call
+ are the same as for \funref{alien-funcall}. \var{style} should be
+ one of the following:
+ \begin{Lentry}
+ \item[\kwd{in}] specifies that the argument is passed by value.
+ This is the default. \kwd{in} arguments have no corresponding
+ return value from the Lisp function.
+
+ \item[\kwd{out}] specifies a pass-by-reference output value. The
+ type of the argument must be a pointer to a fixed sized object
+ (such as an integer or pointer). \kwd{out} and \kwd{in-out}
+ cannot be used with pointers to arrays, records or functions. An
+ object of the correct size is allocated, and its address is passed
+ to the foreign function. When the function returns, the contents
+ of this location are returned as one of the values of the Lisp
+ function.
+
+ \item[\kwd{copy}] is similar to \kwd{in}, but the argument is copied
+ to a pre-allocated object and a pointer to this object is passed
+ to the foreign routine.
+
+ \item[\kwd{in-out}] is a combination of \kwd{copy} and \kwd{out}.
+ The argument is copied to a pre-allocated object and a pointer to
+ this object is passed to the foreign routine. On return, the
+ contents of this location is returned as an additional value.
+ \end{Lentry}
+ Any efficiency-critical foreign interface function should be inline
+ expanded by preceding \code{def-alien-routine} with:
+ \begin{lisp}
+ (declaim (inline \var{lisp-name}))
+ \end{lisp}
+ In addition to avoiding the Lisp call overhead, this allows
+ pointers, word-integers and floats to be passed using non-descriptor
+ representations, avoiding consing (\pxlref{non-descriptor}.)
+\end{defmac}
+
+%%\node def-alien-routine Example, Calling Lisp from C, def-alien-routine, Alien Function Calls
+\subsection{def-alien-routine Example}
+
+Consider the C function \code{cfoo} with the following calling convention:
+\begin{example}
+cfoo (str, a, i)
+ char *str;
+ char *a; /* update */
+ int *i; /* out */
+\{
+/* Body of cfoo. */
+\}
+\end{example}
+which can be described by the following call to \code{def-alien-routine}:
+\begin{lisp}
+(def-alien-routine "cfoo" void
+ (str c-string)
+ (a char :in-out)
+ (i int :out))
+\end{lisp}
+The Lisp function \code{cfoo} will have two arguments (\var{str} and \var{a})
+and two return values (\var{a} and \var{i}).
+
+%%\node Calling Lisp from C, , def-alien-routine Example, Alien Function Calls
+\subsection{Calling Lisp from C}
+
+Calling Lisp functions from C is sometimes possible, but is rather hackish.
+See \code{funcall0} ... \code{funcall3} in the \file{lisp/arch.h}. The
+arguments must be valid CMU CL object descriptors (e.g. fixnums must be
+left-shifted by 2.) See \file{compiler/generic/objdef.lisp} or the derived
+file \file{lisp/internals.h} for details of the object representation.
+\file{lisp/internals.h} is mechanically generated, and is not part of the
+source distribution. It is distributed in the \file{docs/} directory of the
+binary distribution.
+
+Note that the garbage collector moves objects, and won't be able to fix up any
+references in C variables, so either turn GC off or don't keep Lisp pointers
+in C data unless they are to statically allocated objects. You can use
+\funref{purify} to place live data structures in static space so that they
+won't move during GC.
+
+\begin{changebar}
+\subsection{Accessing Lisp Arrays}
+
+Due to the way \cmucl{} manages memory, the amount of memory that can
+be dynamically allocated by \code{malloc} or \funref{make-alien} is
+limited\footnote{\cmucl{} mmaps a large piece of memory for it's own
+ use and this memory is typically about 8 MB above the start of the C
+ heap. Thus, only about 8 MB of memory can be dynamically
+ allocated.}.
+
+To overcome this limitation, it is possible to access the content of
+Lisp arrays which are limited only by the amount of physical memory
+and swap space available. However, this technique is only useful if
+the foreign function takes pointers to memory instead of allocating
+memory for itself. In latter case, you will have to modify the
+foreign functions.
+
+This technique takes advantage of the fact that \cmucl{} has
+specialized array types (\pxlref{specialized-array-types}) that match
+a typical C array. For example, a \code{(simple-array double-float
+ (100))} is stored in memory in essentially the same way as the C
+array \code{double x[100]} would be. The following function allows us
+to get the physical address of such a Lisp array:
+\begin{example}
+(defun array-data-address (array)
+ "Return the physical address of where the actual data of an array is
+stored.
+
+ARRAY must be a specialized array type in CMU Lisp. This means ARRAY
+must be an array of one of the following types:
+
+ double-float
+ single-float
+ (unsigned-byte 32)
+ (unsigned-byte 16)
+ (unsigned-byte 8)
+ (signed-byte 32)
+ (signed-byte 16)
+ (signed-byte 8)
+"
+ (declare (type (or #+signed-array (array (signed-byte 8))
+ #+signed-array (array (signed-byte 16))
+ #+signed-array (array (signed-byte 32))
+ (array (unsigned-byte 8))
+ (array (unsigned-byte 16))
+ (array (unsigned-byte 32))
+ (array single-float)
+ (array double-float))
+ array)
+ (optimize (speed 3) (safety 0))
+ (ext:optimize-interface (safety 3)))
+ ;; with-array-data will get us to the actual data. However, because
+ ;; the array could have been displaced, we need to know where the
+ ;; data starts.
+ (lisp::with-array-data ((data array)
+ (start)
+ (end))
+ (declare (ignore end))
+ ;; DATA is a specialized simple-array. Memory is laid out like this:
+ ;;
+ ;; byte offset Value
+ ;; 0 type code (should be 70 for double-float vector)
+ ;; 4 4 * number of elements in vector
+ ;; 8 1st element of vector
+ ;; ... ...
+ ;;
+ (let ((addr (+ 8 (logandc1 7 (kernel:get-lisp-obj-address data))))
+ (type-size (let ((type (array-element-type data)))
+ (cond ((or (equal type '(signed-byte 8))
+ (equal type '(unsigned-byte 8)))
+ 1)
+ ((or (equal type '(signed-byte 16))
+ (equal type '(unsigned-byte 16)))
+ 2)
+ ((or (equal type '(signed-byte 32))
+ (equal type '(unsigned-byte 32)))
+ 4)
+ ((equal type 'single-float)
+ 4)
+ ((equal type 'double-float)
+ 8)
+ (t
+ (error "Unknown specialized array element type"))))))
+ (declare (type (unsigned-byte 32) addr)
+ (optimize (speed 3) (safety 0) (ext:inhibit-warnings 3)))
+ (system:int-sap (the (unsigned-byte 32)
+ (+ addr (* type-size start)))))))
+\end{example}
+
+Assume we have the C function below that we wish to use:
+\begin{example}
+ double dotprod(double* x, double* y, int n)
+ \{
+ int k;
+ double sum = 0;
+
+ for (k = 0; k < n; ++k) \{
+ sum += x[k] * y[k];
+ \}
+ \}
+\end{example}
+The following example generates two large arrays in Lisp, and calls the C
+function to do the desired computation. This would not have been
+possible using \code{malloc} or \code{make-alien} since we need about
+16 MB of memory to hold the two arrays.
+\begin{example}
+ (def-alien-routine "dotprod" double
+ (x (* double-float) :in)
+ (y (* double-float) :in)
+ (n int :in))
+
+ (let ((x (make-array 1000000 :element-type 'double-float))
+ (y (make-array 1000000 :element-type 'double-float)))
+ ;; Initialize X and Y somehow
+ (let ((x-addr (system:int-sap (array-data-address x)))
+ (y-addr (system:int-sap (array-data-address y))))
+ (dotprod x-addr y-addr 1000000)))
+\end{example}
+In this example, it may be useful to wrap the inner \code{let}
+expression in an \code{unwind-protect} that first turns off garbage
+collection and then turns garbage collection on afterwards. This will
+prevent garbage collection from moving \code{x} and \code{y} after we
+have obtained the (now erroneous) addresses but before the call to
+\code{dotprod} is made.
+
+\end{changebar}
+%%\f
+%%\node Step-by-Step Alien Example, , Alien Function Calls, Alien Objects
+\section{Step-by-Step Alien Example}
+
+This section presents a complete example of an interface to a somewhat
+complicated C function. This example should give a fairly good idea
+of how to get the effect you want for almost any kind of C function.
+Suppose you have the following C function which you want to be able to
+call from Lisp in the file \file{test.c}:
+\begin{verbatim}
+struct c_struct
+{
+ int x;
+ char *s;
+};
+
+struct c_struct *c_function (i, s, r, a)
+ int i;
+ char *s;
+ struct c_struct *r;
+ int a[10];
+{
+ int j;
+ struct c_struct *r2;
+
+ printf("i = %d\n", i);
+ printf("s = %s\n", s);
+ printf("r->x = %d\n", r->x);
+ printf("r->s = %s\n", r->s);
+ for (j = 0; j < 10; j++) printf("a[%d] = %d.\n", j, a[j]);
+ r2 = (struct c_struct *) malloc (sizeof(struct c_struct));
+ r2->x = i + 5;
+ r2->s = "A C string";
+ return(r2);
+};
+\end{verbatim}
+It is possible to call this function from Lisp using the file \file{test.lisp}
+whose contents is:
+\begin{lisp}
+;;; -*- Package: test-c-call -*-
+(in-package "TEST-C-CALL")
+(use-package "ALIEN")
+(use-package "C-CALL")
+
+;;; Define the record c-struct in Lisp.
+(def-alien-type nil
+ (struct c-struct
+ (x int)
+ (s c-string)))
+
+;;; Define the Lisp function interface to the C routine. It returns a
+;;; pointer to a record of type c-struct. It accepts four parameters:
+;;; i, an int; s, a pointer to a string; r, a pointer to a c-struct
+;;; record; and a, a pointer to the array of 10 ints.
+;;;
+;;; The INLINE declaration eliminates some efficiency notes about heap
+;;; allocation of Alien values.
+(declaim (inline c-function))
+(def-alien-routine c-function
+ (* (struct c-struct))
+ (i int)
+ (s c-string)
+ (r (* (struct c-struct)))
+ (a (array int 10)))
+
+;;; A function which sets up the parameters to the C function and
+;;; actually calls it.
+(defun call-cfun ()
+ (with-alien ((ar (array int 10))
+ (c-struct (struct c-struct)))
+ (dotimes (i 10) ; Fill array.
+ (setf (deref ar i) i))
+ (setf (slot c-struct 'x) 20)
+ (setf (slot c-struct 's) "A Lisp String")
+
+ (with-alien ((res (* (struct c-struct))
+ (c-function 5 "Another Lisp String" (addr c-struct) ar)))
+ (format t "Returned from C function.~%")
+ (multiple-value-prog1
+ (values (slot res 'x)
+ (slot res 's))
+ ;;
+ ;; Deallocate result \i{after} we are done using it.
+ (free-alien res)))))
+\end{lisp}
+To execute the above example, it is necessary to compile the C routine as
+follows:
+\begin{example}
+cc -c test.c
+\end{example}
+In order to enable incremental loading with some linkers, you may need to say:
+\begin{example}
+cc -G 0 -c test.c
+\end{example}
+Once the C code has been compiled, you can start up Lisp and load it in:
+\begin{example}
+%lisp
+;;; Lisp should start up with its normal prompt.
+
+;;; Compile the Lisp file. This step can be done separately. You don't have
+;;; to recompile every time.
+* (compile-file "test.lisp")
+
+;;; Load the foreign object file to define the necessary symbols. This must
+;;; be done before loading any code that refers to these symbols. next block
+;;; of comments are actually the output of LOAD-FOREIGN. Different linkers
+;;; will give different warnings, but some warning about redefining the code
+;;; size is typical.
+* (load-foreign "test.o")
+
+;;; Running library:load-foreign.csh...
+;;; Loading object file...
+;;; Parsing symbol table...
+Warning: "_gp" moved from #x00C082C0 to #x00C08460.
+
+Warning: "end" moved from #x00C00340 to #x00C004E0.
+
+;;; o.k. now load the compiled Lisp object file.
+* (load "test")
+
+;;; Now we can call the routine that sets up the parameters and calls the C
+;;; function.
+* (test-c-call::call-cfun)
+
+;;; The C routine prints the following information to standard output.
+i = 5
+s = Another Lisp string
+r->x = 20
+r->s = A Lisp string
+a[0] = 0.
+a[1] = 1.
+a[2] = 2.
+a[3] = 3.
+a[4] = 4.
+a[5] = 5.
+a[6] = 6.
+a[7] = 7.
+a[8] = 8.
+a[9] = 9.
+;;; Lisp prints out the following information.
+Returned from C function.
+;;; Return values from the call to test-c-call::call-cfun.
+10
+"A C string"
+*
+\end{example}
+
+If any of the foreign functions do output, they should not be called from
+within Hemlock. Depending on the situation, various strange behavior occurs.
+Under X, the output goes to the window in which Lisp was started; on a
+terminal, the output will overwrite the Hemlock screen image; in a Hemlock
+slave, standard output is \file{/dev/null} by default, so any output is
+discarded.
+
+\hide{File:/afs/cs.cmu.edu/project/clisp/hackers/ram/docs/cmu-user/ipc.ms}
+
+%%\node Interprocess Communication under LISP, Debugger Programmer's Interface, Alien Objects, Top
+\chapter{Interprocess Communication under LISP}
+\begin{center}
+\b{Written by William Lott and Bill Chiles}
+\end{center}
+\label{remote}
+
+CMU Common Lisp offers a facility for interprocess communication (IPC)
+on top of using Unix system calls and the complications of that level
+of IPC. There is a simple remote-procedure-call (RPC) package build
+on top of TCP/IP sockets.
+
+
+\begin{comment}
+* The REMOTE Package::
+* The WIRE Package::
+* Out-Of-Band Data::
+\end{comment}
+
+%%\node The REMOTE Package, The WIRE Package, Interprocess Communication under LISP, Interprocess Communication under LISP
+\section{The REMOTE Package}
+The \code{remote} package provides simple RPC facility including
+interfaces for creating servers, connecting to already existing
+servers, and calling functions in other Lisp processes. The routines
+for establishing a connection between two processes,
+\code{create-request-server} and \code{connect-to-remote-server},
+return \var{wire} structures. A wire maintains the current state of
+a connection, and all the RPC forms require a wire to indicate where
+to send requests.
+
+
+\begin{comment}
+* Connecting Servers and Clients::
+* Remote Evaluations::
+* Remote Objects::
+* Host Addresses::
+\end{comment}
+
+%%\node Connecting Servers and Clients, Remote Evaluations, The REMOTE Package, The REMOTE Package
+\subsection{Connecting Servers and Clients}
+
+Before a client can connect to a server, it must know the network address on
+which the server accepts connections. Network addresses consist of a host
+address or name, and a port number. Host addresses are either a string of the
+form \code{VANCOUVER.SLISP.CS.CMU.EDU} or a 32 bit unsigned integer. Port
+numbers are 16 bit unsigned integers. Note: \var{port} in this context has
+nothing to do with Mach ports and message passing.
+
+When a process wants to receive connection requests (that is, become a
+server), it first picks an integer to use as the port. Only one server
+(Lisp or otherwise) can use a given port number on a given machine at
+any particular time. This can be an iterative process to find a free
+port: picking an integer and calling \code{create-request-server}. This
+function signals an error if the chosen port is unusable. You will
+probably want to write a loop using \code{handler-case}, catching
+conditions of type error, since this function does not signal more
+specific conditions.
+
+\begin{defun}{wire:}{create-request-server}{%
+ \args{\var{port} \ampoptional{} \var{on-connect}}}
+
+ \code{create-request-server} sets up the current Lisp to accept
+ connections on the given port. If port is unavailable for any
+ reason, this signals an error. When a client connects to this port,
+ the acceptance mechanism makes a wire structure and invokes the
+ \var{on-connect} function. Invoking this function has a couple
+ purposes, and \var{on-connect} may be \nil{} in which case the
+ system foregoes invoking any function at connect time.
+
+ The \var{on-connect} function is both a hook that allows you access
+ to the wire created by the acceptance mechanism, and it confirms the
+ connection. This function takes two arguments, the wire and the
+ host address of the connecting process. See the section on host
+ addresses below. When \var{on-connect} is \nil, the request server
+ allows all connections. When it is non-\nil, the function returns
+ two values, whether to accept the connection and a function the
+ system should call when the connection terminates. Either value may
+ be \nil, but when the first value is \nil, the acceptance mechanism
+ destroys the wire.
+
+ \code{create-request-server} returns an object that
+ \code{destroy-request-server} uses to terminate a connection.
+\end{defun}
+
+\begin{defun}{wire:}{destroy-request-server}{\args{\var{server}}}
+
+ \code{destroy-request-server} takes the result of
+ \code{create-request-server} and terminates that server. Any
+ existing connections remain intact, but all additional connection
+ attempts will fail.
+\end{defun}
+
+\begin{defun}{wire:}{connect-to-remote-server}{%
+ \args{\var{host} \var{port} \ampoptional{} \var{on-death}}}
+
+ \code{connect-to-remote-server} attempts to connect to a remote
+ server at the given \var{port} on \var{host} and returns a wire
+ structure if it is successful. If \var{on-death} is non-\nil, it is
+ a function the system invokes when this connection terminates.
+\end{defun}
+
+
+%%\node Remote Evaluations, Remote Objects, Connecting Servers and Clients, The REMOTE Package
+\subsection{Remote Evaluations}
+After the server and client have connected, they each have a wire
+allowing function evaluation in the other process. This RPC mechanism
+has three flavors: for side-effect only, for a single value, and for
+multiple values.
+
+Only a limited number of data types can be sent across wires as
+arguments for remote function calls and as return values: integers
+inclusively less than 32 bits in length, symbols, lists, and
+\var{remote-objects} (\pxlref{remote-objs}). The system sends symbols
+as two strings, the package name and the symbol name, and if the
+package doesn't exist remotely, the remote process signals an error.
+The system ignores other slots of symbols. Lists may be any tree of
+the above valid data types. To send other data types you must
+represent them in terms of these supported types. For example, you
+could use \code{prin1-to-string} locally, send the string, and use
+\code{read-from-string} remotely.
+
+\begin{defmac}{wire:}{remote}{%
+ \args{\var{wire} \mstar{call-specs}}}
+
+ The \code{remote} macro arranges for the process at the other end of
+ \var{wire} to invoke each of the functions in the \var{call-specs}.
+ To make sure the system sends the remote evaluation requests over
+ the wire, you must call \code{wire-force-output}.
+
+ Each of \var{call-specs} looks like a function call textually, but
+ it has some odd constraints and semantics. The function position of
+ the form must be the symbolic name of a function. \code{remote}
+ evaluates each of the argument subforms for each of the
+ \var{call-specs} locally in the current context, sending these
+ values as the arguments for the functions.
+
+ Consider the following example:
+\begin{verbatim}
+(defun write-remote-string (str)
+ (declare (simple-string str))
+ (wire:remote wire
+ (write-string str)))
+\end{verbatim}
+ The value of \code{str} in the local process is passed over the wire
+ with a request to invoke \code{write-string} on the value. The
+ system does not expect to remotely evaluate \code{str} for a value
+ in the remote process.
+\end{defmac}
+
+\begin{defun}{wire:}{wire-force-output}{\args{\var{wire}}}
+
+ \code{wire-force-output} flushes all internal buffers associated
+ with \var{wire}, sending the remote requests. This is necessary
+ after a call to \code{remote}.
+\end{defun}
+
+\begin{defmac}{wire:}{remote-value}{\args{\var{wire} \var{call-spec}}}
+
+ The \code{remote-value} macro is similar to the \code{remote} macro.
+ \code{remote-value} only takes one \var{call-spec}, and it returns
+ the value returned by the function call in the remote process. The
+ value must be a valid type the system can send over a wire, and
+ there is no need to call \code{wire-force-output} in conjunction
+ with this interface.
+
+ If client unwinds past the call to \code{remote-value}, the server
+ continues running, but the system ignores the value the server sends
+ back.
+
+ If the server unwinds past the remotely requested call, instead of
+ returning normally, \code{remote-value} returns two values, \nil{}
+ and \true. Otherwise this returns the result of the remote
+ evaluation and \nil.
+\end{defmac}
+
+\begin{defmac}{wire:}{remote-value-bind}{%
+ \args{\var{wire} (\mstar{variable}) remote-form
+ \mstar{local-forms}}}
+
+ \code{remote-value-bind} is similar to \code{multiple-value-bind}
+ except the values bound come from \var{remote-form}'s evaluation in
+ the remote process. The \var{local-forms} execute in an implicit
+ \code{progn}.
+
+ If the client unwinds past the call to \code{remote-value-bind}, the
+ server continues running, but the system ignores the values the
+ server sends back.
+
+ If the server unwinds past the remotely requested call, instead of
+ returning normally, the \var{local-forms} never execute, and
+ \code{remote-value-bind} returns \nil.
+\end{defmac}
+
+
+%%\node Remote Objects, Host Addresses, Remote Evaluations, The REMOTE Package
+\subsection{Remote Objects}
+\label{remote-objs}
+
+The wire mechanism only directly supports a limited number of data
+types for transmission as arguments for remote function calls and as
+return values: integers inclusively less than 32 bits in length,
+symbols, lists. Sometimes it is useful to allow remote processes to
+refer to local data structures without allowing the remote process
+to operate on the data. We have \var{remote-objects} to support
+this without the need to represent the data structure in terms of
+the above data types, to send the representation to the remote
+process, to decode the representation, to later encode it again, and
+to send it back along the wire.
+
+You can convert any Lisp object into a remote-object. When you send
+a remote-object along a wire, the system simply sends a unique token
+for it. In the remote process, the system looks up the token and
+returns a remote-object for the token. When the remote process
+needs to refer to the original Lisp object as an argument to a
+remote call back or as a return value, it uses the remote-object it
+has which the system converts to the unique token, sending that
+along the wire to the originating process. Upon receipt in the
+first process, the system converts the token back to the same
+(\code{eq}) remote-object.
+
+\begin{defun}{wire:}{make-remote-object}{\args{\var{object}}}
+
+ \code{make-remote-object} returns a remote-object that has
+ \var{object} as its value. The remote-object can be passed across
+ wires just like the directly supported wire data types.
+\end{defun}
+
+\begin{defun}{wire:}{remote-object-p}{\args{\var{object}}}
+
+ The function \code{remote-object-p} returns \true{} if \var{object}
+ is a remote object and \nil{} otherwise.
+\end{defun}
+
+\begin{defun}{wire:}{remote-object-local-p}{\args{\var{remote}}}
+
+ The function \code{remote-object-local-p} returns \true{} if
+ \var{remote} refers to an object in the local process. This is can
+ only occur if the local process created \var{remote} with
+ \code{make-remote-object}.
+\end{defun}
+
+\begin{defun}{wire:}{remote-object-eq}{\args{\var{obj1} \var{obj2}}}
+
+ The function \code{remote-object-eq} returns \true{} if \var{obj1} and
+ \var{obj2} refer to the same (\code{eq}) lisp object, regardless of
+ which process created the remote-objects.
+\end{defun}
+
+\begin{defun}{wire:}{remote-object-value}{\args{\var{remote}}}
+
+ This function returns the original object used to create the given
+ remote object. It is an error if some other process originally
+ created the remote-object.
+\end{defun}
+
+\begin{defun}{wire:}{forget-remote-translation}{\args{\var{object}}}
+
+ This function removes the information and storage necessary to
+ translate remote-objects back into \var{object}, so the next
+ \code{gc} can reclaim the memory. You should use this when you no
+ longer expect to receive references to \var{object}. If some remote
+ process does send a reference to \var{object},
+ \code{remote-object-value} signals an error.
+\end{defun}
+
+
+%%\node Host Addresses, , Remote Objects, The REMOTE Package
+\subsection{Host Addresses}
+The operating system maintains a database of all the valid host
+addresses. You can use this database to convert between host names
+and addresses and vice-versa.
+
+\begin{defun}{ext:}{lookup-host-entry}{\args{\var{host}}}
+
+ \code{lookup-host-entry} searches the database for the given
+ \var{host} and returns a host-entry structure for it. If it fails
+ to find \var{host} in the database, it returns \nil. \var{Host} is
+ either the address (as an integer) or the name (as a string) of the
+ desired host.
+\end{defun}
+
+\begin{defun}{ext:}{host-entry-name}{\args{\var{host-entry}}}
+ \defunx[ext:]{host-entry-aliases}{\args{\var{host-entry}}}
+ \defunx[ext:]{host-entry-addr-list}{\args{\var{host-entry}}}
+ \defunx[ext:]{host-entry-addr}{\args{\var{host-entry}}}
+
+ \code{host-entry-name}, \code{host-entry-aliases}, and
+ \code{host-entry-addr-list} each return the indicated slot from the
+ host-entry structure. \code{host-entry-addr} returns the primary
+ (first) address from the list returned by
+ \code{host-entry-addr-list}.
+\end{defun}
+
+
+%%\node The WIRE Package, Out-Of-Band Data, The REMOTE Package, Interprocess Communication under LISP
+\section{The WIRE Package}
+
+The \code{wire} package provides for sending data along wires. The
+\code{remote} package sits on top of this package. All data sent
+with a given output routine must be read in the remote process with
+the complementary fetching routine. For example, if you send so a
+string with \code{wire-output-string}, the remote process must know
+to use \code{wire-get-string}. To avoid rigid data transfers and
+complicated code, the interface supports sending
+\var{tagged} data. With tagged data, the system sends a tag
+announcing the type of the next data, and the remote system takes
+care of fetching the appropriate type.
+
+When using interfaces at the wire level instead of the RPC level,
+the remote process must read everything sent by these routines. If
+the remote process leaves any input on the wire, it will later
+mistake the data for an RPC request causing unknown lossage.
+
+\begin{comment}
+* Untagged Data::
+* Tagged Data::
+* Making Your Own Wires::
+\end{comment}
+
+%%\node Untagged Data, Tagged Data, The WIRE Package, The WIRE Package
+\subsection{Untagged Data}
+When using these routines both ends of the wire know exactly what types are
+coming and going and in what order. This data is restricted to the following
+types:
+\begin{itemize}
+
+\item
+8 bit unsigned bytes.
+
+\item
+32 bit unsigned bytes.
+
+\item
+32 bit integers.
+
+\item
+simple-strings less than 65535 in length.
+\end{itemize}
+
+
+\begin{defun}{wire:}{wire-output-byte}{\args{\var{wire} \var{byte}}}
+ \defunx[wire:]{wire-get-byte}{\args{\var{wire}}}
+ \defunx[wire:]{wire-output-number}{\args{\var{wire} \var{number}}}
+ \defunx[wire:]{wire-get-number}{\args{\var{wire} \ampoptional{}
+ \var{signed}}}
+ \defunx[wire:]{wire-output-string}{\args{\var{wire} \var{string}}}
+ \defunx[wire:]{wire-get-string}{\args{\var{wire}}}
+
+ These functions either output or input an object of the specified
+ data type. When you use any of these output routines to send data
+ across the wire, you must use the corresponding input routine
+ interpret the data.
+\end{defun}
+
+
+%%\node Tagged Data, Making Your Own Wires, Untagged Data, The WIRE Package
+\subsection{Tagged Data}
+When using these routines, the system automatically transmits and interprets
+the tags for you, so both ends can figure out what kind of data transfers
+occur. Sending tagged data allows a greater variety of data types: integers
+inclusively less than 32 bits in length, symbols, lists, and \var{remote-objects}
+(\pxlref{remote-objs}). The system sends symbols as two strings, the
+package name and the symbol name, and if the package doesn't exist remotely,
+the remote process signals an error. The system ignores other slots of
+symbols. Lists may be any tree of the above valid data types. To send other
+data types you must represent them in terms of these supported types. For
+example, you could use \code{prin1-to-string} locally, send the string, and use
+\code{read-from-string} remotely.
+
+\begin{defun}{wire:}{wire-output-object}{%
+ \args{\var{wire} \var{object} \ampoptional{} \var{cache-it}}}
+ \defunx[wire:]{wire-get-object}{\args{\var{wire}}}
+
+ The function \code{wire-output-object} sends \var{object} over
+ \var{wire} preceded by a tag indicating its type.
+
+ If \var{cache-it} is non-\nil, this function only sends \var{object}
+ the first time it gets \var{object}. Each end of the wire
+ associates a token with \var{object}, similar to remote-objects,
+ allowing you to send the object more efficiently on successive
+ transmissions. \var{cache-it} defaults to \true{} for symbols and
+ \nil{} for other types. Since the RPC level requires function
+ names, a high-level protocol based on a set of function calls saves
+ time in sending the functions' names repeatedly.
+
+ The function \code{wire-get-object} reads the results of
+ \code{wire-output-object} and returns that object.
+\end{defun}
+
+
+%%\node Making Your Own Wires, , Tagged Data, The WIRE Package
+\subsection{Making Your Own Wires}
+You can create wires manually in addition to the \code{remote} package's
+interface creating them for you. To create a wire, you need a Unix \i{file
+descriptor}. If you are unfamiliar with Unix file descriptors, see section 2 of
+the Unix manual pages.
+
+\begin{defun}{wire:}{make-wire}{\args{\var{descriptor}}}
+
+ The function \code{make-wire} creates a new wire when supplied with
+ the file descriptor to use for the underlying I/O operations.
+\end{defun}
+
+\begin{defun}{wire:}{wire-p}{\args{\var{object}}}
+
+ This function returns \true{} if \var{object} is indeed a wire,
+ \nil{} otherwise.
+\end{defun}
+
+\begin{defun}{wire:}{wire-fd}{\args{\var{wire}}}
+
+ This function returns the file descriptor used by the \var{wire}.
+\end{defun}
+
+
+%%\node Out-Of-Band Data, , The WIRE Package, Interprocess Communication under LISP
+\section{Out-Of-Band Data}
+
+The TCP/IP protocol allows users to send data asynchronously, otherwise
+known as \var{out-of-band} data. When using this feature, the operating
+system interrupts the receiving process if this process has chosen to be
+notified about out-of-band data. The receiver can grab this input
+without affecting any information currently queued on the socket.
+Therefore, you can use this without interfering with any current
+activity due to other wire and remote interfaces.
+
+Unfortunately, most implementations of TCP/IP are broken, so use of
+out-of-band data is limited for safety reasons. You can only reliably
+send one character at a time.
+
+This routines in this section provide a mechanism for establishing
+handlers for out-of-band characters and for sending them out-of-band.
+These all take a Unix file descriptor instead of a wire, but you can
+fetch a wire's file descriptor with \code{wire-fd}.
+
+\begin{defun}{wire:}{add-oob-handler}{\args{\var{fd} \var{char} \var{handler}}}
+
+ The function \code{add-oob-handler} arranges for \var{handler} to be
+ called whenever \var{char} shows up as out-of-band data on the file
+ descriptor \var{fd}.
+\end{defun}
+
+\begin{defun}{wire:}{remove-oob-handler}{\args{\var{fd} \var{char}}}
+
+ This function removes the handler for the character \var{char} on
+ the file descriptor \var{fd}.
+\end{defun}
+
+\begin{defun}{wire:}{remove-all-oob-handlers}{\args{\var{fd}}}
+
+ This function removes all handlers for the file descriptor \var{fd}.
+\end{defun}
+
+\begin{defun}{wire:}{send-character-out-of-band}{\args{\var{fd} \var{char}}}
+
+ This function Sends the character \var{char} down the file
+ descriptor \var{fd} out-of-band.
+\end{defun}
+
+%%\f
+\hide{File:debug-int.tex}
+%%\node Debugger Programmer's Interface, Function Index, Interprocess Communication under LISP, Top
+\chapter{Debugger Programmer's Interface}
+\label{debug-internals}
+
+The debugger programmers interface is exported from from the
+\code{"DEBUG-INTERNALS"} or \code{"DI"} package. This is a CMU
+extension that allows debugging tools to be written without detailed
+knowledge of the compiler or run-time system.
+
+Some of the interface routines take a code-location as an argument. As
+described in the section on code-locations, some code-locations are
+unknown. When a function calls for a \var{basic-code-location}, it
+takes either type, but when it specifically names the argument
+\var{code-location}, the routine will signal an error if you give it an
+unknown code-location.
+
+\begin{comment}
+* DI Exceptional Conditions::
+* Debug-variables::
+* Frames::
+* Debug-functions::
+* Debug-blocks::
+* Breakpoints::
+* Code-locations::
+* Debug-sources::
+* Source Translation Utilities::
+\end{comment}
+
+%%\f
+%%\node DI Exceptional Conditions, Debug-variables, Debugger Programmer's Interface, Debugger Programmer's Interface
+\section{DI Exceptional Conditions}
+
+Some of these operations fail depending on the availability debugging
+information. In the most severe case, when someone saved a Lisp image
+stripping all debugging data structures, no operations are valid. In
+this case, even backtracing and finding frames is impossible. Some
+interfaces can simply return values indicating the lack of information,
+or their return values are naturally meaningful in light missing data.
+Other routines, as documented below, will signal
+\code{serious-condition}s when they discover awkward situations. This
+interface does not provide for programs to detect these situations other
+than by calling a routine that detects them and signals a condition.
+These are serious-conditions because the program using the interface
+must handle them before it can correctly continue execution. These
+debugging conditions are not errors since it is no fault of the
+programmers that the conditions occur.
+
+\begin{comment}
+* Debug-conditions::
+* Debug-errors::
+\end{comment}
+
+%%\node Debug-conditions, Debug-errors, DI Exceptional Conditions, DI Exceptional Conditions
+\subsection{Debug-conditions}
+
+The debug internals interface signals conditions when it can't adhere
+to its contract. These are serious-conditions because the program
+using the interface must handle them before it can correctly continue
+execution. These debugging conditions are not errors since it is no
+fault of the programmers that the conditions occur. The interface
+does not provide for programs to detect these situations other than
+calling a routine that detects them and signals a condition.
+
+
+\begin{deftp}{Condition}{debug-condition}{}
+
+This condition inherits from serious-condition, and all debug-conditions
+inherit from this. These must be handled, but they are not programmer errors.
+\end{deftp}
+
+
+\begin{deftp}{Condition}{no-debug-info}{}
+
+This condition indicates there is absolutely no debugging information
+available.
+\end{deftp}
+
+
+\begin{deftp}{Condition}{no-debug-function-returns}{}
+
+This condition indicates the system cannot return values from a frame since
+its debug-function lacks debug information details about returning values.
+\end{deftp}
+
+
+\begin{deftp}{Condition}{no-debug-blocks}{}
+This condition indicates that a function was not compiled with debug-block
+information, but this information is necessary necessary for some requested
+operation.
+\end{deftp}
+
+\begin{deftp}{Condition}{no-debug-variables}{}
+Similar to \code{no-debug-blocks}, except that variable information was
+requested.
+\end{deftp}
+
+\begin{deftp}{Condition}{lambda-list-unavailable}{}
+Similar to \code{no-debug-blocks}, except that lambda list information was
+requested.
+\end{deftp}
+
+\begin{deftp}{Condition}{invalid-value}{}
+
+This condition indicates a debug-variable has \kwd{invalid} or \kwd{unknown}
+value in a particular frame.
+\end{deftp}
+
+
+\begin{deftp}{Condition}{ambiguous-variable-name}{}
+
+This condition indicates a user supplied debug-variable name identifies more
+than one valid variable in a particular frame.
+\end{deftp}
+
+
+%%\node Debug-errors, , Debug-conditions, DI Exceptional Conditions
+\subsection{Debug-errors}
+
+These are programmer errors resulting from misuse of the debugging tools'
+programmers' interface. You could have avoided an occurrence of one of these
+by using some routine to check the use of the routine generating the error.
+
+
+\begin{deftp}{Condition}{debug-error}{}
+This condition inherits from error, and all user programming errors inherit
+from this condition.
+\end{deftp}
+
+
+\begin{deftp}{Condition}{unhandled-condition}{}
+This error results from a signalled \code{debug-condition} occurring
+without anyone handling it.
+\end{deftp}
+
+
+\begin{deftp}{Condition}{unknown-code-location}{}
+This error indicates the invalid use of an unknown-code-location.
+\end{deftp}
+
+
+\begin{deftp}{Condition}{unknown-debug-variable}{}
+
+This error indicates an attempt to use a debug-variable in conjunction with an
+inappropriate debug-function; for example, checking the variable's validity
+using a code-location in the wrong debug-function will signal this error.
+\end{deftp}
+
+
+\begin{deftp}{Condition}{frame-function-mismatch}{}
+
+This error indicates you called a function returned by
+\code{preprocess-for-eval}
+on a frame other than the one for which the function had been prepared.
+\end{deftp}
+
+
+%%\f
+%%\node Debug-variables, Frames, DI Exceptional Conditions, Debugger Programmer's Interface
+\section{Debug-variables}
+
+Debug-variables represent the constant information about where the system
+stores argument and local variable values. The system uniquely identifies with
+an integer every instance of a variable with a particular name and package. To
+access a value, you must supply the frame along with the debug-variable since
+these are particular to a function, not every instance of a variable on the
+stack.
+
+\begin{defun}{}{debug-variable-name}{\args{\var{debug-variable}}}
+
+ This function returns the name of the \var{debug-variable}. The
+ name is the name of the symbol used as an identifier when writing
+ the code.
+\end{defun}
+
+
+\begin{defun}{}{debug-variable-package}{\args{\var{debug-variable}}}
+
+ This function returns the package name of the \var{debug-variable}.
+ This is the package name of the symbol used as an identifier when
+ writing the code.
+\end{defun}
+
+
+\begin{defun}{}{debug-variable-symbol}{\args{\var{debug-variable}}}
+
+ This function returns the symbol from interning
+ \code{debug-variable-name} in the package named by
+ \code{debug-variable-package}.
+\end{defun}
+
+
+\begin{defun}{}{debug-variable-id}{\args{\var{debug-variable}}}
+
+ This function returns the integer that makes \var{debug-variable}'s
+ name and package name unique with respect to other
+ \var{debug-variable}'s in the same function.
+\end{defun}
+
+
+\begin{defun}{}{debug-variable-validity}{%
+ \args{\var{debug-variable} \var{basic-code-location}}}
+
+ This function returns three values reflecting the validity of
+ \var{debug-variable}'s value at \var{basic-code-location}:
+ \begin{Lentry}
+ \item[\kwd{valid}] The value is known to be available.
+ \item[\kwd{invalid}] The value is known to be unavailable.
+ \item[\kwd{unknown}] The value's availability is unknown.
+ \end{Lentry}
+\end{defun}
+
+
+\begin{defun}{}{debug-variable-value}{\args{\var{debug-variable}
+ \var{frame}}}
+
+ This function returns the value stored for \var{debug-variable} in
+ \var{frame}. The value may be invalid. This is \code{SETF}'able.
+\end{defun}
+
+
+\begin{defun}{}{debug-variable-valid-value}{%
+ \args{\var{debug-variable} \var{frame}}}
+
+ This function returns the value stored for \var{debug-variable} in
+ \var{frame}. If the value is not \kwd{valid}, then this signals an
+ \code{invalid-value} error.
+\end{defun}
+
+
+%%\f
+%%\node Frames, Debug-functions, Debug-variables, Debugger Programmer's Interface
+\section{Frames}
+
+Frames describe a particular call on the stack for a particular thread. This
+is the environment for name resolution, getting arguments and locals, and
+returning values. The stack conceptually grows up, so the top of the stack is
+the most recently called function.
+
+\code{top-frame}, \code{frame-down}, \code{frame-up}, and
+\code{frame-debug-function} can only fail when there is absolutely no
+debug information available. This can only happen when someone saved a
+Lisp image specifying that the system dump all debugging data.
+
+
+\begin{defun}{}{top-frame}{}
+
+ This function never returns the frame for itself, always the frame
+ before calling \code{top-frame}.
+\end{defun}
+
+
+\begin{defun}{}{frame-down}{\args{\var{frame}}}
+
+ This returns the frame immediately below \var{frame} on the stack.
+ When \var{frame} is the bottom of the stack, this returns \nil.
+\end{defun}
+
+
+\begin{defun}{}{frame-up}{\args{\var{frame}}}
+
+ This returns the frame immediately above \var{frame} on the stack.
+ When \var{frame} is the top of the stack, this returns \nil.
+\end{defun}
+
+
+\begin{defun}{}{frame-debug-function}{\args{\var{frame}}}
+
+ This function returns the debug-function for the function whose call
+ \var{frame} represents.
+\end{defun}
+
+
+\begin{defun}{}{frame-code-location}{\args{\var{frame}}}
+
+ This function returns the code-location where \var{frame}'s
+ debug-function will continue running when program execution returns
+ to \var{frame}. If someone interrupted this frame, the result could
+ be an unknown code-location.
+\end{defun}
+
+
+\begin{defun}{}{frame-catches}{\args{\var{frame}}}
+
+ This function returns an a-list for all active catches in
+ \var{frame} mapping catch tags to the code-locations at which the
+ catch re-enters.
+\end{defun}
+
+
+\begin{defun}{}{eval-in-frame}{\args{\var{frame} \var{form}}}
+
+ This evaluates \var{form} in \var{frame}'s environment. This can
+ signal several different debug-conditions since its success relies
+ on a variety of inexact debug information: \code{invalid-value},
+ \code{ambiguous-variable-name}, \code{frame-function-mismatch}. See
+ also \funref{preprocess-for-eval}.
+\end{defun}
+
+\begin{comment}
+ \begin{defun}{}{return-from-frame}{\args{\var{frame} \var{values}}}
+
+ This returns the elements in the list \var{values} as multiple
+ values from \var{frame} as if the function \var{frame} represents
+ returned these values. This signals a
+ \code{no-debug-function-returns} condition when \var{frame}'s
+ debug-function lacks information on returning values.
+
+ \i{Not Yet Implemented}
+ \end{defun}
+\end{comment}
+
+%%\f
+%%\node Debug-functions, Debug-blocks, Frames, Debugger Programmer's Interface
+\section {Debug-functions}
+
+Debug-functions represent the static information about a function determined at
+compile time---argument and variable storage, their lifetime information,
+etc. The debug-function also contains all the debug-blocks representing
+basic-blocks of code, and these contains information about specific
+code-locations in a debug-function.
+
+\begin{defmac}{}{do-debug-function-blocks}{%
+ \args{(\var{block-var} \var{debug-function} \mopt{result-form})
+ \mstar{form}}}
+
+ This executes the forms in a context with \var{block-var} bound to
+ each debug-block in \var{debug-function} successively.
+ \var{Result-form} is an optional form to execute for a return value,
+ and \code{do-debug-function-blocks} returns \nil if there is no
+ \var{result-form}. This signals a \code{no-debug-blocks} condition
+ when the \var{debug-function} lacks debug-block information.
+\end{defmac}
+
+
+\begin{defun}{}{debug-function-lambda-list}{\args{\var{debug-function}}}
+
+ This function returns a list representing the lambda-list for
+ \var{debug-function}. The list has the following structure:
+ \begin{example}
+ (required-var1 required-var2
+ ...
+ (:optional var3 suppliedp-var4)
+ (:optional var5)
+ ...
+ (:rest var6) (:rest var7)
+ ...
+ (:keyword keyword-symbol var8 suppliedp-var9)
+ (:keyword keyword-symbol var10)
+ ...
+ )
+ \end{example}
+ Each \code{var}\var{n} is a debug-variable; however, the symbol
+ \kwd{deleted} appears instead whenever the argument remains
+ unreferenced throughout \var{debug-function}.
+
+ If there is no lambda-list information, this signals a
+ \code{lambda-list-unavailable} condition.
+\end{defun}
+
+
+\begin{defmac}{}{do-debug-function-variables}{%
+ \args{(\var{var} \var{debug-function} \mopt{result})
+ \mstar{form}}}
+
+ This macro executes each \var{form} in a context with \var{var}
+ bound to each debug-variable in \var{debug-function}. This returns
+ the value of executing \var{result} (defaults to \nil). This may
+ iterate over only some of \var{debug-function}'s variables or none
+ depending on debug policy; for example, possibly the compilation
+ only preserved argument information.
+\end{defmac}
+
+
+\begin{defun}{}{debug-variable-info-available}{\args{\var{debug-function}}}
+
+ This function returns whether there is any variable information for
+ \var{debug-function}. This is useful for distinguishing whether
+ there were no locals in a function or whether there was no variable
+ information. For example, if \code{do-debug-function-variables}
+ executes its forms zero times, then you can use this function to
+ determine the reason.
+\end{defun}
+
+
+\begin{defun}{}{debug-function-symbol-variables}{%
+ \args{\var{debug-function} \var{symbol}}}
+
+ This function returns a list of debug-variables in
+ \var{debug-function} having the same name and package as
+ \var{symbol}. If \var{symbol} is uninterned, then this returns a
+ list of debug-variables without package names and with the same name
+ as \var{symbol}. The result of this function is limited to the
+ availability of variable information in \var{debug-function}; for
+ example, possibly \var{debug-function} only knows about its
+ arguments.
+\end{defun}
+
+
+\begin{defun}{}{ambiguous-debug-variables}{%
+ \args{\var{debug-function} \var{name-prefix-string}}}
+
+ This function returns a list of debug-variables in
+ \var{debug-function} whose names contain \var{name-prefix-string} as
+ an initial substring. The result of this function is limited to the
+ availability of variable information in \var{debug-function}; for
+ example, possibly \var{debug-function} only knows about its
+ arguments.
+\end{defun}
+
+
+\begin{defun}{}{preprocess-for-eval}{%
+ \args{\var{form} \var{basic-code-location}}}
+
+ This function returns a function of one argument that evaluates
+ \var{form} in the lexical context of \var{basic-code-location}.
+ This allows efficient repeated evaluation of \var{form} at a certain
+ place in a function which could be useful for conditional breaking.
+ This signals a \code{no-debug-variables} condition when the
+ code-location's debug-function has no debug-variable information
+ available. The returned function takes a frame as an argument. See
+ also \funref{eval-in-frame}.
+\end{defun}
+
+
+\begin{defun}{}{function-debug-function}{\args{\var{function}}}
+
+ This function returns a debug-function that represents debug
+ information for \var{function}.
+\end{defun}
+
+
+\begin{defun}{}{debug-function-kind}{\args{\var{debug-function}}}
+
+ This function returns the kind of function \var{debug-function}
+ represents. The value is one of the following:
+ \begin{Lentry}
+ \item[\kwd{optional}] This kind of function is an entry point to an
+ ordinary function. It handles optional defaulting, parsing
+ keywords, etc.
+ \item[\kwd{external}] This kind of function is an entry point to an
+ ordinary function. It checks argument values and count and calls
+ the defined function.
+ \item[\kwd{top-level}] This kind of function executes one or more
+ random top-level forms from a file.
+ \item[\kwd{cleanup}] This kind of function represents the cleanup
+ forms in an \code{unwind-protect}.
+ \item[\nil] This kind of function is not one of the above; that is,
+ it is not specially marked in any way.
+ \end{Lentry}
+\end{defun}
+
+
+\begin{defun}{}{debug-function-function}{\args{\var{debug-function}}}
+
+ This function returns the Common Lisp function associated with the
+ \var{debug-function}. This returns \nil{} if the function is
+ unavailable or is non-existent as a user callable function object.
+\end{defun}
+
+
+\begin{defun}{}{debug-function-name}{\args{\var{debug-function}}}
+
+ This function returns the name of the function represented by
+ \var{debug-function}. This may be a string or a cons; do not assume
+ it is a symbol.
+\end{defun}
+
+
+%%\f
+%%\node Debug-blocks, Breakpoints, Debug-functions, Debugger Programmer's Interface
+\section{Debug-blocks}
+
+Debug-blocks contain information pertinent to a specific range of code in a
+debug-function.
+
+\begin{defmac}{}{do-debug-block-locations}{%
+ \args{(\var{code-var} \var{debug-block} \mopt{result})
+ \mstar{form}}}
+
+ This macro executes each \var{form} in a context with \var{code-var}
+ bound to each code-location in \var{debug-block}. This returns the
+ value of executing \var{result} (defaults to \nil).
+\end{defmac}
+
+
+\begin{defun}{}{debug-block-successors}{\args{\var{debug-block}}}
+
+ This function returns the list of possible code-locations where
+ execution may continue when the basic-block represented by
+ \var{debug-block} completes its execution.
+\end{defun}
+
+
+\begin{defun}{}{debug-block-elsewhere-p}{\args{\var{debug-block}}}
+
+ This function returns whether \var{debug-block} represents elsewhere
+ code. This is code the compiler has moved out of a function's code
+ sequence for optimization reasons. Code-locations in these blocks
+ are unsuitable for stepping tools, and the first code-location has
+ nothing to do with a normal starting location for the block.
+\end{defun}
+
+
+%%\f
+%%\node Breakpoints, Code-locations, Debug-blocks, Debugger Programmer's Interface
+\section{Breakpoints}
+
+A breakpoint represents a function the system calls with the current frame when
+execution passes a certain code-location. A break point is active or inactive
+independent of its existence. They also have an extra slot for users to tag
+the breakpoint with information.
+
+\begin{defun}{}{make-breakpoint}{%
+ \args{\var{hook-function} \var{what} \keys{\kwd{kind} \kwd{info}
+ \kwd{function-end-cookie}}}}
+
+ This function creates and returns a breakpoint. When program
+ execution encounters the breakpoint, the system calls
+ \var{hook-function}. \var{hook-function} takes the current frame
+ for the function in which the program is running and the breakpoint
+ object.
+
+ \var{what} and \var{kind} determine where in a function the system
+ invokes \var{hook-function}. \var{what} is either a code-location
+ or a debug-function. \var{kind} is one of \kwd{code-location},
+ \kwd{function-start}, or \kwd{function-end}. Since the starts and
+ ends of functions may not have code-locations representing them,
+ designate these places by supplying \var{what} as a debug-function
+ and \var{kind} indicating the \kwd{function-start} or
+ \kwd{function-end}. When \var{what} is a debug-function and
+ \var{kind} is \kwd{function-end}, then hook-function must take two
+ additional arguments, a list of values returned by the function and
+ a function-end-cookie.
+
+ \var{info} is information supplied by and used by the user.
+
+ \var{function-end-cookie} is a function. To implement function-end
+ breakpoints, the system uses starter breakpoints to establish the
+ function-end breakpoint for each invocation of the function. Upon
+ each entry, the system creates a unique cookie to identify the
+ invocation, and when the user supplies a function for this argument,
+ the system invokes it on the cookie. The system later invokes the
+ function-end breakpoint hook on the same cookie. The user may save
+ the cookie when passed to the function-end-cookie function for later
+ comparison in the hook function.
+
+ This signals an error if \var{what} is an unknown code-location.
+
+ \i{Note: Breakpoints in interpreted code or byte-compiled code are
+ not implemented. Function-end breakpoints are not implemented for
+ compiled functions that use the known local return convention
+ (e.g. for block-compiled or self-recursive functions.)}
+
+\end{defun}
+
+
+\begin{defun}{}{activate-breakpoint}{\args{\var{breakpoint}}}
+
+ This function causes the system to invoke the \var{breakpoint}'s
+ hook-function until the next call to \code{deactivate-breakpoint} or
+ \code{delete-breakpoint}. The system invokes breakpoint hook
+ functions in the opposite order that you activate them.
+\end{defun}
+
+
+\begin{defun}{}{deactivate-breakpoint}{\args{\var{breakpoint}}}
+
+ This function stops the system from invoking the \var{breakpoint}'s
+ hook-function.
+\end{defun}
+
+
+\begin{defun}{}{breakpoint-active-p}{\args{\var{breakpoint}}}
+
+ This returns whether \var{breakpoint} is currently active.
+\end{defun}
+
+
+\begin{defun}{}{breakpoint-hook-function}{\args{\var{breakpoint}}}
+
+ This function returns the \var{breakpoint}'s function the system
+ calls when execution encounters \var{breakpoint}, and it is active.
+ This is \code{SETF}'able.
+\end{defun}
+
+
+\begin{defun}{}{breakpoint-info}{\args{\var{breakpoint}}}
+
+ This function returns \var{breakpoint}'s information supplied by the
+ user. This is \code{SETF}'able.
+\end{defun}
+
+
+\begin{defun}{}{breakpoint-kind}{\args{\var{breakpoint}}}
+
+ This function returns the \var{breakpoint}'s kind specification.
+\end{defun}
+
+
+\begin{defun}{}{breakpoint-what}{\args{\var{breakpoint}}}
+
+ This function returns the \var{breakpoint}'s what specification.
+\end{defun}
+
+
+\begin{defun}{}{delete-breakpoint}{\args{\var{breakpoint}}}
+
+ This function frees system storage and removes computational
+ overhead associated with \var{breakpoint}. After calling this,
+ \var{breakpoint} is useless and can never become active again.
+\end{defun}
+
+
+%%\f
+%%\node Code-locations, Debug-sources, Breakpoints, Debugger Programmer's Interface
+\section{Code-locations}
+
+Code-locations represent places in functions where the system has correct
+information about the function's environment and where interesting operations
+can occur---asking for a local variable's value, setting breakpoints,
+evaluating forms within the function's environment, etc.
+
+Sometimes the interface returns unknown code-locations. These
+represent places in functions, but there is no debug information
+associated with them. Some operations accept these since they may
+succeed even with missing debug data. These operations' argument is
+named \var{basic-code-location} indicating they take known and unknown
+code-locations. If an operation names its argument
+\var{code-location}, and you supply an unknown one, it will signal an
+error. For example, \code{frame-code-location} may return an unknown
+code-location if someone interrupted Lisp in the given frame. The
+system knows where execution will continue, but this place in the code
+may not be a place for which the compiler dumped debug information.
+
+\begin{defun}{}{code-location-debug-function}{\args{\var{basic-code-location}}}
+
+ This function returns the debug-function representing information
+ about the function corresponding to the code-location.
+\end{defun}
+
+
+\begin{defun}{}{code-location-debug-block}{\args{\var{basic-code-location}}}
+
+ This function returns the debug-block containing code-location if it
+ is available. Some debug policies inhibit debug-block information,
+ and if none is available, then this signals a \code{no-debug-blocks}
+ condition.
+\end{defun}
+
+
+\begin{defun}{}{code-location-top-level-form-offset}{%
+ \args{\var{code-location}}}
+
+ This function returns the number of top-level forms before the one
+ containing \var{code-location} as seen by the compiler in some
+ compilation unit. A compilation unit is not necessarily a single
+ file, see the section on debug-sources.
+\end{defun}
+
+
+\begin{defun}{}{code-location-form-number}{\args{\var{code-location}}}
+
+ This function returns the number of the form corresponding to
+ \var{code-location}. The form number is derived by walking the
+ subforms of a top-level form in depth-first order. While walking
+ the top-level form, count one in depth-first order for each subform
+ that is a cons. See \funref{form-number-translations}.
+\end{defun}
+
+
+\begin{defun}{}{code-location-debug-source}{\args{\var{code-location}}}
+
+ This function returns \var{code-location}'s debug-source.
+\end{defun}
+
+
+\begin{defun}{}{code-location-unknown-p}{\args{\var{basic-code-location}}}
+
+ This function returns whether \var{basic-code-location} is unknown.
+ It returns \nil when the code-location is known.
+\end{defun}
+
+
+\begin{defun}{}{code-location=}{\args{\var{code-location1}
+ \var{code-location2}}}
+
+ This function returns whether the two code-locations are the same.
+\end{defun}
+
+
+%%\f
+%%\node Debug-sources, Source Translation Utilities, Code-locations, Debugger Programmer's Interface
+\section{Debug-sources}
+
+Debug-sources represent how to get back the source for some code. The
+source is either a file (\code{compile-file} or \code{load}), a
+lambda-expression (\code{compile}, \code{defun}, \code{defmacro}), or
+a stream (something particular to CMU Common Lisp,
+\code{compile-from-stream}).
+
+When compiling a source, the compiler counts each top-level form it
+processes, but when the compiler handles multiple files as one block
+compilation, the top-level form count continues past file boundaries.
+Therefore \code{code-location-top-level-form-offset} returns an offset
+that does not always start at zero for the code-location's
+debug-source. The offset into a particular source is
+\code{code-location-top-level-form-offset} minus
+\code{debug-source-root-number}.
+
+Inside a top-level form, a code-location's form number indicates the
+subform corresponding to the code-location.
+
+\begin{defun}{}{debug-source-from}{\args{\var{debug-source}}}
+
+ This function returns an indication of the type of source. The
+ following are the possible values:
+ \begin{Lentry}
+ \item[\kwd{file}] from a file (obtained by \code{compile-file} if
+ compiled).
+ \item[\kwd{lisp}] from Lisp (obtained by \code{compile} if
+ compiled).
+ \item[\kwd{stream}] from a non-file stream (CMU Common Lisp supports
+ \code{compile-from-stream}).
+ \end{Lentry}
+\end{defun}
+
+
+\begin{defun}{}{debug-source-name}{\args{\var{debug-source}}}
+
+ This function returns the actual source in some sense represented by
+ debug-source, which is related to \code{debug-source-from}:
+ \begin{Lentry}
+ \item[\kwd{file}] the pathname of the file.
+ \item[\kwd{lisp}] a lambda-expression.
+ \item[\kwd{stream}] some descriptive string that's otherwise
+ useless.
+\end{Lentry}
+\end{defun}
+
+
+\begin{defun}{}{debug-source-created}{\args{\var{debug-source}}}
+
+ This function returns the universal time someone created the source.
+ This may be \nil{} if it is unavailable.
+\end{defun}
+
+
+\begin{defun}{}{debug-source-compiled}{\args{\var{debug-source}}}
+
+ This function returns the time someone compiled the source. This is
+ \nil if the source is uncompiled.
+\end{defun}
+
+
+\begin{defun}{}{debug-source-root-number}{\args{\var{debug-source}}}
+
+ This returns the number of top-level forms processed by the compiler
+ before compiling this source. If this source is uncompiled, this is
+ zero. This may be zero even if the source is compiled since the
+ first form in the first file compiled in one compilation, for
+ example, must have a root number of zero---the compiler saw no other
+ top-level forms before it.
+\end{defun}
+
+
+%%\node Source Translation Utilities, , Debug-sources, Debugger Programmer's Interface
+\section{Source Translation Utilities}
+
+These two functions provide a mechanism for converting the rather
+obscure (but highly compact) representation of source locations into an
+actual source form:
+
+\begin{defun}{}{debug-source-start-positions}{\args{\var{debug-source}}}
+
+ This function returns the file position of each top-level form a
+ vector if \var{debug-source} is from a \kwd{file}. If
+ \code{debug-source-from} is \kwd{lisp} or \kwd{stream}, or the file
+ is byte-compiled, then the result is \false.
+\end{defun}
+
+
+\begin{defun}{}{form-number-translations}{\args{\var{form}
+ \var{tlf-number}}}
+
+ This function returns a table mapping form numbers (see
+ \code{code-location-form-number}) to source-paths. A source-path
+ indicates a descent into the top-level-form \var{form}, going
+ directly to the subform corresponding to a form number.
+ \var{tlf-number} is the top-level-form number of \var{form}.
+\end{defun}
+
+
+\begin{defun}{}{source-path-context}{%
+ \args{\var{form} \var{path} \var{context}}}
+
+ This function returns the subform of \var{form} indicated by the
+ source-path. \var{Form} is a top-level form, and \var{path} is a
+ source-path into it. \var{Context} is the number of enclosing forms
+ to return instead of directly returning the source-path form. When
+ \var{context} is non-zero, the form returned contains a marker,
+ \code{\#:****HERE****}, immediately before the form indicated by
+ \var{path}.
+\end{defun}
+
+
+%%\f
+\twocolumn
+%%\node Function Index, Variable Index, Debugger Programmer's Interface, Top
+%%\unnumbered{Function Index}
+\cindex{Function Index}
+
+%%\printindex{fn}
+\printindex[funs]
+
+\twocolumn
+%%\node Variable Index, Type Index, Function Index, Top
+%%\unnumbered{Variable Index}
+\cindex{Variable Index}
+
+%%\printindex{vr}
+\printindex[vars]
+
+\twocolumn
+%%\node Type Index, Concept Index, Variable Index, Top
+%%\unnumbered{Type Index}
+\cindex{Type Index}
+
+%%\printindex{tp}
+\printindex[types]
+
+%%\node Concept Index, , Type Index, Top
+%%\unnumbered{Concept Index}
+\cindex{Concept Index}
+
+%%\printindex{cp}
+\onecolumn
+\printindex[concept]
+\end{document}
--- /dev/null
+things from here which are invaluable for understanding current SBCL:
+ object.tex
--- /dev/null
+the function calling convention
+
+%ECX is used for a count of function argument words, represented as a
+fixnum, so it can also be thought of as a count of function argument
+bytes.
+
+The first three arguments are stored in registers. The remaining
+arguments are stored on the stack.
+
+The comments at the head of DEFINE-VOP (MORE-ARG) explain that
+;;; More args are stored contiguously on the stack, starting immediately at the
+;;; context pointer. The context pointer is not typed, so the lowtag is 0.
+
+?? Once we switch into more-arg arrangement, %ecx no longer seems to be
+ used for argument count (judging from my walkthrough of kw arg parsing
+ code while troubleshooting cold boot problems)
\ No newline at end of file
--- /dev/null
+\part{System Architecture}% -*- Dictionary: int:design -*-
+
+\chapter{Package and File Structure}
+
+\section{RCS and build areas}
+
+The CMU CL sources are maintained using RCS in a hierarchical directory
+structure which supports:
+\begin{itemize}
+\item shared RCS config file across a build area,
+
+\item frozen sources for multiple releases, and
+
+\item separate system build areas for different architectures.
+\end{itemize}
+
+Since this organization maintains multiple copies of the source, it is somewhat
+space intensive. But it is easy to delete and later restore a copy of the
+source using RCS snapshots.
+
+There are three major subtrees of the root \verb|/afs/cs/project/clisp|:
+\begin{description}
+\item[rcs] holds the RCS source (suffix \verb|,v|) files.
+
+\item[src] holds ``checked out'' (but not locked) versions of the source files,
+and is subdivided by release. Each release directory in the source tree has a
+symbolic link named ``{\tt RCS}'' which points to the RCS subdirectory of the
+corresponding directory in the ``{\tt rcs} tree. At top-level in a source tree
+is the ``{\tt RCSconfig}'' file for that area. All subdirectories also have a
+symbolic link to this RCSconfig file, allowing the configuration for an area to
+be easily changed.
+
+\item[build] compiled object files are placed in this tree, which is subdivided
+by machine type and version. The CMU CL search-list mechanism is used to allow
+the source files to be located in a different tree than the object files. C
+programs are compiled by using the \verb|tools/dupsrcs| command to make
+symbolic links to the corresponding source tree.
+\end{description}
+
+On order to modify an file in RCS, it must be checked out with a lock to
+produce a writable working file. Each programmer checks out files into a
+personal ``play area'' subtree of \verb|clisp/hackers|. These tree duplicate
+the structure of source trees, but are normally empty except for files actively
+being worked on.
+
+See \verb|/afs/cs/project/clisp/pmax_mach/alpha/tools/| for
+various tools we use for RCS hacking:
+\begin{description}
+\item[rcs.lisp] Hemlock (editor) commands for RCS file manipulation
+
+\item[rcsupdate.c] Program to check out all files in a tree that have been
+modified since last checkout.
+
+\item[updates] Shell script to produce a single listing of all RCS log
+ entries in a tree since a date.
+
+\item[snapshot-update.lisp] Lisp program to generate a shell script which
+generates a listing of updates since a particular RCS snapshot ({\tt RCSSNAP})
+file was created.
+\end{description}
+
+You can easily operate on all RCS files in a subtree using:
+\begin{verbatim}
+find . -follow -name '*,v' -exec <some command> {} \;
+\end{verbatim}
+
+\subsection{Configuration Management}
+
+config files are useful, especially in combinarion with ``{\tt snapshot}''. You
+can shapshot any particular version, giving an RCSconfig that designates that
+configuration. You can also use config files to specify the system as of a
+particular date. For example:
+\begin{verbatim}
+<3-jan-91
+\end{verbatim}
+in the the config file will cause the version as of that 3-jan-91 to be checked
+out, instead of the latest version.
+
+\subsection{RCS Branches}
+
+Branches and named revisions are used together to allow multiple paths of
+development to be supported. Each separate development has a branch, and each
+branch has a name. This project uses branches in two somewhat different cases
+of divergent development:
+\begin{itemize}
+\item For systems that we have imported from the outside, we generally assign a
+``{\tt cmu}'' branch for our local modifications. When a new release comes
+along, we check it in on the trunk, and then merge our branch back in.
+
+\item For the early development and debugging of major system changes, where
+the development and debugging is expected to take long enough that we wouldn't
+want the trunk to be in an inconsistent state for that long.
+\end{itemize}
+
+\section{Releases}
+
+We name releases according to the normal alpha, beta, default convention.
+Alpha releases are frequent, intended primarily for internal use, and are thus
+not subject to as high high documentation and configuration management
+standards. Alpha releases are designated by the date on which the system was
+built; the alpha releases for different systems may not be in exact
+correspondence, since they are built at different times.
+
+Beta and default releases are always based on a snapshot, ensuring that all
+systems are based on the same sources. A release name is an integer and a
+letter, like ``15d''. The integer is the name of the source tree which the
+system was built from, and the letter represents the release from that tree:
+``a'' is the first release, etc. Generally the numeric part increases when
+there are major system changes, whereas changes in the letter represent
+bug-fixes and minor enhancements.
+
+\section{Source Tree Structure}
+
+A source tree (and the master ``{\tt rcs}'' tree) has subdirectories for each
+major subsystem:
+\begin{description}
+\item[{\tt assembly/}] Holds the CMU CL source-file assembler, and has machine
+specific subdirectories holding assembly code for that architecture.
+
+\item[{\tt clx/}] The CLX interface to the X11 window system.
+
+\item[{\tt code/}] The Lisp code for the runtime system and standard CL
+utilities.
+
+\item[{\tt compiler/}] The Python compiler. Has architecture-specific
+subdirectories which hold backends for different machines. The {\tt generic}
+subdirectory holds code that is shared across most backends.
+
+\item[{\tt hemlock/}] The Hemlock editor.
+
+\item[{\tt lisp/}] The C runtime system code and low-level Lisp debugger.
+
+\item[{\tt pcl/}] CMU version of the PCL implementation of CLOS.
+
+\item[{\tt tools/}] System building command files and source management tools.
+\end{description}
+
+\f
+\section{Package structure}
+
+Goals: with the single exception of LISP, we want to be able to export from the
+package that the code lives in.
+
+\begin{description}
+\item[Mach, CLX...] --- These Implementation-dependent system-interface
+packages provide direct access to specific features available in the operating
+system environment, but hide details of how OS communication is done.
+
+\item[system] contains code that must know about the operating system
+environment: I/O, etc. Hides the operating system environment. Provides OS
+interface extensions such as {\tt print-directory}, etc.
+
+\item[kernel] hides state and types used for system integration: package
+system, error system, streams (?), reader, printer. Also, hides the VM, in
+that we don't export anything that reveals the VM interface. Contains code
+that needs to use the VM and SYSTEM interface, but is independent of OS and VM
+details. This code shouldn't need to be changed in any port of CMU CL, but
+won't work when plopped into an arbitrary CL. Uses SYSTEM, VM, EXTENSIONS. We
+export "hidden" symbols related to implementation of CL: setf-inverses,
+possibly some global variables.
+
+The boundary between KERNEL and VM is fuzzy, but this fuzziness reflects the
+fuzziness in the definition of the VM. We can make the VM large, and bring
+everything inside, or we make make it small. Obviously, we want the VM to be
+as small as possible, subject to efficiency constraints. Pretty much all of
+the code in KERNEL could be put in VM. The issue is more what VM hides from
+KERNEL: VM knows about everything.
+
+\item[lisp] Originally, this package had all the system code in it. The
+current ideal is that this package should have {\it no} code in it, and only
+exist to export the standard interface. Note that the name has been changed by
+x3j13 to common-lisp.
+
+\item[extensions] contains code that any random user could have written: list
+operations, syntactic sugar macros. Uses only LISP, so code in EXTENSIONS is
+pure CL. Exports everything defined within that is useful elsewhere. This
+package doesn't hide much, so it is relatively safe for users to use
+EXTENSIONS, since they aren't getting anything they couldn't have written
+themselves. Contrast this to KERNEL, which exports additional operations on
+CL's primitive data structures: PACKAGE-INTERNAL-SYMBOL-COUNT, etc. Although
+some of the functionality exported from KERNEL could have been defined in CL,
+the kernel implementation is much more efficient because it knows about
+implementation internals. Currently this package contains only extensions to
+CL, but in the ideal scheme of things, it should contain the implementations of
+all CL functions that are in KERNEL (the library.)
+
+\item[VM] hides information about the hardware and data structure
+representations. Contains all code that knows about this sort of thing: parts
+of the compiler, GC, etc. The bulk of the code is the compiler back-end.
+Exports useful things that are meaningful across all implementations, such as
+operations for examining compiled functions, system constants. Uses COMPILER
+and whatever else it wants. Actually, there are different {\it machine}{\tt
+-VM} packages for each target implementation. VM is a nickname for whatever
+implementation we are currently targeting for.
+
+
+\item[compiler] hides the algorithms used to map Lisp semantics onto the
+operations supplied by the VM. Exports the mechanisms used for defining the
+VM. All the VM-independent code in the compiler, partially hiding the compiler
+intermediate representations. Uses KERNEL.
+
+\item[eval] holds code that does direct execution of the compiler's ICR. Uses
+KERNEL, COMPILER. Exports debugger interface to interpreted code.
+
+\item[debug-internals] presents a reasonable, unified interface to
+manipulation of the state of both compiled and interpreted code. (could be in
+KERNEL) Uses VM, INTERPRETER, EVAL, KERNEL.
+
+\item[debug] holds the standard debugger, and exports the debugger
+\end{description}
+
+\chapter{System Building}
+
+It's actually rather easy to build a CMU CL core with exactly what you want in
+it. But to do this you need two things: the source and a working CMU CL.
+
+Basically, you use the working copy of CMU CL to compile the sources,
+then run a process call ``genesis'' which builds a ``kernel'' core.
+You then load whatever you want into this kernel core, and save it.
+
+In the \verb|tools/| directory in the sources there are several files that
+compile everything, and build cores, etc. The first step is to compile the C
+startup code.
+
+{\bf Note:} {\it the various scripts mentioned below have hard-wired paths in
+them set up for our directory layout here at CMU. Anyone anywhere else will
+have to edit them before they will work.}
+
+\section{Compiling the C Startup Code}
+
+There is a circular dependancy between lisp/internals.h and lisp/lisp.map that
+causes bootstrapping problems. To the easiest way to get around this problem
+is to make a fake lisp.nm file that has nothing in it by a version number:
+
+\begin{verbatim}
+ % echo "Map file for lisp version 0" > lisp.nm
+\end{verbatim}
+and then run genesis with NIL for the list of files:
+\begin{verbatim}
+ * (load ".../compiler/generic/new-genesis") ; compile before loading
+ * (lisp::genesis nil ".../lisp/lisp.nm" "/dev/null"
+ ".../lisp/lisp.map" ".../lisp/lisp.h")
+\end{verbatim}
+It will generate
+a whole bunch of warnings about things being undefined, but ignore
+that, because it will also generate a correct lisp.h. You can then
+compile lisp producing a correct lisp.map:
+\begin{verbatim}
+ % make
+\end{verbatim}
+and the use \verb|tools/do-worldbuild| and \verb|tools/mk-lisp| to build
+\verb|kernel.core| and \verb|lisp.core| (see section \ref[building-cores].)
+
+\section{Compiling the Lisp Code}
+
+The \verb|tools| directory contains various lisp and C-shell utilities for
+building CMU CL:
+\begin{description}
+\item[compile-all*] Will compile lisp files and build a kernel core. It has
+numerous command-line options to control what to compile and how. Try -help to
+see a description. It runs a separate Lisp process to compile each
+subsystem. Error output is generated in files with ``{\tt .log}'' extension in
+the root of the build area.
+
+\item[setup.lisp] Some lisp utilities used for compiling changed files in batch
+mode and collecting the error output Sort of a crude defsystem. Loads into the
+``user'' package. See {\tt with-compiler-log-file} and {\tt comf}.
+
+\item[{\it foo}com.lisp] Each system has a ``\verb|.lisp|'' file in
+\verb|tools/| which compiles that system.
+\end{description}
+
+\section{Building Core Images}
+\label{building-cores}
+Both the kernel and final core build are normally done using shell script
+drivers:
+\begin{description}
+\item[do-worldbuild*] Builds a kernel core for the current machine. The
+version to build is indicated by an optional argument, which defaults to
+``alpha''. The \verb|kernel.core| file is written either in the \verb|lisp/|
+directory in the build area, or in \verb|/usr/tmp/|. The directory which
+already contains \verb|kernel.core| is chosen. You can create a dummy version
+with e.g. ``touch'' to select the initial build location.
+
+\item[mk-lisp*] Builds a full core, with conditional loading of subsystems.
+The version is the first argument, which defaults to ``alpha''. Any additional
+arguments are added to the \verb|*features*| list, which controls system
+loading (among other things.) The \verb|lisp.core| file is written in the
+current working directory.
+\end{description}
+
+These scripts load Lisp command files. When \verb|tools/worldbuild.lisp| is
+loaded, it calls genesis with the correct arguments to build a kernel core.
+Similarly, \verb|worldload.lisp|
+builds a full core. Adding certain symbols to \verb|*features*| before
+loading worldload.lisp suppresses loading of different parts of the
+system. These symbols are:
+\begin{description}
+\item[:no-compiler] don't load the compiler.
+\item[:no-clx] don't load CLX.
+\item[:no-hemlock] don't load hemlock.
+\item[:no-pcl] don't load PCL.
+\item[:runtime] build a runtime code, implies all of the above, and then some.
+\end{description}
+
+Note: if you don't load the compiler, you can't (successfully) load the
+pretty-printer or pcl. And if you compiled hemlock with CLX loaded, you can't
+load it without CLX also being loaded.
--- /dev/null
+% -*- Dictionary: design -*-
+\f
+\chapter{Copy propagation}
+
+File: {\tt copyprop}
+
+This phase is optional, but should be done whenever speed or space is more
+important than compile speed. We use global flow analysis to find the reaching
+definitions for each TN. This information is used here to eliminate
+unnecessary TNs, and is also used later on by loop invariant optimization.
+
+In some cases, VMR conversion will unnecessarily copy the value of a TN into
+another TN, since it may not be able to tell that the initial TN has the same
+value at the time the second TN is referenced. This can happen when ICR
+optimize is unable to eliminate a trivial variable binding, or when the user
+does a setq, or may also result from creation of expression evaluation
+temporaries during VMR conversion. Whatever the cause, we would like to avoid
+the unnecessary creation and assignment of these TNs.
+
+What we do is replace TN references whose only reaching definition is a Move
+VOP with a reference to the TN moved from, and then delete the Move VOP if the
+copy TN has no remaining references. There are several restrictions on copy
+propagation:
+\begin{itemize}
+\item The TNs must be ``ordinary'' TNs, not restricted or otherwise
+unusual. Extending the life of restricted (or wired) TNs can make register
+allocation impossible. Some other TN kinds have hidden references.
+
+\item We don't want to defeat source-level debugging by replacing named
+variables with anonymous temporaries.
+
+\item We can't delete moves that representation selected might want to change
+into a representation conversion, since we need the primitive types of both TNs
+to select a conversion.
+\end{itemize}
+
+Some cleverness reduces the cost of flow analysis. As for lifetime analysis,
+we only need to do flow analysis on global packed TNs. We can't do the real
+local TN assignment pass before this, since we allocate TNs afterward, so we do
+a pre-pass that marks the TNs that are local for our purposes. We don't care
+if block splitting eventually causes some of them to be considered global.
+
+Note also that we are really only are interested in knowing if there is a
+unique reaching definition, which we can mash into our flow analysis rules by
+doing an intersection. Then a definition only appears in the set when it is
+unique. We then propagate only definitions of TNs with only one write, which
+allows the TN to stand for the definition.
+
+\f
+\chapter{Representation selection}
+
+File: {\tt represent}
+
+Some types of object (such as {\tt single-float}) have multiple possible
+representations. Multiple representations are useful mainly when there is a
+particularly efficient non-descriptor representation. In this case, there is
+the normal descriptor representation, and an alternate non-descriptor
+representation.
+
+This possibility brings up two major issues:
+\begin{itemize}
+\item The compiler must decide which representation will be most efficient for
+any given value, and
+
+\item Representation conversion code must be inserted where the representation
+of a value is changed.
+\end{itemize}
+First, the representations for TNs are selected by examining all the TN
+references and attempting to minimize reference costs. Then representation
+conversion code is introduced.
+
+This phase is in effect a pre-pass to register allocation. The main reason for
+its existence is that representation conversions may be farily complex (e.g.
+involving memory allocation), and thus must be discovered before register
+allocation.
+
+
+VMR conversion leaves stubs for representation specific move operations.
+Representation selection recognizes {\tt move} by name. Argument and return
+value passing for call VOPs is controlled by the {\tt :move-arguments} option
+to {\tt define-vop}.
+
+Representation selection is also responsible for determining what functions use
+the number stack. If any representation is chosen which could involve packing
+into the {\tt non-descriptor-stack} SB, then we allocate the NFP register
+throughout the component. As an optimization, permit the decision of whether a
+number stack frame needs to be allocated to be made on a per-function basis.
+If a function doesn't use the number stack, and isn't in the same tail-set as
+any function that uses the number stack, then it doesn't need a number stack
+frame, even if other functions in the component do.
+
+\f
+\chapter{Lifetime analysis}
+
+File: {\tt life}
+
+This phase is a preliminary to Pack. It involves three passes:
+ -- A pre-pass that computes the DEF and USE sets for live TN analysis, while
+ also assigning local TN numbers, splitting blocks if necessary. \#\#\# But
+not really...
+ -- A flow analysis pass that does backward flow analysis on the
+ component to find the live TNs at each block boundary.
+ -- A post-pass that finds the conflict set for each TN.
+
+\#|
+Exploit the fact that a single VOP can only exhaust LTN numbers when there are
+large more operands. Since more operand reference cannot be interleaved with
+temporary reference, the references all effectively occur at the same time.
+This means that we can assign all the more args and all the more results the
+same LTN number and the same lifetime info.
+|\#
+
+\f
+\section{Flow analysis}
+
+It seems we could use the global-conflicts structures during compute the
+inter-block lifetime information. The pre-pass creates all the
+global-conflicts for blocks that global TNs are referenced in. The flow
+analysis pass just adds always-live global-conflicts for the other blocks the
+TNs are live in. In addition to possibly being more efficient than SSets, this
+would directly result in the desired global-conflicts information, rather that
+having to create it from another representation.
+
+The DFO sorted per-TN global-conflicts thread suggests some kind of algorithm
+based on the manipulation of the sets of blocks each TN is live in (which is
+what we really want), rather than the set of TNs live in each block.
+
+If we sorted the per-TN global-conflicts in reverse DFO (which is just as good
+for determining conflicts between TNs), then it seems we could scan though the
+conflicts simultaneously with our flow-analysis scan through the blocks.
+
+The flow analysis step is the following:
+ If a TN is always-live or read-before-written in a successor block, then we
+ make it always-live in the current block unless there are already
+ global-conflicts recorded for that TN in this block.
+
+The iteration terminates when we don't add any new global-conflicts during a
+pass.
+
+We may also want to promote TNs only read within a block to always-live when
+the TN is live in a successor. This should be easy enough as long as the
+global-conflicts structure contains this kind of info.
+
+The critical operation here is determining whether a given global TN has global
+conflicts in a given block. Note that since we scan the blocks in DFO, and the
+global-conflicts are sorted in DFO, if we give each global TN a pointer to the
+global-conflicts for the last block we checked the TN was in, then we can
+guarantee that the global-conflicts we are looking for are always at or after
+that pointer. If we need to insert a new structure, then the pointer will help
+us rapidly find the place to do the insertion.]
+
+\f
+\section{Conflict detection}
+
+[\#\#\# Environment, :more TNs.]
+
+This phase makes use of the results of lifetime analysis to find the set of TNs
+that have lifetimes overlapping with those of each TN. We also annotate call
+VOPs with information about the live TNs so that code generation knows which
+registers need to be saved.
+
+The basic action is a backward scan of each block, looking at each TN-Ref and
+maintaining a set of the currently live TNs. When we see a read, we check if
+the TN is in the live set. If not, we:
+ -- Add the TN to the conflict set for every currently live TN,
+ -- Union the set of currently live TNs with the conflict set for the TN, and
+ -- Add the TN to the set of live TNs.
+
+When we see a write for a live TN, we just remove it from the live set. If we
+see a write to a dead TN, then we update the conflicts sets as for a read, but
+don't add the TN to the live set. We have to do this so that the bogus write
+doesn't clobber anything.
+
+[We don't consider always-live TNs at all in this process, since the conflict
+of always-live TNs with other TNs in the block is implicit in the
+global-conflicts structures.
+
+Before we do the scan on a block, we go through the global-conflicts structures
+of TNs that change liveness in the block, assigning the recorded LTN number to
+the TN's LTN number for the duration of processing of that block.]
+
+
+Efficiently computing and representing this information calls for some
+cleverness. It would be prohibitively expensive to represent the full conflict
+set for every TN with sparse sets, as is done at the block-level. Although it
+wouldn't cause non-linear behavior, it would require a complex linked structure
+containing tens of elements to be created for every TN. Fortunately we can
+improve on this if we take into account the fact that most TNs are "local" TNs:
+TNs which have all their uses in one block.
+
+First, many global TNs will be either live or dead for the entire duration of a
+given block. We can represent the conflict between global TNs live throughout
+the block and TNs local to the block by storing the set of always-live global
+TNs in the block. This reduces the number of global TNs that must be
+represented in the conflicts for local TNs.
+
+Second, we can represent conflicts within a block using bit-vectors. Each TN
+that changes liveness within a block is assigned a local TN number. Local
+conflicts are represented using a fixed-size bit-vector of 64 elements or so
+which has a 1 for the local TN number of every TN live at that time. The block
+has a simple-vector which maps from local TN numbers to TNs. Fixed-size
+vectors reduce the hassle of doing allocations and allow operations to be
+open-coded in a maximally tense fashion.
+
+We can represent the conflicts for a local TN by a single bit-vector indexed by
+the local TN numbers for that block, but in the global TN case, we need to be
+able to represent conflicts with arbitrary TNs. We could use a list-like
+sparse set representation, but then we would have to either special-case global
+TNs by using the sparse representation within the block, or convert the local
+conflicts bit-vector to the sparse representation at the block end. Instead,
+we give each global TN a list of the local conflicts bit-vectors for each block
+that the TN is live in. If the TN is always-live in a block, then we record
+that fact instead. This gives us a major reduction in the amount of work we
+have to do in lifetime analysis at the cost of some increase in the time to
+iterate over the set during Pack.
+
+Since we build the lists of local conflict vectors a block at a time, the
+blocks in the lists for each TN will be sorted by the block number. The
+structure also contains the local TN number for the TN in that block. These
+features allow pack to efficiently determine whether two arbitrary TNs
+conflict. You just scan the lists in order, skipping blocks that are in only
+one list by using the block numbers. When we find a block that both TNs are
+live in, we just check the local TN number of one TN in the local conflicts
+vector of the other.
+
+In order to do these optimizations, we must do a pre-pass that finds the
+always-live TNs and breaks blocks up into small enough pieces so that we don't
+run out of local TN numbers. If we can make a block arbitrarily small, then we
+can guarantee that an arbitrarily small number of TNs change liveness within
+the block. We must be prepared to make the arguments to unbounded arg count
+VOPs (such as function call) always-live even when they really aren't. This is
+enabled by a panic mode in the block splitter: if we discover that the block
+only contains one VOP and there are still too many TNs that aren't always-live,
+then we promote the arguments (which we'd better be able to do...).
+
+This is done during the pre-scan in lifetime analysis. We can do this because
+all TNs that change liveness within a block can be found by examining that
+block: the flow analysis only adds always-live TNs.
+
+
+When we are doing the conflict detection pass, we set the LTN number of global
+TNs. We can easily detect global TNs that have not been locally mapped because
+this slot is initially null for global TNs and we null it out after processing
+each block. We assign all Always-Live TNs to the same local number so that we
+don't need to treat references to them specially when making the scan.
+
+We also annotate call VOPs that do register saving with the TNs that are live
+during the call, and thus would need to be saved if they are packed in
+registers.
+
+We adjust the costs for TNs that need to be saved so that TNs costing more to
+save and restore than to reference get packed on the stack. We would also like
+more often saved TNs to get higher costs so that they are packed in more
+savable locations.
+
+\f
+\chapter{Packing}
+
+File: {\tt pack}
+
+\#|
+
+Add lifetime/pack support for pre-packed save TNs.
+
+Fix GTN/VMR conversion to use pre-packed save TNs for old-cont and return-PC.
+(Will prevent preference from passing location to save location from ever being
+honored?)
+
+We will need to make packing of passing locations smarter before we will be
+able to target the passing location on the stack in a tail call (when that is
+where the callee wants it.) Currently, we will almost always pack the passing
+location in a register without considering whether that is really a good idea.
+Maybe we should consider schemes that explicitly understand the parallel
+assignment semantics, and try to do the assignment with a minimum number of
+temporaries. We only need assignment temps for TNs that appear both as an
+actual argument value and as a formal parameter of the called function. This
+only happens in self-recursive functions.
+
+Could be a problem with lifetime analysis, though. The write by a move-arg VOP
+would look like a write in the current env, when it really isn't. If this is a
+problem, then we might want to make the result TN be an info arg rather than a
+real operand. But this would only be a problem in recursive calls, anyway.
+[This would prevent targeting, but targeting across passing locations rarely
+seems to work anyway.] [\#\#\# But the :ENVIRONMENT TN mechanism would get
+confused. Maybe put env explicitly in TN, and have it only always-live in that
+env, and normal in other envs (or blocks it is written in.) This would allow
+targeting into environment TNs.
+
+I guess we would also want the env/PC save TNs normal in the return block so
+that we can target them. We could do this by considering env TNs normal in
+read blocks with no successors.
+
+ENV TNs would be treated totally normally in non-env blocks, so we don't have
+to worry about lifetime analysis getting confused by variable initializations.
+Do some kind of TN costing to determine when it is more trouble than it is
+worth to allocate TNs in registers.
+
+Change pack ordering to be less pessimal. Pack TNs as they are seen in the LTN
+map in DFO, which at least in non-block compilations has an effect something
+like packing main trace TNs first, since control analysis tries to put the good
+code first. This could also reduce spilling, since it makes it less likely we
+will clog all registers with global TNs.
+
+If we pack a TN with a specified save location on the stack, pack in the
+specified location.
+
+Allow old-cont and return-pc to be kept in registers by adding a new "keep
+around" kind of TN. These are kind of like environment live, but are only
+always-live in blocks that they weren't referenced in. Lifetime analysis does
+a post-pass adding always-live conflicts for each "keep around" TN to those
+blocks with no conflict for that TN. The distinction between always-live and
+keep-around allows us to successfully target old-cont and return-pc to passing
+locations. MAKE-KEEP-AROUND-TN (ptype), PRE-PACK-SAVE-TN (tn scn offset).
+Environment needs a KEEP-AROUND-TNS slot so that conflict analysis can find
+them (no special casing is needed after then, they can be made with :NORMAL
+kind). VMR-component needs PRE-PACKED-SAVE-TNS so that conflict analysis or
+somebody can copy conflict info from the saved TN.
+
+
+
+Note that having block granularity in the conflict information doesn't mean
+that a localized packing scheme would have to do all moves at block boundaries
+(which would clash with the desire the have saving done as part of this
+mechanism.) All that it means is that if we want to do a move within the
+block, we would need to allocate both locations throughout that block (or
+something).
+
+
+
+
+
+Load TN pack:
+
+A location is out for load TN packing if:
+
+The location has TN live in it after the VOP for a result, or before the VOP
+for an argument, or
+
+The location is used earlier in the TN-ref list (after) the saved results ref
+or later in the TN-Ref list (before) the loaded argument's ref.
+
+To pack load TNs, we advance the live-tns to the interesting VOP, then
+repeatedly scan the vop-refs to find vop-local conflicts for each needed load
+TN. We insert move VOPs and change over the TN-Ref-TNs as we go so the TN-Refs
+will reflect conflicts with already packed load-TNs.
+
+If we fail to pack a load-TN in the desired SC, then we scan the Live-TNs for
+the SB, looking for a TN that can be packed in an unbounded SB. This TN must
+then be repacked in the unbounded SB. It is important the load-TNs are never
+packed in unbounded SBs, since that would invalidate the conflicts info,
+preventing us from repacking TNs in unbounded SBs. We can't repack in a finite
+SB, since there might have been load TNs packed in that SB which aren't
+represented in the original conflict structures.
+
+Is it permissible to "restrict" an operand to an unbounded SC? Not impossible
+to satisfy as long as a finite SC is also allowed. But in practice, no
+restriction would probably be as good.
+
+We assume all locations can be used when an sc is based on an unbounded sb.
+
+]
+
+
+TN-Refs are be convenient structures to build the target graph out of. If we
+allocated space in every TN-Ref, then there would certainly be enough to
+represent arbitrary target graphs. Would it be enough to allocate a single
+Target slot? If there is a target path though a given VOP, then the Target of
+the write ref would be the read, and vice-versa. To find all the TNs that
+target us, we look at the TN for the target of all our write refs.
+
+We separately chain together the read refs and the write refs for a TN,
+allowing easy determination of things such as whether a TN has only a single
+definition or has no reads. It would also allow easier traversal of the target
+graph.
+
+Represent per-location conflicts as vectors indexed by block number of
+per-block conflict info. To test whether a TN conflicts on a location, we
+would then have to iterate over the TNs global-conflicts, using the block
+number and LTN number to check for a conflict in that block. But since most
+TNs are local, this test actually isn't much more expensive than indexing into
+a bit-vector by GTN numbers.
+
+The big win of this scheme is that it is much cheaper to add conflicts into the
+conflict set for a location, since we never need to actually compute the
+conflict set in a list-like representation (which requires iterating over the
+LTN conflicts vectors and unioning in the always-live TNs). Instead, we just
+iterate over the global-conflicts for the TN, using BIT-IOR to combine the
+conflict set with the bit-vector for that block in that location, or marking
+that block/location combination as being always-live if the conflict is
+always-live.
+
+Generating the conflict set is inherently more costly, since although we
+believe the conflict set size to be roughly constant, it can easily contain
+tens of elements. We would have to generate these moderately large lists for
+all TNs, including local TNs. In contrast, the proposed scheme does work
+proportional to the number of blocks the TN is live in, which is small on
+average (1 for local TNs). This win exists independently from the win of not
+having to iterate over LTN conflict vectors.
+
+
+[\#\#\# Note that since we never do bitwise iteration over the LTN conflict
+vectors, part of the motivation for keeping these a small fixed size has been
+removed. But it would still be useful to keep the size fixed so that we can
+easily recycle the bit-vectors, and so that we could potentially have maximally
+tense special primitives for doing clear and bit-ior on these vectors.]
+
+This scheme is somewhat more space-intensive than having a per-location
+bit-vector. Each vector entry would be something like 150 bits rather than one
+bit, but this is mitigated by the number of blocks being 5-10x smaller than the
+number of TNs. This seems like an acceptable overhead, a small fraction of the
+total VMR representation.
+
+The space overhead could also be reduced by using something equivalent to a
+two-dimensional bit array, indexed first by LTN numbers, and then block numbers
+(instead of using a simple-vector of separate bit-vectors.) This would
+eliminate space wastage due to bit-vector overheads, which might be 50% or
+more, and would also make efficient zeroing of the vectors more
+straightforward. We would then want efficient operations for OR'ing LTN
+conflict vectors with rows in the array.
+
+This representation also opens a whole new range of allocation algorithms: ones
+that store allocate TNs in different locations within different portions of the
+program. This is because we can now represent a location being used to hold a
+certain TN within an arbitrary subset of the blocks the TN is referenced in.
+
+
+
+
+
+
+
+
+
+Pack goals:
+
+Pack should:
+
+Subject to resource constraints:
+ -- Minimize use costs
+ -- "Register allocation"
+ Allocate as many values as possible in scarce "good" locations,
+ attempting to minimize the aggregate use cost for the entire program.
+ -- "Save optimization"
+ Don't allocate values in registers when the save/restore costs exceed
+ the expected gain for keeping the value in a register. (Similar to
+ "opening costs" in RAOC.) [Really just a case of representation
+ selection.]
+
+ -- Minimize preference costs
+ Eliminate as many moves as possible.
+
+
+"Register allocation" is basically an attempt to eliminate moves between
+registers and memory. "Save optimization" counterbalances "register
+allocation" to prevent it from becoming a pessimization, since saves can
+introduce register/memory moves.
+
+Preference optimization reduces the number of moves within an SC. Doing a good
+job of honoring preferences is important to the success of the compiler, since
+we have assumed in many places that moves will usually be optimized away.
+
+The scarcity-oriented aspect of "register allocation" is handled by a greedy
+algorithm in pack. We try to pack the "most important" TNs first, under the
+theory that earlier packing is more likely to succeed due to fewer constraints.
+
+The drawback of greedy algorithms is their inability to look ahead. Packing a
+TN may mess up later "register allocation" by precluding packing of TNs that
+are individually "less important", but more important in aggregate. Packing a
+TN may also prevent preferences from being honored.
+
+
+\f
+Initial packing:
+
+
+Pack all TNs restricted to a finite SC first, before packing any other TNs.
+
+One might suppose that Pack would have to treat TNs in different environments
+differently, but this is not the case. Pack simply assigns TNs to locations so
+that no two conflicting TNs are in the same location. In the process of
+implementing call semantics in conflict analysis, we cause TNs in different
+environments not to conflict. In the case of passing TNs, cross environment
+conflicts do exist, but this reflects reality, since the passing TNs are
+live in both the caller and the callee. Environment semantics has already been
+implemented at this point.
+
+This means that Pack can pack all TNs simultaneously, using one data structure
+to represent the conflicts for each location. So we have only one conflict set
+per SB location, rather than separating this information by environment
+environment.
+
+\f
+Load TN packing:
+
+We create load TNs as needed in a post-pass to the initial packing. After TNs
+are packed, it may be that some references to a TN will require it to be in a
+SC other than the one it was packed in. We create load-TNs and pack them on
+the fly during this post-pass.
+
+What we do is have an optional SC restriction associated with TN-refs. If we
+pack the TN in an SC which is different from the required SC for the reference,
+then we create a TN for each such reference, and pack it into the required SC.
+
+In many cases we will be able to pack the load TN with no hassle, but in
+general we may need to spill a TN that has already been packed. We choose a
+TN that isn't in use by the offending VOP, and then spill that TN onto the
+stack for the duration of that VOP. If the VOP is a conditional, then we must
+insert a new block interposed before the branch target so that the value TN
+value is restored regardless of which branch is taken.
+
+Instead of remembering lifetime information from conflict analysis, we rederive
+it. We scan each block backward while keeping track of which locations have
+live TNs in them. When we find a reference that needs a load TN packed, we try
+to pack it in an unused location. If we can't, we unpack the currently live TN
+with the lowest cost and force it into an unbounded SC.
+
+The per-location and per-TN conflict information used by pack doesn't
+need to be updated when we pack a load TN, since we are done using those data
+structures.
+
+We also don't need to create any TN-Refs for load TNs. [??? How do we keep
+track of load-tn lifetimes? It isn't really that hard, I guess. We just
+remember which load TNs we created at each VOP, killing them when we pass the
+loading (or saving) step. This suggests we could flush the Refs thread if we
+were willing to sacrifice some flexibility in explicit temporary lifetimes.
+Flushing the Refs would make creating the VMR representation easier.]
+
+The lifetime analysis done during load-TN packing doubles as a consistency
+check. If we see a read of a TN packed in a location which has a different TN
+currently live, then there is a packing bug. If any of the TNs recorded as
+being live at the block beginning are packed in a scarce SB, but aren't current
+in that location, then we also have a problem.
+
+The conflict structure for load TNs is fairly simple, the load TNs for
+arguments and results all conflict with each other, and don't conflict with
+much else. We just try packing in targeted locations before trying at random.
+
+
+\f
+\chapter{Code generation}
+
+This is fairly straightforward. We translate VOPs into instruction sequences
+on a per-block basis.
+
+After code generation, the VMR representation is gone. Everything is
+represented by the assembler data structures.
+
+\f
+\chapter{Assembly}
+
+In effect, we do much of the work of assembly when the compiler is compiled.
+
+The assembler makes one pass fixing up branch offsets, then squeezes out the
+space left by branch shortening and dumps out the code along with the load-time
+fixup information. The assembler also deals with dumping unboxed non-immediate
+constants and symbols. Boxed constants are created by explicit constructor
+code in the top-level form, while immediate constants are generated using
+inline code.
+
+[\#\#\# The basic output of the assembler is:
+ A code vector
+ A representation of the fixups along with indices into the code vector for
+ the fixup locations
+ A PC map translating PCs into source paths
+
+This information can then be used to build an output file or an in-core
+function object.
+]
+
+The assembler is table-driven and supports arbitrary instruction formats. As
+far as the assembler is concerned, an instruction is a bit sequence that is
+broken down into subsequences. Some of the subsequences are constant in value,
+while others can be determined at assemble or load time.
+
+Assemble Node Form*
+ Allow instructions to be emitted during the evaluation of the Forms by
+ defining Inst as a local macro. This macro caches various global
+ information in local variables. Node tells the assembler what node
+ ultimately caused this code to be generated. This is used to create the
+ pc=>source map for the debugger.
+
+Assemble-Elsewhere Node Form*
+ Similar to Assemble, but the current assembler location is changed to
+ somewhere else. This is useful for generating error code and similar
+ things. Assemble-Elsewhere may not be nested.
+
+Inst Name Arg*
+ Emit the instruction Name with the specified arguments.
+
+Gen-Label
+Emit-Label (Label)
+ Gen-Label returns a Label object, which describes a place in the code.
+ Emit-Label marks the current position as being the location of Label.
+
+
+\f
+\chapter{Dumping}
+
+So far as input to the dumper/loader, how about having a list of Entry-Info
+structures in the VMR-Component? These structures contain all information
+needed to dump the associated function objects, and are only implicitly
+associated with the functional/XEP data structures. Load-time constants that
+reference these function objects should specify the Entry-Info, rather than the
+functional (or something). We would then need to maintain some sort of
+association so VMR conversion can find the appropriate Entry-Info.
+Alternatively, we could initially reference the functional, and then later
+clobber the reference to the Entry-Info.
+
+We have some kind of post-pass that runs after assembly, going through the
+functions and constants, annotating the VMR-Component for the benefit of the
+dumper:
+ Resolve :Label load-time constants.
+ Make the debug info.
+ Make the entry-info structures.
+
+Fasl dumper and in-core loader are implementation (but not instruction set)
+dependent, so we want to give them a clear interface.
+
+open-fasl-file name => fasl-file
+ Returns a "fasl-file" object representing all state needed by the dumper.
+ We objectify the state, since the fasdumper should be reentrant. (but
+ could fail to be at first.)
+
+close-fasl-file fasl-file abort-p
+ Close the specified fasl-file.
+
+fasl-dump-component component code-vector length fixups fasl-file
+ Dump the code, constants, etc. for component. Code-Vector is a vector
+ holding the assembled code. Length is the number of elements of Vector
+ that are actually in use. Fixups is a list of conses (offset . fixup)
+ describing the locations and things that need to be fixed up at load time.
+ If the component is a top-level component, then the top-level lambda will
+ be called after the component is loaded.
+
+load-component component code-vector length fixups
+ Like Fasl-Dump-Component, but directly installs the code in core, running
+ any top-level code immediately. (???) but we need some way to glue
+ together the componenents, since we don't have a fasl table.
+
+
+
+Dumping:
+
+Dump code for each component after compiling that component, but defer dumping
+of other stuff. We do the fixups on the code vectors, and accumulate them in
+the table.
+
+We have to grovel the constants for each component after compiling that
+component so that we can fix up load-time constants. Load-time constants are
+values needed my the code that are computed after code generation/assembly
+time. Since the code is fixed at this point, load-time constants are always
+represented as non-immediate constants in the constant pool. A load-time
+constant is distinguished by being a cons (Kind . What), instead of a Constant
+leaf. Kind is a keyword indicating how the constant is computed, and What is
+some context.
+
+Some interesting load-time constants:
+
+ (:label . <label>)
+ Is replaced with the byte offset of the label within the code-vector.
+
+ (:code-vector . <component>)
+ Is replaced by the component's code-vector.
+
+ (:entry . <function>)
+ (:closure-entry . <function>)
+ Is replaced by the function-entry structure for the specified function.
+ :Entry is how the top-level component gets a handle on the function
+ definitions so that it can set them up.
+
+We also need to remember the starting offset for each entry, although these
+don't in general appear as explicit constants.
+
+We then dump out all the :Entry and :Closure-Entry objects, leaving any
+constant-pool pointers uninitialized. After dumping each :Entry, we dump some
+stuff to let genesis know that this is a function definition. Then we dump all
+the constant pools, fixing up any constant-pool pointers in the already-dumped
+function entry structures.
+
+The debug-info *is* a constant: the first constant in every constant pool. But
+the creation of this constant must be deferred until after the component is
+compiled, so we leave a (:debug-info) placeholder. [Or maybe this is
+implicitly added in by the dumper, being supplied in a VMR-component slot.]
+
+
+ Work out details of the interface between the back-end and the
+ assembler/dumper.
+
+ Support for multiple assemblers concurrently loaded? (for byte code)
+
+ We need various mechanisms for getting information out of the assembler.
+
+ We can get entry PCs and similar things into function objects by making a
+ Constant leaf, specifying that it goes in the closure, and then
+ setting the value after assembly.
+
+ We have an operation Label-Value which can be used to get the value of a
+ label after assembly and before the assembler data structures are
+ deallocated.
+
+ The function map can be constructed without any special help from the
+ assembler. Codegen just has to note the current label when the function
+ changes from one block to the next, and then use the final value of these
+ labels to make the function map.
+
+ Probably we want to do the source map this way too. Although this will
+ make zillions of spurious labels, we would have to effectively do that
+ anyway.
+
+ With both the function map and the source map, getting the locations right
+ for uses of Elsewhere will be a bit tricky. Users of Elsewhere will need
+ to know about how these maps are being built, since they must record the
+ labels and corresponding information for the elsewhere range. It would be
+ nice to have some cooperation from Elsewhere so that this isn't necessary,
+ otherwise some VOP writer will break the rules, resulting in code that is
+ nowhere.
+
+ The Debug-Info and related structures are dumped by consing up the
+ structure and making it be the value of a constant.
+
+ Getting the code vector and fixups dumped may be a bit more interesting. I
+ guess we want a Dump-Code-Vector function which dumps the code and fixups
+ accumulated by the current assembly, returning a magic object that will
+ become the code vector when it is dumped as a constant.
+]
--- /dev/null
+\chapter{Compiler Overview} % -*- Dictionary: design -*-
+
+The structure of the compiler may be broadly characterized by describing the
+compilation phases and the data structures that they manipulate. The steps in
+the compilation are called phases rather than passes since they don't
+necessarily involve a full pass over the code. The data structure used to
+represent the code at some point is called an {\it intermediate
+representation.}
+
+Two major intermediate representations are used in the compiler:
+\begin{itemize}
+
+\item The Implicit Continuation Representation (ICR) represents the lisp-level
+semantics of the source code during the initial phases. Partial evaluation and
+semantic analysis are done on this representation. ICR is roughly equivalent
+to a subset of Common Lisp, but is represented as a flow-graph rather than a
+syntax tree. Phases which only manipulate ICR comprise the "front end". It
+would be possible to use a different back end such as one that directly
+generated code for a stack machine.
+
+\item The Virtual Machine Representation (VMR) represents the implementation of
+the source code on a virtual machine. The virtual machine may vary depending
+on the the target hardware, but VMR is sufficiently stylized that most of the
+phases which manipulate it are portable.
+\end{itemize}
+
+Each phase is briefly described here. The phases from ``local call analysis''
+to ``constraint propagation'' all interact; for maximum optimization, they
+are generally repeated until nothing new is discovered. The source files which
+primarily contain each phase are listed after ``Files: ''.
+\begin{description}
+
+\item[ICR conversion]
+Convert the source into ICR, doing macroexpansion and simple source-to-source
+transformation. All names are resolved at this time, so we don't have to worry
+about name conflicts later on. Files: {\tt ir1tran, srctran, typetran}
+
+\item[Local call analysis] Find calls to local functions and convert them to
+local calls to the correct entry point, doing keyword parsing, etc. Recognize
+once-called functions as lets. Create {\it external entry points} for
+entry-point functions. Files: {\tt locall}
+
+\item[Find components]
+Find flow graph components and compute depth-first ordering. Separate
+top-level code from run-time code, and determine which components are top-level
+components. Files: {\tt dfo}
+
+\item[ICR optimize] A grab-bag of all the non-flow ICR optimizations. Fold
+constant functions, propagate types and eliminate code that computes unused
+values. Special-case calls to some known global functions by replacing them
+with a computed function. Merge blocks and eliminate IF-IFs. Substitute let
+variables. Files: {\tt ir1opt, ir1tran, typetran, seqtran, vm/vm-tran}
+
+\item[Type constraint propagation]
+Use global flow analysis to propagate information about lexical variable
+types. Eliminate unnecessary type checks and tests. Files: {\tt constraint}
+
+\item[Type check generation]
+Emit explicit ICR code for any necessary type checks that are too complex to be
+easily generated on the fly by the back end. Files: {\tt checkgen}
+
+\item[Event driven operations]
+Various parts of ICR are incrementally recomputed, either eagerly on
+modification of the ICR, or lazily, when the relevant information is needed.
+\begin{itemize}
+\item Check that type assertions are satisfied, marking places where type
+checks need to be done.
+
+\item Locate let calls.
+
+\item Delete functions and variables with no references
+\end{itemize}
+Files: {\tt ir1util}, {\tt ir1opt}
+
+\item[ICR finalize]
+This phase is run after all components have been compiled. It scans the
+global variable references, looking for references to undefined variables
+and incompatible function redefinitions. Files: {\tt ir1final}, {\tt main}.
+
+\item[Environment analysis]
+Determine which distinct environments need to be allocated, and what
+context needed to be closed over by each environment. We detect non-local
+exits and set closure variables. We also emit cleanup code as funny
+function calls. This is the last pure ICR pass. Files: {\tt envanal}
+
+\item[Global TN allocation (GTN)]
+Iterate over all defined functions, determining calling conventions
+and assigning TNs to local variables. Files: {\tt gtn}
+
+\item[Local TN allocation (LTN)]
+Use type and policy information to determine which VMR translation to use
+for known functions, and then create TNs for expression evaluation
+temporaries. We also accumulate some random information needed by VMR
+conversion. Files: {\tt ltn}
+
+\item[Control analysis]
+Linearize the flow graph in a way that minimizes the number of branches. The
+block-level structure of the flow graph is basically frozen at this point.
+Files: {\tt control}
+
+\item[Stack analysis]
+Maintain stack discipline for unknown-values continuation in the presence
+of local exits. Files: {\tt stack}
+
+\item[Entry analysis]
+Collect some back-end information for each externally callable function.
+
+\item[VMR conversion] Convert ICR into VMR by translating nodes into VOPs.
+Emit type checks. Files: {\tt ir2tran, vmdef}
+
+\item[Copy propagation] Use flow analysis to eliminate unnecessary copying of
+TN values. Files: {\tt copyprop}
+
+\item[Representation selection]
+Look at all references to each TN to determine which representation has the
+lowest cost. Emit appropriate move and coerce VOPS for that representation.
+
+\item[Lifetime analysis]
+Do flow analysis to find the set of TNs whose lifetimes
+overlap with the lifetimes of each TN being packed. Annotate call VOPs with
+the TNs that need to be saved. Files: {\tt life}
+
+\item[Pack]
+Find a legal register allocation, attempting to minimize unnecessary moves.
+Files: {\tt pack}
+
+\item[Code generation]
+Call the VOP generators to emit assembly code. Files: {\tt codegen}
+
+\item[Pipeline reorganization] On some machines, move memory references
+backward in the code so that they can overlap with computation. On machines
+with delayed branch instructions, locate instructions that can be moved into
+delay slots. Files: {\tt assem-opt}
+
+\item[Assembly]
+Resolve branches and convert in to object code and fixup information.
+Files: {\tt assembler}
+
+\item[Dumping] Convert the compiled code into an object file or in-core
+function. Files: {\tt debug-dump}, {\tt dump}, {\tt vm/core}
+
+\end{description}
+
+\chapter{The Implicit Continuation Representation}
+
+The set of special forms recognized is exactly that specified in the Common
+Lisp manual. Everything that is described as a macro in CLTL is a macro.
+
+Large amounts of syntactic information are thrown away by the conversion to an
+anonymous flow graph representation. The elimination of names eliminates the
+need to represent most environment manipulation special forms. The explicit
+representation of control eliminates the need to represent BLOCK and GO, and
+makes flow analysis easy. The full Common Lisp LAMBDA is implemented with a
+simple fixed-arg lambda, which greatly simplifies later code.
+
+The elimination of syntactic information eliminates the need for most of the
+"beta transformation" optimizations in Rabbit. There are no progns, no
+tagbodys and no returns. There are no "close parens" which get in the way of
+determining which node receives a given value.
+
+In ICR, computation is represented by Nodes. These are the node types:
+\begin{description}
+\item[if] Represents all conditionals.
+
+\item[set] Represents a {\tt setq}.
+
+\item[ref] Represents a constant or variable reference.
+
+\item[combination] Represents a normal function call.
+
+\item[MV-combination] Represents a {\tt multiple-value-call}. This is used to
+implement all multiple value receiving forms except for {\tt
+multiple-value-prog1}, which is implicit.
+
+\item[bind]
+This represents the allocation and initialization of the variables in
+a lambda.
+
+\item[return]
+This collects the return value from a lambda and represents the
+control transfer on return.
+
+\item[entry] Marks the start of a dynamic extent that can have non-local exits
+to it. Dynamic state can be saved at this point for restoration on re-entry.
+
+\item[exit] Marks a potentially non-local exit. This node is interposed
+between the non-local uses of a continuation and the {\tt dest} so that code to
+do a non-local exit can be inserted if necessary.
+\end{description}
+
+Some slots are shared between all node types (via defstruct inheritance.) This
+information held in common between all nodes often makes it possible to avoid
+special-casing nodes on the basis of type. This shared information is
+primarily concerned with the order of evaluation and destinations and
+properties of results. This control and value flow is indicated in the node
+primarily by pointing to continuations.
+
+The {\tt continuation} structure represents information sufficiently related
+to the normal notion of a continuation that naming it so seems sensible.
+Basically, a continuation represents a place in the code, or alternatively the
+destination of an expression result and a transfer of control. These two
+notions are bound together for the same reasons that they are related in the
+standard functional continuation interpretation.
+
+A continuation may be deprived of either or both of its value or control
+significance. If the value of a continuation is unused due to evaluation for
+effect, then the continuation will have a null {\tt dest}. If the {\tt next}
+node for a continuation is deleted by some optimization, then {\tt next} will
+be {\tt :none}.
+
+ [\#\#\# Continuation kinds...]
+
+The {\tt block} structure represents a basic block, in the the normal sense.
+Control transfers other than simple sequencing are represented by information
+in the block structure. The continuation for the last node in a block
+represents only the destination for the result.
+
+It is very difficult to reconstruct anything resembling the original source
+from ICR, so we record the original source form in each node. The location of
+the source form within the input is also recorded, allowing for interfaces such
+as "Edit Compiler Warnings". See section \ref{source-paths}.
+
+Forms such as special-bind and catch need to have cleanup code executed at all
+exit points from the form. We represent this constraint in ICR by annotating
+the code syntactically within the form with a Cleanup structure describing what
+needs to be cleaned up. Environment analysis determines the cleanup locations
+by watching for a change in the cleanup between two continuations. We can't
+emit cleanup code during ICR conversion, since we don't know which exits will
+be local until after ICR optimizations are done.
+
+Special binding is represented by a call to the funny function %Special-Bind.
+The first argument is the Global-Var structure for the variable bound and the
+second argument is the value to bind it to.
+
+Some subprimitives are implemented using a macro-like mechanism for translating
+%PRIMITIVE forms into arbitrary lisp code. Subprimitives special-cased by VMR
+conversion are represented by a call to the funny function %%Primitive. The
+corresponding Template structure is passed as the first argument.
+
+We check global function calls for syntactic legality with respect to any
+defined function type function. If the call is illegal or we are unable to
+tell if it is legal due to non-constant keywords, then we give a warning and
+mark the function reference as :notinline to force a full call and cause
+subsequent phases to ignore the call. If the call is legal and is to a known
+function, then we annotate the Combination node with the Function-Info
+structure that contains the compiler information for the function.
+
+\f
+\section{Tail sets}
+\#|
+Probably want to have a GTN-like function result equivalence class mechanism
+for ICR type inference. This would be like the return value propagation being
+done by Propagate-From-Calls, but more powerful, less hackish, and known to
+terminate. The ICR equivalence classes could probably be used by GTN, as well.
+
+What we do is have local call analysis eagerly maintain the equivalence classes
+of functions that return the same way by annotating functions with a Tail-Info
+structure shared between all functions whose value could be the value of this
+function. We don't require that the calls actually be tail-recursive, only
+that the call deliver its value to the result continuation. [\#\#\# Actually
+now done by ICR-OPTIMIZE-RETURN, which is currently making ICR optimize
+mandatory.]
+
+We can then use the Tail-Set during ICR type inference. It would have a type
+that is the union across all equivalent functions of the types of all the uses
+other than in local calls. This type would be recomputed during optimization
+of return nodes. When the type changes, we would propagate it to all calls to
+any of the equivalent functions. How do we know when and how to recompute the
+type for a tail-set? Recomputation is driven by type propagation on the result
+continuation.
+
+This is really special-casing of RETURN nodes. The return node has the type
+which is the union of all the non-call uses of the result. The tail-set is
+found though the lambda. We can then recompute the overall union by taking the
+union of the type per return node, rather than per-use.
+
+
+How do result type assertions work? We can't intersect the assertions across
+all functions in the equivalence class, since some of the call combinations may
+not happen (or even be possible). We can intersect the assertion of the result
+with the derived types for non-call uses.
+
+When we do a tail call, we obviously can't check that the returned value
+matches our assertion. Although in principle, we would like to be able to
+check all assertions, to preserve system integrity, we only need to check
+assertions that we depend on. We can afford to lose some assertion information
+as long as we entirely lose it, ignoring it for type inference as well as for
+type checking.
+
+Things will work out, since the caller will see the tail-info type as the
+derived type for the call, and will emit a type check if it needs a stronger
+result.
+
+A remaining question is whether we should intersect the assertion with
+per-RETURN derived types from the very beginning (i.e. before the type check
+pass). I think the answer is yes. We delay the type check pass so that we can
+get our best guess for the derived type before we decide whether a check is
+necessary. But with the function return type, we aren't committing to doing
+any type check when we intersect with the type assertion; the need to type
+check is still determined in the type check pass by examination of the result
+continuation.
+
+What is the relationship between the per-RETURN types and the types in the
+result continuation? The assertion is exactly the Continuation-Asserted-Type
+(note that the asserted type of result continuations will never change after
+ICR conversion). The per-RETURN derived type is different than the
+Continuation-Derived-Type, since it is intersected with the asserted type even
+before Type Check runs. Ignoring the Continuation-Derived-Type probably makes
+life simpler anyway, since this breaks the potential circularity of the
+Tail-Info-Type will affecting the Continuation-Derived-Type, which affects...
+
+When a given return has no non-call uses, we represent this by using
+*empty-type*. This consistent with the interpretation that a return type of
+NIL means the function can't return.
+
+\f
+\section{Hairy function representation}
+
+Non-fixed-arg functions are represented using Optional-Dispatch. An
+Optional-Dispatch has an entry-point function for each legal number of
+optionals, and one for when extra args are present. Each entry point function
+is a simple lambda. The entry point function for an optional is passed the
+arguments which were actually supplied; the entry point function is expected to
+default any remaining parameters and evaluate the actual function body.
+
+If no supplied-p arg is present, then we can do this fairly easily by having
+each entry point supply its default and call the next entry point, with the
+last entry point containing the body. If there are supplied-p args, then entry
+point function is replaced with a function that calls the original entry
+function with T's inserted at the position of all the supplied args with
+supplied-p parameters.
+
+We want to be a bit clever about how we handle arguments declared special when
+doing optional defaulting, or we will emit really gross code for special
+optionals. If we bound the arg specially over the entire entry-point function,
+then the entry point function would be caused to be non-tail-recursive. What
+we can do is only bind the variable specially around the evaluation of the
+default, and then read the special and store the final value of the special
+into a lexical variable which we then pass as the argument. In the common case
+where the default is a constant, we don't have to special-bind at all, since
+the computation of the default is not affected by and cannot affect any special
+bindings.
+
+Keyword and rest args are both implemented using a LEXPR-like "more args"
+convention. The More-Entry takes two arguments in addition to the fixed and
+optional arguments: the argument context and count. (ARG <context> <n>)
+accesses the N'th additional argument. Keyword args are implemented directly
+using this mechanism. Rest args are created by calling %Listify-Rest-Args with
+the context and count.
+
+The More-Entry parses the keyword arguments and passes the values to the main
+function as positional arguments. If a keyword default is not constant, then
+we pass a supplied-p parameter into the main entry and let it worry about
+defaulting the argument. Since the main entry accepts keywords in parsed form,
+we can parse keywords at compile time for calls to known functions. We keep
+around the original parsed lambda-list and related information so that people
+can figure out how to call the main entry.
+
+\f
+\section{ICR representation of non-local exits}
+
+All exits are initially represented by EXIT nodes:
+How about an Exit node:
+ (defstruct (exit (:include node))
+ value)
+The Exit node uses the continuation that is to receive the thrown Value.
+During optimization, if we discover that the Cont's home-lambda is the same is
+the exit node's, then we can delete the Exit node, substituting the Cont for
+all of the Value's uses.
+
+The successor block of an EXIT is the entry block in the entered environment.
+So we use the Exit node to mark the place where exit code is inserted. During
+environment analysis, we need only insert a single block containing the entry
+point stub.
+
+We ensure that all Exits that aren't for a NLX don't have any Value, so that
+local exits never require any value massaging.
+
+The Entry node marks the beginning of a block or tagbody:
+ (defstruct (entry (:include node))
+ (continuations nil :type list))
+
+It contains a list of all the continuations that the body could exit to. The
+Entry node is used as a marker for the the place to snapshot state, including
+the control stack pointer. Each lambda has a list of its Entries so
+that environment analysis can figure out which continuations are really being
+closed over. There is no reason for optimization to delete Entry nodes,
+since they are harmless in the degenerate case: we just emit no code (like a
+no-var let).
+
+
+We represent CATCH using the lexical exit mechanism. We do a transformation
+like this:
+ (catch 'foo xxx) ==>
+ (block \#:foo
+ (%catch \#'(lambda () (return-from \#:foo (%unknown-values))) 'foo)
+ (%within-cleanup :catch
+ xxx))
+
+%CATCH just sets up the catch frame which points to the exit function. %Catch
+is an ordinary function as far as ICR is concerned. The fact that the catcher
+needs to be cleaned up is expressed by the Cleanup slots in the continuations
+in the body. %UNKNOWN-VALUES is a dummy function call which represents the
+fact that we don't know what values will be thrown.
+
+%WITHIN-CLEANUP is a special special form that instantiates its first argument
+as the current cleanup when converting the body. In reality, the lambda is
+also created by the special special form %ESCAPE-FUNCTION, which gives the
+lambda a special :ESCAPE kind so that the back end knows not to generate any
+code for it.
+
+
+We use a similar hack in Unwind-Protect to represent the fact that the cleanup
+forms can be invoked at arbitrarily random times.
+ (unwind-protect p c) ==>
+ (flet ((\#:cleanup () c))
+ (block \#:return
+ (multiple-value-bind
+ (\#:next \#:start \#:count)
+ (block \#:unwind
+ (%unwind-protect \#'(lambda (x) (return-from \#:unwind x)))
+ (%within-cleanup :unwind-protect
+ (return-from \#:return p)))
+ (\#:cleanup)
+ (%continue-unwind \#:next \#:start \#:count))))
+
+We use the block \#:unwind to represent the entry to cleanup code in the case
+where we are non-locally unwound. Calling of the cleanup function in the
+drop-through case (or any local exit) is handled by cleanup generation. We
+make the cleanup a function so that cleanup generation can add calls at local
+exits from the protected form. \#:next, \#:start and \#:count are state used in
+the case where we are unwound. They indicate where to go after doing the
+cleanup and what values are being thrown. The cleanup encloses only the
+protected form. As in CATCH, the escape function is specially tagged as
+:ESCAPE. The cleanup function is tagged as :CLEANUP to inhibit let conversion
+(since references are added in environment analysis.)
+
+Notice that implementing these forms using closures over continuations
+eliminates any need to special-case ICR flow analysis. Obviously we don't
+really want to make heap-closures here. In reality these functions are
+special-cased by the back-end according to their KIND.
+
+\f
+\section{Block compilation}
+
+One of the properties of ICR is that supports "block compilation" by allowing
+arbitrarily large amounts of code to be converted at once, with actual
+compilation of the code being done at will.
+
+
+In order to preserve the normal semantics we must recognize that proclamations
+(possibly implicit) are scoped. A proclamation is in effect only from the time
+of appearance of the proclamation to the time it is contradicted. The current
+global environment at the end of a block is not necessarily the correct global
+environment for compilation of all the code within the block. We solve this
+problem by closing over the relevant information in the ICR at the time it is
+converted. For example, each functional variable reference is marked as
+inline, notinline or don't care. Similarly, each node contains a structure
+known as a Cookie which contains the appropriate settings of the compiler
+policy switches.
+
+We actually convert each form in the file separately, creating a separate
+"initial component" for each one. Later on, these components are merged as
+needed. The main reason for doing this is to cause EVAL-WHEN processing to be
+interleaved with reading.
+
+\f
+\section{Entry points}
+
+\#|
+
+Since we need to evaluate potentially arbitrary code in the XEP argument forms
+(for type checking), we can't leave the arguments in the wired passing
+locations. Instead, it seems better to give the XEP max-args fixed arguments,
+with the passing locations being the true passing locations. Instead of using
+%XEP-ARG, we reference the appropriate variable.
+
+Also, it might be a good idea to do argument count checking and dispatching
+with explicit conditional code in the XEP. This would simplify both the code
+that creates the XEP and the VMR conversion of XEPs. Also, argument count
+dispatching would automatically benefit from any cleverness in compilation of
+case-like forms (jump tables, etc). On the downside, this would push some
+assumptions about how arg dispatching is done into ICR. But then we are
+currently violating abstraction at least as badly in VMR conversion, which is
+also supposed to be implementation independent.
+|\#
+
+As a side-effect of finding which references to known functions can be
+converted to local calls, we find any references that cannot be converted.
+References that cannot be converted to a local call must evaluate to a
+"function object" (or function-entry) that can be called using the full call
+convention. A function that can be called from outside the component is called
+an "entry-point".
+
+Lots of stuff that happens at compile-time with local function calls must be
+done at run-time when an entry-point is called.
+
+It is desirable for optimization and other purposes if all the calls to every
+function were directly present in ICR as local calls. We cannot directly do
+this with entry-point functions, since we don't know where and how the
+entry-point will be called until run-time.
+
+What we do is represent all the calls possible from outside the component by
+local calls within the component. For each entry-point function, we create a
+corresponding lambda called the external entry point or XEP. This is a
+function which takes the number of arguments passed as the first argument,
+followed by arguments corresponding to each required or optional argument.
+
+If an optional argument is unsupplied, the value passed into the XEP is
+undefined. The XEP is responsible for doing argument count checking and
+dispatching.
+
+In the case of a fixed-arg lambda, we emit a call to the %VERIFY-ARGUMENT-COUNT
+funny function (conditional on policy), then call the real function on the
+passed arguments. Even in this simple case, we benefit several ways from
+having a separate XEP:
+ -- The argument count checking is factored out, and only needs to be done in
+ full calls.
+ -- Argument type checking happens automatically as a consequence of passing
+ the XEP arguments in a local call to the real function. This type checking
+ is also only done in full calls.
+ -- The real function may use a non-standard calling convention for the benefit
+ of recursive or block-compiled calls. The XEP converts arguments/return
+ values to/from the standard convention. This also requires little
+ special-casing of XEPs.
+
+If the function has variable argument count (represented by an
+OPTIONAL-DISPATCH), then the XEP contains a COND which dispatches off of the
+argument count, calling the appropriate entry-point function (which then does
+defaulting). If there is a more entry (for keyword or rest args), then the XEP
+obtains the more arg context and count by calling the %MORE-ARG-CONTEXT funny
+function.
+
+All non-local-call references to functions are replaced with references to the
+corresponding XEP. ICR optimization may discover a local call that was
+previously a non-local reference. When we delete the reference to the XEP, we
+may find that it has no references. In this case, we can delete the XEP,
+causing the function to no longer be an entry-point.
+
+\f
\ No newline at end of file
--- /dev/null
+\part{Compiler Organization}
+\include{compiler-overview}
+\include{front}
+\include{middle}
+\include{back}
+\include{interface}
--- /dev/null
+% -*- Dictionary: design; Package: C -*-
+
+\#|
+\chapter{Debugger Information}
+\index{debugger information}
+\label{debug-info}
+
+Although the compiler's great freedom in choice of function call conventions
+and variable representations has major efficiency advantages, it also has
+unfortunate consequences for the debugger. The debug information that we need
+is even more elaborate than for conventional "compiled" languages, since we
+cannot even do a simple backtrace without some debug information. However,
+once having gone this far, it is not that difficult to go the extra distance,
+and provide full source level debugging of compiled code.
+
+Full debug information has a substantial space penalty, so we allow different
+levels of debug information to be specified. In the extreme case, we can
+totally omit debug information.
+
+\f
+\section{The Debug-Info Structure}
+\index{debug-info structure}
+
+The Debug-Info structure directly represents information about the
+source code, and points to other structures that describe the layout of
+run-time data structures.
+
+
+Make some sort of minimal debug-info format that would support at least the
+common cases of level 1 (since that is what we would release), and perhaps
+level 0. Actually, it seems it wouldn't be hard to crunch nearly all of the
+debug-function structure and debug-info function map into a single byte-vector.
+We could have an uncrunch function that restored the current format. This
+would be used by the debugger, and also could be used by purify to delete parts
+of the debug-info even when the compiler dumps it in crunched form.
+[Note that this isn't terribly important if purify is smart about
+debug-info...]
+|\#
+
+\f
+Compiled source map representation:
+
+[\#\#\# store in debug-function PC at which env is properly initialized, i.e.
+args (and return-pc, etc.) in internal locations. This is where a
+:function-start breakpoint would break.]
+
+[\#\#\# Note that that we can easily cache the form-number => source-path or
+form-number => form translation using a vector indexed by form numbers that we
+build during a walk.]
+
+
+
+
+Instead of using source paths in the debug-info, use "form numbers". The form
+number of a form is the number of forms that we walk to reach that form when
+doing a pre-order walk of the source form. [Might want to use a post-order
+walk, as that would more closely approximate evaluation order.]
+
+
+We probably want to continue using source-paths in the compiler, since they are
+quick to compute and to get you to a particular form. [\#\#\# But actually, I
+guess we don't have to precompute the source paths and annotate nodes with
+them: instead we could annotate the nodes with the actual original source form.
+Then if we wanted to find the location of that form, we could walk the root
+source form, looking that original form. But we might still need to enter all
+the forms in a hashtable so that we can tell during IR1 conversion that a given
+form appeared in the original source.]
+
+
+Note that form numbers have an interesting property: it is quite efficient to
+determine whether an arbitrary form is a subform of some other form, since the
+form number of B will be > than A's number and < A's next sibling's number iff
+B is a subform of A.
+
+This should be quite useful for doing the source=>pc mapping in the debugger,
+since that problem reduces to finding the subset of the known locations that
+are for subforms of the specified form.
+
+
+Assume a byte vector with a standard variable-length integer format, something
+like this:
+ 0..253 => the integer
+ 254 => read next two bytes for integer
+ 255 => read next four bytes for integer
+
+Then a compiled debug block is just a sequence of variable-length integers in a
+particular order, something like this:
+ number of successors
+ ...offsets of each successor in the function's blocks vector...
+ first PC
+ [offset of first top-level form (in forms) (only if not component default)]
+ form number of first source form
+ first live mask (length in bytes determined by number of VARIABLES)
+ ...more <PC, top-level form offset, form-number, live-set> tuples...
+
+We determine the number of locations recorded in a block by the finding the
+start of the next compiled debug block in the blocks vector.
+
+[\#\#\# Actually, only need 2 bits for number of successors {0,1,2}. We might
+want to use other bits in the first byte to indicate the kind of location.]
+[\#\#\# We could support local packing by having a general concept of "alternate
+locations" instead of just regular and save locations. The location would have
+a bit indicating that there are alternate locations, in which case we read the
+number of alternate locations and then that many more SC-OFFSETs. In the
+debug-block, we would have a second bit mask with bits set for TNs that are in
+an alternate location. We then read a number for each such TN, with the value
+being interpreted as an index into the Location's alternate locations.]
+
+
+
+It looks like using structures for the compiled-location-info is too bulky.
+Instead we need some packed binary representation.
+
+First, let's represent a SC/offset pair with an "SC-Offset", which is an
+integer with the SC in the low 5 bits and the offset in the remaining bits:
+ ----------------------------------------------------
+ | Offset (as many bits as necessary) | SC (5 bits) |
+ ----------------------------------------------------
+Probably the result should be constrained to fit in a fixnum, since it will be
+more efficient and gives more than enough possible offsets.
+
+We can the represent a compiled location like this:
+ single byte of boolean flags:
+ uninterned name
+ packaged name
+ environment-live
+ has distinct save location
+ has ID (name not unique in this fun)
+ name length in bytes (as var-length integer)
+ ...name bytes...
+ [if packaged, var-length integer that is package name length]
+ ...package name bytes...]
+ [If has ID, ID as var-length integer]
+ SC-Offset of primary location (as var-length integer)
+ [If has save SC, SC-Offset of save location (as var-length integer)]
+
+
+\f
+
+But for a whizzy breakpoint facility, we would need a good source=>code map.
+Dumping a complete code=>source map might be as good a way as any to represent
+this, due to the one-to-many relationship between source and code locations.
+
+We might be able to get away with just storing the source locations for the
+beginnings of blocks and maintaining a mapping from code ranges to blocks.
+This would be fine both for the profiler and for the "where am I running now"
+indication. Users might also be convinced that it was most interesting to
+break at block starts, but I don't really know how easily people could develop
+an understanding of basic blocks.
+
+It could also be a bit tricky to map an arbitrary user-designated source
+location to some "closest" source location actually in the debug info.
+This problem probably exists to some degree even with a full source map, since
+some forms will never appear as the source of any node. It seems you might
+have to negotiate with the user. He would mouse something, and then you would
+highlight some source form that has a common prefix (i.e. is a prefix of the
+user path, or vice-versa.) If they aren't happy with the result, they could
+try something else. In some cases, the designated path might be a prefix of
+several paths. This ambiguity might be resolved by picking the shortest path
+or letting the user choose.
+
+At the primitive level, I guess what this means is that the structure of source
+locations (i.e. source paths) must be known, and the source=>code operation
+should return a list of <source,code> pairs, rather than just a list of code
+locations. This allows the debugger to resolve the ambiguity however it wants.
+
+I guess the formal definition of which source paths we would return is:
+ All source paths in the debug info that have a maximal common prefix with
+ the specified path. i.e. if several paths have the complete specified path
+ as a prefix, we return them all. Otherwise, all paths with an equally
+ large common prefix are returned: if the path with the most in common
+ matches only the first three elements, then we return all paths that match
+ in the first three elements. As a degenerate case (which probably
+ shouldn't happen), if there is no path with anything in common, then we
+ return *all* of the paths.
+
+
+
+In the DEBUG-SOURCE structure we may ultimately want a vector of the start
+positions of each source form, since that would make it easier for the debugger
+to locate the source. It could just open the file, FILE-POSITION to the form,
+do a READ, then loop down the source path. Of course, it could read each form
+starting from the beginning, but that might be too slow.
+
+
+Do XEPs really need Debug-Functions? The only time that we will commonly end
+up in the debugger on an XEP is when an argument type check fails. But I
+suppose it would be nice to be able to print the arguments passed...
+
+
+Note that assembler-level code motion such as pipeline reorganization can cause
+problems with our PC maps. The assembler needs to know that debug info markers
+are different from real labels anyway, so I suppose it could inhibit motion
+across debug markers conditional on policy. It seems unworthwhile to remember
+the node for each individual instruction.
+
+
+For tracing block-compiled calls:
+ Info about return value passing locations?
+ Info about where all the returns are?
+
+We definitely need the return-value passing locations for debug-return. The
+question is what the interface should be. We don't really want to have a
+visible debug-function-return-locations operation, since there are various
+value passing conventions, and we want to paper over the differences.
+
+
+Probably should be a compiler option to initialize stack frame to a special
+uninitialized object (some random immediate type). This would aid debugging,
+and would also help GC problems. For the latter reason especially, this should
+be locally-turn-onable (off of policy? the new debug-info quality?).
+
+
+What about the interface between the evaluator and the debugger? (i.e. what
+happens on an error, etc.) Compiler error handling should be integrated with
+run-time error handling. Ideally the error messages should look the same.
+Practically, in some cases the run-time errors will have less information. But
+the error should look the same to the debugger (or at least similar).
+
+
+\f
+;;;; Debugger interface:
+
+How does the debugger interface to the "evaluator" (where the evaluator means
+all of native code, byte-code and interpreted IR1)? It seems that it would be
+much more straightforward to have a consistent user interface to debugging
+all code representations if there was a uniform debugger interface to the
+underlying stuff, and vice-versa.
+
+Of course, some operations might not be supported by some representations, etc.
+For example, fine-control stepping might not be available in native code.
+In other cases, we might reduce an operation to the lowest common denominator,
+for example fetching lexical variables by string and admitting the possibility
+of ambiguous matches. [Actually, it would probably be a good idea to store the
+package if we are going to allow variables to be closed over.]
+
+Some objects we would need:
+Location:
+ The constant information about the place where a value is stored,
+ everything but which particular frame it is in. Operations:
+ location name, type, etc.
+ location-value frame location (setf'able)
+ monitor-location location function
+ Function is called whenever location is set with the location,
+ frame and old value. If active values aren't supported, then we
+ dummy the effect using breakpoints, in which case the change won't
+ be noticed until the end of the block (and intermediate changes
+ will be lost.)
+debug info:
+ All the debug information for a component.
+Frame:
+ frame-changed-locations frame => location*
+ Return a list of the locations in frame that were changed since the
+ last time this function was called. Or something. This is for
+ displaying interesting state changes at breakpoints.
+ save-frame-state frame => frame-state
+ restore-frame-state frame frame-state
+ These operations allow the debugger to back up evaluation, modulo
+ side-effects and non-local control transfers. This copies and
+ restores all variables, temporaries, etc, local to the frame, and
+ also the current PC and dynamic environment (current catch, etc.)
+
+ At the time of the save, the frame must be for the running function
+ (not waiting for a call to return.) When we restore, the frame
+ becomes current again, effectively exiting from any frames on top.
+ (Of course, frame must not already be exited.)
+
+Thread:
+ Representation of which stack to use, etc.
+Block:
+ What successors the block has, what calls there are in the block.
+ (Don't need to know where calls are as long as we know called function,
+ since can breakpoint at the function.) Whether code in this block is
+ wildly out of order due to being the result of loop-invariant
+ optimization, etc. Operations:
+ block-successors block => code-location*
+ block-forms block => (source-location code-location)*
+ Return the corresponding source locations and code locations for
+ all forms (and form fragments) in the block.
+
+\f
+Variable maps:
+
+There are about five things that the debugger might want to know about a
+variable:
+
+ Name
+ Although a lexical variable's name is "really" a symbol (package and
+ all), in practice it doesn't seem worthwhile to require all the symbols
+ for local variable names to be retained. There is much less VM and GC
+ overhead for a constant string than for a symbol. (Also it is useful
+ to be able to access gensyms in the debugger, even though they are
+ theoretically ineffable).
+
+ ID
+ Which variable with the specified name is this? It is possible to have
+ multiple variables with the same name in a given function. The ID is
+ something that makes Name unique, probably a small integer. When
+ variables aren't unique, we could make this be part of the name, e.g.
+ "FOO\#1", "FOO\#2". But there are advantages to keeping this separate,
+ since in many cases lifetime information can be used to disambiguate,
+ making qualification unnecessary.
+
+ SC
+ When unboxed representations are in use, we must have type information
+ to properly read and write a location. We only need to know the
+ SC for this, which would be amenable to a space-saving
+ numeric encoding.
+
+ Location
+ Simple: the offset in SC. [Actually, we need the save location too.]
+
+ Lifetime
+ In what parts of the program does this variable hold a meaningful
+ value? It seems prohibitive to record precise lifetime information,
+ both in space and compiler effort, so we will have to settle for some
+ sort of approximation.
+
+ The finest granularity at which it is easy to determine liveness is the
+ the block: we can regard the variable lifetime as the set of blocks
+ that the variable is live in. Of course, the variable may be dead (and
+ thus contain meaningless garbage) during arbitrarily large portions of
+ the block.
+
+ Note that this subsumes the notion of which function a variable belongs
+ to. A given block is only in one function, so the function is
+ implicit.
+
+
+The variable map should represent this information space-efficiently and with
+adequate computational efficiency.
+
+The SC and ID can be represented as small integers. Although the ID can in
+principle be arbitrarily large, it should be <100 in practice. The location
+can be represented by just the offset (a moderately small integer), since the
+SB is implicit in the SC.
+
+The lifetime info can be represented either as a bit-vector indexed by block
+numbers, or by a list of block numbers. Which is more compact depends both on
+the size of the component and on the number of blocks the variable is live in.
+In the limit of large component size, the sparse representation will be more
+compact, but it isn't clear where this crossover occurs. Of course, it would
+be possible to use both representations, choosing the more compact one on a
+per-variable basis. Another interesting special case is when the variable is
+live in only one block: this may be common enough to be worth picking off,
+although it is probably rarer for named variables than for TNs in general.
+
+If we dump the type, then a normal list-style type descriptor is fine: the
+space overhead is small, since the shareability is high.
+
+We could probably save some space by cleverly representing the var-info as
+parallel vectors of different types, but this would be more painful in use.
+It seems better to just use a structure, encoding the unboxed fields in a
+fixnum. This way, we can pass around the structure in the debugger, perhaps
+even exporting it from the the low-level debugger interface.
+
+[\#\#\# We need the save location too. This probably means that we need two slots
+of bits, since we need the save offset and save SC. Actually, we could let the
+save SC be implied by the normal SC, since at least currently, we always choose
+the same save SC for a given SC. But even so, we probably can't fit all that
+stuff in one fixnum without squeezing a lot, so we might as well split and
+record both SCs.
+
+In a localized packing scheme, we would have to dump a different var-info
+whenever either the main location or the save location changes. As a practical
+matter, the save location is less likely to change than the main location, and
+should never change without the main location changing.
+
+One can conceive of localized packing schemes that do saving as a special case
+of localized packing. If we did this, then the concept of a save location
+might be eliminated, but this would require major changes in the IR2
+representation for call and/or lifetime info. Probably we will want saving to
+continue to be somewhat magical.]
+
+
+How about:
+
+(defstruct var-info
+ ;;
+ ;; This variable's name. (symbol-name of the symbol)
+ (name nil :type simple-string)
+ ;;
+ ;; The SC, ID and offset, encoded as bit-fields.
+ (bits nil :type fixnum)
+ ;;
+ ;; The set of blocks this variable is live in. If a bit-vector, then it has
+ ;; a 1 when indexed by the number of a block that it is live in. If an
+ ;; I-vector, then it lists the live block numbers. If a fixnum, then that is
+ ;; the number of the sole live block.
+ (lifetime nil :type (or vector fixnum))
+ ;;
+ ;; The variable's type, represented as list-style type descriptor.
+ type)
+
+Then the debug-info holds a simple-vector of all the var-info structures for
+that component. We might as well make it sorted alphabetically by name, so
+that we can binary-search to find the variable corresponding to a particular
+name.
+
+We need to be able to translate PCs to block numbers. This can be done by an
+I-Vector in the component that contains the start location of each block. The
+block number is the index at which we find the correct PC range. This requires
+that we use an emit-order block numbering distinct from the IR2-Block-Number,
+but that isn't any big deal. This seems space-expensive, but it isn't too bad,
+since it would only be a fraction of the code size if the average block length
+is a few words or more.
+
+An advantage of our per-block lifetime representation is that it directly
+supports keeping a variable in different locations when in different blocks,
+i.e. multi-location packing. We use a different var-info for each different
+packing, since the SC and offset are potentially different. The Name and ID
+are the same, representing the fact that it is the same variable. It is here
+that the ID is most significant, since the debugger could otherwise make
+same-name variables unique all by itself.
+
+
+
+Stack parsing:
+
+[\#\#\# Probably not worth trying to make the stack parseable from the bottom up.
+There are too many complications when we start having variable sized stuff on
+the stack. It seems more profitable to work on making top-down parsing robust.
+Since we are now planning to wire the bottom-up linkage info, scanning from the
+bottom to find the top frame shouldn't be too inefficient, even when there was
+a runaway recursion. If we somehow jump into hyperspace, then the debugger may
+get confused, but we can debug this sort of low-level system lossage using
+ADB.]
+
+
+There are currently three relevant context pointers:
+ -- The PC. The current PC is wired (implicit in the machine). A saved
+ PC (RETURN-PC) may be anywhere in the current frame.
+ -- The current stack context (CONT). The current CONT is wired. A saved
+ CONT (OLD-CONT) may be anywhere in the current frame.
+ -- The current code object (ENV). The current ENV is wired. When saved,
+ this is extra-difficult to locate, since it is saved by the caller, and is
+ thus at an unknown offset in OLD-CONT, rather than anywhere in the current
+ frame.
+
+We must have all of these to parse the stack.
+
+With the proposed Debug-Function, we parse the stack (starting at the top) like
+this:
+ 1] Use ENV to locate the current Debug-Info
+ 2] Use the Debug-Info and PC to determine the current Debug-Function.
+ 3] Use the Debug-Function to find the OLD-CONT and RETURN-PC.
+ 4] Find the old ENV by searching up the stack for a saved code object
+ containing the RETURN-PC.
+ 5] Assign old ENV to ENV, OLD-CONT to CONT, RETURN-PC to PC and goto 1.
+
+If we changed the function representation so that the code and environment were
+a single object, then the location of the old ENV would be simplified. But we
+still need to represent ENV as separate from PC, since interrupts and errors
+can happen when the current PC isn't positioned at a valid return PC.
+
+It seems like it might be a good idea to save OLD-CONT, RETURN-PC and ENV at
+the beginning of the frame (before any stack arguments). Then we wouldn't have
+to search to locate ENV, and we also have a hope of parsing the stack even if
+it is damaged. As long as we can locate the start of some frame, we can trace
+the stack above that frame. We can recognize a probable frame start by
+scanning the stack for a code object (presumably a saved ENV).
+
+ Probably we want some fairly general
+mechanism for specifying that a TN should be considered to be live for the
+duration of a specified environment. It would be somewhat easier to specify
+that the TN is live for all time, but this would become very space-inefficient
+in large block compilations.
+
+This mechanism could be quite useful for other debugger-related things. For
+example, when debuggability is important, we could make the TNs holding
+arguments live for the entire environment. This would guarantee that a
+backtrace would always get the right value (modulo setqs).
+
+Note that in this context, "environment" means the Environment structure (one
+per non-let function). At least according to current plans, even when we do
+inter-routine register allocation, the different functions will have different
+environments: we just "equate" the environments. So the number of live
+per-environment TNs is bounded by the size of a "function", and doesn't blow up
+in block compilation.
+
+The implementation is simple: per-environment TNs are flagged by the
+:Environment kind. :Environment TNs are treated the same as :Normal TNs by
+everyone except for lifetime/conflict analysis. An environment's TNs are also
+stashed in a list in the IR2-Environment structure. During during the conflict
+analysis post-pass, we look at each block's environment, and make all the
+environment's TNs always-live in that block.
+
+We can implement the "fixed save location" concept needed for lazy frame
+creation by allocating the save TNs as wired TNs at IR2 conversion time. We
+would use the new "environment lifetime" concept to specify the lifetimes of
+the save locations. There isn't any run-time overhead if we never get around
+to using the save TNs. [Pack would also have to notice TNs with pre-allocated
+save TNs, packing the original TN in the stack location if its FSC is the
+stack.]
+
+
+We want a standard (recognizable) format for an "escape" frame. We must make
+an escape frame whenever we start running another function without the current
+function getting a chance to save its registers. This may be due either to a
+truly asynchronous event such as a software interrupt, or due to an "escape"
+from a miscop. An escape frame marks a brief conversion to a callee-saves
+convention.
+
+Whenever a miscop saves registers, it should make an escape frame. This
+ensures that the "current" register contents can always be located by the
+debugger. In this case, it may be desirable to be able to indicate that only
+partial saving has been done. For example, we don't want to have to save all
+the FP registers just so that we can use a couple extra general registers.
+
+When when the debugger see an escape frame, it knows that register values are
+located in the escape frame's "register save" area, rather than in the normal
+save locations.
+
+It would be nice if there was a better solution to this internal error concept.
+One problem is that it seems there is a substantial space penalty for emitting
+all that error code, especially now that we don't share error code between
+errors because we want to preserve the source context in the PC. But this
+probably isn't really all that bad when considered as a fraction of the code.
+For example, the check part of a type check is 12 bytes, whereas the error part
+is usually only 6. In this case, we could never reduce the space overhead for
+type checks by more than 1/3, thus the total code size reduction would be
+small. This will be made even less important when we do type check
+optimizations to reduce the number of type checks.
+
+Probably we should stick to the same general internal error mechanism, but make
+it interact with the debugger better by allocating linkage registers and
+allowing proceedable errors. We could support shared error calls and
+non-proceedable errors when space is more important than debuggability, but
+this is probably more complexity than is worthwhile.
+
+We jump or trap to a routine that saves the context (allocating at most the
+return PC register). We then encode the error and context in the code
+immediately following the jump/trap. (On the MIPS, the error code can be
+encoded in the trap itself.) The error arguments would be encoded as
+SC-offsets relative to the saved context. This could solve both the
+arg-trashing problem and save space, since we could encode the SC-offsets more
+tersely than the corresponding move instructions.
--- /dev/null
+\documentstyle[cmu-titlepage]{report} % -*- Dictionary: design -*-
+\title{Design of CMU Common Lisp}
+\author{Robert A. MacLachlan (ed)}
+\trnumber{CMU-CS-91-???}
+\abstract{This report documents internal details of the CMU Common Lisp
+compiler and run-time system. CMU Common Lisp is a public domain
+implementation of Common Lisp that runs on various Unix workstations.}
+
+\begin{document}
+\maketitle
+\tableofcontents
+\include{architecture}
+\include{compiler}
+\include{retargeting}
+\include{run-time}
+\appendix
+\include{glossary}
+\end{document}
--- /dev/null
+\chapter{The Type System}
+
+\chapter{The Info Database}
--- /dev/null
+Look at primtype.lisp and objdef.lisp (and early-objdef.lisp) for more
+up-to-date definitions of various tags. (For example, the simple
+string tag has changed since object.tex was written.)
+
+The string format has changed. According to "object.tex", string length is
+stored in the 24 bits of the string header. Instead, those 24 bits
+are set to zero, and string length is encoded in the same way as the
+other specialized simple-array counts, as a fixnum following the
+header.
+
+The number of slots for objects has changed since object.tex was
+written. The only reliable source for current slot definitions seems
+to be the primitive object data maintained by the compiler itself. See
+primtype.lisp and objdef.lisp, or look at the genesis code which reads
+this data to generate the various slot offsets in the C header file.
+
+The meaning of the function-self slot has changed in the X86 port:
+it points directly to the code to be executed.
+
+Nothing about FDEFN objects seems to be documented. FDEFN objects
+replace the simple SYMBOL-FUNCTION slot with a much more complicated
+mechanism, which I [WHN] dislike and would like to get rid of, but
+haven't [yet?].
--- /dev/null
+\chapter{Fasload File Format}% -*- Dictionary: design -*-
+\section{General}
+
+The purpose of Fasload files is to allow concise storage and rapid
+loading of Lisp data, particularly function definitions. The intent
+is that loading a Fasload file has the same effect as loading the
+ASCII file from which the Fasload file was compiled, but accomplishes
+the tasks more efficiently. One noticeable difference, of course, is
+that function definitions may be in compiled form rather than
+S-expression form. Another is that Fasload files may specify in what
+parts of memory the Lisp data should be allocated. For example,
+constant lists used by compiled code may be regarded as read-only.
+
+In some Lisp implementations, Fasload file formats are designed to
+allow sharing of code parts of the file, possibly by direct mapping
+of pages of the file into the address space of a process. This
+technique produces great performance improvements in a paged
+time-sharing system. Since the Mach project is to produce a
+distributed personal-computer network system rather than a
+time-sharing system, efficiencies of this type are explicitly {\it not}
+a goal for the CMU Common Lisp Fasload file format.
+
+On the other hand, CMU Common Lisp is intended to be portable, as it will
+eventually run on a variety of machines. Therefore an explicit goal
+is that Fasload files shall be transportable among various
+implementations, to permit efficient distribution of programs in
+compiled form. The representations of data objects in Fasload files
+shall be relatively independent of such considerations as word
+length, number of type bits, and so on. If two implementations
+interpret the same macrocode (compiled code format), then Fasload
+files should be completely compatible. If they do not, then files
+not containing compiled code (so-called "Fasdump" data files) should
+still be compatible. While this may lead to a format which is not
+maximally efficient for a particular implementation, the sacrifice of
+a small amount of performance is deemed a worthwhile price to pay to
+achieve portability.
+
+The primary assumption about data format compatibility is that all
+implementations can support I/O on finite streams of eight-bit bytes.
+By "finite" we mean that a definite end-of-file point can be detected
+irrespective of the content of the data stream. A Fasload file will
+be regarded as such a byte stream.
+
+\section{Strategy}
+
+A Fasload file may be regarded as a human-readable prefix followed by
+code in a funny little language. When interpreted, this code will
+cause the construction of the encoded data structures. The virtual
+machine which interprets this code has a {\it stack} and a {\it table},
+both initially empty. The table may be thought of as an expandable
+register file; it is used to remember quantities which are needed
+more than once. The elements of both the stack and the table are
+Lisp data objects. Operators of the funny language may take as
+operands following bytes of the data stream, or items popped from the
+stack. Results may be pushed back onto the stack or pushed onto the
+table. The table is an indexable stack that is never popped; it is
+indexed relative to the base, not the top, so that an item once
+pushed always has the same index.
+
+More precisely, a Fasload file has the following macroscopic
+organization. It is a sequence of zero or more groups concatenated
+together. End-of-file must occur at the end of the last group. Each
+group begins with a series of seven-bit ASCII characters terminated
+by one or more bytes of all ones \verb|#xFF|; this is called the
+{\it header}. Following the bytes which terminate the header is the
+{\it body}, a stream of bytes in the funny binary language. The body
+of necessity begins with a byte other than \verb|#xFF|. The body is
+terminated by the operation {\tt FOP-END-GROUP}.
+
+The first nine characters of the header must be "{\tt FASL FILE}" in
+upper-case letters. The rest may be any ASCII text, but by
+convention it is formatted in a certain way. The header is divided
+into lines, which are grouped into paragraphs. A paragraph begins
+with a line which does {\it not} begin with a space or tab character,
+and contains all lines up to, but not including, the next such line.
+The first word of a paragraph, defined to be all characters up to but
+not including the first space, tab, or end-of-line character, is the
+{\it name} of the paragraph. A Fasload file header might look something like
+this:
+\begin{verbatim}
+FASL FILE >SteelesPerq>User>Guy>IoHacks>Pretty-Print.Slisp
+Package Pretty-Print
+Compiled 31-Mar-1988 09:01:32 by some random luser
+Compiler Version 1.6, Lisp Version 3.0.
+Functions: INITIALIZE DRIVER HACK HACK1 MUNGE MUNGE1 GAZORCH
+ MINGLE MUDDLE PERTURB OVERDRIVE GOBBLE-KEYBOARD
+ FRY-USER DROP-DEAD HELP CLEAR-MICROCODE
+ %AOS-TRIANGLE %HARASS-READTABLE-MAYBE
+Macros: PUSH POP FROB TWIDDLE
+\end{verbatim}
+{\it one or more bytes of \verb|#xFF|}
+
+The particular paragraph names and contents shown here are only intended as
+suggestions.
+
+\section{Fasload Language}
+
+Each operation in the binary Fasload language is an eight-bit
+(one-byte) opcode. Each has a name beginning with "{\tt FOP-}". In
+the following descriptions, the name is followed by operand
+descriptors. Each descriptor denotes operands that follow the opcode
+in the input stream. A quantity in parentheses indicates the number
+of bytes of data from the stream making up the operand. Operands
+which implicitly come from the stack are noted in the text. The
+notation "$\Rightarrow$ stack" means that the result is pushed onto the
+stack; "$\Rightarrow$ table" similarly means that the result is added to the
+table. A construction like "{\it n}(1) {\it value}({\it n})" means that
+first a single byte {\it n} is read from the input stream, and this
+byte specifies how many bytes to read as the operand named {\it value}.
+All numeric values are unsigned binary integers unless otherwise
+specified. Values described as "signed" are in two's-complement form
+unless otherwise specified. When an integer read from the stream
+occupies more than one byte, the first byte read is the least
+significant byte, and the last byte read is the most significant (and
+contains the sign bit as its high-order bit if the entire integer is
+signed).
+
+Some of the operations are not necessary, but are rather special
+cases of or combinations of others. These are included to reduce the
+size of the file or to speed up important cases. As an example,
+nearly all strings are less than 256 bytes long, and so a special
+form of string operation might take a one-byte length rather than a
+four-byte length. As another example, some implementations may
+choose to store bits in an array in a left-to-right format within
+each word, rather than right-to-left. The Fasload file format may
+support both formats, with one being significantly more efficient
+than the other for a given implementation. The compiler for any
+implementation may generate the more efficient form for that
+implementation, and yet compatibility can be maintained by requiring
+all implementations to support both formats in Fasload files.
+
+Measurements are to be made to determine which operation codes are
+worthwhile; little-used operations may be discarded and new ones
+added. After a point the definition will be "frozen", meaning that
+existing operations may not be deleted (though new ones may be added;
+some operations codes will be reserved for that purpose).
+
+\begin{description}
+\item[0:] \hspace{2em} {\tt FOP-NOP} \\
+No operation. (This is included because it is recognized
+that some implementations may benefit from alignment of operands to some
+operations, for example to 32-bit boundaries. This operation can be used
+to pad the instruction stream to a desired boundary.)
+
+\item[1:] \hspace{2em} {\tt FOP-POP} \hspace{2em} $\Rightarrow$ \hspace{2em} table \\
+One item is popped from the stack and added to the table.
+
+\item[2:] \hspace{2em} {\tt FOP-PUSH} \hspace{2em} {\it index}(4) \hspace{2em} $\Rightarrow$ \hspace{2em} stack \\
+Item number {\it index} of the table is pushed onto the stack.
+The first element of the table is item number zero.
+
+\item[3:] \hspace{2em} {\tt FOP-BYTE-PUSH} \hspace{2em} {\it index}(1) \hspace{2em} $\Rightarrow$ \hspace{2em} stack \\
+Item number {\it index} of the table is pushed onto the stack.
+The first element of the table is item number zero.
+
+\item[4:] \hspace{2em} {\tt FOP-EMPTY-LIST} \hspace{2em} $\Rightarrow$ \hspace{2em} stack \\
+The empty list ({\tt ()}) is pushed onto the stack.
+
+\item[5:] \hspace{2em} {\tt FOP-TRUTH} \hspace{2em} $\Rightarrow$ \hspace{2em} stack \\
+The standard truth value ({\tt T}) is pushed onto the stack.
+
+\item[6:] \hspace{2em} {\tt FOP-SYMBOL-SAVE} \hspace{2em} {\it n}(4) \hspace{2em} {\it name}({\it n})
+\hspace{2em} $\Rightarrow$ \hspace{2em} stack \& table\\
+The four-byte operand {\it n} specifies the length of the print name
+of a symbol. The name follows, one character per byte,
+with the first byte of the print name being the first read.
+The name is interned in the default package,
+and the resulting symbol is both pushed onto the stack and added to the table.
+
+\item[7:] \hspace{2em} {\tt FOP-SMALL-SYMBOL-SAVE} \hspace{2em} {\it n}(1) \hspace{2em} {\it name}({\it n}) \hspace{2em} $\Rightarrow$ \hspace{2em} stack \& table\\
+The one-byte operand {\it n} specifies the length of the print name
+of a symbol. The name follows, one character per byte,
+with the first byte of the print name being the first read.
+The name is interned in the default package,
+and the resulting symbol is both pushed onto the stack and added to the table.
+
+\item[8:] \hspace{2em} {\tt FOP-SYMBOL-IN-PACKAGE-SAVE} \hspace{2em} {\it index}(4)
+\hspace{2em} {\it n}(4) \hspace{2em} {\it name}({\it n})
+\hspace{2em} $\Rightarrow$ \hspace{2em} stack \& table\\
+The four-byte {\it index} specifies a package stored in the table.
+The four-byte operand {\it n} specifies the length of the print name
+of a symbol. The name follows, one character per byte,
+with the first byte of the print name being the first read.
+The name is interned in the specified package,
+and the resulting symbol is both pushed onto the stack and added to the table.
+
+\item[9:] \hspace{2em} {\tt FOP-SMALL-SYMBOL-IN-PACKAGE-SAVE} \hspace{2em} {\it index}(4)
+\hspace{2em} {\it n}(1) \hspace{2em} {\it name}({\it n}) \hspace{2em}
+$\Rightarrow$ \hspace{2em} stack \& table\\
+The four-byte {\it index} specifies a package stored in the table.
+The one-byte operand {\it n} specifies the length of the print name
+of a symbol. The name follows, one character per byte,
+with the first byte of the print name being the first read.
+The name is interned in the specified package,
+and the resulting symbol is both pushed onto the stack and added to the table.
+
+\item[10:] \hspace{2em} {\tt FOP-SYMBOL-IN-BYTE-PACKAGE-SAVE} \hspace{2em} {\it index}(1)
+\hspace{2em} {\it n}(4) \hspace{2em} {\it name}({\it n})
+\hspace{2em} $\Rightarrow$ \hspace{2em} stack \& table\\
+The one-byte {\it index} specifies a package stored in the table.
+The four-byte operand {\it n} specifies the length of the print name
+of a symbol. The name follows, one character per byte,
+with the first byte of the print name being the first read.
+The name is interned in the specified package,
+and the resulting symbol is both pushed onto the stack and added to the table.
+
+\item[11:]\hspace{2em} {\tt FOP-SMALL-SYMBOL-IN-BYTE-PACKAGE-SAVE} \hspace{2em} {\it index}(1)
+\hspace{2em} {\it n}(1) \hspace{2em} {\it name}({\it n}) \hspace{2em}
+$\Rightarrow$ \hspace{2em} stack \& table\\
+The one-byte {\it index} specifies a package stored in the table.
+The one-byte operand {\it n} specifies the length of the print name
+of a symbol. The name follows, one character per byte,
+with the first byte of the print name being the first read.
+The name is interned in the specified package,
+and the resulting symbol is both pushed onto the stack and added to the table.
+
+\item[12:] \hspace{2em} {\tt FOP-UNINTERNED-SYMBOL-SAVE} \hspace{2em} {\it n}(4) \hspace{2em} {\it name}({\it n})
+\hspace{2em} $\Rightarrow$ \hspace{2em} stack \& table\\
+Like {\tt FOP-SYMBOL-SAVE}, except that it creates an uninterned symbol.
+
+\item[13:] \hspace{2em} {\tt FOP-UNINTERNED-SMALL-SYMBOL-SAVE} \hspace{2em} {\it n}(1)
+\hspace{2em} {\it name}({\it n}) \hspace{2em} $\Rightarrow$ \hspace{2em} stack
+\& table\\
+Like {\tt FOP-SMALL-SYMBOL-SAVE}, except that it creates an uninterned symbol.
+
+\item[14:] \hspace{2em} {\tt FOP-PACKAGE} \hspace{2em} $\Rightarrow$ \hspace{2em} table \\
+An item is popped from the stack; it must be a symbol. The package of
+that name is located and pushed onto the table.
+
+\item[15:] \hspace{2em} {\tt FOP-LIST} \hspace{2em} {\it length}(1) \hspace{2em} $\Rightarrow$ \hspace{2em} stack \\
+The unsigned operand {\it length} specifies a number of
+operands to be popped from the stack. These are made into a list
+of that length, and the list is pushed onto the stack.
+The first item popped from the stack becomes the last element of
+the list, and so on. Hence an iterative loop can start with
+the empty list and perform "pop an item and cons it onto the list"
+{\it length} times.
+(Lists of length greater than 255 can be made by using {\tt FOP-LIST*}
+repeatedly.)
+
+\item[16:] \hspace{2em} {\tt FOP-LIST*} \hspace{2em} {\it length}(1) \hspace{2em} $\Rightarrow$ \hspace{2em} stack \\
+This is like {\tt FOP-LIST} except that the constructed list is terminated
+not by {\tt ()} (the empty list), but by an item popped from the stack
+before any others are. Therefore {\it length}+1 items are popped in all.
+Hence an iterative loop can start with
+a popped item and perform "pop an item and cons it onto the list"
+{\it length}+1 times.
+
+\item[17-24:] \hspace{2em} {\tt FOP-LIST-1}, {\tt FOP-LIST-2}, ..., {\tt FOP-LIST-8} \\
+{\tt FOP-LIST-{\it k}} is like {\tt FOP-LIST} with a byte containing {\it k}
+following it. These exist purely to reduce the size of Fasload files.
+Measurements need to be made to determine the useful values of {\it k}.
+
+\item[25-32:] \hspace{2em} {\tt FOP-LIST*-1}, {\tt FOP-LIST*-2}, ..., {\tt FOP-LIST*-8} \\
+{\tt FOP-LIST*-{\it k}} is like {\tt FOP-LIST*} with a byte containing {\it k}
+following it. These exist purely to reduce the size of Fasload files.
+Measurements need to be made to determine the useful values of {\it k}.
+
+\item[33:] \hspace{2em} {\tt FOP-INTEGER} \hspace{2em} {\it n}(4) \hspace{2em} {\it value}({\it n}) \hspace{2em}
+$\Rightarrow$ \hspace{2em} stack \\
+A four-byte unsigned operand specifies the number of following
+bytes. These bytes define the value of a signed integer in two's-complement
+form. The first byte of the value is the least significant byte.
+
+\item[34:] \hspace{2em} {\tt FOP-SMALL-INTEGER} \hspace{2em} {\it n}(1) \hspace{2em} {\it value}({\it n})
+\hspace{2em} $\Rightarrow$ \hspace{2em} stack \\
+A one-byte unsigned operand specifies the number of following
+bytes. These bytes define the value of a signed integer in two's-complement
+form. The first byte of the value is the least significant byte.
+
+\item[35:] \hspace{2em} {\tt FOP-WORD-INTEGER} \hspace{2em} {\it value}(4) \hspace{2em} $\Rightarrow$ \hspace{2em} stack \\
+A four-byte signed integer (in the range $-2^{31}$ to $2^{31}-1$) follows the
+operation code. A LISP integer (fixnum or bignum) with that value
+is constructed and pushed onto the stack.
+
+\item[36:] \hspace{2em} {\tt FOP-BYTE-INTEGER} \hspace{2em} {\it value}(1) \hspace{2em} $\Rightarrow$ \hspace{2em} stack \\
+A one-byte signed integer (in the range -128 to 127) follows the
+operation code. A LISP integer (fixnum or bignum) with that value
+is constructed and pushed onto the stack.
+
+\item[37:] \hspace{2em} {\tt FOP-STRING} \hspace{2em} {\it n}(4) \hspace{2em} {\it name}({\it n})
+\hspace{2em} $\Rightarrow$ \hspace{2em} stack \\
+The four-byte operand {\it n} specifies the length of a string to
+construct. The characters of the string follow, one per byte.
+The constructed string is pushed onto the stack.
+
+\item[38:] \hspace{2em} {\tt FOP-SMALL-STRING} \hspace{2em} {\it n}(1) \hspace{2em} {\it name}({\it n}) \hspace{2em} $\Rightarrow$ \hspace{2em} stack \\
+The one-byte operand {\it n} specifies the length of a string to
+construct. The characters of the string follow, one per byte.
+The constructed string is pushed onto the stack.
+
+\item[39:] \hspace{2em} {\tt FOP-VECTOR} \hspace{2em} {\it n}(4) \hspace{2em} $\Rightarrow$ \hspace{2em} stack \\
+The four-byte operand {\it n} specifies the length of a vector of LISP objects
+to construct. The elements of the vector are popped off the stack;
+the first one popped becomes the last element of the vector.
+The constructed vector is pushed onto the stack.
+
+\item[40:] \hspace{2em} {\tt FOP-SMALL-VECTOR} \hspace{2em} {\it n}(1) \hspace{2em} $\Rightarrow$ \hspace{2em} stack \\
+The one-byte operand {\it n} specifies the length of a vector of LISP objects
+to construct. The elements of the vector are popped off the stack;
+the first one popped becomes the last element of the vector.
+The constructed vector is pushed onto the stack.
+
+\item[41:] \hspace{2em} {\tt FOP-UNIFORM-VECTOR} \hspace{2em} {\it n}(4) \hspace{2em} $\Rightarrow$ \hspace{2em} stack \\
+The four-byte operand {\it n} specifies the length of a vector of LISP objects
+to construct. A single item is popped from the stack and used to initialize
+all elements of the vector. The constructed vector is pushed onto the stack.
+
+\item[42:] \hspace{2em} {\tt FOP-SMALL-UNIFORM-VECTOR} \hspace{2em} {\it n}(1) \hspace{2em} $\Rightarrow$ \hspace{2em} stack \\
+The one-byte operand {\it n} specifies the length of a vector of LISP objects
+to construct. A single item is popped from the stack and used to initialize
+all elements of the vector. The constructed vector is pushed onto the stack.
+
+\item[43:] \hspace{2em} {\tt FOP-INT-VECTOR} \hspace{2em} {\it len}(4) \hspace{2em}
+{\it size}(1) \hspace{2em} {\it data}($\left\lceil len*count/8\right\rceil$)
+\hspace{2em} $\Rightarrow$ \hspace{2em} stack \\
+The four-byte operand {\it n} specifies the length of a vector of
+unsigned integers to be constructed. Each integer is {\it size}
+bits long, and is packed according to the machine's native byte ordering.
+{\it size} must be a directly supported i-vector element size. Currently
+supported values are 1,2,4,8,16 and 32.
+
+\item[44:] \hspace{2em} {\tt FOP-UNIFORM-INT-VECTOR} \hspace{2em} {\it n}(4) \hspace{2em} {\it size}(1) \hspace{2em}
+{\it value}(@ceiling<{\it size}/8>) \hspace{2em} $\Rightarrow$ \hspace{2em} stack \\
+The four-byte operand {\it n} specifies the length of a vector of unsigned
+integers to construct.
+Each integer is {\it size} bits big, and is initialized to the value
+of the operand {\it value}.
+The constructed vector is pushed onto the stack.
+
+\item[45:] Unused
+
+\item[46:] \hspace{2em} {\tt FOP-SINGLE-FLOAT} \hspace{2em} {\it data}(4) \hspace{2em}
+$\Rightarrow$ \hspace{2em} stack \\
+The {\it data} bytes are read as an integer, then turned into an IEEE single
+float (as though by {\tt make-single-float}).
+
+\item[47:] \hspace{2em} {\tt FOP-DOUBLE-FLOAT} \hspace{2em} {\it data}(8) \hspace{2em}
+$\Rightarrow$ \hspace{2em} stack \\
+The {\it data} bytes are read as an integer, then turned into an IEEE double
+float (as though by {\tt make-double-float}).
+
+\item[48:] \hspace{2em} {\tt FOP-STRUCT} \hspace{2em} {\it n}(4) \hspace{2em} $\Rightarrow$ \hspace{2em} stack \\
+The four-byte operand {\it n} specifies the length structure to construct. The
+elements of the vector are popped off the stack; the first one popped becomes
+the last element of the structure. The constructed vector is pushed onto the
+stack.
+
+\item[49:] \hspace{2em} {\tt FOP-SMALL-STRUCT} \hspace{2em} {\it n}(1) \hspace{2em} $\Rightarrow$ \hspace{2em} stack \\
+The one-byte operand {\it n} specifies the length structure to construct. The
+elements of the vector are popped off the stack; the first one popped becomes
+the last element of the structure. The constructed vector is pushed onto the
+stack.
+
+\item[50-52:] Unused
+
+\item[53:] \hspace{2em} {\tt FOP-EVAL} \hspace{2em} $\Rightarrow$ \hspace{2em} stack \\
+Pop an item from the stack and evaluate it (give it to {\tt EVAL}).
+Push the result back onto the stack.
+
+\item[54:] \hspace{2em} {\tt FOP-EVAL-FOR-EFFECT} \\
+Pop an item from the stack and evaluate it (give it to {\tt EVAL}).
+The result is ignored.
+
+\item[55:] \hspace{2em} {\tt FOP-FUNCALL} \hspace{2em} {\it nargs}(1) \hspace{2em} $\Rightarrow$ \hspace{2em} stack \\
+Pop {\it nargs}+1 items from the stack and apply the last one popped
+as a function to
+all the rest as arguments (the first one popped being the last argument).
+Push the result back onto the stack.
+
+\item[56:] \hspace{2em} {\tt FOP-FUNCALL-FOR-EFFECT} \hspace{2em} {\it nargs}(1) \\
+Pop {\it nargs}+1 items from the stack and apply the last one popped
+as a function to
+all the rest as arguments (the first one popped being the last argument).
+The result is ignored.
+
+\item[57:] \hspace{2em} {\tt FOP-CODE-FORMAT} \hspace{2em} {\it implementation}(1)
+\hspace{2em} {\it version}(1) \\
+This FOP specifiers the code format for following code objects. The operations
+{\tt FOP-CODE} and its relatives may not occur in a group until after {\tt
+FOP-CODE-FORMAT} has appeared; there is no default format. The {\it
+implementation} is an integer indicating the target hardware and environment.
+See {\tt compiler/generic/vm-macs.lisp} for the currently defined
+implementations. {\it version} for an implementation is increased whenever
+there is a change that renders old fasl files unusable.
+
+\item[58:] \hspace{2em} {\tt FOP-CODE} \hspace{2em} {\it nitems}(4) \hspace{2em} {\it size}(4) \hspace{2em}
+{\it code}({\it size}) \hspace{2em} $\Rightarrow$ \hspace{2em} stack \\
+A compiled function is constructed and pushed onto the stack.
+This object is in the format specified by the most recent
+occurrence of {\tt FOP-CODE-FORMAT}.
+The operand {\it nitems} specifies a number of items to pop off
+the stack to use in the "boxed storage" section. The operand {\it code}
+is a string of bytes constituting the compiled executable code.
+
+\item[59:] \hspace{2em} {\tt FOP-SMALL-CODE} \hspace{2em} {\it nitems}(1) \hspace{2em} {\it size}(2) \hspace{2em}
+{\it code}({\it size}) \hspace{2em} $\Rightarrow$ \hspace{2em} stack \\
+A compiled function is constructed and pushed onto the stack.
+This object is in the format specified by the most recent
+occurrence of {\tt FOP-CODE-FORMAT}.
+The operand {\it nitems} specifies a number of items to pop off
+the stack to use in the "boxed storage" section. The operand {\it code}
+is a string of bytes constituting the compiled executable code.
+
+\item[60-61:] Unused
+
+\item[62:] \hspace{2em} {\tt FOP-VERIFY-TABLE-SIZE} \hspace{2em} {\it size}(4) \\
+If the current size of the table is not equal to {\it size},
+then an inconsistency has been detected. This operation
+is inserted into a Fasload file purely for error-checking purposes.
+It is good practice for a compiler to output this at least at the
+end of every group, if not more often.
+
+\item[63:] \hspace{2em} {\tt FOP-VERIFY-EMPTY-STACK} \\
+If the stack is not currently empty,
+then an inconsistency has been detected. This operation
+is inserted into a Fasload file purely for error-checking purposes.
+It is good practice for a compiler to output this at least at the
+end of every group, if not more often.
+
+\item[64:] \hspace{2em} {\tt FOP-END-GROUP} \\
+This is the last operation of a group. If this is not the
+last byte of the file, then a new group follows; the next
+nine bytes must be "{\tt FASL FILE}".
+
+\item[65:] \hspace{2em} {\tt FOP-POP-FOR-EFFECT} \hspace{2em} stack \hspace{2em} $\Rightarrow$ \hspace{2em} \\
+One item is popped from the stack.
+
+\item[66:] \hspace{2em} {\tt FOP-MISC-TRAP} \hspace{2em} $\Rightarrow$ \hspace{2em} stack \\
+A trap object is pushed onto the stack.
+
+\item[67:] Unused
+
+\item[68:] \hspace{2em} {\tt FOP-CHARACTER} \hspace{2em} {\it character}(3) \hspace{2em} $\Rightarrow$ \hspace{2em} stack \\
+The three bytes are read as an integer then converted to a character. This FOP
+is currently rather useless, as extended characters are not supported.
+
+\item[69:] \hspace{2em} {\tt FOP-SHORT-CHARACTER} \hspace{2em} {\it character}(1) \hspace{2em}
+$\Rightarrow$ \hspace{2em} stack \\
+The one byte specifies the code of a Common Lisp character object. A character
+is constructed and pushed onto the stack.
+
+\item[70:] \hspace{2em} {\tt FOP-RATIO} \hspace{2em} $\Rightarrow$ \hspace{2em} stack \\
+Creates a ratio from two integers popped from the stack.
+The denominator is popped first, the numerator second.
+
+\item[71:] \hspace{2em} {\tt FOP-COMPLEX} \hspace{2em} $\Rightarrow$ \hspace{2em} stack \\
+Creates a complex number from two numbers popped from the stack.
+The imaginary part is popped first, the real part second.
+
+\item[72-73:] Unused
+
+\item[74:] \hspace{2em} {\tt FOP-FSET} \hspace{2em} \\
+Except in the cold loader (Genesis), this is a no-op with two stack arguments.
+In the initial core this is used to make DEFUN functions defined at cold-load
+time so that global functions can be called before top-level forms are run
+(which normally installs definitions.) Genesis pops the top two things off of
+the stack and effectively does (SETF SYMBOL-FUNCTION).
+
+\item[75:] \hspace{2em} {\tt FOP-LISP-SYMBOL-SAVE} \hspace{2em} {\it n}(4) \hspace{2em} {\it name}({\it n})
+\hspace{2em} $\Rightarrow$ \hspace{2em} stack \& table\\
+Like {\tt FOP-SYMBOL-SAVE}, except that it creates a symbol in the LISP
+package.
+
+\item[76:] \hspace{2em} {\tt FOP-LISP-SMALL-SYMBOL-SAVE} \hspace{2em} {\it n}(1)
+\hspace{2em} {\it name}({\it n}) \hspace{2em} $\Rightarrow$ \hspace{2em} stack
+\& table\\
+Like {\tt FOP-SMALL-SYMBOL-SAVE}, except that it creates a symbol in the LISP
+package.
+
+\item[77:] \hspace{2em} {\tt FOP-KEYWORD-SYMBOL-SAVE} \hspace{2em} {\it n}(4) \hspace{2em} {\it name}({\it n})
+\hspace{2em} $\Rightarrow$ \hspace{2em} stack \& table\\
+Like {\tt FOP-SYMBOL-SAVE}, except that it creates a symbol in the
+KEYWORD package.
+
+\item[78:] \hspace{2em} {\tt FOP-KEYWORD-SMALL-SYMBOL-SAVE} \hspace{2em} {\it n}(1)
+\hspace{2em} {\it name}({\it n}) \hspace{2em} $\Rightarrow$ \hspace{2em} stack
+\& table\\
+Like {\tt FOP-SMALL-SYMBOL-SAVE}, except that it creates a symbol in the
+KEYWORD package.
+
+\item[79-80:] Unused
+
+\item[81:] \hspace{2em} {\tt FOP-NORMAL-LOAD}\\
+This FOP is used in conjunction with the cold loader (Genesis) to read
+top-level package manipulation forms. These forms are to be read as though by
+the normal loaded, so that they can be evaluated at cold load time, instead of
+being dumped into the initial core image. A no-op in normal loading.
+
+\item[82:] \hspace{2em} {\tt FOP-MAYBE-COLD-LOAD}\\
+Undoes the effect of {\tt FOP-NORMAL-LOAD}.
+
+\item[83:] \hspace{2em} {\tt FOP-ARRAY} \hspace{2em} {\it rank}(4)
+\hspace{2em} $\Rightarrow$ \hspace{2em} stack\\
+This operation creates a simple array header (used for simple-arrays with rank
+/= 1). The data vector is popped off of the stack, and then {\it rank}
+dimensions are popped off of the stack (the highest dimensions is on top.)
+
+\item[84-139:] Unused
+
+\item[140:] \hspace{2em} {\tt FOP-ALTER-CODE} \hspace{2em} {\it index}(4)\\
+This operation modifies the constants part of a code object (necessary for
+creating certain circular function references.) It pops the new value and code
+object are off of the stack, storing the new value at the specified index.
+
+\item[141:] \hspace{2em} {\tt FOP-BYTE-ALTER-CODE} \hspace{2em} {\it index}(1)\\
+Like {\tt FOP-ALTER-CODE}, but has only a one byte offset.
+
+\item[142:] \hspace{2em} {\tt FOP-FUNCTION-ENTRY} \hspace{2em} {\it index}(4)
+\hspace{2em} $\Rightarrow$ \hspace{2em} stack\\
+Initializes a function-entry header inside of a pre-existing code object, and
+returns the corresponding function descriptor. {\it index} is the byte offset
+inside of the code object where the header should be plunked down. The stack
+arguments to this operation are the code object, function name, function debug
+arglist and function type.
+
+\item[143:] Unused
+
+\item[144:] \hspace{2em} {\tt FOP-ASSEMBLER-CODE} \hspace{2em} {\it length}(4)
+\hspace{2em} $\Rightarrow$ \hspace{2em} stack\\
+This operation creates a code object holding assembly routines. {\it length}
+bytes of code are read and placed in the code object, and the code object
+descriptor is pushed on the stack. This FOP is only recognized by the cold
+loader (Genesis.)
+
+\item[145:] \hspace{2em} {\tt FOP-ASSEMBLER-ROUTINE} \hspace{2em} {\it offset}(4)
+\hspace{2em} $\Rightarrow$ \hspace{2em} stack\\
+This operation records an entry point into an assembler code object (for use
+with {\tt FOP-ASSEMBLER-FIXUP}). The routine name (a symbol) is on stack top.
+The code object is underneath. The entry point is defined at {\it offset}
+bytes inside the code area of the code object, and the code object is left on
+stack top (allowing multiple uses of this FOP to be chained.) This FOP is only
+recognized by the cold loader (Genesis.)
+
+\item[146:] Unused
+
+\item[147:] \hspace{2em} {\tt FOP-FOREIGN-FIXUP} \hspace{2em} {\it len}(1)
+\hspace{2em} {\it name}({\it len})
+\hspace{2em} {\it offset}(4) \hspace{2em} $\Rightarrow$ \hspace{2em} stack\\
+This operation resolves a reference to a foreign (C) symbol. {\it len} bytes
+are read and interpreted as the symbol {\it name}. First the {\it kind} and the
+code-object to patch are popped from the stack. The kind is a target-dependent
+symbol indicating the instruction format of the patch target (at {\it offset}
+bytes from the start of the code area.) The code object is left on
+stack top (allowing multiple uses of this FOP to be chained.)
+
+\item[148:] \hspace{2em} {\tt FOP-ASSEMBLER-FIXUP} \hspace{2em} {\it offset}(4)
+\hspace{2em} $\Rightarrow$ \hspace{2em} stack\\
+This operation resolves a reference to an assembler routine. The stack args
+are ({\it routine-name}, {\it kind} and {\it code-object}). The kind is a
+target-dependent symbol indicating the instruction format of the patch target
+(at {\it offset} bytes from the start of the code area.) The code object is
+left on stack top (allowing multiple uses of this FOP to be chained.)
+
+\item[149-199:] Unused
+
+\item[200:] \hspace{2em} {\tt FOP-RPLACA} \hspace{2em} {\it table-idx}(4)
+\hspace{2em} {\it cdr-offset}(4)\\
+
+\item[201:] \hspace{2em} {\tt FOP-RPLACD} \hspace{2em} {\it table-idx}(4)
+\hspace{2em} {\it cdr-offset}(4)\\
+These operations destructively modify a list entered in the table. {\it
+table-idx} is the table entry holding the list, and {\it cdr-offset} designates
+the cons in the list to modify (like the argument to {\tt nthcdr}.) The new
+value is popped off of the stack, and stored in the {\tt car} or {\tt cdr},
+respectively.
+
+\item[202:] \hspace{2em} {\tt FOP-SVSET} \hspace{2em} {\it table-idx}(4)
+\hspace{2em} {\it vector-idx}(4)\\
+Destructively modifies a {\tt simple-vector} entered in the table. Pops the
+new value off of the stack, and stores it in the {\it vector-idx} element of
+the contents of the table entry {\it table-idx.}
+
+\item[203:] \hspace{2em} {\tt FOP-NTHCDR} \hspace{2em} {\it cdr-offset}(4)
+\hspace{2em} $\Rightarrow$ \hspace{2em} stack\\
+Does {\tt nthcdr} on the top-of stack, leaving the result there.
+
+\item[204:] \hspace{2em} {\tt FOP-STRUCTSET} \hspace{2em} {\it table-idx}(4)
+\hspace{2em} {\it vector-idx}(4)\\
+Like {\tt FOP-SVSET}, except it alters structure slots.
+
+\item[255:] \hspace{2em} {\tt FOP-END-HEADER} \\ Indicates the end of a group header,
+as described above.
+\end{description}
--- /dev/null
+\chapter{ICR conversion} % -*- Dictionary: design -*-
+
+
+\f
+\section{Canonical forms}
+
+\#|
+
+Would be useful to have a Freeze-Type proclamation. Its primary use would to
+be say that the indicated type won't acquire any new subtypes in the future.
+This allows better open-coding of structure type predicates, since the possible
+types that would satisfy the predicate will be constant at compile time, and
+thus can be compiled as a skip-chain of EQ tests.
+
+Of course, this is only a big win when the subtypes are few: the most important
+case is when there are none. If the closure of the subtypes is much larger
+than the average number of supertypes of an inferior, then it is better to grab
+the list of superiors out of the object's type, and test for membership in that
+list.
+
+Should type-specific numeric equality be done by EQL rather than =? i.e.
+should = on two fixnums become EQL and then convert to EQL/FIXNUM?
+Currently we transform EQL into =, which is complicated, since we have to prove
+the operands are the class of numeric type before we do it. Also, when EQL
+sees one operand is a FIXNUM, it transforms to EQ, but the generator for EQ
+isn't expecting numbers, so it doesn't use an immediate compare.
+
+
+Array hackery:
+
+
+Array type tests are transformed to %array-typep, separation of the
+implementation-dependent array-type handling. This way we can transform
+STRINGP to:
+ (or (simple-string-p x)
+ (and (complex-array-p x)
+ (= (array-rank x) 1)
+ (simple-string-p (%array-data x))))
+
+In addition to the similar bit-vector-p, we also handle vectorp and any type
+tests on which the dimension isn't wild.
+[Note that we will want to expand into frobs compatible with those that
+array references expand into so that the same optimizations will work on both.]
+
+These changes combine to convert hairy type checks into hairy typep's, and then
+convert hairyp typeps into simple typeps.
+
+
+Do we really need non-VOP templates? It seems that we could get the desired
+effect through implementation-dependent ICR transforms. The main risk would be
+of obscuring the type semantics of the code. We could fairly easily retain all
+the type information present at the time the tranform is run, but if we
+discover new type information, then it won't be propagated unless the VM also
+supplies type inference methods for its internal frobs (precluding the use of
+%PRIMITIVE, since primitives don't have derive-type methods.)
+
+I guess one possibility would be to have the call still considered "known" even
+though it has been transformed. But this doesn't work, since we start doing
+LET optimizations that trash the arglist once the call has been transformed
+(and indeed we want to.)
+
+Actually, I guess the overhead for providing type inference methods for the
+internal frobs isn't that great, since we can usually borrow the inference
+method for a Common Lisp function. For example, in our AREF case:
+ (aref x y)
+==>
+ (let ((\#:len (array-dimension x 0)))
+ (%unchecked-aref x (%check-in-bounds y \#:len)))
+
+Now in this case, if we made %UNCHECKED-AREF have the same derive-type method
+as AREF, then if we discovered something new about X's element type, we could
+derive a new type for the entire expression.
+
+Actually, it seems that baring this detail at the ICR level is beneficial,
+since it admits the possibly of optimizing away the bounds check using type
+information. If we discover X's dimensions, then \#:LEN becomes a constant that
+can be substituted. Then %CHECK-IN-BOUNDS can notice that the bound is
+constant and check it against the type for Y. If Y is known to be in range,
+then we can optimize away the bounds check.
+
+Actually in this particular case, the best thing to do would be if we
+discovered the bound is constant, then replace the bounds check with an
+implicit type check. This way all the type check optimization mechanisms would
+be brought into the act.
+
+So we actually want to do the bounds-check expansion as soon as possible,
+rather than later than possible: it should be a source-transform, enabled by
+the fast-safe policy.
+
+With multi-dimensional arrays we probably want to explicitly do the index
+computation: this way portions of the index computation can become loop
+invariants. In a scan in row-major order, the inner loop wouldn't have to do
+any multiplication: it would only do an addition. We would use normal
+fixnum arithmetic, counting on * to cleverly handle multiplication by a
+constant, and appropriate inline expansion.
+
+Note that in a source transform, we can't make any assumptions the type of the
+array. If it turns out to be a complex array without declared dimensions, then
+the calls to ARRAY-DIMENSION will have to turn into a VOP that can be affected.
+But if it is simple, then the VOP is unaffected, and if we know the bounds, it
+is constant. Similarly, we would have %ARRAY-DATA and %ARRAY-DISPLACEMENT
+operations. %ARRAY-DISPLACEMENT would optimize to 0 if we discover the array
+is simple. [This is somewhat inefficient when the array isn't eventually
+discovered to be simple, since finding the data and finding the displacement
+duplicate each other. We could make %ARRAY-DATA return both as MVs, and then
+optimize to (VALUES (%SIMPLE-ARRAY-DATA x) 0), but this would require
+optimization of trivial VALUES uses.]
+
+Also need (THE (ARRAY * * * ...) x) to assert correct rank.
+
+|\#
+
+A bunch of functions have source transforms that convert them into the
+canonical form that later parts of the compiler want to see. It is not legal
+to rely on the canonical form since source transforms can be inhibited by a
+Notinline declaration. This shouldn't be a problem, since everyone should keep
+their hands off of Notinline calls.
+
+Some transformations:
+
+Endp ==> (NULL (THE LIST ...))
+(NOT xxx) or (NULL xxx) => (IF xxx NIL T)
+
+(typep x '<simple type>) => (<simple predicate> x)
+(typep x '<complex type>) => ...composition of simpler operations...
+TYPEP of AND, OR and NOT types turned into conditionals over multiple TYPEP
+calls. This makes hairy TYPEP calls more digestible to type constraint
+propagation, and also means that the TYPEP code generators don't have to deal
+with these cases. [\#\#\# In the case of union types we may want to do something
+to preserve information for type constraint propagation.]
+
+
+ (apply \#'foo a b c)
+==>
+ (multiple-value-call \#'foo (values a) (values b) (values-list c))
+
+This way only MV-CALL needs to know how to do calls with unknown numbers of
+arguments. It should be nearly as efficient as a special-case VMR-Convert
+method could be.
+
+
+Make-String => Make-Array
+N-arg predicates associated into two-arg versions.
+Associate N-arg arithmetic ops.
+Expand CxxxR and FIRST...nTH
+Zerop, Plusp, Minusp, 1+, 1-, Min, Max, Rem, Mod
+(Values x), (Identity x) => (Prog1 x)
+
+All specialized aref functions => (aref (the xxx) ...)
+
+Convert (ldb (byte ...) ...) into internal frob that takes size and position as
+separate args. Other byte functions also...
+
+Change for-value primitive predicates into (if <pred> t nil). This isn't
+particularly useful during ICR phases, but makes life easy for VMR conversion.
+
+This last can't be a source transformation, since a source transform can't tell
+where the form appears. Instead, ICR conversion special-cases calls to known
+functions with the Predicate attribute by doing the conversion when the
+destination of the result isn't an IF. It isn't critical that this never be
+done for predicates that we ultimately discover to deliver their value to an
+IF, since IF optimizations will flush unnecessary IFs in a predicate.
+
+\f
+\section{Inline functions}
+
+[\#\#\# Inline expansion is especially powerful in the presence of good lisp-level
+optimization ("partial evaluation"). Many "optimizations" usually done in Lisp
+compilers by special-case source-to-source transforms can be had simply by
+making the source of the general case function available for inline expansion.
+This is especially helpful in Common Lisp, which has many commonly used
+functions with simple special cases but bad general cases (list and sequence
+functions, for example.)
+
+Inline expansion of recursive functions is allowed, and is not as silly as it
+sounds. When expanded in a specific context, much of the overhead of the
+recursive calls may be eliminated (especially if there are many keyword
+arguments, etc.)
+
+[Also have MAYBE-INLINE]
+]
+
+We only record a function's inline expansion in the global environment when the
+function is in the null lexical environment, since it the expansion must be
+represented as source.
+
+We do inline expansion of functions locally defined by FLET or LABELS even when
+the environment is not null. Since the appearances of the local function must
+be nested within the desired environment, it is possible to expand local
+functions inline even when they use the environment. We just stash the source
+form and environments in the Functional for the local function. When we
+convert a call to it, we just reconvert the source in the saved environment.
+
+An interesting alternative to the inline/full-call dichotomy is "semi-inline"
+coding. Whenever we have an inline expansion for a function, we can expand it
+only once per block compilation, and then use local call to call this copied
+version. This should get most of the speed advantage of real inline coding
+with much less code bloat. This is especially attractive for simple system
+functions such as Read-Char.
+
+The main place where true inline expansion would still be worth doing is where
+large amounts of the function could be optimized away by constant folding or
+other optimizations that depend on the exact arguments to the call.
+
+
+\f
+\section{Compilation policy}
+
+We want more sophisticated control of compilation safety than is offered in CL,
+so that we can emit only those type checks that are likely to discover
+something (i.e. external interfaces.)
+
+\#|
+
+\f
+\section{Notes}
+
+Generalized back-end notion provides dynamic retargeting? (for byte code)
+
+The current node type annotations seem to be somewhat unsatisfactory, since we
+lose information when we do a THE on a continuation that already has uses, or
+when we convert a let where the actual result continuation has other uses.
+
+But the case with THE isn't really all that bad, since the test of whether
+there are any uses happens before conversion of the argument, thus THE loses
+information only when there are uses outside of the declared form. The LET
+case may not be a big deal either.
+
+Note also that losing user assertions isn't really all that bad, since it won't
+damage system integrity. At worst, it will cause a bug to go undetected. More
+likely, it will just cause the error to be signaled in a different place (and
+possibly in a less informative way). Of course, there is an efficiency hit for
+losing type information, but if it only happens in strange cases, then this
+isn't a big deal.
+
+\f
+\chapter{Local call analysis}
+
+All calls to local functions (known named functions and LETs) are resolved to
+the exact LAMBDA node which is to be called. If the call is syntactically
+illegal, then we emit a warning and mark the reference as :notinline, forcing
+the call to be a full call. We don't even think about converting APPLY calls;
+APPLY is not special-cased at all in ICR. We also take care not to convert
+calls in the top-level component, which would join it to normal code. Calls to
+functions with rest args and calls with non-constant keywords are also not
+converted.
+
+We also convert MV-Calls that look like MULTIPLE-VALUE-BIND to local calls,
+since we know that they can be open-coded. We replace the optional dispatch
+with a call to the last optional entry point, letting MV-Call magically default
+the unsupplied values to NIL.
+
+When ICR optimizations discover a possible new local call, they explicitly
+invoke local call analysis on the code that needs to be reanalyzed.
+
+[\#\#\# Let conversion. What is means to be a let. Argument type checking done
+by caller. Significance of local call is that all callers are known, so
+special call conventions may be used.]
+A lambda called in only one place is called a "let" call, since a Let would
+turn into one.
+
+In addition to enabling various ICR optimizations, the let/non-let distinction
+has important environment significance. We treat the code in function and all
+of the lets called by that function as being in the same environment. This
+allows exits from lets to be treated as local exits, and makes life easy for
+environment analysis.
+
+Since we will let-convert any function with only one call, we must be careful
+about cleanups. It is possible that a lexical exit from the let function may
+have to clean up dynamic bindings not lexically apparent at the exit point. We
+handle this by annotating lets with any cleanup in effect at the call site.
+The cleanup for continuations with no immediately enclosing cleanup is the
+lambda that the continuation is in. In this case, we look at the lambda to see
+if any cleanups need to be done.
+
+Let conversion is disabled for entry-point functions, since otherwise we might
+convert the call from the XEP to the entry point into a let. Then later on, we
+might want to convert a non-local reference into a local call, and not be able
+to, since once a function has been converted to a let, we can't convert it
+back.
+
+
+A function's return node may also be deleted if it is unreachable, which can
+happen if the function never returns normally. Such functions are not lets.
+
+\f
+\chapter{Find components}
+
+This is a post-pass to ICR conversion that massages the flow graph into the
+shape subsequent phases expect. Things done:
+ Compute the depth-first ordering for the flow graph.
+ Find the components (disconnected parts) of the flow graph.
+
+This pass need only be redone when newly converted code has been added to the
+flow graph. The reanalyze flag in the component structure should be set by
+people who mess things up.
+
+We create the initial DFO using a variant of the basic algorithm. The initial
+DFO computation breaks the ICR up into components, which are parts that can be
+compiled independently. This is done to increase the efficiency of large block
+compilations. In addition to improving locality of reference and reducing the
+size of flow analysis problems, this allows back-end data structures to be
+reclaimed after the compilation of each component.
+
+ICR optimization can change the connectivity of the flow graph by discovering
+new calls or eliminating dead code. Initial DFO determination splits up the
+flow graph into separate components, but does so conservatively, ensuring that
+parts that might become joined (due to local call conversion) are joined from
+the start. Initial DFO computation also guarantees that all code which shares
+a lexical environment is in the same component so that environment analysis
+needs to operate only on a single component at a time.
+
+[This can get a bit hairy, since code seemingly reachable from the
+environment entry may be reachable from a NLX into that environment. Also,
+function references must be considered as links joining components even though
+the flow graph doesn't represent these.]
+
+After initial DFO determination, components are neither split nor joined. The
+standard DFO computation doesn't attempt to split components that have been
+disconnected.
+
+\f
+\chapter{ICR optimize}
+
+{\bf Somewhere describe basic ICR utilities: continuation-type,
+constant-continuation-p, etc. Perhaps group by type in ICR description?}
+
+We are conservative about doing variable-for-variable substitution in ICR
+optimization, since if we substitute a variable with a less restrictive type,
+then we may prevent use of a "good" representation within the scope of the
+inner binding.
+
+Note that variable-variable substitutions aren't really crucial in ICR, since
+they don't create opportunities for new optimizations (unlike substitution of
+constants and functions). A spurious variable-variable binding will show up as
+a Move operation in VMR. This can be optimized away by reaching-definitions
+and also by targeting. [\#\#\# But actually, some optimizers do see if operands
+are the same variable.]
+
+\#|
+
+The IF-IF optimization can be modeled as a value driven optimization, since
+adding a use definitely is cause for marking the continuation for
+reoptimization. [When do we add uses? Let conversion is the only obvious
+time.] I guess IF-IF conversion could also be triggered by a non-immediate use
+of the test continuation becoming immediate, but to allow this to happen would
+require Delete-Block (or somebody) to mark block-starts as needing to be
+reoptimized when a predecessor changes. It's not clear how important it is
+that IF-IF conversion happen under all possible circumstances, as long as it
+happens to the obvious cases.
+
+[\#\#\# It isn't totally true that code flushing never enables other worthwhile
+optimizations. Deleting a functional reference can cause a function to cease
+being an XEP, or even trigger let conversion. It seems we still want to flush
+code during ICR optimize, but maybe we want to interleave it more intimately
+with the optimization pass.
+
+Ref-flushing works just as well forward as backward, so it could be done in the
+forward pass. Call flushing doesn't work so well, but we could scan the block
+backward looking for any new flushable stuff if we flushed a call on the
+forward pass.
+
+When we delete a variable due to lack of references, we leave the variable
+in the lambda-list so that positional references still work. The initial value
+continuation is flushed, though (replaced with NIL) allowing the initial value
+for to be deleted (modulo side-effects.)
+
+Note that we can delete vars with no refs even when they have sets. I guess
+when there are no refs, we should also flush all sets, allowing the value
+expressions to be flushed as well.
+
+Squeeze out single-reference unset let variables by changing the dest of the
+initial value continuation to be the node that receives the ref. This can be
+done regardless of what the initial value form is, since we aren't actually
+moving the evaluation. Instead, we are in effect using the continuation's
+locations in place of the temporary variable.
+
+Doing this is of course, a wild violation of stack discipline, since the ref
+might be inside a loop, etc. But with the VMR back-end, we only need to
+preserve stack discipline for unknown-value continuations; this ICR
+transformation must be already be inhibited when the DEST of the REF is a
+multiple-values receiver (EXIT, RETURN or MV-COMBINATION), since we must
+preserve the single-value semantics of the let-binding in this case.
+
+The REF and variable must be deleted as part of this operation, since the ICR
+would otherwise be left in an inconsistent state; we can't wait for the REF to
+be deleted due to bing unused, since we have grabbed the arg continuation and
+substituted it into the old DEST.
+
+The big reason for doing this transformation is that in macros such as INCF and
+PSETQ, temporaries are squeezed out, and the new value expression is evaluated
+directly to the setter, allowing any result type assertion to be applied to the
+expression evaluation. Unlike in the case of substitution, there is no point
+in inhibiting this transformation when the initial value type is weaker than
+the variable type. Instead, we intersect the asserted type for the old REF's
+CONT with the type assertion on the initial value continuation. Note that the
+variable's type has already been asserted on the initial-value continuation.
+
+Of course, this transformation also simplifies the ICR even when it doesn't
+discover interesting type assertions, so it makes sense to do it whenever
+possible. This reduces the demands placed on register allocation, etc.
+
+|\#
+
+There are three dead-code flushing rules:
+ 1] Refs with no DEST may be flushed.
+ 2] Known calls with no dest that are flushable may be flushed. We null the
+ DEST in all the args.
+ 3] If a lambda-var has no refs, then it may be deleted. The flushed argument
+ continuations have their DEST nulled.
+
+These optimizations all enable one another. We scan blocks backward, looking
+for nodes whose CONT has no DEST, then type-dispatching off of the node. If we
+delete a ref, then we check to see if it is a lambda-var with no refs. When we
+flush an argument, we mark the blocks for all uses of the CONT as needing to be
+reoptimized.
+
+\f
+\section{Goals for ICR optimizations}
+
+\#|
+
+When an optimization is disabled, code should still be correct and not
+ridiculously inefficient. Phases shouldn't be made mandatory when they have
+lots of non-required stuff jammed into them.
+
+|\#
+
+This pass is optional, but is desirable if anything is more important than
+compilation speed.
+
+This phase is a grab-bag of optimizations that concern themselves with the flow
+of values through the code representation. The main things done are type
+inference, constant folding and dead expression elimination. This phase can be
+understood as a walk of the expression tree that propagates assertions down the
+tree and propagates derived information up the tree. The main complication is
+that there isn't any expression tree, since ICR is flow-graph based.
+
+We repeat this pass until we don't discover anything new. This is a bit of
+feat, since we dispatch to arbitrary functions which may do arbitrary things,
+making it hard to tell if anything really happened. Even if we solve this
+problem by requiring people to flag when they changed or by checking to see if
+they changed something, there are serious efficiency problems due to massive
+redundant computation, since in many cases the only way to tell if anything
+changed is to recompute the value and see if it is different from the old one.
+
+We solve this problem by requiring that optimizations for a node only depend on
+the properties of the CONT and the continuations that have the node as their
+DEST. If the continuations haven't changed since the last pass, then we don't
+attempt to re-optimize the node, since we know nothing interesting will happen.
+
+We keep track of which continuations have changed by a REOPTIMIZE flag that is
+set whenever something about the continuation's value changes.
+
+When doing the bottom up pass, we dispatch to type specific code that knows how
+to tell when a node needs to be reoptimized and does the optimization. These
+node types are special-cased: COMBINATION, IF, RETURN, EXIT, SET.
+
+The REOPTIMIZE flag in the COMBINATION-FUN is used to detect when the function
+information might have changed, so that we know when where are new assertions
+that could be propagated from the function type to the arguments.
+
+When we discover something about a leaf, or substitute for leaf, we reoptimize
+the CONT for all the REF and SET nodes.
+
+We have flags in each block that indicate when any nodes or continuations in
+the block need to be re-optimized, so we don't have to scan blocks where there
+is no chance of anything happening.
+
+It is important for efficiency purposes that optimizers never say that they did
+something when they didn't, but this by itself doesn't guarantee timely
+termination. I believe that with the type system implemented, type inference
+will converge in finite time, but as a practical matter, it can take far too
+long to discover not much. For this reason, ICR optimization is terminated
+after three consecutive passes that don't add or delete code. This premature
+termination only happens 2% of the time.
+
+\f
+\section{Flow graph simplification}
+
+Things done:
+ Delete blocks with no predecessors.
+ Merge blocks that can be merged.
+ Convert local calls to Let calls.
+ Eliminate degenerate IFs.
+
+We take care not to merge blocks that are in different functions or have
+different cleanups. This guarantees that non-local exits are always at block
+ends and that cleanup code never needs to be inserted within a block.
+
+We eliminate IFs with identical consequent and alternative. This would most
+likely happen if both the consequent and alternative were optimized away.
+
+[Could also be done if the consequent and alternative were different blocks,
+but computed the same value. This could be done by a sort of cross-jumping
+optimization that looked at the predecessors for a block and merged code shared
+between predecessors. IFs with identical branches would eventually be left
+with nothing in their branches.]
+
+We eliminate IF-IF constructs:
+ (IF (IF A B C) D E) ==>
+ (IF A (IF B D E) (IF C D E))
+
+In reality, what we do is replicate blocks containing only an IF node where the
+predicate continuation is the block start. We make one copy of the IF node for
+each use, leaving the consequent and alternative the same. If you look at the
+flow graph representation, you will see that this is really the same thing as
+the above source to source transformation.
+
+\f
+\section{Forward ICR optimizations}
+
+In the forward pass, we scan the code in forward depth-first order. We
+examine each call to a known function, and:
+
+\begin{itemize}
+\item Eliminate any bindings for unused variables.
+
+\item Do top-down type assertion propagation. In local calls, we propagate
+asserted and derived types between the call and the called lambda.
+
+\item
+ Replace calls of foldable functions with constant arguments with the
+ result. We don't have to actually delete the call node, since Top-Down
+ optimize will delete it now that its value is unused.
+
+\item
+ Run any Optimizer for the current function. The optimizer does arbitrary
+ transformations by hacking directly on the IR. This is useful primarily
+ for arithmetic simplification and similar things that may need to examine
+ and modify calls other than the current call. The optimizer is responsible
+ for recording any changes that it makes. An optimizer can inhibit further
+ optimization of the node during the current pass by returning true. This
+ is useful when deleting the node.
+
+\item
+ Do ICR transformations, replacing a global function call with equivalent
+ inline lisp code.
+
+\item
+ Do bottom-up type propagation/inferencing. For some functions such as
+ Coerce we will dispatch to a function to find the result type. The
+ Derive-Type function just returns a type structure, and we check if it is
+ different from the old type in order to see if there was a change.
+
+\item
+ Eliminate IFs with predicates known to be true or false.
+
+\item
+ Substitute the value for unset let variables that are bound to constants,
+ unset lambda variables or functionals.
+
+\item
+ Propagate types from local call args to var refs.
+\end{itemize}
+
+We use type info from the function continuation to find result types for
+functions that don't have a derive-type method.
+
+
+ICR transformation:
+
+ICR transformation does "source to source" transformations on known global
+functions, taking advantage of semantic information such as argument types and
+constant arguments. Transformation is optional, but should be done if speed or
+space is more important than compilation speed. Transformations which increase
+space should pass when space is more important than speed.
+
+A transform is actually an inline function call where the function is computed
+at compile time. The transform gets to peek at the continuations for the
+arguments, and computes a function using the information gained. Transforms
+should be cautious about directly using the values of constant continuations,
+since the compiler must preserve eqlness of named constants, and it will have a
+hard time if transforms go around randomly copying constants.
+
+The lambda that the transform computes replaces the original function variable
+reference as the function for the call. This lets the compiler worry about
+evaluating each argument once in the right order. We want to be careful to
+preserve type information when we do a transform, since it may be less than
+obvious what the transformed code does.
+
+There can be any number of transforms for a function. Each transform is
+associated with a function type that the call must be compatible with. A
+transform is only invoked if the call has the right type. This provides a way
+to deal with the common case of a transform that only applies when the
+arguments are of certain types and some arguments are not specified. We always
+use the derived type when determining whether a transform is applicable. Type
+check is responsible for setting the derived type to the intersection of the
+asserted and derived types.
+
+If the code in the expansion has insufficient explicit or implicit argument
+type checking, then it should cause checks to be generated by making
+declarations.
+
+A transformation may decide to pass if it doesn't like what it sees when it
+looks at the args. The Give-Up function unwinds out of the transform and deals
+with complaining about inefficiency if speed is more important than brevity.
+The format args for the message are arguments to Give-Up. If a transform can't
+be done, we just record the message where ICR finalize can find it. note. We
+can't complain immediately, since it might get transformed later on.
+
+\f
+\section{Backward ICR optimizations}
+
+In the backward pass, we scan each block in reverse order, and
+eliminate any effectless nodes with unused values. In ICR this is the
+only way that code is deleted other than the elimination of unreachable blocks.
+
+\f
+\chapter{Type checking}
+
+[\#\#\# Somehow split this section up into three parts:
+ -- Conceptual: how we know a check is necessary, and who is responsible for
+ doing checks.
+ -- Incremental: intersection of derived and asserted types, checking for
+ non-subtype relationship.
+ -- Check generation phase.
+]
+
+
+We need to do a pretty good job of guessing when a type check will ultimately
+need to be done. Generic arithmetic, for example: In the absence of
+declarations, we will use use the safe variant, but if we don't know this, we
+will generate a check for NUMBER anyway. We need to look at the fast-safe
+templates and guess if any of them could apply.
+
+We compute a function type from the VOP arguments
+and assertions on those arguments. This can be used with Valid-Function-Use
+to see which templates do or might apply to a particular call. If we guess
+that a safe implementation will be used, then we mark the continuation so as to
+force a safe implementation to be chosen. [This will happen if ICR optimize
+doesn't run to completion, so the icr optimization after type check generation
+can discover new type information. Since we won't redo type check at that
+point, there could be a call that has applicable unsafe templates, but isn't
+type checkable.]
+
+[\#\#\# A better and more general optimization of structure type checks: in type
+check conversion, we look at the *original derived* type of the continuation:
+if the difference between the proven type and the asserted type is a simple
+type check, then check for the negation of the difference. e.g. if we want a
+FOO and we know we've got (OR FOO NULL), then test for (NOT NULL). This is a
+very important optimization for linked lists of structures, but can also apply
+in other situations.]
+
+If after ICR phases, we have a continuation with check-type set in a context
+where it seems likely a check will be emitted, and the type is too
+hairy to be easily checked (i.e. no CHECK-xxx VOP), then we do a transformation
+on the ICR equivalent to:
+ (... (the hair <foo>) ...)
+==>
+ (... (funcall \#'(lambda (\#:val)
+ (if (typep \#:val 'hair)
+ \#:val
+ (%type-check-error \#:val 'hair)))
+ <foo>)
+ ...)
+This way, we guarantee that VMR conversion never has to emit type checks for
+hairy types.
+
+[Actually, we need to do a MV-bind and several type checks when there is a MV
+continuation. And some values types are just too hairy to check. We really
+can't check any assertion for a non-fixed number of values, since there isn't
+any efficient way to bind arbitrary numbers of values. (could be done with
+MV-call of a more-arg function, I guess...)
+]
+
+[Perhaps only use CHECK-xxx VOPs for types equivalent to a ptype? Exceptions
+for CONS and SYMBOL? Anyway, no point in going to trouble to implement and
+emit rarely used CHECK-xxx vops.]
+
+One potential lose in converting a type check to explicit conditionals rather
+than to a CHECK-xxx VOP is that VMR code motion optimizations won't be able to
+do anything. This shouldn't be much of an issue, though, since type constraint
+propagation has already done global optimization of type checks.
+
+
+This phase is optional, but should be done if anything is more important than
+compile speed.
+
+Type check is responsible for reconciling the continuation asserted and derived
+types, emitting type checks if appropriate. If the derived type is a subtype
+of the asserted type, then we don't need to do anything.
+
+If there is no intersection between the asserted and derived types, then there
+is a manifest type error. We print a warning message, indicating that
+something is almost surely wrong. This will inhibit any transforms or
+generators that care about their argument types, yet also inhibits further
+error messages, since NIL is a subtype of every type.
+
+If the intersection is not null, then we set the derived type to the
+intersection of the asserted and derived types and set the Type-Check flag in
+the continuation. We always set the flag when we can't prove that the type
+assertion is satisfied, regardless of whether we will ultimately actually emit
+a type check or not. This is so other phases such as type constraint
+propagation can use the Type-Check flag to detect an interesting type
+assertion, instead of having to duplicate much of the work in this phase.
+[\#\#\# 7 extremely random values for CONTINUATION-TYPE-CHECK.]
+
+Type checks are generated on the fly during VMR conversion. When VMR
+conversion generates the check, it prints an efficiency note if speed is
+important. We don't flame now since type constraint progpagation may decide
+that the check is unnecessary. [\#\#\# Not done now, maybe never.]
+
+In local function call, it is the caller that is in effect responsible for
+checking argument types. This happens in the same way as any other type check,
+since ICR optimize propagates the declared argument types to the type
+assertions for the argument continuations in all the calls.
+
+Since the types of arguments to entry points are unknown at compile time, we
+want to do runtime checks to ensure that the incoming arguments are of the
+correct type. This happens without any special effort on the part of type
+check, since the XEP is represented as a local call with unknown type
+arguments. These arguments will be marked as needing to be checked.
+
+\f
+\chapter{Constraint propagation}
+
+\#|
+New lambda-var-slot:
+
+constraints: a list of all the constraints on this var for either X or Y.
+
+How to maintain consistency? Does it really matter if there are constraints
+with deleted vars lying around? Note that whatever mechanism we use for
+getting the constraints in the first place should tend to keep them up to date.
+Probably we would define optimizers for the interesting relations that look at
+their CONT's dest and annotate it if it is an IF.
+
+But maybe it is more trouble then it is worth trying to build up the set of
+constraints during ICR optimize (maintaining consistency in the process).
+Since ICR optimize iterates a bunch of times before it converges, we would be
+wasting time recomputing the constraints, when nobody uses them till constraint
+propagation runs.
+
+It seems that the only possible win is if we re-ran constraint propagation
+(which we might want to do.) In that case, we wouldn't have to recompute all
+the constraints from scratch. But it seems that we could do this just as well
+by having ICR optimize invalidate the affected parts of the constraint
+annotation, rather than trying to keep them up to date. This also fits better
+with the optional nature of constraint propagation, since we don't want ICR
+optimize to commit to doing a lot of the work of constraint propagation.
+
+For example, we might have a per-block flag indicating that something happened
+in that block since the last time constraint propagation ran. We might have
+different flags to represent the distinction between discovering a new type
+assertion inside the block and discovering something new about an if
+predicate, since the latter would be cheaper to update and probably is more
+common.
+
+It's fairly easy to see how we can build these sets of restrictions and
+propagate them using flow analysis, but actually using this information seems
+a bit more ad-hoc.
+
+Probably the biggest thing we do is look at all the refs. If have proven that
+the value is EQ (EQL for a number) to some other leaf (constant or lambda-var),
+then we can substitute for that reference. In some cases, we will want to do
+special stuff depending on the DEST. If the dest is an IF and we proved (not
+null), then we can substitute T. And if the dest is some relation on the same
+two lambda-vars, then we want to see if we can show that relation is definitely
+true or false.
+
+Otherwise, we can do our best to invert the set of restrictions into a type.
+Since types hold only constant info, we have to ignore any constraints between
+two vars. We can make some use of negated type restrictions by using
+TYPE-DIFFERENCE to remove the type from the ref types. If our inferred type is
+as good as the type assertion, then the continuation's type-check flag will be
+cleared.
+
+It really isn't much of a problem that we don't infer union types on joins,
+since union types are relatively easy to derive without using flow information.
+The normal bottom-up type inference done by ICR optimize does this for us: it
+annotates everything with the union of all of the things it might possibly be.
+Then constraint propagation subtracts out those types that can't be in effect
+because of predicates or checks.
+
+
+
+This phase is optional, but is desirable if anything is more important than
+compilation speed. We use an algorithm similar to available expressions to
+propagate variable type information that has been discovered by implicit or
+explicit type tests, or by type inference.
+
+We must do a pre-pass which locates set closure variables, since we cannot do
+flow analysis on such variables. We set a flag in each set closure variable so
+that we can quickly tell that it is losing when we see it again. Although this
+may seem to be wastefully redundant with environment analysis, the overlap
+isn't really that great, and the cost should be small compared to that of the
+flow analysis that we are preparing to do. [Or we could punt on set
+variables...]
+
+A type constraint is a structure that includes sset-element and has the type
+and variable.
+[\#\#\# Also a not-p flag indicating whether the sense is negated.]
+ Each variable has a list of its type constraints. We create a
+type constraint when we see a type test or check. If there is already a
+constraint for the same variable and type, then we just re-use it. If there is
+already a weaker constraint, then we generate both the weak constraints and the
+strong constraint so that the weak constraints won't be lost even if the strong
+one is unavailable.
+
+We find all the distinct type constraints for each variable during the pre-pass
+over the lambda nesting. Each constraint has a list of the weaker constraints
+so that we can easily generate them.
+
+Every block generates all the type constraints in it, but a constraint is
+available in a successor only if it is available in all predecessors. We
+determine the actual type constraint for a variable at a block by intersecting
+all the available type constraints for that variable.
+
+This isn't maximally tense when there are constraints that are not
+hierarchically related, e.g. (or a b) (or b c). If these constraints were
+available from two predecessors, then we could infer that we have an (or a b c)
+constraint, but the above algorithm would come up with none. This probably
+isn't a big problem.
+
+[\#\#\# Do we want to deal with (if (eq <var> '<foo>) ...) indicating singleton
+member type?]
+
+We detect explicit type tests by looking at type test annotation in the IF
+node. If there is a type check, the OUT sets are stored in the node, with
+different sets for the consequent and alternative. Implicit type checks are
+located by finding Ref nodes whose Cont has the Type-Check flag set. We don't
+actually represent the GEN sets, we just initialize OUT to it, and then form
+the union in place.
+
+When we do the post-pass, we clear the Type-Check flags in the continuations
+for Refs when we discover that the available constraints satisfy the asserted
+type. Any explicit uses of typep should be cleaned up by the ICR optimizer for
+typep. We can also set the derived type for Refs to the intersection of the
+available type assertions. If we discover anything, we should consider redoing
+ICR optimization, since better type information might enable more
+optimizations.
+
+
+\chapter{ICR finalize} % -*- Dictionary: design -*-
+
+This pass looks for interesting things in the ICR so that we can forget about
+them. Used and not defined things are flamed about.
+
+We postpone these checks until now because the ICR optimizations may discover
+errors that are not initially obvious. We also emit efficiency notes about
+optimizations that we were unable to do. We can't emit the notes immediately,
+since we don't know for sure whether a repeated attempt at optimization will
+succeed.
+
+We examine all references to unknown global function variables and update the
+approximate type accordingly. We also record the names of the unknown
+functions so that they can be flamed about if they are never defined. Unknown
+normal variables are flamed about on the fly during ICR conversion, so we
+ignore them here.
+
+We check each newly defined global function for compatibility with previously
+recorded type information. If there is no :defined or :declared type, then we
+check for compatibility with any approximate function type inferred from
+previous uses.
+\f
+\chapter{Environment analysis}
+\#|
+
+A related change would be to annotate ICR with information about tail-recursion
+relations. What we would do is add a slot to the node structure that points to
+the corresponding Tail-Info when a node is in a TR position. This annotation
+would be made in a final ICR pass that runs after cleanup code is generated
+(part of environment analysis). When true, the node is in a true TR position
+(modulo return-convention incompatibility). When we determine return
+conventions, we null out the tail-p slots in XEP calls or known calls where we
+decided not to preserve tail-recursion.
+
+
+In this phase, we also check for changes in the dynamic binding environment
+that require cleanup code to be generated. We just check for changes in the
+Continuation-Cleanup on local control transfers. If it changes from
+an inner dynamic context to an outer one that is in the same environment, then
+we emit code to clean up the dynamic bindings between the old and new
+continuation. We represent the result of cleanup detection to the back end by
+interposing a new block containing a call to a funny function. Local exits
+from CATCH or UNWIND-PROTECT are detected in the same way.
+
+
+|\#
+
+The primary activity in environment analysis is the annotation of ICR with
+environment structures describing where variables are allocated and what values
+the environment closes over.
+
+Each lambda points to the environment where its variables are allocated, and
+the environments point back. We always allocate the environment at the Bind
+node for the sole non-let lambda in the environment, so there is a close
+relationship between environments and functions. Each "real function" (i.e.
+not a LET) has a corresponding environment.
+
+We attempt to share the same environment among as many lambdas as possible so
+that unnecessary environment manipulation is not done. During environment
+analysis the only optimization of this sort is realizing that a Let (a lambda
+with no Return node) cannot need its own environment, since there is no way
+that it can return and discover that its old values have been clobbered.
+
+When the function is called, values from other environments may need to be made
+available in the function's environment. These values are said to be "closed
+over".
+
+Even if a value is not referenced in a given environment, it may need to be
+closed over in that environment so that it can be passed to a called function
+that does reference the value. When we discover that a value must be closed
+over by a function, we must close over the value in all the environments where
+that function is referenced. This applies to all references, not just local
+calls, since at other references we must have the values on hand so that we can
+build a closure. This propagation must be applied recursively, since the value
+must also be available in *those* functions' callers.
+
+If a closure reference is known to be "safe" (not an upward funarg), then the
+closure structure may be allocated on the stack.
+
+Closure analysis deals only with closures over values, while Common Lisp
+requires closures over variables. The difference only becomes significant when
+variables are set. If a variable is not set, then we can freely make copies of
+it without keeping track of where they are. When a variable is set, we must
+maintain a single value cell, or at least the illusion thereof. We achieve
+this by creating a heap-allocated "value cell" structure for each set variable
+that is closed over. The pointer to this value cell is passed around as the
+"value" corresponding to that variable. References to the variable must
+explicitly indirect through the value cell.
+
+When we are scanning over the lambdas in the component, we also check for bound
+but not referenced variables.
+
+Environment analysis emits cleanup code for local exits and markers for
+non-local exits.
+
+A non-local exit is a control transfer from one environment to another. In a
+non-local exit, we must close over the continuation that we transfer to so that
+the exiting function can find its way back. We indicate the need to close a
+continuation by placing the continuation structure in the closure and also
+pushing it on a list in the environment structure for the target of the exit.
+[\#\#\# To be safe, we would treat the continuation as a set closure variable so
+that we could invalidate it when we leave the dynamic extent of the exit point.
+Transferring control to a meaningless stack pointer would be apt to cause
+horrible death.]
+
+Each local control transfer may require dynamic state such as special bindings
+to be undone. We represent cleanup actions by funny function calls in a new
+block linked in as an implicit MV-PROG1.
+
--- /dev/null
+\chapter{Glossary}% -*- Dictionary: int:design -*-
+
+% Note: in an entry, any word that is also defined should be \it
+% should entries have page references as well?
+
+\begin{description}
+\item[assert (a type)]
+In Python, all type checking is done via a general type assertion
+mechanism. Explicit declarations and implicit assertions (e.g. the arg to
++ is a number) are recorded in the front-end (implicit continuation)
+representation. Type assertions (and thus type-checking) are "unbundled"
+from the operations that are affected by the assertion. This has two major
+advantages:
+\begin{itemize}
+\item Code that implements operations need not concern itself with checking
+operand types.
+
+\item Run-time type checks can be eliminated when the compiler can prove that
+the assertion will always be satisfied.
+\end{itemize}
+See also {\it restrict}.
+
+\item[back end] The back end is the part of the compiler that operates on the
+{\it virtual machine} intermediate representation. Also included are the
+compiler phases involved in the conversion from the {\it front end}
+representation (or {\it ICR}).
+
+\item[bind node] This is a node type the that marks the start of a {\it lambda}
+body in {\it ICR}. This serves as a placeholder for environment manipulation
+code.
+
+\item[IR1] The first intermediate representation, also known as {\it ICR}, or
+the Implicit Continuation Represenation.
+
+\item[IR2] The second intermediate representation, also known as {\it VMR}, or
+the Virtual Machine Representation.
+
+\item[basic block] A basic block (or simply "block") has the pretty much the
+usual meaning of representing a straight-line sequence of code. However, the
+code sequence ultimately generated for a block might contain internal branches
+that were hidden inside the implementation of a particular operation. The type
+of a block is actually {\tt cblock}. The {\tt block-info} slot holds an
+{\tt VMR-block} containing backend information.
+
+\item[block compilation] Block compilation is a term commonly used to describe
+the compile-time resolution of function names. This enables many
+optimizations.
+
+\item[call graph]
+Each node in the call graph is a function (represented by a {\it flow graph}.)
+The arcs in the call graph represent a possible call from one function to
+another. See also {\it tail set}.
+
+\item[cleanup]
+A cleanup is the part of the implicit continuation representation that
+retains information scoping relationships. For indefinite extent bindings
+(variables and functions), we can abandon scoping information after ICR
+conversion, recovering the lifetime information using flow analysis. But
+dynamic bindings (special values, catch, unwind protect, etc.) must be
+removed at a precise time (whenever the scope is exited.) Cleanup
+structures form a hierarchy that represents the static nesting of dynamic
+binding structures. When the compiler does a control transfer, it can use
+the cleanup information to determine what cleanup code needs to be emitted.
+
+\item[closure variable]
+A closure variable is any lexical variable that has references outside of
+its {\it home environment}. See also {\it indirect value cell}.
+
+\item[closed continuation] A closed continuation represents a {\tt tagbody} tag
+or {\tt block} name that is closed over. These two cases are mostly
+indistinguishable in {\it ICR}.
+
+\item[home] Home is a term used to describe various back-pointers. A lambda
+variable's "home" is the lambda that the variable belongs to. A lambda's "home
+environment" is the environment in which that lambda's variables are allocated.
+
+\item[indirect value cell]
+Any closure variable that has assignments ({\tt setq}s) will be allocated in an
+indirect value cell. This is necessary to ensure that all references to
+the variable will see assigned values, since the compiler normally freely
+copies values when creating a closure.
+
+\item[set variable] Any variable that is assigned to is called a "set
+variable". Several optimizations must special-case set variables, and set
+closure variables must have an {\it indirect value cell}.
+
+\item[code generator] The code generator for a {\it VOP} is a potentially
+arbitrary list code fragment which is responsible for emitting assembly code to
+implement that VOP.
+
+\item[constant pool] The part of a compiled code object that holds pointers to
+non-immediate constants.
+
+\item[constant TN]
+A constant TN is the {\it VMR} of a compile-time constant value. A
+constant may be immediate, or may be allocated in the {\it constant pool}.
+
+\item[constant leaf]
+A constant {\it leaf} is the {\it ICR} of a compile-time constant value.
+
+\item[combination]
+A combination {\it node} is the {\it ICR} of any fixed-argument function
+call (not {\tt apply} or {\tt multiple-value-call}.)
+
+\item[top-level component]
+A top-level component is any component whose only entry points are top-level
+lambdas.
+
+\item[top-level lambda]
+A top-level lambda represents the execution of the outermost form on which
+the compiler was invoked. In the case of {\tt compile-file}, this is often a
+truly top-level form in the source file, but the compiler can recursively
+descend into some forms ({\tt eval-when}, etc.) breaking them into separate
+compilations.
+
+\item[component] A component is basically a sequence of blocks. Each component
+is compiled into a separate code object. With {\it block compilation} or {\it
+local functions}, a component will contain the code for more than one function.
+This is called a component because it represents a connected portion of the
+call graph. Normally the blocks are in depth-first order ({\it DFO}).
+
+\item[component, initial] During ICR conversion, blocks are temporarily
+assigned to initial components. The "flow graph canonicalization" phase
+determines the true component structure.
+
+\item[component, head and tail]
+The head and tail of a component are dummy blocks that mark the start and
+end of the {\it DFO} sequence. The component head and tail double as the root
+and finish node of the component's flow graph.
+
+\item[local function (call)]
+A local function call is a call to a function known at compile time to be
+in the same {\it component}. Local call allows compile time resolution of the
+target address and calling conventions. See {\it block compilation}.
+
+\item[conflict (of TNs, set)]
+Register allocation terminology. Two TNs conflict if they could ever be
+live simultaneously. The conflict set of a TN is all TNs that it conflicts
+with.
+
+\item[continuation]
+The ICR data structure which represents both:
+\begin{itemize}
+\item The receiving of a value (or multiple values), and
+
+\item A control location in the flow graph.
+\end{itemize}
+In the Implicit Continuation Representation, the environment is implicit in the
+continuation's BLOCK (hence the name.) The ICR continuation is very similar to
+a CPS continuation in its use, but its representation doesn't much resemble (is
+not interchangeable with) a lambda.
+
+\item[cont] A slot in the {\it node} holding the {\it continuation} which
+receives the node's value(s). Unless the node ends a {\it block}, this also
+implicitly indicates which node should be evaluated next.
+
+\item[cost] Approximations of the run-time costs of operations are widely used
+in the back end. By convention, the unit is generally machine cycles, but the
+values are only used for comparison between alternatives. For example, the
+VOP cost is used to determine the preferred order in which to try possible
+implementations.
+
+\item[CSP, CFP] See {\it control stack pointer} and {\it control frame
+pointer}.
+
+\item[Control stack] The main call stack, which holds function stack frames.
+All words on the control stack are tagged {\it descriptors}. In all ports done
+so far, the control stack grows from low memory to high memory. The most
+recent call frames are considered to be ``on top'' of earlier call frames.
+
+\item[Control stack pointer] The allocation pointer for the {\it control
+stack}. Generally this points to the first free word at the top of the stack.
+
+\item[Control frame pointer] The pointer to the base of the {\it control stack}
+frame for a particular function invocation. The CFP for the running function
+must be in a register.
+
+\item[Number stack] The auxiliary stack used to hold any {\it non-descriptor}
+(untagged) objects. This is generally the same as the C call stack, and thus
+typically grows down.
+
+\item[Number stack pointer] The allocation pointer for the {\it number stack}.
+This is typically the C stack pointer, and is thus kept in a register.
+
+\item[NSP, NFP] See {\it number stack pointer}, {\it number frame pointer}.
+
+\item[Number frame pointer] The pointer to the base of the {\it number stack}
+frame for a particular function invocation. Functions that don't use the
+number stack won't have an NFP, but if an NFP is allocated, it is always
+allocated in a particular register. If there is no variable-size data on the
+number stack, then the NFP will generally be identical to the NSP.
+
+\item[Lisp return address] The name of the {\it descriptor} encoding the
+"return pc" for a function call.
+
+\item[LRA] See {\it lisp return address}. Also, the name of the register where
+the LRA is passed.
+
+
+\item[Code pointer] A pointer to the header of a code object. The code pointer
+for the currently running function is stored in the {\tt code} register.
+
+\item[Interior pointer] A pointer into the inside of some heap-allocated
+object. Interior pointers confuse the garbage collector, so their use is
+highly constrained. Typically there is a single register dedicated to holding
+interior pointers.
+
+\item[dest]
+A slot in the {\it continuation} which points the the node that receives this
+value. Null if this value is not received by anyone.
+
+\item[DFN, DFO] See {\it Depth First Number}, {\it Depth First Order}.
+
+\item[Depth first number] Blocks are numbered according to their appearance in
+the depth-first ordering (the {\tt block-number} slot.) The numbering actually
+increases from the component tail, so earlier blocks have larger numbers.
+
+\item[Depth first order] This is a linearization of the flow graph, obtained by
+a depth-first walk. Iterative flow analysis algorithms work better when blocks
+are processed in DFO (or reverse DFO.)
+
+
+\item[Object] In low-level design discussions, an object is one of the
+following:
+\begin{itemize}
+\item a single word containing immediate data (characters, fixnums, etc)
+\item a single word pointing to an object (structures, conses, etc.)
+\end{itemize}
+These are tagged with three low-tag bits as described in the section
+\ref{tagging} This is synonymous with {\it descriptor}.
+In other parts of the documentation, may be used more loosely to refer to a
+{\it lisp object}.
+
+\item[Lisp object]
+A Lisp object is a high-level object discussed as a data type in the Common
+Lisp definition.
+
+\item[Data-block]
+A data-block is a dual-word aligned block of memory that either manifests a
+Lisp object (vectors, code, symbols, etc.) or helps manage a Lisp object on
+the heap (array header, function header, etc.).
+
+\item[Descriptor]
+A descriptor is a tagged, single-word object. It either contains immediate
+data or a pointer to data. This is synonymous with {\it object}. Storage
+locations that must contain descriptors are referred to as descriptor
+locations.
+
+\item[Pointer descriptor]
+A descriptor that points to a {\it data block} in memory (i.e. not an immediate
+object.)
+
+\item[Immediate descriptor]
+A descriptor that encodes the object value in the descriptor itself; used for
+characters, fixnums, etc.
+
+\item[Word]
+A word is a 32-bit quantity.
+
+\item[Non-descriptor]
+Any chunk of bits that isn't a valid tagged descriptor. For example, a
+double-float on the number stack. Storage locations that are not scanned by
+the garbage collector (and thus cannot contain {\it pointer descriptors}) are
+called non-descriptor locations. {\it Immediate descriptors} can be stored in
+non-descriptor locations.
+
+
+\item[Entry point] An entry point is a function that may be subject to
+``unpredictable'' control transfers. All entry points are linked to the root
+of the flow graph (the component head.) The only functions that aren't entry
+points are {\it let} functions. When complex lambda-list syntax is used,
+multiple entry points may be created for a single lisp-level function.
+See {\it external entry point}.
+
+\item[External entry point] A function that serves as a ``trampoline'' to
+intercept function calls coming in from outside of the component. The XEP does
+argument syntax and type checking, and may also translate the arguments and
+return values for a locally specialized calling calling convention.
+
+\item[XEP] An {\it external entry point}.
+
+\item[lexical environment] A lexical environment is a structure that is used
+during VMR conversion to represent all lexically scoped bindings (variables,
+functions, declarations, etc.) Each {\tt node} is annotated with its lexical
+environment, primarily for use by the debugger and other user interfaces. This
+structure is also the environment object passed to {\tt macroexpand}.
+
+\item[environment] The environment is part of the ICR, created during
+environment analysis. Environment analysis apportions code to disjoint
+environments, with all code in the same environment sharing the same stack
+frame. Each environment has a ``{\it real}'' function that allocates it, and
+some collection {\tt let} functions. Although environment analysis is the
+last ICR phase, in earlier phases, code is sometimes said to be ``in the
+same/different environment(s)''. This means that the code will definitely be
+in the same environment (because it is in the same real function), or that is
+might not be in the same environment, because it is not in the same function.
+
+\item[fixup] Some sort of back-patching annotation. The main sort encountered
+are load-time {\it assembler fixups}, which are a linkage annotation mechanism.
+
+\item[flow graph] A flow graph is a directed graph of basic blocks, where each
+arc represents a possible control transfer. The flow graph is the basic data
+structure used to represent code, and provides direct support for data flow
+analysis. See component and ICR.
+
+\item[foldable] An attribute of {\it known functions}. A function is foldable
+if calls may be constant folded whenever the arguments are compile-time
+constant. Generally this means that it is a pure function with no side
+effects.
+
+
+FSC
+full call
+function attribute
+function
+ "real" (allocates environment)
+ meaning function-entry
+ more vague (any lambda?)
+funny function
+GEN (kill and...)
+global TN, conflicts, preference
+GTN (number)
+IR ICR VMR ICR conversion, VMR conversion (translation)
+inline expansion, call
+kill (to make dead)
+known function
+LAMBDA
+leaf
+let call
+lifetime analysis, live (tn, variable)
+load tn
+LOCS (passing, return locations)
+local call
+local TN, conflicts, (or just used in one block)
+location (selection)
+LTN (number)
+main entry
+mess-up (for cleanup)
+more arg (entry)
+MV
+non-local exit
+non-packed SC, TN
+non-set variable
+operand (to vop)
+optimizer (in icr optimize)
+optional-dispatch
+pack, packing, packed
+pass (in a transform)
+passing
+ locations (value)
+ conventions (known, unknown)
+policy (safe, fast, small, ...)
+predecessor block
+primitive-type
+reaching definition
+REF
+representation
+ selection
+ for value
+result continuation (for function)
+result type assertion (for template) (or is it restriction)
+restrict
+ a TN to finite SBs
+ a template operand to a primitive type (boxed...)
+ a tn-ref to particular SCs
+
+return (node, vops)
+safe, safety
+saving (of registers, costs)
+SB
+SC (restriction)
+semi-inline
+side-effect
+ in ICR
+ in VMR
+sparse set
+splitting (of VMR blocks)
+SSET
+SUBPRIMITIVE
+successor block
+tail recursion
+ tail recursive
+ tail recursive loop
+ user tail recursion
+
+template
+TN
+TNBIND
+TN-REF
+transform (source, ICR)
+type
+ assertion
+ inference
+ top-down, bottom-up
+ assertion propagation
+ derived, asserted
+ descriptor, specifier, intersection, union, member type
+ check
+type-check (in continuation)
+UNBOXED (boxed) descriptor
+unknown values continuation
+unset variable
+unwind-block, unwinding
+used value (dest)
+value passing
+VAR
+VM
+VOP
+XEP
+
+\end{description}
--- /dev/null
+\chapter{User Interface}
+
+\section{Error Message Utilities}
+
+\section{Source Paths}
+
--- /dev/null
+
+\f
+;;;; Terminology.
+
+OBJECT
+ An object is one of the following:
+ a single word containing immediate data (characters, fixnums, etc)
+ a single word pointing to an object (structures, conses, etc.)
+ These are tagged with three low-tag bits as described in the section
+ "Tagging". This is synonymous with DESCRIPTOR.
+
+LISP OBJECT
+ A Lisp object is a high-level object discussed as a data type in Common
+ Lisp: The Language.
+
+DATA-BLOCK
+ A data-block is a dual-word aligned block of memory that either manifests a
+ Lisp object (vectors, code, symbols, etc.) or helps manage a Lisp object on
+ the heap (array header, function header, etc.).
+
+DESCRIPTOR
+ A descriptor is a tagged, single-word object. It either contains immediate
+ data or a pointer to data. This is synonymous with OBJECT.
+
+WORD
+ A word is a 32-bit quantity.
+
+
+\f
+;;;; Tagging.
+
+The following is a key of the three bit low-tagging scheme:
+ 000 even fixnum
+ 001 function pointer
+ 010 other-immediate (header-words, characters, symbol-value trap value, etc.)
+ 011 list pointer
+ 100 odd fixnum
+ 101 structure pointer
+ 110 unused
+ 111 other-pointer to data-blocks (other than conses, structures,
+ and functions)
+
+This taging scheme forces a dual-word alignment of data-blocks on the heap, but
+this can be pretty negligible:
+ RATIOS and COMPLEX must have a header-word anyway since they are not a
+ major type. This wastes one word for these infrequent data-blocks since
+ they require two words for the data.
+ BIGNUMS must have a header-word and probably contain only one other word
+ anyway, so we probably don't waste any words here. Most bignums just
+ barely overflow fixnums, that is by a bit or two.
+ Single and double FLOATS?
+ no waste
+ one word wasted
+ SYMBOLS are dual-word aligned with the header-word.
+ Everything else is vector-like including code, so these probably take up
+ so many words that one extra one doesn't matter.
+
+
+\f
+;;;; GC Comments.
+
+Data-Blocks comprise only descriptors, or they contain immediate data and raw
+bits interpreted by the system. GC must skip the latter when scanning the
+heap, so it does not look at a word of raw bits and interpret it as a pointer
+descriptor. These data-blocks require headers for GC as well as for operations
+that need to know how to interpret the raw bits. When GC is scanning, and it
+sees a header-word, then it can determine how to skip that data-block if
+necessary. Header-Words are tagged as other-immediates. See the sections
+"Other-Immediates" and "Data-Blocks and Header-Words" for comments on
+distinguishing header-words from other-immediate data. This distinction is
+necessary since we scan through data-blocks containing only descriptors just as
+we scan through the heap looking for header-words introducing data-blocks.
+
+Data-Blocks containing only descriptors do not require header-words for GC
+since the entire data-block can be scanned by GC a word at a time, taking
+whatever action is necessary or appropriate for the data in that slot. For
+example, a cons is referenced by a descriptor with a specific tag, and the
+system always knows the size of this data-block. When GC encounters a pointer
+to a cons, it can transport it into the new space, and when scanning, it can
+simply scan the two words manifesting the cons interpreting each word as a
+descriptor. Actually there is no cons tag, but a list tag, so we make sure the
+cons is not nil when appropriate. A header may still be desired if the pointer
+to the data-block does not contain enough information to adequately maintain
+the data-block. An example of this is a simple-vector containing only
+descriptor slots, and we attach a header-word because the descriptor pointing
+to the vector lacks necessary information -- the type of the vector's elements,
+its length, etc.
+
+There is no need for a major tag for GC forwarding pointers. Since the tag
+bits are in the low end of the word, a range check on the start and end of old
+space tells you if you need to move the thing. This is all GC overhead.
+
+
+\f
+;;;; Structures.
+
+Structures comprise a word for each slot in the definition in addition to one
+word, a type slot which is a pointer descriptor. This points to a structure
+describing the data-block as a structure, a defstruct-descriptor object. When
+operating on a structure, doing a structure test can be done by simply checking
+the tag bits on the pointer descriptor referencing it. As described in section
+"GC Comments", data-blocks such as those representing structures may avoid
+having a header-word since they are GC-scanable without any problem. This
+saves two words for every structure instance.
+
+
+\f
+;;;; Fixnums.
+
+A fixnum has one of the following formats in 32 bits:
+ -------------------------------------------------------
+ | 30 bit 2's complement even integer | 0 0 0 |
+ -------------------------------------------------------
+or
+ -------------------------------------------------------
+ | 30 bit 2's complement odd integer | 1 0 0 |
+ -------------------------------------------------------
+
+Effectively, there is one tag for immediate integers, two zeros. This buys one
+more bit for fixnums, and now when these numbers index into simple-vectors or
+offset into memory, they point to word boundaries on 32-bit, byte-addressable
+machines. That is, no shifting need occur to use the number directly as an
+offset.
+
+This format has another advantage on byte-addressable machines when fixnums are
+offsets into vector-like data-blocks, including structures. Even though we
+previously mentioned data-blocks are dual-word aligned, most indexing and slot
+accessing is word aligned, and so are fixnums with effectively two tag bits.
+
+Two tags also allow better usage of special instructions on some machines that
+can deal with two low-tag bits but not three.
+
+Since the two bits are zeros, we avoid having to mask them off before using the
+words for arithmetic, but division and multiplication require special shifting.
+
+
+\f
+;;;; Other-immediates.
+
+An other-immediate has the following format:
+ ----------------------------------------------------------------
+ | Data (24 bits) | Type (8 bits with low-tag) | 0 1 0 |
+ ----------------------------------------------------------------
+
+The system uses eight bits of type when checking types and defining system
+constants. This allows allows for 32 distinct other-immediate objects given
+the three low-tag bits tied down.
+
+The system uses this format for characters, SYMBOL-VALUE unbound trap value,
+and header-words for data-blocks on the heap. The type codes are laid out to
+facilitate range checks for common subtypes; for example, all numbers will have
+contiguous type codes which are distinct from the contiguous array type codes.
+See section "Data-Blocks and Other-immediates Typing" for details.
+
+
+\f
+;;;; Data-Blocks and Header-Word Format.
+
+Pointers to data-blocks have the following format:
+ ----------------------------------------------------------------
+ | Dual-word address of data-block (29 bits) | 1 1 1 |
+ ----------------------------------------------------------------
+
+The word pointed to by the above descriptor is a header-word, and it has the
+same format as an other-immediate:
+ ----------------------------------------------------------------
+ | Data (24 bits) | Type (8 bits with low-tag) | 0 1 0 |
+ ----------------------------------------------------------------
+
+This is convenient for scanning the heap when GC'ing, but it does mean that
+whenever GC encounters an other-immediate word, it has to do a range check on
+the low byte to see if it is a header-word or just a character (for example).
+This is easily acceptable performance hit for scanning.
+
+The system interprets the data portion of the header-word for non-vector
+data-blocks as the word length excluding the header-word. For example, the
+data field of the header for ratio and complex numbers is two, one word each
+for the numerator and denominator or for the real and imaginary parts.
+
+For vectors and data-blocks representing Lisp objects stored like vectors, the
+system ignores the data portion of the header-word:
+ ----------------------------------------------------------------
+ | Unused Data (24 bits) | Type (8 bits with low-tag) | 0 1 0 |
+ ----------------------------------------------------------------
+ | Element Length of Vector (30 bits) | 0 0 |
+ ----------------------------------------------------------------
+
+Using a separate word allows for much larger vectors, and it allows LENGTH to
+simply access a single word without masking or shifting. Similarly, the header
+for complex arrays and vectors has a second word, following the header-word,
+the system uses for the fill pointer, so computing the length of any array is
+the same code sequence.
+
+
+\f
+;;;; Data-Blocks and Other-immediates Typing.
+
+These are the other-immediate types. We specify them including all low eight
+bits, including the other-immediate tag, so we can think of the type bits as
+one type -- not an other-immediate major type and a subtype. Also, fetching a
+byte and comparing it against a constant is more efficient than wasting even a
+small amount of time shifting out the other-immediate tag to compare against a
+five bit constant.
+
+ Number (< 30)
+00000 010 bignum 10
+00000 010 ratio 14
+00000 010 single-float 18
+00000 010 double-float 22
+00000 010 complex 26
+
+ Array (>= 30 code 86)
+ Simple-Array (>= 20 code 70)
+00000 010 simple-array 30
+ Vector (>= 34 code 82)
+00000 010 simple-string 34
+00000 010 simple-bit-vector 38
+00000 010 simple-vector 42
+00000 010 (simple-array (unsigned-byte 2) (*)) 46
+00000 010 (simple-array (unsigned-byte 4) (*)) 50
+00000 010 (simple-array (unsigned-byte 8) (*)) 54
+00000 010 (simple-array (unsigned-byte 16) (*)) 58
+00000 010 (simple-array (unsigned-byte 32) (*)) 62
+00000 010 (simple-array single-float (*)) 66
+00000 010 (simple-array double-float (*)) 70
+00000 010 complex-string 74
+00000 010 complex-bit-vector 78
+00000 010 (array * (*)) -- general complex vector. 82
+00000 010 complex-array 86
+
+00000 010 code-header-type 90
+00000 010 function-header-type 94
+00000 010 closure-header-type 98
+00000 010 funcallable-instance-header-type 102
+00000 010 unused-function-header-1-type 106
+00000 010 unused-function-header-2-type 110
+00000 010 unused-function-header-3-type 114
+00000 010 closure-function-header-type 118
+00000 010 return-pc-header-type 122
+00000 010 value-cell-header-type 126
+00000 010 symbol-header-type 130
+00000 010 base-character-type 134
+00000 010 system-area-pointer-type (header type) 138
+00000 010 unbound-marker 142
+00000 010 weak-pointer-type 146
+
+
+\f
+;;;; Strings.
+
+All strings in the system are C-null terminated. This saves copying the bytes
+when calling out to C. The only time this wastes memory is when the string
+contains a multiple of eight characters, and then the system allocates two more
+words (since Lisp objects are dual-word aligned) to hold the C-null byte.
+Since the system will make heavy use of C routines for systems calls and
+libraries that save reimplementation of higher level operating system
+functionality (such as pathname resolution or current directory computation),
+saving on copying strings for C should make C call out more efficient.
+
+The length word in a string header, see section "Data-Blocks and Header-Word
+Format", counts only the characters truly in the Common Lisp string.
+Allocation and GC will have to know to handle the extra C-null byte, and GC
+already has to deal with rounding up various objects to dual-word alignment.
+
+
+\f
+;;;; Symbols and NIL.
+
+Symbol data-block has the following format:
+ -------------------------------------------------------
+ | 5 (data-block words) | Symbol Type (8 bits) |
+ -------------------------------------------------------
+ | Value Descriptor |
+ -------------------------------------------------------
+ | Function Pointer |
+ -------------------------------------------------------
+ | Raw Function Address |
+ -------------------------------------------------------
+ | Setf Function |
+ -------------------------------------------------------
+ | Property List |
+ -------------------------------------------------------
+ | Print Name |
+ -------------------------------------------------------
+ | Package |
+ -------------------------------------------------------
+
+Most of these slots are self-explanatory given what symbols must do in Common
+Lisp, but a couple require comments. We added the Raw Function Address slot to
+speed up named call which is the most common calling convention. This is a
+non-descriptor slot, but since objects are dual word aligned, the value
+inherently has fixnum low-tag bits. The GC method for symbols must know to
+update this slot. The Setf Function slot is currently unused, but we had an
+extra slot due to adding Raw Function Address since objects must be dual-word
+aligned.
+
+The issues with nil are that we want it to act like a symbol, and we need list
+operations such as CAR and CDR to be fast on it. CMU Common Lisp solves this
+by putting nil as the first object in static space, where other global values
+reside, so it has a known address in the system:
+ ------------------------------------------------------- <-- start static
+ | 0 | space
+ -------------------------------------------------------
+ | 5 (data-block words) | Symbol Type (8 bits) |
+ ------------------------------------------------------- <-- nil
+ | Value/CAR |
+ -------------------------------------------------------
+ | Definition/CDR |
+ -------------------------------------------------------
+ | Raw Function Address |
+ -------------------------------------------------------
+ | Setf Function |
+ -------------------------------------------------------
+ | Property List |
+ -------------------------------------------------------
+ | Print Name |
+ -------------------------------------------------------
+ | Package |
+ -------------------------------------------------------
+ | ... |
+ -------------------------------------------------------
+In addition, we make the list typed pointer to nil actually point past the
+header word of the nil symbol data-block. This has usefulness explained below.
+The value and definition of nil are nil. Therefore, any reference to nil used
+as a list has quick list type checking, and CAR and CDR can go right through
+the first and second words as if nil were a cons object.
+
+When there is a reference to nil used as a symbol, the system adds offsets to
+the address the same as it does for any symbol. This works due to a
+combination of nil pointing past the symbol header-word and the chosen list and
+other-pointer type tags. The list type tag is four less than the other-pointer
+type tag, but nil points four additional bytes into its symbol data-block.
+
+
+\f
+;;;; Array Headers.
+
+The array-header data-block has the following format:
+ ----------------------------------------------------------------
+ | Header Len (24 bits) = Array Rank +5 | Array Type (8 bits) |
+ ----------------------------------------------------------------
+ | Fill Pointer (30 bits) | 0 0 |
+ ----------------------------------------------------------------
+ | Available Elements (30 bits) | 0 0 |
+ ----------------------------------------------------------------
+ | Data Vector (29 bits) | 1 1 1 |
+ ----------------------------------------------------------------
+ | Displacement (30 bits) | 0 0 |
+ ----------------------------------------------------------------
+ | Displacedp (29 bits) -- t or nil | 1 1 1 |
+ ----------------------------------------------------------------
+ | Range of First Index (30 bits) | 0 0 |
+ ----------------------------------------------------------------
+ .
+ .
+ .
+
+The array type in the header-word is one of the eight-bit patterns from section
+"Data-Blocks and Other-immediates Typing", indicating that this is a complex
+string, complex vector, complex bit-vector, or a multi-dimensional array. The
+data portion of the other-immediate word is the length of the array header
+data-block. Due to its format, its length is always five greater than the
+array's number of dimensions. The following words have the following
+interpretations and types:
+ Fill Pointer
+ This is a fixnum indicating the number of elements in the data vector
+ actually in use. This is the logical length of the array, and it is
+ typically the same value as the next slot. This is the second word, so
+ LENGTH of any array, with or without an array header, is just four bytes
+ off the pointer to it.
+ Available Elements
+ This is a fixnum indicating the number of elements for which there is
+ space in the data vector. This is greater than or equal to the logical
+ length of the array when it is a vector having a fill pointer.
+ Data Vector
+ This is a pointer descriptor referencing the actual data of the array.
+ This a data-block whose first word is a header-word with an array type as
+ described in sections "Data-Blocks and Header-Word Format" and
+ "Data-Blocks and Other-immediates Typing"
+ Displacement
+ This is a fixnum added to the computed row-major index for any array.
+ This is typically zero.
+ Displacedp
+ This is either t or nil. This is separate from the displacement slot, so
+ most array accesses can simply add in the displacement slot. The rare
+ need to know if an array is displaced costs one extra word in array
+ headers which probably aren't very frequent anyway.
+ Range of First Index
+ This is a fixnum indicating the number of elements in the first dimension
+ of the array. Legal index values are zero to one less than this number
+ inclusively. IF the array is zero-dimensional, this slot is
+ non-existent.
+ ... (remaining slots)
+ There is an additional slot in the header for each dimension of the
+ array. These are the same as the Range of First Index slot.
+
+
+\f
+;;;; Bignums.
+
+Bignum data-blocks have the following format:
+ -------------------------------------------------------
+ | Length (24 bits) | Bignum Type (8 bits) |
+ -------------------------------------------------------
+ | least significant bits |
+ -------------------------------------------------------
+ .
+ .
+ .
+
+The elements contain the two's complement representation of the integer with
+the least significant bits in the first element or closer to the header. The
+sign information is in the high end of the last element.
+
+
+
+\f
+;;;; Code Data-Blocks.
+
+A code data-block is the run-time representation of a "component". A component
+is a connected portion of a program's flow graph that is compiled as a single
+unit, and it contains code for many functions. Some of these functions are
+callable from outside of the component, and these are termed "entry points".
+
+Each entry point has an associated user-visible function data-block (of type
+FUNCTION). The full call convention provides for calling an entry point
+specified by a function object.
+
+Although all of the function data-blocks for a component's entry points appear
+to the user as distinct objects, the system keeps all of the code in a single
+code data-block. The user-visible function object is actually a pointer into
+the middle of a code data-block. This allows any control transfer within a
+component to be done using a relative branch.
+
+Besides a function object, there are other kinds of references into the middle
+of a code data-block. Control transfer into a function also occurs at the
+return-PC for a call. The system represents a return-PC somewhat similarly to
+a function, so GC can also recognize a return-PC as a reference to a code
+data-block.
+
+It is incorrect to think of a code data-block as a concatenation of "function
+data-blocks". Code for a function is not emitted in any particular order with
+respect to that function's function-header (if any). The code following a
+function-header may only be a branch to some other location where the
+function's "real" definition is.
+
+
+The following are the three kinds of pointers to code data-blocks:
+ Code pointer (labeled A below):
+ A code pointer is a descriptor, with other-pointer low-tag bits, pointing
+ to the beginning of the code data-block. The code pointer for the
+ currently running function is always kept in a register (CODE). In
+ addition to allowing loading of non-immediate constants, this also serves
+ to represent the currently running function to the debugger.
+ Return-PC (labeled B below):
+ The return-PC is a descriptor, with other-pointer low-tag bits, pointing
+ to a location for a function call. Note that this location contains no
+ descriptors other than the one word of immediate data, so GC can treat
+ return-PC locations the same as instructions.
+ Function (labeled C below):
+ A function is a descriptor, with function low-tag bits, that is user
+ callable. When a function header is referenced from a closure or from
+ the function header's self-pointer, the pointer has other-pointer low-tag
+ bits, instead of function low-tag bits. This ensures that the internal
+ function data-block associated with a closure appears to be uncallable
+ (although users should never see such an object anyway).
+
+ Information about functions that is only useful for entry points is kept
+ in some descriptors following the function's self-pointer descriptor.
+ All of these together with the function's header-word are known as the
+ "function header". GC must be able to locate the function header. We
+ provide for this by chaining together the function headers in a NIL
+ terminated list kept in a known slot in the code data-block.
+
+
+A code data-block has the following format:
+ ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ <-- A
+ | Header-Word count (24 bits) | %Code-Type (8 bits) |
+ ----------------------------------------------------------------
+ | Number of code words (fixnum tag) |
+ ----------------------------------------------------------------
+ | Pointer to first function header (other-pointer tag) |
+ ----------------------------------------------------------------
+ | Debug information (structure tag) |
+ ----------------------------------------------------------------
+ | First constant (a descriptor) |
+ ----------------------------------------------------------------
+ | ... |
+ ----------------------------------------------------------------
+ | Last constant (and last word of code header) |
+ ----------------------------------------------------------------
+ | Some instructions (non-descriptor) |
+ ----------------------------------------------------------------
+ | (pad to dual-word boundary if necessary) |
+ ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ <-- B
+ | Word offset from code header (24) | %Return-PC-Type (8) |
+ ----------------------------------------------------------------
+ | First instruction after return |
+ ----------------------------------------------------------------
+ | ... more code and return-PC header-words |
+ ----------------------------------------------------------------
+ | (pad to dual-word boundary if necessary) |
+ ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ <-- C
+ | Offset from code header (24) | %Function-Header-Type (8) |
+ ----------------------------------------------------------------
+ | Self-pointer back to previous word (with other-pointer tag) |
+ ----------------------------------------------------------------
+ | Pointer to next function (other-pointer low-tag) or NIL |
+ ----------------------------------------------------------------
+ | Function name (a string or a symbol) |
+ ----------------------------------------------------------------
+ | Function debug arglist (a string) |
+ ----------------------------------------------------------------
+ | Function type (a list-style function type specifier) |
+ ----------------------------------------------------------------
+ | Start of instructions for function (non-descriptor) |
+ ----------------------------------------------------------------
+ | More function headers and instructions and return PCs, |
+ | until we reach the total size of header-words + code |
+ | words. |
+ ----------------------------------------------------------------
+
+
+The following are detailed slot descriptions:
+ Code data-block header-word:
+ The immediate data in the code data-block's header-word is the number of
+ leading descriptors in the code data-block, the fixed overhead words plus
+ the number of constants. The first non-descriptor word, some code,
+ appears at this word offset from the header.
+ Number of code words:
+ The total number of non-header-words in the code data-block. The total
+ word size of the code data-block is the sum of this slot and the
+ immediate header-word data of the previous slot. The system accesses
+ this slot with the system constant, %Code-Code-Size-Slot, offset from the
+ header-word.
+ Pointer to first function header:
+ A NIL-terminated list of the function headers for all entry points to
+ this component. The system accesses this slot with the system constant,
+ %Code-Entry-Points-Slot, offset from the header-word.
+ Debug information:
+ The DEBUG-INFO structure describing this component. All information that
+ the debugger wants to get from a running function is kept in this
+ structure. Since there are many functions, the current PC is used to
+ locate the appropriate debug information. The system keeps the debug
+ information separate from the function data-block, since the currently
+ running function may not be an entry point. There is no way to recover
+ the function object for the currently running function, since this
+ data-block may not exist. The system accesses this slot with the system
+ constant, %Code-Debug-Info-Slot, offset from the header-word.
+ First constant ... last constant:
+ These are the constants referenced by the component, if there are any.
+ The system accesses the first constant slot with the system constant,
+ %Code-Constants-Offset, offset from the header-word.
+
+ Return-PC header word:
+ The immediate header-word data is the word offset from the enclosing code
+ data-block's header-word to this word. This allows GC and the debugger
+ to easily recover the code data-block from a return-PC. The code at the
+ return point restores the current code pointer using a subtract immediate
+ of the offset, which is known at compile time.
+
+ Function entry point header-word:
+ The immediate header-word data is the word offset from the enclosing code
+ data-block's header-word to this word. This is the same as for the
+ retrun-PC header-word.
+ Self-pointer back to header-word:
+ In a non-closure function, this self-pointer to the previous header-word
+ allows the call sequence to always indirect through the second word in a
+ user callable function. See section "Closure Format". With a closure,
+ indirecting through the second word gets you a function header-word. The
+ system ignores this slot in the function header for a closure, since it
+ has already indirected once, and this slot could be some random thing
+ that causes an error if you jump to it. This pointer has an
+ other-pointer tag instead of a function pointer tag, indicating it is not
+ a user callable Lisp object. The system accesses this slot with the
+ system constant, %Function-Code-Slot, offset from the function
+ header-word.
+ Pointer to next function:
+ This is the next link in the thread of entry point functions found in
+ this component. This value is NIL when the current header is the last
+ entry point in the component. The system accesses this slot with the
+ system constant, %Function-Header-Next-Slot, offset from the function
+ header-word.
+ Function name:
+ This function's name (for printing). If the user defined this function
+ with DEFUN, then this is the defined symbol, otherwise it is a
+ descriptive string. The system accesses this slot with the system
+ constant, %Function-Header-Name-Slot, offset from the function
+ header-word.
+ Function debug arglist:
+ A printed string representing the function's argument list, for human
+ readability. If it is a macroexpansion function, then this is the
+ original DEFMACRO arglist, not the actual expander function arglist. The
+ system accesses this slot with the system constant,
+ %Function-Header-Debug-Arglist-Slot, offset from the function
+ header-word.
+ Function type:
+ A list-style function type specifier representing the argument signature
+ and return types for this function. For example,
+ (FUNCTION (FIXNUM FIXNUM FIXNUM) FIXNUM)
+ or
+ (FUNCTION (STRING &KEY (:START UNSIGNED-BYTE)) STRING)
+ This information is intended for machine readablilty, such as by the
+ compiler. The system accesses this slot with the system constant,
+ %Function-Header-Type-Slot, offset from the function header-word.
+
+
+\f
+;;;; Closure Format.
+
+A closure data-block has the following format:
+ ----------------------------------------------------------------
+ | Word size (24 bits) | %Closure-Type (8 bits) |
+ ----------------------------------------------------------------
+ | Pointer to function header (other-pointer low-tag) |
+ ----------------------------------------------------------------
+ | . |
+ | Environment information |
+ | . |
+ ----------------------------------------------------------------
+
+
+A closure descriptor has function low-tag bits. This means that a descriptor
+with function low-tag bits may point to either a function header or to a
+closure. The idea is that any callable Lisp object has function low-tag bits.
+Insofar as call is concerned, we make the format of closures and non-closure
+functions compatible. This is the reason for the self-pointer in a function
+header. Whenever you have a callable object, you just jump through the second
+word, offset some bytes, and go.
+
+
+\f
+;;;; Function call.
+
+Due to alignment requirements and low-tag codes, it is not possible to use a
+hardware call instruction to compute the return-PC. Instead the return-PC
+for a call is computed by doing an add-immediate to the start of the code
+data-block.
+
+An advantage of using a single data-block to represent both the descriptor and
+non-descriptor parts of a function is that both can be represented by a
+single pointer. This reduces the number of memory accesses that have to be
+done in a full call. For example, since the constant pool is implicit in a
+return-PC, a call need only save the return-PC, rather than saving both the
+return PC and the constant pool.
+
+
+\f
+;;;; Memory Layout.
+
+CMU Common Lisp has four spaces, read-only, static, dynamic-0, and dynamic-1.
+Read-only contains objects that the system never modifies, moves, or reclaims.
+Static space contains some global objects necessary for the system's runtime or
+performance (since they are located at a known offset at a know address), and
+the system never moves or reclaims these. However, GC does need to scan static
+space for references to moved objects. Dynamic-0 and dynamic-1 are the two
+heap areas for stop-and-copy GC algorithms.
+
+What global objects are at the head of static space???
+ NIL
+ eval::*top-of-stack*
+ lisp::*current-catch-block*
+ lisp::*current-unwind-protect*
+ FLAGS (RT only)
+ BSP (RT only)
+ HEAP (RT only)
+
+In addition to the above spaces, the system has a control stack, binding stack,
+and a number stack. The binding stack contains pairs of descriptors, a symbol
+and its previous value. The number stack is the same as the C stack, and the
+system uses it for non-Lisp objects such as raw system pointers, saving
+non-Lisp registers, parts of bignum computations, etc.
+
+
+\f
+;;;; System Pointers.
+
+The system pointers reference raw allocated memory, data returned by foreign
+function calls, etc. The system uses these when you need a pointer to a
+non-Lisp block of memory, using an other-pointer. This provides the greatest
+flexibility by relieving contraints placed by having more direct references
+that require descriptor type tags.
+
+A system area pointer data-block has the following format:
+ -------------------------------------------------------
+ | 1 (data-block words) | SAP Type (8 bits) |
+ -------------------------------------------------------
+ | system area pointer |
+ -------------------------------------------------------
+
+"SAP" means "system area pointer", and much of our code contains this naming
+scheme. We don't currently restrict system pointers to one area of memory, but
+if they do point onto the heap, it is up to the user to prevent being screwed
+by GC or whatever.
--- /dev/null
+% -*- Dictionary: design; Package: C -*-
+
+May be worth having a byte-code representation for interpreted code. This way,
+an entire system could be compiled into byte-code for debugging (the
+"check-out" compiler?).
+
+Given our current inclination for using a stack machine to interpret IR1, it
+would be straightforward to layer a byte-code interpreter on top of this.
+
+
+Interpreter:
+
+Instead of having no interpreter, or a more-or-less conventional interpreter,
+or byte-code interpreter, how about directly executing IR1?
+
+We run through the IR1 passes, possibly skipping optional ones, until we get
+through environment analysis. Then we run a post-pass that annotates IR1 with
+information about where values are kept, i.e. the stack slot.
+
+We can lazily convert functions by having FUNCTION make an interpreted function
+object that holds the code (really a closure over the interpreter). The first
+time that we try to call the function, we do the conversion and processing.
+Also, we can easily keep track of which interpreted functions we have expanded
+macros in, so that macro redefinition automatically invalidates the old
+expansion, causing lazy reconversion.
+
+Probably the interpreter will want to represent MVs by a recognizable structure
+that is always heap-allocated. This way, we can punt the stack issues involved
+in trying to spread MVs. So a continuation value can always be kept in a
+single cell.
+
+The compiler can have some special frobs for making the interpreter efficient,
+such as a call operation that extracts arguments from the stack
+slots designated by a continuation list. Perhaps
+ (values-mapcar fun . lists)
+<==>
+ (values-list (mapcar fun . lists))
+This would be used with MV-CALL.
+
+
+This scheme seems to provide nearly all of the advantages of both the compiler
+and conventional interpretation. The only significant disadvantage with
+respect to a conventional interpreter is that there is the one-time overhead of
+conversion, but doing this lazily should make this quite acceptable.
+
+With respect to a conventional interpreter, we have major advantages:
+ + Full syntax checking: safety comparable to compiled code.
+ + Semantics similar to compiled code due to code sharing. Similar diagnostic
+ messages, etc. Reduction of error-prone code duplication.
+ + Potential for full type checking according to declarations (would require
+ running IR1 optimize?)
+ + Simplifies debugger interface, since interpreted code can look more like
+ compiled code: source paths, edit definition, etc.
+
+For all non-run-time symbol annotations (anything other than SYMBOL-FUNCTION
+and SYMBOL-VALUE), we use the compiler's global database. MACRO-FUNCTION will
+use INFO, rather than vice-versa.
+
+When doing the IR1 phases for the interpreter, we probably want to suppress
+optimizations that change user-visible function calls:
+ -- Don't do local call conversion of any named functions (even lexical ones).
+ This is so that a call will appear on the stack that looks like the call in
+ the original source. The keyword and optional argument transformations
+ done by local call mangle things quite a bit. Also, note local-call
+ converting prevents unreferenced arguments from being deleted, which is
+ another non-obvious transformation.
+ -- Don't run source-transforms, IR1 transforms and IR1 optimizers. This way,
+ TRACE and BACKTRACE will show calls with the original arguments, rather
+ than the "optimized" form, etc. Also, for the interpreter it will
+ actually be faster to call the original function (which is compiled) than
+ to "inline expand" it. Also, this allows implementation-dependent
+ transforms to expand into %PRIMITIVE uses.
+
+There are some problems with stepping, due to our non-syntactic IR1
+representation. The source path information is the key that makes this
+conceivable. We can skip over the stepping of a subform by quietly evaluating
+nodes whose source path lies within the form being skipped.
+
+One problem with determining what value has been returned by a form. With a
+function call, it is theoretically possible to precisely determine this, since
+if we complete evaluation of the arguments, then we arrive at the Combination
+node whose value is synonymous with the value of the form. We can even detect
+this case, since the Node-Source will be EQ to the form. And we can also
+detect when we unwind out of the evaluation, since we will leave the form
+without having ever reached this node.
+
+But with macros and special-forms, there is no node whose value is the value of
+the form, and no node whose source is the macro call or special form. We can
+still detect when we leave the form, but we can't be sure whether this was a
+normal evaluation result or an explicit RETURN-FROM.
+
+But does this really matter? It seems that we can print the value returned (if
+any), then just print the next form to step. In the rare case where we did
+unwind, the user should be able to figure it out.
+
+[We can look at this as a side-effect of CPS: there isn't any difference
+between a "normal" return and a non-local one.]
+
+[Note that in any control transfer (normal or otherwise), the stepper may need
+to unwind out of an arbitrary number of levels of stepping. This is because a
+form in a TR position may yield its to a node arbitrarily far our.]
+
+Another problem is with deciding what form is being stepped. When we start
+evaluating a node, we dive into code that is nested somewhere down inside that
+form. So we actually have to do a loop of asking questions before we do any
+evaluation. But what do we ask about?
+
+If we ask about the outermost enclosing form that is a subform of the the last
+form that the user said to execute, then we might offer a form that isn't
+really evaluated, such as a LET binding list.
+
+But once again, is this really a problem? It is certainly different from a
+conventional stepper, but a pretty good argument could be made that it is
+superior. Haven't you ever wanted to skip the evaluation of all the
+LET bindings, but not the body? Wouldn't it be useful to be able to skip the
+DO step forms?
+
+All of this assumes that nobody ever wants to step through the guts of a
+macroexpansion. This seems reasonable, since steppers are for weenies, and
+weenies don't define macros (hence don't debug them). But there are probably
+some weenies who don't know that they shouldn't be writing macros.
+
+We could handle this by finding the "source paths" in the expansion of each
+macro by sticking some special frob in the source path marking the place where
+the expansion happened. When we hit code again that is in the source, then we
+revert to the normal source path. Something along these lines might be a good
+idea anyway (for compiler error messages, for example).
+
+The source path hack isn't guaranteed to work quite so well in generated code,
+though, since macros return stuff that isn't freshly consed. But we could
+probably arrange to win as long as any given expansion doesn't return two EQ
+forms.
+
+It might be nice to have a command that skipped stepping of the form, but
+printed the results of each outermost enclosed evaluated subform, i.e. if you
+used this on the DO step-list, it would print the result of each new-value
+form. I think this is implementable. I guess what you would do is print each
+value delivered to a DEST whose source form is the current or an enclosing
+form. Along with the value, you would print the source form for the node that
+is computing the value.
+
+The stepper can also have a "back" command that "unskips" or "unsteps". This
+would allow the evaluation of forms that are pure (modulo lexical variable
+setting) to be undone. This is useful, since in stepping it is common that you
+skip a form that you shouldn't have, or get confused and want to restart at
+some earlier point.
+
+What we would do is remember the current node and the values of all local
+variables. heap before doing each step or skip action. We can then back up
+the state of all lexical variables and the "program counter". To make this
+work right with set closure variables, we would copy the cell's value, rather
+than the value cell itself.
+
+[To be fair, note that this could easily be done with our current interpreter:
+the stepper could copy the environment alists.]
+
+We can't back up the "program counter" when a control transfer leaves the
+current function, since this state is implicitly represented in the
+interpreter's state, and is discarded when we exit. We probably want to ask
+for confirmation before leaving the function to give users a chance to "unskip"
+the forms in a TR position.
+
+Another question is whether the conventional stepper is really a good thing to
+imitate... How about an editor-based mouse-driven interface? Instead of
+"skipping" and "stepping", you would just designate the next form that you
+wanted to stop at. Instead of displaying return values, you replace the source
+text with the printed representation of the value.
+
+It would show the "program counter" by highlighting the *innermost* form that
+we are about to evaluate, i.e. the source form for the node that we are stopped
+at. It would probably also be useful to display the start of the form that was
+used to designate the next stopping point, although I guess this could be
+implied by the mouse position.
+
+
+Such an interface would be a little harder to implement than a dumb stepper,
+but it would be much easier to use. [It would be impossible for an evalhook
+stepper to do this.]
+
+
+%PRIMITIVE usage:
+
+Note: %PRIMITIVE can only be used in compiled code. It is a trapdoor into the
+compiler, not a general syntax for accessing "sub-primitives". It's main use
+is in implementation-dependent compiler transforms. It saves us the effort of
+defining a "phony function" (that is not really defined), and also allows
+direct communication with the code generator through codegen-info arguments.
+
+Some primitives may be exported from the VM so that %PRIMITIVE can be used to
+make it explicit that an escape routine or interpreter stub is assuming an
+operation is implemented by the compiler.
--- /dev/null
+\chapter{Memory Management}
+\section{Stacks and Globals}
+\section{Heap Layout}
+\section{Garbage Collection}
+
+\chapter{Interface to C and Assembler}
+
+\chapter{Low-level debugging}
+
+\chapter{Core File Format}
--- /dev/null
+% -*- Dictionary: design -*-
+
+\f
+\chapter{Virtual Machine Representation Introduction}
+
+\f
+\chapter{Global TN assignment}
+
+[\#\#\# Rename this phase so as not to be confused with the local/global TN
+representation.]
+
+The basic mechanism for closing over values is to pass the values as additional
+implicit arguments in the function call. This technique is only applicable
+when:
+ -- the calling function knows which values the called function wants to close
+ over, and
+ -- the values to be closed over are available in the calling environment.
+
+The first condition is always true of local function calls. Environment
+analysis can guarantee that the second condition holds by closing over any
+needed values in the calling environment.
+
+If the function that closes over values may be called in an environment where
+the closed over values are not available, then we must store the values in a
+"closure" so that they are always accessible. Closures are called using the
+"full call" convention. When a closure is called, control is transferred to
+the "external entry point", which fetches the values out of the closure and
+then does a local call to the real function, passing the closure values as
+implicit arguments.
+
+In this scheme there is no such thing as a "heap closure variable" in code,
+since the closure values are moved into TNs by the external entry point. There
+is some potential for pessimization here, since we may end up moving the values
+from the closure into a stack memory location, but the advantages are also
+substantial. Simplicity is gained by always representing closure values the
+same way, and functions with closure references may still be called locally
+without allocating a closure. All the TN based VMR optimizations will apply
+to closure variables, since closure variables are represented in the same way
+as all other variables in VMR. Closure values will be allocated in registers
+where appropriate.
+
+Closures are created at the point where the function is referenced, eliminating
+the need to be able to close over closures. This lazy creation of closures has
+the additional advantage that when a closure reference is conditionally not
+done, then the closure consing will never be done at all. The corresponding
+disadvantage is that a closure over the same values may be created multiple
+times if there are multiple references. Note however, that VMR loop and common
+subexpression optimizations can eliminate redundant closure consing. In any
+case, multiple closures over the same variables doesn't seem to be that common.
+
+\#|
+Having the Tail-Info would also make return convention determination trivial.
+We could just look at the type, checking to see if it represents a fixed number
+of values. To determine if the standard return convention is necessary to
+preserve tail-recursion, we just iterate over the equivalent functions, looking
+for XEPs and uses in full calls.
+|\#
+
+The Global TN Assignment pass (GTN) can be considered a post-pass to
+environment analysis. This phase assigns the TNs used to hold local lexical
+variables and pass arguments and return values and determines the value-passing
+strategy used in local calls.
+
+To assign return locations, we look at the function's tail-set.
+
+If the result continuation for an entry point is used as the continuation for a
+full call, then we may need to constrain the continuation's values passing
+convention to the standard one. This is not necessary when the call is known
+not to be part of a tail-recursive loop (due to being a known function).
+
+Once we have figured out where we must use the standard value passing strategy,
+we can use a more flexible strategy to determine the return locations for local
+functions. We determine the possible numbers of return values from each
+function by examining the uses of all the result continuations in the
+equivalence class of the result continuation.
+
+If the tail-set type is for a fixed number of
+values, then we return that fixed number of values from all the functions whose
+result continuations are equated. If the number of values is not fixed, then
+we must use the unknown-values convention, although we are not forced to use
+the standard locations. We assign the result TNs at this time.
+
+We also use the tail-sets to see what convention we want to use. What we do is
+use the full convention for any function that has a XEP its tail-set, even if
+we aren't required to do so by a tail-recursive full call, as long as there are
+no non-tail-recursive local calls in the set. This prevents us from
+gratuitously using a non-standard convention when there is no reason to.
+
+\f
+\chapter{Local TN assignment}
+
+[Want a different name for this so as not to be confused with the different
+local/global TN representations. The really interesting stuff in this phase is
+operation selection, values representation selection, return strategy, etc.
+Maybe this phase should be conceptually lumped with GTN as "implementation
+selection", since GTN determines call strategies and locations.]
+
+\#|
+
+[\#\#\# I guess I believe that it is OK for VMR conversion to dick the ICR flow
+graph. An alternative would be to give VMR its very own flow graph, but that
+seems like overkill.
+
+In particular, it would be very nice if a TR local call looked exactly like a
+jump in VMR. This would allow loop optimizations to be done on loops written
+as recursions. In addition to making the call block transfer to the head of
+the function rather than to the return, we would also have to do something
+about skipping the part of the function prolog that moves arguments from the
+passing locations, since in a TR call they are already in the right frame.
+
+
+In addition to directly indicating whether a call should be coded with a TR
+variant, the Tail-P annotation flags non-call nodes that can directly return
+the value (an "advanced return"), rather than moving the value to the result
+continuation and jumping to the return code. Then (according to policy), we
+can decide to advance all possible returns. If all uses of the result are
+Tail-P, then LTN can annotate the result continuation as :Unused, inhibiting
+emission of the default return code.
+
+[\#\#\# But not really. Now there is a single list of templates, and a given
+template has only one policy.]
+
+In LTN, we use the :Safe template as a last resort even when the policy is
+unsafe. Note that we don't try :Fast-Safe; if this is also a good unsafe
+template, then it should have the unsafe policies explicitly specified.
+
+With a :Fast-Safe template, the result type must be proven to satisfy the
+output type assertion. This means that a fast-safe template with a fixnum
+output type doesn't need to do fixnum overflow checking. [\#\#\# Not right to
+just check against the Node-Derived-Type, since type-check intersects with
+this.]
+
+It seems that it would be useful to have a kind of template where the args must
+be checked to be fixnum, but the template checks for overflow and signals an
+error. In the case where an output assertion is present, this would generate
+better code than conditionally branching off to make a bignum, and then doing a
+type check on the result.
+
+ How do we deal with deciding whether to do a fixnum overflow check? This
+ is perhaps a more general problem with the interpretation of result type
+ restrictions in templates. It would be useful to be able to discriminate
+ between the case where the result has been proven to be a fixnum and where
+ it has simply been asserted to be so.
+
+ The semantics of result type restriction is that the result must be proven
+ to be of that type *except* for safe generators, which are assumed to
+ verify the assertion. That way "is-fixnum" case can be a fast-safe
+ generator and the "should-be-fixnum" case is a safe generator. We could
+ choose not to have a safe "should-be-fixnum" generator, and let the
+ unrestricted safe generator handle it. We would then have to do an
+ explicit type check on the result.
+
+ In other words, for all template except Safe, a type restriction on either
+ an argument or result means "this must be true; if it is not the system may
+ break." In contrast, in a Safe template, the restriction means "If this is
+ not true, I will signal an error."
+
+ Since the node-derived-type only takes into consideration stuff that can be
+ proved from the arguments, we can use the node-derived-type to select
+ fast-safe templates. With unsafe policies, we don't care, since the code
+ is supposed to be unsafe.
+
+|\#
+
+Local TN assignment (LTN) assigns all the TNs needed to represent the values of
+continuations. This pass scans over the code for the component, examining each
+continuation and its destination. A number of somewhat unrelated things are
+also done at the same time so that multiple passes aren't necessary.
+ -- Determine the Primitive-Type for each continuation value and assigns TNs
+ to hold the values.
+ -- Use policy information to determine the implementation strategy for each
+ call to a known function.
+ -- Clear the type-check flags in continuations whose destinations have safe
+ implementations.
+ -- Determine the value-passing strategy for each continuation: known or
+ unknown.
+ -- Note usage of unknown-values continuations so that stack analysis can tell
+ when stack values must be discarded.
+
+If safety is more important that speed and space, then we consider generating
+type checks on the values of nodes whose CONT has the Type-Check flag set. If
+the destinatation for the continuation value is safe, then we don't need to do
+a check. We assume that all full calls are safe, and use the template
+information to determine whether inline operations are safe.
+
+This phase is where compiler policy switches have most of their effect. The
+speed/space/safety tradeoff can determine which of a number of coding
+strategies are used. It is important to make the policy choice in VMR
+conversion rather than in code generation because the cost and storage
+requirement information which drives TNBIND will depend strongly on what actual
+VOP is chosen. In the case of +/FIXNUM, there might be three or more
+implementations, some optimized for speed, some for space, etc. Some of these
+VOPS might be open-coded and some not.
+
+We represent the implementation strategy for a call by either marking it as a
+full call or annotating it with a "template" representing the open-coding
+strategy. Templates are selected using a two-way dispatch off of operand
+primitive-types and policy. The general case of LTN is handled by the
+LTN-Annotate function in the function-info, but most functions are handled by a
+table-driven mechanism. There are four different translation policies that a
+template may have:
+\begin{description}
+\item[Safe]
+ The safest implementation; must do argument type checking.
+
+\item[Small]
+ The (unsafe) smallest implementation.
+
+\item[Fast]
+ The (unsafe) fastest implementation.
+
+\item[Fast-Safe]
+ An implementation optimized for speed, but which does any necessary
+ checks exclusive of argument type checking. Examples are array bounds
+ checks and fixnum overflow checks.
+\end{description}
+
+Usually a function will have only one or two distinct templates. Either or
+both of the safe and fast-safe templates may be omitted; if both are specified,
+then they should be distinct. If there is no safe template and our policy is
+safe, then we do a full call.
+
+We use four different coding strategies, depending on the policy:
+\begin{description}
+\item[Safe:] safety $>$ space $>$ speed, or
+we want to use the fast-safe template, but there isn't one.
+
+\item[Small:] space $>$ (max speed safety)
+
+\item[Fast:] speed $>$ (max space safety)
+
+\item[Fast-Safe (and type check):] safety $>$ speed $>$ space, or we want to use
+the safe template, but there isn't one.
+\end{description}
+
+``Space'' above is actually the maximum of space and cspeed, under the theory
+that less code will take less time to generate and assemble. [\#\#\# This could
+lose if the smallest case is out-of-line, and must allocate many linkage
+registers.]
+
+\f
+\chapter{Control optimization}
+
+In this phase we annotate blocks with drop-throughs. This controls how code
+generation linearizes code so that drop-throughs are used most effectively. We
+totally linearize the code here, allowing code generation to scan the blocks
+in the emit order.
+
+There are basically two aspects to this optimization:
+ 1] Dynamically reducing the number of branches taken v.s. branches not
+ taken under the assumption that branches not taken are cheaper.
+ 2] Statically minimizing the number of unconditional branches, saving space
+ and presumably time.
+
+These two goals can conflict, but if they do it seems pretty clear that the
+dynamic optimization should get preference. The main dynamic optimization is
+changing the sense of a conditional test so that the more commonly taken branch
+is the fall-through case. The problem is determining which branch is more
+commonly taken.
+
+The most clear-cut case is where one branch leads out of a loop and the other
+is within. In this case, clearly the branch within the loop should be
+preferred. The only added complication is that at some point in the loop there
+has to be a backward branch, and it is preferable for this branch to be
+conditional, since an unconditional branch is just a waste of time.
+
+In the absence of such good information, we can attempt to guess which branch
+is more popular on the basis of difference in the cost between the two cases.
+Min-max strategy suggests that we should choose the cheaper alternative, since
+the percentagewise improvement is greater when the branch overhead is
+significant with respect to the cost of the code branched to. A tractable
+approximation of this is to compare only the costs of the two blocks
+immediately branched to, since this would avoid having to do any hairy graph
+walking to find all the code for the consequent and the alternative. It might
+be worthwhile discriminating against ultra-expensive functions such as ERROR.
+
+For this to work, we have to detect when one of the options is empty. In this
+case, the next for one branch is a successor of the other branch, making the
+comparison meaningless. We use dominator information to detect this situation.
+When a branch is empty, one of the predecessors of the first block in the empty
+branch will be dominated by the first block in the other branch. In such a
+case we favor the empty branch, since that's about as cheap as you can get.
+
+Statically minimizing branches is really a much more tractable problem, but
+what literature there is makes it look hard. Clearly the thing to do is to use
+a non-optimal heuristic algorithm.
+
+A good possibility is to use an algorithm based on the depth first ordering.
+We can modify the basic DFO algorithm so that it chooses an ordering which
+favors any drop-thrus that we may choose for dynamic reasons. When we are
+walking the graph, we walk the desired drop-thru arc last, which will place it
+immediately after us in the DFO unless the arc is a retreating arc.
+
+We scan through the DFO and whenever we find a block that hasn't been done yet,
+we build a straight-line segment by setting the drop-thru to the unreached
+successor block which has the lowest DFN greater than that for the block. We
+move to the drop-thru block and repeat the process until there is no such
+block. We then go back to our original scan through the DFO, looking for the
+head of another straight-line segment.
+
+This process will automagically implement all of the dynamic optimizations
+described above as long as we favor the appropriate IF branch when creating the
+DFO. Using the DFO will prevent us from making the back branch in a loop the
+drop-thru, but we need to be clever about favoring IF branches within loops
+while computing the DFO. The IF join will be favored without any special
+effort, since we follow through the most favored path until we reach the end.
+
+This needs some knowledge about the target machine, since on most machines
+non-tail-recursive calls will use some sort of call instruction. In this case,
+the call actually wants to drop through to the return point, rather than
+dropping through to the beginning of the called function.
+
+\f
+\chapter{VMR conversion}
+
+\#|
+Single-use let var continuation substitution not really correct, since it can
+cause a spurious type error. Maybe we do want stuff to prove that an NLX can't
+happen after all. Or go back to the idea of moving a combination arg to the
+ref location, and having that use the ref cont (with its output assertion.)
+This lossage doesn't seem very likely to actually happen, though.
+[\#\#\# must-reach stuff wouldn't work quite as well as combination substitute in
+psetq, etc., since it would fail when one of the new values is random code
+(might unwind.)]
+
+Is this really a general problem with eager type checking? It seems you could
+argue that there was no type error in this code:
+ (+ :foo (throw 'up nil))
+But we would signal an error.
+
+
+Emit explicit you-lose operation when we do a move between two non-T ptypes,
+even when type checking isn't on. Can this really happen? Seems we should
+treat continuations like this as though type-check was true. Maybe LTN should
+leave type-check true in this case, even when the policy is unsafe. (Do a type
+check against NIL?)
+
+At continuation use time, we may in general have to do both a coerce-to-t and a
+type check, allocating two temporary TNs to hold the intermediate results.
+
+
+VMR Control representation:
+
+We represent all control transfer explicitly. In particular, :Conditional VOPs
+take a single Target continuation and a Not-P flag indicating whether the sense
+of the test is negated. Then an unconditional Branch VOP will be emitted
+afterward if the other path isn't a drop-through.
+
+So we linearize the code before VMR-conversion. This isn't a problem,
+since there isn't much change in control flow after VMR conversion (none until
+loop optimization requires introduction of header blocks.) It does make
+cost-based branch prediction a bit ucky, though, since we don't have any cost
+information in ICR. Actually, I guess we do have pretty good cost information
+after LTN even before VMR conversion, since the most important thing to know is
+which functions are open-coded.
+
+|\#
+
+VMR preserves the block structure of ICR, but replaces the nodes with a target
+dependent virtual machine (VM) representation. Different implementations may
+use different VMs without making major changes in the back end. The two main
+components of VMR are Temporary Names (TNs) and Virtual OPerations (VOPs). TNs
+represent the locations that hold values, and VOPs represent the operations
+performed on the values.
+
+A "primitive type" is a type meaningful at the VM level. Examples are Fixnum,
+String-Char, Short-Float. During VMR conversion we use the primitive type of
+an expression to determine both where we can store the result of the expression
+and which type-specific implementations of an operation can be applied to the
+value. [Ptype is a set of SCs == representation choices and representation
+specific operations]
+
+The VM specific definitions provide functions that do stuff like find the
+primitive type corresponding to a type and test for primitive type subtypep.
+Usually primitive types will be disjoint except for T, which represents all
+types.
+
+The primitive type T is special-cased. Not only does it overlap with all the
+other types, but it implies a descriptor ("boxed" or "pointer") representation.
+For efficiency reasons, we sometimes want to use
+alternate representations for some objects such as numbers. The majority of
+operations cannot exploit alternate representations, and would only be
+complicated if they had to be able to convert alternate representations into
+descriptors. A template can require an operand to be a descriptor by
+constraining the operand to be of type T.
+
+A TN can only represent a single value, so we bare the implementation of MVs at
+this point. When we know the number of multiple values being handled, we use
+multiple TNs to hold them. When the number of values is actually unknown, we
+use a convention that is compatible with full function call.
+
+Everything that is done is done by a VOP in VMR. Calls to simple primitive
+functions such as + and CAR are translated to VOP equivalents by a table-driven
+mechanism. This translation is specified by the particular VM definition; VMR
+conversion makes no assumptions about which operations are primitive or what
+operand types are worth special-casing. The default calling mechanisms and
+other miscellaneous builtin features are implemented using standard VOPs that
+must implemented by each VM.
+
+Type information can be forgotten after VMR conversion, since all type-specific
+operation selections have been made.
+
+Simple type checking is explicitly done using CHECK-xxx VOPs. They act like
+innocuous effectless/unaffected VOPs which return the checked thing as a
+result. This allows loop-invariant optimization and common subexpression
+elimination to remove redundant checks. All type checking is done at the time
+the continuation is used.
+
+Note that we need only check asserted types, since if type inference works, the
+derived types will also be satisfied. We can check whichever is more
+convenient, since both should be true.
+
+Constants are turned into special Constant TNs, which are wired down in a SC
+that is determined by their type. The VM definition provides a function that
+returns constant a TN to represent a Constant Leaf.
+
+Each component has a constant pool. There is a register dedicated to holding
+the constant pool for the current component. The back end allocates
+non-immediate constants in the constant pool when it discovers them during
+translation from ICR.
+
+[\#\#\# Check that we are describing what is actually implemented. But this
+really isn't very good in the presence of interesting unboxed
+representations...]
+Since LTN only deals with values from the viewpoint of the receiver, we must be
+prepared during the translation pass to do stuff to the continuation at the
+time it is used.
+ -- If a VOP yields more values than are desired, then we must create TNs to
+ hold the discarded results. An important special-case is continuations
+ whose value is discarded. These continuations won't be annotated at all.
+ In the case of a Ref, we can simply skip evaluation of the reference when
+ the continuation hasn't been annotated. Although this will eliminate
+ bogus references that for some reason weren't optimized away, the real
+ purpose is to handle deferred references.
+ -- If a VOP yields fewer values than desired, then we must default the extra
+ values to NIL.
+ -- If a continuation has its type-check flag set, then we must check the type
+ of the value before moving it into the result location. In general, this
+ requires computing the result in a temporary, and having the type-check
+ operation deliver it in the actual result location.
+ -- If the template's result type is T, then we must generate a boxed
+ temporary to compute the result in when the continuation's type isn't T.
+
+
+We may also need to do stuff to the arguments when we generate code for a
+template. If an argument continuation isn't annotated, then it must be a
+deferred reference. We use the leaf's TN instead. We may have to do any of
+the above use-time actions also. Alternatively, we could avoid hair by not
+deferring references that must be type-checked or may need to be boxed.
+
+\f
+\section{Stack analysis}
+
+Think of this as a lifetime problem: a values generator is a write and a values
+receiver is a read. We want to annotate each VMR-Block with the unknown-values
+continuations that are live at that point. If we do a control transfer to a
+place where fewer continuations are live, then we must deallocate the newly
+dead continuations.
+
+We want to convince ourselves that values deallocation based on lifetime
+analysis actually works. In particular, we need to be sure that it doesn't
+violate the required stack discipline. It is clear that it is impossible to
+deallocate the values before they become dead, since later code may decide to
+use them. So the only thing we need to ensure is that the "right" time isn't
+later than the time that the continuation becomes dead.
+
+The only reason why we couldn't deallocate continuation A as soon as it becomes
+dead would be that there is another continuation B on top of it that isn't dead
+(since we can only deallocate the topmost continuation).
+
+The key to understanding why this can't happen is that each continuation has
+only one read (receiver). If B is on top of A, then it must be the case that A
+is live at the receiver for B. This means that it is impossible for B to be
+live without A being live.
+
+
+The reason that we don't solve this problem using a normal iterative flow
+analysis is that we also need to know the ordering of the continuations on the
+stack so that we can do deallocation. When it comes time to discard values, we
+want to know which discarded continuation is on the bottom so that we can reset
+SP to its start.
+
+[I suppose we could also decrement SP by the aggregate size of the discarded
+continuations.] Another advantage of knowing the order in which we expect
+continuations to be on the stack is that it allows us to do some consistency
+checking. Also doing a localized graph walk around the values-receiver is
+likely to be much more efficient than doing an iterative flow analysis problem
+over all the code in the component (not that big a consideration.)
+
+
+
+\#|
+Actually, what we do is do a backward graph walk from each unknown-values
+receiver. As we go, we mark each walked block with ther ordered list of
+continuations we believe are on the stack. Starting with an empty stack, we:
+ -- When we encounter another unknown-values receiver, we push that
+ continuation on our simulated stack.
+ -- When we encounter a receiver (which had better be for the topmost
+ continuation), we pop that continuation.
+ -- When we pop all continuations, we terminate our walk.
+
+[\#\#\# not quite right... It seems we may run into "dead values" during the
+graph walk too. It seems that we have to check if the pushed continuation is
+on stack top, and if not, add it to the ending stack so that the post-pass will
+discard it.]
+
+
+
+[\#\#\# Also, we can't terminate our walk just because we hit a block previously
+walked. We have to compare the the End-Stack with the values received along
+the current path: if we have more values on our current walk than on the walk
+that last touched the block, then we need to re-walk the subgraph reachable
+from from that block, using our larger set of continuations. It seems that our
+actual termination condition is reaching a block whose End-Stack is already EQ
+to our current stack.]
+
+
+
+
+
+If at the start, the block containing the values receiver has already been
+walked, the we skip the walk for that continuation, since it has already been
+handled by an enclosing values receiver. Once a walk has started, we
+ignore any signs of a previous walk, clobbering the old result with our own,
+since we enclose that continuation, and the previous walk doesn't take into
+consideration the fact that our values block underlies its own.
+
+When we are done, we have annotated each block with the stack current both at
+the beginning and at the end of that block. Blocks that aren't walked don't
+have anything on the stack either place (although they may hack MVs
+internally).
+
+We then scan all the blocks in the component, looking for blocks that have
+predecessors with a different ending stack than that block's starting stack.
+(The starting stack had better be a tail of the predecessor's ending stack.)
+We insert a block intervening between all of these predecessors that sets SP to
+the end of the values for the continuation that should be on stack top. Of
+course, this pass needn't be done if there aren't any global unknown MVs.
+
+Also, if we find any block that wasn't reached during the walk, but that USEs
+an outside unknown-values continuation, then we know that the DEST can't be
+reached from this point, so the values are unused. We either insert code to
+pop the values, or somehow mark the code to prevent the values from ever being
+pushed. (We could cause the popping to be done by the normal pass if we
+iterated over the pushes beforehand, assigning a correct END-STACK.)
+
+[\#\#\# But I think that we have to be a bit clever within blocks, given the
+possibility of blocks being joined. We could collect some unknown MVs in a
+block, then do a control transfer out of the receiver, and this control
+transfer could be squeezed out by merging blocks. How about:
+
+ (tagbody
+ (return
+ (multiple-value-prog1 (foo)
+ (when bar
+ (go UNWIND))))
+
+ UNWIND
+ (return
+ (multiple-value-prog1 (baz)
+ bletch)))
+
+But the problem doesn't happen here (can't happen in general?) since a node
+buried within a block can't use a continuation outside of the block. In fact,
+no block can have more then one PUSH continuation, and this must always be be
+last continuation. So it is trivially (structurally) true that all pops come
+before any push.
+
+[\#\#\# But not really: the DEST of an embedded continuation may be outside the
+block. There can be multiple pushes, and we must find them by iterating over
+the uses of MV receivers in LTN. But it would be hard to get the order right
+this way. We could easily get the order right if we added the generators as we
+saw the uses, except that we can't guarantee that the continuations will be
+annotated at that point. (Actually, I think we only need the order for
+consistency checks, but that is probably worthwhile). I guess the thing to do
+is when we process the receiver, add the generator blocks to the
+Values-Generators, then do a post-pass that re-scans the blocks adding the
+pushes.]
+
+I believe that above concern with a dead use getting mashed inside a block
+can't happen, since the use inside the block must be the only use, and if the
+use isn't reachable from the push, then the use is totally unreachable, and
+should have been deleted, which would prevent the prevent it from ever being
+annotated.
+]
+]
+|\#
+
+We find the partial ordering of the values globs for unknown values
+continuations in each environment. We don't have to scan the code looking for
+unknown values continuations since LTN annotates each block with the
+continuations that were popped and not pushed or pushed and not popped. This
+is all we need to do the inter-block analysis.
+
+After we have found out what stuff is on the stack at each block boundary, we
+look for blocks with predecessors that have junk on the stack. For each such
+block, we introduce a new block containing code to restore the stack pointer.
+Since unknown-values continuations are represented as <start, count>, we can
+easily pop a continuation using the Start TN.
+
+Note that there is only doubt about how much stuff is on the control stack,
+since only it is used for unknown values. Any special stacks such as number
+stacks will always have a fixed allocation.
+
+\f
+\section{Non-local exit}
+
+
+If the starting and ending continuations are not in the same environment, then
+the control transfer is a non-local exit. In this case just call Unwind with
+the appropriate stack pointer, and let the code at the re-entry point worry
+about fixing things up.
+
+It seems like maybe a good way to organize VMR conversion of NLX would be to
+have environment analysis insert funny functions in new interposed cleanup
+blocks. The thing is that we need some way for VMR conversion to:
+ 1] Get its hands on the returned values.
+ 2] Do weird control shit.
+ 3] Deliver the values to the original continuation destination.
+I.e. we need some way to interpose arbitrary code in the path of value
+delivery.
+
+What we do is replace the NLX uses of the continuation with another
+continuation that is received by a MV-Call to %NLX-VALUES in a cleanup block
+that is interposed between the NLX uses and the old continuation's block. The
+MV-Call uses the original continuation to deliver it's values to.
+
+[Actually, it's not really important that this be an MV-Call, since it has to
+be special-cased by LTN anyway. Or maybe we would want it to be an MV call.
+If did normal LTN analysis of an MV call, it would force the returned values
+into the unknown values convention, which is probably pretty convenient for use
+in NLX.
+
+Then the entry code would have to use some special VOPs to receive the unknown
+values. But we probably need special VOPs for NLX entry anyway, and the code
+can share with the call VOPs. Also we probably need the technology anyway,
+since THROW will use truly unknown values.]
+
+
+On entry to a dynamic extent that has non-local-exists into it (always at an
+ENTRY node), we take a complete snapshot of the dynamic state:
+ the top pointers for all stacks
+ current Catch and Unwind-Protect
+ current special binding (binding stack pointer in shallow binding)
+
+We insert code at the re-entry point which restores the saved dynamic state.
+All TNs live at a NLX EP are forced onto the stack, so we don't have to restore
+them, and we don't have to worry about getting them saved.
+
--- /dev/null
+\chapter{Object Format}
+
+\f
+\section{Tagging}
+
+The following is a key of the three bit low-tagging scheme:
+\begin{description}
+ \item[000] even fixnum
+ \item[001] function pointer
+ \item[010] even other-immediate (header-words, characters, symbol-value trap value, etc.)
+ \item[011] list pointer
+ \item[100] odd fixnum
+ \item[101] structure pointer
+ \item[110] odd other immediate
+ \item[111] other-pointer to data-blocks (other than conses, structures,
+ and functions)
+\end{description}
+
+This tagging scheme forces a dual-word alignment of data-blocks on the heap,
+but this can be pretty negligible:
+\begin{itemize}
+\item RATIOS and COMPLEX must have a header-word anyway since they are not a
+ major type. This wastes one word for these infrequent data-blocks since
+ they require two words for the data.
+
+\item BIGNUMS must have a header-word and probably contain only one other word
+ anyway, so we probably don't waste any words here. Most bignums just
+ barely overflow fixnums, that is by a bit or two.
+
+\item Single and double FLOATS?
+ no waste, or
+ one word wasted
+
+\item SYMBOLS have a pad slot (current called the setf function, but unused.)
+\end{itemize}
+Everything else is vector-like including code, so these probably take up
+so many words that one extra one doesn't matter.
+
+
+\f
+\section{GC Comments}
+
+Data-Blocks comprise only descriptors, or they contain immediate data and raw
+bits interpreted by the system. GC must skip the latter when scanning the
+heap, so it does not look at a word of raw bits and interpret it as a pointer
+descriptor. These data-blocks require headers for GC as well as for operations
+that need to know how to interpret the raw bits. When GC is scanning, and it
+sees a header-word, then it can determine how to skip that data-block if
+necessary. Header-Words are tagged as other-immediates. See the sections
+"Other-Immediates" and "Data-Blocks and Header-Words" for comments on
+distinguishing header-words from other-immediate data. This distinction is
+necessary since we scan through data-blocks containing only descriptors just as
+we scan through the heap looking for header-words introducing data-blocks.
+
+Data-Blocks containing only descriptors do not require header-words for GC
+since the entire data-block can be scanned by GC a word at a time, taking
+whatever action is necessary or appropriate for the data in that slot. For
+example, a cons is referenced by a descriptor with a specific tag, and the
+system always knows the size of this data-block. When GC encounters a pointer
+to a cons, it can transport it into the new space, and when scanning, it can
+simply scan the two words manifesting the cons interpreting each word as a
+descriptor. Actually there is no cons tag, but a list tag, so we make sure the
+cons is not nil when appropriate. A header may still be desired if the pointer
+to the data-block does not contain enough information to adequately maintain
+the data-block. An example of this is a simple-vector containing only
+descriptor slots, and we attach a header-word because the descriptor pointing
+to the vector lacks necessary information -- the type of the vector's elements,
+its length, etc.
+
+There is no need for a major tag for GC forwarding pointers. Since the tag
+bits are in the low end of the word, a range check on the start and end of old
+space tells you if you need to move the thing. This is all GC overhead.
+
+
+\f
+\section{Structures}
+
+A structure descriptor has the structure lowtag type code, making
+{\tt structurep} a fast operation. A structure
+data-block has the following format:
+\begin{verbatim}
+ -------------------------------------------------------
+ | length (24 bits) | Structure header type (8 bits) |
+ -------------------------------------------------------
+ | structure type name (a symbol) |
+ -------------------------------------------------------
+ | structure slot 0 |
+ -------------------------------------------------------
+ | ... structure slot length - 2 |
+ -------------------------------------------------------
+\end{verbatim}
+
+The header word contains the structure length, which is the number of words
+(other than the header word.) The length is always at least one, since the
+first word of the structure data is the structure type name.
+
+\f
+\section{Fixnums}
+
+A fixnum has one of the following formats in 32 bits:
+\begin{verbatim}
+ -------------------------------------------------------
+ | 30 bit 2's complement even integer | 0 0 0 |
+ -------------------------------------------------------
+\end{verbatim}
+or
+\begin{verbatim}
+ -------------------------------------------------------
+ | 30 bit 2's complement odd integer | 1 0 0 |
+ -------------------------------------------------------
+\end{verbatim}
+
+Effectively, there is one tag for immediate integers, two zeros. This buys one
+more bit for fixnums, and now when these numbers index into simple-vectors or
+offset into memory, they point to word boundaries on 32-bit, byte-addressable
+machines. That is, no shifting need occur to use the number directly as an
+offset.
+
+This format has another advantage on byte-addressable machines when fixnums are
+offsets into vector-like data-blocks, including structures. Even though we
+previously mentioned data-blocks are dual-word aligned, most indexing and slot
+accessing is word aligned, and so are fixnums with effectively two tag bits.
+
+Two tags also allow better usage of special instructions on some machines that
+can deal with two low-tag bits but not three.
+
+Since the two bits are zeros, we avoid having to mask them off before using the
+words for arithmetic, but division and multiplication require special shifting.
+
+
+\f
+\section{Other-immediates}
+
+As for fixnums, there are two different three-bit lowtag codes for
+other-immediate, allowing 64 other-immediate types:
+\begin{verbatim}
+----------------------------------------------------------------
+| Data (24 bits) | Type (8 bits with low-tag) | 1 0 |
+----------------------------------------------------------------
+\end{verbatim}
+
+The type-code for an other-immediate type is considered to include the two
+lowtag bits. This supports the concept of a single "type code" namespace for
+all descriptors, since the normal lowtag codes are disjoint from the
+other-immediate codes.
+
+For other-pointer objects, the full eight bits of the header type code are used
+as the type code for that kind of object. This is why we use two lowtag codes
+for other-immediate types: each other-pointer object needs a distinct
+other-immediate type to mark its header.
+
+The system uses the other-immediate format for characters,
+the {\tt symbol-value} unbound trap value, and header-words for data-blocks on
+the heap. The type codes are laid out to facilitate range checks for common
+subtypes; for example, all numbers will have contiguous type codes which are
+distinct from the contiguous array type codes. See section
+\ref{data-blocks-and-o-i} for details.
+
+\f
+\section{Data-Blocks and Header-Word Format}
+
+Pointers to data-blocks have the following format:
+\begin{verbatim}
+----------------------------------------------------------------
+| Dual-word address of data-block (29 bits) | 1 1 1 |
+----------------------------------------------------------------
+\end{verbatim}
+
+The word pointed to by the above descriptor is a header-word, and it has the
+same format as an other-immediate:
+\begin{verbatim}
+----------------------------------------------------------------
+| Data (24 bits) | Type (8 bits with low-tag) | 0 1 0 |
+----------------------------------------------------------------
+\end{verbatim}
+This is convenient for scanning the heap when GC'ing, but it does mean that
+whenever GC encounters an other-immediate word, it has to do a range check on
+the low byte to see if it is a header-word or just a character (for example).
+This is easily acceptable performance hit for scanning.
+
+The system interprets the data portion of the header-word for non-vector
+data-blocks as the word length excluding the header-word. For example, the
+data field of the header for ratio and complex numbers is two, one word each
+for the numerator and denominator or for the real and imaginary parts.
+
+For vectors and data-blocks representing Lisp objects stored like vectors, the
+system ignores the data portion of the header-word:
+\begin{verbatim}
+----------------------------------------------------------------
+| Unused Data (24 bits) | Type (8 bits with low-tag) | 0 1 0 |
+----------------------------------------------------------------
+| Element Length of Vector (30 bits) | 0 0 |
+----------------------------------------------------------------
+\end{verbatim}
+
+Using a separate word allows for much larger vectors, and it allows {\tt
+length} to simply access a single word without masking or shifting. Similarly,
+the header for complex arrays and vectors has a second word, following the
+header-word, the system uses for the fill pointer, so computing the length of
+any array is the same code sequence.
+
+
+\f
+\section{Data-Blocks and Other-immediates Typing}
+
+\label{data-blocks-and-o-i}
+These are the other-immediate types. We specify them including all low eight
+bits, including the other-immediate tag, so we can think of the type bits as
+one type -- not an other-immediate major type and a subtype. Also, fetching a
+byte and comparing it against a constant is more efficient than wasting even a
+small amount of time shifting out the other-immediate tag to compare against a
+five bit constant.
+\begin{verbatim}
+Number (< 30)
+ bignum 10
+ ratio 14
+ single-float 18
+ double-float 22
+ complex 26
+
+Array (>= 30 code 86)
+ Simple-Array (>= 20 code 70)
+ simple-array 30
+ Vector (>= 34 code 82)
+ simple-string 34
+ simple-bit-vector 38
+ simple-vector 42
+ (simple-array (unsigned-byte 2) (*)) 46
+ (simple-array (unsigned-byte 4) (*)) 50
+ (simple-array (unsigned-byte 8) (*)) 54
+ (simple-array (unsigned-byte 16) (*)) 58
+ (simple-array (unsigned-byte 32) (*)) 62
+ (simple-array single-float (*)) 66
+ (simple-array double-float (*)) 70
+ complex-string 74
+ complex-bit-vector 78
+ (array * (*)) -- general complex vector. 82
+ complex-array 86
+
+code-header-type 90
+function-header-type 94
+closure-header-type 98
+funcallable-instance-header-type 102
+unused-function-header-1-type 106
+unused-function-header-2-type 110
+unused-function-header-3-type 114
+closure-function-header-type 118
+return-pc-header-type (a.k.a LRA) 122
+value-cell-header-type 126
+symbol-header-type 130
+base-character-type 134
+system-area-pointer-type (header type) 138
+unbound-marker 142
+weak-pointer-type 146
+structure-header-type 150
+\end{verbatim}
+\f
+\section{Strings}
+
+All strings in the system are C-null terminated. This saves copying the bytes
+when calling out to C. The only time this wastes memory is when the string
+contains a multiple of eight characters, and then the system allocates two more
+words (since Lisp objects are dual-word aligned) to hold the C-null byte.
+Since the system will make heavy use of C routines for systems calls and
+libraries that save reimplementation of higher level operating system
+functionality (such as pathname resolution or current directory computation),
+saving on copying strings for C should make C call out more efficient.
+
+The length word in a string header, see section "Data-Blocks and Header-Word
+Format", counts only the characters truly in the Common Lisp string.
+Allocation and GC will have to know to handle the extra C-null byte, and GC
+already has to deal with rounding up various objects to dual-word alignment.
+
+
+\f
+\section{Symbols and NIL}
+
+Symbol data-block has the following format:
+\begin{verbatim}
+-------------------------------------------------------
+| 7 (data-block words) | Symbol Type (8 bits) |
+-------------------------------------------------------
+| Value Descriptor |
+-------------------------------------------------------
+| Function Pointer |
+-------------------------------------------------------
+| Raw Function Address |
+-------------------------------------------------------
+| Setf Function |
+-------------------------------------------------------
+| Property List |
+-------------------------------------------------------
+| Print Name |
+-------------------------------------------------------
+| Package |
+-------------------------------------------------------
+\end{verbatim}
+
+Most of these slots are self-explanatory given what symbols must do in Common
+Lisp, but a couple require comments. We added the Raw Function Address slot to
+speed up named call which is the most common calling convention. This is a
+non-descriptor slot, but since objects are dual word aligned, the value
+inherently has fixnum low-tag bits. The GC method for symbols must know to
+update this slot. The Setf Function slot is currently unused, but we had an
+extra slot due to adding Raw Function Address since objects must be dual-word
+aligned.
+
+The issues with nil are that we want it to act like a symbol, and we need list
+operations such as CAR and CDR to be fast on it. CMU Common Lisp solves this
+by putting nil as the first object in static space, where other global values
+reside, so it has a known address in the system:
+\begin{verbatim}
+------------------------------------------------------- <-- space
+| 0 | start
+-------------------------------------------------------
+| 7 (data-block words) | Symbol Type (8 bits) |
+------------------------------------------------------- <-- nil
+| Value/CAR |
+-------------------------------------------------------
+| Definition/CDR |
+-------------------------------------------------------
+| Raw Function Address |
+-------------------------------------------------------
+| Setf Function |
+-------------------------------------------------------
+| Property List |
+-------------------------------------------------------
+| Print Name |
+-------------------------------------------------------
+| Package |
+-------------------------------------------------------
+| ... |
+-------------------------------------------------------
+\end{verbatim}
+In addition, we make the list typed pointer to nil actually point past the
+header word of the nil symbol data-block. This has usefulness explained below.
+The value and definition of nil are nil. Therefore, any reference to nil used
+as a list has quick list type checking, and CAR and CDR can go right through
+the first and second words as if nil were a cons object.
+
+When there is a reference to nil used as a symbol, the system adds offsets to
+the address the same as it does for any symbol. This works due to a
+combination of nil pointing past the symbol header-word and the chosen list and
+other-pointer type tags. The list type tag is four less than the other-pointer
+type tag, but nil points four additional bytes into its symbol data-block.
+
+
+\f
+;;;; Array Headers.
+
+The array-header data-block has the following format:
+\begin{verbatim}
+----------------------------------------------------------------
+| Header Len (24 bits) = Array Rank +5 | Array Type (8 bits) |
+----------------------------------------------------------------
+| Fill Pointer (30 bits) | 0 0 |
+----------------------------------------------------------------
+| Available Elements (30 bits) | 0 0 |
+----------------------------------------------------------------
+| Data Vector (29 bits) | 1 1 1 |
+----------------------------------------------------------------
+| Displacement (30 bits) | 0 0 |
+----------------------------------------------------------------
+| Displacedp (29 bits) -- t or nil | 1 1 1 |
+----------------------------------------------------------------
+| Range of First Index (30 bits) | 0 0 |
+----------------------------------------------------------------
+ .
+ .
+ .
+
+\end{verbatim}
+The array type in the header-word is one of the eight-bit patterns from section
+"Data-Blocks and Other-immediates Typing", indicating that this is a complex
+string, complex vector, complex bit-vector, or a multi-dimensional array. The
+data portion of the other-immediate word is the length of the array header
+data-block. Due to its format, its length is always five greater than the
+array's number of dimensions. The following words have the following
+interpretations and types:
+\begin{description}
+ \item[Fill Pointer:]
+ This is a fixnum indicating the number of elements in the data vector
+ actually in use. This is the logical length of the array, and it is
+ typically the same value as the next slot. This is the second word, so
+ LENGTH of any array, with or without an array header, is just four bytes
+ off the pointer to it.
+ \item[Available Elements:]
+ This is a fixnum indicating the number of elements for which there is
+ space in the data vector. This is greater than or equal to the logical
+ length of the array when it is a vector having a fill pointer.
+ \item[Data Vector:]
+ This is a pointer descriptor referencing the actual data of the array.
+ This a data-block whose first word is a header-word with an array type as
+ described in sections "Data-Blocks and Header-Word Format" and
+ "Data-Blocks and Other-immediates Typing"
+ \item[Displacement:]
+ This is a fixnum added to the computed row-major index for any array.
+ This is typically zero.
+ \item[Displacedp:]
+ This is either t or nil. This is separate from the displacement slot, so
+ most array accesses can simply add in the displacement slot. The rare
+ need to know if an array is displaced costs one extra word in array
+ headers which probably aren't very frequent anyway.
+ \item[Range of First Index:]
+ This is a fixnum indicating the number of elements in the first dimension
+ of the array. Legal index values are zero to one less than this number
+ inclusively. IF the array is zero-dimensional, this slot is
+ non-existent.
+ \item[... (remaining slots):]
+ There is an additional slot in the header for each dimension of the
+ array. These are the same as the Range of First Index slot.
+\end{description}
+
+\f
+\section{Bignums}
+
+Bignum data-blocks have the following format:
+\begin{verbatim}
+-------------------------------------------------------
+| Length (24 bits) | Bignum Type (8 bits) |
+-------------------------------------------------------
+| least significant bits |
+-------------------------------------------------------
+ .
+ .
+ .
+\end{verbatim}
+The elements contain the two's complement representation of the integer with
+the least significant bits in the first element or closer to the header. The
+sign information is in the high end of the last element.
+
+
+
+\f
+\section{Code Data-Blocks}
+
+A code data-block is the run-time representation of a "component". A component
+is a connected portion of a program's flow graph that is compiled as a single
+unit, and it contains code for many functions. Some of these functions are
+callable from outside of the component, and these are termed "entry points".
+
+Each entry point has an associated user-visible function data-block (of type
+{\tt function}). The full call convention provides for calling an entry point
+specified by a function object.
+
+Although all of the function data-blocks for a component's entry points appear
+to the user as distinct objects, the system keeps all of the code in a single
+code data-block. The user-visible function object is actually a pointer into
+the middle of a code data-block. This allows any control transfer within a
+component to be done using a relative branch.
+
+Besides a function object, there are other kinds of references into the middle
+of a code data-block. Control transfer into a function also occurs at the
+return-PC for a call. The system represents a return-PC somewhat similarly to
+a function, so GC can also recognize a return-PC as a reference to a code
+data-block. This representation is known as a Lisp Return Address (LRA).
+
+It is incorrect to think of a code data-block as a concatenation of "function
+data-blocks". Code for a function is not emitted in any particular order with
+respect to that function's function-header (if any). The code following a
+function-header may only be a branch to some other location where the
+function's "real" definition is.
+
+
+The following are the three kinds of pointers to code data-blocks:
+\begin{description}
+ \item[Code pointer (labeled A below):]
+ A code pointer is a descriptor, with other-pointer low-tag bits, pointing
+ to the beginning of the code data-block. The code pointer for the
+ currently running function is always kept in a register (CODE). In
+ addition to allowing loading of non-immediate constants, this also serves
+ to represent the currently running function to the debugger.
+ \item[LRA (labeled B below):]
+ The LRA is a descriptor, with other-pointer low-tag bits, pointing
+ to a location for a function call. Note that this location contains no
+ descriptors other than the one word of immediate data, so GC can treat
+ LRA locations the same as instructions.
+ \item[Function (labeled C below):]
+ A function is a descriptor, with function low-tag bits, that is user
+ callable. When a function header is referenced from a closure or from
+ the function header's self-pointer, the pointer has other-pointer low-tag
+ bits, instead of function low-tag bits. This ensures that the internal
+ function data-block associated with a closure appears to be uncallable
+ (although users should never see such an object anyway).
+
+ Information about functions that is only useful for entry points is kept
+ in some descriptors following the function's self-pointer descriptor.
+ All of these together with the function's header-word are known as the
+ "function header". GC must be able to locate the function header. We
+ provide for this by chaining together the function headers in a NIL
+ terminated list kept in a known slot in the code data-block.
+\end{description}
+
+A code data-block has the following format:
+\begin{verbatim}
+A -->
+****************************************************************
+| Header-Word count (24 bits) | Code-Type (8 bits) |
+----------------------------------------------------------------
+| Number of code words (fixnum tag) |
+----------------------------------------------------------------
+| Pointer to first function header (other-pointer tag) |
+----------------------------------------------------------------
+| Debug information (structure tag) |
+----------------------------------------------------------------
+| First constant (a descriptor) |
+----------------------------------------------------------------
+| ... |
+----------------------------------------------------------------
+| Last constant (and last word of code header) |
+----------------------------------------------------------------
+| Some instructions (non-descriptor) |
+----------------------------------------------------------------
+| (pad to dual-word boundary if necessary) |
+
+B -->
+****************************************************************
+| Word offset from code header (24) | Return-PC-Type (8) |
+----------------------------------------------------------------
+| First instruction after return |
+----------------------------------------------------------------
+| ... more code and LRA header-words |
+----------------------------------------------------------------
+| (pad to dual-word boundary if necessary) |
+
+C -->
+****************************************************************
+| Offset from code header (24) | Function-Header-Type (8) |
+----------------------------------------------------------------
+| Self-pointer back to previous word (with other-pointer tag) |
+----------------------------------------------------------------
+| Pointer to next function (other-pointer low-tag) or NIL |
+----------------------------------------------------------------
+| Function name (a string or a symbol) |
+----------------------------------------------------------------
+| Function debug arglist (a string) |
+----------------------------------------------------------------
+| Function type (a list-style function type specifier) |
+----------------------------------------------------------------
+| Start of instructions for function (non-descriptor) |
+----------------------------------------------------------------
+| More function headers and instructions and return PCs, |
+| until we reach the total size of header-words + code |
+| words. |
+----------------------------------------------------------------
+\end{verbatim}
+
+The following are detailed slot descriptions:
+\begin{description}
+ \item[Code data-block header-word:]
+ The immediate data in the code data-block's header-word is the number of
+ leading descriptors in the code data-block, the fixed overhead words plus
+ the number of constants. The first non-descriptor word, some code,
+ appears at this word offset from the header.
+ \item[Number of code words:]
+ The total number of non-header-words in the code data-block. The total
+ word size of the code data-block is the sum of this slot and the
+ immediate header-word data of the previous slot.
+ header-word.
+ \item[Pointer to first function header:]
+ A NIL-terminated list of the function headers for all entry points to
+ this component.
+ \item[Debug information:]
+ The DEBUG-INFO structure describing this component. All information that
+ the debugger wants to get from a running function is kept in this
+ structure. Since there are many functions, the current PC is used to
+ locate the appropriate debug information. The system keeps the debug
+ information separate from the function data-block, since the currently
+ running function may not be an entry point. There is no way to recover
+ the function object for the currently running function, since this
+ data-block may not exist.
+ \item[First constant ... last constant:]
+ These are the constants referenced by the component, if there are any.
+\vspace{1ex}
+ \item[LRA header word:]
+ The immediate header-word data is the word offset from the enclosing code
+ data-block's header-word to this word. This allows GC and the debugger
+ to easily recover the code data-block from a LRA. The code at the
+ return point restores the current code pointer using a subtract immediate
+ of the offset, which is known at compile time.
+\vspace{1ex}
+ \item[Function entry point header-word:]
+ The immediate header-word data is the word offset from the enclosing code
+ data-block's header-word to this word. This is the same as for the
+ retrun-PC header-word.
+ \item[Self-pointer back to header-word:]
+ In a non-closure function, this self-pointer to the previous header-word
+ allows the call sequence to always indirect through the second word in a
+ user callable function. See section "Closure Format". With a closure,
+ indirecting through the second word gets you a function header-word. The
+ system ignores this slot in the function header for a closure, since it
+ has already indirected once, and this slot could be some random thing
+ that causes an error if you jump to it. This pointer has an
+ other-pointer tag instead of a function pointer tag, indicating it is not
+ a user callable Lisp object.
+ \item[Pointer to next function:]
+ This is the next link in the thread of entry point functions found in
+ this component. This value is NIL when the current header is the last
+ entry point in the component.
+ \item[Function name:]
+ This function's name (for printing). If the user defined this function
+ with DEFUN, then this is the defined symbol, otherwise it is a
+ descriptive string.
+ \item[Function debug arglist:]
+ A printed string representing the function's argument list, for human
+ readability. If it is a macroexpansion function, then this is the
+ original DEFMACRO arglist, not the actual expander function arglist.
+ \item[Function type:]
+ A list-style function type specifier representing the argument signature
+ and return types for this function. For example,
+ \begin{verbatim}
+(function (fixnum fixnum fixnum) fixnum)
+ \end{verbatim}
+ or
+ \begin{verbatim}
+(function (string &key (:start unsigned-byte)) string)
+ \end{verbatim}
+ This information is intended for machine readablilty, such as by the
+ compiler.
+\end{description}
+
+\f
+\section{Closure Format}
+
+A closure data-block has the following format:
+\begin{verbatim}
+----------------------------------------------------------------
+| Word size (24 bits) | Closure-Type (8 bits) |
+----------------------------------------------------------------
+| Pointer to function header (other-pointer low-tag) |
+----------------------------------------------------------------
+| . |
+| Environment information |
+| . |
+----------------------------------------------------------------
+\end{verbatim}
+
+A closure descriptor has function low-tag bits. This means that a descriptor
+with function low-tag bits may point to either a function header or to a
+closure. The idea is that any callable Lisp object has function low-tag bits.
+Insofar as call is concerned, we make the format of closures and non-closure
+functions compatible. This is the reason for the self-pointer in a function
+header. Whenever you have a callable object, you just jump through the second
+word, offset some bytes, and go.
+
+
+\f
+\section{Function call}
+
+Due to alignment requirements and low-tag codes, it is not possible to use a
+hardware call instruction to compute the LRA. Instead the LRA
+for a call is computed by doing an add-immediate to the start of the code
+data-block.
+
+An advantage of using a single data-block to represent both the descriptor and
+non-descriptor parts of a function is that both can be represented by a
+single pointer. This reduces the number of memory accesses that have to be
+done in a full call. For example, since the constant pool is implicit in a
+LRA, a call need only save the LRA, rather than saving both the
+return PC and the constant pool.
+
+
+\f
+\section{Memory Layout}
+
+CMU Common Lisp has four spaces, read-only, static, dynamic-0, and dynamic-1.
+Read-only contains objects that the system never modifies, moves, or reclaims.
+Static space contains some global objects necessary for the system's runtime or
+performance (since they are located at a known offset at a know address), and
+the system never moves or reclaims these. However, GC does need to scan static
+space for references to moved objects. Dynamic-0 and dynamic-1 are the two
+heap areas for stop-and-copy GC algorithms.
+
+What global objects are at the head of static space???
+\begin{verbatim}
+ NIL
+ eval::*top-of-stack*
+ lisp::*current-catch-block*
+ lisp::*current-unwind-protect*
+ FLAGS (RT only)
+ BSP (RT only)
+ HEAP (RT only)
+\end{verbatim}
+
+In addition to the above spaces, the system has a control stack, binding stack,
+and a number stack. The binding stack contains pairs of descriptors, a symbol
+and its previous value. The number stack is the same as the C stack, and the
+system uses it for non-Lisp objects such as raw system pointers, saving
+non-Lisp registers, parts of bignum computations, etc.
+
+
+\f
+\section{System Pointers}
+
+The system pointers reference raw allocated memory, data returned by foreign
+function calls, etc. The system uses these when you need a pointer to a
+non-Lisp block of memory, using an other-pointer. This provides the greatest
+flexibility by relieving contraints placed by having more direct references
+that require descriptor type tags.
+
+A system area pointer data-block has the following format:
+\begin{verbatim}
+-------------------------------------------------------
+| 1 (data-block words) | SAP Type (8 bits) |
+-------------------------------------------------------
+| system area pointer |
+-------------------------------------------------------
+\end{verbatim}
+
+"SAP" means "system area pointer", and much of our code contains this naming
+scheme. We don't currently restrict system pointers to one area of memory, but
+if they do point onto the heap, it is up to the user to prevent being screwed
+by GC or whatever.
--- /dev/null
+Todo:
+fasl.tex
+In good shape.
+
+object.tex
+Fairly good, but should probably be integrated with description of primitives
+in vm.tex.
+
+front.tex
+Needs updating cleanup scan. Not too bad.
+
+middle.tex
+Need VMR overview. New names for GTN/LTN? Needs general cleanup, but not too
+bad. NLX and stack are the worst.
+
+back.tex
+Pack and assembler need more info. General cleanup.
+
+
+compiler-overview.tex
+Adapt introductory material from /../fred/usr/ram/comp.mss, pap:talk.mss
+Division between ICR overview and ICR convert needs work.
+
+debugger.tex
+Needs much work. Merge much info from debug-info and debug-int. Duplicating a
+fair amount of stuff in the source may make sense where, since this is a part
+of the system that is generally interesting. And also, a part that people
+building on CMU CL might want to understand.
+
+glossary.tex
+Finish, integrate w/ main text?
+
+interpreter.tex
+Very sketchy and tentative. Needs to be fleshed out from the code.
+
+retargeting.tex
+Very rough. Needs to be merged with parts of vm.tex (call vops). Needs some
+additional text. Documentation of assembler, and all other exported
+interfaces. (Generate defined VOP descriptions from the core, keyed to files?)
+
+vm.tex
+This file should probably cease to exist, going into object, retargeting and
+introductory material. [Also other scrap in stuff/]
+
+
+[VMR and ICR overview also needed...]
+
+architecture.tex
+Missing sections on startup code, compiling, building.
+
+environment.tex
+Needs to be written: type system and info database interfaces.
+
+interface.tex
+Needs to be written: source paths and error message utilities.
+
+lowlev.tex
+Needs to be written. All manner of low-level stuff: memory layout and
+management, core file format, C interface, low-level debugging (and ldb.)
+
+\f
+Several different audiences:
+ -- Curious compiler implementors (not a big priority. Downplay academic
+ aspects, i.e. comparisons to other techniques, analysis of limitations,
+ future work...) Compiler part can be more academic, and include some
+ justifications of other design decisions.
+ -- System maintainers.
+ -- People retargeting the compiler.
+ -- People bringing up the system in a new environment.
+
+Sys arch part:
+ Package + file structure [system.txt]
+ system building [compiling.txt]
+ bootstrapping & cross compiling
+
+Compiler design:
+ Overview (mirror structure of rest of the part)
+ ICR data structure
+ Front end [front.tex]
+ Basic VMR data structures (no back-end stuff)
+ Middle end [middle.tex]
+ Back end + data structures [back.tex]
+
+ Error system interface
+ Source tracking
+
+Compiler retargeting:
+ VM definition concepts [porting.txt, mail.txt, retargeting.tex]
+ SCs, SBs, primitive-types
+ Defining VOPS
+ time specification
+ defining
+ and using the assembler
+ Required VOPs [internal.txt, lowlev.txt, vm.mss]
+ Standard primitives [vm.mss] (broken down by type, parallels object format
+ section structure.)
+ Customizing VMR conversion
+ multiple hardware
+ constant operands
+ VM specific transforms
+ special-case IR2 convert methods
+
+Run-time system:
+ type system
+ info database
+ Data format [object.tex]
+ Debugger:
+ Info format [debug.txt]
+ Stack parsing [debug.txt]
+ Breakpoints
+ Internal errors
+ Signals
+ Memory management: [William]
+ heap Layout
+ stacks
+ GC
+ misc implementation stuff: foreign call, assembly routines [lowlev.txt]
+ LDB and low-level debugging
+ core file format [William]
+ fasl format [fasl.tex]
--- /dev/null
+\part{Compiler Retargeting}
+
+[\#\#\#
+
+In general, it is a danger sign if a generator references a TN that isn't an
+operand or temporary, since lifetime analysis hasn't been done for that use.
+We are doing weird stuff for the old-cont and return-pc passing locations,
+hoping that the conflicts at the called function have the desired effect.
+Other stuff? When a function returns unknown values, we don't reference the
+values locations when a single-value return is done. But nothing is live at a
+return point anyway.
+
+
+
+Have a way for template conversion to special-case constant arguments?
+How about:
+ If an arg restriction is (:satisfies [<predicate function>]), and the
+ corresponding argument is constant, with the constant value satisfying the
+ predicate, then (if any other restrictions are satisfied), the template
+ will be emitted with the literal value passed as an info argument. If the
+ predicate is omitted, then any constant will do.
+
+ We could sugar this up a bit by allowing (:member <object>*) for
+ (:satisfies (lambda (x) (member x '(<object>*))))
+
+We could allow this to be translated into a Lisp type by adding a new Constant
+type specifier. This could only appear as an argument to a function type.
+To satisfy (Constant <type>), the argument must be a compile-time constant of
+the specified type. Just Constant means any constant (i.e. (Constant *)).
+This would be useful for the type constraints on ICR transforms.
+
+
+Constant TNs: we count on being able to indirect to the leaf, and don't try to
+wedge the information into the offset. We set the FSC to an appropriate
+immediate SC.
+
+ Allow "more operands" to VOPs in define-vop. You can't do much with the
+ more operands: define-vop just fills in the cost information according to
+ the loading costs for a SC you specify. You can't restrict more operands,
+ and you can't make local preferences. In the generator, the named variable
+ is bound to the TN-ref for the first extra operand. This should be good
+ enough to handle all the variable arg VOPs (primarily function call and
+ return). Usually more operands are used just to get TN lifetimes to work
+ out; the generator actually ignores them.
+
+ Variable-arg VOPs can't be used with the VOP macro. You must use VOP*.
+ VOP* doesn't do anything with these extra operand except stick them on the
+ ends of the operand lists passed into the template. VOP* is often useful
+ within the convert functions for non-VOP templates, since it can emit a VOP
+ using an already prepared TN-Ref list.
+
+
+ It is pretty basic to the whole primitive-type idea that there is only one
+ primitive-type for a given lisp type. This is really the same as saying
+ primitive types are disjoint. A primitive type serves two somewhat
+ unrelated purposes:
+ -- It is an abstraction a Lisp type used to select type specific
+ operations. Originally kind of an efficiency hack, but it lets a
+ template's type signature be used both for selection and operand
+ representation determination.
+ -- It represents a set of possible representations for a value (SCs). The
+ primitive type is used to determine the legal SCs for a TN, and is also
+ used to determine which type-coercion/move VOP to use.
+
+]
+
+There are basically three levels of target dependence:
+
+ -- Code in the "front end" (before VMR conversion) deals only with Lisp
+ semantics, and is totally target independent.
+
+ -- Code after VMR conversion and before code generation depends on the VM,
+ but should work with little modification across a wide range of
+ "conventional" architectures.
+
+ -- Code generation depends on the machine's instruction set and other
+ implementation details, so it will have to be redone for each
+ implementation. Most of the work here is in defining the translation into
+ assembly code of all the supported VOPs.
+
+
+\f
+\chapter{Storage bases and classes}
+New interface: instead of CURRENT-FRAME-SIZE, have CURRENT-SB-SIZE <name> which
+returns the current element size of the named SB.
+
+How can we have primitive types that overlap, i.e. (UNSIGNED-BYTE 32),
+(SIGNED-BYTE 32), FIXNUM?
+Primitive types are used for two things:
+ Representation selection: which SCs can be used to represent this value?
+ For this purpose, it isn't necessary that primitive types be disjoint,
+ since any primitive type can choose an arbitrary set of
+ representations. For moves between the overlapping representations,
+ the move/load operations can just be noops when the locations are the
+ same (vanilla MOVE), since any bad moves should be caught out by type
+ checking.
+ VOP selection:
+ Is this operand legal for this VOP? When ptypes overlap in interesting
+ ways, there is a problem with allowing just a simple ptype restriction,
+ since we might want to allow multiple ptypes. This could be handled
+ by allowing "union primitive types", or by allowing multiple primitive
+ types to be specified (only in the operand restriction.) The latter
+ would be long the lines of other more flexible VOP operand restriction
+ mechanisms, (constant, etc.)
+
+
+
+Ensure that load/save-operand never need to do representation conversion.
+
+The PRIMITIVE-TYPE more/coerce info would be moved into the SC. This could
+perhaps go along with flushing the TN-COSTS. We would annotate the TN with
+best SC, which implies the representation (boxed or unboxed). We would still
+need represent the legal SCs for restricted TNs somehow, and also would have to
+come up with some other way for pack to keep track of which SCs we have already
+tried.
+
+A SC would have a list of "alternate" SCs and a boolean SAVE-P value that
+indicates it needs to be saved across calls in some non-SAVE-P SC. A TN is
+initially given its "best" SC. The SC is annotated with VOPs that are used for
+moving between the SC and its alternate SCs (load/save operand, save/restore
+register). It is also annotated with the "move" VOPs used for moving between
+this SC and all other SCs it is possible to move between. We flush the idea
+that there is only c-to-t and c-from-t.
+
+But how does this mesh with the idea of putting operand load/save back into the
+generator? Maybe we should instead specify a load/save function? The
+load/save functions would also differ from the move VOPs in that they would
+only be called when the TN is in fact in that particular alternate SC, whereas
+the move VOPs will be associated with the primary SC, and will be emitted
+before it is known whether the TN will be packed in the primary SC or an
+alternate.
+
+I guess a packed SC could also have immediate SCs as alternate SCs, and
+constant loading functions could be associated with SCs using this mechanism.
+
+So given a TN packed in SC X and a SC restriction for Y and Z, how do we know
+which load function to call? There would be ambiguity if X was an alternate
+for both Y and Z and they specified different load functions. This seems
+unlikely to arise in practice, though, so we could just detect the ambiguity
+and give an error at define-vop time. If they are doing something totally
+weird, they can always inhibit loading and roll their own.
+
+Note that loading costs can be specified at the same time (same syntax) as
+association of loading functions with SCs. It seems that maybe we will be
+rolling DEFINE-SAVE-SCS and DEFINE-MOVE-COSTS into DEFINE-STORAGE-CLASS.
+
+Fortunately, these changes will affect most VOP definitions very little.
+
+
+A Storage Base represents a physical storage resource such as a register set or
+stack frame. Storage bases for non-global resources such as the stack are
+relativized by the environment that the TN is allocated in. Packing conflict
+information is kept in the storage base, but non-packed storage resources such
+as closure environments also have storage bases.
+Some storage bases:
+ General purpose registers
+ Floating point registers
+ Boxed (control) stack environment
+ Unboxed (number) stack environment
+ Closure environment
+
+A storage class is a potentially arbitrary set of the elements in a storage
+base. Although conceptually there may be a hierarchy of storage classes such
+as "all registers", "boxed registers", "boxed scratch registers", this doesn't
+exist at the implementation level. Such things can be done by specifying
+storage classes whose locations overlap. A TN shouldn't have lots of
+overlapping SC's as legal SC's, since time would be wasted repeatedly
+attempting to pack in the same locations.
+
+There will be some SC's whose locations overlap a great deal, since we get Pack
+to do our representation analysis by having lots of SC's. A SC is basically a
+way of looking at a storage resource. Although we could keep a fixnum and an
+unboxed representation of the same number in the same register, they correspond
+to different SC's since they are different representation choices.
+
+TNs are annotated with the primitive type of the object that they hold:
+ T: random boxed object with only one representation.
+ Fixnum, Integer, XXX-Float: Object is always of the specified numeric type.
+ String-Char: Object is always a string-char.
+
+When a TN is packed, it is annotated with the SC it was packed into. The code
+generator for a VOP must be able to uniquely determine the representation of
+its operands from the SC. (debugger also...)
+
+Some SCs:
+ Reg: any register (immediate objects)
+ Save-Reg: a boxed register near r15 (registers easily saved in a call)
+ Boxed-Reg: any boxed register (any boxed object)
+ Unboxed-Reg: any unboxed register (any unboxed object)
+ Float-Reg, Double-Float-Reg: float in FP register.
+ Stack: boxed object on the stack (on cstack)
+ Word: any 32bit unboxed object on nstack.
+ Double: any 64bit unboxed object on nstack.
+
+We have a number of non-packed storage classes which serve to represent access
+costs associated with values that are not allocated using conflicts
+information. Non-packed TNs appear to already be packed in the appropriate
+storage base so that Pack doesn't get confused. Costs for relevant non-packed
+SC's appear in the TN-Ref cost information, but need not ever be summed into
+the TN cost vectors, since TNs cannot be packed into them.
+
+There are SCs for non-immediate constants and for each significant kind of
+immediate operand in the architecture. On the RT, 4, 8 and 20 bit integer SCs
+are probably worth having.
+
+Non-packed SCs:
+ Constant
+ Immediate constant SCs:
+ Signed-Byte-<N>, Unsigned-Byte-<N>, for various architecture dependent
+ values of <N>
+ String-Char
+ XXX-Float
+ Magic values: T, NIL, 0.
+
+\f
+\chapter{Type system parameterization}
+
+The main aspect of the VM that is likely to vary for good reason is the type
+system:
+
+ -- Different systems will have different ways of representing dynamic type
+ information. The primary effect this has on the compiler is causing VMR
+ conversion of type tests and checks to be implementation dependent.
+ Rewriting this code for each implementation shouldn't be a big problem,
+ since the portable semantics of types has already been dealt with.
+
+ -- Different systems will have different specialized number and array types,
+ and different VOPs specialized for these types. It is easy add this kind
+ of knowledge without affecting the rest of the compiler. All you have to
+ do is define the VOPs and translations.
+
+ -- Different systems will offer different specialized storage resources
+ such as floating-point registers, and will have additional kinds of
+ primitive-types. The storage class mechanism handles a large part of this,
+ but there may be some problem in getting VMR conversion to realize the
+ possibly large hidden costs in implicit moves to and from these specialized
+ storage resources. Probably the answer is to have some sort of general
+ mechanism for determining the primitive-type for a TN given the Lisp type,
+ and then to have some sort of mechanism for automatically using specialized
+ Move VOPs when the source or destination has some particular primitive-type.
+
+\#|
+How to deal with list/null(symbol)/cons in primitive-type structure? Since
+cons and symbol aren't used for type-specific template selection, it isn't
+really all that critical. Probably Primitive-Type should return the List
+primitive type for all of Cons, List and Null (indicating when it is exact).
+This would allow type-dispatch for simple sequence functions (such as length)
+to be done using the standard template-selection mechanism. [Not a wired
+assumption]
+|\#
+
+
+\f
+\chapter{VOP Definition}
+
+Before the operand TN-refs are passed to the emit function, the following
+stuff is done:
+ -- The refs in the operand and result lists are linked together in order using
+ the Across slot. This list is properly NIL terminated.
+ -- The TN slot in each ref is set, and the ref is linked into that TN's refs
+ using the Next slot.
+ -- The Write-P slot is set depending on whether the ref is an argument or
+ result.
+ -- The other slots have the default values.
+
+The template emit function fills in the Vop, Costs, Cost-Function,
+SC-Restriction and Preference slots, and links together the Next-Ref chain as
+appropriate.
+
+\f
+\section{Lifetime model}
+
+\#|
+Note in doc that the same TN may not be used as both a more operand and as any
+other operand to the same VOP, to simplify more operand LTN number coalescing.
+|\#
+
+It seems we need a fairly elaborate model for intra-VOP conflicts in order to
+allocate temporaries without introducing spurious conflicts. Consider the
+important case of a VOP such as a miscop that must have operands in certain
+registers. We allocate a wired temporary, create a local preference for the
+corresponding operand, and move to (or from) the temporary. If all temporaries
+conflict with all arguments, the result will be correct, but arguments could
+never be packed in the actual passing register. If temporaries didn't conflict
+with any arguments, then the temporary for an earlier argument might get packed
+in the same location as the operand for a later argument; loading would then
+destroy an argument before it was read.
+
+A temporary's intra-VOP lifetime is represented by the times at which its life
+starts and ends. There are various instants during the evaluation that start
+and end VOP lifetimes. Two TNs conflict if the live intervals overlap.
+Lifetimes are open intervals: if one TN's lifetime begins at a point where
+another's ends, then the TNs don't conflict.
+
+The times within a VOP are the following:
+
+:Load
+ This is the beginning of the argument's lives, as far as intra-vop
+ conflicts are concerned. If load-TNs are allocated, then this is the
+ beginning of their lives.
+
+(:Argument <n>)
+ The point at which the N'th argument is read for the last time (by this
+ VOP). If the argument is dead after this VOP, then the argument becomes
+ dead at this time, and may be reused as a temporary or result load-TN.
+
+(:Eval <n>)
+ The N'th evaluation step. There may be any number of evaluation steps, but
+ it is unlikely that more than two are needed.
+
+(:Result <n>)
+ The point at which the N'th result is first written into. This is the
+ point at which that result becomes live.
+
+:Save
+ Similar to :Load, but marks the end of time. This is point at which result
+ load-TNs are stored back to the actual location.
+
+In any of the list-style time specifications, the keyword by itself stands for
+the first such time, i.e.
+ :argument <==> (:argument 0)
+
+
+Note that argument/result read/write times don't actually have to be in the
+order specified, but they must *appear* to happen in that order as far as
+conflict analysis is concerned. For example, the arguments can be read in any
+order as long no TN is written that has a life beginning at or after
+(:Argument <n>), where N is the number of an argument whose reading was
+postponed.
+
+[\#\#\# (???)
+
+We probably also want some syntactic sugar in Define-VOP for automatically
+moving operands to/from explicitly allocated temporaries so that this kind of
+thing is somewhat easy. There isn't really any reason to consider the
+temporary to be a load-TN, but we want to compute costs as though it was and
+want to use the same operand loading routines.
+
+We also might consider allowing the lifetime of an argument/result to be
+extended forward/backward. This would in many cases eliminate the need for
+temporaries when operands are read/written out of order.
+]
+
+\f
+\section{VOP Cost model}
+
+Note that in this model, if a operand has no restrictions, it has no cost.
+This makes make sense, since the purpose of the cost is to indicate the
+relative value of packing in different SCs. If the operand isn't required to
+be in a good SC (i.e. a register), then we might as well leave it in memory.
+The SC restriction mechanism can be used even when doing a move into the SC is
+too complex to be generated automatically (perhaps requiring temporary
+registers), since Define-VOP allows operand loading to be done explicitly.
+
+\f
+\section{Efficiency notes}
+
+ In addition to
+being used to tell whether a particular unsafe template might get emitted, we
+can also use it to give better efficiency notes:
+ -- We can say what is wrong with the call types, rather than just saying we
+ failed to open-code.
+ -- We can tell whether any of the "better" templates could possibly apply,
+ i.e. is the inapplicability of a template because of inadequate type
+ information or because the type is just plain wrong. We don't want to
+ flame people when a template that couldn't possibly match doesn't match,
+ e.g. complaining that we can't use fixnum+ when the arguments are known to
+ be floats.
+
+
+This is how we give better efficiency notes:
+
+The Template-Note is a short noun-like string without capitalization or
+punctuation that describes what the template "does", i.e. we say
+"Unable to do ~A, doing ~A instead."
+
+The Cost is moved from the Vop-Info to the Template structure, and is used to
+determine the "goodness" of possibly applicable templates. [Could flush
+Template/Vop-Info distinction] The cost is used to choose the best applicable
+template to emit, and also to determine what better templates we might have
+been able to use.
+
+A template is possibly applicable if there is an intersection between all of
+the arg/result types and the corresponding arg/result restrictions, i.e. the
+template is not clearly impossible: more declarations might allow it to be
+emitted.
+
+\f
+\chapter{Assembler Retargeting}
+
+\f
+\chapter{Writing Assembly Code}
+
+VOP writers expect:
+ MOVE
+ You write when you port the assembler.)
+ EMIT-LABEL
+ Assembler interface like INST. Takes a label you made and says "stick it
+ here."
+ GEN-LABEL
+ Returns a new label suitable for use with EMIT-LABEL exactly once and
+ for referencing as often as necessary.
+ INST
+ Recognizes and dispatches to instructions you defined for assembler.
+ ALIGN
+ This takes the number of zero bits you want in the low end of the address
+ of the next instruction.
+ ASSEMBLE
+ ASSEMBLE-ELSEWHERE
+ Get ready for assembling stuff. Takes a VOP and arbitrary PROGN-style
+ body. Wrap these around instruction emission code announcing the first
+ pass of our assembler.
+ CURRENT-NFP-TN
+ This returns a TN for the NFP if the caller uses the number stack, or
+ nil.
+ SB-ALLOCATED-SIZE
+ This returns the size of some storage based used by the currently
+ compiling component.
+ ...
+
+;;;
+;;; VOP idioms
+;;;
+
+STORE-STACK-TN
+LOAD-STACK-TN
+ These move a value from a register to the control stack, or from the
+ control stack to a register. They take care of checking the TN types,
+ modifying offsets according to the address units per word, etc.
+
+\f
+\chapter{Required VOPS}
+
+
+Note: the move VOP cannot have any wired temps. (Move-Argument also?) This is
+so we can move stuff into wired TNs without stepping on our toes.
+
+
+We create set closure variables using the Value-Cell VOP, which takes a value
+and returns a value cell containing the value. We can basically use this
+instead of a Move VOP when initializing the variable. Value-Cell-Set and
+Value-Cell-Ref are used to access the value cell. We can have a special effect
+for value cells so that value cells references can be discovered to be common
+subexpressions or loop invariants.
+
+
+
+
+Represent unknown-values continuations as (start, count). Unknown values
+continuations are always outside of the current frame (on stack top). Within a
+function, we always set up and receive values in the standard passing
+locations. If we receive stack values, then we must BLT them down to the start
+of our frame, filling in any unsupplied values. If we generate unknown values
+(i.e. PUSH-VALUES), then we set the values up in the standard locations, then
+BLT them to stack top. When doing a tail-return of MVs, we just set them up in
+the standard locations and decrement SP: no BLT is necessary.
+
+Unknown argument call (MV-CALL) takes its arguments on stack top (is given a
+base pointer). If not a tail call, then we just set the arg pointer to the
+base pointer and call. If a tail call, we must BLT the arguments down to the
+beginning of the current frame.
+
+
+Implement more args by BLT'ing the more args *on top* of the current frame.
+This solves two problems:
+ -- Any register more arguments can be made uniformly accessibly by copying
+ them into memory. [We can't store the registers in place, since the
+ beginning of the frame gets double use for storing the old-cont, return-pc
+ and env.]
+ -- It solves the deallocation problem: the arguments will be deallocated when
+ the frame is returned from or a tail full call is done out of it. So
+ keyword args will be properly tail-recursive without any special mechanism
+ for squeezing out the more arg once the parsing is done. Note that a tail
+ local call won't blast the more arg, since in local call the callee just
+ takes the frame it is given (in this case containing the more arg).
+
+More args in local call??? Perhaps we should not attempt local call conversion
+in this case. We already special-case keyword args in local call. It seems
+that the main importance of more args is primarily related to full call: it is
+used for defining various kinds of frobs that need to take arbitrary arguments:
+ -- Keyword arguments
+ -- Interpreter stubs
+ -- "Pass through" applications such as dispatch functions
+
+Given the marginal importance of more args in local call, it seems unworth
+going to any implementation difficulty. In fact, it seems that it would cause
+complications both at the VMR level and also in the VM definition. This being
+the case, we should flush it.
+
+
+\section{Function Call}
+
+
+\f
+\subsection{Registers and frame format}
+
+These registers are used in function call and return:
+
+A0..A{\it n}
+ In full call, the first three arguments. In unknown values return, the
+ first three return values.
+
+CFP
+ The current frame pointer. In full call, this initially points to a
+ partial frame large enough to hold the passed stack arguments (zero-length
+ if none).
+
+CSP
+ The current control stack top pointer.
+
+OCFP
+ In full call, the passing location for the frame to return to.
+
+ In unknown-values return of other than one value, the pointer to returned
+ stack values. In such a return, OCFP is always initialized to point to
+ the frame returned from, even when no stack values are returned. This
+ allows OCFP to be used to restore CSP.
+
+LRA
+ In full call, the passing location for the return PC.
+
+NARGS
+ In full call, the number of arguments passed. In unknown-values return of
+ other than one value, the number of values returned.
+
+\f
+\subsection{Full call}
+
+What is our usage of CFP, OCFP and CSP?
+
+It is an invariant that CSP always points after any useful information so that
+at any time an interrupt can come and allocate stuff in the stack.
+
+TR call is also a constraint: we can't deallocate the caller's frame before the
+call, since it holds the stack arguments for the call.
+
+What we do is have the caller set up CFP, and have the callee set CSP to CFP
+plus the frame size. The caller leaves CSP alone: the callee is the one who
+does any necessary stack deallocation.
+
+In a TR call, we don't do anything: CFP is left as CFP, and CSP points to the
+end of the frame, keeping the stack arguments from being trashed.
+
+In a normal call, CFP is set to CSP, causing the callee's frame to be allocated
+after the current frame.
+
+\f
+\subsection{Unknown values return}
+
+The unknown values return convention is always used in full call, and is used
+in local call when the compiler either can't prove that a fixed number of
+values are returned, or decides not to use the fixed values convention to allow
+tail-recursive XEP calls.
+
+The unknown-values return convention has variants: single value and variable
+values. We make this distinction to optimize the important case of a returner
+whose knows exactly one value is being returned. Note that it is possible to
+return a single value using the variable-values convention, but it is less
+efficient.
+
+We indicate single-value return by returning at the return-pc+4; variable value
+return is indicated by returning at the return PC.
+
+Single-value return makes only the following guarantees:
+ A0 holds the value returned.
+ CSP has been reset: there is no garbage on the stack.
+
+In variable value return, more information is passed back:
+ A0..A2 hold the first three return values. If fewer than three values are
+ returned, then the unused registers are initialized to NIL.
+
+ OCFP points to the frame returned from. Note that because of our
+ tail-recursive implementation of call, the frame receiving the values is
+ always immediately under the frame returning the values. This means that
+ we can use OCFP to index the values when we access them, and to restore
+ CSP when we want to discard them.
+
+ NARGS holds the number of values returned.
+
+ CSP is always (+ OCFP (* NARGS 4)), i.e. there is room on the stack
+ allocated for all returned values, even if they are all actually passed in
+ registers.
+
+\f
+\subsection{External Entry Points}
+
+Things that need to be done on XEP entry:
+ 1] Allocate frame
+ 2] Move more arg above the frame, saving context
+ 3] Set up env, saving closure pointer if closure
+ 4] Move arguments from closure to local home
+ Move old-cont and return-pc to the save locations
+ 5] Argument count checking and dispatching
+
+XEP VOPs:
+
+Allocate-Frame
+Copy-More-Arg <nargs-tn> 'fixed {in a3} => <context>, <count>
+Setup-Environment
+Setup-Closure-Environment => <closure>
+Verify-Argument-Count <nargs-tn> 'count {for fixed-arg lambdas}
+Argument-Count-Error <nargs-tn> {Drop-thru on hairy arg dispatching}
+Use fast-if-=/fixnum and fast-if-</fixnum for dispatching.
+
+Closure vops:
+make-closure <fun entry> <slot count> => <closure>
+closure-init <closure> <values> 'slot
+
+
+Things that need to be done on all function entry:
+ -- Move arguments to the variable home (consing value cells as necessary)
+ -- Move environment values to the local home
+ -- Move old-cont and return-pc to the save locations
+
+\f
+\section{Calls}
+
+Calling VOP's are a cross product of the following sets (with some members
+missing):
+ Return values
+ multiple (all values)
+ fixed (calling with unknown values conventions, wanting a certain
+ number.)
+ known (only in local call where caller/callee agree on number of
+ values.)
+ tail (doesn't return but does tail call)
+ What function
+ local
+ named (going through symbol, like full but stash fun name for error sys)
+ full (have a function)
+ Args
+ fixed (number of args are known at compile-time)
+ variable (MULTIPLE-VALUE-CALL and APPLY)
+
+Note on all jumps for calls and returns that we want to put some instruction
+in the jump's delay slot(s).
+
+Register usage at the time of the call:
+
+LEXENV
+ This holds the lexical environment to use during the call if it's a closure,
+ and it is undefined otherwise.
+
+CNAME
+ This holds the symbol for a named call and garbage otherwise.
+
+OCFP
+ This holds the frame pointer, which the system restores upon return. The
+ callee saves this if necessary; this is passed as a pseudo-argument.
+
+A0 ... An
+ These holds the first n+1 arguments.
+
+NARGS
+ This holds the number of arguments, as a fixnum.
+
+LRA
+ This holds the lisp-return-address object which indicates where to return.
+ For a tail call, this retains its current value. The callee saves this
+ if necessary; this is passed as a pseudo-argument.
+
+CODE
+ This holds the function object being called.
+
+CSP
+ The caller ignores this. The callee sets it as necessary based on CFP.
+
+CFP
+ This holds the callee's frame pointer. Caller sets this to the new frame
+ pointer, which it remembered when it started computing arguments; this is
+ CSP if there were no stack arguments. For a tail call CFP retains its
+ current value.
+
+NSP
+ The system uses this within a single function. A function using NSP must
+ allocate and deallocate before returning or making a tail call.
+
+Register usage at the time of the return for single value return, which
+goes with the unknown-values convention the caller used.
+
+A0
+ The holds the value.
+
+CODE
+ This holds the lisp-return-address at which the system continues executing.
+
+CSP
+ This holds the CFP. That is, the stack is guaranteed to be clean, and there
+ is no code at the return site to adjust the CSP.
+
+CFP
+ This holds the OCFP.
+
+Additional register usage for multiple value return:
+
+NARGS
+ This holds the number of values returned.
+
+A0 ... An
+ These holds the first n+1 values, or NIL if there are less than n+1 values.
+
+CSP
+ Returner stores CSP to hold its CFP + NARGS * <address units per word>
+
+OCFP
+ Returner stores this as its CFP, so the returnee has a handle on either
+ the start of the returned values on the stack.
+
+
+ALLOCATE FULL CALL FRAME.
+
+If the number of call arguments (passed to the VOP as an info argument)
+indicates that there are stack arguments, then it makes some callee frame for
+arguments:
+ VOP-result <- CSP
+ CSP <- CSP + value of VOP info arg times address units per word.
+
+In a call sequence, move some arguments to the right places.
+
+There's a variety of MOVE-ARGUMENT VOP's.
+
+FULL CALL VOP'S
+(variations determined by whether it's named, it's a tail call, there
+is a variable arg count, etc.)
+
+ if variable number of arguments
+ NARGS <- (CSP - value of VOP argument) shift right by address units per word.
+ A0...An <- values off of VOP argument (just fill them all)
+ else
+ NARGS <- value of VOP info argument (always a constant)
+
+ if tail call
+ OCFP <- value from VOP argument
+ LRA <- value from VOP argument
+ CFP stays the same since we reuse the frame
+ NSP <- NFP
+ else
+ OCFP <- CFP
+ LRA <- compute LRA by adding an assemble-time determined constant to
+ CODE.
+ CFP <- new frame pointer (remembered when starting to compute args)
+ This is CSP if no stack args.
+ when (current-nfp-tn VOP-self-pointer)
+ stack-temp <- NFP
+
+ if named
+ CNAME <- function symbol name
+ the-fun <- function object out of symbol
+
+ LEXENV <- the-fun (from previous line or VOP argument)
+ CODE <- function-entry (the first word after the-fun)
+ LIP <- calc first instruction addr (CODE + constant-offset)
+ jump and run off temp
+
+ <emit Lisp return address data-block>
+ <default and move return values OR receive return values>
+ when (current-nfp-tn VOP-self-pointer)
+ NFP <- stack-temp
+
+Callee:
+
+XEP-ALLOCATE-FRAME
+ emit function header (maybe initializes offset back to component start,
+ but other pointers are set up at load-time. Pads
+ to dual-word boundary.)
+ CSP <- CFP + compile-time determined constant (frame size)
+ if the function uses the number stack
+ NFP <- NSP
+ NSP <- NSP + compile-time determined constant (number stack frame size)
+
+SETUP-ENVIRONMENT
+(either use this or the next one)
+
+CODE <- CODE - assembler-time determined offset from function-entry back to
+ the code data-block address.
+
+SETUP-CLOSURE-ENVIRONMENT
+(either use this or the previous one)
+After this the CLOSURE-REF VOP can reference closure variables.
+
+VOP-result <- LEXENV
+CODE <- CODE - assembler-time determined offset from function-entry back to
+ the code data-block address.
+
+Return VOP's
+RETURN and RETURN-MULTIPLE are for the unknown-values return convention.
+For some previous caller this is either it wants n values (and it doesn't
+know how many are coming), or it wants all the values returned (and it
+doesn't know how many are coming).
+
+
+RETURN
+(known fixed number of values, used with the unknown-values convention
+ in the caller.)
+When compiler invokes VOP, all values are already where they should be;
+just get back to caller.
+
+when (current-nfp-tn VOP-self-pointer)
+ ;; The number stack grows down in memory.
+ NSP <- NFP + number stack frame size for calls within the currently
+ compiling component
+ times address units per word
+CODE <- value of VOP argument with LRA
+if VOP info arg is 1 (number of values we know we're returning)
+ CSP <- CFP
+ LIP <- calc target addr
+ (CODE + skip over LRA header word + skip over address units per branch)
+ (The branch is in the caller to skip down to the MV code.)
+else
+ NARGS <- value of VOP info arg
+ nil out unused arg regs
+ OCFP <- CFP (This indicates the start of return values on the stack,
+ but you leave space for those in registers for convenience.)
+ CSP <- CFP + NARGS * address-units-per-word
+ LIP <- calc target addr (CODE + skip over LRA header word)
+CFP <- value of VOP argument with OCFP
+jump and run off LIP
+
+RETURN-MULTIPLE
+(unknown number of values, used with the unknown-values convention in
+ the caller.)
+When compiler invokes VOP, it gets TN's representing a pointer to the
+values on the stack and how many values were computed.
+
+when (current-nfp-tn VOP-self-pointer)
+ ;; The number stack grows down in memory.
+ NSP <- NFP + number stack frame size for calls within the currently
+ compiling component
+ times address units per word
+NARGS <- value of VOP argument
+copy the args to the beginning of the current (returner's) frame.
+ Actually some go into the argument registers. When putting the rest at
+ the beginning of the frame, leave room for those in the argument registers.
+CSP <- CFP + NARGS * address-units-per-word
+nil out unused arg regs
+OCFP <- CFP (This indicates the start of return values on the stack,
+ but you leave space for those in registers for convenience.)
+CFP <- value of VOP argument with OCFP
+CODE <- value of VOP argument with LRA
+LIP <- calc target addr (CODE + skip over LRA header word)
+jump and run off LIP
+
+
+Returnee
+The call VOP's call DEFAULT-UNKNOWN-VALUES or RECEIVE-UNKNOWN-VALUES after
+spitting out transfer control to get stuff from the returner.
+
+DEFAULT-UNKNOWN-VALUES
+(We know what we want and we got something.)
+If returnee wants one value, it never does anything to deal with a shortage
+of return values. However, if start at PC, then it has to adjust the stack
+pointer to dump extra values (move OCFP into CSP). If it starts at PC+N,
+then it just goes along with the "want one value, got it" case.
+If the returnee wants multiple values, and there's a shortage of return
+values, there are two cases to handle. One, if the returnee wants fewer
+values than there are return registers, and we start at PC+N, then it fills
+in return registers A1..A<desired values necessary>; if we start at PC,
+then the returnee is fine since the returning conventions have filled in
+the unused return registers with nil, but the returnee must adjust the
+stack pointer to dump possible stack return values (move OCFP to CSP).
+Two, if the returnee wants more values than the number of return registers,
+and it starts at PC+N (got one value), then it sets up returnee state as if
+an unknown number of values came back:
+ A0 has the one value
+ A1..An get nil
+ NARGS gets 1
+ OCFP gets CSP, so general code described below can move OCFP into CSP
+If we start at PC, then branch down to the general "got k values, wanted n"
+code which takes care of the following issues:
+ If k < n, fill in stack return values of nil for shortage of return
+ values and move OCFP into CSP
+ If k >= n, move OCFP into CSP
+This also restores CODE from LRA by subtracting an assemble-time constant.
+
+RECEIVE-UKNOWN-VALUES
+(I want whatever I get.)
+We want these at the end of our frame. When the returnee starts starts at
+PC, it moves the return value registers to OCFP..OCFP[An] ignoring where
+the end of the stack is and whether all the return value registers had
+values. The returner left room on the stack before the stack return values
+for the register return values. When the returnee starts at PC+N, bump CSP
+by 1 and copy A0 there.
+This also restores CODE from LRA by subtracting an assemble-time constant.
+
+
+Local call
+
+There are three flavors:
+ 1] KNOWN-CALL-LOCAL
+ Uses known call convention where caller and callee agree where all
+ the values are, and there's a fixed number of return values.
+ 2] CALL-LOCAL
+ Uses the unknown-values convention, but we expect a particular
+ number of values in return.
+ 3] MULTIPLE-CALL-LOCAL
+ Uses the unknown-values convention, but we want all values returned.
+
+ALLOCATE-FRAME
+
+If the number of call arguments (passed to the VOP as an info argument)
+indicates that there are stack arguments, then it makes some callee frame for
+arguments:
+ VOP-result1 <- CSP
+ CSP <- CSP + control stack frame size for calls within the currently
+ compiling component
+ times address units per word.
+ when (callee-nfp-tn <VOP info arg holding callee>)
+ ;; The number stack grows down.
+ ;; May have to round to dual-word boundary if machines C calling
+ ;; conventions demand this.
+ NSP <- NSP - number stack frame size for calls within the currently
+ compiling component
+ times address units per word
+ VOP-result2 <- NSP
+
+KNOWN-CALL-LOCAL, CALL-LOCAL, MULTIPLE-CALL-LOCAL
+KNOWN-CALL-LOCAL has no need to affect CODE since CODE is the same for the
+caller/returnee and the returner. This uses KNOWN-RETURN.
+With CALL-LOCAL and MULTIPLE-CALL-LOCAL, the caller/returnee must fixup
+CODE since the callee may do a tail full call. This happens in the code
+emitted by DEFAULT-UNKNOWN-VALUES and RECEIVE-UNKNOWN-VALUES. We use these
+return conventions since we don't know what kind of values the returner
+will give us. This could happen due to a tail full call to an unknown
+function, or because the callee had different return points that returned
+various numbers of values.
+
+when (current-nfp-tn VOP-self-pointer) ;Get VOP self-pointer with
+ ;DEFINE-VOP switch :vop-var.
+ stack-temp <- NFP
+CFP <- value of VOP arg
+when (callee-nfp-tn <VOP info arg holding callee>)
+ <where-callee-wants-NFP-tn> <- value of VOP arg
+<where-callee-wants-LRA-tn> <- compute LRA by adding an assemble-time
+ determined constant to CODE.
+jump and run off VOP info arg holding start instruction for callee
+
+<emit Lisp return address data-block>
+<case call convention
+ known: do nothing
+ call: default and move return values
+ multiple: receive return values
+>
+when (current-nfp-tn VOP-self-pointer)
+ NFP <- stack-temp
+
+KNOWN-RETURN
+
+CSP <- CFP
+when (current-nfp-tn VOP-self-pointer)
+ ;; number stack grows down in memory.
+ NSP <- NFP + number stack frame size for calls within the currently
+ compiling component
+ times address units per word
+LIP <- calc target addr (value of VOP arg + skip over LRA header word)
+CFP <- value of VOP arg
+jump and run off LIP
+
+
+
+\f
+\chapter{Standard Primitives}
+
+\f
+\chapter{Customizing VMR Conversion}
+
+Another way in which different implementations differ is in the relative cost
+of operations. On machines without an integer multiply instruction, it may be
+desirable to convert multiplication by a constant into shifts and adds, while
+this is surely a bad idea on machines with hardware support for multiplication.
+Part of the tuning process for an implementation will be adding implementation
+dependent transforms and disabling undesirable standard transforms.
+
+When practical, ICR transforms should be used instead of VMR generators, since
+transforms are more portable and less error-prone. Note that the Lisp code
+need not be implementation independent: it may contain all sorts of
+sub-primitives and similar stuff. Generally a function should be implemented
+using a transform instead of an VMR translator unless it cannot be implemented
+as a transform due to being totally evil or it is just as easy to implement as
+a translator because it is so simple.
+
+\f
+\section{Constant Operands}
+
+If the code emitted for a VOP when an argument is constant is very different
+than the non-constant case, then it may be desirable to special-case the
+operation in VMR conversion by emitting different VOPs. An example would be if
+SVREF is only open-coded when the index is a constant, and turns into a miscop
+call otherwise. We wouldn't want constant references to spuriously allocate
+all the miscop linkage registers on the off chance that the offset might not be
+constant. See the :constant feature of VOP primitive type restrictions.
+
+\f
+\section{Supporting Multiple Hardware Configurations}
+
+
+A winning way to change emitted code depending on the hardware configuration,
+i.e. what FPA is present is to do this using primitive types. Note that the
+Primitive-Type function is VM supplied, and can look at any appropriate
+hardware configuration switches. Short-Float can become 6881-Short-Float,
+AFPA-Short-Float, etc. There would be separate SBs and SCs for the registers
+of each kind of FP hardware, with the each hardware-specific primitive type
+using the appropriate float register SC. Then the hardware specific templates
+would provide AFPA-Short-Float as the argument type restriction.
+
+Primitive type changes:
+
+The primitive-type structure is given a new %Type slot, which is the CType
+structure that is equivalent to this type. There is also a Guard slot, with,
+if true is a function that control whether this primitive type is allowed (due
+to hardware configuration, etc.)
+
+We add new :Type and :Guard keywords to Def-Primitive-Type. Type is the type
+specifier that is equivalent (default to the primitive-type name), and Guard is
+an expression evaluated in the null environment that controls whether this type
+applies (default to none, i.e. constant T).
+
+The Primitive-Type-Type function returns the Lisp CType corresponding to a
+primitive type. This is the %Type unless there is a guard that returns false,
+in which case it is the empty type (i.e. NIL).
+
+[But this doesn't do what we want it to do, since we will compute the
+function type for a template at load-time, so they will correspond to whatever
+configuration was in effect then. Maybe we don't want to dick with guards here
+(if at all). I guess we can defer this issue until we actually support
+different FP configurations. But it would seem pretty losing to separately
+flame about all the different FP configurations that could be used to open-code
++ whenever we are forced to closed-code +.
+
+If we separately report each better possibly applicable template that we
+couldn't use, then it would be reasonable to report any conditional template
+allowed by the configuration.
+
+But it would probably also be good to give some sort of hint that perhaps it
+would be a good time to make sure you understand how to tell the compiler to
+compile for a particular configuration. Perhaps if there is a template that
+applies *but for the guard*, then we could give a note. This way, if someone
+thinks they are being efficient by throwing in lots of declarations, we can let
+them know that they may have to do more.
+
+I guess the guard should be associated with the template rather than the
+primitive type. This would allow LTN and friends to easily tell whether a
+template applies in this configuration. It is also probably more natural for
+some sorts of things: with some hardware variants, it may be that the SBs and
+representations (SCs) are really the same, but there some different allowed
+operations. In this case, we could easily conditionalize VOPs without the
+increased complexity due to bogus SCs. If there are different storage
+resources, then we would conditionalize Primitive-Type as well.
+
+
+\f
+\section{Special-case VMR convert methods}
+
+ (defun continuation-tn (cont \&optional (check-p t))
+ ...)
+Return the TN which holds Continuation's first result value. In general
+this may emit code to load the value into a TN. If Check-P is true, then
+when policy indicates, code should be emitted to check that the value satisfies
+the continuation asserted type.
+
+ (defun result-tn (cont)
+ ...)
+Return the TN that Continuation's first value is delivered in. In general,
+may emit code to default any additional values to NIL.
+
+ (defun result-tns (cont n)
+ ...)
+Similar to Result-TN, except that it returns a list of N result TNs, one
+for each of the first N values.
+
+
+Nearly all open-coded functions should be handled using standard template
+selection. Some (all?) exceptions:
+ -- List, List* and Vector take arbitrary numbers of arguments. Could
+ implement Vector as a source transform. Could even do List in a transform
+ if we explicitly represent the stack args using %More-Args or something.
+ -- %Typep varies a lot depending on the type specifier. We don't want to
+ transform it, since we want %Typep as a canonical form so that we can do
+ type optimizations.
+ -- Apply is weird.
+ -- Funny functions emitted by the compiler: %Listify-Rest-Args, Arg,
+ %More-Args, %Special-Bind, %Catch, %Unknown-Values (?), %Unwind-Protect,
+ %Unwind, %%Primitive.
--- /dev/null
+@make [Manual]
+@device [PostScript]
+@use (database "/usr/lisp/scribe/database/")
+@libraryfile [Mathematics10]
+@libraryfile [ArpaCredit]
+@libraryfile [table]
+@libraryfile [spice]
+@style(FontFamily=TimesRoman)
+@style(Date="March 1952")
+
+@commandstring(pusharrow = "@jsym<L>")
+@define(f, facecode f)
+
+@commandstring(InstrSection = "@tabclear@tabset[.5 in, 3.0 in]")
+@form(Instr = "@*@\@Parm[name]@\")
+@form(BInstr ="@*@\@Parm[name]@+[*]@\")
+@string(DinkyMachine = "IBM RT PC")
+@begin[TitlePage]
+@begin[TitleBox]
+@blankspace(0.25in)
+@heading[Internal Design of CMU Common Lisp
+on the IBM RT PC]
+@begin[Center]
+@b{David B. McDonald
+Scott E. Fahlman
+Skef Wholey
+
+@value[Date]
+
+CMU-CS-87-157
+}
+@end[Center]
+@end[TitleBox]
+@center[@b<Abstract>]
+@begin[Text]
+CMU Common Lisp is an implementation of Common Lisp that currently runs on
+the IBM RT PC under Mach, a Berkeley Unix 4.3 binary compatible operating
+system. This document describes low level
+details of the implementation. In particular, it describes the data
+formats used for all Lisp objects, the assembler language routines
+(miscops) used to support compiled code, the function call and return
+mechanism, and other design information necessary to understand the
+underlying structure of the CMU Common Lisp implementation on the IBM RT PC
+under the Mach operating system.
+@end[Text]
+
+@begin[ResearchCredit]
+@ArpaCredit[Contract=Strategic87-90]
+@end[ResearchCredit]
+@end[TitlePage]
+
+@heading [Acknowledgments]
+
+This document is based heavily on the document @i[Revised Internal Design
+of Spice Lisp] by Skef Wholey, Scott Fahlman, and Joseph Ginder.
+
+The FASL file format was designed by Guy L. Steele Jr. and Walter van
+Roggen, and the appendix on this subject is their document with very few
+modifications.
+
+@chapter [Introduction]
+
+@section [Scope and Purpose]
+
+This document describes a new implementation of CMU Common Lisp (nee Spice
+Lisp) as it is implemented on the @value(DinkyMachine) running Mach, a
+Berkeley Unix 4.3 binary compatible operating system. This design is
+undergoing rapid change, and for the present is not guaranteed to
+accurately describe any past, present, or future implementation of CMU
+Common Lisp. All questions and comments on this material should be
+directed to David B. McDonald (David.McDonald@@CS.CMU.EDU).
+
+This document specifies the hand-coded assembler routines (miscops) and
+virtual memory architecture of the @value(DinkyMachine) CMU Common Lisp system.
+This is a working document, and it will change frequently as the system is
+developed and maintained. If some detail of the system does not agree with
+what is specified here, it is to be considered a bug.
+
+@section [Notational Conventions]
+@index [Bit numbering]
+@index [Byte numbering]
+CMU Common Lisp objects are 32 bits long. The high-order bit of each word is
+numbered 0; the low-order bit is numbered 31. If a word is broken into smaller
+units, these are packed into the word from left to right. For example, if we
+break a word into bytes, byte 0 would occupy bits 0-7, byte 1 would occupy
+8-15, byte 2 would occupy 16-23, and byte 3 would occupy 24-31.
+
+All CMU Common Lisp documentation uses decimal as the default radix; other
+radices will be indicated by a subscript (as in 77@-[8]) or by a clear
+statement of what radix is in use.
+
+@chapter [Data Types and Object Formats]
+
+@section [Lisp Objects]
+@index [Lisp objects]
+
+Lisp objects are 32 bits long. They come in 32 basic types, divided into three
+classes: immediate data types, pointer types, and forwarding pointer types.
+The storage formats are as follows:
+
+@index [Immediate object format]
+@index [Pointer object format]
+@begin [verbatim, group]
+
+@b[Immediate Data Types:]
+ 0 4 5 31
+------------------------------------------------------------------------
+| Type Code (5) | Immediate Data (27) |
+------------------------------------------------------------------------
+
+@b[Pointer and Forwarding Types:]
+ 0 4 5 6 7 29 31
+------------------------------------------------------------------------
+| Type Code (5) | Space Code (2) | Pointer (23) | Unused (2) |
+------------------------------------------------------------------------
+@end [verbatim]
+
+@section [Table of Type Codes]
+@index [Type codes]
+
+@begin [verbatim, group]
+
+Code Type Class Explanation
+---- ---- ----- -----------
+0 + Fixnum Immediate Positive fixnum, miscop code, etc.
+1 GC-Forward Pointer GC forward pointer, used during GC.
+4 Bignum Pointer Bignum.
+5 Ratio Pointer Two words: numerator, denominator.
+6 + Short Float Immediate Positive short flonum.
+7 - Short Float Immediate Negative short flonum.
+8 Single Float Pointer Single precision float.
+9 Double Float Pointer Double precision float (?).
+9 Long Float Pointer Long float.
+10 Complex Pointer Two words: real, imaginary parts.
+11 String Pointer Character string.
+12 Bit-Vector Pointer Vector of bits
+13 Integer-Vector Pointer Vector of integers
+14 General-Vector Pointer Vector of Lisp objects.
+15 Array Pointer Array header.
+16 Function Pointer Compiled function header.
+17 Symbol Pointer Symbol.
+18 List Pointer Cons cell.
+20 C. S. Pointer Pointer Pointer into control stack.
+21 B. S. Pointer Pointer Pointer into binding stack.
+26 Interruptible Immediate Marks a miscop as interruptible.
+27 Character Immediate Character object.
+28 Values-Marker Immediate Multiple values marker.
+29 Catch-All Immediate Catch-All object.
+30 Trap Immediate Illegal object trap.
+31 - Fixnum Immediate Negative fixnum.
+@end [verbatim]
+
+@section [Table of Space Codes]
+@index [Space codes]
+
+@begin [verbatim, group]
+
+Code Space Explanation
+---- ----- -----------
+0 Dynamic-0 Storage normally garbage collected, space 0.
+1 Dynamic-1 Storage normally garbage collected, space 1.
+2 Static Permanent objects, never moved or reclaimed.
+3 Read-Only Objects never moved, reclaimed, or altered.
+@end [verbatim]
+
+@section [Immediate Data Type Descriptions]
+
+@begin [description]
+
+@index [Fixnum format]
+Fixnum@\A 28-bit two's complement integer. The sign bit is stored redundantly
+in the top 5 bits of the word.
+
+@index [Short float format]
+Short-Float@\The sign bit is stored as part of the type code,
+allowing a 28 bit signed short float format. The format of short floating
+point numbers is:
+@begin [verbatim]
+ 0 3 4 5 12 13 31
+---------------------------------------------------------------
+| Type code (4) | Sign (1) | Exponent (8) | Mantissa (19) |
+---------------------------------------------------------------
+@end [verbatim]
+The floating point number is the same format as the @value(DinkyMachine)
+supports for single precision numbers, except it has been shifted right
+by four bits for the type code. The result of any operation is therefore
+truncated. Long floating point numbers are also available if you need
+more accuracy and better error propagation properties.
+
+@index [Character object]
+Character@\A character object holding a character code, control bits, and font
+in the following format:
+@begin [verbatim, group]
+ 0 4 6 7 8 15 16 23 24 31
+---------------------------------------------------------------
+| Type code (5) | Unused (3) | Font (8) | Bits (8) | Code (8) |
+---------------------------------------------------------------
+@end [verbatim]
+
+@index [Values-Marker]
+Values-Marker@\Used to mark the presence of multiple values on the stack. The
+low 16 bits indicate how many values are being returned. Note that only 65535
+values can be returned from a multiple-values producing form. These are pushed
+onto the stack in order, and the Values-Marker is returned in register A0.
+
+@index [Catch-All object]
+Catch-All@\Object used as the catch tag for unwind-protects. Special things
+happen when a catch frame with this as its tag is encountered during a throw.
+See section @ref[Catch] for details.
+
+@index[Trap]
+@index[Illegal object trap]
+Trap@\Illegal object trap. This value is used in symbols to signify an
+undefined value or definition.
+
+@index[Interruptible Marker]
+Interruptible-Marker@\Object used to mark a miscop as interruptible. This
+object is put in one of the registers and signals to the interrupt handler
+that the miscop can be interrupted safely. Only miscops that can take a long
+time (e.g., length when passed a circular list, system call miscops that
+may wait indefinitely) are marked this way.
+@end [description]
+
+@section [Pointer-Type Objects and Spaces]
+@index [Pointer object format]
+@index [Virtual memory]
+
+Each of the pointer-type lisp objects points into a different space in virtual
+memory. There are separate spaces for Bit-Vectors, Symbols, Lists, and so on.
+The 5-bit type-code provides the high-order virtual address bits for the
+object, followed by the 2-bit space code, followed by the 25-bit pointer
+address. This gives a 30-bit virtual address to a 32-bit word; since the
+@value(DinkyMachine) is a byte-addressed machine, the two low-order
+bits are 0. In effect we have carved a 30-bit space into a fixed set
+of 23-bit subspaces, not all of which are used.
+
+@index [Space codes]
+The space code divides each of the type spaces into four sub-spaces,
+as shown in the table above. At any given time, one of the dynamic
+spaces is considered newspace, while the other is oldspace.
+During a stop and copy garbage collection, a ``flip'' can be done, turning the
+old newspace into the new oldspace. All type-spaces are flipped at once.
+Allocation of new dynamic objects always occurs in newspace.
+
+@index [Static space]
+@index [Read-only space]
+Optionally, the user (or system functions) may allocate objects in
+static or read-only space. Such objects are never reclaimed once they
+are allocated -- they occupy the space in which they were initially
+allocated for the lifetime of the Lisp process. The advantage of
+static allocation is that the GC never has to move these objects,
+thereby saving a significant amount of work, especially if the objects
+are large. Objects in read-only space are static, in that they are
+never moved or reclaimed; in addition, they cannot be altered once
+they are set up. Pointers in read-only space may only point to
+read-only or static space, never to dynamic space. This saves even
+more work, since read-only space does not need to be scavenged, and
+pages of read-only material do not need to be written back onto the
+disk during paging.
+
+Objects in a particular type-space will contain either pointers to
+garbage-collectible objects or words of raw non-garbage-collectible bits, but
+not both. Similarly, a space will contain either fixed-length objects or
+variable-length objects, but not both. A variable-length object always
+contains a 24-bit length field right-justified in the first word, with
+the positive fixnum type-code in the high-order five bits. The remaining three
+bits can be used for sub-type information. The length field gives the
+size of the object in 32-bit words, including the header word. The
+garbage collector needs this information when the object is moved, and
+it is also useful for bounds checking.
+
+The format of objects in each space are as follows:
+
+@begin [description]
+@index [Symbol]
+@index [Value cell]
+@index [Definition cell]
+@index [Property list cell]
+@index [Plist cell]
+@index [Print name cell]
+@index [Pname cell]
+@index [Package cell]
+Symbol@\Each symbol is represented as a
+fixed-length block of boxed Lisp cells. The number of cells
+per symbol is 5, in the following order:
+@begin [verbatim, group]
+0 Value cell for shallow binding.
+1 Definition cell: a function or list.
+2 Property list: a list of attribute-value pairs.
+3 Print name: a string.
+4 Package: the obarray holding this symbol.
+@end [verbatim]
+
+@index [List cell]
+List@\A fixed-length block of two boxed Lisp cells, the CAR and the CDR.
+
+@index [General-Vector format]
+@index [G-Vector format]
+@index [Vector format]
+General-Vector@\Vector of lisp objects, any length. The first word is a fixnum
+giving the number of words allocated for the vector (up to 24 bits). The
+highest legal index is this number minus 2. The second word is vector entry 0,
+and additional entries are allocated contiguously in virtual memory. General
+vectors are sometimes called G-Vectors. (See section @ref[Vectors] for further
+details.)
+
+@index [Integer-Vector format]
+@index [I-Vector format]
+@index [Vector format]
+Integer-Vector@\Vector of integers, any length. The 24 low bits of the first
+word give the allocated length in 32-bit words. The low-order 28 bits of the
+second word gives the length of the vector in entries, whatever the length of
+the individual entries may be. The high-order 4 bits of the second word
+contain access-type information that yields, among other things, the number of
+bits per entry. Entry 0 is left-justified in the third word of the vector.
+Bits per entry will normally be powers of 2, so they will fit neatly into
+32-bit words, but if necessary some empty space may be left at the low-order
+end of each word. Integer vectors are sometimes called I-Vectors. (See
+section @ref[Vectors] for details.)
+
+@index [Bit-Vector format]
+@index [Vector format]
+Bit-Vector@\Vector of bits, any length. Bit-Vectors are represented in a form
+identical to I-Vectors, but live in a different space for efficiency reasons.
+
+@index [Bignum format]
+@label [Bignums]
+Bignum@\Bignums are infinite-precision integers, represented in a format
+identical to G-Vectors. Each bignum is stored as a series of 32-bit words,
+with the low-order word stored first. The representation is two's complement,
+but the sign of the number is redundantly encoded in the type field of the
+fixnum in the header word. If this fixnum is non-negative, then so is the
+bignum, if it is negative, so is the bignum.
+
+@index [Flonum format]
+@index [Flonum formats]
+@index [Floating point formats]
+Floats@\Floats are stored as two or more consecutive words of bits, in the
+following format:
+@begin [verbatim, group]
+---------------------------------------------------------------
+| Header word, used only for GC forward pointers. |
+---------------------------------------------------------------
+| Appropriate number of 32-bit words in machine format |
+---------------------------------------------------------------
+@end [verbatim]
+The number of words used to represent a floating point number is one plus the
+size of the floating point number being stored. The floating point numbers
+will be represented in whatever format the @value(DinkyMachine) expects. The
+extra header word is needed so that a valid floating point number is not
+mistaken for a gc-forward pointer during a garbage collection.
+
+@index [Ratio format]
+Ratio@\Ratios are stored as two consecutive words of Lisp objects, which should
+both be integers.
+
+@index [Complex number format]
+Complex@\Complex numbers are stored as two consecutive words of Lisp objects,
+which should both be numbers.
+
+@index [Array format]
+Array@\This is actually a header which holds the accessing and
+other information about the array. The actual array contents are held in a
+vector (either an I-Vector or G-Vector) pointed to by an entry in
+the header. The header is identical in format to a G-Vector. For
+details on what the array header contains, see section @ref[Arrays].
+
+@index [String format]
+String@\A vector of bytes. Identical in form to I-Vectors with the access type
+always 8-Bit. However, instead of accepting and returning fixnums, string
+accesses accept and return character objects. Only the 8-bit code field is
+actually stored, and the returned character object always has bit and font
+values of 0.
+
+@index [Function object format]
+Function @\A compiled CMU Common Lisp function consists of both lisp
+objects and raw bits for the code. The Lisp objects are stored in
+the Function space in a format identical to that used for general
+vectors, with a 24-bit length field in the first word. This object
+contains assorted parameters needed by the calling machinery, a
+pointer to an 8-bit I-Vector containing the compiled code, a number
+of pointers to symbols used as special variables within the function,
+and a number of lisp objects used as constants by the function.
+@end [description]
+
+@section [Forwarding Pointers]
+@index [Forwarding pointers]
+
+@begin [description]
+@index [GC-Forward pointer]
+GC-Forward@\When a data structure is transported into newspace, a GC-Forward
+pointer is left behind in the first word of the oldspace object. This points
+to the same type-space in which it is found. For example, a GC-Forward in
+G-Vector space points to a structure in the G-Vector newspace. GC-Forward
+pointers are only found in oldspace.
+@end [description]
+
+@section [System and Stack Spaces]
+@index [System table space]
+@index [Stack spaces]
+@index [Control stack space]
+@index [Binding stack space]
+@index [Special binding stack space]
+
+The virtual addresses below 08000000@-[16] are not occupied by Lisp objects,
+since Lisp objects with type code 0 are positive fixnums. Some of this space
+is used for other purposes by Lisp. A couple of pages (4096 byte pages)
+at address 00100000@-[16] contain tables that Lisp needs to access
+frequently. These include the allocation table, the active-catch-frame,
+information to link to C routines, etc. Memory at location 00200000@-[16]
+contains code for various miscops. Also, any C code loaded into a running
+Lisp process is loaded after the miscops. The format of the allocation
+table is described in chapter @ref[Alloc-Chapter].
+
+The control stack grows upward (toward higher addresses) in memory,
+and is a framed stack. It contains only general Lisp objects (with
+some random things encoded as fixnums). Every object
+pointed to by an entry on this stack is kept alive. The frame for a
+function call contains an area for the function's arguments, an area
+for local variables, a pointer to the caller's frame, and a pointer
+into the binding stack. The frame for a Catch form contains similar
+information. The precise stack format can be found in chapter
+@ref[Runtime].
+
+The special binding stack grows downward. This stack is used to hold
+previous values of special variables that have been bound. It grows and
+shrinks with the depth of the binding environment, as reflected in the
+control stack. This stack contains symbol-value pairs, with only boxed
+Lisp objects present.
+
+All Lisp objects are allocated on word boundaries, since the
+@value(DinkyMachine) can only access words on word boundaries.
+
+@section [Vectors and Arrays]
+@label [Vectors]
+@index [Vectors]
+
+Common Lisp arrays can be represented in a few different ways in CMU Common
+Lisp -- different representations have different performance advantages.
+Simple general vectors, simple vectors of integers, and simple strings are
+basic CMU Common Lisp data types, and access to these structures is quicker
+than access to non-simple (or ``complex'') arrays. However, all
+multi-dimensional arrays in CMU Common Lisp are complex arrays, so
+references to these are always through a header structure.
+
+@subsection [General Vectors]
+@index [General-Vector format]
+
+G-Vectors contain Lisp objects. The format is as follows:
+
+@begin [verbatim, group]
+------------------------------------------------------------------
+| Fixnum code (5) | Subtype (3) | Allocated length (24) |
+------------------------------------------------------------------
+| Vector entry 0 (Additional entries in subsequent words) |
+------------------------------------------------------------------
+@end [verbatim]
+
+The first word of the vector is
+a header indicating its length; the remaining words hold the boxed entries of
+the vector, one entry per 32-bit word. The header word is of type fixnum. It
+contains a 3-bit subtype field, which is used to indicate several special types
+of general vectors. At present, the following subtype codes are defined:
+
+@index [DEFSTRUCT]
+@index [Hash tables]
+@begin [itemize, spread 0, spacing 1]
+0 Normal. Used for assorted things.
+
+1 Named structure created by DEFSTRUCT, with type name in entry 0.
+
+2 EQ Hash Table, last rehashed in dynamic-0 space.
+
+3 EQ Hash Table, last rehashed in dynamic-1 space.
+
+4 EQ Hash Table, must be rehashed.
+@end [itemize]
+
+Following the subtype is a 24-bit field indicating how many 32-bit words are
+allocated for this vector, including the header word. Legal indices into the
+vector range from zero to the number in the allocated length field minus 2,
+inclusive. Normally, the index is checked on every access to the vector.
+Entry 0 is stored in the second word of the vector, and subsequent entries
+follow contiguously in virtual memory.
+
+Once a vector has been allocated, it is possible to reduce its length by using
+the Shrink-Vector miscop, but never to increase its length, even back to
+the original size, since the space freed by the reduction may have been
+reclaimed. This reduction simply stores a new smaller value in the length
+field of the header word.
+
+It is not an error to create a vector of length 0, though it will always be an
+out-of-bounds error to access such an object. The maximum possible length for
+a general vector is 2@+[24]-2 entries, and that can't fit in the available
+space. The maximum length is 2@+[23]-2 entries, and that is only possible if
+no other general vectors are present in the space.
+
+@index [Bignum Format]
+Bignums are identical in format to G-Vectors although each entry is a 32-bit
+integer, and thus only assembler routines should ever access an entry.
+
+@index [Function object format]
+@index [Array format]
+Objects of type Function and Array are identical in format to
+general vectors, though they have their own spaces.
+
+@subsection [Integer Vectors]
+@index [Integer-Vector format]
+
+I-Vectors contain unboxed items of data, and their format is more complex. The
+data items come in a variety of lengths, but are of constant length within a
+given vector. Data going to and from an I-Vector are passed as Fixnums, right
+justified. Internally these integers are stored in packed form, filling 32-bit
+words without any type-codes or other overhead. The format is as follows:
+
+@begin [verbatim, group]
+----------------------------------------------------------------
+| Fixnum code (5) | Subtype (3) | Allocated length (24) |
+----------------------------------------------------------------
+| Access type (4) | Number of entries (28) |
+----------------------------------------------------------------
+| Entry 0 left justified |
+----------------------------------------------------------------
+@end [verbatim]
+
+The first word of an I-Vector
+contains the Fixnum type-code in the top 5 bits, a 3-bit subtype code in the
+next three bits, and the total allocated length of the vector (in 32-bit words)
+in the low-order 24 bits. At present, the following subtype codes are defined:
+@begin [itemize, spread 0, spacing 1]
+0 Normal. Used for assorted things.
+
+1 Code. This is the code-vector for a function object.
+@end [itemize]
+
+The second word of the vector is the one that is looked at every
+time the vector is accessed. The low-order 28 bits of this word
+contain the number of valid entries in the vector, regardless of how
+long each entry is. The lowest legal index into the vector is always
+0; the highest legal index is one less than this number-of-entries
+field from the second word. These bounds are checked on every access.
+Once a vector is allocated, it can be reduced in size but not increased.
+The Shrink-Vector miscop changes both the allocated length field
+and the number-of-entries field of an integer vector.
+
+@index [Access-type codes]
+The high-order 4 bits of the second word contain an access-type code
+which indicates how many bits are occupied by each item (and therefore
+how many items are packed into a 32-bit word). The encoding is as follows:
+@begin [verbatim, group]
+0 1-Bit 8 Unused
+1 2-Bit 9 Unused
+2 4-Bit 10 Unused
+3 8-Bit 11 Unused
+4 16-Bit 12 Unused
+5 32-Bit 13 Unused
+6 Unused 14 Unused
+7 Unused 15 Unused
+@end [verbatim]
+
+In I-Vectors, the data items are packed into the third and subsequent
+words of the vector. Item 0 is left justified in the third word,
+item 1 is to its right, and so on until the allocated number of items
+has been accommodated. All of the currently-defined access types
+happen to pack neatly into 32-bit words, but if this should not be
+the case, some unused bits would remain at the right side of each
+word. No attempt will be made to split items between words to use up
+these odd bits. When allocated, an I-Vector is initialized to all
+0's.
+
+As with G-Vectors, it is not an error to create an I-Vector of length
+0, but it will always be an error to access such a vector. The
+maximum possible length of an I-Vector is 2@+[28]-1 entries or
+2@+[23]-3 words, whichever is smaller.
+
+@index [String format]
+Objects of type String are identical in format to I-Vectors, though they have
+their own space. Strings always have subtype 0 and access-type 3 (8-Bit).
+Strings differ from normal I-Vectors in that the accessing miscops accept
+and return objects of type Character rather than Fixnum.
+
+@subsection [Arrays]
+@label [Arrays]
+@index [Arrays]
+
+An array header is identical in form to a G-Vector. Like any G-Vector, its
+first word contains a fixnum type-code, a 3-bit subtype code, and a 24-bit
+total length field (this is the length of the array header, not of the vector
+that holds the data). At present, the subtype code is always 0. The entries
+in the header-vector are interpreted as follows:
+
+@index [Array header format]
+@begin [description]
+0 Data Vector @\This is a pointer to the I-Vector, G-Vector, or string that
+contains the actual data of the array. In a multi-dimensional array, the
+supplied indices are converted into a single 1-D index which is used to access
+the data vector in the usual way.
+
+1 Number of Elements @\This is a fixnum indicating the number of elements for
+which there is space in the data vector.
+
+2 Fill Pointer @\This is a fixnum indicating how many elements of the data
+vector are actually considered to be in use. Normally this is initialized to
+the same value as the Number of Elements field, but in some array applications
+it will be given a smaller value. Any access beyond the fill pointer is
+illegal.
+
+3 Displacement @\This fixnum value is added to the final code-vector index
+after the index arithmetic is done but before the access occurs. Used for
+mapping a portion of one array into another. For most arrays, this is 0.
+
+4 Range of First Index @\This is the number of index values along the first
+dimension, or one greater than the largest legal value of this index (since the
+arrays are always zero-based). A fixnum in the range 0 to 2@+[24]-1. If any
+of the indices has a range of 0, the array is legal but will contain no data
+and accesses to it will always be out of range. In a 0-dimension array, this
+entry will not be present.
+
+5 - N Ranges of Subsequent Dimensions
+@end [description]
+
+The number of dimensions of an array can be determined by looking at the length
+of the array header. The rank will be this number minus 6. The maximum array
+rank is 65535 - 6, or 65529.
+
+The ranges of all indices are checked on every access, during the conversion to
+a single data-vector index. In this conversion, each index is added to the
+accumulating total, then the total is multiplied by the range of the following
+dimension, the next index is added in, and so on. In other words, if the data
+vector is scanned linearly, the last array index is the one that varies most
+rapidly, then the index before it, and so on.
+
+@section [Symbols Known to the Assembler Routines]
+@label [Known-Objects]
+
+A large number of symbols will be pre-defined when a CMU Common Lisp system
+is fired up. A few of these are so fundamental to the operation of the
+system that their addresses have to be known to the assembler routines.
+These symbols are listed here. All of these symbols are in static space,
+so they will not move around.
+
+@begin [description]
+@index [NIL]
+NIL @\94000000@-[16] The value of NIL is always NIL; it is an error
+to alter it. The plist of NIL is always NIL; it is an error to alter
+it. NIL is unique among symbols in that it is stored in Cons cell
+space and thus you can take its CAR and CDR, yielding NIL in either
+case. NIL has been placed in Cons cell space so that the more common
+operations on lists will yield the desired results. This slows down
+some symbol operations but this should be insignificant compared to
+the savings in list operations. A test for NIL for the
+@value(DinkyMachine) is:
+@begin(Example)
+ xiu R0,P,X'9400'
+ bz IsNIL or bnz IsNotNIL
+@end(Example)
+
+@index [T]
+T @\8C000000@-[16] The value of T is always T; it is an error
+to alter it. A similar sequence of code as for NIL above can test for T,
+if necessary.
+
+@index [%SP-Internal-Apply]
+%SP-Internal-Apply @\8C000014@-[16] The function stored in the definition cell
+of this symbol is called by an assembler routine whenever compiled code calls
+an interpreted function.
+
+@index [%SP-Internal-Error]
+%SP-Internal-Error @\8C000028@-[16] The function stored in the definition cell
+of this symbol is called whenever an error is detected during the execution of
+an assembler routine. See section @ref[Errors] for details.
+
+@index [%SP-Software-Interrupt-Handler]
+%SP-Software-Interrupt-Handler @\8C00003C@-[16] The function stored in the
+definition cell of this symbol is called whenever a software interrupt occurs.
+See section @ref[Interrupts] for details.
+
+@index [%SP-Internal-Throw-Tag]
+%SP-Internal-Throw-Tag @\8C000050@-[16] This symbol is bound to the tag being
+thrown when a Catch-All frame is encountered on the stack. See section
+@ref[Catch] for details.
+
+@index [%Initial-function]
+%Initial-function@\8c000064@-[16] This symbol's function cell should contain
+a function that is called when the initial core image is started. This
+function should initialize all the data structures that Lisp needs to run.
+
+@index [%Link-table-header]
+%Link-table-header@\8c000078@-[16] This symbol's value cell contains a pointer
+to the link table information.
+
+@index [Current-allocation-space]
+Current-allocation-space@\8c00008c@-[16] This symbol's value cell contains
+an encoded form of the current space that new lisp objects are to be allocated
+in.
+
+@index [%SP-bignum/fixnum]
+%SP-bignum/fixnum@\8c0000a0@-[16] This function is invoked by the miscops
+when a division of a bignum by a fixnum results in a ratio.
+
+@index [%SP-fixnum/bignum]
+%SP-bignum/bignum@\8c0000b4@-[16] This
+function is invoked by the miscops when a division of a fixnum by a
+bignum results in a ratio.
+
+@index [%SP-bignum/bignum]
+%SP-bignum/bignum@\8c0000c8@-[16] This function is invoked by the miscops
+when a division of a bignum by a bignum results in a ratio.
+
+@index [%SP-abs-ratio]
+%SP-abs-ratio@\8c0000dc@-[16] This function is invoked by the miscops
+when the absolute value of a ratio is taken.
+
+@index [%SP-abs-complex]
+%SP-abs-complex@\8c0000f0@-[16] This function is invoked by the miscops
+when the absolute value of a complex is taken.
+
+@index [%SP-negate-ratio]
+%SP-negate-ratio@\8c000104@-[16] This function is invoked by the miscops
+when a ratio is to be negated.
+
+@index [%SP-negate-complex]
+%SP-negate-ratio@\8c000118@-[16] This function is invoked by the miscops
+when a complex is to be negated.
+
+@index[%SP-integer+ratio]
+%SP-integer+ratio@\8c00012c@-[16] This function is invoked by the miscops
+when a fixnum or bignum is added to a ratio.
+
+@index[%SP-ratio+ratio]
+%SP-ratio+ratio@\8c000140@-[16] This function is invoked by the miscops
+when a ratio is added to a ratio.
+
+@index[%SP-complex+number]
+%SP-complex+number@\8c000154@-[16] This function is invoked by the miscops
+when a complex is added to a number.
+
+@index[%SP-number+complex]
+%SP-number+complex@\8c000168@-[16] This function is invoked by the miscops
+when a number is added to a complex.
+
+@index[%SP-complex+complex]
+%SP-complex+complex@\8c00017c@-[16] This function is invoked by the miscops
+when a number is added to a complex.
+
+@index[%SP-1+ratio]
+%SP-1+ratio@\8c000190@-[16] This function is invoked by the miscops when
+1 is added to a ratio.
+
+@index[%SP-1+complex]
+%SP-1+complex@\8c000190@-[16] This function is invoked by the miscops when
+1 is added to a complex.
+
+@index[%SP-ratio-integer]
+%SP-ratio-integer@\8c0001b8@-[16] This function is invoked by the miscops
+when an integer is subtracted from a ratio.
+
+@index[%SP-ratio-ratio]
+%SP-ratio-ratio@\8c0001cc@-[16] This function is invoked by the miscops
+when an ratio is subtracted from a ratio.
+
+@index[%SP-complex-number]
+%SP-complex-number@\8c0001e0@-[16] This function is invoked by the miscops
+when a complex is subtracted from a number.
+
+@index[%SP-number-complex]
+%SP-number-complex@\8c0001f4@-[16] This function is invoked by the miscops
+when a number is subtracted from a complex.
+
+@index[%SP-complex-complex]
+%SP-complex-complex@\8c000208@-[16] This function is invoked by the miscops
+when a complex is subtracted from a complex.
+
+@index[%SP-1-complex]
+%SP-1-complex@\8c000230@-[16] This function is invoked by the miscops when
+1 is subtracted from a complex.
+
+@index[%SP-ratio*ratio]
+%SP-ratio*ratio@\8c000244@-[16] This function is invoked by the miscops to
+multiply two ratios.
+
+@index[%SP-number*complex]
+%SP-number*complex@\8c000258@-[16] This function is invoked by the miscops to
+multiply a number by a complex.
+
+@index[%SP-complex*number]
+%SP-complex*number@\8c00026c@-[16] This function is invoked by the miscops to
+multiply a complex by a number.
+
+@index[%SP-complex*complex]
+%SP-complex*complex@\8c000280@-[16] This function is invoked by the miscops
+to multiply a complex by a complex.
+
+@index[%SP-integer/ratio]
+%SP-integer/ratio@\8c000294@-[16] This function is invoked by the miscops to
+divide an integer by a ratio.
+
+@index[%SP-ratio/integer]
+%SP-ratio/integer@\8c0002a8@-[16] This function is invoked by the miscops to
+divide a ratio by an integer.
+
+@index[%SP-ratio/ratio]
+%SP-ratio/ratio@\8c0002bc@-[16] This function is invoked by the miscops to
+divide a ratio by a ratio.
+
+@index[%SP-number/complex]
+%SP-number/complex@\8c0002d0@-[16] This function is invoked by the miscops to
+divide a number by a complex.
+
+@index[%SP-complex/number]
+%SP-complex/number@\8c0002e4@-[16] This function is invoked by the miscops to
+divide a complex by a number.
+
+@index[%SP-complex/complex]
+%SP-complex/complex@\8c0002f8@-[16] This function is invoked by the miscops
+to divide a complex by a complex.
+
+@index[%SP-integer-truncate-ratio]
+%SP-integer-truncate-ratio@\8c00030c@-[16] This function is invoked by the
+miscops to truncate an integer by a ratio.
+
+@index[%SP-ratio-truncate-integer]
+%SP-ratio-truncate-integer@\8c000320@-[16] This function is invoked by the
+miscops to truncate a ratio by an integer.
+
+@index[%SP-ratio-truncate-ratio]
+%SP-ratio-truncate-ratio@\8c000334@-[16] This function is invoked by the
+miscops to truncate a ratio by a ratio.
+
+@index[%SP-number-truncate-complex]
+%SP-number-truncate-complex@\8c000348@-[16] This function is invoked by the
+miscops to truncate a number by a complex.
+
+@index[%SP-complex-truncate-number]
+%SP-complex-truncate-number@\8c00035c@-[16] This function is invoked by the
+miscops to truncate a complex by a number.
+
+@index[%SP-complex-truncate-complex]
+%SP-complex-truncate-complex@\8c000370@-[16] This function is invoked by
+the miscops to truncate a complex by a complex.
+
+@index[maybe-gc]
+Maybe-GC@\8c000384@-[16] This function may be invoked by any miscop that
+does allocation. This function determines whether it is time to garbage
+collect or not. If it is it performs a garbage collection. Whether it
+invokes a garbage collection or not, it returns the single argument passed
+to it.
+
+@index[Lisp-environment-list]
+Lisp-environment-list@\8c000398@-[16] The value of this symbol is
+set to the a list of the Unix environment strings passed into the Lisp
+process. This list by Lisp to obtain various environment information, such
+as the user's home directory, etc.
+
+@index[Call-lisp-from-c]
+Call-lisp-from-C@\8c0003ac@-[16] This function is called whenever a
+C function called by Lisp tries to call a Lisp function.
+
+@index[Lisp-command-line-list]
+Lisp-command-line-list@\8c0003c0@-[16] The value of this symbol is
+set to the list of strings passed into the Lisp process as the command
+line.
+
+@index[*Nameserverport*]
+*Nameserverport*@\8c0003d4@-[16] The value of this symbol is set to
+the C global variable name_server_port. This allows Lisp to access the
+name server.
+
+@index[*Ignore-Floating-Point-Underflow*]
+*Ignore-Floating-Point-Underflow*@\8c0003e8@-[16] If the the value of this
+symbol is NIL then an error is signalled when floating point underflow
+occurs, otherwise the operation quietly returns zero.
+@End[description]
+
+@chapter [Runtime Environment]
+@index [Runtime Environment]
+@label [Runtime]
+
+@section [Register Allocation]
+@index [Register allocation]
+To describe the assembler support routines in chapter @ref[Instr-Chapter] and
+the complicated
+control conventions in chapter @ref[Control-Conventions] requires that we talk
+about the allocation of the 16 32-bit general purpose registers provided
+by the @value(DinkyMachine).
+@begin [description]
+@index [Program-Counter register]
+Program-Counter (PC) [R15]@\This register contains an index into the current
+code vector when a Lisp function is about to be called. When a miscop is
+called, it contains the return address. It may be used as a super temporary
+between miscop and function calls.
+
+@index [Active-Function-Pointer register]
+Active-Function-Pointer (AF) [R14]@\This register contains a pointer to the
+active function object. It is used to access the symbol and constant area for
+the currently running function.
+
+@index [Active-Frame-Pointer register]
+Active-Frame-Pointer (FP) [R13]@\This register contains a pointer to the
+current active frame on the control stack. It is used to access the arguments
+and local variables stored on the control stack.
+
+@index [Binding-Stack-Pointer register]
+Binding-Stack-Pointer (BS) [R12]@\This register contains the current binding
+stack pointer. The binding stack is a downward growing stack and follows
+a decrement-write/increment-read discipline.
+
+@index [Local registers]
+Local registers (L0-L4) [R7-R11]@\These registers contain locals and saved
+arguments for the currently executing function. Functions may use these
+registers, so that stack accesses can be reduced, since a stack access is
+relatively expensive compared to a register access.
+
+@index [Argument registers]
+Argument register (A0, A1, A2) [R1, R3, R5]@\These registers contain arguments
+to a function or miscop that has just been called. On entry to a function
+or miscop, they contain the first three arguments. The first thing a function
+does is to move the contents of these registers into the local registers.
+
+@index [Miscop argument register]
+Miscop argument register (A3) [R4]@\This register is used to pass a fourth
+argument to miscops requiring four or more arguments. It is also used as a
+super temporary by the compiler.
+
+@index [Control-Stack-Pointer register]
+Control-Stack-Pointer (CS) [R6]@\The stack pointer for the control stack, an
+object of type Control-Stack-Pointer. Points to the last used word in
+Control-Stack space; this upward growing stack uses a
+increment-write/read-decrement discipline.
+
+@index [Non-Lisp temporary registers]
+Non-Lisp temporary registers (NL0, NL1) [R0, R2]@\These registers are used to
+contain non-Lisp values. They will normally be used during miscop calls, but
+may also be used in in-line code to contain temporary data. These are the only
+two registers never examined by the garbage collector, so no pointers to Lisp
+objects should be stored here (since they won't get updated during a garbage
+collection).
+@end [description]
+
+@section [Function Object Format]
+@label [Fn-Format]
+
+Each compiled function is represented in the machine as a Function
+Object. This is identical in form to a G-Vector of lisp objects, and
+is treated as such by the garbage collector, but it exists in a
+special function space. (There is no particular reason for this
+distinction. We may decide later to store these things in G-Vector
+space, if we become short on spaces or have some reason to believe
+that this would improve paging behavior.) Usually, the function
+objects and code vectors will be kept in read-only space, but nothing
+should depend on this; some applications may create, compile, and
+destroy functions often enough to make dynamic allocation of function
+objects worthwhile.
+
+@index [Code vector]
+@index [Constants in code] The function object contains a vector of
+header information needed by the function-calling mechanism: a
+pointer to the I-Vector that holds the actual code. Following this
+is the so-called ``symbols and constants'' area. The first few
+entries in this area are fixnums that give the offsets into the code
+vector for various numbers of supplied arguments. Following this
+begin the true symbols and constants used by the function. Any
+symbol used by the code as a special variable.
+Fixnum constants can be generated faster
+with in-line code than they can be accessed from the function-object,
+so they are not stored in the constants area.
+
+The subtype of the G-Vector header indicates the type of the function:
+@begin(Itemize, spacing 1, spread 0)
+0 - A normal function (expr).
+
+1 - A special form (fexpr).
+
+2 - A defmacro macroexpansion function.
+
+3 - An anonymous expr. The name is the name of the parent function.
+
+4 - A compiled top-level form.
+@end(Itemize)
+Only the fexpr information has any real meaning to the system. The rest
+is there for the printer and anyone else who cares.
+
+
+After the one-word G-Vector header, the entries of the function object
+are as follows:
+
+@begin [verbatim, group]
+0 Name of the innermost enclosing named function.
+1 Pointer to the unboxed Code vector holding the instructions.
+2 A fixnum with bit fields as follows:
+ 24 - 31: The minimum legal number of args (0 to 255).
+ 16 - 23: The maximum number of args, not counting &rest (0 to 255).
+ The fixnum has a negative type code, if the function accepts a &rest
+ arg and a positive one otherwise.
+3 A string describing the source file from which the function was defined.
+ See below for a description of the format.
+4 A string containing a printed representation of the argument list, for
+ documentation purposes. If the function is a defmacro macroexpansion
+ function, the argument list will be the one originally given to defmacro
+ rather than the actual arglist to the expansion function.
+5 The symbols and constants area starts here.
+ This word is entry 0 of the symbol/constant area.
+ The first few entries in this area are fixnums representing the
+ code-vector entry points for various numbers of optional arguments.
+@end [verbatim]
+
+@section [Defined-From String Format]
+@label [Defined-From-String-Format]
+@index [Defined-From String Format]
+
+The defined-from string may have any of three different formats, depending
+on which of the three compiling functions compiled it:
+@begin(Description)
+compile-file "@i[filename user-time universal-time]"@\ The @i[filename] is
+the namestring of the truename of the file the function was defined from.
+The time is the file-write-date of the file.
+
+compile "Lisp on @i[user-time], machine @i[machine universal-time]"@\
+The time is the time that the function was compiled. @i[Machine] is the
+machine-instance of the machine on which the compilation was done.
+
+compile-from-stream "@i[stream] on @i[user-time], machine @i[machine-instance
+universal-time]"@\@i[Stream] is the printed representation of the stream
+compiled from. The time is the time the compilation started.
+@end(Description)
+
+An example of the format of @i[user-time] is 6-May-86 1:04:44. The
+@i[universal-time] is the same time represented as a decimal integer.
+It should be noted that in each case, the universal time is the last
+thing in the string.
+
+@section [Control-Stack Format]
+@label [Control-Stack-Format]
+@index [Control-stack format]
+
+The CMU Common Lisp control stack is a framed stack. Call frames, which hold
+information for function calls, are intermixed with catch frames, which hold
+information used for non-local exits. In addition, the control stack is used
+as a scratchpad for random computations.
+
+@subsection [Call Frames]
+@index [Open frame]
+@index [Active frame]
+
+At any given time, the machine contains pointers to the current top
+of the control stack and the start of the current active frame (in
+which the current function is executing). In addition, there is a
+pointer to the current top of the special binding stack. CMU Common Lisp
+on the Perq also has a pointer to an open frame. An open frame is
+one which has been partially built, but which is still having
+arguments for it computed. When all the arguments have been computed
+and saved on the frame, the function is then started. This means
+that the call frame is completed, becomes the current active frame,
+and the function is executed. At this time, special variables may be
+bound and the old values are saved on the binding stack. Upon
+return, the active frame is popped away and the result is either sent
+as an argument to some previously opened frame or goes to some other
+destination. The binding stack is popped and old values are
+restored.
+
+On the @value(DinkyMachine), open frames still exist, however, no register is
+allocated to point at the most recent one. Instead, a count of the arguments
+to the function is kept. In most cases, a known fixed number of arguments are
+passed to a function, and this is all that is needed to calculate the correct
+place to set the active frame pointer.
+In some cases, it is not as simple, and runtime calculations are necessary to
+set up the frame pointer. These calculations are simple except in some very
+strange cases.
+
+The active frame contains pointers to the previously-active frame and
+to the point to which the binding stack will be popped
+on exit, among other things. Following this is a vector of storage locations
+for the function's arguments and local variables. Space is allocated for the
+maximum number of arguments that the function can take, regardless of how many
+are actually supplied.
+
+In an open frame, stack space is allocated up to the point where the arguments
+are stored. Nothing is stored in the frame
+at this time. Thus, as arguments are computed, they can simply be pushed on
+the stack. Since the first three arguments are passed in registers, it is
+sometimes necessary to save these values when succeeding arguments are
+complicated. When the function is finally started, the remainder of the frame
+is built (including storing all the
+registers that must be saved). A call frame looks like this:
+@begin [verbatim, group]
+0 Saved local 0 register.
+1 Saved local 1 register.
+2 Saved local 2 register.
+3 Saved local 3 register.
+4 Saved local 4 register.
+5 Pointer to previous binding stack.
+6 Pointer to previous active frame.
+7 Pointer to previous active function.
+8 Saved PC of caller. A fixnum.
+9 Args-and-locals area starts here. This is entry 0.
+@end [verbatim]
+The first slot is pointed to by the Active-Frame register if this frame is
+currently active.
+
+@subsection [Catch Frames]
+@index [Catch]
+@index [Catch frames]
+
+Catch frames contain much of the same information that call frames
+do, and have a very similar format. A catch frame holds the function
+object for the current function, a stack pointer to the current
+active frame, a pointer to the current top of the binding stack, and
+a pointer to the previous catch frame. When a Throw occurs, an
+operation similar to returning from this catch frame (as if it
+were a call frame) is performed, and the stacks are unwound to the
+proper place for continued execution in the current function. A
+catch frame looks like this:
+@begin [verbatim, group]
+0 Pointer to current binding stack.
+1 Pointer to current active frame.
+2 Pointer to current function object.
+3 Destination PC for a Throw.
+4 Tag caught by this catch frame.
+5 Pointer to previous catch frame.
+@end [verbatim]
+The conventions used to manipulate call and catch frames are described in
+chapter @ref[Control-Conventions].
+
+@section [Binding-Stack Format]
+@index [Binding stack format]
+
+Each entry of the binding-stack consists of two boxed (32-bit) words. Pushed
+first is a pointer to the symbol being bound. Pushed second is the symbol's
+old value (any boxed item) that is to be restored when the binding stack is
+popped.
+
+@chapter [Storage Management]
+@index [Storage management]
+@index [Garbage Collection]
+@label [Alloc-Chapter]
+
+@index [Free-Storage pointer]
+@index [Clean-Space pointer]
+New objects are allocated from the lowest unused addresses within the specified
+space. Each allocation call specifies how many words are wanted, and a
+Free-Storage pointer is incremented by that amount. There is one of these
+Free-Storage pointers for each space, and it points to the lowest free address
+in the space. There is also a Clean-Space pointer associated with each space
+that is used during garbage collection. These pointers are stored in a table
+which is indexed by the type and space code. The
+address of the Free-Storage pointer for a given space is
+@begin[verbatim]
+ (+ alloc-table-base (lsh type 5) (lsh space 3)).
+@end[verbatim]
+The address of the Clean-Space pointer is
+@begin[verbatim]
+ (+ alloc-table-base (lsh type 5) (lsh space 3) 4).
+@end[verbatim]
+
+Common Lisp on the @value(DinkyMachine) uses a stop-and-copy garbage collector
+to reclaim storage. The Collect-Garbage miscop performs a full GC. The
+algorithm used is a degenerate form of Baker's incremental garbage collection
+scheme. When the Collect-Garbage miscop is executed, the following
+happens:
+@begin[enumerate]
+The current newspace becomes oldspace, and the current oldspace becomes
+newspace.
+
+The newspace Free-Storage and Clean-Space pointers are initialized to point to
+the beginning of their spaces.
+
+The objects pointed at by contents of all the registers containing Lisp objects
+are transported if necessary.
+
+The control stack and binding stack are scavenged.
+
+Each static pointer space is scavenged.
+
+Each new dynamic space is scavenged. The scavenging of the dynamic spaces
+continues until an entire pass through all of them does not result in anything
+being transported. At this point, every live object is in newspace.
+@end[enumerate]
+A Lisp-level GC function returns the oldspace pages to Mach.
+
+@index [Transporter]
+@section [The Transporter]
+The transporter moves objects from oldspace to newspace. It is given an
+address @i[A], which contains the object to be transported, @i[B]. If @i[B] is
+an immediate object, a pointer into static space, a pointer into read-only
+space, or a pointer into newspace, the transporter does nothing.
+
+If @i[B] is a pointer into oldspace, the object it points to must be
+moved. It may, however, already have been moved. Fetch the first
+word of @i[B], and call it @i[C]. If @i[C] is a GC-forwarding
+pointer, we form a new pointer with the type code of @i[B] and the
+low 27 bits of @i[C]. Write this into @i[A].
+
+If @i[C] is not a GC-forwarding pointer, we must copy the object that
+@i[B] points to. Allocate a new object of the same size in newspace,
+and copy the contents. Replace @i[C] with a GC-forwarding pointer to
+the new structure, and write the address of the new structure back
+into @i[A].
+
+Hash tables maintained with an EQ relation need special treatment by the
+transporter. Whenever a G-Vector with subtype 2 or 3 is transported to
+newspace, its subtype code is changed to 4. The Lisp-level hash-table
+functions will see that the subtype code has changed, and re-hash the entries
+before any access is made.
+
+@index [Scavenger]
+@section [The Scavenger] The scavenger looks through an area of
+pointers for pointers into oldspace, transporting the objects they
+point to into newspace. The stacks and static spaces need to be
+scavenged once, but the new dynamic spaces need to be scavenged
+repeatedly, since new objects will be allocated while garbage
+collection is in progress. To keep track of how much a dynamic space
+has been scavenged, a Clean-Space pointer is maintained. The
+Clean-Space pointer points to the next word to be scavenged. Each
+call to the scavenger scavenges the area between the Clean-Space
+pointer and the Free-Storage pointer. The Clean-Space pointer is
+then set to the Free-Storage pointer. When all Clean-Space pointers
+are equal to their Free-Storage pointers, GC is complete.
+
+To maintain (and create) locality of list structures, list space is
+treated specially. When a list cell is transported, if the cdr points
+to oldspace, it is immediately transported to newspace. This continues until
+the end of the list is encountered or a non-oldspace pointer occurs in the cdr
+position. This linearizes lists in the cdr direction which should
+improve paging performance.
+
+@section [Purification]
+@index [Purification]
+@label [PURIFY]
+
+Garbage is created when the files that make up a CMU Common Lisp system are
+loaded. Many functions are needed only for initialization and
+bootstrapping (e.g. the ``one-shot'' functions produced by the compiler for
+random forms between function definitions), and these can be thrown away
+once a full system is built. Most of the functions in the system, however,
+will be used after initialization. Rather than bend over backwards to make
+the compiler dump some functions in read-only space and others in dynamic
+space (which involves dumping their constants in the proper spaces, also),
+@i[everything] is dumped into dynamic space. A purify miscop is provided
+that does a garbage collection and moves accessible information in dynamic
+space into read-only or static space.
+
+@chapter [Assembler Support Routines]
+@label [Instr-Chapter]
+@index [Assembler Support Routines]
+
+To support compiled Common Lisp code many hand coded assembler
+language routines (miscops) are required. These routines accept
+arguments in the three argument registers, the special miscop
+argument register, and in a very few cases on the stack. The current
+register assignments are:
+@begin(Itemize, spread 0, spacing 1)
+A0 contains the first argument.
+
+A1 contains the second argument.
+
+A2 contains the third argument.
+
+A3 contains the fourth argument.
+@end(itemize)
+The rest of the arguments are passed on the stack with the last
+argument at the end of the stack. All arguments on the stack must be
+popped off the stack by the miscop. All miscops return their
+values in register A0. A few miscops return two or three values,
+these are all placed in the argument registers. The main return
+value is stored in register A0, the others in A1 and A2. The
+compiler must generate code to use the multiple values correctly,
+i.e., place the return values on the stack and put a values marker in
+register A0 if multiple-values are wanted. Otherwise the compiler
+can use the value(s) it needs and ignore the rest. NB: Most of the
+miscops follow this scheme, however, a few do not. Any
+discrepancies are explained in the description of particular
+miscops.
+
+Several of the instructions described in the Perq Internal Design Document do
+not have associated miscops, rather they have been code directly in-line.
+Examples of these instructions include push, pop, bind, bind-null, many of the
+predicates, and a few other instructions. Most of these instructions can be
+performed in 4 or fewer @value(DinkyMachine) instructions and the overhead of
+calling a miscop seemed overly expensive. Some instructions are encoded
+in-line or as a miscop call depending on settings of compiler optimization
+switches. If space is more important than speed, then some Perq instructions
+are compiled as calls to out of line miscops rather than generating in-line
+code.
+
+@section [Miscop Descriptions]
+@label[macro-codes]
+
+There are 10 classes of miscops: allocation, stack manipulation,
+list manipulation, symbol manipulation, array manipulation, type predicate,
+arithmetic and logical, function call and return,
+miscellaneous, and system hacking.
+
+@subsection [Allocation]
+@instrsection
+All non-immediate objects are allocated in the ``current allocation space,''
+which is dynamic space, static space, or read-only space. The current
+allocation space is initially dynamic space, but can be changed by using the
+Set-Allocation-Space miscop below. The current allocation space can be
+determined by using the Get-Allocation-Space miscop. One usually wants to
+change the allocation space around some section of code; an unwind protect
+should be used to insure that the allocation space is restored to some safe
+value.
+
+@begin(Description)
+@index [Get-Allocation-Space]
+Get-Allocation-Space (@i[])@\returns 0, 2, or 3 if the current allocation
+space is dynamic, static, or read-only, respectively.
+
+@index [Set-Allocation-Space]
+Set-Allocation-Space (@i[X])@\sets the current allocation space to dynamic,
+static, or read-only if @i[X] is 0, 2, or 3 respectively. Returns @i[X].
+
+@index [Alloc-Bit-Vector]
+Alloc-Bit-Vector (Length)@\returns a new bit-vector @i[Length] bits long,
+which is allocated in the current allocation space. @i[Length] must be a
+positive fixnum.
+
+@index [Alloc-I-Vector]
+Alloc-I-Vector (@i[Length A])@\returns a new I-Vector @i[Length]
+bytes long, with the access code specified by @i[A]. @i[Length] and
+@i[A] must be positive fixnums.
+
+@index [Alloc-String]
+Alloc-String (@i[Length])@\ returns a new string @i[Length] characters long.
+@i[Length] must be a fixnum.
+
+@index [Alloc-Bignum]
+Alloc-Bignum (@i[Length])@\returns a new bignum @i[Length] 32-bit words long.
+@i[Length] must be a fixnum.
+
+@index [Make-Complex]
+Make-Complex (@i[Realpart Imagpart])@\returns a new complex number with the
+specified @i[Realpart] and @i[Imagpart]. @i[Realpart] and @i[Imagpart] should
+be the same type of non-complex number.
+
+@index [Make-Ratio]
+Make-Ratio (@i[Numerator Denominator])@\returns a new ratio with the
+specified @i[Numerator] and @i[Denominator]. @i[Numerator] and
+@i[Denominator] should be integers.
+
+@index [Alloc-G-Vector]
+Alloc-G-Vector (@i[Length Initial-Element])@\returns a new G-Vector
+with @i[Length] elements initialized to @i[Initial-Element].
+@i[Length] should be a fixnum.
+
+@index [Static-Alloc-G-Vector]
+Static-G-Vector (@i[Length Initial-Element])@\returns a new G-Vector in
+static allocation space with @i[Length] elements initialized to
+@i[Initial-Element].
+
+@index [Vector]
+Vector (@i[Elt@-[0] Elt@-[1] ... Elt@-[Length - 1] Length])@\returns a new
+G-Vector containing the specified @i[Length] elements. @i[Length] should be a
+fixnum and is passed in register A0. The rest of the arguments are passed on
+the stack.
+
+@index [Alloc-Function]
+Alloc-Function (@i[Length])@\returns a new function with @i[Length] elements.
+@i[Length] should be a fixnum.
+
+@index [Alloc-Array]
+Alloc-Array (@i[Length])@\returns a new array with @i[Length] elements.
+@i[Length] should be a fixnum.
+
+@index [Alloc-Symbol]
+Alloc-Symbol (@i[Print-Name])@\returns a new symbol with the print-name as
+@i[Print-Name]. The value is initially Trap, the definition is Trap,
+the property list and the package are initially NIL. The symbol is
+not interned by this operation -- that is done in Lisp code.
+@i[Print-Name] should be a simple-string.
+
+@index [Cons]
+Cons (@i[Car Cdr])@\returns a new cons with the specified @i[Car] and @i[Cdr].
+
+@index [List]
+List (@i[Elt@-[0] Elt@-[1] ... Elt@-[CE - 1] Length])@\returns a new list
+containing the @i[Length] elements. @i[Length] should be fixnum and is
+passed in register NL0. The first three arguments are passed in A0, A1, and
+A2. The rest of the arguments are passed on the stack.
+
+@index [List*]
+List* (@i[Elt@-[0] Elt@-[1] ... Elt@-[CE - 1] Length])@\returns a list* formed
+by the @i[Length-1] elements. The last element is placed in the cdr of the
+last element of the new list formed. @i[Length] should be a fixnum and is
+passed in register NL0. The first three arguments are passed in A0, A1, and
+A2. The rest of the arguments are passed on the stack.
+
+@index[mv-list]
+MV-List (@i[Elt@-<0> Elt@-<1> ... Elt@-<CE - 1> Length])@\returns a list
+formed from the elements, all of which are on the stack. @i[Length] is
+passed in register A0. This miscop is invoked when multiple values from
+a function call are formed into a list.
+@end(Description)
+
+@subsection [Stack Manipulation]
+@instrsection
+
+@begin(Description)
+@index [Push]
+Push (@i[E])@\pushes E on to the control stack.
+
+@index [Pop]
+Pop (@i[E])@\pops the top item on the control stack into @i[E].
+
+@index [NPop]
+NPop (@i[N])@\If @i[N] is positive, @i[N] items are popped off of the stack.
+If @i[N] is negative, NIL is pushed onto the stack -@i[N] times. @i[N] must be
+a fixnum.
+
+@index [Bind-Null]
+Bind-Null (@i[E])@\pushes @i[E] (which must be a symbol) and its current value
+onto the binding stack, and sets the value of @i[E] to NIL. Returns NIL.
+
+@index [Bind]
+Bind (Value Symbol)@\pushes @i[Symbol] (which must be a symbol) and its current
+value onto the binding stack, and sets the value cell of @i[Symbol] to
+@i[Value]. Returns @i[Symbol].
+
+@index [Unbind]
+Unbind (@i[N])@\undoes the top @i[N] bindings on the binding stack.
+@end(Description)
+
+@subsection [List Manipulation]
+@instrsection
+
+@begin(Description)
+@index [Car]
+@index [Cdr]
+@index [Caar]
+@index [Cadr]
+@index [Cdar]
+@index [Cddr]
+Car, Cdr, Caar, Cadr, Cdar, Cddr (@i[E])@\returns the car, cdr, caar, cadr,
+cdar, or cddr of @i[E] respectively.
+
+@index [Set-Cdr]
+@index [Set-Cddr]
+Set-Cdr, Set-Cddr (@i[E])@\The cdr or cddr of the contents of @i[E] is stored
+in @i[E]. The contents of @i[E] should be either a list or NIL.
+
+@index [Set-Lpop]
+Set-Lpop (@i[E])@\The car of the contents of @i[E] is returned;
+the cdr of the contents of @i[E] is stored in @i[E]. The contents of @i[E]
+should be a list or NIL.
+
+@index [Spread]
+Spread (@i[E])@\pushes the elements of the list @i[E] onto the stack in
+left-to-right order.
+
+@index [Replace-Car]
+@index [Replace-Cdr]
+Replace-Car, Replace-Cdr (@i[List Value])@\sets the car or cdr of the @i[List]
+to @i[Value] and returns @i[Value].
+
+@index [Endp]
+Endp (X)@\sets the condition code eq bit to 1 if @i[X] is NIL, or 0 if @i[X] is
+a cons cell. Otherwise an error is signalled.
+
+@index [Assoc]
+@index [Assq]
+Assoc, Assq (@i[List Item])@\returns the first cons in the association-list
+@i[List] whose car is EQL to @i[Item]. If the = part of the EQL comparison
+bugs out (and it can if the numbers are too complicated), a Lisp-level Assoc
+function is called with the current cdr of the @i[List]. Assq returns the
+first cons in the association-list @i[List] whose car is EQ to @i[Item].
+
+@index [Member]
+@index [Memq] Member, Memq (@i[List Item])@\returns the first cons in
+the list @i[List] whose car is EQL to @i[Item]. If the = part of the
+EQL comparison bugs out, a Lisp-level Member function is called with
+the current cdr of the @i[List]. Memq returns the first cons in
+@i[List] whose car is EQ to the @i[Item].
+
+@index [GetF]
+
+GetF (@i[List Indicator Default])@\searches for the @i[Indicator] in
+the list @i[List], cddring down as the Common Lisp form GetF would.
+If @i[Indicator] is found, its associated value is returned,
+otherwise @i[Default] is returned.
+@end(Description)
+
+@subsection [Symbol Manipulation]
+@instrsection
+
+Most of the symbol manipulation miscops are compiled in-line rather than
+actual calls.
+
+@begin(Description)
+@index [Get-Value]
+Get-Value (@i[Symbol])@\returns the value of @i[Symbol] (which must be a
+symbol). An error is signalled if @i[Symbol] is unbound.
+
+@index [Set-Value]
+Set-Value (@i[Symbol Value])@\sets the value cell of the symbol @i[Symbol] to
+@i[Value]. @i[Value] is returned.
+
+@index [Get-Definition]
+Get-Definition (@i[Symbol])@\returns the definition of the symbol
+@i[Symbol]. If @i[Symbol] is undefined, an error is signalled.
+
+@index [Set-Definition]
+Set-Definition (@i[Symbol Definition])@\sets the definition of the symbol
+@i[Symbol] to @i[Definition]. @i[Definition] is returned.
+
+@index [Get-Plist]
+Get-Plist (@i[Symbol])@\returns the property list of the symbol @i[Symbol].
+
+@index [Set-Plist]
+Set-Plist (@i[Symbol Plist])@\sets the property
+list of the symbol @i[Symbol] to
+@i[Plist]. @i[Plist] is returned.
+
+@index [Get-Pname]
+Get-Pname (@i[Symbol])@\returns the print name of the symbol @i[Symbol].
+
+@index [Get-Package]
+Get-Package (@i[Symbol])@\returns the package cell of the symbol @i[Symbol].
+
+@index [Set-Package]
+Set-Package (@i[Symbol Package])@\sets the package cell of the symbol
+@i[Symbol] to @i[Package]. @i[Package] is returned.
+
+@index [Boundp]
+Boundp (@i[Symbol])@\sets the eq condition code bit to 1 if the symbol
+@i[Symbol] is bound; sets it to 0 otherwise.
+
+@index [FBoundp]
+FBoundp (@i[Symbol])@\sets the eq condition code bit to 1 if the symbol
+@i[Symbol] is defined; sets it to 0 otherwise.
+
+@index [Get]
+Get (@i[Symbol] @i[Indicator] @i[Default])@\searches the property list of
+@i[Symbol] for @i[Indicator] and returns the associated value. If
+@i[Indicator] is not found, @i[Default] is returned.
+
+@index [Put]
+Put (@i[Symbol] @i[Indicator] @i[Value])@\searches the property list of
+@i[Symbol] for @i[Indicator] and replaces the associated value with @i[Value].
+If @i[Indicator] is not found, the @i[Indicator] @i[Value] pair are consed onto
+the front of the property list.
+@end(Description)
+
+@subsection [Array Manipulation]
+@instrsection
+
+Common Lisp arrays have many manifestations in CMU Common Lisp. The CMU
+Common Lisp data types Bit-Vector, Integer-Vector, String, General-Vector,
+and Array are used to implement the collection of data types the Common
+Lisp manual calls ``arrays.''
+
+In the following miscop descriptions, ``simple-array'' means an array
+implemented in CMU Common Lisp as a Bit-Vector, I-Vector, String, or
+G-Vector. ``Complex-array'' means an array implemented as a CMU Common Lisp
+Array object. ``Complex-bit-vector'' means a bit-vector implemented as a
+CMU Common Lisp array; similar remarks apply for ``complex-string'' and so
+forth.
+
+@begin(Description)
+@index [Vector-Length] @index [G-Vector-Length] @index
+[Simple-String-Length] @index [Simple-Bit-Vector-Length] Vector-Length
+(@i[Vector])@\returns the length of the one-dimensional Common Lisp array
+@i[Vector]. G-Vector-Length, Simple-String-Length, and
+Simple-Bit-Vector-Length return the lengths of G-Vectors, CMU Common Lisp
+strings, and CMU Common Lisp Bit-Vectors respectively. @i[Vector] should
+be a vector of the appropriate type.
+
+@index [Get-Vector-Subtype]
+Get-Vector-Subtype (@i[Vector])@\returns the subtype field of the vector
+@i[Vector] as an integer. @i[Vector] should be a vector of some sort.
+
+@index [Set-Vector-Subtype]
+Set-Vector-Subtype (@i[Vector A])@\sets the subtype field of the vector
+@i[Vector] to @i[A], which must be a fixnum.
+
+@index [Get-Vector-Access-Code]
+Get-Vector-Access-Code (@i[Vector])@\returns the access code of the I-Vector
+(or Bit-Vector) @i[Vector] as a fixnum.
+
+@index [Shrink-Vector]
+Shrink-Vector (@i[Vector Length])@\sets the length field and the
+number-of-entries field of the vector @i[Vector] to @i[Length]. If the vector
+contains Lisp objects, entries beyond the new end are set to Trap.
+Returns the shortened vector. @i[Length] should be a fixnum. One cannot
+shrink array headers or function headers.
+
+@index [Typed-Vref]
+Typed-Vref (@i[A Vector I])@\returns the @i[I]'th element of the I-Vector
+@i[Vector] by indexing into it as if its access-code were @i[A]. @i[A] and
+@i[I] should be fixnums.
+
+@index [Typed-Vset]
+Typed-Vset (@i[A Vector I Value])@\sets the @i[I]'th element of the I-Vector
+@i[Vector] to @i[Value] indexing into @i[Vector] as if its access-code were
+@i[A]. @i[A], @i[I], and @i[Value] should be fixnums. @i[Value] is returned.
+
+@index [Header-Length]
+Header-Length (@i[Object])@\returns the number of Lisp objects in the header of
+the function or array @i[Object]. This is used to find the number of
+dimensions of an array or the number of constants in a function.
+
+@index [Header-Ref]
+Header-Ref (@i[Object I])@\returns the @i[I]'th element of the function or
+array header @i[Object]. @i[I] must be a fixnum.
+
+@index [Header-Set]
+Header-Set (@i[Object I Value])@\sets the @i[I]'th element of the function of
+array header @i[Object] to @i[Value], and pushes @i[Value]. @i[I] must be a
+fixnum.
+@end(Description)
+
+The names of the miscops used to reference and set elements of arrays are
+based somewhat on the Common Lisp function names. The SVref, SBit, and SChar
+miscops perform the same operation as their Common Lisp namesakes --
+referencing elements of simple-vectors, simple-bit-vectors, and simple-strings
+respectively. Aref1 references any kind of one dimensional array.
+The names of setting functions are derived by replacing ``ref'' with ``set'',
+``char'' with ``charset'', and ``bit'' with ``bitset.''
+
+@begin(Description)
+@index [Aref1]
+@index [SVref]
+@index [SChar]
+@index [SBit]
+Aref1, SVref, SChar, SBit (@i[Array I])@\returns the @i[I]'th element of the
+one-dimensional
+array @i[Array]. SVref pushes an element of a G-Vector; SChar an element of a
+string; Sbit an element of a Bit-Vector. @i[I] should be a fixnum.
+
+@index [Aset1]
+@index [SVset]
+@index [SCharset]
+@index [SBitset]
+Aset1, SVset, SCharset, SBitset (@i[Array I Value])@\sets the @i[I]'th element
+of the one-dimensional
+array @i[Array] to @i[Value]. SVset sets an element of a G-Vector; SCharset an
+element of a string; SBitset an element of a Bit-Vector. @i[I] should be a
+fixnum and @i[Value] is returned.
+
+@index [CAref2]
+@index [CAref3]
+CAref2, CAref3 (@i[Array I1 I2])@\returns the element (@i[I1], @i[I2]) of the
+two-dimensional array @i[Array]. @i[I1] and @i[I2] should be
+fixnums. CAref3 pushes the element (@i[I1], @i[I2], @i[I3]).
+
+@index [CAset2]
+@index [CAset3]
+CAset2, CAset3 (@i[Array I1 I2 Value]) @\sets the element (@i[I1], @i[I2]) of
+the two-dimensional array @i[Array] to @i[Value] and returns @i[Value].
+@i[I1] and @i[I2] should be fixnums. CAset3 sets the element (@i[I1], @i[I2],
+@i[I3]).
+
+@index [Bit-Bash]
+Bit-Bash (@i[V1 V2 V3 Op])@\@i[V1], @i[V2], and @i[V3] should be bit-vectors
+and @i[Op] should be a fixnum. The elements of the bit vector @i[V3] are
+filled with the result of @i[Op]'ing the corresponding elements of @i[V1] and
+@i[V2]. @i[Op] should be a Boole-style number (see the Boole miscop in
+section @ref[Boole-Section]).
+@end(Description)
+
+The rest of the miscops in this section implement special cases of sequence or
+string operations. Where an operand is referred to as a string, it may
+actually be an 8-bit I-Vector or system area pointer.
+
+@begin(Description)
+@index [Byte-BLT]
+Byte-BLT (@i[Src-String Src-Start Dst-String Dst-Start Dst-End])@\
+moves bytes from @i[Src-String] into @i[Dst-String] between @i[Dst-Start]
+(inclusive) and @i[Dst-End] (exclusive). @i[Dst-Start] - @i[Dst-End] bytes are
+moved. If the substrings specified overlap, ``the right thing happens,'' i.e.
+all the characters are moved to the right place. This miscop corresponds
+to the Common Lisp function REPLACE when the sequences are simple-strings.
+
+@index [Find-Character]
+Find-Character (@i[String Start End Character])@\
+searches @i[String] for the @i[Character] from @i[Start] to @i[End]. If the
+character is found, the corresponding index into @i[String] is returned,
+otherwise NIL is returned. This miscop corresponds to the Common Lisp
+function FIND when the sequence is a simple-string.
+
+@index [Find-Character-With-Attribute]
+Find-Character-With-Attribute (@i[String Start End Table Mask])@\
+The codes of the characters of @i[String] from @i[Start] to @i[End] are used as
+indices into the @i[Table], which is an I-Vector of 8-bit bytes. When the
+number picked up from the table bitwise ANDed with @i[Mask] is non-zero, the
+current index into the @i[String] is returned.
+
+@index [SXHash-Simple-String]
+SXHash-Simple-String (@i[String Length])@\Computes the hash code of the first
+@i[Length] characters of @i[String] and pushes it on the stack. This
+corresponds to the Common Lisp function SXHASH when the object is a
+simple-string. The @i[Length] operand can be Nil, in which case the length of
+the string is calculated in assembler.
+@end(Description)
+
+@subsection [Type Predicates]
+@instrsection
+
+Many of the miscops described in this sub-section can be coded in-line rather
+than as miscops. In particular, all the predicates on basic types are coded
+in-line with default optimization settings in the compiler. Currently, all of
+these predicates set the eq condition code bit to return an indication of
+whether the predicate is true or false. This is so that the
+@value(DinkyMachine) branch instructions can be used directly without having to
+test for NIL. However, this only works if the value of the predicate is needed
+for a branching decision. In the cases where the value is actually needed, T
+or NIL is generated in-line according to whether the predicate is true or
+false. At some point it might be worthwhile having two versions of these
+predicates, one which sets the eq condition code bit, and one which returns T
+or NIL. This is especially true if space becomes an issue.
+
+@begin(Description)
+@index [Bit-Vector-P]
+Bit-Vector-P (@i[Object])@\sets the eq condition code bit to 1 if @i[Object] is
+a Common Lisp bit-vector or 0 if it is not.
+
+@index [Simple-Bit-Vector-P]
+Simple-Bit-Vector-P (@i[Object])@\sets the eq condition code bit to 1 if
+@i[Object] is a CMU Common Lisp bit-vector or 0 if it is not.
+
+@index [Simple-Integer-Vector-P]
+Simple-Integer-Vector-P (@i[Object])@\sets the eq condition code bit to 1
+if @i[Object] is a CMU Common Lisp I-Vector or 0 if it is not.
+
+@index [StringP]
+StringP (@i[Object])@\sets the eq condition code bit to 1 if @i[Object] is a
+Common Lisp string or 0 if it is not.
+
+@index [Simple-String-P]
+Simple-String-P (@i[Object])@\sets the eq condition code bit to 1 if
+@i[Object] is a CMU Common Lisp string or 0 if it is not.
+
+@index [BignumP]
+BignumP (@i[Object])@\sets the eq condition code bit to 1 if @i[Object] is a
+bignum or 0 if it is not.
+
+@index [Long-Float-P]
+Long-Float-P (@i[Object])@\sets the eq condition code bit to 1 if
+@i[Object] is a long-float or 0 if it is not.
+
+@index [ComplexP]
+ComplexP (@i[Object])@\sets the eq condition code bit to 1 if @i[Object] is a
+complex number or 0 if it is not.
+
+@index [RatioP]
+RatioP (@i[Object])@\sets the eq condition code bit to 1 if @i[Object] is a
+ratio or 0 if it is not.
+
+@index [IntegerP]
+IntegerP (@i[Object])@\sets the eq condition code bit to 1 if @i[Object] is a
+fixnum or bignum or 0 if it is not.
+
+@index [RationalP]
+RationalP (@i[Object])@\sets the eq condition code bit to 1 if @i[Object] is a
+fixnum, bignum, or ratio or 0 if it is not.
+
+@index [FloatP]
+FloatP (@i[Object])@\sets the eq condition code bit to 1 if @i[Object] is a
+short-float or long-float or 0 if it is not.
+
+@index [NumberP]
+NumberP (@i[Object])@\sets the eq condition code bit to 1 if @i[Object] is a
+number or 0 if it is not.
+
+@index [General-Vector-P]
+General-Vector-P (@i[Object])@\sets the eq condition code bit to 1 if
+@i[Object] is a Common Lisp general vector or 0 if it is not.
+
+@index [Simple-Vector-P]
+Simple-Vector-P (@i[Object])@\sets the eq condition code bit to 1 if @i[Object]
+is a CMU Common Lisp G-Vector or 0 if it is not.
+
+@index [Compiled-Function-P]
+Compiled-Function-P (@i[Object])@\sets the eq condition code bit to 1 if
+@i[Object] is a compiled function or 0 if it is not.
+
+@index [ArrayP]
+ArrayP (@i[Object])@\sets the eq condition code bit to 1 if @i[Object] is a
+Common Lisp array or 0 if it is not.
+
+@index [VectorP]
+VectorP (@i[Object])@\sets the eq condition code bit to 1 if @i[Object] is a
+Common Lisp vector of 0 if it is not.
+
+@index [Complex-Array-P]
+Complex-Array-P (@i[Object])@\sets the eq condition code bit to 1 if @i[Object]
+is a CMU Common Lisp array or 0 if it is not.
+
+@index [SymbolP]
+SymbolP (@i[Object])@\sets the eq condition code bit to 1 if @i[Object] is a
+symbol or 0 if it is not.
+
+@index [ListP]
+ListP (@i[Object])@\sets the eq condition code bit to 1 if @i[Object] is a cons
+or NIL or 0 if it is not.
+
+@index [ConsP]
+ConsP (@i[Object])@\sets the eq condition code bit to 1 if @i[Object] is a cons
+or 0 if it is not.
+
+@index [FixnumP]
+FixnumP (@i[Object])@\sets the eq condition code bit to 1 if @i[Object] is a
+fixnum or 0 if it is not.
+
+@index [Single-Float-P]
+Single-Float-P (@i[Object])@\sets the eq condition code bit to 1 if @i[Object]
+is a single-float or 0 if it is not.
+
+@index [CharacterP]
+CharacterP (@i[Object])@\sets the eq condition code bit to 1 if @i[Object] is
+a character or 0 if it is not.
+@end(Description)
+
+@subsection [Arithmetic]
+@instrsection
+
+@begin(Description)
+@index [Integer-Length]
+Integer-Length (@i[Object])@\returns the integer-length (as defined in the
+Common Lisp manual) of the integer @i[Object].
+
+@index [Logcount]
+Logcount (@i[Object])@\returns the number of 1's if @i[object] is a
+positive integer, the number of 0's if @i[object] is a negative integer,
+and signals an error otherwise.
+
+@index [Float-Short]
+Float-Short (@i[Object])@\returns a short-float corresponding to the number
+@i[Object].
+
+@index [Float-Long]
+Float-Long (@i[Number])@\returns a long float formed by coercing @i[Number] to
+a long float. This corresponds to the Common Lisp function Float when given a
+long float as its second argument.
+
+@index [Realpart]
+Realpart (@i[Number])@\returns the realpart of the @i[Number].
+
+@index [Imagpart]
+Imagpart (@i[Number])@\returns the imagpart of the @i[Number].
+
+@index [Numerator]
+Numerator (@i[Number])@\returns the numerator of the rational @i[Number].
+
+@index [Denominator]
+Denominator (@i[Number])@\returns the denominator of the rational @i[Number].
+
+@index [Decode-Float]
+Decode-Float (@i[Number])@\performs the Common Lisp Decode-Float function,
+returning 3 values.
+
+@index [Scale-Float]
+Scale-Float (@i[Number X])@\performs the Common Lisp Scale-Float function,
+returning the result.
+
+@index[=]
+= (@i[X Y])@\sets the condition codes according to whether @i[X] is equal
+to @i[Y]. Both @i[X] and @i[Y] must be numbers, otherwise an error is
+signalled. If a rational is compared with a flonum, the rational is
+converted to a flonum of the same type first. If a short flonum is compared
+with a long flonum, the short flonum is converted to a long flonum.
+Flonums must be exactly equal (after conversion) for the condition codes to
+be set to equality. This miscop also deals with complex numbers.
+
+@index [Compare]
+Compare (@i[X Y])@\sets the condition codes according to
+whether @i[X] is less than, equal to, or greater than @i[Y]. @i[X]
+and @i[Y] must be numbers. Conversions as described in = above are done
+as necessary. This miscop replaces the < and > instructions on the Perq,
+so that the branch on condition instructions can be used more
+effectively. The value of < and > as defined for the Perq are
+only generated if necessary, i.e., the result is saved. If @i[X] or @i[Y]
+is a complex number, an error is signalled.
+
+@index [Truncate]
+Truncate (@i[N X])@\performs the Common Lisp TRUNCATE operation. There are 3
+cases depending on @i[X]:
+@Begin[Itemize]
+If @i[X] is fixnum 1, return two items: a fixnum or bignum
+representing the integer part of @i[N] (rounded toward 0), then either 0 if
+@i[N] was already an integer or the fractional part of @i[N] represented as a
+flonum or ratio with the same type as @i[N].
+
+If @i[X] and @i[N] are both fixnums or bignums and @i[X] is not 1, divide
+@i[N] by @i[X]. Return two items: the integer quotient (a fixnum or
+bignum) and the integer remainder.
+
+If either @i[X] or @i[N] is a flonum or ratio, return a fixnum or bignum
+quotient (the true quotient rounded toward 0), then a flonum or ratio
+remainder. The type of the remainder is determined by the same type-coercion
+rules as for +. The value of the remainder is equal to @i[N] - @i[X] *
+@i[Quotient].
+@End[Itemize]
+On the @value(DinkyMachine), the integer part is returned in register A0, and
+the remainder in A1.
+
+@index [+]
+@index [-]
+@index [*]
+@index [/]
++, -, *, / (@i[N X])@\returns @i[N] + @i[X]. -, *, and / are similar.
+
+@index [Fixnum*Fixnum]
+@index [Fixnum/Fixnum]
+Fixnum*Fixnum, Fixnum/Fixnum (@i[N X])@\returns @i[N] * @i[X], where
+both @i[N] and @i[X] are fixnums. Fixnum/ is similar.
+
+@index [1+]
+1+ (@i[E])@\returns @i[E] + 1.
+
+@index [1-]
+1- (@i[E])@\returns @i[E] - 1.
+
+@index [Negate]
+Negate (@i[N])@\returns -@i[N].
+
+@index [Abs]
+Abs (@i[N])@\returns |@i[N]|.
+
+@index [GCD]
+GCD (@i[N X])@\returns the greatest common divisor of the integers @i[N] and @i[X].
+
+@index [Logand]
+@index [Logior]
+@index [Logxor]
+Logand (@i[N X])@\returns the bitwise and of the integers @i[N] and @i[X].
+Logior and Logxor are analogous.
+
+@index [Lognot]
+Lognot (@i[N])@\returns the bitwise complement of @i[N].
+
+@index [Boole]
+@label [Boole-Section]
+Boole (@i[Op X Y])@\performs the Common Lisp Boole operation @i[Op] on @i[X],
+and @i[Y]. The Boole constants for CMU Common Lisp are these:
+@begin [verbatim, group]
+ boole-clr 0
+ boole-set 1
+ boole-1 2
+ boole-2 3
+ boole-c1 4
+ boole-c2 5
+ boole-and 6
+ boole-ior 7
+ boole-xor 8
+ boole-eqv 9
+ boole-nand 10
+ boole-nor 11
+ boole-andc1 12
+ boole-andc2 13
+ boole-orc1 14
+ boole-orc2 15
+@end [verbatim]
+
+@index [Ash]
+Ash (@i[N X])@\performs the Common Lisp ASH operation on @i[N] and @i[X].
+
+@index [Ldb]
+Ldb (@i[S P N])@\All args are integers; @i[S] and @i[P] are non-negative.
+Performs the Common Lisp LDB operation with @i[S] and @i[P] being the size and
+position of the byte specifier.
+
+@index [Mask-Field]
+Mask-Field (@i[S P N])@\performs the Common Lisp Mask-Field operation with
+@i[S] and @i[P] being the size and position of the byte specifier.
+
+@index [Dpb]
+Dpb (@i[V S P N])@\performs the Common Lisp DPB operation with @i[S] and @i[P]
+being the size and position of the byte specifier.
+
+@index [Deposit-Field]
+Deposit-Field (@i[V S P N])@\performs the Common Lisp Deposit-Field operation
+with @i[S] and @i[P] as the size and position of the byte specifier.
+
+@index [Lsh]
+Lsh (@i[N X])@\returns a fixnum that is @i[N] shifted left by @i[X] bits, with
+0's shifted in on the right. If @i[X] is negative, @i[N] is shifted to the
+right with 0's coming in on the left. Both @i[N] and @i[X] should be fixnums.
+
+@index [Logldb]
+Logldb (@i[S P N])@\All args are fixnums. @i[S] and @i[P] specify a ``byte''
+or bit-field of any length within @i[N]. This is extracted and is returned
+right-justified as a fixnum. @i[S] is the length of the field in bits; @i[P]
+is the number of bits from the right of @i[N] to the beginning of the
+specified field. @i[P] = 0 means that the field starts at bit 0 of @i[N], and
+so on. It is an error if the specified field is not entirely within the 26
+bits of @i[N]
+
+@index [Logdpb]
+Logdpb (@i[V S P N])@\All args are fixnums. Returns a number equal to @i[N],
+but with the field specified by @i[P] and @i[S] replaced by the @i[S] low-order
+bits of @i[V]. It is an error if the field does not fit into the 26 bits of
+@i[N].
+
+@index[Sin]@index[Cos]@index[Tan]@index[Atan]
+Sin(@i[X]), Cos(@i[X]), Tan(@i[X]), and Atan(@i[X])@\accept a single number
+@i[X] as argument and return the sine, cosine, tangent, and arctangent of
+the number respectively. These miscops take advantage of the hardware
+support provided on the IBM RT PC if it is available, otherwise they escape
+to Lisp code to calculate the appropriate result.
+
+@index[Log]
+Log(@i[X])@\returns the natural log of the number @i[X]. This miscop uses
+the hardware operation if it is available, otherwise it escapes to Lisp
+code to calculate the result.
+
+@index[Exp]
+Exp(@i[X])@\returns e raised to the power @i[X]. This miscop uses the
+hardware operation if it is available, otherwise it escapes to Lisp code to
+calculate the result.
+
+@index[Sqrt]
+Sqrt(@i[X])@\returns the square root of @i[X]. This miscop uses the
+hardware operation if it is available, otherwise it escapes to Lisp code to
+calculate the result.
+@end(Description)
+
+@subsection [Branching]
+All branching is done with @value(DinkyMachine) branch instructions.
+Instructions are generated to set the condition code bits appropriately, and
+a branch which tests the appropriate condition code bit is generated.
+
+@subsection [Function Call and Return]
+@instrsection
+
+@begin(Description)
+@index [Call]
+Call()@\A call frame for a function is opened. This is explained in
+more detail in the next chapter.
+
+@index [Call-0]
+Call-0 (@i[F])@\@i[F] must be an executable function, but is a
+function of 0 arguments. Thus, there is no need to collect arguments. The
+call frame is opened and activated in a single miscop.
+
+@index [Call-Multiple]
+Call-Multiple ()@\Just like a Call miscop, but it marks the frame
+to indicate that multiple values will be accepted. See
+section @ref[Multi].
+
+@index[Set-Up-Apply-Args]
+Set-Up-Apply-Args ()@\is called to handle the last argument of a
+function called by apply. All the other arguments will have been
+properly set up by this time. Set-up-apply-args places the values of
+the list passed as the last argument to apply in their proper
+locations, whether they belong in argument registers or on the stack.
+It updates the NArgs register with the actual count of the arguments
+being passed to the function. When Set-up-apply-args returns, all the
+arguments to the function being applied are in their correct
+locations, and the function can be invoked normally.
+
+@index[Start-Call-Interpreter]
+Start-Call-Interpreter (@i[NArgs])@\is called from the interpreter to
+start a function call. It accepts the number of arguments that are
+pushed on the stack in register A0. Just below the arguments is the
+function to call; just below the function is the area to store the
+preserved registers. This miscop sets up the argument registers
+correctly, moves any other arguments down on the stack to their
+proper place, and invokes the function.
+
+@index[Invoke1]
+Invoke1 (@i[Function] @i[Argument])@\is similar to Start-Call-Interpreter,
+but is simpler, since the @i[Function] is being called with only a
+single @i[Argument].
+
+@index[Invoke1*]
+Invoke1* (@i[Function] @i[Argument])@\is similar to Invoke1, but the
+@i[Function] being called is called for one value, rather than multiple ones.
+
+@index [Start-call-mc]
+Start-call-mc ()@\is called when the compiler generates code for the
+form multiple-value-call. Register A0 contains the function to be
+called, A1 contains a 0 if the call if for a single value, and 1
+otherwise, NArgs contains the number of arguments that are stored on
+the stack. The argument registers are set up correctly, and the
+excess values moved down on the stack if necessary. Finally, the
+function is actually invoked.
+
+@index [Push-Last]
+Push-Last ()@\closes the currently open call frame, and initiates a function
+call.
+
+@index [Return]
+Return (@i[X])@\Return from the current function call. After the current
+frame is popped off the stack, @i[X] is returned in register A0 as the result
+Being returned. See section @ref[Return] for more details.
+
+@index [Return-From]
+Return-From (@i[X] @i[F])@\is similar to Return, except it accepts the frame
+to return from as an additional argument.
+
+@index [Return-1-Value-Any-Bind]
+Return-1-Value-Any-Bind (@i[X])@\is similar to return, except only
+one value is returned. Any number of bindings are undone during the
+return operation.
+
+@index [Return-Mult-Value-0-Bind]
+Return-Mult-Value-0-Bind (@i[X])@\is similar to return, except multiple values
+may be returned, but the binding stack does not have to be popped.
+
+@index [Link-Address-Fixup]
+Link-Address-Fixup (@i[Symbol NArgs Code-Vector Offset])@\finds the
+correct link table entry for @i[Symbol] with @i[NArgs] (@i[NArgs]
+specifies the fixed number of arguments and a flag if more may be
+passed). It smashes the @i[Code-Vector] at @i[Offset] to generate
+code to point at the absolute address of the link table entry.
+
+@index [Miscop-Fixup]
+Miscop-Fixup (@i[Code-Vector Offset Index])@\smashes @i[Code-Vector] at
+@i[Offset] with the correct value for the miscop specified by @i[Index] in a
+transfer vector of all the miscops.
+
+@index [Make-Compiled-Closure]
+Make-Compiled-Closure (@i[env fcn offset])@\returns a new function object
+that is a copy of the function object @i[fcn] which has the @i[env]
+information stored at @i[offset]. Compiled lexical closures are now
+represented as real function objects rather than as lists. This miscop is
+necessary to support this change.
+
+@index [Reset-link-table]
+Reset-link-table (@i[function])@\resets all the link table entries for
+@i[function] to the default action. This is necessary because Portable
+Commonloops updates generic function objects by copying new information
+into the function object. The link table must be updated to reflect this
+or the wrong function will be called.
+
+@index[Interrupt-Handler]
+@begin[Multiple]
+Interrupt-Handler (@i[Signal Code Signal-Context])@\gets the first
+indication that a Unix signal has occurred. This miscop does not follow
+the normal Lisp calling conventions at all. Instead it follows the
+standard IBM RT PC calling conventions for C or other algorithmic
+languages. On entry the registers are as follows:
+@begin(Description)
+R0@\Pointer to C data area for Interrupt-Handler. Currently this data area
+only holds a pointer to the entry point for Interrupt-Handler and nothing
+else.
+
+R1@\Pointer to a C stack that contains information about the signal.
+
+R2@\Contains the @i[Signal] number that caused the interrupt to happen.
+
+R3@\Contains the @i[Code] that further specifies what caused the interrupt
+(if necessary).
+
+R4@\Contains a pointer to the @i[signal-context] which contains
+information about where the interrupt occurred, the saved registers, etc.
+
+R5-R14@\Contain unknown values.
+
+R15@\is the return PC which will return from the interrupt handler and
+restart the computation.
+@end(Description)
+Interrupt-Handler determines whether it is safe to take the interrupt now,
+i.e., it is executing in Lisp code, C code, or an interruptible miscop. An
+interruptible miscop is one that has been specially written to make sure
+that it is safe to interrupt it at any point and is possible that it will
+never return of its own accord (e.g., length which could be passed a
+circular list, some of the system call miscops, etc.). If it is safe to
+take the interrupt, the signal-context is modified so that control will
+transfer to the miscop interrupt-routine when the interrupt-handler returns
+normally (i.e., after the kernel has done the necessary bookkeeping). If
+it is unsafe to take the interrupt (i.e., it is executing in an
+non-interruptible miscop), then the return PC of the miscop is modified to
+be interrupt-routine and interrupt-handler returns to the kernel. In
+either case interrupts are disabled and information is stored in a global
+Lisp data area, so that the interrupt-routine miscop can retrieve the
+important information about the interrupt.
+@end[Multiple]
+
+Interrupt-Routine ()@\gets control when it is safe to take an interrupt.
+It saves the current state of the computation on the appropriate stack (on
+the C stack if it was executing in C or on the Lisp stack if in Lisp)
+including all the registers, some control information specifying whether
+the computation was in C code, Lisp code, whether it should form a PC in
+register R15. When a PC has to be formed in R15, R14 will contain a pointer
+to the active function and R15 will contain an index into the code vector
+associated with the active function. Reforming the PC is necessary so
+it is possible to restart a computation even after a garbage collection
+may have moved the function. Once this information is stored,
+interrupt-routine invokes the Lisp function %sp-software-interrupt-routine
+which moves the processing of the interrupt to Lisp code.
+
+@index [Break-Return]
+Break-Return (@i[])@\returns from a function called by the
+interrupt-routine miscop. The only function that should ever do this is
+%sp-software-interrupt-routine. This miscop expects the stack to be in a
+format that is generated during an interrupt and should not be used for
+anything else.
+
+@index [Catch]
+Catch (@i[Tag PC])@\builds a catch frame. @i[Tag] is the tag caught by this
+catch frame, @i[PC] is a saved-format PC (i.e., an index into the current code
+vector). See section @ref[Catch] for details.
+
+@index [Catch-Multiple]
+Catch-Multiple (@i[Tag PC])@\builds a multiple-value catch frame. @i[Tag] is
+the tag caught by this catch frame, and @i[PC] is a saved-format PC. See
+section @ref[Catch] for details.
+
+@index [Catch-All]
+Catch-All (@i[PC])@\builds a catch frame whose tag is the special Catch-All
+object. @i[PC] is the saved-format PC, which is the address to branch to if
+this frame is thrown through. See section @ref[Catch] for details.
+
+@index [Throw]
+Throw (@i[X Tag])@\@i[Tag] is the throw-tag, normally a symbol. @i[X] is the
+value to be returned. See section @ref[Catch] for a description of how this
+miscop works.
+
+@index[Rest-Entry-0]@index[Rest-Entry-1]@index[Rest-Entry-2]@index[Rest-Entry]
+Rest-Entry-0, Rest-Entry-1, Rest-Entry-2, Rest-Entry@\are miscops
+that do the processing for a function at its &rest entry point.
+Rest-Entry-@i[i] are miscops that are invoked by functions that have
+0, 1, or 2 arguments before the &rest argument. Rest-entry is
+invoked for all other cases, and is passed an additional argument in
+A3 which is the number of non-&rest arguments. These miscops form
+the &rest arg list and set up all the registers to have the
+appropriate values. In particular, the non-&rest arguments are copied
+into preserved registers, and the &rest arg list is built and stored
+in the appropriate preserved register or on the stack as appropriate.
+
+@index[Call-Foreign]
+Call-Foreign (@i[C-Function Arguments NArgs])@\establishes the C
+environment so that C code can be called correctly. @i[C-Function] is a
+pointer to the data area for a C function, the first word of which is a
+pointer to the entry point of the C function. @i[Arguments] is a block of
+storage that contains the @i[NArgs] arguments to be passed to the C
+function. The first four of these arguments are passed in registers R2
+through R5 respectively, the rest are moved onto the C stack in the proper
+location. When the C function returns, Call-Foreign restores the Lisp
+environment and returns as its value the integer in R2.
+
+@index[Call-Lisp]
+Call-Lisp (@i[Arg@-<1> ... Arg@-<2>])@\is a Lisp miscop that gets control
+when a C function needs to call a Lisp function. Lisp provides a mechanism
+for setting up an object that looks like a C procedure pointer. The code
+pointer in this object always points at Call-Lisp. Additional data in this
+procedure pointer is the Lisp function to call and the number of arguments
+that it should be called with. Call-Lisp restores the Lisp environment,
+saves the state of the C computation, moves the C arguments into the
+correct places for a call to a Lisp function and then invokes the special
+Lisp function call-lisp-from-c. This Lisp function actually invokes the
+correct Lisp function. Call-Lisp never regains control.
+
+@index[Return-To-C]
+Return-To-C (@i[C-Stack-Pointer Value])@\is used in the
+function call-lisp-from-c to return control to C from a Lisp function
+called by C. @i[C-Stack-Pointer] is the C stack pointer when the call-lisp
+miscop got control. The C stack pointer argument is used to restore the C
+environment to what it was at the time the call to Lisp was made.
+@i[Value] is the value returned from Lisp and is passed back to C in
+register R2. Currently, it is not possible to return other than a single
+32 bit quantity.
+
+@index[Reset-C-Stack]
+Reset-C-Stack ()@\is invoked when a Lisp function called by C throws out
+past where it should return to C. Reset-C-Stack restores the C stack to
+what it was before the original call to C happened. This is so that in the
+future, the C stack will not contain any garbage that should not be there.
+
+@index[Set-C-Procedure-Pointer]
+Set-C-Procedure-Pointer (@i[Sap] @i[I] @I[Proc])@\sets the @i[I/2]'th
+element of @i[sap] to be the data part of the statically allocated g-vector
+@i[Proc]. This is used to set up a C procedure argument in the argument
+block that is passed to call-foreign.
+
+@end(Description)
+
+@subsection [Miscellaneous]
+@instrsection
+
+@begin(Description)
+@index [Eq]
+Eq (@i[X Y])@\sets the eq condition code bit to 1 if @i[X] and @i[Y] are the
+same object, 0 otherwise.
+
+@index [Eql]
+Eql (@i[X Y])@\sets the eq condition code bit to 1 if @i[X] and @i[Y] are the
+same object or if
+@i[X] and @i[Y] are numbers of the same type with the same value, 0 otherwise.
+
+@index [Make-Predicate]
+Make-Predicate (@i[X])@\returns NIL if @i[X] is NIL or T if it is not.
+
+@index [Not-Predicate]
+Not-Predicate (@i[X])@\returns T if @i[X] is NIL or NIL if it is not.
+
+@index [Values-To-N]
+Values-To-N (@i[V])@\@i[V] must be a Values-Marker. Returns the number
+of values indicated in the low 24 bits of @i[V] as a fixnum.
+
+@index [N-To-Values]
+N-To-Values (@i[N])@\@i[N] is a fixnum. Returns a Values-Marker with the
+same low-order 24 bits as @i[N].
+
+@index [Force-Values]
+Force-Values (@i[VM])@\If the @i[VM] is a Values-Marker, do
+nothing; if not, push @i[VM] and return a Values-Marker 1.
+
+@index [Flush-Values]
+Flush-Values (@i[])@\is a no-op for the @value(DinkyMachine), since the only
+time that a Flush-Values miscop is generated is in some well-defined cases
+where all the values are wanted on the stack.
+@end(Description)
+
+@subsection [System Hacking]
+@label [System-Hacking-Instructions]
+@instrsection
+
+@begin(Description)
+@index [Get-Type]
+Get-Type (@i[Object])@\returns the five type bits of the @i[Object] as a
+fixnum.
+
+@index [Get-Space]
+Get-Space (@i[Object])@\returns the two space bits of @i[Object] as a
+fixnum.
+
+@index [Make-Immediate-Type]
+Make-Immediate-Type (@i[X A])@\returns an object whose type bits are the
+integer @i[A] and whose other bits come from the immediate object or pointer
+@i[X]. @i[A] should be an immediate type code.
+
+@index [8bit-System-Ref]
+8bit-System-Ref (@i[X I])@\@i[X] must be a system area pointer, returns
+the @i[I]'th byte of @i[X], indexing into @i[X] directly. @i[I]
+must be a fixnum.
+
+@index [8bit-System-Set]
+8bit-System-Set (@i[X I V])@\@i[X] must be a system area pointer, sets the
+@i[I]'th element of @i[X] to @i[V], indexing into @i[X] directly.
+
+@index [16bit-System-Ref]
+16bit-System-Ref (@i[X I])@\@i[X] must be a system area pointer, returns the
+@i[I]'th 16-bit word of @i[X], indexing into @i[X] directly.
+
+@index [Signed-16bit-System-Ref]
+Signed-16bit-System-Ref (@i[X I])@\@i[X] must be a system area pointer,
+returns the @i[I]'th 16-bit word of @i[X] extending the high order bit as
+the sign bit.
+
+@Index [16bit-System-Set]
+16bit-System-Set (@i[X I V])@\@i[X] must be a system area pointer, sets the
+@i[I]'th element of @i[X] to @i[V], indexing into @i[X] directly.
+
+@Index [Signed-32bit-System-Ref]
+Signed-32bit-System-Ref (@i[X I])@\@i[X] must be a system area pointer and
+@i[I] an even fixnum, returns the @i[I]/2'th 32 bit word as a signed
+quantity.
+
+@Index [Unsigned-32bit-System-Ref]
+Unsigned-32bit-System-Ref (@i[X I])@\@i[X] must be a system area pointer and
+@i[I] an even fixnum, returns the @i[I]/2'th 32 bit word as an unsigned
+quantity.
+
+@Index [Signed-32bit-System-Set]
+Signed-32bit-System-Set (@i[X I V])@\@i[X] must be a system area pointer,
+@i[I] an even fixnum, and @i[V] an integer, sets the @i[I]/2'th element of
+@i[X] to @i[V].
+
+@index[Sap-System-Ref]
+Sap-System-Ref (@i[X I])@\@i[X] must be a system area pointer and @i[I] and
+even fixnum, returns the @i[I]/2'th element of @i[X] as a system area
+pointer.
+
+@index[Sap-System-Set]
+Sap-System-Set (@i[X I V])@\@i[X] and @i[V] must be a system area pointers
+and @i[I] an even fixnum, sets the @i[I]/2'th element of @i[X] to @i[V].
+
+@index[Pointer-System-Set]
+Pointer-System-Set (@i[X I])@\@i[X] must be a system area pointer, @i[I] an
+even fixnum, and @i[V] a pointer (either system area pointer or Lisp
+pointer), sets the @i[I]/2'th element of @i[X] to the pointer @i[V]. If
+the pointer is a Lisp pointer, the pointer stored is to the first word of
+data (i.e., the header word(s) are bypassed).
+
+@index[Sap-Int]
+Sap-Int (@i[X])@\@i[X] should be a system area pointer, returns a Lisp
+integer containing the system area pointer. This miscop is useful when it
+is necessary to do arithmetic on system area pointers.
+
+@index[Int-Sap]
+Int-Sap (@i[X])@\@i[X] should be an integer (fixnum or bignum), returns a
+system area pointer. This miscop performs the inverse operation of sap-int.
+
+@index[Check-<=]
+Check-<= (@i[X] @i[Y])@\checks to make sure that @i[X] is less than or
+equal to @i[Y]. If not, then check-<= signals an error, otherwise it just
+returns.
+
+@index [Collect-Garbage]
+Collect-Garbage (@i[])@\causes a stop-and-copy GC to be performed.
+
+@index [Purify]
+Purify (@i[])@\is similar to collect-garbage, except it copies Lisp objects
+into static or read-only space. This miscop needs Lisp level code to get
+the process started by putting some root structures into the correct space.
+
+@index [Newspace-Bit]
+Newspace-Bit (@i[])@\returns 0 if newspace is currently space 0 or 1 if it is
+1.
+
+@index [Save]
+Save (@i[*current-alien-free-pointer*] @i[Checksum] @I[memory])@\Save takes
+a snap short of the current state of the Lisp computation. The value of
+the symbol *Current-alien-free-pointer* must be passed to save, so that it
+can save the static alien data structures. The parameter @i[checksum]
+specifies whether a checksum should be generated for the saved image.
+Currently, this parameter is ignored and no checksum is generated. The
+parameter @i[memory] should be be a pointer to a block of memory where the
+saved core image will be stored. Save returns the size of the core image
+generated.
+
+@index [Syscall0]
+@index [Syscall1]
+@index [Syscall2]
+@index [Syscall3]
+@index [Syscall4]
+@index [Syscall]
+Syscall0 Syscall1 Syscall2 Syscall3 Syscall4 Syscall (@i[number]
+@i[arg@-<1> ... arg@-<n>])@\is for making syscalls to the Mach kernel. The
+argument @i[number] should be the number of the syscall. Syscall0 accepts
+no arguments to the syscall; syscall1 accepts one argument to the syscall,
+etc. Syscall accepts five or more arguments to the syscall.
+
+@index[Unix-write]
+Unix-Write (@i[fd buffer offset length])@\performs a Unix write syscall to
+the file descriptor @i[fd]. @i[Buffer] should contain the data to be
+written; @i[Offset] should be an offset into buffer from which to start
+writing; and @i[length] is the number of bytes of data to write.
+
+@index[Unix-fork]
+Unix-Fork ()@\performs a Unix fork operation returning one or two values.
+If an error occurred, the value -1 and the error code is returned. If no
+error occurred, 0 is returned in the new process and the process id of the
+child process is returned in the parent process.
+
+@index [Arg-In-Frame] Arg-In-Frame (@i[N F])@\@i[N] is a fixnum, @i[F] is a
+control stack pointer as returned by the Active-Call-Frame miscop. It
+returns the item in slot @i[N] of the args-and-locals area of call frame
+@i[F].
+
+@index [Active-Call-Frame]
+Active-Call-Frame (@i[])@\returns a control-stack pointer to the start of the
+currently active call frame. This will be of type Control-Stack-Pointer.
+
+@index [Active-Catch-Frame]
+Active-Catch-Frame (@i[])@\returns the control-stack pointer to the start of
+the currently active catch frame. This is Nil if there is no active catch.
+
+@index [Set-Call-Frame]
+Set-Call-Frame (@i[P])@\@i[P] must be a control stack pointer. This becomes
+the current active call frame pointer.
+
+@index [Current-Stack-Pointer]
+Current-Stack-Pointer (@i[])@\returns the Control-Stack-Pointer that points
+to the current top of the stack (before the result of this operation is
+pushed). Note: by definition, this points to the
+to the last thing pushed.
+
+@index [Current-Binding-Pointer]
+Current-Binding-Pointer (@i[])@\returns a Binding-Stack-Pointer that points
+to the first word above the current top of the binding stack.
+
+@index [Read-Control-Stack]
+Read-Control-Stack (@i[F])@\@i[F] must be a control stack pointer. Returns
+the Lisp object that resides at this location. If the addressed object is
+totally outside the current stack, this is an error.
+
+@index [Write-Control-Stack]
+Write-Control-Stack (@i[F V])@\@i[F] is a stack pointer, @i[V] is any Lisp
+object. Writes @i[V] into the location addressed. If the addressed cell is
+totally outside the current stack, this is an error. Obviously, this should
+only be used by carefully written and debugged system code, since you can
+destroy the world by using this miscop.
+
+@index [Read-Binding-Stack]
+Read-Binding-Stack (@i[B])@\@i[B] must be a binding stack pointer. Reads and
+returns the Lisp object at this location. An error if the location specified
+is outside the current binding stack.
+
+@index [Write-Binding-Stack]
+Write-Binding-Stack (@i[B V])@\@i[B] must be a binding stack pointer. Writes
+@i[V] into the specified location. An error if the location specified is
+outside the current binding stack.
+@end(Description)
+
+@chapter [Control Conventions]
+@label [Control-Conventions]
+@index [Hairy stuff]
+
+@section [Function Calls]
+@index [Call]
+@index [Call-0]
+@index [Call-Multiple]
+
+On the Perq function calling is done by micro-coded instructions. The
+instructions perform a large number of operations, including determining
+whether the function being called is compiled or interpreted, determining that
+a legal number of arguments are passed, and branching to the correct entry
+point in the function. To do all this on the @value(DinkyMachine) would
+involve a large amount of computation. In the general case, it is necessary to
+do all this, but in some common cases, it is possible to short circuit most of
+this work.
+
+To perform a function call in the general case, the following steps occur:
+@begin(Enumerate)
+
+Allocate space on the control stack for the fix-sized part of a call
+frame. This space will be used to store all the registers that must
+be preserved across a function call.
+
+Arguments to the function are now evaluated. The first three
+arguments are stored in the argument registers A0, A1, and A2. The
+rest of the arguments are stored on the stack as they are evaluated.
+Note that during the evaluation of arguments, the argument registers
+may be used and may have to be stored in local variables and restored
+just before the called function is invoked.
+
+Load R0 with the argument count.
+
+Load the PC register with the offset into the current code vector of
+the place to return to when the function call is complete.
+
+If this call is for multiple values, mark the frame as accepting
+multiple values, by making the fixnum offset above negative by oring
+in the negative fixnum type code.
+
+Store all the registers that must be preserved over the function call in the
+current frame.
+@end(Enumerate)
+
+At this point, all the arguments are set up and all the registers have been
+saved. All the code to this point is done inline. If the object being called
+as a function is a symbol, we get the definition from the definition cell of
+the symbol. If this definition is the trap object, an undefined symbol error
+is generated. The function calling mechanism diverges at this point depending
+on the type of function being called, i.e., whether it is a compiled function
+object or a list.
+
+If we have a compiled function object, the following steps are performed (this
+code is out of line):
+@begin(Enumerate)
+Load the active function register with a pointer to the compiled function
+object.
+
+The active frame register is set to the start of the current frame.
+
+Note the number of arguments evaluated. Let this be K. The correct
+entry point in the called function's code vector must be computed as
+a function of K and the number of arguments the called function
+wants:
+@begin(Enumerate, spread 0, spacing 1)
+If K < minimum number of arguments, signal an error.
+
+If K > maximum number of arguments and there is no &rest argument,
+signal an error.
+
+If K > maximum number of arguments and there is a &rest argument,
+start at offset 0 in the code vector. This entry point must collect
+the excess arguments into a list and leave the &rest argument in the
+appropriate argument register or on the stack as appropriate.
+
+If K is between the minimum and maximum arguments (inclusive), get
+the starting offset from the appropriate slot of the called
+function's function object. This is stored as a fixnum in slot K -
+MIN + 6 of the function object.
+@end(Enumerate)
+
+Load one of the Non-Lisp temporary registers with the address of the
+code vector and add in the offset calculated above. Then do a branch
+register instruction with this register as the operand. The called
+function is now executing at the appropriate place.
+@end(enumerate)
+
+If the function being called is a list, %SP-Internal-Apply must be called to
+interpret the function with the given arguments. Proceed as follows:
+@begin(Enumerate)
+Note the number of arguments evaluated for the current open frame (call this N)
+and the frame pointer for the frame (call it F). Also remember the lambda
+expression in this frame (call it L).
+
+Load the active function register with the list L.
+
+Load the PC register with 0.
+
+Allocate a frame on the control stack for the call to %SP-Internal-Apply.
+
+Move the contents of the argument registers into the local registers L0, L1,
+and L2 respectively.
+
+Store all the preserved registers in the frame.
+
+Place N, F, and L into argument registers A0, A1, and A2 respectively.
+
+Do the equivalent of a start call on %SP-Internal-Apply.
+@end(Enumerate) %SP-Internal-Apply, a function of three arguments,
+now evaluates the call to the lambda-expression or interpreted
+lexical closure L, obtaining the arguments from the frame pointed to
+by F. The first three arguments must be obtained from the frame that
+%SP-Internal-Apply runs in, since they are stored in its stack frame
+and not on the stack as the rest of the arguments are. Prior to
+returning %SP-Internal-Apply sets the Active-Frame register to F, so
+that it returns from frame F.
+
+The above is the default calling mechanism. However, much of the
+overhead can be reduced. Most of the overhead is incurred by having
+to check the legality of the function call everytime the function is
+called. In many situations where the function being called is a
+symbol, this checking can be done only once per call site by
+introducing a data structure called a link table. The one exception
+to this rule is when the function apply is used with a symbol. In
+this situation, the argument count checks are still necessary, but
+checking for whether the function is a list or compiled function
+object can be bypassed.
+
+The link table is a hash table whose key is based on the name of the
+function, the number of arguments supplied to the call and a flag
+specifying whether the call is done through apply or not. Each entry
+of the link table consists of two words:
+@begin(Enumerate)
+The address of the function object associated with the symbol being
+called. This is here, so that double indirection is not needed to
+access the function object which must be loaded into the active
+function register. Initially, the symbol is stored in this slot.
+
+The address of the instruction in the function being called to start
+executing when this table entry is used. Initially, this points to
+an out of line routine that checks the legality of the call and
+calculates the correct place to jump to in the called function. This
+out of line routine replaces the contents of this word with the
+correct address it calculated. In the case when the call is caused
+by apply, this will often be an out of line routine that checks the
+argument count and calculates where to jump. In the case where the
+called function accepts &rest arguments and the minimum number of
+arguments passed is guaranteed to be greater than the maximum number
+of arguments, then a direct branch to the &rest arg entry point is
+made.
+@end(Enumerate)
+
+When a compiled file is loaded into the lisp environment, all the
+entries for the newly loaded functions will be set to an out of line
+routine mentioned above. Also, during a garbage collection the
+entries in this table must be updated when a function object for a
+symbol is moved.
+
+The @value(DinkyMachine) code to perform a function call using the link table
+becomes:
+@begin(Example)
+ cal CS,CS,%Frame-Size ; Alloc. space on control st.
+
+ <Code to evaluate arguments to the function>
+
+ cau NL1,0,high-half-word(lte(function nargs flag))
+ oil NL1,0,low-half-word(lte(function nargs flag))
+ cal PC,0,return-tag ; Offset into code vector.
+ <oiu PC,PC,#xF800 ; Mark if call-multiple frame>
+ stm L0,CS,-(%Frame-Size-4) ; Save preserved regs.
+ lm AF,NL1,0 ; Link table entry contents.
+ bnbrx pz,R15 ; Branch to called routine.
+ cal FP,CS,-(%Frame-Size-4) ; Get pointer to frame.
+return-tag:
+@end(Example)
+The first two instructions after the arguments are evaled get the
+address of the link table entry into a register. The two 16-bit half
+word entries are filled in at load time. The rest of the
+instructions should be fairly straight forward.
+
+@section(Returning from a Function Call)
+@label(Return)
+@index(Return)
+
+Returning from a function call on the Perq is done by a micro-coded
+instruction. On the @value(DinkyMachine), return has to do the following:
+@begin(enumerate)
+Pop the binding stack back to the binding stack pointer stored in the frame
+we're returning from. For each symbol/value pair popped of the binding stack,
+restore that value for the symbol.
+
+Save the current value of the frame pointer in a temporary registers. This
+will be used to restore the control stack pointer at the end.
+
+Restore all the registers that are preserved across a function call.
+
+Get a pointer to the code vector for the function we're returning to. This is
+retrieved from the code slot of what is now the active function.
+
+Make sure the relative PC (which is now in a register) is positive and add it
+to the code vector pointer above, giving the address of the instruction to
+return to.
+
+If the function is returning multiple values do a block transfer of all the
+return values down over the stack frame just released, i.e., the first return
+value should be stored where the temporarily saved frame pointer points to.
+In effect the return values can be pushed onto the stack using the saved frame
+pointer above as a stack pointer that is incremented everytime a value is
+pushed. Register A0 can be examined to determine the number of values that
+must be transferred.
+
+Set the control stack register to the saved frame pointer above. NB: it may
+have been updated if multiple values are being returned.
+
+Resume execution of the calling function.
+@end(enumerate)
+
+Again, it is not always necessary to use the general return code. At compile
+time it is often possible to determine that no special symbols have to be
+unbound and/or only one value is being returned. For example the code to
+perform a return when only one value is returned and it is unnecessary to
+unbind any special symbols is:
+@begin(Example)
+ cas NL1,FP,0 ; Save frame register.
+ lm L0,FP,0 ; Restore all preserved regs.
+ ls A3,AF,%function-code ; Get pointer to code vector.
+ niuo PC,PC,#x07FF ; Make relative PC positive.
+ cas PC,A3,PC ; Get addr. of instruction
+ bnbrx pz,PC ; to return to and do so while
+ cas CS,NL1,0 ; updating control stack reg.
+@end(Example)
+
+
+@subsection [Returning Multiple-Values]
+@label [Multi]
+@index [Multiple values]
+
+If the current frame can accept multiple values and a values marker is in
+register A0 indicating N values on top of the stack, it is necessary to copy
+the N return values down to the top of the control stack after the current
+frame is popped off. Thus returning multiple values is similar to the
+above, but a block transfer is necessary to move the returned values down to
+the correct location on the control stack.
+
+In tail recursive situations, such as in the last form of a PROGN, one
+function, FOO, may want to call another function, BAR, and return ``whatever
+BAR returns.'' Call-Multiple is used in this case. If BAR returns multiple
+values, they will all be passed to FOO. If FOO's caller wants multiple values,
+the values will be returned. If not, FOO's Return instruction will see that
+there are multiple values on the stack, but that multiple values will not be
+accepted by FOO's caller. So Return will return only the first value.
+
+@section [Non-Local Exits]
+@label [Catch]
+@index [Catch]
+@index [Throw]
+@index [Catch-All object]
+@index [Unwind-Protect]
+@index [Non-Local Exits]
+
+The Catch and Unwind-Protect special forms are implemented using
+catch frames. Unwind-Protect builds a catch frame whose tag is the
+Catch-All object. The Catch miscop creates a catch frame for a
+given tag and PC to branch to in the current instruction. The Throw
+miscop looks up the stack by following the chain of catch frames
+until it finds a frame with a matching tag or a frame with the
+Catch-All object as its tag. If it finds a frame with a matching
+tag, that frame is ``returned from,'' and that function is resumed.
+If it finds a frame with the Catch-All object as its tag, that frame
+is ``returned from,'' and in addition, %SP-Internal-Throw-Tag is set
+to the tag being searched for. So that interrupted cleanup forms
+behave correctly, %SP-Internal-Throw-Tag should be bound to the
+Catch-All object before the Catch-All frame is built. The protected
+forms are then executed, and if %SP-Internal-Throw-Tag is not the
+Catch-All object, its value is thrown to. Exactly what we do is
+this:
+@begin [enumerate]
+Put the contents of the Active-Catch register into a register, A.
+Put NIL into another register, B.
+
+If A is NIL, the tag we seek isn't on the stack. Signal an
+Unseen-Throw-Tag error.
+
+Look at the tag for the catch frame in register A. If it's the tag
+we're looking for, go to step 4. If it's the Catch-All object and B
+is NIL, copy A to B. Set A to the previous catch frame and go back
+to step 2.
+
+If B is non-NIL, we need to execute some cleanup forms. Return into
+B's frame and bind %SP-Internal-Throw-Tag to the tag we're searching
+for. When the cleanup forms are finished executing, they'll throw to
+this tag again.
+
+If B is NIL, return into this frame, pushing the return value (or
+BLTing the multiple values if this frame accepts multiple values and
+there are multiple values).
+@end [enumerate]
+
+If no form inside of a Catch results in a Throw, the catch frame
+needs to be removed from the stack before execution of the function
+containing the throw is resumed. For now, the value produced by the
+forms inside the Catch form are thrown to the tag. Some sort of
+specialized miscop could be used for this, but right now we'll
+just go with the throw. The branch PC specified by a Catch
+miscop is part of the constants area of the function object,
+much like the function's entry points.
+
+@section [Escaping to Lisp code]
+@label [Escape]
+@index [Escape to Lisp code convention]
+
+Escaping to Lisp code is fairly straight forward. If a miscop discovers that
+it needs to call a Lisp function, it creates a call frame on the control
+stack and sets it up so that the called function returns to the function that
+called the miscop. This means it is impossible to return control to a miscop
+from a Lisp function.
+
+@section [Errors]
+@label [Errors]
+@index [Errors]
+
+When an error occurs during the execution of a miscop, a call
+to %SP-Internal-Error is performed. This call is a break-type call,
+so if the error is proceeded (with a Break-Return instruction), no
+value will be returned.
+
+
+%SP-Internal-Error is passed a fixnum error code as its first
+argument. The second argument is a fixnum offset into the current
+code vector that points to the location immediately following the
+instruction that encountered the trouble. From this offset, the
+Lisp-level error handler can reconstruct the PC of the losing
+instruction, which is not readily available in the micro-machine.
+Following the offset, there may be 0 - 2 additional arguments that
+provide information of possible use to the error handler. For
+example, an unbound-symbol error will pass the symbol in question as
+the third arg.
+
+The following error codes are currently defined. Unless otherwise
+specified, only the error code and the code-vector offset are passed
+as arguments.
+
+@begin
+[description]
+1 Object Not List@\The object is passed as the third argument.
+
+2 Object Not Symbol@\The object is passed as the third argument.
+
+3 Object Not Number@\The object is passed as the third argument.
+
+4 Object Not Integer@\The object is passed as the third argument.
+
+5 Object Not Ratio@\The object is passed as the third argument.
+
+6 Object Not Complex@\The object is passed as the third argument.
+
+7 Object Not Vector@\The object is passed as the third argument.
+
+8 Object Not Simple Vector@\The object is passed as the third argument.
+
+9 Illegal Function Object@\The object is passed as the third argument.
+
+10 Object Not Header@\The object (which is not an array or function header)
+is passed as the third argument.
+
+11 Object Not I-Vector@\The object is passed as the third argument.
+
+12 Object Not Simple Bit Vector@\The object is passed as the third argument.
+
+13 Object Not Simple String@\The object is passed as the third argument.
+
+14 Object Not Character@\The object is passed as the third argument.
+
+15 Object Not Control Stack Pointer@\The object is passed as the third
+argument.
+
+16 Object Not Binding Stack Pointer@\The object is passed as the third
+argument.
+
+17 Object Not Array@\The object is passed as the third argument.
+
+18 Object Not Non-negative Fixnum@\The object is passed as the third
+argument.
+
+19 Object Not System Area Pointer@\The object is passed as the third
+argument.
+
+20 Object Not System Pointer@\The object is passed as the third argument.
+
+21 Object Not Float@\The object is passed as the third argument.
+
+22 Object Not Rational@\The object is passed as the third argument.
+
+23 Object Not Non-Complex Number@\A complex number has been passed to
+the comparison routine for < or >. The complex number is passed as the
+third argument.
+
+25 Unbound Symbol @\Attempted access to the special value of an unbound
+symbol. Passes the symbol as the third argument to %Sp-Internal-Error.
+
+26 Undefined Symbol @\Attempted access to the definition cell of an undefined
+symbol. Passes the symbol as the third argument to %Sp-Internal-Error.
+
+27 Altering NIL @\Attempt to bind or setq the special value of NIL.
+
+28 Altering T @\Attempt to bind or setq the special value of T.
+
+30 Illegal Vector Access Type @\The specified access type is returned as the
+third argument.
+
+31 Illegal Vector Size @\Attempt to allocate a vector with negative size or
+size too large for vectors of this type. Passes the requested size as the
+third argument.
+
+32 Vector Index Out of Range @\The specified index is out of bounds for
+this vector. The bad index is passed as the third argument.
+
+33 Illegal Vector Index@\The specified index is not a positive fixnum. The
+bad index is passed as the third argument.
+
+34 Illegal Shrink Vector Value@\The specified value to shrink a vector to is
+not a positive fixnum. The bad value is passed as the third argument.
+
+35 Not A Shrink@\The specified value is greater than the current size of the
+vector being shrunk. The bad value is passed as the third argument.
+
+36 Illegal Data Vector@\The data vector of an array is illegal. The bad
+vector is passed as the third value.
+
+37 Array has Too Few Indices@\An attempt has been made to access
+an array as a two or three dimensional array when it has fewer than two
+or three dimensions, respectively.
+
+38 Array has Too Many Indices@\An attempt has been made to access an array
+as a two or three dimensional array when it has more than two or three
+dimensions, respectively.
+
+40 Illegal Byte Specifier@\A bad byte specifier has been passed to one
+of the byte manipulation miscops. The offending byte specifier is passed
+as the third argument.
+
+41 Illegal Position in Byte Specifier@\A bad position has been given in a
+byte specifier that has been passed to one of the byte manipulation
+miscops. The offending byte specifier is passed as the third
+argument.
+
+42 Illegal Size in Byte Specifier@\A bad size has been given in a
+byte specifier that has been passed to one of the byte manipulation
+miscops. The offending byte specifier is passed as the third
+argument.
+
+43 Illegal Shift Count@\A shift miscop has encountered non fixnum shift
+count. The offending shift count is passed as the third argument.
+
+44 Illegal Boole Operation@\The operation code passed to the boole miscop
+is either not a fixnum or is out of range. The operation code is passed as
+the third argument.
+
+50 Too Few Arguments@\Too few arguments have been passed to a function. The
+number of arguments actually passed is passed as the third argument, and the
+function is passed as the fourth.
+
+51 Too Many Arguments@\Too many arguments have been passed to a function.
+The number of arguments actually passed is passed as the third argument, and
+the function is passed as the fourth.
+
+52 Last Apply Arg Not a List@\The last argument to a function being
+invoked by apply is not a list. The last argument is passed as the third
+argument.
+
+53 Deleted Link Table Entry@\An attempt has been made to call a function
+through a link table entry which no longer exists. This is a serious
+internal error and should never happen.
+
+55 Error Not <=@\The check-<= miscop will invoke this error if the condition
+is false. The two arguments are passed as the third and fourth arguments
+to %SP-internal-error.
+
+60 Divide by 0@\An division operation has done a division by zero. The
+two operands are passed as the third and fourth arguments.
+
+61 Unseen Throw Tag@\An attempt has been made to throw to a tag that is
+not in the current catch hierarchy. The offending tag is passed as the
+third argument.
+
+62 Short Float Underflow@\A short float operation has resulted in
+underflow. The two arguments to the operation are passed as the third
+and fourth arguments.
+
+63 Short Float Overflow@\A short float operation has resulted in
+overflow. The two arguments to the operation are passed as the third
+and fourth arguments.
+
+64 Single Float Underflow@\A single float operation has resulted in
+underflow. The two arguments to the operation are passed as the third
+and fourth arguments.
+
+65 Single Float Overflow@\A single float operation has resulted in
+overflow. The two arguments to the operation are passed as the third
+and fourth arguments.
+
+66 Long Float Underflow@\A long float operation has resulted in
+underflow. The two arguments to the operation are passed as the third
+and fourth arguments.
+
+67 Long Float Overflow@\A long float operation has resulted in
+overflow. The two arguments to the operation are passed as the third
+and fourth arguments.
+
+68 Monadic Short Float Underflow@\A short float operation has resulted in
+underflow. The argument to the operation is passed as the third argument.
+
+69 Monadic Short Float Overflow@\A short float operation has resulted in
+overflow. The argument to the operation is passed as the third argument.
+
+70 Monadic Long Float Underflow@\A long float operation has resulted in
+underflow. The argument to the operation is passed as the third argument.
+
+71 Monadic Long Float Overflow@\A long float operation has resulted in
+overflow. The argument to the operation is passed as the third argument.
+@end [description]
+
+@section [Trapping to the Mach Kernel]
+@label [Trap]
+@index [Trapping to the kernel]
+@index [Kernel traps]
+
+Trapping to the Mach kernel is done through one of the syscall0, syscall1,
+syscall2, syscall3, syscall4, or syscall miscops. The first argument to
+these miscops is the number of the Unix syscall that is to be invoked. Any
+other arguments the syscall requires are passed in order after the first
+one. Syscall0 accepts only the syscall number and no other arguments;
+syscall1 accepts the syscall number and a single argument to the syscall;
+etc. Syscall accepts the syscall number and five or more arguments to the
+Unix syscall. These syscalls generally return two values: the result twice
+if the syscall succeeded and a -1 and the Unix error code if the syscall
+failed.
+
+@section [Interrupts]
+@label [Interrupts]
+@index [Interrupts]
+
+An interface has been built to the general signal mechanism defined by the
+Unix operating system. As mentioned in the section on function call and
+return miscops, several miscops are defined that support the lowest level
+interface to the Unix signal mechanism. The manual @I[CMU Common Lisp
+User's Manual, Mach/IBM RT PC Edition] contains descriptions of functions
+that allow a user to set up interrupt handlers for any of the Unix signals
+from within Lisp.
+
+@appendix [Fasload File Format]
+@section [General]
+
+The purpose of Fasload files is to allow concise storage and rapid
+loading of Lisp data, particularly function definitions. The intent
+is that loading a Fasload file has the same effect as loading the
+ASCII file from which the Fasload file was compiled, but accomplishes
+the tasks more efficiently. One noticeable difference, of course, is
+that function definitions may be in compiled form rather than
+S-expression form. Another is that Fasload files may specify in what
+parts of memory the Lisp data should be allocated. For example,
+constant lists used by compiled code may be regarded as read-only.
+
+In some Lisp implementations, Fasload file formats are designed to
+allow sharing of code parts of the file, possibly by direct mapping
+of pages of the file into the address space of a process. This
+technique produces great performance improvements in a paged
+time-sharing system. Since the Mach project is to produce a
+distributed personal-computer network system rather than a
+time-sharing system, efficiencies of this type are explicitly @i[not]
+a goal for the CMU Common Lisp Fasload file format.
+
+On the other hand, CMU Common Lisp is intended to be portable, as it will
+eventually run on a variety of machines. Therefore an explicit goal
+is that Fasload files shall be transportable among various
+implementations, to permit efficient distribution of programs in
+compiled form. The representations of data objects in Fasload files
+shall be relatively independent of such considerations as word
+length, number of type bits, and so on. If two implementations
+interpret the same macrocode (compiled code format), then Fasload
+files should be completely compatible. If they do not, then files
+not containing compiled code (so-called "Fasdump" data files) should
+still be compatible. While this may lead to a format which is not
+maximally efficient for a particular implementation, the sacrifice of
+a small amount of performance is deemed a worthwhile price to pay to
+achieve portability.
+
+The primary assumption about data format compatibility is that all
+implementations can support I/O on finite streams of eight-bit bytes.
+By "finite" we mean that a definite end-of-file point can be detected
+irrespective of the content of the data stream. A Fasload file will
+be regarded as such a byte stream.
+
+@section [Strategy]
+
+A Fasload file may be regarded as a human-readable prefix followed by
+code in a funny little language. When interpreted, this code will
+cause the construction of the encoded data structures. The virtual
+machine which interprets this code has a @i[stack] and a @i[table],
+both initially empty. The table may be thought of as an expandable
+register file; it is used to remember quantities which are needed
+more than once. The elements of both the stack and the table are
+Lisp data objects. Operators of the funny language may take as
+operands following bytes of the data stream, or items popped from the
+stack. Results may be pushed back onto the stack or pushed onto the
+table. The table is an indexable stack that is never popped; it is
+indexed relative to the base, not the top, so that an item once
+pushed always has the same index.
+
+More precisely, a Fasload file has the following macroscopic
+organization. It is a sequence of zero or more groups concatenated
+together. End-of-file must occur at the end of the last group. Each
+group begins with a series of seven-bit ASCII characters terminated
+by one or more bytes of all ones (FF@-(16)); this is called the
+@i[header]. Following the bytes which terminate the header is the
+@i[body], a stream of bytes in the funny binary language. The body
+of necessity begins with a byte other than FF@-(16). The body is
+terminated by the operation @f[FOP-END-GROUP].
+
+The first nine characters of the header must be "@f[FASL FILE]" in
+upper-case letters. The rest may be any ASCII text, but by
+convention it is formatted in a certain way. The header is divided
+into lines, which are grouped into paragraphs. A paragraph begins
+with a line which does @i[not] begin with a space or tab character,
+and contains all lines up to, but not including, the next such line.
+The first word of a paragraph, defined to be all characters up to but
+not including the first space, tab, or end-of-line character, is the
+@i[name] of the paragraph. A Fasload file header might look something like
+this:
+@begin(verbatim)
+FASL FILE >SteelesPerq>User>Guy>IoHacks>Pretty-Print.Slisp
+Package Pretty-Print
+Compiled 31-Mar-1988 09:01:32 by some random luser
+Compiler Version 1.6, Lisp Version 3.0.
+Functions: INITIALIZE DRIVER HACK HACK1 MUNGE MUNGE1 GAZORCH
+ MINGLE MUDDLE PERTURB OVERDRIVE GOBBLE-KEYBOARD
+ FRY-USER DROP-DEAD HELP CLEAR-MICROCODE
+ %AOS-TRIANGLE %HARASS-READTABLE-MAYBE
+Macros: PUSH POP FROB TWIDDLE
+@r[<one or more bytes of FF@-(16)>]
+@end(verbatim)
+The particular paragraph names and contents shown here are only intended as
+suggestions.
+
+@section [Fasload Language]
+
+Each operation in the binary Fasload language is an eight-bit
+(one-byte) opcode. Each has a name beginning with "@f[FOP-]". In
+the following descriptions, the name is followed by operand
+descriptors. Each descriptor denotes operands that follow the opcode
+in the input stream. A quantity in parentheses indicates the number
+of bytes of data from the stream making up the operand. Operands
+which implicitly come from the stack are noted in the text. The
+notation "@PushArrow stack" means that the result is pushed onto the
+stack; "@PushArrow table" similarly means that the result is added to the
+table. A construction like "@i[n](1) @i[value](@i[n])" means that
+first a single byte @i[n] is read from the input stream, and this
+byte specifies how many bytes to read as the operand named @i[value].
+All numeric values are unsigned binary integers unless otherwise
+specified. Values described as "signed" are in two's-complement form
+unless otherwise specified. When an integer read from the stream
+occupies more than one byte, the first byte read is the least
+significant byte, and the last byte read is the most significant (and
+contains the sign bit as its high-order bit if the entire integer is
+signed).
+
+Some of the operations are not necessary, but are rather special
+cases of or combinations of others. These are included to reduce the
+size of the file or to speed up important cases. As an example,
+nearly all strings are less than 256 bytes long, and so a special
+form of string operation might take a one-byte length rather than a
+four-byte length. As another example, some implementations may
+choose to store bits in an array in a left-to-right format within
+each word, rather than right-to-left. The Fasload file format may
+support both formats, with one being significantly more efficient
+than the other for a given implementation. The compiler for any
+implementation may generate the more efficient form for that
+implementation, and yet compatibility can be maintained by requiring
+all implementations to support both formats in Fasload files.
+
+Measurements are to be made to determine which operation codes are
+worthwhile; little-used operations may be discarded and new ones
+added. After a point the definition will be "frozen", meaning that
+existing operations may not be deleted (though new ones may be added;
+some operations codes will be reserved for that purpose).
+
+@begin(description)
+0 @f[ ] @f[FOP-NOP] @\
+No operation. (This is included because it is recognized
+that some implementations may benefit from alignment of operands to some
+operations, for example to 32-bit boundaries. This operation can be used
+to pad the instruction stream to a desired boundary.)
+
+1 @f[ ] @f[FOP-POP] @f[ ] @PushArrow @f[ ] table @\
+One item is popped from the stack and added to the table.
+
+2 @f[ ] @f[FOP-PUSH] @f[ ] @i[index](4) @f[ ] @PushArrow @f[ ] stack @\
+Item number @i[index] of the table is pushed onto the stack.
+The first element of the table is item number zero.
+
+3 @f[ ] @f[FOP-BYTE-PUSH] @f[ ] @i[index](1) @f[ ] @PushArrow @f[ ] stack @\
+Item number @i[index] of the table is pushed onto the stack.
+The first element of the table is item number zero.
+
+4 @f[ ] @f[FOP-EMPTY-LIST] @f[ ] @PushArrow @f[ ] stack @\
+The empty list (@f[()]) is pushed onto the stack.
+
+5 @f[ ] @f[FOP-TRUTH] @f[ ] @PushArrow @f[ ] stack @\
+The standard truth value (@f[T]) is pushed onto the stack.
+
+6 @f[ ] @f[FOP-SYMBOL-SAVE] @f[ ] @i[n](4) @f[ ] @i[name](@i[n])
+@f[ ] @PushArrow @f[ ] stack & table@\
+The four-byte operand @i[n] specifies the length of the print name
+of a symbol. The name follows, one character per byte,
+with the first byte of the print name being the first read.
+The name is interned in the default package,
+and the resulting symbol is both pushed onto the stack and added to the table.
+
+7 @f[ ] @f[FOP-SMALL-SYMBOL-SAVE] @f[ ] @i[n](1) @f[ ] @i[name](@i[n]) @f[ ] @PushArrow @f[ ] stack & table@\
+The one-byte operand @i[n] specifies the length of the print name
+of a symbol. The name follows, one character per byte,
+with the first byte of the print name being the first read.
+The name is interned in the default package,
+and the resulting symbol is both pushed onto the stack and added to the table.
+
+8 @f[ ] @f[FOP-SYMBOL-IN-PACKAGE-SAVE] @f[ ] @i[index](4)
+@f[ ] @i[n](4) @f[ ] @i[name](@i[n])
+@f[ ] @PushArrow @f[ ] stack & table@\
+The four-byte @i[index] specifies a package stored in the table.
+The four-byte operand @i[n] specifies the length of the print name
+of a symbol. The name follows, one character per byte,
+with the first byte of the print name being the first read.
+The name is interned in the specified package,
+and the resulting symbol is both pushed onto the stack and added to the table.
+
+9 @f[ ] @f[FOP-SMALL-SYMBOL-IN-PACKAGE-SAVE] @f[ ] @i[index](4)
+@f[ ] @i[n](1) @f[ ] @i[name](@i[n]) @f[ ]
+@PushArrow @f[ ] stack & table@\
+The four-byte @i[index] specifies a package stored in the table.
+The one-byte operand @i[n] specifies the length of the print name
+of a symbol. The name follows, one character per byte,
+with the first byte of the print name being the first read.
+The name is interned in the specified package,
+and the resulting symbol is both pushed onto the stack and added to the table.
+
+10 @f[ ] @f[FOP-SYMBOL-IN-BYTE-PACKAGE-SAVE] @f[ ] @i[index](1)
+@f[ ] @i[n](4) @f[ ] @i[name](@i[n])
+@f[ ] @PushArrow @f[ ] stack & table@\
+The one-byte @i[index] specifies a package stored in the table.
+The four-byte operand @i[n] specifies the length of the print name
+of a symbol. The name follows, one character per byte,
+with the first byte of the print name being the first read.
+The name is interned in the specified package,
+and the resulting symbol is both pushed onto the stack and added to the table.
+
+11@f[ ] @f[FOP-SMALL-SYMBOL-IN-BYTE-PACKAGE-SAVE] @f[ ] @i[index](1)
+@f[ ] @i[n](1) @f[ ] @i[name](@i[n]) @f[ ]
+@PushArrow @f[ ] stack & table@\
+The one-byte @i[index] specifies a package stored in the table.
+The one-byte operand @i[n] specifies the length of the print name
+of a symbol. The name follows, one character per byte,
+with the first byte of the print name being the first read.
+The name is interned in the specified package,
+and the resulting symbol is both pushed onto the stack and added to the table.
+
+12 Unused.
+
+13 @f[ ] @f[FOP-DEFAULT-PACKAGE] @f[ ] @i[index](4) @\
+A package stored in the table entry specified by @i[index] is made
+the default package for future @f[FOP-SYMBOL] and @f[FOP-SMALL-SYMBOL]
+interning operations. (These package FOPs may change or disappear
+as the package system is determined.)
+
+14 @f[ ] @f[FOP-PACKAGE] @f[ ] @PushArrow @f[ ] table @\
+An item is popped from the stack; it must be a symbol. The package of
+that name is located and pushed onto the table.
+
+15 @f[ ] @f[FOP-LIST] @f[ ] @i[length](1) @f[ ] @PushArrow @f[ ] stack @\
+The unsigned operand @i[length] specifies a number of
+operands to be popped from the stack. These are made into a list
+of that length, and the list is pushed onto the stack.
+The first item popped from the stack becomes the last element of
+the list, and so on. Hence an iterative loop can start with
+the empty list and perform "pop an item and cons it onto the list"
+@i[length] times.
+(Lists of length greater than 255 can be made by using @f[FOP-LIST*]
+repeatedly.)
+
+16 @f[ ] @f[FOP-LIST*] @f[ ] @i[length](1) @f[ ] @PushArrow @f[ ] stack @\
+This is like @f[FOP-LIST] except that the constructed list is terminated
+not by @f[()] (the empty list), but by an item popped from the stack
+before any others are. Therefore @i[length]+1 items are popped in all.
+Hence an iterative loop can start with
+a popped item and perform "pop an item and cons it onto the list"
+@i[length]+1 times.
+
+17-24 @f[ ] @f[FOP-LIST-1], @f[FOP-LIST-2], ..., @f[FOP-LIST-8] @\
+@f[FOP-LIST-@i{k}] is like @f[FOP-LIST] with a byte containing @i[k]
+following it. These exist purely to reduce the size of Fasload files.
+Measurements need to be made to determine the useful values of @i[k].
+
+25-32 @f[ ] @f[FOP-LIST*-1], @f[FOP-LIST*-2], ..., @f[FOP-LIST*-8] @\
+@f[FOP-LIST*-@i{k}] is like @f[FOP-LIST*] with a byte containing @i[k]
+following it. These exist purely to reduce the size of Fasload files.
+Measurements need to be made to determine the useful values of @i[k].
+
+33 @f[ ] @f[FOP-INTEGER] @f[ ] @i[n](4) @f[ ] @i[value](@i[n]) @f[ ]
+@PushArrow @f[ ] stack @\
+A four-byte unsigned operand specifies the number of following
+bytes. These bytes define the value of a signed integer in two's-complement
+form. The first byte of the value is the least significant byte.
+
+34 @f[ ] @f[FOP-SMALL-INTEGER] @f[ ] @i[n](1) @f[ ] @i[value](@i[n])
+@f[ ] @PushArrow @f[ ] stack @\
+A one-byte unsigned operand specifies the number of following
+bytes. These bytes define the value of a signed integer in two's-complement
+form. The first byte of the value is the least significant byte.
+
+35 @f[ ] @f[FOP-WORD-INTEGER] @f[ ] @i[value](4) @f[ ] @PushArrow @f[ ] stack @\
+A four-byte signed integer (in the range -2@+[31] to 2@+[31]-1) follows the
+operation code. A LISP integer (fixnum or bignum) with that value
+is constructed and pushed onto the stack.
+
+36 @f[ ] @f[FOP-BYTE-INTEGER] @f[ ] @i[value](1) @f[ ] @PushArrow @f[ ] stack @\
+A one-byte signed integer (in the range -128 to 127) follows the
+operation code. A LISP integer (fixnum or bignum) with that value
+is constructed and pushed onto the stack.
+
+37 @f[ ] @f[FOP-STRING] @f[ ] @i[n](4) @f[ ] @i[name](@i[n])
+@f[ ] @PushArrow @f[ ] stack @\
+The four-byte operand @i[n] specifies the length of a string to
+construct. The characters of the string follow, one per byte.
+The constructed string is pushed onto the stack.
+
+38 @f[ ] @f[FOP-SMALL-STRING] @f[ ] @i[n](1) @f[ ] @i[name](@i[n]) @f[ ] @PushArrow @f[ ] stack @\
+The one-byte operand @i[n] specifies the length of a string to
+construct. The characters of the string follow, one per byte.
+The constructed string is pushed onto the stack.
+
+39 @f[ ] @f[FOP-VECTOR] @f[ ] @i[n](4) @f[ ] @PushArrow @f[ ] stack @\
+The four-byte operand @i[n] specifies the length of a vector of LISP objects
+to construct. The elements of the vector are popped off the stack;
+the first one popped becomes the last element of the vector.
+The constructed vector is pushed onto the stack.
+
+40 @f[ ] @f[FOP-SMALL-VECTOR] @f[ ] @i[n](1) @f[ ] @PushArrow @f[ ] stack @\
+The one-byte operand @i[n] specifies the length of a vector of LISP objects
+to construct. The elements of the vector are popped off the stack;
+the first one popped becomes the last element of the vector.
+The constructed vector is pushed onto the stack.
+
+41 @f[ ] @f[FOP-UNIFORM-VECTOR] @f[ ] @i[n](4) @f[ ] @PushArrow @f[ ] stack @\
+The four-byte operand @i[n] specifies the length of a vector of LISP objects
+to construct. A single item is popped from the stack and used to initialize
+all elements of the vector. The constructed vector is pushed onto the stack.
+
+42 @f[ ] @f[FOP-SMALL-UNIFORM-VECTOR] @f[ ] @i[n](1) @f[ ] @PushArrow @f[ ] stack @\
+The one-byte operand @i[n] specifies the length of a vector of LISP objects
+to construct. A single item is popped from the stack and used to initialize
+all elements of the vector. The constructed vector is pushed onto the stack.
+
+43 @f[ ] @f[FOP-INT-VECTOR] @f[ ] @i[n](4) @f[ ] @i[size](1) @f[ ] @i[count](1) @f[ ]
+@i[data](@ceiling<@i[n]/@i[count]>@ceiling<@i[size]*@i[count]/8>) @f[ ]
+@PushArrow @f[ ] stack @\
+The four-byte operand @i[n] specifies the length of a vector of
+unsigned integers to be constructed. Each integer is @i[size]
+bits big, and are packed in the data stream in sections of
+@i[count] apiece. Each section occupies an integral number of bytes.
+If the bytes of a section are lined up in a row, with the first
+byte read at the right, and successive bytes placed to the left,
+with the bits within a byte being arranged so that the low-order bit
+is to the right, then the integers of the section are successive
+groups of @i[size] bits, starting from the right and running across
+byte boundaries. (In other words, this is a consistent
+right-to-left convention.) Any bits wasted at the left end of
+a section are ignored, and any wasted groups in the last section
+are ignored.
+It is permitted for the loading implementation to use a vector
+format providing more precision than is required by @i[size].
+For example, if @i[size] were 3, it would be permitted to use a vector
+of 4-bit integers, or even vector of general LISP objects filled
+with integer LISP objects. However, an implementation is expected
+to use the most restrictive format that will suffice, and is expected
+to reconstruct objects identical to those output if the Fasload file
+was produced by the same implementation.
+(For the PERQ U-vector formats, one would have
+@i[size] an element of {1, 2, 4, 8, 16}, and @i[count]=32/@i[size];
+words could be read directly into the U-vector.
+This operation provides a very general format whereby almost
+any conceivable implementation can output in its preferred packed format,
+and another can read it meaningfully; by checking at the beginning
+for good cases, loading can still proceed quickly.)
+The constructed vector is pushed onto the stack.
+
+44 @f[ ] @f[FOP-UNIFORM-INT-VECTOR] @f[ ] @i[n](4) @f[ ] @i[size](1) @f[ ]
+@i[value](@ceiling<@i[size]/8>) @f[ ] @PushArrow @f[ ] stack @\
+The four-byte operand @i[n] specifies the length of a vector of unsigned
+integers to construct.
+Each integer is @i[size] bits big, and is initialized to the value
+of the operand @i[value].
+The constructed vector is pushed onto the stack.
+
+45 @f[ ] @f[FOP-FLOAT] @f[ ] @i[n](1) @f[ ] @i[exponent](@ceiling<@i[n]/8>) @f[ ]
+@i[m](1) @f[ ] @i[mantissa](@ceiling<@i[m]/8>) @f[ ] @PushArrow @f[ ] stack @\
+The first operand @i[n] is one unsigned byte, and describes the number of
+@i[bits] in the second operand @i[exponent], which is a signed
+integer in two's-complement format. The high-order bits of
+the last (most significant) byte of @i[exponent] shall equal the sign bit.
+Similar remarks apply to @i[m] and @i[mantissa]. The value denoted by these
+four operands is @i[mantissa]@f[x]2@+{@i[exponent]-length(@i[mantissa])}.
+A floating-point number shall be constructed which has this value,
+and then pushed onto the stack. That floating-point format should be used
+which is the smallest (most compact) provided by the implementation which
+nevertheless provides enough accuracy to represent both the exponent
+and the mantissa correctly.
+
+46-51 Unused
+
+52 @f[ ] @f[FOP-ALTER] @f[ ] @i[index](1) @\
+Two items are popped from the stack; call the first @i[newval] and
+the second @i[object]. The component of @i[object] specified by
+@i[index] is altered to contain @i[newval]. The precise operation
+depends on the type of @i[object]:
+@begin(description)
+List @\ A zero @i[index] means alter the car (perform @f[RPLACA]),
+and @i[index]=1 means alter the cdr (@f[RPLACD]).
+
+Symbol @\ By definition these indices have the following meaning,
+and have nothing to do with the actual representation of symbols
+in a given implementation:
+@begin(description)
+0 @\ Alter value cell.
+
+1 @\ Alter function cell.
+
+2 @\ Alter property list (!).
+@end(description)
+
+Vector (of any kind) @\ Alter component number @i[index] of the vector.
+
+String @\ Alter character number @i[index] of the string.
+@end(description)
+
+53 @f[ ] @f[FOP-EVAL] @f[ ] @PushArrow @f[ ] stack @\
+Pop an item from the stack and evaluate it (give it to @f[EVAL]).
+Push the result back onto the stack.
+
+54 @f[ ] @f[FOP-EVAL-FOR-EFFECT] @\
+Pop an item from the stack and evaluate it (give it to @f[EVAL]).
+The result is ignored.
+
+55 @f[ ] @f[FOP-FUNCALL] @f[ ] @i[nargs](1) @f[ ] @PushArrow @f[ ] stack @\
+Pop @i[nargs]+1 items from the stack and apply the last one popped
+as a function to
+all the rest as arguments (the first one popped being the last argument).
+Push the result back onto the stack.
+
+56 @f[ ] @f[FOP-FUNCALL-FOR-EFFECT] @f[ ] @i[nargs](1) @\
+Pop @i[nargs]+1 items from the stack and apply the last one popped
+as a function to
+all the rest as arguments (the first one popped being the last argument).
+The result is ignored.
+
+57 @f[ ] @f[FOP-CODE-FORMAT] @f[ ] @i[id](1) @\
+The operand @i[id] is a unique identifier specifying the format
+for following code objects. The operations @f[FOP-CODE]
+and its relatives may not
+occur in a group until after @f[FOP-CODE-FORMAT] has appeared;
+there is no default format. This is provided so that several
+compiled code formats may co-exist in a file, and so that a loader
+can determine whether or not code was compiled by the correct
+compiler for the implementation being loaded into.
+So far the following code format identifiers are defined:
+@begin(description)
+0 @\ PERQ
+
+1 @\ VAX
+
+3 @\ @value(DinkyMachine)
+@end(description)
+
+58 @f[ ] @f[FOP-CODE] @f[ ] @i[nitems](4) @f[ ] @i[size](4) @f[ ]
+@i[code](@i[size]) @f[ ] @PushArrow @f[ ] stack @\
+A compiled function is constructed and pushed onto the stack.
+This object is in the format specified by the most recent
+occurrence of @f[FOP-CODE-FORMAT].
+The operand @i[nitems] specifies a number of items to pop off
+the stack to use in the "boxed storage" section. The operand @i[code]
+is a string of bytes constituting the compiled executable code.
+
+59 @f[ ] @f[FOP-SMALL-CODE] @f[ ] @i[nitems](1) @f[ ] @i[size](2) @f[ ]
+@i[code](@i[size]) @f[ ] @PushArrow @f[ ] stack @\
+A compiled function is constructed and pushed onto the stack.
+This object is in the format specified by the most recent
+occurrence of @f[FOP-CODE-FORMAT].
+The operand @i[nitems] specifies a number of items to pop off
+the stack to use in the "boxed storage" section. The operand @i[code]
+is a string of bytes constituting the compiled executable code.
+
+60 @f[ ] @f[FOP-STATIC-HEAP] @\
+Until further notice operations which allocate data structures
+may allocate them in the static area rather than the dynamic area.
+(The default area for allocation is the dynamic area; this
+default is reset whenever a new group is begun.
+This command is of an advisory nature; implementations with no
+static heap can ignore it.)
+
+61 @f[ ] @f[FOP-DYNAMIC-HEAP] @\
+Following storage allocation should be in the dynamic area.
+
+62 @f[ ] @f[FOP-VERIFY-TABLE-SIZE] @f[ ] @i[size](4) @\
+If the current size of the table is not equal to @i[size],
+then an inconsistency has been detected. This operation
+is inserted into a Fasload file purely for error-checking purposes.
+It is good practice for a compiler to output this at least at the
+end of every group, if not more often.
+
+63 @f[ ] @f[FOP-VERIFY-EMPTY-STACK] @\
+If the stack is not currently empty,
+then an inconsistency has been detected. This operation
+is inserted into a Fasload file purely for error-checking purposes.
+It is good practice for a compiler to output this at least at the
+end of every group, if not more often.
+
+64 @f[ ] @f[FOP-END-GROUP] @\
+This is the last operation of a group. If this is not the
+last byte of the file, then a new group follows; the next
+nine bytes must be "@f[FASL FILE]".
+
+65 @f[ ] @f[FOP-POP-FOR-EFFECT] @f[ ] stack @f[ ] @PushArrow @f[ ] @\
+One item is popped from the stack.
+
+66 @f[ ] @f[FOP-MISC-TRAP] @f[ ] @PushArrow @f[ ] stack @\
+A trap object is pushed onto the stack.
+
+67 @f[ ] @f[FOP-READ-ONLY-HEAP] @\
+Following storage allocation may be in a read-only heap.
+(For symbols, the symbol itself may not be in a read-only area,
+but its print name (a string) may be.
+This command is of an advisory nature; implementations with no
+read-only heap can ignore it, or use a static heap.)
+
+68 @f[ ] @f[FOP-CHARACTER] @f[ ] @i[character](3) @f[ ] @PushArrow @f[ ] stack @\
+The three bytes specify the 24 bits of a CMU Common Lisp character object.
+The bytes, lowest first, represent the code, control, and font bits.
+A character is constructed and pushed onto the stack.
+
+69 @f[ ] @f[FOP-SHORT-CHARACTER] @f[ ] @i[character](1) @f[ ]
+@PushArrow @f[ ] stack @\
+The one byte specifies the lower eight bits of a CMU Common Lisp character
+object (the code). A character is constructed with zero control
+and zero font attributes and pushed onto the stack.
+
+70 @f[ ] @f[FOP-RATIO] @f[ ] @PushArrow @f[ ] stack @\
+Creates a ratio from two integers popped from the stack.
+The denominator is popped first, the numerator second.
+
+71 @f[ ] @f[FOP-COMPLEX] @f[ ] @PushArrow @f[ ] stack @\
+Creates a complex number from two numbers popped from the stack.
+The imaginary part is popped first, the real part second.
+
+72 @f[ ] @f[FOP-LINK-ADDRESS-FIXUP] @f[ ] @i[nargs](1) @f[ ] @i[restp](1)
+@f[ ] @i[offset](4) @f[ ] @PushArrow @f[ ] stack @\
+Valid only for when FOP-CODE-FORMAT corresponds to the Vax or the
+@value(DinkyMachine).
+This operation pops a symbol and a code object from the stack and pushes
+a modified code object back onto the stack according to the needs of the
+runtime code linker on the Vax or @value(DinkyMachine).
+
+73 @f[ ] @f[FOP-LINK-FUNCTION-FIXUP] @f[ ] @i[offset](4) @f[ ]
+@PushArrow @f[ ] stack @\
+Valid only for when FOP-CODE-FORMAT corresponds to the Vax or the
+@value(DinkyMachine).
+This operation pops a symbol and a code object from the stack and pushes
+a modified code object back onto the stack according to the needs of the
+runtime code linker on the Vax or the @value(DinkyMachine).
+
+74 @f[ ] @f[FOP-FSET] @f[ ] @\
+Pops the top two things off of the stack and uses them as arguments to FSET
+(i.e. SETF of SYMBOL-FUNCTION).
+
+128 @f[ ] @f[FOP-LINK-ADDRESS-FIXUP] @f[ ] @i[nargs] @f[ ] @i[flag] @f[ ]
+@i[offset] @f[ ]@\Valid only when FOP-CODE-FORMAT corresponds to the
+@value(DinkyMachine). This operation pops a symbol and a function object
+off the stack. The code vector in the function object is modified
+according to the needs of the runtime code linker of the @value(DinkyMachine)
+and pushed back on the stack. This FOP links in calls to other functions.
+
+129 @f[ ] @f[FOP-MISCOP-FIXUP] @f[ ] @i[index](2) @f[ ] @i[offset](4) @f[ ]@\
+Valid only when FOP-CODE-FORMAT corresponds to the @value(DinkyMachine).
+This operation pops a code object from the stack and pushes a
+modified code object back onto the stack according to the needs of
+the runtime code linker on the @value(DinkyMachine). This FOP links in
+calls to the assembler language support routines.
+
+130 @f[ ] @f[FOP-ASSEMBLER-ROUTINE] @f[ ] @i[code-length] @f[ ] @\
+Valid only when FOP-CODE-FORMAT corresponds to the @value(DinkyMachine).
+This operation loads assembler code into the assembler code space of the
+currently running Lisp.
+
+131 @f[ ] @f[FOP-FIXUP-MISCOP-ROUTINE] @f[ ]@\Valid only when FOP-CODE-FORMAT
+corresponds to the @value(DinkyMachine). This operation pops a list of
+external references, a list of external labels defined, the name, and the
+code address off the stack. This information is saved, so that after
+everything is loaded, all the external references can be resolved.
+
+132 @f[ ] @f[FOP-FIXUP-ASSEMBLER-ROUTINE] @f[ ]@\is similar to
+FOP-FIXUP-MISCOP-ROUTINE, except it is for internal assembler routines
+rather than ones visible to Lisp.
+
+133 @f[ ] @f[FOP-FIXUP-USER-MISCOP-ROUTINE] @f[ ]@\is similar to
+FOP-FIXUP-MISCOP-ROUTINE, except it is for routines written by users who
+have an extremely good understanding of the system internals.
+
+134 @f[ ] @f[FOP-USER-MISCOP-FIXUP] @f[ ] @i[offset](4) @f[ ]@\is similar
+to FOP-MISCOP-FIXUP, but is used to link in user defined miscops.
+
+255 @f[ ] @f[FOP-END-HEADER] @\ Indicates the end of a group header, as described above.
+@end(description)
+
+@Appendix[Building CMU Common Lisp]
+
+@section(Introduction)
+This document explains how to build a working Common Lisp from source code on
+the IBM RT PC under the Mach operating system. You should already have a
+working Common Lisp running on an IBM RT PC before trying to build a new Common
+Lisp.
+
+Throughout this document the following terms are used:
+@begin(Description)
+Core file@\A core file is a file containing an image of a Lisp system. The
+core file contains header information describing where the data in the rest of
+the file should be placed in memory. There is a simple C program which reads a
+core file into memory at the correct locations and then jumps to a location
+determined by the contents of the core file. The C code includes the X
+window system version 10 release 4 which may be called from Lisp.
+
+
+Cold core file @\A cold core file contains enough of the Lisp system to make it
+possible to load in the rest of the code necessary to generate a full Common
+Lisp. A cold core file is generated by the program Genesis.
+
+Miscops@\Miscops are assembler language routines that are used to support
+compiled Lisp code. A Lisp macro assembler provides a
+convenient mechanism for writing these assembler language routines.
+
+Matchmaker@\Matchmaker is a program developed to automatically generate
+remote procedure call interfaces between programs. Matchmaker accepts
+a description of a remote procedure call interface and generates code
+that implements it.
+@end(Description)
+
+There are many steps required to go from sources to a working Common Lisp
+system. Each step will be explained in detail in the following sections.
+It is possible to perform more than one step with one invocation of Lisp.
+However, I recommend that each step be started with a fresh Lisp. There
+is some small chance that something done in one step will adversely affect
+a following step if the same Lisp is used. The scripts for each
+step assume that you are in the user package which is the default when
+Lisp first starts up. If you change to some other package, some of these
+steps may not work correctly.
+
+In many of the following steps, there are lines setting up search lists so that
+command files know where to find the sources. What I have done is create a
+init.lisp file that sets up these search lists for me. This file is
+automatically loaded from the user's home directory (as determined by the
+@b[HOME] environment variable) when you start up Lisp. Note that my init.lisp
+file is included with the sources. You may have to modify it, if you change
+where the lisp sources are.
+
+@section(Installing Source Code)
+With this document, you should also have received a tape cartridge in tar
+format containing the complete Common Lisp source code. You should create
+some directory where you want to put the source code. For the following
+discussion, I will assume that the source code lives in the directory
+/usr/lisp. To install the source code on your machine, issue the following
+commands:
+@begin(Example)
+cd /usr/lisp
+tar xvf <tape device>
+@end(Example)
+The first command puts you into the directory where you want the source code,
+and the second extracts all the files and sub-directories from the tape into
+the current directory. <Tape device> should be the name of the tape device on
+your machine, usually /dev/st0.
+
+The following sub-directories will be created by tar:
+@begin(Description)
+bin@\contains a single executable file, lisp, which is a C program
+used to start up Common Lisp.
+
+clc@\contains the Lisp source code for the Common Lisp compiler and assembler.
+
+code@\contains the Lisp source code that corresponds to all the functions,
+variables, macros, and special forms described in @i[Common Lisp: The Language]
+by Guy L. Steele Jr., as well as some Mach specific files.
+
+hemlock@\contains the Lisp source code for Hemlock, an emacs-like editor
+written completely in Common Lisp.
+
+icode@\contains Matchmaker generated code for interfaces to Inter Process
+Communication (IPC) routines. This code is used to communicate with other
+processes using a remote procedure call mechanism. Under Mach, all the
+facilities provided by Mach beyond the normal Berkeley Unix 4.3 system
+calls are accessed from Lisp using this IPC mechanism. Currently, the
+code for the Mach, name server, Lisp typescript, and Lisp eval server
+interfaces reside in this directory.
+
+idefs@\contains the Matchmaker definition files used to generate the Lisp
+code in the icode directory.
+
+lib@\contains files needed to run Lisp. The file lisp.core is known as a
+Lisp core file and is loaded into memory by the lisp program mentioned
+above in the entry for the bin directory. This file has a format which
+allows it to be mapped into memory at the correct locations. The files
+spell-dictionary.text and spell-dictionary.bin are the text and binary
+form of a dictionary, respectively, used by Hemlock's spelling checker and
+corrector. The two files hemlock.cursor and hemlock.mask are used by
+Hemlock when running under the X window system.
+
+miscops@\contains the Lisp assembler source code for all the miscops
+that support low level Lisp functions, such as storage allocation,
+complex operations that can not performed in-line, garbage collection, and
+other operations. These routines are written in assembler, so that they
+are as efficient as possible. These routines use a very short calling
+sequence, so calling them is very cheap compared to a normal Lisp
+function call.
+
+mm@\contains the Lisp source code for the Matchmaker program. This program
+is used to generate the Lisp source code files in icode from the corresponding
+matchmaker definitions in idefs.
+
+pcl@\contains the Lisp source code for a version of the Common Lisp Object
+System (originally Portable Common Loops),
+an object oriented programming language built on top of Common Lisp.
+
+X@\contains the C object files for X version 10 release 4 C library
+routines. These are linked with the lisp startup code, so that X is
+available from Lisp.
+
+scribe@\contains Scribe source and postscript output for the manuals
+describing various aspects of the CMU Common Lisp implementation.
+
+demos@\contains the Lisp source code for various demonstration programs.
+This directory contains the Gabriel benchmark set (bmarks.lisp) and
+a sub-directory containing the Soar program which is also used for
+benchmarking purposes. There may be other programs and/or sub-directories
+here that you may look at.
+@end(Description)
+These directories contain source files as well as Lisp object files.
+This means it is not necessary to go through all the steps to
+build a new a Common Lisp, only those steps that are affected by
+a modification to the sources. For example, modifying the compiler
+will require recompiling everything. Modifying a miscop file should
+require only reassembling that particular file and rebuilding the
+cold core file and full core file.
+
+As well as the directories mentioned above, there are also several files
+contained in the top-level directory. These are:
+@begin(Description)
+init.lisp@\is a Lisp init file I use. This sets up some standard search
+lists, as well as defines a Hemlock mode for editing miscop
+source files.
+
+lisp.c@\contains the C code used to start up the lisp core image under Mach.
+
+lispstart.s@\contains some assembler language code that is invoked by lisp.c
+to finish the process of starting up the lisp process.
+
+makefile@\contains make definitions for compiling lisp.c and lispstart.s
+into the lisp program.
+
+rg@\contains some adb commands that can be read into adb while debugging a lisp
+process. It prints out all the registers, the name of the currently
+executing Lisp function, and sets an adb variable to the current stack frame
+which is used by the following file.
+
+st@\contains some adb commands that can be read into adb while debugging
+a lisp process. It prints out a Lisp stack frame and the name of the
+function associated with the stack frame. It also updates the adb variable
+mentioned above to point to the next stack frame. Repeatedly reading this
+file into adb will produce a backtrace of all the active call frames
+on the Lisp stack.
+
+ac@\contains some adb commands that print out the current values of the
+active catch pointer. This points to the head of a list of catch frames
+that exist on the control stack.
+
+cs@\contains some adb commands that print out the contents of a catch
+frame. Reading cs into adb several times in a row (after reading ac once)
+will print out the catch frames in order.
+@end(Description)
+
+@section(Compiling the Lisp Startup Program)
+To compile the lisp start up program, you should be in the top level directory
+of the sources (/usr/lisp) and type:
+@begin(Example)
+make lisp
+@end(Example)
+This will compile the file lisp.c, assemble the file lispstart.s and produce
+an executable file lisp. Currently the default location for the lisp core
+file is /usr/misc/.lisp/lib/lisp.core. If you want to change this default
+location, edit the file lisp.c and change the line
+@begin(Example)
+#define COREFILE "/usr/misc/.lisp/lib/lisp.core"
+@end(Example)
+to refer to the file where you intend to put the core file.
+
+This step takes a few seconds.
+
+@section(Assembling Assembler routines)
+The standard core image includes a Lisp macro assembler. To assemble all
+the miscops, the following steps should be performed:
+@begin(Example)
+(compile-file "/usr/lisp/clc/miscasm.lisp")
+(load "/usr/lisp/clc/miscasm.fasl")
+(setf (search-list "msc:") '("/usr/lisp/miscops/"))
+(clc::asm-files)
+@end(Example)
+The first line compiles a file that contains a couple of functions used to
+assemble miscop source files. The second line loads the resulting compiled
+file into the currently executing core image. The third line defines the
+msc search list which is used by the function clc::asm-files to locate
+the miscop sources. The terminal will display information as each file
+is assembled. For each file a .fasl, a .list, and an .err file will be
+generated in /usr/lisp/miscops.
+
+This step takes about half an hour.
+
+@section(Compiling the Compiler)
+
+To compile the compiler is simple:
+@begin(Example)
+(setf (search-list "clc:") '("/usr/lisp/clc/"))
+(load "clc:compclc.lisp")
+@end(Example)
+The first line just sets up a search list variable clc, so that the file
+compclc.lisp can find the compiler sources. The terminal will display
+information as each file is assembled. For each file a .fasl and an .err file
+will be generated. A log of the compiler output is also displayed on the
+terminal.
+
+This step takes about forty-five minutes.
+
+@section(Compiling the Lisp Sources)
+
+Compiling the Lisp source code is also easy:
+@begin(Example)
+(setf (search-list "code:") '("/usr/lisp/code/"))
+(load "code:worldcom.lisp")
+@end(Example)
+Again, the first line defines a search list variable, so that the file
+worldcom.lisp can find the Lisp sources. As each file is compiled, the
+name of the file is printed on the terminal. For each file a .fasl will be
+generated. Also, a single error log will be generated in the file
+code:compile-lisp.log.
+
+This step takes about an hour and a half.
+
+@section(Compiling Hemlock)
+
+Compiling the Hemlock source code is done as follows:
+@begin(Example)
+(setf (search-list "hem:") '("/usr/lisp/hemlock/"))
+(load "hem:ctw.lisp")
+@end(Example)
+Again, the first line defines a search list variable, so that ctw.lisp can
+find the Hemlock sources. As each file is compiled, the name of the file is
+printed on the terminal. For each file a .fasl will be generated. Also, a
+single error log will be generated in the file hem:lossage.log.
+
+This step takes about forty-five minutes.
+
+@section(Compiling Matchmaker)
+Compiling the matchmaker sources is done as follows:
+@begin(Example)
+(setf (search-list "mm:") '("/usr/lisp/mm"))
+(compile-file "mm:mm.lisp")
+(load "mm:mm.fasl")
+(compile-mm)
+@end(Example)
+The first line sets up a search list, so that the matchmaker sources can be
+found. The second line compiles the file containing a function for compiling
+the matchmaker sources. The third line loads the file just
+compiled, and the final line invokes the function compile-mm which compiles the
+matchmaker sources. For each file, a .fasl and .err file is generated. Also,
+a log of the compiler output is printed to the terminal.
+
+This step takes about 15 minutes
+
+@section(Generating Lisp Source Files from Matchmaker Definition Files)
+The following sequence of commands is necessary to generate the Lisp
+files for the Mach interface:
+@begin(Example)
+(setf (search-list "mm:") '("/usr/lisp/mm/"))
+(setf (search-list "idefs:") '("/usr/lisp/idefs/"))
+(setf (search-list "icode:") '("/usr/lisp/icode/"))
+(setf (search-list "code:") '("/usr/lisp/code/"))
+(setf (default-directory) "/usr/lisp/icode/")
+(load "code:mm-interfaces.lisp")
+@end(Example)
+The first four lines set up search lists for mm (matchmaker sources), idefs
+(matchmaker interface definition files), icode (Lisp matchmaker interface
+sources), and code (Lisp code sources). The fifth line changes the current
+working directory to be /usr/lisp/icode. This is where the output from
+matchmaker will be placed. And finally, the last line invokes matchmaker on
+the matchmaker definition files for all the interfaces.
+
+Matchmaker generates three files for each interface XXX:
+@begin(Description)
+XXXdefs.lisp@\contains constants and record definitions for the interface.
+
+XXXmsgdefs.lisp@\contains definitions of offsets to important fields in the
+messages that are sent to and received from the interface.
+
+XXXuser.lisp@\contains code for each remote procedure, that sends a message
+to the server and receives the reply from the server (if appropriate).
+Each of these functions returns one or more values. The first value
+returned is a general return which specifies whether the remote procedure
+call succeeded or gives an indication of why it failed. Other values may
+be returned depending on the particular remote procedure. These values are
+returned using the multiple value mechanism of Common Lisp.
+@end(Description)
+
+This step takes about five minutes.
+
+@section(Compiling Matchmaker Generated Lisp Files)
+To compile the matchmaker generated Lisp files the following steps should
+be performed:
+@begin(Example)
+(setf (search-list "code:") '("/usr/lisp/code/"))
+(setf (search-list "icode:") '("/usr/lisp/icode/"))
+(load "code:comutil.lisp")
+@end(Example)
+The first two lines set up search lists for the code and icode directory.
+The final line loads a command file that compiles the Mach interface
+definition in the correct order. Note that once the files are compiled,
+the XXXmsgdefs files are no longer needed. The file
+/usr/lisp/icode/lossage.log contains a listing of all the error messages
+generated by the compiler.
+
+This step takes about fifteen minutes.
+
+@section(Compiling the Common Lisp Object System)
+
+To compile the Common Lisp Object System (CLOS) do the following:
+@begin(Example)
+(setf (search-list "pcl:") '("/usr/lisp/pcl/"))
+(rename-package (find-package "CLOS") "OLD-CLOS")
+(compile-file "pcl:defsys.lisp")
+(load "pcl:defsys.fasl")
+(clos::compile-pcl)
+@end(Example)
+The first line sets up a search list as usual. The second line renames the
+CLOS package to be the OLD-CLOS package. This is so that the current version
+of CLOS doesn't interfere with the compilation process. The third line
+compiles a file containing some functions for building CLOS. The fourth
+line loads in the result of the previous compilation. The final line
+compiles all the CLOS files necessary for a working CLOS system.
+
+The file /usr/lisp/pcl/test.lisp is a file that contains some test functions.
+To run it through CLOS build a new Lisp and start up a fresh Lisp
+resulting from the build and do the following:
+@begin(Example)
+(in-package 'clos)
+(compile-file "/usr/lisp/pcl/test.lisp")
+(load "/usr/lisp/pcl/test.fasl")
+@end(Example)
+This sequence of function calls puts you in the CLOS package, compiles the
+test file and then loads it. As the test file is loaded, it executes several
+tests. It will print out a message specifying whether each test passed or
+failed.
+
+Currently, CLOS is built into the standard core.
+
+This step takes about 30 minutes.
+
+@section(Compiling Genesis)
+To compile genesis do the following:
+@begin(Example)
+(compile-file "/usr/lisp/clc/genesis.lisp")
+@end(Example)
+Genesis is used to build a cold core file. Compiling Genesis takes about five
+minutes.
+
+@section(Building a Cold Core File)
+Once all the files have been assembled or compiled as described above, it is
+necessary to build a cold core file as follows:
+@begin(Example)
+(setf (search-list "code:") '("/usr/lisp/code/"))
+(setf (search-list "icode:") '("/usr/lisp/icode/"))
+(setf (search-list "msc:") '("/usr/lisp/miscops/"))
+(load "/usr/lisp/clc/genesis.fasl")
+(load "code:worldbuild.lisp")
+@end(Example)
+The first three lines set up search lists for the code, icode, and miscops
+subdirectories. The fourth line loads in the program Genesis which builds
+the cold core file. The last line calls Genesis on a list of the files that
+are necessary to build the cold core file. As each file is being processed,
+its name is printed to the terminal. Genesis generates two files:
+/usr/lisp/ilisp.core and /usr/lisp/lisp.map. Ilisp.core is the cold core
+file and lisp.map is a file containing the location of all the functions
+and miscops in the cold core file. Lisp.map is useful for debugging the
+cold core file.
+
+This step takes from about fifteen minutes.
+
+@section(Building a Full Common Lisp)
+The cold core file built above does not contain some of the more useful
+programs such as the compiler and hemlock. To build these into a core, it is
+necessary to do the following:
+@begin(Example)
+lisp -c /usr/lisp/ilisp.core
+(in-package "USER")
+(load (open "/usr/lisp/code/worldload.lisp"))
+@end(Example)
+The first line invokes the lisp startup program specifying the cold core
+file just built as the core file to load. This cold core file is set up
+to do a significant amount of initialization and it is quite possible that
+some bug will occur during this initialization process. After about a
+minute, you should get a prompt of the form:
+@begin(Example)
+CMU Common Lisp kernel core image 2.7(?).
+[You are in the Lisp Package.]
+*
+@end(Example)
+The following two lines should then be entered. The first of these puts
+you into the User package which is the package you should be in when the
+full core is first started up. It is necessary to add this line, because
+the current package is rebound while a file is loaded. The last line loads
+in a file that loads in the compiler, hemlock, and some other files not yet
+loaded. The open call is @b[essential] otherwise when the full core is
+started up, load will try to close the file and probably invalidate memory
+that is needed. When load is passed a stream, it does not automatically
+close the stream. With a file name it now does after a recent bug fix.
+This file prompts for the versions of the Lisp system, the compiler, and
+hemlock. You should enter versions that make sense for your installation.
+It then purifies the core image. Up to this point most of the Lisp system
+has been loaded into dynamic space. Only a few symbols and some other data
+structures are in static space. The process of purification moves Lisp
+objects into static and read-only space, leaving very little in dynamic
+space. Having the Lisp system in static and read-only space reduces the
+amount of work the garbage collector has to do. Only those objects needed
+in the final core file are retained. Finally, a new core file is generated
+and is written to the file /usr/lisp/nlisp.core. Also, the currently
+running Lisp should go through the default initialization process, finally
+prompting for input with an asterisk. At this point you have successfully
+built a new core file containing a complete Common Lisp implementation.
+
+This step takes about thirty minutes.
+
+@section(Debugging)
+Debugging Lisp code is much easier with a fully functional Lisp. However, it
+is quite possible that a change made in the system can cause a bug to happen
+while running the cold core file. If this happens, it is best to use adb to
+track down the problem. Unfortunately, the core file (i.e., the
+remains of a process normally created by Unix when a process dies) generated by
+such a bug will be of no use. To get some useful information, follow these
+steps:
+@begin(Enumerate)
+Look at the file /usr/lisp/lisp.map and find the entry points for the
+miscop routines error0, error1, and error2. These entry points are
+used to invoke the Lisp error system from the miscops. Write down
+the numbers beside these names. They are the addresses (in hex) of where
+the miscops are located when the cold core file is loaded into memory.
+
+Run adb on the lisp file, i.e.:
+@begin(example)
+adb lisp
+@end(Example)
+
+Set a breakpoint at the lispstart entry point:
+@begin(Example)
+lispstart:b
+@end(Example)
+
+Start the lisp program running, telling it to use ilisp.core (I'm
+assuming you're in /usr/lisp):
+@begin(Example)
+:r -c ilisp.core
+@end(Example)
+
+After a while, you will hit the lispstart breakpoint. The core file has been
+mapped into memory, but control is still in the C startup code. At this point,
+you should enter breakpoints for all the error entry points described above.
+
+Continue running the program by typing :c. Shortly after this, the C lisp
+program will give up control to Lisp proper. Lisp will start doing its
+initialization and will probably hit one of the error break points.
+At that point you can look around at the state and try and discover
+what has gone wrong. Note that the two files rg and st are useful at this
+point. Also, you should look at the document @i[Internal Design of Common
+Lisp on the IBM RT PC] by David B. McDonald, Scott E. Fahlman, and Skef
+Wholey so that you know the internal data structures.
+@end(Enumerate)
+
+@section(Running the Soar Benchmark)
+To compile the soar benchmark, you should do the following:
+@begin(Example)
+(compile-file "/usr/lisp/demos/soar/soar.lisp")
+@end(Example)
+
+To run the benchmark, you should start up a fresh Lisp and do the following:
+@begin(Example)
+(load "/usr/lisp/demos/soar/soar.fasl")
+(load "/usr/lisp/demos/soar/default.soar")
+(load "/usr/lisp/demos/soar/eight.soar")
+(user-select 'first)
+(init-soar)
+(time (run))
+@end(Example)
+The first two lines load in the standard Soar system. The third line loads in
+information about the eight puzzle which is a standard Soar puzzle that has
+been run on several different machines. The fourth line sets up the puzzle
+conditions so that it will select a goal to work on automatically. The fifth
+line initializes Soar's working memory, etc. The final line is the one that
+actually runs the benchmark. Soar prints out a fair amount of information as
+it solves the puzzle. The final state should be numbered 143 when it finishes.
+The time macro prints out information about information various resources after
+the eight puzzle has run.
+
+@section(Summary)
+I have tried to present sufficient information here to allow anyone to be
+able to build a Common Lisp system under Mach from the sources. I am sure
+there are many tricks that I have learned to use to reduce the amount of grief
+necessary to build a system. My best recommendation is to go slowly. Start
+by building a system from the sources provided on the tape. Make sure you
+are comfortable doing that before you try modifying anything.
+
+Some hints on building the system which you may find useful:
+@begin(Itemize)
+If you change the compiler, you will have to recompile all the sources before
+the change is reflected in a system. Changing the compiler is probably the
+most dangerous change you can make, since an error here means that
+nothing will work. In particular, this is the time you are going to need
+to get familiar with adb and the internal structure of the Lisp, since a
+serious error in the compiler will show up during the initialization of the
+cold core file.
+
+Changing the miscops should be done with care. They follow a fairly rigid
+convention and you should understand all the information provided in
+@i[Internal Design of Common Lisp on the IBM RT PC] before making any changes
+to miscops. You will probably need to get familiar with adb to debug some of
+the changes. Note that this requires building a new cold core file and a final
+core file before the change is reflected in the system.
+
+Changing sources in the code directory should be fairly straight forward. The
+only time this will cause trouble is if you change something that a lot of
+files depend on in which case you will have to recompile everything and build
+a new cold core file and a core file.
+
+Changing hemlock should have no adverse effect on system integrity.
+
+If you make a fairly major change, it is a good idea to go through the complete
+process of building a core file at least two or three times. If things are
+still working at the end of this, your change is probably correct and shouldn't
+cause any serious trouble.
+
+Finally, always keep at least one backup copy of a good core image around.
+If you build a bad core file over an existing one and can't back up, it is
+possible that you may not be able to recover from a serious error.
+@end(Itemize)
--- /dev/null
+\part{Run-Time system}
+\include{environment}
+\include{interpreter}
+\include{debugger}
+\include{object}
+\include{lowlev}
+\include{fasl}
--- /dev/null
+\chapter{Introduction} % -*- Dictionary: design -*-
+
+(defun gvp (f)
+ (with-open-file (s f :direction :output :if-exists :supersede)
+ (maphash \#'(lambda (k v)
+ (declare (ignore v))
+ (format s "~A~%" k))
+ (c::backend-template-names c::*backend*))))
+
+\f
+\section{Scope and Purpose}
+
+This document describes the Virtual Machine that serves as the basis for the
+portable implementation of \ccl. The Virtual Machine (hereafter referred to as
+the VM) provides a layer of abstraction that hides low-level details of
+hardware and implementation strategy, while still revealing enough of the
+implementation so that most of the system can be written at the VM level or
+above.
+
+\begin{comment}
+
+{\#\#\# Shouldn't specify VOPs. Instead, should specify which \clisp functions
+are primitive and which subprimitives exist. Isn't really anyone's business
+which VOPs actually exist. Each primitive function or subprimitive is
+implemented either as a VOP or as expansion into Lisp code, at the particular
+implementation's discretion.
+
+From this point of view, the document is expressing the contract that the Lisp
+level code outside of the compiler must satisfy. All functions must ultimately
+be defined in terms of primitive functions and sub-primitives.
+
+The responsibility of the compiler is to implement these primitive operations,
+and also to implement special forms, variables and function calling.
+
+VOPs emitted by the hard-wired translators for non-function nodes are a
+somewhat different story. Each implementation will presumably implement all
+these VOPs in order to avoid having to rewrite IR2 translation. We also need
+to spend quite a bit of time discussing the semantics of these operations,
+since they don't just correspond to some \clisp function with type constraints.
+
+Hard-wired stuff:
+
+function call
+variable access:
+ global
+ function
+ constant
+ closure
+ local
+closure creation
+non-local exit
+special binding/unbinding
+TN hacking:
+ move VOPs
+ TN address (???)
+Conditionals:
+ Basic conditionals: EQ, ...
+ Interface to generation of other conditional VOPs.
+
+Some VOPs don't need to be implemented at all:
+ VOPs to delimit the lifetimes of big stack TNs such as catch blocks
+ Others? Move VOPs might be defined in terms of an implementation supplied
+ move routine, since we probably also need this info outside of VOP generators
+ so that implicit moves can be generated.
+
+
+Type testing/checking (somehow)
+
+}
+
+What this document talks about:
+
+Interface between compiler front-end and back end. (VOPs)
+ Primitive \clisp operations directly supported by the VM.
+ Support for complex language features such as function call.
+
+Sub-primitives that allow system code to do things not possible in \clisp.
+
+Descriptions of how the current \ccl system uses VM facilities, especially
+non-standard ones accessed through sub-primitives.
+
+Notes about known portability problems.
+
+Guidelines for writing portable \ccl system code. To some degree these
+guidelines are implied by statements that certain things are true of \ccl
+system code.
+
+Descriptions of data structures that are not directly used by the VM, such as
+debug information and Core files.
+
+Descriptions of data structures that are directly used by the VM, such as
+symbols and arrays.
+
+
+Who should read it:
+
+People who want to port \ccl.
+People who want to understand the compiler.
+People who want to understand how \ccl works.
+People who need to write portable \ccl system code.
+People such as debugger writers who need to access \ccl\t()'s internal data
+structures.
+
+What it won't do:
+
+Tell you things that are obviously implementation dependent, such as type
+systems or memory management disciplines. See the the various implementation
+VM documents.
+
+Tell you only what you need to know. Programmers shouldn't exploit properties
+of the VM documented here unless there is no way to do the same thing in
+portable \clisp.
+
+Tell you how the compiler works. In order to understand some of the subtleties
+of VOP descriptions, you will have to understand the IR2 representation and how
+it fits into the rest of the compiler.
+
+Tell you anything about \clisp semantics. When some part of the VM has a
+direct relationship to \clisp semantics, the relationship will be directly
+stated using \clisp terminology, since a restatement of the semantics is likely
+to be inaccurate or misleading. Exceptions will be made only when some
+implication of the \clisp semantics is non-obvious.
+
+Tell you everything about how \ccl works. This document only offers
+information that is likely to be needed by programmers doing a port or writing
+system code; portable, self-contained parts of the system are totally ignored.
+This document deliberately avoids replicating information that is easily
+available in the system sources, since such replicated information is always
+incorrect somewhere. In some cases, a forwarding pointer to the appropriate
+source will be given.
+
+
+Things the VM won't do:
+
+The VM specification does not totally solve the problem of porting \ccl, since
+it is inevitable that it will not map cleanly to all possible combinations of
+hardware and operating systems. The VM should not be regarded as being cast in
+concrete, since changes in many characteristics would only affect a tiny
+fraction of the system sources.
+
+One current major problem with porting is that large pieces of functionality
+are entirely within the VM, and would need to be reimplemented for each port.
+A major goal for future work on the system is moving code out of the VM, both
+by supporting a "fast-call" convention that allows reasonable use of Lisp in
+the out of line implementation of VOPs, and by having a "bugout" mechanism that
+allows the VM to call Lisp functions to implement the hard cases in some VOPs.
+
+The VM is designed to support conventional, untagged, general register
+architectures. Suitably lobotomized, it could be mapped to less flexible
+hardware such as "Lisp machines", but the compiler would have serious
+difficulties supporting stack architectures.
+
+The VM does not support concurrent lightweight processes. Locking primitives
+and deep-binding of specials would be needed.
+
+The VM does not deal with operating systems interface issues at all. A minimal
+port would require implementing at least file and terminal I/O streams. \ccl
+implements system interfaces using Aliens and other facilities built on top of
+them.
+
+\end{comment}
+
+
+
+Major components:
+\begin{itemize}
+Specific virtual operations implemented by the VM (VOPs). VOPs are primarily
+the concern of the compiler, since it translates Lisp code into VOPs and then
+translates VOPs into the implementation.
+
+Sub-primitives that are used by Lisp code needing to perform operations
+below the Lisp level. The compiler implements some sub-primitives directly
+using VOPs, while others are translated into Lisp code. Sub-primitives provide
+a layer of insulation between the Lisp system code and the VM, since the Lisp
+code may assume the existence of operations that are not implemented directly
+by the VM. Only sub-primitives with fairly portable semantics are documented
+here. Others are in implementation-specific VM documentation.
+\end{itemize}
+
+\comment<Not all sub-primitives are VOPs, and most VOPs are not sub-primitives.>
+
+
+\f
+\subsection{VOP base name rules}
+
+The names of VOPs that implement functions are based on the function name.
+Other VOPs may use any base that doesn't conflict with a function name. There
+are some rules used to obtain the base name for related operations.
+
+To get the name of a setting operation, replace the string "{\tt ref}" in the name
+with "{\tt set}". If "{\tt ref}" doesn't appear in the name, add the prefix "{\tt set-}" to the
+base name. For example, {\tt svref} becomes {\tt svset}, and {\tt symbol-value}
+becomes {\tt set-symbol-value}.
+
+To get the name of a conditional VOP from the name of a predicate, add the
+prefix "{\tt if-}" to the predicate name. For example, {\tt eq} becomes {\tt if-eq}.
+{\tt eq} by itself would be a VOP that returned true or false value.
+
+Some operations check for some error condition, magically signalling the error
+through an implicit control transfer. These operations are prefixed with
+"{\tt check-}", as in {\tt check-fixnum} and {\tt check-bound}.
+
+
+\f
+\subsection{VOP name prefixes and suffixes}
+
+Prefixes and suffixes are added to the base to get the names of variant
+versions of the VOP. The fully general VOP name looks like this:
+\begin{format}
+ {"{\tt small-}" | "{\tt fast-}"} {\it name}{"{\tt -c}" {\it info}}{"{\tt /}" {\it type}{"{\tt =>}" {\it result-type}}
+\end{format}
+The "{\tt small-}" and "{\tt fast-}" prefixes indicates that the VOP does minimal
+safety checking and is optimized for space or speed, respectively. The absence
+of a prefix indicates the safest (or only) version. Usually if the "{\tt small-}"
+VOP exists, it will be a synonym for either the fast version or the safe
+version, depending on which is smaller.
+
+The "{\tt -c}" suffix indicates that the some info that is passed as a normal
+argument to the base version of the VOP is passed as Codegen-Info in this
+version. A typical use would be for VOPs where it is important to use a
+different version when one of the arguments is a compile time constant.
+{\it info} is some (possibly null) string that indicates which "{\tt -c}" variant
+is involved.
+
+The "{\tt /}{\it type}" suffix asserts that all operands that could be of {\it type} are.
+For example, {\tt +/fixnum} adds two fixnums returning a fixnum, while
+{\tt length/simple-vector} finds the length of a simple vector, but the result isn't
+a simple vector.
+
+The "{\tt =>}{\it result-type}" suffix supplies a result type assertion on the
+operation.
+
+A not totally silly example of all these modifiers simultaneously is
+ {\tt fast-+-c/fixnum=>integer}. This operation would this operation adds two
+fixnums, one of which is a constant passed as codegen info, resulting in an
+integer. The implementation is optimized for speed at the expense of space and
+safety.
+
+
+\f
+\chapter{Data Types and Storage Resources}
+
+\f
+\section{Lisp Objects}
+\index{Lisp objects}
+
+A Lisp object is fixed-size data structure that is organized in a way mandated
+by the VM implementation. The fixed format allows the VM to determine the type
+of the object. \comment<Virtual type? VM type? Implementation type?
+...provides the VM enough information about the type of the object for the VM
+to implement the VM-level semantics... ...supports the "dynamic types"...>
+
+Lisp objects are stored in locations known as cells.
+
+
+Has major types: immediate and non-immediate.
+Non-immediate objects may have a subtype.
+Non-immediate types:
+ symbol (nil may be weird)
+ cons
+ ratio
+ complex
+ some float types
+ g-vector
+ i-vector
+ string
+ bit-vector
+ environment (always has subtype)
+ array header
+ bignum
+ structure
+ pc (code vector)
+ stack closure (control stack pointer)
+
+Non-immediate objects are allocated in "type spaces". The type space of an
+object is characterized by a small integer known as the type code. Any two
+objects of one of the above boxed types will always have the same type code.
+{But not really... Some types might be allocated in different type spaces at
+different times. (?)}
+
+The type code doesn't totally describe the object. In general, subtype
+information may be involved.
+
+
+Immediate types:
+ character
+ fixnum
+ unbound trap
+ short float
+
+
+\f
+\section{Type VOPs}
+
+We consider control transfer to be the fundamental result of comparison, rather
+than anything such as a condition code. Although most compilers with whizzy
+register allocation seem to explicitly allocate and manipulate the condition
+codes, it seems that any benefit is small in our case. This is partly because
+our VOPs are at a somewhat higher level, making it difficult to tell which VOPs
+do and don't trash the the CC. Explicitly incorporating condition codes in our
+VM also introduces another architecture dependency.
+
+At the IR2 level, we have a class of IF-XXX VOPs which transfer control to one
+of two places on the basis of some test on the operands. When generating code
+for a predicate, we peek at the destination IF node to find where to transfer
+control to.
+
+The exact representation of type tests in IR2 will be fairly implementation
+dependent, since it will depend on the specific type system for the given
+implementation. For example, if an implementation can test some types with a
+simple tag check, but other types require reading a field from the object in
+addition, then the two different kinds of checks should be distinct at the VOP
+level, since this will allow the VOP cost and storage information to be more
+accurate. Generation of type tests should be factored out of code which would
+otherwise be more portable. Probably the IR2 translator for TYPEP and the type
+check generation code are the only places that should know about how type tests
+are represented in IR2.
+
+if-type (object)
+if-type-range
+ If-Type Tests whether Object has the type code that is passed in the
+ codegen info. If-Type-Range tests for a range of type codes.
+
+{small, fast} if-vector-type (object)
+ Test that Object is either of the specified type code, or is a 1d array
+ header with data having the specified type code.
+
+if-vector-subtype (object)
+ Test the subtype field of a vector-like object. It is assumed that the
+ object has already been determined to be vector-like.
+
+if-fixnump (object)
+if-short-float-p
+if-characterp
+ The rationale behind having these as separate VOPs is that they are likely
+ to be immediate types, and thus may have bizzare type schemes.
+
+if-consp (object)
+if-listp
+ We have distinct operations for these predicates since one or the other
+ isn't a simple tag test, but we don't know which one.
+
+if-rationalp (object)
+if-floatp
+if-integerp
+if-numberp
+if-vectorp
+if-functionp
+ The rationale behind having these operations is that they may take a lot of
+ code, so it is reasonable to put them out of line.
+
+
+\f
+\section{Type Sub-primitives}
+
+change-type (object) => result
+ Change the type of an object according to codegen info. The meaning of
+ this is highly type-system dependent, but it doesn't matter, since the
+ compiler will never emit this VOP directly. The only way that it can show
+ up is through %Primitive.
+get-type
+
+
+Storage resources:
+
+Boxed and unboxed locations:
+Non-immediate objects may not be stored in unboxed locations.
+Things not lisp objects may not be stored in boxed locations.
+
+Control stack is boxed.
+Optional number stack is unboxed.
+Heap environment is boxed.
+Fixed number of registers, some boxed and some unboxed.
+
+PCs may be stored on the control stack or in boxed registers, subject to the
+constraint that a corresponding environment is also stored. Locations
+containing PCs don't need to be zeroed when they are no longer used; nothing
+bad will happen if an old PC is unaccompanied by an environment.
+
+
+\item[Trap]Illegal object trap. This value is used in symbols to signify an
+undefined value or definition.
+
+\f
+\chapter{Characters}
+
+
+Character is an immediate type. Characters are manipulated primarily by
+converting into an integer and accessing these fields:
+\begin{description}
+\item[{\tt %character-code-byte}]The character code. This is effectively required to
+start at bit 0, since \cl equates {\tt char-int} to {\tt char-code} when there is
+no bits or font. All current \ccl systems use ASCII for the character codes,
+and define {\tt \#\newline} to be a linefeed, but system code should not count on
+this.
+
+\item[{\tt %character-control-byte}]The character bits. Character bits are used by
+Hemlock to describe modifiers in keyboard events, but there is no assumption of
+any general portable significance of character bits.
+
+{\tt %character-font-byte}\\The character font. This is not used by \ccl, and is
+not particularly useful.
+\end{description}
+
+Characters should be converted to and from integers by using the \clisp
+{\tt char-int} and {\tt int-char} functions, which the compiler translates into
+these VOPs:
+\begin{example}
+char-int (char) => int
+int-char (int) => char
+\end{example}
+In the common case where Char is known to be a {\tt string-char}, these
+operations are equivalent to {\tt char-code} and {\tt code-char}. In addition to
+providing a portable interface to character conversion, the VOP representation
+of this type conversion allows the compiler to avoid unnecessary boxing and
+unboxing of character objects.
+
+Existing code explicitly converts fixnums to characters by using the
+Make-Immediate-Type sub-primitive with %Character-Type. Currently conversion
+of characters to fixnums is rather confused. Originally, characters were a
+subtype of the Misc type code, and the result of the Make-Fixnum sub-primitive
+had to be masked with {\tt %character-int-mask}; some code still does this, while
+other code may not.
+
+Character comparisons could be implemented by doing numeric comparisons on the
+result of {\tt char-int}, or by using {\tt eq} in the case of {\tt char=}, but this
+can result in unnecessary type conversions. Instead, the compiler uses these
+conditional VOPs:
+\begin{example}
+if-char= (x y)
+if-char< (x y)
+if-char> (x y)
+\end{example}
+
+\f
+\chapter{Symbols}
+
+
+Symbols are currently fairly boring in \ccl, containing only the obvious slots:
+\begin{description}
+{\tt %symbol-value-slot}\\The current dynamic value of this symbol. If the
+symbol is currently unbound, then the value of this slot is the unbound marker.
+
+{\tt %symbol-function-slot}\\The global function function definition of this
+symbol. If the symbol is not fbound, then this slot holds the unbound marker.
+
+\multiple{
+{\tt %symbol-plist-slot} \*
+{\tt %symbol-name-slot} \*
+{\tt %symbol-package-slot}
+}\\The property list, print name and package for this symbol.
+\end{description}
+
+
+\f
+\section{Sub-primitives}
+
+The {\tt alloc-symbol} sub-primitive allocates a new symbol object. {\it name} is
+the simple-string that is to be the name of the symbol.
+\begin{example}
+alloc-symbol (name) => symbol
+\end{example}
+
+The {\tt set-symbol-package} sub-primitive is used by system code that must set
+the symbol package.
+\begin{example}
+set-symbol-package (symbol new-value)
+\end{example}
+
+
+\f
+\section{Accessor VOPs}
+
+These VOPs read the global symbol value and definition cells. {\tt constant-ref}
+may only be used on symbols that have been defined to be constants. Since a
+constant cannot change in value and cannot be dynamically bound, the compiler
+may be able to compile uses of {\tt constant-ref} more efficiently. Unsafe
+versions of these VOPs may not check for the slot being unbound, which the
+corresponding \clisp functions are required to do.
+\begin{example}
+{small, fast} symbol-value (symbol) => value
+{small, fast} constant-ref (symbol) => value
+{small, fast} symbol-function (symbol) => value
+\end{example}
+
+These VOPs set the global symbol value and definition cells. {\tt makunbound}
+and {\tt fmakunbound} are implemented by setting the value to the unbound marker.
+\begin{example}
+{small, fast} set-symbol-value (symbol new-value)
+{small, fast} set-symbol-function (symbol new-value)
+\end{example}
+
+The \clisp accessors for other symbol slots are translated into uses of the
+{\tt slot-ref} and {\tt slot-set} VOPs.
+
+
+\f
+\section{Special Binding}
+
+These VOPs implement dynamic binding of special variables using shallow
+binding. {\tt bind} binds {\it symbol} to the specified {\it value}, while
+{\tt unbind} undoes the most recent {\it count} special bindings on the binding
+stack.
+\begin{example}
+bind (symbol value)
+unbind (count)
+\end{example}
+
+\f
+\section{Property Lists}
+
+The {\tt get} VOP implements the corresponding \clisp function, while {\tt put}
+implements its setf-inverse.
+\begin{example}
+get (symbol indicator default) => value
+put (symbol indicator value)
+\end{example}
+
+\f
+\chapter{Lists}
+
+
+cons
+
+list<n> (elt0 ... elt<n-1>) => list
+list (elt0 ... elt<n-1> more-elts) => list
+ For some small N, we have fixed-arg versions of List. For larger lists, we
+ pass in additional elements in a stack TN (possibly required to be on stack
+ top). List* is similar.
+
+
+These VOPs implement the corresponding \clisp functions:
+\begin{example}
+{small, fast} car (list) => value
+{small, fast} cdr (list) => value
+\end{example}
+
+These VOPs set the car or cdr of a cons:
+\begin{example}
+{small, fast} set-car (cons new-value)
+{small, fast} set-cdr (cons new-value)
+\end{example}
+
+These VOPs implement the \clisp {\tt assoc} and {\tt member} functions with test
+functions of {\tt eql} and {\tt eq}:
+\begin{example}
+assoc (item alist) => cons-or-nil
+assq (item alist) => cons-or-nil
+member (item list) => cons-or-nil
+memq (item list) => cons-or-nil
+\end{example}
+
+
+{\tt getf} implements the corresponding \clisp function, while {\tt putf} is used
+to implement its setf-inverse. {\tt putf} returns the new value for the list so
+that it may stored back into the place.
+\begin{example}
+getf (list indicator default) => value
+putf (list indicator new-value) => list
+\end{example}
+
+\f
+\chapter{Numbers}
+
+\index{Fixnum format}
+Fixnum\\An N-bit two's complement integer.
+
+\index{Short float format}
+Short-Float\\An immediate float format.
+
+\index{Bignum format}
+\label{Bignums}
+Bignum\\Bignums are infinite-precision integers, represented somehow.
+
+\index{Flonum format}
+\index{Floating point formats}
+Floats\\Floats are stored as consecutive words of bits.
+
+\index{Ratio format}
+Ratio\\Ratios are stored as two consecutive words of Lisp objects, which should
+both be integers.
+
+\index{Complex number format}
+Complex\\Complex numbers are stored as two consecutive words of Lisp objects,
+which should both be numbers.
+
+
+\f
+\section{Number VOPs}
+
+integer-length
+{small, fast} integer-length/fixnum
+
+float=>xxx-float
+
+realpart
+lmagpart
+numerator
+denominator
+decode-float
+{small, fast} decode-float/xxx-float
+scale-float
+{small, fast} scale-float/xxx-float
+
+if-= (x y)
+{small, fast} if-=/fixnum
+{small, fast} if-=/xxx-float
+ Do numeric comparison of X and Y. The codegen-info contains the
+ continuations to transfer to in the true and false cases. Same for <, >.
+
++ (x y) => z
+{small, fast} +/fixnum
+{small, fast} +/fixnum=>integer
+{small, fast} +/xxx-float
+ Same for -, *. Fixnum multiplication by a constant power of 2 (or near
+ power of 2) can be done by a transform.
+
+/ (x y) => z
+{small, fast} //xxx-float
+
+negate
+{small, fast} negate/fixnum
+{small, fast} negate/fixnum=>integer
+{small, fast} negate/xxx-float
+ Ditto for Abs.
+
+truncate (x y) => q r
+{small, fast} truncate/fixnum
+
+logand (x y) => z
+{small, fast} logand/fixnum
+ Ditto for logior, logxor.
+
+lognot (n) => z
+{small, fast} lognot/fixnum
+
+ash (n x) => z
+{small, fast} ash/fixnum
+{small, fast} ash-c/fixnum
+
+ldb
+dpb
+mask-field
+deposit-field
+ These will only be used as a last resort. There should be transforms that
+ turn fixnum operations with constant byte-specifiers into standard logical
+ operations.
+
+\f
+\section{Number Sub-primitives}
+
+
+alloc-bignum
+make-complex
+make-ratio
+lsh
+logldb
+logdpb
+
+
+\f
+\chapter{Arrays}
+
+\cl arrays can be represented in a few different ways in \rtccl --
+different representations have different performance advantages. Simple
+general vectors, simple vectors of integers, and simple strings are basic \rtccl
+ data types, and access to these structures is quicker than access to
+non-simple (or ``complex'') arrays. However, all multi-dimensional arrays in
+\rtccl are complex arrays, so references to these are always through a
+header structure.
+
+
+Once a vector has been allocated, it is possible to reduce its length by using
+the Shrink-Vector sub-primitive, but never to increase its length, even back to
+the original size, since the space freed by the reduction may have been
+reclaimed.
+
+
+\f
+\subsection{Arrays}
+\label{Arrays}
+\index{Arrays}
+
+An array header is identical in form to a G-Vector. At present, the following
+subtype codes are defined:
+\begin{itemize, spread 0, spacing 1}
+0 Normal.
+1 Array is displaced to another array (which may be simple).
+\end{itemize}
+The entries in the header-vector are interpreted as follows:
+
+\index{Array header format}
+\begin{description}
+0 Data Vector \\This is a pointer to the I-Vector, G-Vector, or string that
+contains the actual data of the array. In a multi-dimensional array, the
+supplied indices are converted into a single 1-D index which is used to access
+the data vector in the usual way. If the array is displaced, then this is
+the array displaced to, which may be an array header. In general, array
+access must loop until it finds an actual data vector.
+
+1 Number of Elements \\This is a fixnum indicating the number of elements for
+which there is space in the data vector.
+
+2 Fill Pointer \\This is a fixnum indicating how many elements of the data
+vector are actually considered to be in use. Normally this is initialized to
+the same value as the Number of Elements field, but in some array applications
+it will be given a smaller value. Any access beyond the fill pointer is
+illegal.
+
+3 Displacement \\This fixnum value is added to the final code-vector index
+after the index arithmetic is done but before the access occurs. Used for
+mapping a portion of one array into another. For most arrays, this is 0.
+
+4 Range of First Index \\This is the number of index values along the first
+dimension, or one greater than the largest legal value of this index (since the
+arrays are always zero-based). A fixnum in the range 0 to 2\+{24}-1. If any
+of the indices has a range of 0, the array is legal but will contain no data
+and accesses to it will always be out of range. In a 0-dimension array, this
+entry will not be present.
+
+5 - N Ranges of Subsequent Dimensions
+\end{description}
+
+The number of dimensions of an array can be determined by looking at the length
+of the array header. The rank will be this number minus 6. The maximum array
+rank is 65535 - 6, or 65529.
+
+The ranges of all indices are checked on every access, during the conversion to
+a single data-vector index. In this conversion, each index is added to the
+accumulating total, then the total is multiplied by the range of the following
+dimension, the next index is added in, and so on. In other words, if the data
+vector is scanned linearly, the last array index is the one that varies most
+rapidly, then the index before it, and so on.
+
+
+\f
+\section{Array VOPs}
+
+alloc-bit-vector
+alloc-i-vector
+alloc-string
+alloc-g-vector
+ Initialized and uninitialized versions?
+
+
+length (sequence) => size
+{small, fast} length/vector
+{small, fast} length/simple-vector
+{small, fast} length/simple-string
+{small, fast} length/simple-bit-vector
+
+aref1 (vector index) => value
+{small, fast} aref1/simple-vector
+{small, fast} aref1/simple-string
+{small, fast} aref1/simple-bit-vector
+{small, fast} aref1/simple-array-XXX-float
+
+aset1 (vector index new-value)
+{small, fast} aset1/simple-vector
+{small, fast} aset1/simple-string
+{small, fast} aset1/simple-bit-vector
+{small, fast} aset1/simple-array-XXX-float
+
+{small, fast} aref1/simple-array-unsigned-byte (vector index) => value
+{small, fast} aset1/simple-array-unsigned-byte (vector index new-value)
+ Byte size is codegen info.
+
+aref<N> (array index0 ... index<n-1>) => value
+aset<N> (array index0 ... index<n-1> new-value)
+ For some small value of N. Of course, higher dimensional arrays can also
+ be specialized in seven different ways.... Multi-dimensional simple array
+ reference with known dimensions can be open-coded using a transform (useful
+ for benchmarks.)
+
+
+\f
+\section{Array Sub-primitives}
+
+alloc-array
+vector-subtype
+set-vector-subtype
+vector-access-code
+set-vector-access-code
+shrink-vector
+
+typed-vref
+typed-vset
+
+header-length (header) => size
+header-ref (header index) => value
+header-set (header index new-value)
+
+bit-bash
+byte-blt
+{reverse-}find-character
+{reverse-}find-character-with-attribute
+{reverse-}string-compare
+sxhash-simple-string
+sxhash-simple-substring
+
+\f
+\chapter{Structures}
+
+{small, fast} structure-ref (s) => value
+{small, fast} structure-set (s new-value)
+ Read and write structure slots. Defstruct slot description is in codegen
+ info.
+
+alloc-structure
+
+\f
+\chapter{Runtime Environment}
+\index{Runtime Environment}
+\label{Runtime}
+
+\f
+\section{Register Allocation}
+\index{Register allocation}
+
+The main idea is to globally allocate only those registers with global
+significance.
+
+We permanently dedicate the CONT register to point to the current control stack
+environment. This is the "frame pointer" in standard terminology. It isn't
+possible to get pack to allocate this register on an as-needed basis due to the
+classic phase-ordering problem. We need to know if TNs are allocated on the
+stack before we can determine tell how badly we need a frame pointer register.
+This is of little significance with the control stack environment, since we
+almost always need one, and if there are any stack TNs, we must allocate the
+frame pointer in a register, since there is nowhere else to put it. The
+problem is more severe with a number stack environment pointer. We can't
+dedicate a register to it, since we usually don't have any TNs on the number
+stack. The only easy solution is to always allocate the number stack
+environment pointer on the control stack. This really isn't too bad, when you
+compare the cost of doing an extra memory reference to get at the number stack
+to the cost of number-consing.
+
+We also dedicate the ENV register to the current constant pool. It would be
+possible to explicitly allocate the constant pointer as needed if we explicitly
+represented non-immediate constant access by a VOP, but this would be extra
+work, and there are major advantages to representing all constants using TNs.
+Another potential efficiency advantage is since the same constant pool is
+shared by all the code in a component, we need only initialize ENV on entry to
+the component. When we make local calls, we don't have to do anything to make
+the constants available to the callee.
+
+Since the constant pool will also contain the code vector and the debug info,
+having it in a known place may make life easier for GC and the debugger. We
+may not be able to count on it too much, though, since ENV holds other things
+will calls are in progress, and might be pretty random if we jumped into
+hyperspace.
+
+\f
+Runtime environment:
+
+CONT: the current control stack context.
+PC is assumed to be accessible to the debugger when an error happens.
+Current-Catch: pointer to the current catch frame. Format of frame is assumed.
+Current-Unwind-Protect: current unwind protect frame. Similar to catch.
+
+If shallow-bind, binding stack and binding stack pointer.
+If deep-bind, current special binding. Format of binding frame assumed.
+
+Everything depends on the current environment, which is CONT.
+
+
+PC
+OLD-CONT
+ENV
+A<n>
+CONT
+CS
+
+\f
+\section{Other Dynamic State}
+
+There are some dynamic state variables that are stored in known memory
+locations, rather than having a dedicated register:
+\begin{description}
+binding stack pointer\\The current pointer to the top of the binding stack.
+
+current catch\\The pointer to the current catch block.
+
+current unwind-protect\\The pointer to the current unwind-protect block.
+\end{description}
+
+
+
+\f
+\section{Control-Stack Format}
+\label{Control-Stack-Format}
+\index{Control-stack format}
+
+
+The control stack contains only Lisp objects. Every object pointed to by an
+entry on this stack is kept alive.
+
+The \rtccl control stack does not have a rigid frame structure. The compiler
+is allowed a large amount of freedom in the use of the stack so that it choose
+the best calling sequences. Mostly the compiler is the only system that cares
+how the stack is laid out, so this isn't a big problem. See chapter
+\ref{debug-info} for a description of the structures which allow the debugger
+to parse the stack.
+
+
+
+\section{Values Passing Conventions}
+
+
+The first {\it nregs} arguments are passed in registers, where nregs is an
+implementation dependent constant. Any additional arguments are the block of
+storage between CONT and CS on the control stack. The first nregs locations in
+this block of storage are unused so that register more-args can be stored on
+the stack without having to BLT the stack values up.
+
+Returning unknown values are passed in a similar way, but the stack values
+block is between OLD-CONT and CS. There isn't any underneath the values: on
+return OLD-CONT is always what CS was when the function was called. The
+function returned to must copy the values into the desired location in its
+frame and deallocate excess stuff on the top of the stack.
+
+More args are represented by a pointer to the block of values and a count. The
+function that originally created the more arg must allocate and deallocate this
+stuff somehow. In the case of a local call to a more arg entry, we can just
+allocate it as a TN. The external entry point for a more arg entry is more
+magical.
+
+
+
+The caller allocates the environment for the called function, stores the
+arguments into it, and jumps to the function. The caller makes the called
+environment current, passing in the return OLD-CONT and PC as explicit arguments.
+
+When returning values, the returner directly stores the return values into the
+frame being returned to. This works even though the caller doesn't know what
+function it is returning to, since the same return locations are allocated in
+all frames.
+
+In a tail-recursive call, we can destructively modify the current frame and
+jump right to the callee, rather than allocating a new frame. We can do this
+because TNBind globally allocates frame locations; all frames are the same size
+and have the same TNs in the same place.
+
+\f
+\section{Binding-Stack Format}
+\index{Binding stack format}
+\comment<In a symbol chapter?>
+
+
+The special binding stack is used to hold previous values of special variables
+that have been bound. It grows and shrinks with the depth of the binding
+environment, as reflected in the control stack. This stack contains
+symbol-value pairs, with only boxed Lisp objects present.
+
+Each entry of the binding-stack consists of two boxed (32-bit) words. Pushed
+first is a pointer to the symbol being bound. Pushed second is the symbol's
+old value (any boxed item) that is to be restored when the binding stack is
+popped.
+
+\f
+\chapter{Functions}
+
+Function calling is a way of life.
+
+every function is a closure. pointer to current closure is passed in ENV
+unless it isn't (in local call may be elsewhere).
+
+The description of the representation of functions and the function calling
+conventions is a large part of the VM description, since:
+ Function calling is one of the most complicated facilities provided by the
+ VM.
+
+ Everything that happens, happens in a function, so all parts of the system
+ tend to get dragged in.
+
+
+Aspects of function call:
+ Control
+ Environment CONT, ENV
+ Argument/value passing
+ Argument/value count dispatching
+
+
+
+\f
+\section{Function Object Format}
+\label{Fn-Format}
+
+The old notion of a "function object" is now broken down into four different
+parts:
+\begin{description}
+Function entry\\A function entry is a structure that holds the information
+that we need to call a function. This is the user visible function object.
+
+Environment\\The environment is stuff that a function needs when it runs.
+This includes constants computed at load time and variables closed over at run
+time. Environment information may be allocated in the function entry structure
+after the required linkage information.
+
+Entry information\\This is information about a specific function entry that is
+occasionally referenced at run time, but need not be immediately accessible.
+Entry information will be either allocated in the function entry
+or in the environment that it points to.
+
+Debug information\\This is information about a function that isn't normally
+needed at run time. Debug information can be found by poking around in
+environment objects.
+\end{description}
+See chapter \ref{control-conventions} for a description of how function objects
+are used.
+
+\f
+\section{Environment Object Sub-primitives}
+
+alloc-code ?
+alloc-closure?
+
+\f
+\subsection{Debug Information Location}
+
+If present, debug information is stored immediately following any fixed
+information in the environment object. It may be necessary to chain up
+multiple levels of environments to find the debug information. The debug
+information can be recognized because it is represented by a defstruct
+structure. See chapter \ref{debug-info} for a description of the debug
+information.
+
+\f
+\section{Function Calls}
+\index{function call}
+
+\ccl supports three major calling conventions. The convention used
+depends on the amount of information available at compile time:
+\begin{description}
+Local\\Local call is used when the call and the called function are
+compiled at the same time. Using the term "convention" to describe this
+call mechanism is somewhat of a misnomer, since the compiler can do
+whatever it wants.
+
+Named\\Named call is used when the call is to a global function whose name
+is known at compile time.
+
+Anonymous\\Anonymous call is used when the function called is unknown until
+run time.
+\end{description}
+
+\#|
+IR2 function call:
+
+Environment manipulation code is always emitted at the location of the Bind or
+Return node for a Lambda.
+
+Implicit args to functions in IR2:
+ old-cont: cont to restore on return
+ return-pc: pc to return to
+ env: pointer to current closure (if heap)
+ closure<n>: closed values for current closure (if stack)
+
+Other info needed for IR2 conversion of functions:
+ base pointers for all heap closures consed by this function
+ also have passing locs for each explicit arg
+ return strategy (known or unknown) and return locs
+
+All arguments including implicit ones must have both a passing TN and a
+permanent TN. Passing locs for let calls can be the actual TN that holds the
+variable in the case of local variables. Set closure variables must still have
+a separate passing TN.
+
+If we know the values counts for the argument continuations, then we compile
+local mv-calls by moving the TNs for the values continuations into the argument
+passing locations. Other mv-calls must be compiled using various hairy
+stack-hacking VOPs and unknown argument count call VOPs.
+
+For now, we will create the callee's frame just before the call, instead of
+creating it before the evaluation of the first argument. If we created the
+environment early, then we would be able to move the argument values directly
+into the frame, instead of having to store them somewhere else for a while.
+The problem with early creation is that lifetime analysis gets confused because
+there is more than one instance of the same TN present simultaneously in the
+case where there are nested calls to the same function.
+
+It turns out that there isn't a problem with a simple self-call, because the TN
+in the called frame is really the "same" TN as the one in the current frame,
+due to the restricted way in which we use the passing TNs.
+
+We emit code for external entry points during IR2 conversion. The external
+entry point is the place where we start running in a full call from a
+function-entry. It does arg count checking and dispatching, moves the
+arguments into the passing locations for the for the lambda being called, and
+calls the lambda, moving the results into the standard locations if there
+aren't there already.
+|\#
+
+
+In IR2, the environment manipulation semantics of function call are decoupled
+from the control semantics. When allocating closure variables for a Let, it is
+possible to do environment manipulation with only the normal sequential control
+flow. In the case of a Let call with the same environment, we neither
+manipulate the environment nor transfer control; we merely initialize the
+variables with Move VOPs.
+
+If a local function returns a known number of values which is less than the
+number expected by the caller, then additional code must be inserted at the
+return site which sets the unused values to NIL.
+
+The full function call mechanism must effectively be a subset of the local call
+mechanism, since the two mechanisms must mesh at entry points and full function
+calls. A full call turns into some kind of full call VOP. There are different
+VOPs for calling named functions and closures. We also have tail-recursive
+full call VOPs. Arguments are set up using Move VOPs, just as for local call.
+The only difference is that the passing locations and conventions are
+restricted to the standard ones.
+
+The gory details of arg count checking and dispatching are buried in the
+Function-Entry VOP, which takes a functional and a list of continuations, one
+pointing to each external entry.
+
+\f
+\subsection{Local Call}
+\index{local call}
+
+Named and anonymous call are called full calls, to distinguish them from
+local call. When making full calls, the compiler must make many worst-case
+assumptions that aren't necessary in a local call. The advantage of local
+call is that the compiler can choose to use only those parts of the full
+call sequence that are actually necessary.
+
+In local call, we always know the function being called, so we never have
+to do argument count checking, and can always use an immediate branch for
+the control transfer. If the function doesn't return to more than one
+place, then can just use a simple branch, or even drop through.
+
+The argument passing TNs may be allocated anywhere. The caller allocates the
+stack frame for the called function, moving any non-register arguments into the
+passing locations in the callee's frame.
+
+If we are calling a local function that doesn't always return the same
+number of values, then we must use the same values returning mechanism that
+is used in full call, but we don't have to use the standard registers.
+
+A tail-recursive local call doesn't require any call VOP. We just use Move
+VOPs to put the arguments into the passing locations and then jump to the the
+start of the code for the function. We don't have to do any stack hackery
+since we use the same stack frame format for all the functions compiled at the
+same time. In many cases tail-recursive local calls can be entirely optimized
+away, since they involve only some moves and a branch. We preference the
+argument values to the passing locations of the called function, making it
+likely that no move will be necessary. Often the control transfer can be done
+by simply dropping through.
+
+We have to do some funny stuff with local calls in order to get the lifetimes
+for the passing locations right, since lifetime analysis skips directly from
+the return point to the call point, ignoring the uses of the passing locations
+in the called function. Similarly, we pretend that a block ending in a return
+has no successors.
+
+call-local (arg*) "fun" => value
+multiple-call-local (arg*) "fun" => start end val0 ... val<n>
+ Call-Local is used for calls to local functions that are forced to use the
+ unknown-values passing convention. Value is the first return value
+ register; we don't really do anything to it, but we specify it as a result
+ to represent the assignment done by the calling function.
+
+ Multiple-Call-Local is similar, but specifies all the values used by the
+ unknown-values convention. Default-Values may be used to receive a
+ specific number of values.
+
+known-call-local (arg*) "fun" => value*
+ This VOP is used for local calls to functions where we can determine at
+ compile time that the number of values returned is always the same. In
+ this case, we don't need to indicate the number of values, and can pass
+ them in separate TNs. The Values are the actual return locations. We
+ don't really do anything to the return values; we just specify them as
+ results to represent the assignment done by the called function.
+
+known-return (return-pc value*) "fun"
+ This VOP is used for returning from local calls using the known return
+ values convention. The specified return Values are moved into the passing
+ locations in the caller's frame.
+
+
+If we know that the function we are calling is non-recursive, then we can
+compile it much like a tail-recursive call. We must have a call VOP to compute
+the return PC, but we don't need to allocate a frame or save registers. We
+just set up the arguments in the frame and do the call.
+
+We require simple functions to use the known-values convention. It would be
+possible to support unknown values, but it would potentially require BLT'ing
+return values out of the frame and on to the top of the stack. Supporting
+unknown values would also require a bunch more VOPs, since we need different
+call and return VOPs for simple call.
+
+Known values return causes no problems, since the callee knows how many values
+are wanted. We store the values directly into the current frame, since it is
+also the caller's frame.
+
+known-call-simple () "fun" => return-pc
+known-return-simple (return-pc) "fun"
+ Similar to the non-simple VOPs, but don't allocate or deallocate frames,
+ and assume that argument and value passing is done with explicit Move VOPs.
+
+\f
+\subsection{Full Call}
+\index{full call}
+
+Both named and anonymous call are optimized for calls where the number of
+arguments is known at compile time. Unknown argument calls are a
+pathological case of anonymous call; this case will be ignored in the main
+discussion. The difference between named and anonymous calls is in the
+argument count dispatching mechanism.
+
+Named call allows an arbitrary number of entry points, with start PCs at
+arbitrary locations in the code vector. The link-table mechanism described
+below allows named calls to jump directly to the actual entry point without any
+run-time argument count or type checking checking.
+
+Anonymous call has a fixed number of entry points, with start PCs at fixed
+locations in the code vector. This allows calls to be made without knowing
+what function is being called, but has more run-time overhead. The object
+called must be checked to be a valid function-entry object. The entry PC must
+be computed from the function entry, and argument count checking must be done
+if there are more than three required or optional arguments.
+
+Argument passing in full call is conceptually similar to local call, but the
+caller can't allocate the entire frame for the callee, since it doesn't know
+how much stack is needed. Instead we allocate the frame in two parts. The
+caller only allocates the beginning of the frame, which contains the stack
+arguments in fixed locations. We leave the first <n> locations unused so that
+the called function can move register more args onto the stack without having
+to BLT down any stack arguments.
+
+The place in the code where a full call jumps in is called an external entry
+point. The external entry point allocates the rest of the stack frame and then
+does a local call to the actual entry-point function, fetching the arguments
+from the standard passing locations. Usually we can do a tail-recursive local
+call.
+
+There are two main cases where the call from the external entry point cannot be
+tail-recursive:
+ -- It is desirable to use the known-values convention for calling the
+ entry-point function if the entry-point is used in other local calls
+ (perhaps because of recursion). In this case, the called function stores
+ the return values back into the frame allocated by the external entry point
+ and then returns back to it. The external entry point must then return
+ these values using the standard unknown-values convention.
+ -- In a more-arg entry point we don't know how many stack arguments there are
+ at the beginning of the frame, so we can't really use the frame allocated
+ by the external entry point at all. Instead we do a local call to the
+ more-arg entry point, passing in a pointer to the first extra value. When
+ the function returns, we deallocate the crap on the stack and then return
+ the values. It is still o.k. to use the known-values return convention
+ from the more-arg entry since the extra arg values are no longer needed by
+ the time the returning function stores the return values back into the
+ external entry point frame.
+
+
+In full call we must always use the unknown-values convention for return. The
+first <n> values are passed in the standard argument registers. The Old-Cont
+register holds the Start of the values block and SP points to the End.
+
+
+{small, fast} call (function arg0 ... arg<n>) "nargs" => value
+{small, fast} call-named (arg0 ... arg<n>) "nargs" "name" => value
+ Call-Closure calls Function with the specified register arguments,
+ returning the first value as the result. "nargs" is the total number of
+ arguments passed. Only the register arguments actually passed should be
+ specified as operands.
+
+ Call-Named is similar, but calls a global function specified at compile
+ time by "name".
+
+{small, fast} tail-call (function pc arg0 ... arg<n>) "nargs"
+{small, fast} tail-call-named (pc arg0 ... arg<n>) "nargs" "name"
+ Similar to the standard call VOPs, but passes PC as the return PC, rather
+ than returning to the call site. These VOPs have no results since they
+ don't return.
+
+{small, fast} multiple-call (function arg0 ... arg<n>) "nargs"
+ => start end val0 ... val<n>
+{small, fast} multiple-call-named (arg0 ... arg<n>) "nargs" "name"
+ => start end val0 ... val<n>
+ These VOPs are similar to the standard call VOPs, but allow any number of
+ values to be received by returning all the value passing registers as
+ results. A specific number of values may be received by using
+ Default-Values.
+
+call-unknown (function count arg0 ... arg<n>) => start end val0 ... val<n>
+tail-call-unknown (function pc count arg0 ... arg<n>)
+ Call a function with an unknown number of arguments. Used for apply and
+ hairy multiple-value-call.
+
+Function-Entry () "function" => env return-pc old-cont arg*
+ This marks the place where we jump into a component for an external
+ entry point. It represents whatever magic is necessary to do argument
+ count checking and dispatching. The external entry points for each
+ argument count will be successors of the entry-vector block (might be in
+ the same block if only one?)
+
+ Function-Entry also represents argument passing by specifying the actual
+ external passing locations as results, thus marking the beginning of their
+ lifetimes. All passing locations actually used by any entry point are
+ specified as Args, including stack arguments.
+ {\#\#\# Do we really need this? If we do, then we probably also need similar
+ entry markers for local functions. The lifetimes don't really need to be
+ explicitly bounded, since an entry point is effectively "the end of the
+ world."}
+
+\f
+\section(Returning from a Function Call)
+\label(Return)
+\index(Return)
+
+
+return (return-pc value)
+multiple-return (return-pc start end val0 ... val<n>)
+ Return Value from the current function, jumping back to the location
+ specified by Return-PC. {Perhaps allow to return any fixed, known number
+ of values.}
+
+ Multiple-Return is similar, but allows an arbitrary number of values to be
+ returned. End - Start is the total number of values returned. Start
+ points to the beginning of the block of return values, but the first <n>
+ values val0 ... val<n> are actually returned in registers.
+
+default-values (start end val0 ... val<n>) => val0 ... val<j>
+ This VOP is used when we want to receive exactly J values. If fewer than J
+ values were supplied, then missing values are defaulted to NIL. As a
+ side-effect, this VOP pops off any returned stack values.
+
+\f
+\section{Saving and Restoring Registers}
+
+We use a caller-saves convention. The caller explicitly emits saving and
+restoring code. Tail-recursive calls don't need
+any register saving since we never come back.
+
+
+\f
+\chapter{Non-local exits}
+
+\f
+\subsection{Unwind Blocks}
+\index{Catch}
+\index{Catch frames}
+
+There is one aspect of the control stack format that is fixed, and which
+concerns us at this level. This is the format of the "frames" which mark the
+destination of non-local exits, such as for BLOCK and CATCH. These frames are
+collectively known as unwind blocks. The basic unwind block is used for
+lexical exists such as BLOCK, and for UNWIND-PROTECT. Its format is the
+following:
+\begin{verbatim}
+0 Pointer to current unwind-protect.
+1 Control stack context to restore on entry.
+2 PC to enter at.
+\end{verbatim}
+
+The unwind block for CATCH is identical except for additional cells
+containing the catch tag and previous catch.
+\begin{verbatim}
+0 Pointer to current unwind-protect.
+1 Control stack context to restore on entry.
+2 PC to enter at.
+3 Catch tag.
+4 Previous catch.
+\end{verbatim}
+
+The conventions used to manipulate unwind blocks are described in chapter
+\ref{Control-Conventions}.
+
+
+\f
+\section{Non-Local Exits}
+\label{Catch}
+\index{Catch}
+\index{Throw}
+\index{Unwinding}
+\index{Unwind-Protect}
+\index{Non-Local Exits}
+
+In the normal flow of control, each function that is called executes until it
+reaches a return point; under these conditions no special effort is needed to
+restore the environment as long as each function undoes any change that it
+makes to the dynamic state before it returns. When we make a non-local
+transfer, we skip a potentially arbitrary collection of these cleanup actions.
+Since we cannot in general know what changes have been made to the dynamic
+environment below us on the stack, we must restore a snapshot of the dynamic
+environment at the re-entry point.
+
+We represent the closed continuation by the pointer to the unwind-block for the
+reentry point. At the exit point, we just pass this stack pointer to the
+Unwind VOP, which deals with processing any unwind-protects. When Unwind is
+done, it grabs the re-entry PC out of the location at the stack pointer and
+jumps in.
+
+Catch and Unwind-Protect work in pretty much the same way. We make a stack TN
+to hold the catch frame or whatever, allocate TNs in them to represent the
+slots, and then initialize them. The frame can be explicitly linked in by TN
+manipulations, since the active catch and whatnot are represented by TNs.
+Since allocation of the frame is decoupled from linking and unlinking, some of
+this stuff could be moved out of loops. We will need a VOP for loading the PC
+for an arbitrary continuation so that we can set up the reentry PC. This can
+be done using the Call VOP. Using a call instruction is probably a good way to
+get a PC on most architectures anyway.
+
+These TNs are allocated by Pack like any others; we use special alloc and
+dealloc VOPs to delimit the aggregate lifetimes.
+
+In the non-local case, the the Block, Catch and Unwind-Protect special forms
+are implemented using unwind blocks. The unwind blocks are built by move
+operations emitted inline by the compiler. The compiler adds and removes
+catches and unwind protects by explicit moves to the locations that hold the
+current catch and unwind protect blocks. The entry PC is loaded using the Call
+VOP.
+
+The Unwind miscop is the basis non-local exits. It takes the address of an
+unwind block and processes unwind-protects until the current unwind-protect is
+the one recorded in the unwind block, then jumps in at the entry in the unwind
+block. The entry for the unwind block is responsible for restoring any state
+other than the current unwind-protect.
+
+Unwind is used directly to implement non-local Return-From. The address of the
+unwind block is stored in a closure variable.
+
+Catch just does a scan up the chain of Catch blocks, starting at the current
+catch. When it finds the right one, it calls unwind on it.
+
+Unwind-protects are represented by unwind blocks linked into the current
+unwind-protect chain. The cleanup code is entered just like any other any
+other unwind entry. As before, the entry is responsible for establishing the
+correct dynamic environment for the cleanup code. The target unwind block is
+passed in some non-argument register. When the cleanup code is done, it
+just calls Unwind with the block passed in. The cleanup code must be careful
+not to trash the argument registers or CS, since there may be multiple values
+lurking out there.
+
+With Catch/Throw, we always use the variable values return value passing convention,
+since we don't know how many values the catch wants. With Block/Return-From,
+we can do whatever we want, since the returner and receiver know each other.
+
+If a Block or Catch receives stack values, it must call a VOP that BLT's the
+values down the stack, squeezing out any intermediate crud.
+
+
+unwind (context)
+throw (tag)
+ Unwind does a non-local exit, unwinding to the place indicated by Context.
+ Context is a pointer to a block of storage allocated on the control stack,
+ containing the entry PC, current environment and current unwind-protect.
+ We scan up the stack, processing unwind-protects until we reach the entry
+ point. The values being returned are passed in the standard locations.
+ Throw is similar, but does a dynamic lookup for the Tag to determine what
+ context to unwind to.
+
--- /dev/null
+<chapter id="compiler"><title>The Compiler</>
+
+<para>This chapter will discuss most compiler issues other than
+efficiency, including compiler error messages, the &SBCL compiler's
+unusual approach to type safety in the presence of type declarations,
+the effects of various compiler optimization policies, and the way
+that inlining and open coding may cause optimized code to differ from
+a naive translation. Efficiency issues are sufficiently varied and
+separate that they have <link linkend="efficiency">their own
+chapter</link>.</para>
+
+<sect1><title>Error Messages</>
+<!--INDEX {error messages}{compiler}-->
+<!--INDEX {compiler error messages}-->
+
+<para>The compiler supplies a large amount of source location
+information in error messages. The error messages contain a lot of
+detail in a terse format, so they may be confusing at first. Error
+messages will be illustrated using this example program:
+<programlisting>(defmacro zoq (x)
+ `(roq (ploq (+ ,x 3))))
+
+(defun foo (y)
+ (declare (symbol y))
+ (zoq y))</programlisting>
+The main problem with this program is that it is trying to add
+<literal>3</> to a symbol. Note also that the functions
+<function>roq</> and <function>ploq</> aren't defined anywhere.
+</para>
+
+<sect2><title>The Parts of the Error Message</>
+
+<para>When processing this program, the compiler will produce this warning:
+<screen>file: /tmp/foo.lisp
+
+in: DEFUN FOO
+ (ZOQ Y)
+--> ROQ PLOQ +
+==>
+ Y
+caught WARNING:
+ Result is a SYMBOL, not a NUMBER.</screen>
+In this example we see each of the six possible parts of a compiler error
+message:
+<orderedlist>
+ <listitem><para><computeroutput>File: /tmp/foo.lisp</>
+ This is the name of the file that the compiler read the
+ relevant code from. The file name is displayed because it
+ may not be immediately obvious when there is an
+ error during compilation of a large system, especially when
+ <function>with-compilation-unit</> is used to delay undefined
+ warnings.</para></listitem>
+ <listitem><para><computeroutput>in: DEFUN FOO</> This is the
+ definition top-level form responsible for the error. It is
+ obtained by taking the first two elements of the enclosing form
+ whose first element is a symbol beginning with <quote><literal>def</></>.
+ If there is no such enclosing <quote><literal>def</></> form, then the
+ outermost form is used. If there are multiple <literal>def</>
+ forms, then they are all printed from the outside in, separated by
+ <literal>=></>'s. In this example, the problem was in the
+ <function>defun</> for <function>foo</>.</para></listitem>
+ <listitem><para><computeroutput>(ZOQ Y)</> This is the
+ <emphasis>original source</> form responsible for the error.
+ Original source means that the form directly appeared in the
+ original input to the compiler, i.e. in the lambda passed to
+ <function>compile</> or in the top-level form read from the
+ source file. In this example, the expansion of the <function>zoq</>
+ macro was responsible for the error.</para></listitem>
+ <listitem><para><computeroutput>--> ROQ PLOQ +</> This is the
+ <emphasis>processing path</> that the compiler used to produce
+ the errorful code. The processing path is a representation of
+ the evaluated forms enclosing the actual source that the
+ compiler encountered when processing the original source.
+ The path is the first element of each form, or the form itself
+ if the form is not a list. These forms result from the
+ expansion of macros or source-to-source transformation done
+ by the compiler. In this example, the enclosing evaluated forms
+ are the calls to <function>roq</>, <function>ploq</> and
+ <function>+</>. These calls resulted from the expansion of
+ the <function>zoq</> macro.</para></listitem>
+ <listitem><para><computeroutput>==> Y</> This is the
+ <emphasis>actual source</> responsible for the error. If
+ the actual source appears in the explanation, then
+ we print the next enclosing evaluated form, instead of
+ printing the actual source twice. (This is the form
+ that would otherwise have been the last form of the processing
+ path.) In this example, the problem is with the evaluation of
+ the reference to the variable <varname>y</>.</para></listitem>
+ <listitem><para>
+ <computeroutput>caught WARNING: Result is a SYMBOL, not a NUMBER.</>
+ This is the <emphasis>explanation</> of the problem. In this
+ example, the problem is that <varname>y</> evaluates to a symbol,
+ but is in a context where a number is required (the argument
+ to <function>+</>).</para></listitem>
+</orderedlist>
+
+Note that each part of the error message is distinctively marked:
+
+<itemizedlist>
+ <listitem><para> <computeroutput>file:</> and <computeroutput>in:</>
+ mark the file and definition, respectively.</para></listitem>
+ <listitem><para> The original source is an indented form with no
+ prefix.</para></listitem>
+ <listitem><para> Each line of the processing path is prefixed with
+ <computeroutput>--></computeroutput></para></listitem>
+ <listitem><para> The actual source form is indented like the original
+ source, but is marked by a preceding <computeroutput>==></> line.
+ </para></listitem>
+ <listitem><para> The explanation is prefixed with the error
+ severity, which can be <computeroutput>caught ERROR:</>,
+ <computeroutput>caught WARNING:</>,
+ <computeroutput>caught STYLE-WARNING:</>, or
+ <computeroutput>note:</>. </para></listitem>
+</itemizedlist>
+</para>
+
+<para>Each part of the error message is more specific than the preceding
+one. If consecutive error messages are for nearby locations, then the
+front part of the error messages would be the same. In this case, the
+compiler omits as much of the second message as in common with the
+first. For example:
+<screen>file: /tmp/foo.lisp
+
+in: DEFUN FOO
+ (ZOQ Y)
+--> ROQ
+==>
+ (PLOQ (+ Y 3))
+caught STYLE-WARNING:
+ undefined function: PLOQ
+
+==>
+ (ROQ (PLOQ (+ Y 3)))
+caught STYLE-WARNING:
+ undefined function: ROQ</screen>
+In this example, the file, definition and original source are
+identical for the two messages, so the compiler omits them in the
+second message. If consecutive messages are entirely identical, then
+the compiler prints only the first message, followed by:
+<computeroutput>[Last message occurs <replaceable>repeats</> times]</>
+where <replaceable>repeats</> is the number of times the message
+was given.</para>
+
+<para>If the source was not from a file, then no file line is printed.
+If the actual source is the same as the original source, then the
+processing path and actual source will be omitted. If no forms
+intervene between the original source and the actual source, then the
+processing path will also be omitted.</para>
+
+</sect2>
+
+<sect2><title>The Original and Actual Source</>
+
+<para>The <emphasis>original source</> displayed will almost always be
+a list. If the actual source for an error message is a symbol, the
+original source will be the immediately enclosing evaluated list form.
+So even if the offending symbol does appear in the original source,
+the compiler will print the enclosing list and then print the symbol
+as the actual source (as though the symbol were introduced by a
+macro.)</para>
+
+<para>When the <emphasis>actual source</> is displayed
+(and is not a symbol), it will always
+be code that resulted from the expansion of a macro or a source-to-source
+compiler optimization. This is code that did not appear in the original
+source program; it was introduced by the compiler.</para>
+
+<para>Keep in mind that when the compiler displays a source form
+in an error message, it always displays the most specific (innermost)
+responsible form. For example, compiling this function
+<programlisting>(defun bar (x)
+ (let (a)
+ (declare (fixnum a))
+ (setq a (foo x))
+ a))</programlisting>
+gives this error message
+<screen>in: DEFUN BAR
+ (LET (A) (DECLARE (FIXNUM A)) (SETQ A (FOO X)) A)
+caught WARNING: The binding of A is not a FIXNUM:
+ NIL</screen>
+This error message is not saying <quote>there is a problem somewhere in
+this <function>let</></quote> — it is saying that there is a
+problem with the <function>let</> itself. In this example, the problem
+is that <varname>a</>'s <literal>nil</> initial value is not a
+<type>fixnum</>.</para>
+
+</sect2>
+
+<sect2><title>The Processing Path</>
+<!--INDEX processing path-->
+<!--INDEX macroexpansion-->
+<!--INDEX source-to-source transformation-->
+
+<para>The processing path is mainly useful for debugging macros, so if
+you don't write macros, you can probably ignore it. Consider this
+example:
+
+<programlisting>(defun foo (n)
+ (dotimes (i n *undefined*)))
+</programlisting>
+
+Compiling results in this error message:
+
+<screen>in: DEFUN FOO
+ (DOTIMES (I N *UNDEFINED*))
+--> DO BLOCK LET TAGBODY RETURN-FROM
+==>
+ (PROGN *UNDEFINED*)
+caught STYLE-WARNING:
+ undefined variable: *UNDEFINED*</screen>
+
+Note that <function>do</> appears in the processing path. This is because
+<function>dotimes</> expands into:
+
+<programlisting>(do ((i 0 (1+ i)) (#:g1 n))
+ ((>= i #:g1) *undefined*)
+ (declare (type unsigned-byte i)))</programlisting>
+
+The rest of the processing path results from the expansion
+of <function>do</>:
+
+<programlisting>
+(block nil
+ (let ((i 0) (#:g1 n))
+ (declare (type unsigned-byte i))
+ (tagbody (go #:g3)
+ #:g2 (psetq i (1+ i))
+ #:g3 (unless (>= i #:g1) (go #:g2))
+ (return-from nil (progn *undefined*)))))
+</programlisting>
+
+In this example, the compiler descended into the <function>block</>,
+<function>let</>, <function>tagbody</> and <function>return-from</> to
+reach the <function>progn</> printed as the actual source. This is a
+place where the <quote>actual source appears in explanation</> rule
+was applied. The innermost actual source form was the symbol
+<varname>*undefined*</> itself, but that also appeared in the
+explanation, so the compiler backed out one level.</para>
+
+</sect2>
+
+<sect2><title>Error Severity</>
+<!--INDEX severity of compiler errors -->
+<!--INDEX compiler error severity -->
+
+<para>There are four levels of compiler error severity:
+<wordasword>error</>, <wordasword>warning</>, <wordasword>style
+warning</>, and <wordasword>note</>. The first three levels correspond
+to condition classes which are defined in the &ANSI; standard for
+&CommonLisp; and which have special significance to the
+<function>compile</> and <function>compile-file</> functions. These
+levels of compiler error severity occur when the compiler handles
+conditions of these classes. The fourth level of compiler error
+severity, <wordasword>note</>, is used for problems which are too mild
+for the standard condition classes, typically hints about how
+efficiency might be improved.</para>
+
+</sect2>
+
+<sect2><title>Errors During Macroexpansion</>
+<!--INDEX {macroexpansion}{errors during}-->
+
+<para>The compiler handles errors that happen during macroexpansion,
+turning them into compiler errors. If you want to debug the error (to
+debug a macro), you can set <varname>*break-on-signals*</> to
+<literal>error</>. For example, this definition:
+
+<programlisting>(defun foo (e l)
+ (do ((current l (cdr current))
+ ((atom current) nil))
+ (when (eq (car current) e) (return current))))</programlisting>
+
+gives this error:
+
+<screen>in: DEFUN FOO
+ (DO ((CURRENT L #) (# NIL)) (WHEN (EQ # E) (RETURN CURRENT)) )
+caught ERROR: (during macroexpansion)
+
+error in function LISP::DO-DO-BODY:
+ DO step variable is not a symbol: (ATOM CURRENT)</screen>
+</para>
+
+</sect2>
+
+<sect2><title>Read Errors</>
+<!--INDEX {read errors}{compiler}-->
+
+<para>&SBCL;'s compiler (unlike &CMUCL;'s) does not attempt to recover
+from read errors when reading a source file, but instead just reports
+the offending character position and gives up on the entire source
+file.</para>
+
+</sect2>
+
+<!-- FIXME: How much control over error messages is in SBCL?
+_ How much should be? How much of this documentation should
+_ we save or adapt?
+_
+_ %%\node Error Message Parameterization, , Read Errors, Interpreting Error Messages
+_ \subsection{Error Message Parameterization}
+_ \cpsubindex{error messages}{verbosity}
+_ \cpsubindex{verbosity}{of error messages}
+_
+_ There is some control over the verbosity of error messages. See also
+_ \varref{undefined-warning-limit}, \code{*efficiency-note-limit*} and
+_ \varref{efficiency-note-cost-threshold}.
+_
+_ \begin{defvar}{}{enclosing-source-cutoff}
+_
+_ This variable specifies the number of enclosing actual source forms
+_ that are printed in full, rather than in the abbreviated processing
+_ path format. Increasing the value from its default of \code{1}
+_ allows you to see more of the guts of the macroexpanded source,
+_ which is useful when debugging macros.
+_ \end{defvar}
+_
+_ \begin{defvar}{}{error-print-length}
+_ \defvarx{error-print-level}
+_
+_ These variables are the print level and print length used in
+_ printing error messages. The default values are \code{5} and
+_ \code{3}. If null, the global values of \code{*print-level*} and
+_ \code{*print-length*} are used.
+_ \end{defvar}
+_
+_ \begin{defmac}{extensions:}{def-source-context}{%
+_ \args{\var{name} \var{lambda-list} \mstar{form}}}
+_
+_ This macro defines how to extract an abbreviated source context from
+_ the \var{name}d form when it appears in the compiler input.
+_ \var{lambda-list} is a \code{defmacro} style lambda-list used to
+_ parse the arguments. The \var{body} should return a list of
+_ subforms that can be printed on about one line. There are
+_ predefined methods for \code{defstruct}, \code{defmethod}, etc. If
+_ no method is defined, then the first two subforms are returned.
+_ Note that this facility implicitly determines the string name
+_ associated with anonymous functions.
+_ \end{defmac}
+_
+_ -->
+
+</sect1>
+
+<sect1><title>The Compiler's Handling of Types</>
+
+<para>The most unusual features of the &SBCL; compiler (which is
+very similar to the original &CMUCL compiler, also known as
+&Python;) is its unusually sophisticated understanding of the
+&CommonLisp; type system and its unusually conservative approach to
+the implementation of type declarations. These two features reward the
+use of type declarations throughout development, even when high
+performance is not a concern. (Also, as discussed <link
+linkend="efficiency">in the chapter on performance</>, the use of
+appropriate type declarations can be very important for performance as
+well.)</para>
+
+<para>The &SBCL; compiler, like the related compiler in &CMUCL;,
+treats type declarations much differently than other Lisp compilers.
+By default (<emphasis>i.e.</>, at ordinary levels of the
+<parameter>safety</> compiler optimization parameter), the compiler
+doesn't blindly believe most type declarations; it considers them
+assertions about the program that should be checked.</para>
+
+<para>The &SBCL; compiler also has a greater knowledge of the
+&CommonLisp; type system than other compilers. Support is incomplete
+only for the <type>not</>, <type>and</> and <type>satisfies</>
+types.
+<!-- FIXME: See also sections \ref{advanced-type-stuff}
+ and \ref{type-inference}, once we snarf them from the
+ CMU CL manual. -->
+</para>
+
+<sect2 id=compiler-impl-limitations><title>Implementation Limitations</>
+
+<para>
+Ideally, the compiler would consider <emphasis>all</> type declarations to
+be assertions, so that adding type declarations to a program, no
+matter how incorrect they might be, would <emphasis>never</> cause
+undefined behavior. As of &SBCL; version 0.6.4, the compiler is known to
+fall short of this goal in two areas:
+<itemizedlist>
+ <listitem><para>The compiler trusts function return values which
+ have been established with <function>proclaim</>.</para></listitem>
+ <listitem><para>There are a few poorly characterized but apparently
+ very uncommon situations where a type declaration in an unexpected
+ location will be trusted and never checked by the
+ compiler.</para></listitem>
+</itemizedlist></para>
+
+<para>These are important bugs, but are not necessarily easy to fix,
+so they may, alas, remain in the system for a while.</para>
+
+</sect2>
+
+<sect2><title>Type Errors at Compile Time</>
+<!--INDEX compile time type errors-->
+<!--INDEX type checking}{at compile time}-->
+
+<para>If the compiler can prove at compile time that some portion of
+the program cannot be executed without a type error, then it will give
+a warning at compile time. It is possible that the offending code
+would never actually be executed at run-time due to some higher level
+consistency constraint unknown to the compiler, so a type warning
+doesn't always indicate an incorrect program. For example, consider
+this code fragment:
+
+<programlisting>(defun raz (foo)
+ (let ((x (case foo
+ (:this 13)
+ (:that 9)
+ (:the-other 42))))
+ (declare (fixnum x))
+ (foo x)))
+</programlisting>
+
+Compilation produces this warning:
+
+<screen>in: DEFUN RAZ
+ (CASE FOO (:THIS 13) (:THAT 9) (:THE-OTHER 42))
+--> LET COND IF COND IF COND IF
+==>
+ (COND)
+caught WARNING: This is not a FIXNUM:
+ NIL</screen>
+
+In this case, the warning means that if <varname>foo</> isn't any of
+<literal>:this</>, <literal>:that</> or <literal>:the-other</>, then
+<varname>x</> will be initialized to <literal>nil</>, which the
+<type>fixnum</> declaration makes illegal. The warning will go away if
+<function>ecase</> is used instead of <function>case</>, or if
+<literal>:the-other</> is changed to <literal>t</>.</para>
+
+<para>This sort of spurious type warning happens moderately often in
+the expansion of complex macros and in inline functions. In such
+cases, there may be dead code that is impossible to correctly execute.
+The compiler can't always prove this code is dead (could never be
+executed), so it compiles the erroneous code (which will always signal
+an error if it is executed) and gives a warning.</para>
+
+<para>
+Type warnings are inhibited when the
+<parameter>extensions:inhibit-warnings</> optimization quality is
+<literal>3</>. (See <link linkend="compiler-policy">the section
+on compiler policy</>.) This can be used in a local declaration
+to inhibit type warnings in a code fragment that has spurious
+warnings.</para>
+
+</sect2>
+
+<sect2><title>Precise Type Checking</>
+<!--INDEX precise type checking-->
+<!--INDEX {type checking}{precise}-->
+
+<para>With the default compilation policy, all type declarations are
+precisely checked, except in a few situations (such as using
+<function>the</> to constrain the argument type passed to a function)
+where they are simply ignored instead. Precise checking means that the
+check is done as though <function>typep</> had been called with the
+exact type specifier that appeared in the declaration. In &SBCL;,
+adding type declarations makes code safer. (Except that as noted <link
+linkend="compiler-impl-limitations">elsewhere</link>, remaining bugs in
+the compiler's handling of types unfortunately provide some exceptions to
+this rule.)</para>
+
+<para>If a variable is declared to be
+<type>(integer 3 17)</>
+then its
+value must always always be an integer between <literal>3</>
+and <literal>17</>.
+If multiple type declarations apply to a single variable, then all the
+declarations must be correct; it is as though all the types were
+intersected producing a single <type>and</> type specifier.</para>
+
+<para>Argument type declarations are automatically enforced. If you declare
+the type of a function argument, a type check will be done when that
+function is called. In a function call, the called function does the
+argument type checking, which means that a more restrictive type
+assertion in the calling function (e.g., from <function>the</>) may be
+lost.</para>
+
+<para>The types of structure slots are also checked. The value of a
+structure slot must always be of the type indicated in any
+<literal>:type</> slot option. </para>
+
+<para>In traditional &CommonLisp; compilers, not all type assertions
+are checked, and type checks are not precise. Traditional compilers
+blindly trust explicit type declarations, but may check the argument
+type assertions for built-in functions. Type checking is not precise,
+since the argument type checks will be for the most general type legal
+for that argument. In many systems, type declarations suppress what
+little type checking is being done, so adding type declarations makes
+code unsafe. This is a problem since it discourages writing type
+declarations during initial coding. In addition to being more error
+prone, adding type declarations during tuning also loses all the
+benefits of debugging with checked type assertions.</para>
+
+<para>To gain maximum benefit from the compiler's type checking, you
+should always declare the types of function arguments and structure
+slots as precisely as possible. This often involves the use of
+<type>or</>, <type>member</>, and other list-style type specifiers.</para>
+
+</sect2>
+
+<sect2 id="weakened-type-checking"><title>Weakened Type Checking</>
+<!--INDEX weakened type checking-->
+<!--INDEX {type checking}{weakened}-->
+
+<para>At one time, &CMUCL; supported another level of type checking,
+<quote>weakened type checking</>, when the value for the
+<parameter>speed</> optimization quality is greater than
+<parameter>safety</>, and <parameter>safety</> is not <literal>0</>.
+The &CMUCL; manual still has a description of it, but the code no
+longer corresponds to the manual. It sounds like a good thing to have,
+and we might someday be able to restore it in &SBCL; but in the
+meantime, if you ask the compiler to optimize <parameter>speed</> to a
+higher level than <parameter>safety</>, your program is performing
+without a safety net, because &SBCL; may believe any or all type
+declarations without any runtime checking at all.</para>
+
+<!-- (beginning of text adapted from out-of-date CMUCL manual, describing
+_ features it would be nice for SBCL to restore someday)
+_
+_ <para>When the value for the <parameter>speed</> optimization quality
+_ is greater than <parameter>safety</>, and <parameter>safety</> is not
+_ <literal>0</>, then type checking is weakened to reduce the speed and
+_ space penalty. In structure-intensive code this can double the speed,
+_ yet still catch most type errors. Weakened type checks provide a level
+_ of safety similar to that of <quote>safe</> code in other &CommonLisp;
+_ compilers.</para>
+_
+_ <para>A type check is weakened by changing the check to be for some
+_ convenient supertype of the asserted type. For example, <type>(integer
+_ 3 17)</> is changed to <type>fixnum</>, <type>(simple-vector 17)</> to
+_ <type>simple-vector</>, and structure types are changed to
+_ <type>structure-object</>. A test for a complex type like <type>(or node hunk
+_ (member :foo :bar :baz))</> will be omitted entirely (i.e., the type
+_ is weakened to <type>*</>.) If a precise check can be done for no
+_ extra cost, then no weakening is done.</para>
+_
+_ <para>Although weakened type checking is similar to type checking done
+_ by other compilers, it is sometimes safer and sometimes less safe.
+_ Weakened checks are done in the same places is precise checks, so all
+_ the preceding discussion about where checking is done still applies.
+_ Weakened checking is sometimes somewhat unsafe because although the
+_ check is weakened, the precise type is still input into type
+_ inference. In some contexts this will result in type inferences not
+_ justified by the weakened check, and hence deletion of some type
+_ checks that would be done by conventional compilers.</para>
+_
+_ <para>For example, if this code was compiled with weakened checks
+_
+_ <programlisting>(defstruct foo
+_ (a nil :type simple-string))
+_
+_ (defstruct bar
+_ (a nil :type single-float))
+_
+_ (defun myfun (x)
+_ (declare (type bar x))
+_ (* (bar-a x) 3.0))</programlisting>
+_
+_ and <function>myfun</> was passed a value of
+_ type <type>foo</>, then no type error would be
+_ signaled, and we would try to multiply a <type>simple-vector</> as
+_ though it were a <type>single-float</> (with unpredictable results.)
+_ This is because the check for <type>bar</> was weakened to
+_ <type>structure-object</>, yet when compiling the call to <type>bar-a</>, the
+_ compiler thinks it knows it has a <type>bar</>.</para>
+_
+_ <para>Note that normally even weakened type checks report the precise
+_ type in error messages. For example, if <function>myfun</>'s
+_ <type>bar</> check is weakened to <type>structure-object</>, and the argument
+_ is <literal>nil</>, then the error will be:
+_
+_ <screen>Type-error in MYFUN:
+_ NIL is not of type BAR</screen>
+_
+_ However, there is some speed and space cost for signaling a precise
+_ error, so the weakened type is reported if the <parameter>speed</>
+_ optimization quality is <literal>3</> or <parameter>debug</>
+_ quality is less than <literal>1</>:
+_
+_ <screen>Type-error in MYFUN:
+_ NIL is not of type STRUCTURE-OBJECT</screen>
+_
+_ </para>
+_
+_ (end of text adapted from out-of-date CMUCL manual, describing
+_ features it would be nice for SBCL to restore someday) -->
+
+</sect2>
+
+<sect2><title>Getting Existing Programs to Run</>
+<!--INDEX {existing programs}{to run}-->
+<!--INDEX {types}{portability}-->
+<!--INDEX {compatibility with other Lisps}
+ (should also have an entry in the non-&ANSI;-isms section)-->
+
+<para>Since &SBCL;'s compiler does much more comprehensive type
+checking than other Lisp compilers, &SBCL; will detect type errors in
+many programs that have been debugged using other compilers. These
+errors are mostly incorrect declarations, although compile-time type
+errors can find actual bugs if parts of the program have never been
+tested.</para>
+
+<para>Some incorrect declarations can only be detected by run-time
+type checking. It is very important to initially compile programs with
+full type checks and then test this version. After the checking
+version has been tested, then you can consider weakening or
+eliminating type checks. <emphasis>This applies even to previously
+debugged programs,</emphasis> because the &SBCL; compiler does much
+more type inference than other &CommonLisp; compilers, so an incorrect
+declaration can do more damage.</para>
+
+<para>The most common problem is with variables whose constant initial
+value doesn't match the type declaration. Incorrect constant initial
+values will always be flagged by a compile-time type error, and they
+are simple to fix once located. Consider this code fragment:
+
+<programlisting>(prog (foo)
+ (declare (fixnum foo))
+ (setq foo ...)
+ ...)</programlisting>
+
+Here <varname>foo</> is given an initial value of <literal>nil</>, but
+is declared to be a <type>fixnum</>. Even if it is never read, the
+initial value of a variable must match the declared type. There are
+two ways to fix this problem. Change the declaration
+
+<programlisting>(prog (foo)
+ (declare (type (or fixnum null) foo))
+ (setq foo ...)
+ ...)</programlisting>
+
+or change the initial value
+
+<programlisting>(prog ((foo 0))
+ (declare (fixnum foo))
+ (setq foo ...)
+ ...)</programlisting>
+
+It is generally preferable to change to a legal initial value rather
+than to weaken the declaration, but sometimes it is simpler to weaken
+the declaration than to try to make an initial value of the
+appropriate type.</para>
+
+<para>Another declaration problem occasionally encountered is
+incorrect declarations on <function>defmacro</> arguments. This can happen
+when a function is converted into a macro. Consider this macro:
+
+<programlisting>(defmacro my-1+ (x)
+ (declare (fixnum x))
+ `(the fixnum (1+ ,x)))</programlisting>
+
+Although legal and well-defined &CommonLisp; code, this meaning of
+this definition is almost certainly not what the writer intended. For
+example, this call is illegal:
+
+<programlisting>(my-1+ (+ 4 5))</>
+
+This call is illegal because the argument to the macro is
+<literal>(+ 4 5)</>, which is a <type>list</>, not a
+<type>fixnum</>. Because of
+macro semantics, it is hardly ever useful to declare the types of
+macro arguments. If you really want to assert something about the
+type of the result of evaluating a macro argument, then put a
+<function>the</> in the expansion:
+
+<programlisting>(defmacro my-1+ (x)
+ `(the fixnum (1+ (the fixnum ,x))))</programlisting>
+
+In this case, it would be stylistically preferable to change this
+macro back to a function and declare it inline. Macros have no
+efficiency advantage over inline functions when using the
+&SBCL; compiler.
+<!--FIXME: <xref>inline-expansion</>, once we crib the
+ relevant text from the CMU CL manual.-->
+</para>
+
+<para>
+Some more subtle problems are caused by incorrect declarations that
+can't be detected at compile time. Consider this code:
+
+<programlisting>(do ((pos 0 (position #\a string :start (1+ pos))))
+ ((null pos))
+ (declare (fixnum pos))
+ ...)</programlisting>
+
+Although <varname>pos</> is almost always a <varname>fixnum</>, it is
+<literal>nil</> at the end of the loop. If this example is compiled
+with full type checks (the default), then running it will signal a
+type error at the end of the loop. If compiled without type checks,
+the program will go into an infinite loop (or perhaps
+<function>position</> will complain because <literal>(1+ nil)</> isn't
+a sensible start.) Why? Because if you compile without type checks,
+the compiler just quietly believes the type declaration. Since the
+compiler believes that <varname>pos</> is always a <type>fixnum</>, it
+believes that <varname>pos</> is never <literal>nil</>, so
+<literal>(null pos)</> is never true, and the loop exit test is
+optimized away. Such errors are sometimes flagged by unreachable code
+notes, but it is still important to initially compile and test any
+system with full type checks, even if the system works fine when
+compiled using other compilers.</para>
+
+<para>In this case, the fix is to weaken the type declaration to
+<type>(or fixnum null)</>.
+<footnote><para>Actually, this declaration is unnecessary
+ unnecessary in &SBCL;, since it already knows <function>position</>
+ returns a non-negative <type>fixnum</> or <literal>nil</>.
+ </para></footnote>
+
+Note that there is usually little performance penalty for weakening a
+declaration in this way. Any numeric operations in the body can still
+assume the variable is a <type>fixnum</>, since <literal>nil</> is not a legal
+numeric argument. Another possible fix would be to say:
+
+<programlisting>(do ((pos 0 (position #\a string :start (1+ pos))))
+ ((null pos))
+ (let ((pos pos))
+ (declare (fixnum pos))
+ ...))</programlisting>
+
+This would be preferable in some circumstances, since it would allow a
+non-standard representation to be used for the local <varname>pos</>
+variable in the loop body.
+<!-- FIXME: <xref>ND-variables</>, once we crib the text from the
+ CMU CL manual. -->
+</para>
+
+<para>In summary, remember that <emphasis>all</> values that a variable
+<emphasis>ever</> has must be of the declared type, and that you
+should test using safe compilation options initially.</para>
+
+</sect2>
+
+</sect1>
+
+<sect1 id="compiler-policy"><title>Compiler Policy</>
+
+<para>As of version 0.6.4, &SBCL; still uses most of the &CMUCL; code
+for compiler policy. Thi &CMUCL; code has many features and high-quality
+documentation, but the two unfortunately do not match. So this area of
+the compiler and its interface needs to be cleaned up. Meanwhile, here
+is some rudimentary documentation on the current behavior of the
+system.</para>
+
+<para>Compiler policy is controlled by the <parameter>optimize</>
+declaration. The compiler supports the &ANSI; optimization qualities,
+and also an extension <parameter>sb-ext:inhibit-warnings</>.</para>
+
+<para>Ordinarily, when the <parameter>speed</> quality is high, the
+compiler emits notes to notify the programmer about its inability to
+apply various optimizations. Setting
+<parameter>sb-ext:inhibit-warnings</> to a value at least as large as
+the <parameter>speed</> quality inhibits this notification. This can
+be useful to suppress notes about code which is known to be
+unavoidably inefficient. (For example, the compiler issues notes about
+having to use generic arithmetic instead of fixnum arithmetic, which
+is not useful for code which truly can't guarantee that its arguments
+will always be fixnums.)</para>
+
+<note><para>The basic functionality of the <parameter>optimize
+inhibit-warnings</> extension will probably be supported in all future
+versions of the system, but it will probably be renamed when the
+compiler and its interface are cleaned up. The current name is
+misleading, because it mostly inhibits optimization notes, not
+warnings. And making it an optimization quality is misleading, because
+it shouldn't affect the resulting code at all. It may become a
+declaration identifier with a name like SB-EXT:INHIBIT-NOTES, so that
+what's currently written
+
+<programlisting>(declaim (optimize (sb-ext:inhibit-warnings 2)))</>
+
+would become something like
+
+<programlisting>(declaim (sb-ext:inhibit-notes 2))</>
+
+</para></note>
+
+<para>When <parameter>speed</> is zero, the compiler emits byte code
+instead of native code. Byte code can be substantially more compact
+than native code (on the order of a factor of 2) and is usually much,
+much slower than native code (on the order of a factor of 50).</para>
+
+<para>When <parameter>safety</> is zero, almost all runtime checking
+of types, array bounds, and so forth is suppressed.</para>
+
+<para>When <parameter>safety</> is less than <parameter>speed</>, any
+and all type checks may be suppressed. At some point in the past,
+&CMUCL; had <link linkend="weakened-type-checking">a more nuanced
+interpretation of this.</link> At some point in the future, &SBCL; may
+restore that interpretation, or something like it. Until then, setting
+<parameter>safety</> less than <parameter>speed</> may have roughly
+the same effect as setting <parameter>safety</> to zero.</para>
+
+<para>The value of <parameter>space</> mostly influences the
+compiler's decision whether to inline operations, which tend to
+increase the size of programs. Use the value <literal>0</> with
+caution, since it can cause the compiler to inline operations so
+promiscuously that the net effect is to slow the program by causing
+cache misses or swapping.</para>
+
+<!-- FIXME: old CMU CL compiler policy, should perhaps be adapted
+_ for SBCL. (Unfortunately, the CMU CL docs are out of sync with the
+_ CMU CL code, so adapting this requires not only reformatting
+_ the documentation, but rooting out code rot.)
+_
+_<sect2 id="compiler-policy"><title>Compiler Policy</>
+_ INDEX {policy}{compiler}
+_ INDEX compiler policy
+_
+_<para>The policy is what tells the compiler <emphasis>how</> to
+_compile a program. This is logically (and often textually) distinct
+_from the program itself. Broad control of policy is provided by the
+_<parameter>optimize</> declaration; other declarations and variables
+_control more specific aspects of compilation.</para>
+_
+_\begin{comment}
+_* The Optimize Declaration::
+_* The Optimize-Interface Declaration::
+_\end{comment}
+_
+_%%\node The Optimize Declaration, The Optimize-Interface Declaration, Compiler Policy, Compiler Policy
+_\subsection{The Optimize Declaration}
+_\label{optimize-declaration}
+_\cindex{optimize declaration}
+_\cpsubindex{declarations}{\code{optimize}}
+_
+_The \code{optimize} declaration recognizes six different
+_\var{qualities}. The qualities are conceptually independent aspects
+_of program performance. In reality, increasing one quality tends to
+_have adverse effects on other qualities. The compiler compares the
+_relative values of qualities when it needs to make a trade-off; i.e.,
+_if \code{speed} is greater than \code{safety}, then improve speed at
+_the cost of safety.
+_
+_The default for all qualities (except \code{debug}) is \code{1}.
+_Whenever qualities are equal, ties are broken according to a broad
+_idea of what a good default environment is supposed to be. Generally
+_this downplays \code{speed}, \code{compile-speed} and \code{space} in
+_favor of \code{safety} and \code{debug}. Novice and casual users
+_should stick to the default policy. Advanced users often want to
+_improve speed and memory usage at the cost of safety and
+_debuggability.
+_
+_If the value for a quality is \code{0} or \code{3}, then it may have a
+_special interpretation. A value of \code{0} means ``totally
+_unimportant'', and a \code{3} means ``ultimately important.'' These
+_extreme optimization values enable ``heroic'' compilation strategies
+_that are not always desirable and sometimes self-defeating.
+_Specifying more than one quality as \code{3} is not desirable, since
+_it doesn't tell the compiler which quality is most important.
+_
+_
+_These are the optimization qualities:
+_\begin{Lentry}
+_
+_\item[\code{speed}] \cindex{speed optimization quality}How fast the
+_ program should is run. \code{speed 3} enables some optimizations
+_ that hurt debuggability.
+_
+_\item[\code{compilation-speed}] \cindex{compilation-speed optimization
+_ quality}How fast the compiler should run. Note that increasing
+_ this above \code{safety} weakens type checking.
+_
+_\item[\code{space}] \cindex{space optimization quality}How much space
+_ the compiled code should take up. Inline expansion is mostly
+_ inhibited when \code{space} is greater than \code{speed}. A value
+_ of \code{0} enables promiscuous inline expansion. Wide use of a
+_ \code{0} value is not recommended, as it may waste so much space
+_ that run time is slowed. \xlref{inline-expansion} for a discussion
+_ of inline expansion.
+_
+_\item[\code{debug}] \cindex{debug optimization quality}How debuggable
+_ the program should be. The quality is treated differently from the
+_ other qualities: each value indicates a particular level of debugger
+_ information; it is not compared with the other qualities.
+_ \xlref{debugger-policy} for more details.
+_
+_\item[\code{safety}] \cindex{safety optimization quality}How much
+_ error checking should be done. If \code{speed}, \code{space} or
+_ \code{compilation-speed} is more important than \code{safety}, then
+_ type checking is weakened (\pxlref{weakened-type-checks}). If
+_ \code{safety} if \code{0}, then no run time error checking is done.
+_ In addition to suppressing type checks, \code{0} also suppresses
+_ argument count checking, unbound-symbol checking and array bounds
+_ checks.
+_
+_\item[\code{extensions:inhibit-warnings}] \cindex{inhibit-warnings
+_ optimization quality}This is a CMU extension that determines how
+_ little (or how much) diagnostic output should be printed during
+_ compilation. This quality is compared to other qualities to
+_ determine whether to print style notes and warnings concerning those
+_ qualities. If \code{speed} is greater than \code{inhibit-warnings},
+_ then notes about how to improve speed will be printed, etc. The
+_ default value is \code{1}, so raising the value for any standard
+_ quality above its default enables notes for that quality. If
+_ \code{inhibit-warnings} is \code{3}, then all notes and most
+_ non-serious warnings are inhibited. This is useful with
+_ \code{declare} to suppress warnings about unavoidable problems.
+_\end{Lentry}
+_
+_%%\node The Optimize-Interface Declaration, , The Optimize Declaration, Compiler Policy
+_\subsection{The Optimize-Interface Declaration}
+_\label{optimize-interface-declaration}
+_\cindex{optimize-interface declaration}
+_\cpsubindex{declarations}{\code{optimize-interface}}
+_
+_The \code{extensions:optimize-interface} declaration is identical in
+_syntax to the \code{optimize} declaration, but it specifies the policy
+_used during compilation of code the compiler automatically generates
+_to check the number and type of arguments supplied to a function. It
+_is useful to specify this policy separately, since even thoroughly
+_debugged functions are vulnerable to being passed the wrong arguments.
+_The \code{optimize-interface} declaration can specify that arguments
+_should be checked even when the general \code{optimize} policy is
+_unsafe.
+_
+_Note that this argument checking is the checking of user-supplied
+_arguments to any functions defined within the scope of the
+_declaration, \code{not} the checking of arguments to \llisp{}
+_primitives that appear in those definitions.
+_
+_The idea behind this declaration is that it allows the definition of
+_functions that appear fully safe to other callers, but that do no
+_internal error checking. Of course, it is possible that arguments may
+_be invalid in ways other than having incorrect type. Functions
+_compiled unsafely must still protect themselves against things like
+_user-supplied array indices that are out of bounds and improper lists.
+_See also the \kwd{context-declarations} option to
+_\macref{with-compilation-unit}.
+_
+_(end of section on compiler policy)
+_-->
+
+</sect1>
+
+<sect1><title>Open Coding and Inline Expansion</>
+<!--INDEX open-coding-->
+<!--INDEX inline expansion-->
+<!--INDEX static functions-->
+
+<para>Since &CommonLisp; forbids the redefinition of standard
+functions, the compiler can have special knowledge of these standard
+functions embedded in it. This special knowledge is used in various
+ways (open coding, inline expansion, source transformation), but the
+implications to the user are basically the same:
+<itemizedlist>
+ <listitem><para> Attempts to redefine standard functions may
+ be frustrated, since the function may never be called. Although
+ it is technically illegal to redefine standard functions, users
+ sometimes want to implicitly redefine these functions when they
+ are debugging using the <function>trace</> macro. Special-casing
+ of standard functions can be inhibited using the
+ <parameter>notinline</> declaration.</para></listitem>
+ <listitem><para> The compiler can have multiple alternate
+ implementations of standard functions that implement different
+ trade-offs of speed, space and safety. This selection is
+ based on the <link linkend="compiler-policy">compiler policy</link>.
+ </para></listitem>
+</itemizedlist>
+</para>
+
+<para>When a function call is <emphasis>open coded</>, inline code whose
+effect is equivalent to the function call is substituted for that
+function call. When a function call is <emphasis>closed coded</>, it
+is usually left as is, although it might be turned into a call to a
+different function with different arguments. As an example, if
+<function>nthcdr</> were to be open coded, then
+
+<programlisting>(nthcdr 4 foobar)</programlisting>
+
+might turn into
+
+<programlisting>(cdr (cdr (cdr (cdr foobar))))</>
+
+or even
+
+<programlisting>(do ((i 0 (1+ i))
+ (list foobar (cdr foobar)))
+ ((= i 4) list))</programlisting>
+
+If <function>nth</> is closed coded, then
+
+<programlisting>
+(nth x l)
+</programlisting>
+
+might stay the same, or turn into something like
+
+<programlisting>
+(car (nthcdr x l))
+</programlisting>
+</para>
+
+<para>In general, open coding sacrifices space for speed, but some
+functions (such as <function>car</>) are so simple that they are always
+open-coded. Even when not open-coded, a call to a standard function
+may be transformed into a different function call (as in the last
+example) or compiled as <emphasis>static call</>. Static function call
+uses a more efficient calling convention that forbids
+redefinition.</para>
+
+</sect1>
+
+</chapter>
--- /dev/null
+<chapter id="efficiency"><title>Efficiency</>
+
+<para>FIXME: The material in the &CMUCL; manual about getting good
+performance from the compiler should be reviewed, reformatted in
+DocBook, lightly edited for &SBCL;, and substituted into this
+manual. In the meantime, the original &CMUCL; manual is still 95+%
+correct for the &SBCL; version of the &Python; compiler. See the
+sections
+<itemizedlist>
+ <listitem><para>Advanced Compiler Use and Efficiency Hints</></>
+ <listitem><para>Advanced Compiler Introduction</></>
+ <listitem><para>More About Types in Python</></>
+ <listitem><para>Type Inference</></>
+ <listitem><para>Source Optimization</></>
+ <listitem><para>Tail Recursion</></>
+ <listitem><para>Local Call</></>
+ <listitem><para>Block Compilation</></>
+ <listitem><para>Inline Expansion</></>
+ <listitem><para>Object Representation</></>
+ <listitem><para>Numbers</></>
+ <listitem><para>General Efficiency Hints</></>
+ <listitem><para>Efficiency Notes</></>
+</itemizedlist>
+</para>
+
+<para>Besides this information from the &CMUCL; manual, there are a
+few other points to keep in mind.
+<itemizedlist>
+ <listitem><para>The &CMUCL; manual doesn't seem to state it explicitly,
+ but &Python; has a mental block about type inference when
+ assignment is. involved &Python; is very aggressive and clever
+ about inferring the types of values bound with <function>let</>,
+ <function>let*</>, inline function call, and so forth. However,
+ it's much more passive and dumb about inferring the types of
+ values assigned with <function>setq</>, <function>setf</>, and
+ friends. It would be nice to fix this, but in the meantime don't
+ expect that just because it's very smart about types in most
+ respects it will be smart about types involved in assignments.
+ (This doesn't affect its ability to benefit from explicit type
+ declarations involving the assigned variables, only its ability to
+ get by without explicit type declarations.)</para></listitem>
+ <listitem><para>Since the time the &CMUCL; manual was written,
+ &CMUCL; (and thus &SBCL;) has gotten a generational garbage
+ collector. This means that there are some efficiency implications
+ of various patterns of memory usage which aren't discussed in the
+ &CMUCL; manual. (Some new material should be written about
+ this.)</para></listitem>
+ <listitem><para>&SBCL; has some important known efficiency problems.
+ Perhaps the most important are
+ <itemizedlist>
+ <listitem><para>There is no support for the &ANSI;
+ <parameter>dynamic-extent</> declaration, not even for
+ closures or <parameter>&rest</> lists.</para></listitem>
+ <listitem><para>The garbage collector is not particularly
+ efficient.</para></listitem>
+ <listitem><para>Various aspects of the PCL implementation
+ of CLOS are more inefficient than necessary.</para></listitem>
+ </itemizedlist>
+ </para></listitem>
+</itemizedlist>
+</para>
+
+<para>Finally, note that &CommonLisp; defines many constructs which, in
+the infamous phrase, <quote>could be compiled efficiently by a
+sufficiently smart compiler</quote>. The phrase is infamous because
+making a compiler which actually is sufficiently smart to find all
+these optimizations systematically is well beyond the state of the art
+of current compiler technology. Instead, they're optimized on a
+case-by-case basis by hand-written code, or not optimized at all if
+the appropriate case hasn't been hand-coded. Some cases where no such
+hand-coding has been done as of &SBCL; version 0.6.3 include
+<itemizedlist>
+ <listitem><para><literal>(reduce #'f x)</>
+ where the type of <varname>x</> is known at compile
+ time</para></listitem>
+ <listitem><para>various bit vector operations, e.g.
+ <literal>(position 0 some-bit-vector)</></para></listitem>
+</itemizedlist>
+If your system's performance is suffering because of some construct
+which could in principle be compiled efficiently, but which the &SBCL;
+compiler can't in practice compile efficiently, consider writing a
+patch to the compiler and submitting it for inclusion in the main
+sources. Such code is often reasonably straightforward to write;
+search the sources for the string <quote><function>deftransform</></>
+to find many examples (some straightforward, some less so).</para>
+
+</chapter>
--- /dev/null
+<chapter id="ffi"><title>The Foreign Function Interface</>
+
+<para>FIXME: The material in the &CMUCL; manual about the foreign
+function interface should be reviewed, reformatted in DocBook,
+lightly edited for &SBCL;, and substituted into this manual. But in
+the meantime, the original &CMUCL; manual is still 95+% correct for
+the &SBCL; version of the foreign function interface. (The main
+difference is that the package names have changed from
+<quote><literal>ALIEN</></> and <quote><literal>C-CALL</></> to
+<quote><literal>SB-ALIEN</></> and <quote><literal>SB-C-CALL</></>.)
+ <!-- FIXME: Oh, and I seem to remember that the CMUCL manual
+ was out of date about how to test for a null pointer,
+ there's a builtin operator to do it, you don't need to
+ do the nasty idiom the manual says you need to do. -->
+ <!-- FIXME: Also, the CMU CL alien documentation claims you
+ can just do (DEF-ALIEN-VARIABLE "errno" INT), which fails
+ with modern multithreading hacks. -->
+ <!-- FIXME: Also, LOAD-FOREIGN isn't implemented as of sbcl-0.6.7,
+ but LOAD-1-FOREIGN is. -->
+See the sections
+<itemizedlist>
+ <listitem><para>Type Translations</></>
+ <listitem><para>System Area Pointers</></>
+ <listitem><para>Alien Objects</></>
+ <listitem><para>Alien Types</></>
+ <listitem><para>Alien Operations</></>
+ <listitem><para>Alien Variables</></>
+ <listitem><para>Alien Function Calls</></>
+</itemizedlist>
+</para>
+
+</chapter>
\ No newline at end of file
--- /dev/null
+<chapter id="intro"><title>Introduction</>
+
+<para>&SBCL; is a mostly-conforming implementation of the &ANSI;
+&CommonLisp; standard. This manual focuses on behavior which is
+specific to &SBCL;, not on behavior which is common to all
+implementations of &ANSI; &CommonLisp;.</para>
+
+<sect1><title>More Information on &CommonLisp; in General</>
+
+<para>If you are an experienced programmer in general but need
+information on using &CommonLisp; in particular, <emphasis>ANSI Common
+Lisp</>, by Paul Graham, is a good place to start. <emphasis>Paradigms
+Of Artificial Intelligence Programming</>, by Peter Norvig, also has
+some good information on general &CommonLisp; programming, and many
+nontrivial examples. For CLOS in particular, <emphasis>Object-Oriented
+Programming In Common Lisp</> by Sonya Keene is useful.</para>
+
+<para>Two very useful resources for working with any implementation of
+&CommonLisp; are the
+<ulink url="http://ilisp.cons.org"><application>ILISP</></ulink>
+package for <application>Emacs</> and
+<ulink url="http://www.harlequin.com/books/HyperSpec">the &CommonLisp;
+HyperSpec</>.</para>
+
+</sect1>
+
+<sect1><title>More Information on SBCL</title>
+
+<para>Besides this manual, some other &SBCL;-specific information is
+available:
+<itemizedlist>
+ <listitem><para>There is a Unix <quote>man page</> file
+ <filename>sbcl.1</> in the &SBCL; distribution,
+ describing command options and other usage information
+ for the Unix <function>sbcl</> command which invokes
+ the &SBCL; system.</para></listitem>
+ <listitem><para>Documentation for non-&ANSI; extensions for
+ various commands is available online from the &SBCL; executable
+ itself. The extensions for functions which have their own
+ command prompts (e.g. the debugger, and <function>inspect</>)
+ are documented in text available by typing <userinput>help</>
+ at their command prompts. The extensions for functions which
+ don't have their own command prompt (e.g. <function>trace</>)
+ are described in their documentation strings,
+ unless your &SBCL was compiled with an option not
+ to include documentation strings, in which case the doc strings
+ are only readable in the source code.</para></listitem>
+ <listitem><para>The <ulink url="http://sbcl.sourceforge.net/">
+ &SBCL; home page</ulink> has some general
+ information, plus links to mailing lists devoted to &SBCL;,
+ and to archives of these mailing lists.</para></listitem>
+ <listitem><para>Some low-level information describing the
+ programming details of the conversion from &CMUCL; to &SBCL;
+ is available in the <filename>doc/FOR-CMUCL-DEVELOPERS</>
+ file in the &SBCL; distribution.</para></listitem>
+</itemizedlist>
+</para>
+
+</sect1>
+
+<sect1 id="implementation"><title>System Implementation and History</>
+
+<para>You can work productively with SBCL without understanding
+anything about how it was and is implemented, but a little knowledge
+can be helpful in order to better understand error messages,
+troubleshoot problems, to understand why some parts of the system are
+better debugged than others, and to anticipate which known bugs, known
+performance problems, and missing extensions are likely to be fixed,
+tuned, or added.</para>
+
+<para>&SBCL; is descended from &CMUCL;, which is itself descended from
+Spice Lisp. Early implementations for the Mach operating system on the
+IBM RT, back in the 1980s. Design decisions from that time are still
+reflected in the current implementation:
+<itemizedlist>
+ <listitem><para>The system expects to be loaded into a
+ fixed-at-compile-time location in virtual memory, and also expects
+ the location of all of its heap storage to be specified
+ at compile time.</para></listitem>
+ <listitem><para>The system overcommits memory, allocating large
+ amounts of address space from the system (often more than
+ the amount of virtual memory available) and then failing
+ if ends up using too much of the allocated storage.</para></listitem>
+ <listitem><para>A word is a 32-bit quantity. The system has been
+ ported to many processor architectures without altering this
+ basic principle. Some hacks allow the system to run on the Alpha
+ chip (a 64-bit architecture) but the assumption that a word is
+ 32 bits wide is implicit in hundreds of places in the
+ system.</para></listitem>
+ <listitem><para>The system is implemented as a C program which is
+ responsible for supplying low-level services and loading a
+ Lisp <quote>.core</quote> file.
+ </para></listitem>
+</itemizedlist>
+</para>
+
+<para>&SBCL; also inherited some newer architectural features from
+&CMUCL;. The most important is that it has a generational garbage
+collector (<quote>GC</>), which has various implications (mostly good)
+for performance. These are discussed in <link linkend="efficiency">
+another chapter</link>.</para>
+
+<para>The direct ancestor of &SBCL; is the X86 port of &CMUCL;.
+This port is in some ways the least mature of any in the &CMUCL;
+system, and some things (like profiling and backtracing)
+do not work particularly well there. &SBCL; should be able
+to improve in these areas, but it may take a while.</para>
+
+<para>The &SBCL; GC, like the GC on the X86 port of &CMUCL;, is
+<emphasis>conservative</>. This means that it doesn't maintain a
+strict separation between tagged and untagged data, instead treating
+some untagged data (e.g. raw floating point numbers) as
+possibly-tagged data and so not collecting any Lisp objects that they
+point to. This has some negative consequences for average time
+efficiency (though possibly no worse than the negative consequences of
+trying to implement an exact GC on a processor architecture as
+register-poor as the X86) and also has potentially unlimited
+consequences for worst-case memory efficiency. In practice,
+conservative garbage collectors work reasonably well, not getting
+anywhere near the worst case. But they can occasionally cause
+odd patterns of memory usage.</para>
+
+<para>The fork from &CMUCL; was based on a major rewrite of the system
+bootstrap process. &CMUCL; has for many years tolerated a very unusual
+<quote>build</> procedure which doesn't actually build the complete
+system from scratch, but instead progressively overwrites parts of a
+running system with new versions. This quasi-build procedure can cause
+various bizarre bootstrapping hangups, especially when a major change
+is made to the system. It also makes the connection between the
+current source code and the current executable more tenuous than in
+any other software system I'm aware of -- it's easy to accidentally
+<quote>build</> a &CMUCL; system containing characteristics not
+reflected in the current version of the source code.</para>
+
+<para>Other major changes since the fork from &CMUCL; include
+<itemizedlist>
+ <listitem><para>&SBCL; has dropped support for many &CMUCL; extensions,
+ (e.g. remote procedure call, Unix system interface, and X11
+ interface).</para></listitem>
+ <listitem><para>&SBCL; has deleted or deprecated
+ some nonstandard features and code complexity which helped
+ efficiency at the price of maintainability. For example, the
+ &SBCL; compiler no longer implements memory pooling internally
+ (and so is simpler and more maintainable, but generates more
+ garbage and runs more slowly), and various block-compilation
+ efficiency-increasing extensions to the language have been
+ deleted or are no longer used in the implementation of &SBCL;
+ itself.</para></listitem>
+</itemizedlist>
+</para>
+
+</sect1>
+
+</chapter>
--- /dev/null
+#!/bin/sh
+
+rm -f book1.htm
+jade -t sgml -ihtml -d sbcl-html.dsl\#html user-manual.sgml
+ln -sf book1.htm user-manual.html
--- /dev/null
+<!DOCTYPE style-sheet PUBLIC "-//James Clark//DTD DSSSL Style Sheet//EN"
+
+--
+
+This is a stylesheet for converting DocBook to HTML, implemented as a
+customization layer over Norman Walsh's modular DocBook stylesheets.
+It's possible that it could be useful for other documents, or even
+that it could be an example of decent DSSSL style, but if so, that's
+basically an accident, since it was written based on a superficial
+reading of chapter 4 of _DocBook: The Definitive Guide_, by Norman
+Walsh and Leonard Muellner, and has only been tested on the SBCL
+manual.
+
+This software is part of the SBCL system. See the README file for more
+information.
+
+The SBCL system is derived from the CMU CL system, which was written
+at Carnegie Mellon University and released into the public domain. The
+software is in the public domain and is provided with absolutely no
+warranty. See the COPYING and CREDITS files for more information.
+
+--
+
+ [<!ENTITY docbook.dsl
+ SYSTEM
+ "/usr/lib/sgml/stylesheets/nwalsh-modular/html/docbook.dsl"
+ CDATA
+ dsssl>]>
+
+<style-sheet>
+<style-specification id="html" use="docbook">
+<style-specification-body>
+
+;;; FIXME: It would be nice to have output files have ".html" extensions
+;;; instead of ".htm" extensions.
+
+;;; Essentially all the stuff in the "Programming languages and
+;;; constructs" section (pp. 40-41 of _DocBook: The Definitive Guide_)
+;;; is to be monospaced. The one exception is "replaceable", which
+;;; needs to be distinguishable from the others.
+;;;
+;;; (In the modular stylesheets as of 1.54, some elements like "type"
+;;; were typeset in the same font as running text, which led to
+;;; horrible confusion in the SBCL manual.)
+(element action ($mono-seq$))
+(element classname ($mono-seq$))
+(element constant ($mono-seq$))
+(element errorcode ($mono-seq$))
+(element errorname ($mono-seq$))
+(element errortype ($mono-seq$))
+(element function ($mono-seq$))
+(element interface ($mono-seq$))
+(element interfacedefinition ($mono-seq$))
+(element literal ($mono-seq$))
+(element msgtext ($mono-seq$))
+(element parameter ($mono-seq$))
+(element property ($mono-seq$))
+(element replaceable ($italic-seq$))
+(element returnvalue ($mono-seq$))
+(element structfield ($mono-seq$))
+(element structname ($mono-seq$))
+(element symbol ($mono-seq$))
+(element token ($mono-seq$))
+(element type ($mono-seq$))
+(element varname ($mono-seq$))
+
+;;; Things in the "Operating systems" and "General purpose"
+;;; sections (pp. 41-42 and pp. 42-43
+;;; of _DocBook: The Definitive Guide_) are handled on a case
+;;; by case basis.
+;;;
+;;; "Operating systems" section
+(element application ($charseq$))
+(element command ($mono-seq$))
+(element envar ($mono-seq$))
+(element filename ($mono-seq$))
+(element medialabel ($mono-seq$))
+;;; (The "msgtext" element is handled in another section.)
+(element option ($mono-seq$))
+;;; (The "parameter" element is handled in another section.)
+(element prompt ($bold-mono-seq$))
+(element systemitem ($mono-seq$))
+;;;
+;;; "General purpose" section
+(element database ($charseq$))
+(element email ($mono-seq$))
+;;; (The "filename" element is handled in another section.)
+(element hardware ($mono-seq$))
+(element inlinegraphic ($mono-seq$))
+;;; (The "literal" element is handled in another section.)
+;;; (The "medialabel" element is handled in another section.)
+;;; (The "option" element is handled in another section.)
+(element optional ($italic-mono-seq$))
+;;; (The "replaceable" element is handled in another section.)
+;;; (The "symbol" element is handled in another section.)
+;;; (The "token" element is handled in another section.)
+;;; (The "type" element is handled in another section.)
+
+</style-specification-body>
+</style-specification>
+
+<external-specification id="docbook" document="docbook.dsl">
+
+</style-sheet>
--- /dev/null
+.\" -*- Mode: Text -*-
+.\"
+.\" man page introduction to SBCL
+.\"
+.\" SBCL, including this man page, is derived from CMU Common Lisp, of
+.\" which it was said (ca. 1991)
+.\" **********************************************************************
+.\" This code was written as part of the CMU Common Lisp project at
+.\" Carnegie Mellon University, and has been placed in the public domain.
+.\" If you want to use this code or any part of CMU Common Lisp, please
+.\" contact Scott Fahlman or slisp-group@cs.cmu.edu.
+.\" **********************************************************************
+.\"
+.\" $Header$
+.\" FIXME: The date below should be $Date$.
+.TH SBCL 1 "$Date$"
+.AT 3
+.SH NAME
+SBCL -- "Steel Bank Common Lisp"
+
+.SH DESCRIPTION
+
+SBCL is a free Common Lisp programming environment. It is derived from
+the free CMU CL programming environment. (The name is intended to
+acknowledge the connection: steel and banking are the industries where
+Carnegie and Mellon made the big bucks.)
+
+.SH COMMAND LINE SYNTAX
+
+Command line syntax can be considered an advanced topic; for ordinary
+interactive use, no command line arguments should be necessary.
+
+In order to understand the command line argument syntax for SBCL, it
+is helpful to understand that the SBCL system is implemented as two
+components, a low-level runtime environment written in C and a
+higher-level system written in Common Lisp itself. Some command line
+arguments are processed during the initialization of the low-level
+runtime environment, some command line arguments are processed during
+the initialization of the Common Lisp system, and any remaining
+command line arguments are passed on to user code.
+
+The full, unambiguous syntax for SBCL is
+.TP 3
+.B sbcl [runtime options] --end-runtime-options [toplevel options] --end-toplevel-options [user options]
+.PP
+
+For convenience, the --end-runtime-options and --end-toplevel-options
+elements can be omitted. Omitting these elements can be convenient
+when you are running the program interactively, and you can see that
+no ambiguities are possible with the option values you are using.
+Omitting these elements is probably a bad idea for any batch file
+where any of the options are under user control, since it makes it
+impossible for SBCL to detect erroneous command line input, so that
+erroneous command line arguments will be passed on to the user program
+even if they was intended for the runtime system or the Lisp system.
+
+Supported runtime options are
+.TP 3
+.B --core <corefilename>
+Run the specified Lisp core file instead of the default. (See the FILES
+section.) Note that if the Lisp core file is a user-created core file, it may
+run a nonstandard toplevel which does not accept the standard toplevel options.
+.TP 3
+.B --noinform
+Suppress the printing of any banner or other informational message at
+startup. (Combined with the --noprint toplevel option, this makes it
+straightforward to write Lisp "scripts" which work as Unix pipes.)
+.PP
+
+In the future, runtime options may be added to control behavior such
+as lazy allocation of memory.
+
+Runtime options, including any --end-runtime-options option,
+are stripped out of the command line before the
+Lisp toplevel logic gets a chance to see it.
+
+Supported toplevel options for the standard SBCL core are
+.TP 3
+.B --sysinit <filename>
+Load filename instead of the default system-wide
+initialization file. (See the FILES section.)
+There is no special option to cause
+no system-wide initialization file to be read, but on a Unix
+system "--sysinit /dev/null" can be used to achieve the same effect.
+.TP 3
+.B --userinit <filename>
+Load filename instead of the default user
+initialization file. (See the FILES section.)
+There is no special option to cause
+no user initialization file to be read, but on a Unix
+system "--userinit /dev/null" can be used to achieve the same effect.
+.TP 3
+.B --eval <command>
+After executing any initialization file, but before starting the
+read-eval-print loop on standard input,
+evaluate the command given. More than
+one --eval option can be used, and all will be executed,
+in the order they appear on the command line.
+.TP 3
+.B --noprint
+When ordinarily the toplevel "read-eval-print loop" would be
+executed, execute a "read-eval loop" instead, i.e. don't print
+a prompt and don't echo results. (Combined with the --noinform
+runtime option, this makes it straightforward to write Lisp
+"scripts" which work as Unix pipe utilities.)
+.TP 3
+.B --noprogrammer
+Ordinarily the system initializes *DEBUG-IO* to *TERMINAL-IO*.
+When the --notty option is set, however, *DEBUG-IO* is instead
+set to a stream which sends its output to *ERROR-OUTPUT* and
+which raises an error on input. As a result, any attempt by the
+program to get programmer feedback through the debugger
+causes an error which abnormally terminates the entire
+Lisp environment. (This can be useful behavior for programs
+which are to run without programmer supervision.)
+.PP
+
+Regardless of the order in which --sysinit, --userinit, and --eval
+options appear on the command line, the sysinit file, if it exists, is
+loaded first; then the userinit file, if it exists, is loaded; then
+any --eval commands are executed in sequence; then the read-eval-print
+loop is started on standard input. At any step, error conditions or
+commands such as SB-EXT:QUIT can cause execution to be terminated
+before proceeding to subsequent steps.
+
+Note that when running SBCL from a core file created by a user call to
+the SB-EXT:SAVE-LISP-AND-DIE, the toplevel options may be under the
+control of user code passed as arguments to SB-EXT:SAVE-LISP-AND-DIE.
+For this purpose, the --end-toplevel-options option itself can be
+considered a toplevel option, i.e. the user core, at its option, may
+not support it.
+
+In the standard SBCL startup sequence (i.e. with no user core
+involved) toplevel options and any --end-toplevel-options option are
+stripped out of the command line argument list before user code gets a
+chance to see it.
+
+.SH OVERVIEW
+
+SBCL aims for but has not reached ANSI compliance.
+
+SBCL compiles Lisp to native code, or optionally to more-compact but
+much slower byte code.
+
+SBCL's garbage collector is generational and conservative.
+
+SBCL includes a source level debugger, as well as the ANSI TRACE
+facility and a rudimentary profiler.
+
+.SH DIFFERENCES FROM CMU CL
+
+SBCL can be built from scratch using a plain vanilla ANSI Common Lisp
+system and a C compiler, and all of its properties are specified by
+the version of the source code that it was created from. (This clean
+bootstrappability was the immediate motivation for forking off of the
+CMU CL development tree.)
+
+Many extensions supported by CMU CL, like Motif support,
+the Hemlock editor, search paths, the WIRE protocol, various
+user-level macros and functions (e.g. LETF, ITERATE, MEMQ,
+REQUIRED-ARGUMENT), and many others.
+
+SBCL has retained some extensions of its parent CMU CL. Many
+of them are in three categories:
+.TP 3
+\--
+hooks into the low level workings of the system which can be useful
+for debugging (e.g. a list of functions to be run whenever GC occurs,
+or an operator to cause a particular string to be compiled into a fasl
+file)
+.TP 3
+\--
+non-portable performance hacks (e.g. PURIFY, which causes
+everything currently in existence to become immune to GC)
+.TP 3
+\--
+things which might be in the new ANSI spec (e.g. weak pointers,
+finalization, foreign function interface to C, and Gray streams)
+.PP
+
+There are also various retained extensions which don't fall into
+any particular category, e.g.
+.TP 3
+\--
+the ability to save running Lisp images as executable files
+.PP
+
+Some of the retained extensions have new names and/or different
+options than their CMU CL counterparts. For example, the SBCL function
+which saves a Lisp image to disk and kills it is called
+SAVE-LISP-AND-DIE instead of SAVE-LISP, and it supports fewer keyword
+options than CMU CL's SAVE-LISP.
+
+.SH THE COMPILER
+
+SBCL inherits from CMU CL the "Python" native code compiler. This
+compiler is very clever about understanding the type system of Common
+Lisp and using it to produce efficient code, and about producing notes
+to let the user know when the compiler doesn't have enough type
+information to produce efficient code. It also tries (almost always
+successfully) to follow the unusual but very useful principle that
+type declarations should be checked at runtime unless the user
+explicitly tells the system that speed is more important than safety.
+
+The CMU CL version of this compiler reportedly produces pretty good
+code for modern machines which have lots of registers, but its code
+for the X86 is marred by a lot of extra loads and stores to
+stack-based temporary variables. Because of this, and because of the
+extra levels of indirection in Common Lisp relative to C, we find a
+typical performance decrease by a factor of perhaps 2 to 5 for small
+programs coded in SBCL instead of GCC.
+
+For more information about the compiler, see the user manual.
+
+.SH DOCUMENTATION
+
+Currently, the documentation for the system is
+.TP 3
+\--
+the user manual
+.TP 3
+\--
+this man page
+.TP 3
+\--
+doc strings and online help built into the SBCL executable
+.PP
+
+.SH SYSTEM REQUIREMENTS
+
+Unlike its distinguished ancestor CMU CL, SBCL is currently only
+supported on X86. Linux and FreeBSD are currently available. It would
+probably be straightforward to port the CMU CL support for Alpha or
+SPARC as well, or to OpenBSD or NetBSD, but at the time of this
+writing no such efforts are underway.
+
+As of version 0.6.3, SBCL requires on the order of 16Mb to run. In
+some future version, this number could shrink significantly, since
+large parts of the system are far from execution bottlenecks and could
+reasonably be stored in compact byte compiled form. (CMU CL does this
+routinely; the only reason SBCL doesn't currently do this is a
+combination of bootstrapping technicalities and inertia.)
+
+.SH ENVIRONMENT
+
+.TP 10n
+.BR SBCL_HOME
+If this variable is set, it overrides the default directories for
+files like "sbclrc" and "sbcl.core", so that instead of being searched
+for in e.g. /etc/, /usr/local/etc/, /usr/lib/, and /usr/local/lib/, they
+are searched for only in the directory named by SBCL_HOME. This is
+intended to support users who wish to use their own version of SBCL
+instead of the version which is currently installed as the system
+default.
+.PP
+
+.SH FILES
+
+/usr/lib/sbcl.core and /usr/local/lib/sbcl.core are the standard
+locations for the standard SBCL core, unless overridden by the SBCL_HOME
+variable.
+
+/etc/sbclrc and /usr/local/etc/sbclrc are the standard locations for
+system-wide SBCL initialization files, unless overridden by the
+SBCL_HOME variable.
+
+$HOME/.sbclrc is the standard location for a user's SBCL
+initialization file.
+
+.SH BUGS
+
+Too numerous to list, alas. This section attempts to list the most
+serious known bugs, and a reasonably representative sampling of
+others. For more information on bugs, see the BUGS file in the
+distribution.
+
+It is possible to get in deep trouble by exhausting
+memory. To plagiarize a sadly apt description of a language not
+renowned for the production of bulletproof software, "[The current
+SBCL implementation of] Common Lisp makes it harder for you to shoot
+yourself in the foot, but when you do, the entire universe explodes."
+.TP 3
+\--
+The system doesn't deal well with stack overflow.
+.TP 3
+\--
+The SBCL system overcommits memory at startup. On typical Unix-alikes
+like Linux and *BSD, this can cause other processes to be killed
+randomly (!) if the SBCL system turns out to use more virtual memory
+than the system has available for it.
+.PP
+
+The facility for dumping a running Lisp image to disk gets confused
+when run without the PURIFY option, and creates an unnecessarily large
+core file (apparently representing memory usage up to the previous
+high-water mark). Moreover, when the file is loaded, it confuses the
+GC, so that thereafter memory usage can never be reduced below that
+level.
+
+By default, the compiler is overaggressive about static typing,
+assuming that a function's return type never changes. Thus compiling
+and loading a file containing
+(DEFUN FOO (X) NIL)
+(DEFUN BAR (X) (IF (FOO X) 1 2))
+(DEFUN FOO (X) (PLUSP X))
+then running (FOO 1) gives 2 (because the compiler "knew"
+that FOO's return type is NULL).
+
+The compiler's handling of function return values unnecessarily
+violates the "declarations are assertions" principle that it otherwise
+adheres to. Using PROCLAIM or DECLAIM to specify the return type of a
+function causes the compiler to believe you without checking. Thus
+compiling a file containing
+(DECLAIM (FTYPE (FUNCTION (T) NULL) SOMETIMES))
+(DEFUN SOMETIMES (X) (ODDP X))
+(DEFUN FOO (X) (IF (SOMETIMES X) 'THIS-TIME 'NOT-THIS-TIME))
+then running (FOO 1) gives NOT-THIS-TIME, because the
+never compiled code to check the declaration.
+
+The TRACE facility can't be used on some kinds of functions.
+
+The profiler is flaky, e.g. sometimes it fails by throwing a
+signal instead of giving you a result.
+
+SYMBOL-FUNCTION is much slower than you'd expect, being implemented
+not as a slot access but as a search through the compiler/kernel
+"globaldb" database.
+
+CLOS (based on the PCL reference implementation) is quite slow.
+
+The interpreter's pre-processing freezes in the macro definitions in effect at
+the time an interpreted function is defined.
+
+There are many nagging pre-ANSIisms, e.g.
+.TP 3
+\--
+CLOS (based on the PCL reference implementation) is incompletely
+integrated into the system, so that e.g. SB-PCL::FIND-CLASS is a
+different function than CL::FIND-CLASS. (This is less of a problem in
+practice than the speed, but it's still distasteful.)
+.TP 3
+--
+The ANSI-recommended idiom for creating a function which is only
+sometimes expanded inline,
+(DECLAIM (INLINE F))
+(DEFUN F ...)
+(DECLAIM (NOTINLINE F)),
+doesn't do what you'd expect. (Instead, you have to declare the
+function as SB-EXT:MAYBE-INLINE to get the desired effect.)
+.TP 3
+--
+Compiling DEFSTRUCT in strange places (e.g. inside a DEFUN) doesn't
+do anything like what it should.
+.TP 3
+\--
+The symbol * is the name of a type similar to T. (It's used as part
+of the implementation of compound types like (ARRAY * 1).)
+.TP 3
+\--
+The DESCRIBE facility doesn't use CLOS (PRINT-OBJECT, etc.) as it should.
+Instead it is based on old hardwired TYPECASEs.
+.TP 3
+\--
+The printer doesn't use CLOS (PRINT-OBJECT, etc.) everywhere it should.
+Instead it still uses old hardwired TYPECASEs. (This one is not as
+annoying as it sounds, since the printer does use PRINT-OBJECT in the
+places where it tends to matter most.)
+.PP
+
+.SH SUPPORT
+
+Please send bug reports or other information to
+<william.newman@airmail.net>.
+
+.SH DISTRIBUTION
+
+SBCL is a free implementation of Common Lisp derived from CMU CL. Both
+sources and executables are freely available; this software is "as
+is", and has no warranty of any kind. CMU and the authors assume no
+responsibility for the consequences of any use of this software. See
+the CREDITS file in the distribution for more information about
+history, contributors and permissions.
+
--- /dev/null
+<!DOCTYPE book PUBLIC "-//OASIS//DTD DocBook V3.1//EN" [
+
+ <!-- markup for common expressions -->
+ <!ENTITY ANSI "<acronym>ANSI</>">
+ <!ENTITY CMUCL "<application>CMU CL</>">
+ <!ENTITY IEEE "<acronym>IEEE</>">
+ <!ENTITY Python "<application>Python</>">
+ <!ENTITY SBCL "<application>SBCL</>">
+
+ <!-- common expressions I haven't figured out how to mark up -->
+ <!-- KLUDGE: There doesn't seem to be any DocBook tag for names of
+ programming languages. Typesetting Lisp Common Lisp as an
+ <application> looks funny. Is there a better way?
+ WHN 20000505 -->
+ <!ENTITY CommonLisp "Common Lisp">
+ <!ENTITY Lisp "Lisp">
+
+ <!-- common expressions I haven't figured out how to express -->
+ <!ENTITY mdash "-">
+
+ <!-- document components -->
+ <!ENTITY ch-intro SYSTEM "intro.sgml">
+ <!ENTITY ch-compiler SYSTEM "compiler.sgml">
+ <!ENTITY ch-efficiency SYSTEM "efficiency.sgml">
+ <!ENTITY ch-beyond-ansi SYSTEM "beyond-ansi.sgml">
+ <!ENTITY ch-ffi SYSTEM "ffi.sgml">
+
+ ]>
+
+<book>
+
+<bookinfo>
+ <title>&SBCL; User Manual</title>
+ <legalnotice>
+
+ <para>This manual is part of the &SBCL; software system. See the
+ <filename>README</> file for more information.</para>
+
+ <para>This manual is derived in part from the manual for the &CMUCL;
+ system, which was produced at Carnegie Mellon University and
+ later released into the public domain. This manual is in the
+ public domain and is provided with absolutely no warranty. See the
+ <filename>COPYING</> and <filename>CREDITS</> files for more
+ information.</para>
+
+ </legalnotice>
+</bookinfo>
+
+&ch-intro;
+&ch-compiler;
+&ch-efficiency;
+&ch-beyond-ansi;
+&ch-ffi;
+
+<colophon>
+<para>This manual is maintained in SGML/DocBook, and automatically
+translated into other forms (e.g. HTML or TeX). If you're
+<emphasis>reading</> this manual in one of these non-DocBook
+translated forms, that's fine, but if you want to <emphasis>modify</>
+this manual, you are strongly advised to seek out a DocBook version
+and modify that instead of modifying a translated version. Even
+better might be to seek out <emphasis>the</> DocBook version
+(maintained at the time of this writing as part of
+<ulink url="http://sbcl.sourceforge.net/">the &SBCL; project</>)
+and submit a patch.</para>
+</colophon>
+
+</book>
--- /dev/null
+#!/bin/sh
+
+# Install SBCL files into the usual places.
+
+cp src/runtime/sbcl /usr/local/bin/
+cp output/sbcl.core /usr/local/lib/
+cp doc/sbcl.1 /usr/local/man/man1/
--- /dev/null
+#!/bin/sh
+
+# The make-config.sh script uses information about the target machine
+# to set things up for compilation. It's vaguely like a stripped-down
+# version of autoconf. It's intended to be run as part of make.sh. The
+# only time you'd want to run it by itself is if you're trying to
+# cross-compile the system or if you're doing some kind of
+# troubleshooting.
+
+# This software is part of the SBCL system. See the README file for
+# more information.
+#
+# This software is derived from the CMU CL system, which was
+# written at Carnegie Mellon University and released into the
+# public domain. The software is in the public domain and is
+# provided with absolutely no warranty. See the COPYING and CREDITS
+# files for more information.
+
+echo //entering make-config.sh
+
+ltf=`pwd`/local-target-features.lisp-expr
+echo //initializing $ltf
+echo '; This is a machine-generated file and should not be edited by hand.' > $ltf
+echo -n '(' >> $ltf
+
+echo '//setting up "target"-named symlinks to designate target architecture'
+sbcl_arch=x86 # (the only possibility supported, at least as of sbcl-0.6.7)
+echo -n ":x86" >> $ltf # (again, the only possibility supported)
+for d in src/compiler src/assembly; do
+ echo //setting up symlink $d/target
+ original_dir=`pwd`
+ cd $d
+ if [ -L target ] ; then
+ rm target
+ elif [ -e target ] ; then
+ echo "I'm afraid to replace non-symlink $d/target with a symlink."
+ exit 1
+ fi
+ if [ -d $sbcl_arch ] ; then
+ ln -s $sbcl_arch target
+ else
+ echo "missing sbcl_arch directory $PWD/$sbcl_arch"
+ exit 1
+ fi
+ cd $original_dir
+done
+
+echo //setting up OS-dependent information
+cd src/runtime/
+rm -f Config
+if [ `uname` = Linux ]; then
+ echo -n ' :linux' >> $ltf
+ ln -s Config.x86-linux Config
+elif uname | grep BSD; then
+ if [ `uname` = FreeBSD ]; then
+ echo -n ' :freebsd' >> $ltf
+ elif [ `uname` = OpenBSD ]; then
+ echo -n ' :openbsd' >> $ltf
+ else
+ echo unsupported BSD variant: `uname`
+ exit 1
+ fi
+ echo -n ' :bsd' >> $ltf
+ ln -s Config.x86-bsd Config
+else
+ echo unsupported OS type: `uname`
+ exit 1
+fi
+
+echo //finishing $ltf
+echo ')' >> $ltf
+
+# FIXME: The version system should probably be redone along these lines:
+#
+# echo //setting up version information.
+# versionfile=version.txt
+# cp base-version.txt $versionfile
+# echo " (built `date -u` by `whoami`@`hostname`)" >> $versionfile
+# echo 'This is a machine-generated file and should not be edited by hand.' >> $versionfile
--- /dev/null
+#!/bin/sh
+
+# This is a script to be run as part of make.sh. The only time you'd
+# want to run it by itself is if you're trying to cross-compile the
+# system or if you're doing some kind of troubleshooting.
+
+# This software is part of the SBCL system. See the README file for
+# more information.
+#
+# This software is derived from the CMU CL system, which was
+# written at Carnegie Mellon University and released into the
+# public domain. The software is in the public domain and is
+# provided with absolutely no warranty. See the COPYING and CREDITS
+# files for more information.
+
+echo //entering make-host-1.sh
+
+# Compile and load the cross-compiler. (We load it here not because we're
+# about to use it, but because it's written under the assumption that each
+# file will be loaded before the following file is compiled.)
+#
+# Also take the opportunity to compile and load genesis, to create the
+# header file sbcl.h which will be needed to create the C runtime
+# environment.
+echo //building cross-compiler, and doing first genesis
+$SBCL_XC_HOST <<-'EOF' || exit 1
+ ;; (We want to have some limit on print length and print level
+ ;; during bootstrapping because PRINT-OBJECT only gets set
+ ;; up rather late, and running without PRINT-OBJECT it's easy
+ ;; to fall into printing enormous (or infinitely circular)
+ ;; low-level representations of things.)
+ (setf *print-level* 5 *print-length* 5)
+ (load "src/cold/shared.lisp")
+ (in-package "SB-COLD")
+ (setf *host-obj-prefix* "obj/from-host/")
+ (load "src/cold/shared.lisp")
+ (load "src/cold/set-up-cold-packages.lisp")
+ (load "src/cold/defun-load-or-cload-xcompiler.lisp")
+ (load-or-cload-xcompiler #'host-cload-stem)
+ (host-cload-stem "compiler/generic/genesis")
+ (sb!vm:genesis :c-header-file-name "src/runtime/sbcl.h")
+ EOF
--- /dev/null
+#!/bin/sh
+
+# This is a script to be run as part of make.sh. The only time you'd
+# want to run it by itself is if you're trying to cross-compile the
+# system or if you're doing some kind of troubleshooting.
+
+# This software is part of the SBCL system. See the README file for
+# more information.
+#
+# This software is derived from the CMU CL system, which was
+# written at Carnegie Mellon University and released into the
+# public domain. The software is in the public domain and is
+# provided with absolutely no warranty. See the COPYING and CREDITS
+# files for more information.
+
+echo //entering make-host-2.sh
+
+# In a fresh host Lisp invocation, load and run the cross-compiler to
+# create the target object files describing the target SBCL.
+#
+# (There are at least three advantages to running the cross-compiler in a
+# fresh host Lisp invocation instead of just using the same Lisp invocation
+# that we used to compile it:
+# (1) It reduces the chance that the cross-compilation process
+# inadvertently comes to depend on some weird compile-time
+# side-effect.
+# (2) It reduces peak memory demand (because definitions wrapped in
+# (EVAL-WHEN (:COMPILE-TOPLEVEL :EXECUTE) ..) aren't defined
+# in the fresh image).
+# (3) It makes it easier to jump in and retry a step when tweaking
+# and experimenting with the bootstrap procedure.
+# Admittedly, these don't seem to be enormously important advantages, but
+# the only disadvantage seems to be the extra time required to reload
+# the fasl files into the new host Lisp, and that doesn't seem to be
+# an enormously important disadvantage, either.)
+echo //running cross-compiler to create target object files
+$SBCL_XC_HOST <<-'EOF' || exit 1
+ (setf *print-level* 5 *print-length* 5)
+ (load "src/cold/shared.lisp")
+ (in-package "SB-COLD")
+ (setf *host-obj-prefix* "obj/from-host/"
+ *target-obj-prefix* "obj/from-xc/")
+ (load "src/cold/set-up-cold-packages.lisp")
+ (load "src/cold/defun-load-or-cload-xcompiler.lisp")
+ (load-or-cload-xcompiler #'host-load-stem)
+ (defun proclaim-target-optimization ()
+ (let ((debug (if (find :sb-show *shebang-features*) 2 1)))
+ (sb-xc:proclaim `(optimize (compilation-speed 1)
+ (debug ,debug)
+ (sb!ext:inhibit-warnings 2)
+ (safety 3)
+ (space 1)
+ (speed 2)))))
+ (compile 'proclaim-target-optimization)
+ (defun in-target-cross-compilation-mode (fn)
+ "Call FN with everything set up appropriately for cross-compiling
+ a target file."
+ (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)
+ ;; Let the target know that we're the cross-compiler.
+ (*features* (cons :sb-xc *features*))
+ ;; We need to tweak the readtable..
+ (*readtable* (copy-readtable))
+ ;; In order to reduce peak memory usage during GENESIS,
+ ;; it helps to stuff several toplevel forms together
+ ;; into the same function.
+ (sb!c::*top-level-lambda-max* 10))
+ ;; ..in order to make backquotes expand into target code
+ ;; instead of host code.
+ ;; FIXME: Isn't this now taken care of automatically by
+ ;; toplevel forms in the xcompiler backq.lisp file?
+ (set-macro-character #\` #'sb!impl::backquote-macro)
+ (set-macro-character #\, #'sb!impl::comma-macro)
+ ;; Control optimization policy.
+ (proclaim-target-optimization)
+ ;; Specify where target machinery lives.
+ (with-additional-nickname ("SB-XC" "SB!XC")
+ (funcall fn))))
+ (compile 'in-target-cross-compilation-mode)
+ (setf *target-compile-file* 'sb-xc:compile-file)
+ (setf *target-assemble-file* 'sb!c:assemble-file)
+ (setf *in-target-compilation-mode-fn*
+ #'in-target-cross-compilation-mode)
+ (load "src/cold/compile-cold-sbcl.lisp")
+ (let ((filename "output/object-filenames-for-genesis.lisp-expr"))
+ (ensure-directories-exist filename :verbose t)
+ (with-open-file (s filename :direction :output)
+ (write *target-object-file-names* :stream s :readably t)))
+ ;; If you're experimenting with the system under a
+ ;; cross-compilation host which supports CMU-CL-style SAVE-LISP,
+ ;; this can be a good time to run it,
+ ;; The resulting core isn't used in the normal build, but
+ ;; can be handy for experimenting with the system.
+ (when (find :sb-show *shebang-features*)
+ #+cmu (ext:save-lisp "output/after-xc.core" :load-init-file nil)
+ #+sbcl (sb-ext:save-lisp-and-die "output/after-xc.core"))
+ EOF
+
+# Run GENESIS again in order to create cold-sbcl.core.
+#
+# In a fresh host Lisp invocation, load the cross-compiler (in order
+# to get various definitions that GENESIS needs, not in order to
+# cross-compile GENESIS, compile and load GENESIS, then run GENESIS.
+# (We use a fresh host Lisp invocation here for basically the same
+# reasons we did before when loading and running the cross-compiler.)
+#
+# (This second invocation of GENESIS is done because in order to
+# create a .core file, as opposed to just a .h file, GENESIS needs
+# symbol table data on the C runtime, which we can get only after the
+# C runtime has been built.)
+echo //loading and running GENESIS to create cold-sbcl.core
+$SBCL_XC_HOST <<-'EOF' || exit 1
+ (setf *print-level* 5 *print-length* 5)
+ (load "src/cold/shared.lisp")
+ (in-package "SB-COLD")
+ (setf *host-obj-prefix* "obj/from-host/"
+ *target-obj-prefix* "obj/from-xc/")
+ (load "src/cold/set-up-cold-packages.lisp")
+ (load "src/cold/defun-load-or-cload-xcompiler.lisp")
+ (load-or-cload-xcompiler #'host-load-stem)
+ (defparameter *target-object-file-names*
+ (with-open-file (s "output/object-filenames-for-genesis.lisp-expr"
+ :direction :input)
+ (read s)))
+ (host-load-stem "compiler/generic/genesis")
+ (sb!vm:genesis :object-file-names *target-object-file-names*
+ :c-header-file-name "output/sbcl2.h"
+ :symbol-table-file-name "src/runtime/sbcl.nm"
+ :core-file-name "output/cold-sbcl.core"
+ ;; The map file is not needed by the system, but can
+ ;; be very handy when debugging cold init problems.
+ :map-file-name "output/cold-sbcl.map")
+ EOF
+
+echo //testing for consistency of first and second GENESIS passes
+if cmp src/runtime/sbcl.h output/sbcl2.h; then
+ echo //sbcl2.h matches sbcl.h -- good.
+else
+ echo error: sbcl2.h does not match sbcl.h.
+ exit 1
+fi
--- /dev/null
+#!/bin/sh
+
+# This is a script to be run as part of make.sh. The only time you'd
+# want to run it by itself is if you're trying to cross-compile the
+# system or if you're doing some kind of troubleshooting.
+
+# This software is part of the SBCL system. See the README file for
+# more information.
+#
+# This software is derived from the CMU CL system, which was
+# written at Carnegie Mellon University and released into the
+# public domain. The software is in the public domain and is
+# provided with absolutely no warranty. See the COPYING and CREDITS
+# files for more information.
+
+echo //entering make-target-1.sh
+
+# Build the runtime system and symbol table (.nm) file.
+#
+# (This C build has to come after the first genesis in order to get
+# the sbcl.h the C build needs, and come before the second genesis in
+# order to produce the symbol table file that second genesis needs. It
+# could come either before or after running the cross compiler; that
+# doesn't matter.)
+echo //building runtime system and symbol table file
+cd src/runtime
+${GNUMAKE:-gmake} clean || exit 1
+${GNUMAKE:-gmake} depend || exit 1
+${GNUMAKE:-gmake} all || exit 1
--- /dev/null
+#!/bin/sh
+
+# This is a script to be run as part of make.sh. The only time you'd
+# want to run it by itself is if you're trying to cross-compile the
+# system or if you're doing some kind of troubleshooting.
+
+# This software is part of the SBCL system. See the README file for
+# more information.
+#
+# This software is derived from the CMU CL system, which was
+# written at Carnegie Mellon University and released into the
+# public domain. The software is in the public domain and is
+# provided with absolutely no warranty. See the COPYING and CREDITS
+# files for more information.
+
+echo //entering make-host-2.sh
+
+# Do warm init stuff, e.g. building and loading CLOS, and stuff which
+# can't be done until CLOS is running.
+#
+# Note that it's normal for the newborn system to think rather hard at
+# the beginning of this process (e.g. using nearly 100Mb of virtual memory
+# and >30 seconds of CPU time on a 450MHz CPU), and unless you built the
+# system with the :SB-SHOW feature enabled, it does it rather silently,
+# without trying to tell you about what it's doing. So unless it hangs
+# for much longer than that, don't worry, it's likely to be normal.
+echo //doing warm init
+./src/runtime/sbcl \
+--core output/cold-sbcl.core \
+--sysinit /dev/null --userinit /dev/null <<-'EOF' || exit 1
+ (sb!int:/show "hello, world!")
+ (let ((*print-length* 5)
+ (*print-level* 5))
+ (sb!int:/show "about to LOAD warm.lisp")
+ (load "src/cold/warm.lisp"))
+ (sb-int:/show "about to SAVE-LISP-AND-DIE")
+ ;; Even if /SHOW output was wanted during build, it's probably
+ ;; not wanted by default after build is complete. (And if it's
+ ;; wanted, it can easily be turned back on.)
+ #+sb-show (setf sb-int:*/show* nil)
+ (sb-ext:save-lisp-and-die "output/sbcl.core" :purify t)
+ EOF
--- /dev/null
+#!/bin/sh
+
+# "When we build software, it's a good idea to have a reliable method
+# for getting an executable from it. We want any two reconstructions
+# starting from the same source to end up in the same result. That's
+# just a basic intellectual premise."
+# -- Christian Quinnec, in _Lisp In Small Pieces_, p. 313
+
+# This software is part of the SBCL system. See the README file for
+# more information.
+#
+# This software is derived from the CMU CL system, which was
+# written at Carnegie Mellon University and released into the
+# public domain. The software is in the public domain and is
+# provided with absolutely no warranty. See the COPYING and CREDITS
+# files for more information.
+
+# The value of SBCL_XC_HOST should be a command to invoke the
+# cross-compilation Lisp system in such a way that it reads commands
+# from standard input, and terminates when it reaches end of file on
+# standard input. Suitable values are:
+# "sbcl" to use an existing SBCL binary as a cross-compilation host
+# "sbcl --sysinit /dev/null --userinit /dev/null"
+# to use an existing SBCL binary as a cross-compilation host
+# even though you have stuff in your initialization files
+# which makes it behave in such a non-standard way that
+# it keeps the build from working
+# "lisp -batch" to use an existing CMU CL binary as a cross-compilation host
+# "lisp -noinit -batch"
+# to use an existing CMU CL binary as a cross-compilation host
+# when you have weird things in your .cmucl-init file
+#
+# FIXME: Make a more sophisticated command line parser, probably
+# accepting "sh make.sh --xc-host foolisp" instead of the
+# the present "sh make.sh foolisp".
+# FIXME: Tweak this script, and the rest of the system, to support
+# a second bootstrapping pass in which the cross-compilation host is
+# known to be SBCL itself, so that the cross-compiler can do some
+# optimizations (especially specializable arrays) that it doesn't
+# know how to implement how in a portable way. (Or maybe that wouldn't
+# require a second pass, just testing at build-the-cross-compiler time
+# whether the cross-compilation host returns suitable values from
+# UPGRADED-ARRAY-ELEMENT-TYPE?)
+export SBCL_XC_HOST="${1:-sbcl}"
+echo //SBCL_XC_HOST=\"$SBCL_XC_HOST\"
+
+# If you're cross-compiling, you should probably just walk through the
+# make-config.sh script by hand doing the right thing on both the host
+# and target machines.
+sh make-config.sh || exit 1
+
+# The foo-host-bar.sh scripts are run on the cross-compilation host,
+# and the foo-target-bar.sh scripts are run on the target machine. In
+# ordinary compilation, we just do these phases consecutively on the
+# same machine, but if you wanted to cross-compile from one machine
+# which supports Common Lisp to another which does not (yet) support
+# Lisp, you could do something like this:
+# Create copies of the source tree on both host and target.
+# Create links from "target" to "x86" in "src/compiler/" and
+# in "src/assembly/", on both the host and the target. (That
+# would ordinarily be done by the make.sh code above; if we're
+# doing make.sh stuff by hand, we need to do this by hand, too.)
+# On the host system:
+# SBCL_XC_HOST=<whatever> sh make-host-1.sh
+# Copy src/runtime/sbcl.h from the host system to the target system.
+# On the target system:
+# sh make-target-1.sh
+# Copy src/runtime/sbcl.nm from the target system to the host system.
+# On the host system:
+# SBCL_XC_HOST=<whatever> sh make-host-2.sh
+# Copy output/cold-sbcl.core from the host system to the target system.
+# On the target system:
+# sh make-host-2.sh
+sh make-host-1.sh || exit 1
+sh make-target-1.sh || exit 1
+sh make-host-2.sh || exit 1
+sh make-target-2.sh || exit 1
--- /dev/null
+;;;; the specifications of SBCL-specific packages, except..
+;;;; * the creation of the trivial SB-SLOT-ACCESSOR-NAME package
+;;;; * any SHADOWing hackery
+;;;; The standard, non-SBCL-specific packages COMMON-LISP,
+;;;; COMMON-LISP-USER, and KEYWORD are also handled through other
+;;;; mechanisms.
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(#s(sb-cold:package-data
+ :name "SB!ALIEN"
+ :doc "public: the ALIEN foreign function interface"
+ :use ("CL" "SB!EXT" "SB!INT" "SB!SYS" "SB!ALIEN-INTERNALS")
+ :reexport ("ARRAY" "BOOLEAN" "DOUBLE-FLOAT" "LONG-FLOAT" "FUNCTION"
+ "INTEGER" "SINGLE-FLOAT" "UNION" "SYSTEM-AREA-POINTER"
+ "VALUES" "*")
+ :export ("ADDR" "ALIEN" "ALIEN-FUNCALL" "ALIEN-SAP"
+ "ALIEN-SIZE" "ALIEN-BOOLEAN" "CAST" "DEF-ALIEN-ROUTINE"
+ "DEF-ALIEN-TYPE" "DEF-ALIEN-VARIABLE" "DEF-BUILTIN-ALIEN-TYPE"
+ "DEREF" "ENUM" "EXTERN-ALIEN"
+ "SAP-ALIEN" "SIGNED" "SLOT" "STRUCT"
+ "UNSIGNED" "WITH-ALIEN" "FREE-ALIEN" "NULL-ALIEN"
+ "MAKE-ALIEN"
+ "LOAD-FOREIGN" "LOAD-1-FOREIGN"))
+
+ #s(sb-cold:package-data
+ :name "SB!ALIEN-INTERNALS"
+ :doc "private: stuff for implementing ALIENs and friends"
+ :use ("CL")
+ :export ("%CAST" "%DEREF-ADDR" "%HEAP-ALIEN" "%HEAP-ALIEN-ADDR"
+ "%LOCAL-ALIEN-ADDR" "%LOCAL-ALIEN-FORCED-TO-MEMORY-P" "%SAP-ALIEN"
+ "%SET-DEREF" "%SET-HEAP-ALIEN" "%SET-LOCAL-ALIEN" "%SET-SLOT"
+ "%SLOT-ADDR" "*VALUES-TYPE-OKAY*" "ALIEN-ARRAY-TYPE"
+ "ALIEN-ARRAY-TYPE-DIMENSIONS" "ALIEN-ARRAY-TYPE-ELEMENT-TYPE"
+ "ALIEN-ARRAY-TYPE-P" "ALIEN-BOOLEAN-TYPE" "ALIEN-BOOLEAN-TYPE-P"
+ "ALIEN-DOUBLE-FLOAT-TYPE" "ALIEN-DOUBLE-FLOAT-TYPE-P"
+ "ALIEN-ENUM-TYPE" "ALIEN-ENUM-TYPE-P" "ALIEN-FLOAT-TYPE"
+ "ALIEN-FLOAT-TYPE-P" "ALIEN-FUNCTION-TYPE"
+ "ALIEN-FUNCTION-TYPE-ARG-TYPES" "ALIEN-FUNCTION-TYPE-P"
+ "ALIEN-FUNCTION-TYPE-RESULT-TYPE" "ALIEN-INTEGER-TYPE"
+ "ALIEN-INTEGER-TYPE-P" "ALIEN-INTEGER-TYPE-SIGNED"
+ "ALIEN-LONG-FLOAT-TYPE" "ALIEN-LONG-FLOAT-TYPE-P"
+ "ALIEN-POINTER-TYPE" "ALIEN-POINTER-TYPE-P"
+ "ALIEN-POINTER-TYPE-TO" "ALIEN-RECORD-FIELD"
+ "ALIEN-RECORD-FIELD-NAME" "ALIEN-RECORD-FIELD-OFFSET"
+ "ALIEN-RECORD-FIELD-P" "ALIEN-RECORD-FIELD-TYPE"
+ "ALIEN-RECORD-TYPE" "ALIEN-RECORD-TYPE-FIELDS"
+ "ALIEN-RECORD-TYPE-P" "ALIEN-SINGLE-FLOAT-TYPE"
+ "ALIEN-SINGLE-FLOAT-TYPE-P" "ALIEN-SUBTYPE-P" "ALIEN-TYPE"
+ "ALIEN-TYPE-=" "ALIEN-TYPE-ALIGNMENT" "ALIEN-TYPE-BITS"
+ "ALIEN-TYPE-P" "ALIEN-TYPEP"
+ "ALIEN-VALUE" "ALIEN-VALUE-TYPE"
+ "ALIEN-VALUE-SAP" "ALIEN-VALUE-P"
+ "ALIEN-VALUES-TYPE" "ALIEN-VALUES-TYPE-P"
+ "ALIEN-VALUES-TYPE-VALUES" "ALIGN-OFFSET" "COMPUTE-ALIEN-REP-TYPE"
+ "COMPUTE-DEPORT-LAMBDA" "COMPUTE-DEPOSIT-LAMBDA"
+ "COMPUTE-EXTRACT-LAMBDA" "COMPUTE-LISP-REP-TYPE"
+ "COMPUTE-NATURALIZE-LAMBDA" "DEF-ALIEN-TYPE-CLASS"
+ "DEF-ALIEN-TYPE-METHOD" "DEF-ALIEN-TYPE-TRANSLATOR" "DEPORT"
+ "DEPOSIT-ALIEN-VALUE" "DISPOSE-LOCAL-ALIEN" "EXTRACT-ALIEN-VALUE"
+ "HEAP-ALIEN-INFO" "HEAP-ALIEN-INFO-P" "HEAP-ALIEN-INFO-SAP-FORM"
+ "HEAP-ALIEN-INFO-TYPE" "INVOKE-ALIEN-TYPE-METHOD" "LOCAL-ALIEN"
+ "LOCAL-ALIEN-INFO" "LOCAL-ALIEN-INFO-FORCE-TO-MEMORY-P"
+ "LOCAL-ALIEN-INFO-P" "LOCAL-ALIEN-INFO-TYPE"
+ "MAKE-ALIEN-FUNCTION-TYPE" "MAKE-ALIEN-POINTER-TYPE"
+ "MAKE-ALIEN-VALUE"
+ "MAKE-LOCAL-ALIEN" "NATURALIZE" "NOTE-LOCAL-ALIEN-TYPE"
+ "PARSE-ALIEN-TYPE" "UNPARSE-ALIEN-TYPE"))
+
+ #s(sb-cold:package-data
+ :name "SB!ASSEM"
+ :doc "private: the assembler, used by the compiler"
+ :use ("CL")
+ :export ("ASSEMBLY-UNIT"
+
+ "*ASSEM-SCHEDULER-P*"
+ "*ASSEM-INSTRUCTIONS*"
+ "*ASSEM-MAX-LOCATIONS*"
+
+ "EMIT-BYTE" "EMIT-SKIP" "EMIT-BACK-PATCH"
+ "EMIT-CHOOSER" "DEFINE-BITFIELD-EMITTER"
+ "DEFINE-INSTRUCTION" "DEFINE-INSTRUCTION-MACRO"
+ "DEF-ASSEMBLER-PARAMS" "EMIT-POSTIT"
+
+ "MAKE-SEGMENT" "SEGMENT-NAME" "ASSEMBLE"
+ "ALIGN" "INST" "LABEL" "LABEL-P" "GEN-LABEL"
+ "EMIT-LABEL" "LABEL-POSITION" "APPEND-SEGMENT" "FINALIZE-SEGMENT"
+ "ON-SEGMENT-CONTENTS-VECTORLY" "WRITE-SEGMENT-CONTENTS"
+ "READS" "WRITES" "SEGMENT"
+ "WITHOUT-SCHEDULING"
+ "VARIABLE-LENGTH"
+ "SEGMENT-COLLECT-DYNAMIC-STATISTICS"
+
+ ;; In classic CMU CL, these symbols were explicitly imported by
+ ;; package C. Since package C uses package ASSEM (and no
+ ;; other package does) it seems cleaner to export these symbols
+ ;; from package ASSEM instead. I hope nothing breaks..
+ ;; -- WHN 19990220
+ "BRANCH" "DO-SSET-ELEMENTS" "FLUSHABLE" "MAKE-SSET" "SSET"
+ "SSET-ADJOIN" "SSET-DELETE" "SSET-ELEMENT" "SSET-EMPTY"))
+
+ #s(sb-cold:package-data
+ :name "SB!BIGNUM"
+ :doc "private: bignum implementation"
+ :use ("CL" "SB!KERNEL" "SB!INT" "SB!EXT")
+ :export ("%ADD-WITH-CARRY" "%ALLOCATE-BIGNUM" "%ASHL" "%ASHR"
+ "%BIGNUM-LENGTH" "%BIGNUM-REF" "%BIGNUM-SET"
+ "%BIGNUM-SET-LENGTH" "%DIGIT-0-OR-PLUSP"
+ "%DIGIT-LOGICAL-SHIFT-RIGHT"
+ "%FIXNUM-DIGIT-WITH-CORRECT-SIGN" "%FIXNUM-TO-DIGIT"
+ "%FLOOR" "%LOGAND" "%LOGIOR" "%LOGNOT" "%LOGXOR"
+ "%MULTIPLY" "%MULTIPLY-AND-ADD"
+ "%SUBTRACT-WITH-BORROW" "ADD-BIGNUMS"
+ "BIGNUM-ASHIFT-LEFT" "BIGNUM-ASHIFT-RIGHT"
+ "BIGNUM-COMPARE" "BIGNUM-DEPOSIT-BYTE"
+ "BIGNUM-ELEMENT-TYPE" "BIGNUM-GCD" "BIGNUM-INDEX"
+ "BIGNUM-INTEGER-LENGTH" "BIGNUM-LOAD-BYTE"
+ "BIGNUM-LOGCOUNT" "BIGNUM-LOGICAL-AND"
+ "BIGNUM-LOGICAL-IOR" "BIGNUM-LOGICAL-NOT"
+ "BIGNUM-LOGICAL-XOR" "BIGNUM-PLUS-P"
+ "BIGNUM-TO-FLOAT" "BIGNUM-TRUNCATE" "BIGNUM-TYPE"
+ "FLOAT-BIGNUM-RATIO" "MAKE-SMALL-BIGNUM"
+ "MULTIPLY-BIGNUM-AND-FIXNUM" "MULTIPLY-BIGNUMS"
+ "MULTIPLY-FIXNUMS" "NEGATE-BIGNUM"
+ "SUBTRACT-BIGNUM" "SXHASH-BIGNUM"))
+
+ #s(sb-cold:package-data
+ :name "SB!C"
+ :doc "private: implementation of the compiler"
+ :use ("CL" "SB!ALIEN-INTERNALS" "SB!ALIEN" "SB!BIGNUM"
+ #!+sb-dyncount "SB-DYNCOUNT"
+ "SB!EXT" "SB!INT" "SB!KERNEL" "SB!ASSEM" "SB!SYS")
+ :reexport ("SLOT" "CODE-INSTRUCTIONS" "FLUSHABLE")
+ :export ("%ALIEN-FUNCALL" "%CATCH-BREAKUP" "%CONTINUE-UNWIND" "&MORE"
+ "%LISTIFY-REST-ARGS" "%MORE-ARG" "%MORE-ARG-VALUES"
+ "%UNWIND-PROTECT-BREAKUP"
+
+ "*BACKEND-BYTE-ORDER*" "*BACKEND-DISASSEM-PARAMS*"
+ "*BACKEND-FASL-FILE-IMPLEMENTATION*"
+ "*BACKEND-FASL-FILE-TYPE*" "*BACKEND-FASL-FILE-VERSION*"
+ "*BACKEND-INFO-ENVIRONMENT*"
+ "*BACKEND-INSTRUCTION-FLAVORS*" "*BACKEND-INSTRUCTION-FORMATS*"
+ "*BACKEND-INTERNAL-ERRORS*" "*BACKEND-PAGE-SIZE*"
+ "*BACKEND-REGISTER-SAVE-PENALTY*"
+ "*BACKEND-SB-LIST*" "*BACKEND-SB-NAMES*"
+ "*BACKEND-SC-NAMES*" "*BACKEND-SC-NUMBERS*"
+ "*BACKEND-SPECIAL-ARG-TYPES*"
+ "*BACKEND-T-PRIMITIVE-TYPE*"
+
+ "*CODE-SEGMENT*"
+ "*COMPILE-TIME-DEFINE-MACROS*"
+ "*COMPILING-FOR-INTERPRETER*" "*CONVERTING-FOR-INTERPRETER*"
+ "*COUNT-VOP-USAGES*" "*ELSEWHERE*"
+ "*FASL-HEADER-STRING-START-STRING*"
+ "*FASL-HEADER-STRING-STOP-CHAR-CODE*"
+ "*SETF-ASSUMED-FBOUNDP*"
+ "*SUPPRESS-VALUES-DECLARATION*"
+
+ "ALLOC-ALIEN-STACK-SPACE" "ALLOC-NUMBER-STACK-SPACE"
+ "ALLOCATE-CODE-OBJECT" "ALLOCATE-FRAME"
+ "ALLOCATE-DYNAMIC-CODE-OBJECT" "ALLOCATE-FULL-CALL-FRAME"
+ "ANY" "ARGUMENT-COUNT-ERROR" "ASSEMBLE-FILE"
+ "ATTRIBUTES" "ATTRIBUTES-INTERSECTION" "ATTRIBUTES-UNION"
+ "ATTRIBUTES=" "BIND"
+ "BYTE-BLT" ; doesn't logically belong here, but is name of VOP..
+ "CALL" "CALL-LOCAL" "CALL-NAMED" "CALL-OUT" "CALL-VARIABLE"
+ "CALLEE-NFP-TN" "CALLEE-RETURN-PC-TN"
+ "CASE-BODY" "CATCH-BLOCK" "CHECK-CONS"
+ "CHECK-FIXNUM" "CHECK-FUNCTION" "CHECK-FUNCTION-OR-SYMBOL"
+ "CHECK-SIGNED-BYTE-32" "CHECK-SYMBOL" "CHECK-UNSIGNED-BYTE-32"
+ "CLOSURE-INIT" "CLOSURE-REF"
+ "CODE-CONSTANT-REF" "CODE-CONSTANT-SET"
+ "COMPILE-FOR-EVAL" "COMPONENT" "COMPONENT-HEADER-LENGTH"
+ "COMPONENT-INFO" "COMPONENT-LIVE-TN" "COMPUTE-FUNCTION"
+ "COMPUTE-OLD-NFP" "COPY-MORE-ARG"
+ "CURRENT-BINDING-POINTER" "CURRENT-NFP-TN"
+ "CURRENT-STACK-POINTER" "DEALLOC-ALIEN-STACK-SPACE"
+ "DEALLOC-NUMBER-STACK-SPACE" "DEF-BOOLEAN-ATTRIBUTE"
+ "DEF-IR1-TRANSLATOR" "DEF-PRIMITIVE-TRANSLATOR"
+ "DEF-PRIMITIVE-TYPE" "DEF-PRIMITIVE-TYPE-ALIAS"
+ "DEF-SOURCE-TRANSFORM" "DEF-VM-SUPPORT-ROUTINE"
+ "DEFINE-ASSEMBLY-ROUTINE" "DEFINE-MOVE-FUNCTION"
+ "DEFINE-MOVE-VOP" "DEFINE-STORAGE-BASE"
+ "DEFINE-STORAGE-CLASS" "DEFINE-VOP"
+ "DEFKNOWN" "DEFOPTIMIZER"
+ "DEFTRANSFORM" "DERIVE-TYPE"
+ "ENTRY-NODE-INFO-NLX-TAG" "ENTRY-NODE-INFO-ST-TOP"
+ "ENVIRONMENT-DEBUG-LIVE-TN" "ENVIRONMENT-LIVE-TN"
+ "FAST-SYMBOL-FUNCTION" "FAST-SYMBOL-VALUE" "FOLDABLE"
+ "FORCE-TN-TO-STACK" "GET-VECTOR-SUBTYPE"
+ "HALT" "IF-EQ" "INSTANCE-REF" "INSTANCE-SET"
+ "IR2-COMPONENT-CONSTANTS" "IR2-CONVERT"
+ "IR2-ENVIRONMENT-NUMBER-STACK-P" "KNOWN-CALL-LOCAL"
+ "KNOWN-RETURN" "LAMBDA-EVAL-INFO-ARGS-PASSED"
+ "LAMBDA-EVAL-INFO-ENTRIES" "LAMBDA-EVAL-INFO-FRAME-SIZE"
+ "LAMBDA-EVAL-INFO-FUNCTION" "LOCATION=" "LTN-ANNOTATE"
+ "MAKE-ALIAS-TN" "MAKE-CATCH-BLOCK"
+ "MAKE-CLOSURE" "MAKE-CONSTANT-TN" "MAKE-FIXNUM"
+ "MAKE-LOAD-TIME-CONSTANT-TN" "MAKE-N-TNS" "MAKE-NORMAL-TN"
+ "MAKE-OTHER-IMMEDIATE-TYPE" "MAKE-RANDOM-TN"
+ "MAKE-REPRESENTATION-TN" "MAKE-RESTRICTED-TN" "MAKE-SC-OFFSET"
+ "MAKE-STACK-POINTER-TN" "MAKE-TN-REF" "MAKE-UNWIND-BLOCK"
+ "MAKE-VALUE-CELL" "MAKE-WIRED-TN" "META-PRIMITIVE-TYPE-OR-LOSE"
+ "META-SB-OR-LOSE" "META-SC-NUMBER-OR-LOSE" "META-SC-OR-LOSE"
+ "MORE-ARG-CONTEXT" "MOVABLE" "MOVE" "MULTIPLE-CALL"
+ "MULTIPLE-CALL-LOCAL" "MULTIPLE-CALL-NAMED"
+ "MULTIPLE-CALL-VARIABLE" "NLX-ENTRY" "NLX-ENTRY-MULTIPLE"
+ "NON-DESCRIPTOR-STACK" "NOTE-ENVIRONMENT-START"
+ "NOTE-THIS-LOCATION" "OPTIMIZER" "PACK-TRACE-TABLE"
+ "POLICY" "PREDICATE" "PRIMITIVE-TYPE" "PRIMITIVE-TYPE-OF"
+ "PRIMITIVE-TYPE-OR-LOSE" "PRIMITIVE-TYPE-VOP"
+ "PRIMITIVE-TYPE-NAME" "PUSH-VALUES"
+ "READ-PACKED-BIT-VECTOR" "READ-VAR-INTEGER" "READ-VAR-STRING"
+ "RESET-STACK-POINTER" "RESTORE-DYNAMIC-STATE"
+ "RETURN-MULTIPLE" "SAVE-DYNAMIC-STATE" "SB"
+ "SB-ALLOCATED-SIZE" "SB-NAME" "SB-OR-LOSE" "SB-P" "SC" "SC-CASE"
+ "SC-IS" "SC-NAME" "SC-NUMBER" "SC-NUMBER-OR-LOSE"
+ "SC-OFFSET-OFFSET" "SC-OFFSET-SCN" "SC-OR-LOSE" "SC-P" "SC-SB"
+ "SET-UNWIND-PROTECT" "SET-VECTOR-SUBTYPE"
+ "SETUP-CLOSURE-ENVIRONMENT" "SETUP-ENVIRONMENT"
+ "SPECIFY-SAVE-TN" "INSTANCE-REF"
+ "INSTANCE-SET" "TAIL-CALL" "TAIL-CALL-NAMED"
+ "TAIL-CALL-VARIABLE" "TEMPLATE-OR-LOSE"
+ "TN" "TN-OFFSET" "TN-P" "TN-REF" "TN-REF-ACROSS" "TN-REF-LOAD-TN"
+ "TN-REF-NEXT" "TN-REF-NEXT-REF" "TN-REF-P" "TN-REF-TARGET"
+ "TN-REF-TN" "TN-REF-VOP" "TN-REF-WRITE-P" "TN-SC" "TN-VALUE"
+ "TRACE-TABLE-ENTRY" "TYPE-CHECK-ERROR" "UNBIND" "UNBIND-TO-HERE"
+ "UNSAFE" "UNWIND" "UWP-ENTRY"
+ "VALUE-CELL-REF" "VALUE-CELL-SET"
+ "VERIFY-ARGUMENT-COUNT" "WRITE-PACKED-BIT-VECTOR"
+ "WRITE-VAR-INTEGER" "WRITE-VAR-STRING" "XEP-ALLOCATE-FRAME"
+ "LABEL-ID" "FIXUP" "FIXUP-FLAVOR" "FIXUP-NAME" "FIXUP-OFFSET"
+ "FIXUP-P" "MAKE-FIXUP"
+ "DEF-ALLOC"
+ "VAR-ALLOC"
+ "SAFE-FDEFN-FUNCTION"
+ "NOTE-FIXUP"
+ "DEF-REFFER"
+ "EMIT-NOP"
+ "DEF-SETTER"
+ "FIXED-ALLOC"
+ "MAKE-UNBOUND-MARKER"
+ "RETURN-SINGLE"
+ "NOTE-NEXT-INSTRUCTION"
+ "SET-SLOT"
+ "LOCATION-NUMBER"
+ "BYTE-FASL-FILE-VERSION"
+ "*COMPONENT-BEING-COMPILED*"
+ "BLOCK-NUMBER"
+ "BACKEND"
+ "BACKEND-BYTE-FASL-FILE-IMPLEMENTATION"
+ "BACKEND-BYTE-FASL-FILE-TYPE"
+ "IR2-BLOCK-BLOCK"
+ "DISASSEM-BYTE-COMPONENT"
+ "FUNCALLABLE-INSTANCE-LEXENV"
+ "DISASSEM-BYTE-FUN"
+ "VOP-BLOCK"
+ "*ASSEMBLY-OPTIMIZE*"
+ "LARGE-ALLOC"
+ "%SET-FUNCTION-SELF"
+ "VM-SUPPORT-ROUTINES-IMMEDIATE-CONSTANT-SC"
+ "VM-SUPPORT-ROUTINES-LOCATION-PRINT-NAME"
+ "VM-SUPPORT-ROUTINES-PRIMITIVE-TYPE-OF"
+ "VM-SUPPORT-ROUTINES-PRIMITIVE-TYPE"
+ "VM-SUPPORT-ROUTINES-MAKE-CALL-OUT-TNS"
+ "VM-SUPPORT-ROUTINES-STANDARD-ARGUMENT-LOCATION"
+ "VM-SUPPORT-ROUTINES-MAKE-RETURN-PC-PASSING-LOCATION"
+ "VM-SUPPORT-ROUTINES-MAKE-OLD-FP-PASSING-LOCATION"
+ "VM-SUPPORT-ROUTINES-MAKE-OLD-FP-SAVE-LOCATION"
+ "VM-SUPPORT-ROUTINES-MAKE-RETURN-PC-SAVE-LOCATION"
+ "VM-SUPPORT-ROUTINES-MAKE-ARGUMENT-COUNT-LOCATION"
+ "VM-SUPPORT-ROUTINES-MAKE-NFP-TN"
+ "VM-SUPPORT-ROUTINES-MAKE-STACK-POINTER-TN"
+ "VM-SUPPORT-ROUTINES-MAKE-NUMBER-STACK-POINTER-TN"
+ "VM-SUPPORT-ROUTINES-MAKE-UNKNOWN-VALUES-LOCATIONS"
+ "VM-SUPPORT-ROUTINES-SELECT-COMPONENT-FORMAT"
+ "VM-SUPPORT-ROUTINES-MAKE-NLX-SP-TN"
+ "VM-SUPPORT-ROUTINES-MAKE-DYNAMIC-STATE-TNS"
+ "VM-SUPPORT-ROUTINES-MAKE-NLX-ENTRY-ARGUMENT-START-LOCATION"
+ "VM-SUPPORT-ROUTINES-GENERATE-CALL-SEQUENCE"
+ "VM-SUPPORT-ROUTINES-GENERATE-RETURN-SEQUENCE"
+ "VM-SUPPORT-ROUTINES-EMIT-NOP"
+ "VM-SUPPORT-ROUTINES-LOCATION-NUMBER"))
+
+ #s(sb-cold:package-data
+ :name "SB!C-CALL"
+ ;; FIXME: Why not just put this stuff into SB-ALIEN? Or maybe
+ ;; just glom this and SB-ALIEN together into SB-FFI?
+ :doc "public: some types used with ALIENs"
+ :use ("CL" "SB!SYS" "SB!ALIEN-INTERNALS" "SB!ALIEN")
+ :reexport ("FLOAT" "CHAR")
+ :export ("C-STRING" "DOUBLE" "INT" "LONG"
+ "SHORT" "UNSIGNED-CHAR" "UNSIGNED-INT"
+ "UNSIGNED-LONG" "UNSIGNED-SHORT" "VOID"))
+
+ #!+sb-dyncount
+ #s(sb-cold:package-data
+ :name "SB!DYNCOUNT"
+ :doc "private: some somewhat-stale code for collecting runtime statistics"
+ :use ("CL" "SB!ALIEN-INTERNALS" "SB!ALIEN" "SB!BIGNUM"
+ "SB!EXT" "SB!INT" "SB!KERNEL" "SB!ASSEM" "SB!SYS")
+ :export ("*COLLECT-DYNAMIC-STATISTICS*" "COUNT-ME"
+ "DYNCOUNT-INFO-COUNTS" "DYNCOUNT-INFO-COSTS"
+ "IR2-COMPONENT-DYNCOUNT-INFO"
+ "DYNCOUNT-INFO" "DYNCOUNT-INFO-P"))
+
+ ;; This package is a grab bag for things which used to be internal
+ ;; symbols in package COMMON-LISP. Lots of these symbols are accessed
+ ;; with explicit SB!IMPL:: prefixes in the code. It would be nice to
+ ;; reduce the use of this practice, so if symbols from here which are
+ ;; accessed that way are found to belong more appropriately in
+ ;; an existing package (e.g. KERNEL or SYS or EXT) or a new package
+ ;; (e.g. something to collect together all the FOP stuff), I
+ ;; (WHN 19990223) encourage maintainers to move them there..
+ ;;
+ ;; ..except that it's getting so big and crowded that maybe it
+ ;; should be split up, too.
+ #s(sb-cold:package-data
+ :name "SB!IMPL"
+ :doc "private: a grab bag of implementation details"
+ :use ("CL" "SB!EXT" "SB!INT" "SB!SYS" "SB!DEBUG" "SB!KERNEL" "SB!BIGNUM"))
+
+ ;; FIXME: It seems to me that this could go away, with its contents moved
+ ;; into SB!KERNEL, like the implementation of the rest of the class system.
+ #s(sb-cold:package-data
+ :name "SB!CONDITIONS"
+ :doc "private: the implementation of the condition system"
+ :use ("CL" "SB!EXT" "SB!INT" "SB!KERNEL"))
+
+ #s(sb-cold:package-data
+ :name "SB!DEBUG"
+ :doc
+"public: (eventually) the debugger interface (but currently) the
+debugger interface mixed with various low-level implementation stuff
+like *STACK-TOP-HINT*"
+ :use ("CL" "SB!EXT" "SB!INT" "SB!SYS")
+ :export ("*AUTO-EVAL-IN-FRAME*" "*DEBUG-CONDITION*"
+ "*DEBUG-PRINT-LENGTH*" "*DEBUG-PRINT-LEVEL*" "*DEBUG-READTABLE*"
+ "*DEBUG-PROMPT*" "*DEBUG-HELP-STRING*" "*FLUSH-DEBUG-ERRORS*"
+ "*IN-THE-DEBUGGER*"
+ "*TRACE-INDENTATION-STEP*" "*MAX-TRACE-INDENTATION*"
+ "*TRACE-FRAME*" "*TRACE-PRINT-LENGTH*"
+ "*TRACE-PRINT-LEVEL*" "*TRACED-FUNCTION-LIST*"
+ "ARG" "BACKTRACE" "INTERNAL-DEBUG" "VAR"
+ "*PRINT-LOCATION-KIND*"
+ "*ONLY-BLOCK-START-LOCATIONS*" "*STACK-TOP-HINT*"
+ "*TRACE-VALUES*" "DO-DEBUG-COMMAND"
+ "*TRACE-ENCAPSULATE-DEFAULT*"))
+
+ #s(sb-cold:package-data
+ :name "SB!DI"
+ :doc "private: primitives used to write debuggers"
+ :use ("CL" "SB!EXT" "SB!INT" "SB!KERNEL" "SB!SYS")
+ :import-from (("SB!C"
+ "DEBUG-SOURCE-FROM" "DEBUG-SOURCE-NAME"
+ "DEBUG-SOURCE-CREATED" "DEBUG-SOURCE-COMPILED"
+ "DEBUG-SOURCE-START-POSITIONS" "MAKE-DEBUG-SOURCE"
+ "DEBUG-SOURCE" "DEBUG-SOURCE-P"))
+ :reexport ("DEBUG-SOURCE-FROM" "DEBUG-SOURCE-NAME"
+ "DEBUG-SOURCE-CREATED" "DEBUG-SOURCE-COMPILED"
+ "DEBUG-SOURCE-START-POSITIONS" "DEBUG-SOURCE"
+ "DEBUG-SOURCE-P")
+ :export ("*DEBUGGING-INTERPRETER*" "ACTIVATE-BREAKPOINT"
+ "AMBIGUOUS-DEBUG-VARS" "AMBIGUOUS-VARIABLE-NAME" "BREAKPOINT"
+ "BREAKPOINT-ACTIVE-P" "BREAKPOINT-HOOK-FUNCTION" "BREAKPOINT-INFO"
+ "BREAKPOINT-KIND" "BREAKPOINT-P" "BREAKPOINT-WHAT" "CODE-LOCATION"
+ "CODE-LOCATION-DEBUG-BLOCK" "CODE-LOCATION-DEBUG-FUNCTION"
+ "CODE-LOCATION-DEBUG-SOURCE" "CODE-LOCATION-FORM-NUMBER"
+ "CODE-LOCATION-P" "CODE-LOCATION-TOP-LEVEL-FORM-OFFSET"
+ "CODE-LOCATION-UNKNOWN-P" "CODE-LOCATION=" "DEACTIVATE-BREAKPOINT"
+ "DEBUG-BLOCK" "DEBUG-BLOCK-ELSEWHERE-P" "DEBUG-BLOCK-P"
+ "DEBUG-BLOCK-SUCCESSORS" "DEBUG-CONDITION" "DEBUG-ERROR"
+ "DEBUG-FUNCTION" "DEBUG-FUNCTION-FUNCTION" "DEBUG-FUNCTION-KIND"
+ "DEBUG-FUNCTION-LAMBDA-LIST" "DEBUG-FUNCTION-NAME"
+ "DEBUG-FUNCTION-P" "DEBUG-FUNCTION-START-LOCATION"
+ "DEBUG-FUNCTION-SYMBOL-VARIABLES"
+ "DEBUG-SOURCE-ROOT-NUMBER" "DEBUG-VAR"
+ "DEBUG-VAR-ID" "DEBUG-VAR-INFO-AVAILABLE"
+ "DEBUG-VAR-SYMBOL-NAME" "DEBUG-VAR-P" "DEBUG-VAR-PACKAGE-NAME"
+ "DEBUG-VAR-SYMBOL" "DEBUG-VAR-VALID-VALUE"
+ "DEBUG-VAR-VALIDITY" "DEBUG-VAR-VALUE"
+ "DELETE-BREAKPOINT" "DO-BLOCKS"
+ "DO-DEBUG-BLOCK-LOCATIONS" "DO-DEBUG-FUNCTION-BLOCKS"
+ "DO-DEBUG-FUNCTION-VARIABLES" "EVAL-IN-FRAME"
+ "FORM-NUMBER-TRANSLATIONS" "FRAME" "FRAME-CATCHES"
+ "FRAME-CODE-LOCATION" "FRAME-DEBUG-FUNCTION" "FRAME-DOWN"
+ "FRAME-FUNCTION-MISMATCH" "FRAME-NUMBER" "FRAME-P" "FRAME-UP"
+ "FUNCTION-DEBUG-FUNCTION" "FUNCTION-END-COOKIE-VALID-P"
+ "INVALID-CONTROL-STACK-POINTER" "INVALID-VALUE"
+ "LAMBDA-LIST-UNAVAILABLE" "MAKE-BREAKPOINT" "NO-DEBUG-BLOCKS"
+ "NO-DEBUG-FUNCTION-RETURNS" "NO-DEBUG-INFO" "PREPROCESS-FOR-EVAL"
+ "RETURN-FROM-FRAME" "SOURCE-PATH-CONTEXT"
+ "TOP-FRAME" "UNHANDLED-CONDITION" "UNKNOWN-CODE-LOCATION"
+ "UNKNOWN-CODE-LOCATION-P" "UNKNOWN-DEBUG-VAR"
+ "CODE-LOCATION-KIND" "FLUSH-FRAMES-ABOVE"))
+
+ #s(sb-cold:package-data
+ :name "SB!DISASSEM"
+ :doc "private: stuff related to the implementation of the disassembler"
+ :use ("CL" "SB!EXT" "SB!INT")
+ :export ("*DISASSEM-INST-ALIGNMENT-BYTES*"
+ "*DISASSEM-NOTE-COLUMN*" "*DISASSEM-OPCODE-COLUMN-WIDTH*"
+ "*DISASSEM-SCHEDULER-P*" "*DISASSEM-LOCATION-COLUMN-WIDTH*"
+ "ADD-COMMENT-HOOK" "ADD-HOOK" "ADD-NOTE-HOOK"
+ "ARG-VALUE" "CREATE-DSTATE" "DISASSEM-STATE"
+ "DISASSEMBLE-CODE-COMPONENT"
+ "DISASSEMBLE-FUNCTION" "DISASSEMBLE-MEMORY"
+ "DISASSEMBLE-SEGMENT" "DISASSEMBLE-SEGMENTS"
+ "DSTATE-CODE" "DSTATE-CURPOS" "DSTATE-GET-PROP"
+ "DSTATE-NEXTPOS" "DSTATE-SEGMENT-LENGTH"
+ "DSTATE-SEGMENT-SAP" "DSTATE-SEGMENT-START"
+ "FIELD-TYPE" "FIND-INST" "GEN-FIELD-TYPE-DECL-FORM"
+ "GEN-INST-DECL-FORM" "GEN-INST-FORMAT-DECL-FORM"
+ "GET-CODE-SEGMENTS" "GET-FUNCTION-SEGMENTS"
+ "GET-INST-SPACE" "HANDLE-BREAK-ARGS"
+ "INST" "INST-FORMAT" "LABEL-SEGMENTS"
+ "MAYBE-NOTE-ASSEMBLER-ROUTINE"
+ "MAYBE-NOTE-ASSOCIATED-STORAGE-REF"
+ "MAYBE-NOTE-NIL-INDEXED-OBJECT"
+ "MAYBE-NOTE-NIL-INDEXED-SYMBOL-SLOT-REF"
+ "MAYBE-NOTE-SINGLE-STORAGE-REF" "NOTE"
+ "NOTE-CODE-CONSTANT" "PARAMS" "PRIN1-QUOTED-SHORT"
+ "PRIN1-SHORT" "PRINT-BYTES"
+ "PRINT-CURRENT-ADDRESS" "PRINT-FIELD" "PRINT-INST"
+ "PRINT-INST-USING" "PRINT-NOTES-AND-NEWLINE"
+ "PRINT-WORDS" "SAP-REF-DCHUNK" "SEG-DEBUG-FUNCTION"
+ "SEG-LENGTH" "SEG-START" "SEGMENT"
+ "SET-ADDRESS-PRINTING-RANGE" "SET-DISASSEM-PARAMS"
+ "SET-DSTATE-SEGMENT" "SIGN-EXTEND" "SPECIALIZE"
+ "GEN-PRINTER-DEF-FORMS-DEF-FORM" "MAKE-DSTATE"
+ "DEFINE-ARGUMENT-TYPE" "GEN-ARG-TYPE-DEF-FORM"
+ "READ-SIGNED-SUFFIX" "ADD-OFFS-HOOK"
+ "MAKE-MEMORY-SEGMENT" "GEN-PREAMBLE-FORM"
+ "MAKE-SEGMENT" "SEGMENT-OVERFLOW"
+ "SEG-VIRTUAL-LOCATION" "MAKE-DECODED-INST"
+ "DCHUNK" "*DEFAULT-DSTATE-HOOKS*"
+ "MAKE-CODE-SEGMENT" "MAKE-OFFS-HOOK"
+ "DSTATE-SEGMENT" "DSTATE-CUR-OFFS"
+ "PRINC16" "INSTRUCTION" "DEFINE-INSTRUCTION-FORMAT"
+ "DSTATE-NEXT-OFFS" "INSTALL-INST-FLAVORS"
+ "SEG-SAP-MAKER" "DISASSEMBLE-ASSEM-SEGMENT"
+ "GEN-CLEAR-INFO-FORM" "READ-SUFFIX"
+ "MAP-SEGMENT-INSTRUCTIONS" "GEN-FORMAT-DEF-FORM"
+ "SET-LOCATION-PRINTING-RANGE" "MAKE-VECTOR-SEGMENT"
+ "ADD-OFFS-NOTE-HOOK" "ADD-OFFS-COMMENT-HOOK"
+ "DSTATE-CUR-ADDR" "DSTATE-NEXT-ADDR"))
+
+ #!+sb-interpreter
+ #s(sb-cold:package-data
+ :name "SB!EVAL"
+ :doc "private: the implementation of the IR1 interpreter"
+ :use ("CL" "SB!KERNEL" "SB!INT")
+ :export ("*EVAL-STACK-TRACE*" "*INTERNAL-APPLY-NODE-TRACE*"
+ "FLUSH-INTERPRETED-FUNCTION-CACHE" "INTERNAL-EVAL"
+ "INTERPRETED-FUNCTION"
+ "INTERPRETED-FUNCTION-ARGLIST"
+ "INTERPRETED-FUNCTION-CLOSURE"
+ "INTERPRETED-FUNCTION-LAMBDA-EXPRESSION"
+ "INTERPRETED-FUNCTION-NAME"
+ "INTERPRETED-FUNCTION-P"
+ "INTERPRETED-FUNCTION-TYPE"
+ "MAKE-INTERPRETED-FUNCTION"
+ "PRINT-INTERPRETED-FUNCTION-OBJECT"
+ "TRACE-EVAL"))
+
+ #s(sb-cold:package-data
+ :name "SB!EXT"
+ :doc "public: miscellaneous supported extensions to the ANSI Lisp spec"
+ ;; FIXME: Why don't we just USE-PACKAGE %KERNEL here instead of importing?
+ :use ("CL" "SB!ALIEN" "SB!C-CALL" "SB!INT" "SB!SYS")
+ ;; FIXME: If we advertise these as extensions, they should be in the
+ ;; SB!EXT package (and perhaps re-exported from the %KERNEL
+ ;; package) rather than in some other package and reexported from
+ ;; SB!EXT.
+ :import-from (("SB!KERNEL" "WEAK-POINTER-P"))
+ :reexport ("LOAD-FOREIGN" "LOAD-1-FOREIGN" "WEAK-POINTER-P")
+ :export (;; Information about how the program was invoked is
+ ;; nonstandard but very useful.
+ "*POSIX-ARGV*" "POSIX-GETENV"
+
+ ;; People have various good reasons to mess with the GC.
+ "*AFTER-GC-HOOKS*" "*BEFORE-GC-HOOKS*"
+ "*GC-NOTIFY-AFTER*" "*GC-NOTIFY-BEFORE*" "*GC-NOTIFY-STREAM*"
+ "*GC-VERBOSE*"
+ "BYTES-CONSED-BETWEEN-GCS"
+ "GC" "GC-OFF" "GC-ON" "GET-BYTES-CONSED"
+ "*GC-RUN-TIME*"
+ "PURIFY"
+
+ ;; There is no one right way to report progress on
+ ;; hairy compiles.
+ "*COMPILE-PROGRESS*"
+
+ ;; There is no one right way to do DESCRIBE.
+ "*DESCRIBE-INDENTATION-STEP*"
+
+ ;; There is no one right way to do efficiency notes.
+ "*EFFICIENCY-NOTE-COST-THRESHOLD*" "*EFFICIENCY-NOTE-LIMIT*"
+
+ ;; There's no one right way to report errors.
+ "*ENCLOSING-SOURCE-CUTOFF*"
+ "*UNDEFINED-WARNING-LIMIT*"
+
+ ;; and for dedicated users who really want to customize
+ ;; error reporting, we have
+ "DEF-SOURCE-CONTEXT"
+
+ ;; FIXME: These seem like the right thing, but are they
+ ;; consistent with ANSI? (And actually maybe they're not
+ ;; quite the right thing; it might be better to also do
+ ;; WITH-STANDARD-IO-SYNTAX or something.)
+ "*ERROR-PRINT-LENGTH*" "*ERROR-PRINT-LEVEL*" "*ERROR-PRINT-LINES*"
+
+ ;; KLUDGE: CMU CL had
+ ;; "*IGNORE-FLOATING-POINT-UNDERFLOW*", which seemed
+ ;; like a reasonable idea but doesn't seem to be supported
+ ;; now? -- WHN 19991206
+
+ ;; extended declarations..
+ "CONSTANT-FUNCTION" "END-BLOCK" "FREEZE-TYPE"
+ "INHIBIT-WARNINGS"
+ "MAYBE-INLINE" "OPTIMIZE-INTERFACE" "START-BLOCK"
+
+ ;; ..and variables to control compiler policy
+ "*INLINE-EXPANSION-LIMIT*"
+ "*USE-IMPLEMENTATION-TYPES*"
+ "*BYTE-COMPILE-TOP-LEVEL*"
+ "*BYTE-COMPILE-DEFAULT*"
+ "*DERIVE-FUNCTION-TYPES*" ; FIXME FIXME FIXME FIXME..
+
+ ;; a special form for breaking out of our "declarations
+ ;; are assertions" default
+ "TRULY-THE"
+
+ ;; This is something which must exist inside any Common Lisp
+ ;; implementation, and which someone writing a customized toplevel
+ ;; might well want. It seems perverse to hide it from
+ ;; them..
+ "INTERACTIVE-EVAL"
+
+ ;; weak pointers and finalization
+ "FINALIZE" "CANCEL-FINALIZATION"
+ ;; FIXME: "WEAK-POINTER-P" here once it moves from %KERNEL
+ "HASH-TABLE-WEAK-P" "MAKE-WEAK-POINTER"
+ "WEAK-POINTER" "WEAK-POINTER-VALUE"
+
+ ;; If the user knows we're doing IEEE, he might reasonably
+ ;; want to do this stuff.
+ "FLOAT-DENORMALIZED-P"
+ "FLOAT-NAN-P" "FLOAT-TRAPPING-NAN-P"
+ "FLOATING-POINT-INVALID"
+ "FLOAT-INFINITY-P"
+ #!+sb-infinities "SHORT-FLOAT-NEGATIVE-INFINITY"
+ #!+sb-infinities "SHORT-FLOAT-POSITIVE-INFINITY"
+ #!+sb-infinities "SINGLE-FLOAT-NEGATIVE-INFINITY"
+ #!+sb-infinities "SINGLE-FLOAT-POSITIVE-INFINITY"
+ #!+sb-infinities "DOUBLE-FLOAT-NEGATIVE-INFINITY"
+ #!+sb-infinities "DOUBLE-FLOAT-POSITIVE-INFINITY"
+ #!+sb-infinities "LONG-FLOAT-NEGATIVE-INFINITY"
+ #!+sb-infinities "LONG-FLOAT-POSITIVE-INFINITY"
+
+ ;; hacks to work around system limitations
+ "*INTEXP-MAXIMUM-EXPONENT*" ; since we crash hard when
+ ; memory is exhausted
+
+ ;; saving Lisp images
+ "SAVE-LISP-AND-DIE"
+
+ ;; miscellaneous useful supported extensions
+ "QUIT"
+
+ ;; running a Unix program from Lisp, not quite working
+ ;; in sbcl-0.6.6, but maybe soon..
+ "RUN-PROGRAM"))
+
+ #s(sb-cold:package-data
+ :name "SB!FORMAT"
+ :doc "private: implementation of FORMAT and friends"
+ :use ("CL" "SB!KERNEL" "SB!EXT" "SB!INT"))
+
+ #s(sb-cold:package-data
+ :name "SB!GRAY"
+ :doc
+"public: an implementation of the stream-definition-by-user
+Lisp extension proposal by David N. Gray"
+ :use ("CL" "SB!KERNEL" "SB!EXT" "SB!INT")
+ :export ("FUNDAMENTAL-BINARY-STREAM" "FUNDAMENTAL-BINARY-INPUT-STREAM"
+ "FUNDAMENTAL-BINARY-OUTPUT-STREAM" "FUNDAMENTAL-CHARACTER-STREAM"
+ "FUNDAMENTAL-CHARACTER-INPUT-STREAM"
+ "FUNDAMENTAL-CHARACTER-OUTPUT-STREAM"
+ "FUNDAMENTAL-INPUT-STREAM" "FUNDAMENTAL-OUTPUT-STREAM"
+ "FUNDAMENTAL-STREAM"
+ "STREAM-ADVANCE-TO-COLUMN" "STREAM-CLEAR-INPUT"
+ "STREAM-CLEAR-OUTPUT" "STREAM-FINISH-OUTPUT" "STREAM-FORCE-OUTPUT"
+ "STREAM-FRESH-LINE" "STREAM-LINE-COLUMN" "STREAM-LINE-LENGTH"
+ "STREAM-LISTEN" "STREAM-PEEK-CHAR" "STREAM-READ-BYTE"
+ "STREAM-READ-CHAR" "STREAM-READ-CHAR-NO-HANG" "STREAM-READ-LINE"
+ "STREAM-START-LINE-P" "STREAM-TERPRI" "STREAM-UNREAD-CHAR"
+ "STREAM-WRITE-BYTE" "STREAM-WRITE-CHAR" "STREAM-WRITE-STRING"))
+
+ ;; FIXME: It looks as though it's no longer important to have INSPECT be
+ ;; a separate package. INSPECT functionality is in the ANSI spec, and we
+ ;; might as well implement it with everything else.
+ #s(sb-cold:package-data
+ :name "SB!INSPECT"
+ :doc "private: implementation of INSPECT"
+ :use ("CL" "SB!KERNEL" "SB!EXT" "SB!INT")
+ :export ("*INTERFACE-STYLE*" "REMOVE-ALL-DISPLAYS"
+ "REMOVE-OBJECT-DISPLAY" "SHOW-OBJECT"))
+
+ #s(sb-cold:package-data
+ :name "SB!INT"
+ :doc
+"private: miscellaneous unsupported extensions to the ANSI spec. Most of
+the stuff in here originated in CMU CL's EXTENSIONS package and is
+retained, possibly temporariliy, because it might be used internally."
+ :use ("CL" "SB!ALIEN" "SB!C-CALL" "SB!SYS")
+ ;; FIXME: RATIOP should probably not go through this package but be
+ ;; called directly from SB!KERNEL, unless it's implemented as
+ ;; TYPEP X 'RATIO in which case it doesn't need to be in SB!KERNEL.
+ ;; And BIGNUMP and FIXNUMP should probably just be in this package,
+ ;; even if they have low-level-optimized implementations. (Their
+ ;; *meanings* aren't low-level, even if their implementations are.)
+ :import-from (("SB!KERNEL" "BIGNUMP" "FIXNUMP" "RATIOP"))
+ :reexport ("BIGNUMP" "FIXNUMP" "RATIOP")
+ :export ("*AFTER-SAVE-INITIALIZATIONS*" "*BEFORE-SAVE-INITIALIZATIONS*"
+
+ "*ALL-MODIFIER-NAMES*"
+ "*BACKUP-EXTENSION*"
+
+ ;; INFO stuff doesn't belong in a user-visible package, we
+ ;; should be able to change it without apology.
+ "*INFO-ENVIRONMENT*"
+ "CLEAR-INFO"
+ "COMPACT-INFO-ENVIRONMENT"
+ "DEFINE-INFO-CLASS" "DEFINE-INFO-TYPE"
+ "DO-INFO"
+ "INFO"
+ "MAKE-INFO-ENVIRONMENT"
+
+ ;; packages grabbed once and for all
+ "*KEYWORD-PACKAGE*" "*CL-PACKAGE*"
+
+ ;; hash mixing operations
+ "MIX" "MIXF"
+
+ ;; Arguably there's no one right value for the system
+ ;; prompt. But Common Lisp makes it easy for you to write
+ ;; your own REPL if you really care, so I'm not convinced we
+ ;; need this as a supported extension.
+ "*PROMPT*"
+
+ ;; I'm not convinced that FDEFINITIONs are the ideal
+ ;; solution, so exposing ways to peek into the system
+ ;; seems undesirable, since it makes it harder to get
+ ;; rid of FDEFINITIONs entirely later.
+ "*SETF-FDEFINITION-HOOK*"
+
+ ;; useful but non-standard user-level functions..
+ "ASSQ" "DELQ" "MEMQ"
+ "%FIND-PACKAGE-OR-LOSE" "FIND-UNDELETED-PACKAGE-OR-LOSE"
+
+ ;; ..and macros
+ "COLLECT"
+ "DO-ANONYMOUS" "DOHASH" "DOVECTOR"
+ "ITERATE"
+ "LETF" "LETF*"
+ "ONCE-ONLY"
+ "DEF!MACRO" "DEF!METHOD" "DEF!STRUCT" "DEF!TYPE"
+
+ ;; encapsulation
+ "ARGUMENT-LIST"
+ "BASIC-DEFINITION"
+ "ENCAPSULATE" "ENCAPSULATED-DEFINITION" "ENCAPSULATED-P"
+ "UNENCAPSULATE"
+
+ ;; various CHAR-CODEs
+ "BELL-CHAR-CODE" "ESCAPE-CHAR-CODE" "FORM-FEED-CHAR-CODE"
+ "RETURN-CHAR-CODE" "RUBOUT-CHAR-CODE" "TAB-CHAR-CODE"
+
+ ;; nonstandard type predicates
+ "INSTANCEP"
+ "DOUBLE-FLOATP"
+ "LOGICAL-PATHNAME-P"
+ "LONG-FLOATP"
+ "SHORT-FLOATP"
+ "SINGLE-FLOATP"
+
+ ;; symbol-hacking idioms
+ "CONCAT-PNAMES" "KEYWORDICATE" "SYMBOLICATE"
+
+ ;; search lists (FIXME: should go away)
+ "ENUMERATE-SEARCH-LIST"
+ "CLEAR-SEARCH-LIST"
+ "SEARCH-LIST"
+ "SEARCH-LIST-DEFINED-P"
+
+ ;; certainly doesn't belong in public extensions
+ ;; FIXME: maybe belongs in %KERNEL with other typesystem stuff?
+ "CONSTANT-ARGUMENT"
+
+ ;; not used any more? (and not appropriate in SB!EXT, since
+ ;; SPECIAL things are so obnoxious in Common Lisp)
+ "E"
+
+ ;; various internal defaults
+ "*DEFAULT-PACKAGE-USE-LIST*"
+ "DEFAULT-INIT-CHAR"
+ "*LOAD-SOURCE-TYPES*" "*LOAD-OBJECT-TYPES*"
+
+ ;; hash caches
+ "DEFINE-HASH-CACHE"
+ "DEFUN-CACHED"
+
+ ;; time
+ "FORMAT-DECODED-TIME" "FORMAT-UNIVERSAL-TIME" "PARSE-TIME"
+
+ ;; indenting
+ "MAKE-INDENTING-STREAM"
+ "INDENTING-FURTHER"
+
+ ;; stream commands, used by the debugger
+ "GET-STREAM-COMMAND" "MAKE-STREAM-COMMAND" "STREAM-COMMAND"
+ "STREAM-COMMAND-ARGS" "STREAM-COMMAND-NAME" "STREAM-COMMAND-P"
+
+ ;; used for FORMAT tilde paren
+ "MAKE-CASE-FROB-STREAM"
+
+ ;; Some of these are probably still used for Unix-y processes.
+ ;; -- WHN 19991206
+ "PROCESS-CLOSE"
+ "PROCESS-CORE-DUMPED" "PROCESS-ERROR" "PROCESS-EXIT-CODE"
+ "PROCESS-INPUT" "PROCESS-KILL" "PROCESS-OUTPUT" "PROCESS-P"
+ "PROCESS-PID" "PROCESS-PLIST" "PROCESS-PTY" "PROCESS-STATUS"
+ "PROCESS-STATUS-HOOK" "PROCESS-WAIT"
+
+ ;; debuggers' little helpers
+ #!+sb-show "*/SHOW*"
+ "/SHOW" "/NOSHOW"
+ "/XHOW" "/NOXHOW"
+ "/SHOW0" "/NOSHOW0"
+
+ ;; cross-compilation bootstrap hacks which turn into
+ ;; placeholders in a target system
+ "UNCROSS"
+
+ ;; misc. utilities used internally
+ "LEGAL-FUNCTION-NAME-P"
+ "FUNCTION-NAME-BLOCK-NAME"
+ #!-sb-infinities "INFINITE"
+ "LISTEN-SKIP-WHITESPACE"
+ "PACKAGE-INTERNAL-SYMBOL-COUNT" "PACKAGE-EXTERNAL-SYMBOL-COUNT"
+ "PROPER-LIST-OF-LENGTH-P"
+ "LIST-OF-LENGTH-AT-LEAST-P"
+ "READ-SEQUENCE-OR-DIE"
+ "RENAME-KEYWORD-ARGS"
+ "REQUIRED-ARGUMENT"
+ "UNIX-NAMESTRING" ; FIXME: perhaps belongs in package %UNIX
+ "FEATUREP"
+ "FLUSH-STANDARD-OUTPUT"
+
+ ;; These could be moved back into SB!EXT if someone has compelling
+ ;; reasons, but hopefully we can get by without supporting them,
+ ;; at least not as publicly accessible things with fixed
+ ;; interfaces.
+ "DEFAULT-DIRECTORY"
+ "FILE-COMMENT"
+ "GET-FLOATING-POINT-MODES" "SET-FLOATING-POINT-MODES"
+ "WITH-FLOAT-TRAPS-MASKED"
+ "DEFINE-HASH-TABLE-TEST"
+ "*GC-INHIBIT-HOOK*"
+
+ ;; not used any more, I think -- WHN 19991206
+ #+nil
+ ("SERVE-BUTTON-PRESS"
+ "SERVE-BUTTON-RELEASE" "SERVE-CIRCULATE-NOTIFY"
+ "SERVE-CIRCULATE-REQUEST" "SERVE-CLIENT-MESSAGE"
+ "SERVE-COLORMAP-NOTIFY" "SERVE-CONFIGURE-NOTIFY"
+ "SERVE-CONFIGURE-REQUEST" "SERVE-CREATE-NOTIFY"
+ "SERVE-DESTROY-NOTIFY" "SERVE-ENTER-NOTIFY" "SERVE-EXPOSURE"
+ "SERVE-FOCUS-IN" "SERVE-FOCUS-OUT" "SERVE-GRAPHICS-EXPOSURE"
+ "SERVE-GRAVITY-NOTIFY" "SERVE-KEY-PRESS" "SERVE-KEY-RELEASE"
+ "SERVE-LEAVE-NOTIFY" "SERVE-MAP-NOTIFY" "SERVE-MAP-REQUEST"
+ "SERVE-MOTION-NOTIFY" "SERVE-NO-EXPOSURE" "SERVE-PROPERTY-NOTIFY"
+ "SERVE-REPARENT-NOTIFY" "SERVE-RESIZE-REQUEST"
+ "SERVE-SELECTION-CLEAR" "SERVE-SELECTION-NOTIFY"
+ "SERVE-SELECTION-REQUEST" "SERVE-UNMAP-NOTIFY"
+ "SERVE-VISIBILITY-NOTIFY")))
+
+ #s(sb-cold:package-data
+ :name "SB!ITERATE"
+ :doc "private: implementation of an iteration facility used by PCL"
+ :use ("CL" "SB!WALKER")
+ :export ("ITERATE" "ITERATE*" "GATHERING" "GATHER"
+ "WITH-GATHERING" "INTERVAL" "ELEMENTS"
+ "LIST-ELEMENTS" "LIST-TAILS" "PLIST-ELEMENTS"
+ "EACHTIME" "WHILE" "UNTIL" "COLLECTING" "JOINING"
+ "MAXIMIZING" "MINIMIZING" "SUMMING"
+ "*ITERATE-WARNINGS*"))
+
+ #s(sb-cold:package-data
+ :name "SB!KERNEL"
+ :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."
+ :use ("CL" "SB!ALIEN" "SB!ALIEN-INTERNALS" "SB!BIGNUM"
+ "SB!EXT" "SB!INT" "SB!SYS")
+ :import-from (("SB!C-CALL" "VOID"))
+ :reexport ("DEF!STRUCT" "DEF!MACRO" "VOID")
+ :export ("%ACOS" "%ACOSH" "%ARRAY-AVAILABLE-ELEMENTS"
+ "%ARRAY-DATA-VECTOR" "%ARRAY-DIMENSION"
+ "%ARRAY-DISPLACED-P"
+ "%ARRAY-DISPLACEMENT" "%ARRAY-FILL-POINTER"
+ "%ARRAY-FILL-POINTER-P" "%ASIN" "%ASINH"
+ "%ATAN" "%ATAN2" "%ATANH"
+ "%CALLER-FRAME-AND-PC" "%CHECK-BOUND" "%CLOSURE-FUNCTION"
+ "%CLOSURE-INDEX-REF" "%COS" "%COS-QUICK"
+ "%COSH" "%DEPOSIT-FIELD"
+ "%DOUBLE-FLOAT" "%DPB" "%EXP" "%EXPM1"
+ "%FUNCTION-HEADER-ARGLIST"
+ "%FUNCTION-HEADER-NAME" "%FUNCTION-HEADER-TYPE"
+ "%HYPOT" "%INSTANCE-SET-CONDITIONAL" "%LDB"
+ "%LOG" "%LOGB" "%LOG10" "%LOG1P" "%LONG-FLOAT"
+ "%MAKE-COMPLEX" "%MAKE-FUNCALLABLE-INSTANCE" "%MAKE-RATIO"
+ "%MAP-TO-SIMPLE-VECTOR-ARITY-1" "%MAP-TO-LIST-ARITY-1"
+ "%MAP-TO-NIL-ON-SEQUENCE" "%MAP-TO-NIL-ON-SIMPLE-VECTOR"
+ "%MAP-TO-NIL-ON-VECTOR" "%MASK-FIELD" "%NEGATE" "%POW"
+ "%RAW-BITS" "%RAW-REF-COMPLEX-DOUBLE"
+ "%RAW-REF-COMPLEX-LONG"
+ "%RAW-REF-COMPLEX-SINGLE" "%RAW-REF-DOUBLE"
+ "%RAW-REF-LONG"
+ "%RAW-REF-SINGLE" "%RAW-SET-COMPLEX-DOUBLE"
+ "%RAW-SET-COMPLEX-LONG" "%RAW-SET-COMPLEX-SINGLE"
+ "%RAW-SET-DOUBLE" "%RAW-SET-LONG" "%RAW-SET-SINGLE"
+ "%SCALB" "%SCALBN" "%SET-FUNCALLABLE-INSTANCE-FUNCTION"
+ "%SET-FUNCALLABLE-INSTANCE-INFO" "%SET-RAW-BITS"
+ "%SET-SAP-REF-16" "%SET-SAP-REF-32" "%SET-SAP-REF-64"
+ "%SET-SAP-REF-8" "%SET-SAP-REF-DOUBLE" "%SET-SAP-REF-LONG"
+ "%SET-SAP-REF-SAP" "%SET-SAP-REF-SINGLE"
+ "%SET-SIGNED-SAP-REF-16" "%SET-SIGNED-SAP-REF-32"
+ "%SET-SIGNED-SAP-REF-64" "%SET-SIGNED-SAP-REF-8"
+ "%SET-STACK-REF" "%SIN" "%SIN-QUICK"
+ "%SINGLE-FLOAT" "%SINH" "%SP-SET-DEFINITION"
+ "%SP-SET-PLIST"
+ "%SQRT" "%SXHASH-SIMPLE-STRING"
+ "%SXHASH-SIMPLE-SUBSTRING" "%TAN" "%TAN-QUICK"
+ "%TANH" "%UNARY-ROUND" "%UNARY-TRUNCATE"
+ "%WITH-ARRAY-DATA" "WITH-ARRAY-DATA"
+ "*ALREADY-MAYBE-GCING*"
+ "*CURRENT-LEVEL*" "*EMPTY-TYPE*"
+ "*EVAL-STACK-TOP*" "*GC-INHIBIT*"
+ "*NEED-TO-COLLECT-GARBAGE*"
+ "*PRETTY-PRINTER*" "*UNIVERSAL-TYPE*"
+ "*UNPARSE-FUNCTION-TYPE-SIMPLIFY*" "*WILD-TYPE*"
+ "32BIT-LOGICAL-AND" "32BIT-LOGICAL-ANDC1"
+ "32BIT-LOGICAL-ANDC2"
+ "32BIT-LOGICAL-EQV" "32BIT-LOGICAL-NAND"
+ "32BIT-LOGICAL-NOR"
+ "32BIT-LOGICAL-NOT" "32BIT-LOGICAL-OR"
+ "32BIT-LOGICAL-ORC1"
+ "32BIT-LOGICAL-ORC2" "32BIT-LOGICAL-XOR"
+ "ALIEN-TYPE-TYPE"
+ "ALIEN-TYPE-TYPE-ALIEN-TYPE" "ALIEN-TYPE-TYPE-P"
+ "ALLOCATE-VECTOR"
+ "ALWAYS-SUBTYPEP" "ARGS-TYPE" "ARGS-TYPE-ALLOWP"
+ "ARGS-TYPE-KEYP"
+ "ARGS-TYPE-KEYWORDS" "ARGS-TYPE-OPTIONAL" "ARGS-TYPE-P"
+ "ARGS-TYPE-REQUIRED" "ARGS-TYPE-REST"
+ "ARRAY-HEADER-P" "ARRAY-TYPE" "ARRAY-TYPE-COMPLEXP"
+ "ARRAY-TYPE-DIMENSIONS" "ARRAY-TYPE-ELEMENT-TYPE"
+ "ARRAY-TYPE-P"
+ "ARRAY-TYPE-SPECIALIZED-ELEMENT-TYPE" "ASH-INDEX"
+ "ASSERT-ERROR" "BASE-CHAR-P"
+ "!BEGIN-COLLECTING-COLD-INIT-FORMS"
+ "BINDING-STACK-POINTER-SAP" "BIT-BASH-AND"
+ "BIT-BASH-ANDC1"
+ "BIT-BASH-ANDC2" "BIT-BASH-CLEAR" "BIT-BASH-COPY"
+ "BIT-BASH-EQV"
+ "BIT-BASH-IOR" "BIT-BASH-LOGNAND" "BIT-BASH-LOGNOR"
+ "BIT-BASH-NOT"
+ "BIT-BASH-ORC1" "BIT-BASH-ORC2" "BIT-BASH-SET"
+ "BIT-BASH-XOR"
+ "BIT-INDEX" "BOGUS-ARGUMENT-TO-VALUES-LIST-ERROR"
+ "BOOLE-CODE"
+ "BYTE-SPECIFIER" "CALLABLE" "CASE-BODY-ERROR"
+ "CHECK-FOR-CIRCULARITY" "CHECK-TYPE-ERROR"
+ "CODE-COMPONENT" "CODE-COMPONENT-P"
+ "CODE-DEBUG-INFO" "CODE-HEADER-REF" "CODE-HEADER-SET"
+ "CODE-INSTRUCTIONS" "COERCE-TO-BIT-VECTOR" "COERCE-TO-FUNCTION"
+ "COERCE-TO-LIST" "COERCE-TO-SIMPLE-STRING"
+ "COERCE-TO-SIMPLE-VECTOR" "COERCE-TO-VECTOR"
+ "*COLD-INIT-COMPLETE-P*"
+ "!COLD-INIT-FORMS" "COMPLEX-DOUBLE-FLOAT-P"
+ "COMPLEX-FLOAT-P" "COMPLEX-LONG-FLOAT-P"
+ "COMPLEX-RATIONAL-P" "COMPLEX-SINGLE-FLOAT-P"
+ "COMPLEX-VECTOR-P" "CONSED-SEQUENCE" "CONSTANT" "CONSTANT-TYPE"
+ "CONSTANT-TYPE-P" "CONSTANT-TYPE-TYPE"
+ "CONTAINING-INTEGER-TYPE"
+ "CONTROL-STACK-POINTER-SAP" "COPY-FROM-SYSTEM-AREA"
+ "COPY-NUMERIC-TYPE" "COPY-TO-SYSTEM-AREA"
+ "COPY-BYTE-VECTOR-TO-SYSTEM-AREA"
+ "CSUBTYPEP" "CTYPE" "TYPE-HASH-VALUE"
+ "CTYPE-OF" "CTYPE-P" "CTYPEP" "CURRENT-FP" "CURRENT-SP"
+ "DATA-VECTOR-REF" "DATA-VECTOR-SET" "DECODE-DOUBLE-FLOAT"
+ "DECODE-LONG-FLOAT" "DECODE-SINGLE-FLOAT" "DESCEND-INTO"
+ "DIVISION-BY-ZERO-ERROR"
+ "DOUBLE-FLOAT-EXPONENT" "DOUBLE-FLOAT-HIGH-BITS"
+ "DOUBLE-FLOAT-INT-EXPONENT" "DOUBLE-FLOAT-LOW-BITS"
+ "DOUBLE-FLOAT-SIGNIFICAND"
+ "DOUBLE-FLOAT-P" "FLOAT-WAIT"
+ "DYNAMIC-SPACE-FREE-POINTER"
+ "!DEFUN-FROM-COLLECTED-COLD-INIT-FORMS"
+ "ERROR-NUMBER-OR-LOSE" "FDOCUMENTATION" "FILENAME"
+ "FIND-AND-INIT-OR-CHECK-LAYOUT"
+ "FLOAT-EXPONENT" "FLOAT-FORMAT-DIGITS" "FLOAT-FORMAT-NAME"
+ "FLOAT-FORMAT-MAX" "FLOATING-POINT-EXCEPTION"
+ "FORM" "FUNCALLABLE-INSTANCE-P"
+ "FUNCTION-CODE-HEADER" "FUNCTION-TYPE"
+ "FUNCTION-TYPE-ALLOWP"
+ "FUNCTION-TYPE-KEYP" "FUNCTION-TYPE-KEYWORDS"
+ "FUNCTION-TYPE-NARGS" "FUNCTION-TYPE-OPTIONAL"
+ "FUNCTION-TYPE-P"
+ "FUNCTION-TYPE-REQUIRED" "FUNCTION-TYPE-REST"
+ "FUNCTION-TYPE-RETURNS" "FUNCTION-TYPE-WILD-ARGS"
+ "FUNCTION-WORD-OFFSET" "GET-CLOSURE-LENGTH"
+ "GET-HEADER-DATA"
+ "GET-LISP-OBJ-ADDRESS" "GET-LOWTAG"
+ "GET-TYPE"
+ "HAIRY-DATA-VECTOR-REF" "HAIRY-DATA-VECTOR-SET" "HAIRY-TYPE"
+ "HAIRY-TYPE-CHECK-TEMPLATE-NAME" "HAIRY-TYPE-SPECIFIER"
+ "HANDLE-CIRCULARITY" "IGNORE-IT"
+ "INDEX" "INDEX-TOO-LARGE-ERROR" "INTEGER-DECODE-DOUBLE-FLOAT"
+ "INTEGER-DECODE-LONG-FLOAT" "INTEGER-DECODE-SINGLE-FLOAT"
+ "INTERNAL-ERROR" "INTERNAL-TIME"
+ "INVALID-ARGUMENT-COUNT-ERROR" "INVALID-ARRAY-INDEX-ERROR"
+ "INVALID-UNWIND-ERROR" "IRRATIONAL"
+ "JUST-DUMP-IT-NORMALLY"
+ "KEY-INFO" "KEY-INFO-NAME"
+ "KEY-INFO-P" "KEY-INFO-TYPE"
+ "LAYOUT-DEPTHOID"
+ "LAYOUT-INVALID-ERROR" "LEXENV"
+ "LIST-TO-SIMPLE-STRING*" "LIST-TO-BIT-VECTOR*"
+ "LIST-TO-VECTOR*"
+ "LONG-FLOAT-EXPONENT" "LONG-FLOAT-EXP-BITS"
+ "LONG-FLOAT-HIGH-BITS"
+ "LONG-FLOAT-LOW-BITS" "LONG-FLOAT-MID-BITS" "LONG-FLOAT-P"
+ "LRA" "LRA-CODE-HEADER" "LRA-P"
+ "MAKE-ALIEN-TYPE-TYPE" "MAKE-ARGS-TYPE"
+ "MAKE-ARRAY-HEADER" "MAKE-ARRAY-TYPE" "MAKE-DOUBLE-FLOAT"
+ "MAKE-FUNCTION-TYPE"
+ "MAKE-KEY-INFO" "MAKE-LISP-OBJ" "MAKE-LONG-FLOAT"
+ "MAKE-MEMBER-TYPE" "MAKE-NAMED-TYPE"
+ "MAKE-NULL-LEXENV" "MAKE-NUMERIC-TYPE"
+ "MAKE-SINGLE-FLOAT" "MAKE-SPECIALIZABLE-ARRAY"
+ "%MAKE-INSTANCE" "MAKE-UNION-TYPE" "MAKE-VALUES-TYPE"
+ "MAYBE-GC" "MEMBER-TYPE" "MEMBER-TYPE-MEMBERS"
+ "MEMBER-TYPE-P" "MERGE-BITS"
+ "DEFMACRO-MUNDANELY" "MUTATOR-SELF"
+ "NAMED-TYPE" "NAMED-TYPE-NAME" "NAMED-TYPE-P"
+ "NATIVE-BYTE-ORDER" "NEGATE"
+ "NEVER-SUBTYPEP" "NIL-FUNCTION-RETURNED-ERROR"
+ "NOT-<=-ERROR" "NOT-=-ERROR"
+ "NOT-DUMPED-AT-ALL"
+ "NUMERIC-CONTAGION" "NUMERIC-TYPE"
+ "NUMERIC-TYPE-CLASS" "NUMERIC-TYPE-COMPLEXP"
+ "NUMERIC-TYPE-FORMAT"
+ "NUMERIC-TYPE-HIGH" "NUMERIC-TYPE-LOW" "NUMERIC-TYPE-P"
+ "OBJECT-NOT-ARRAY-ERROR" "OBJECT-NOT-BASE-CHAR-ERROR"
+ "OBJECT-NOT-BIGNUM-ERROR" "OBJECT-NOT-BIT-VECTOR-ERROR"
+ "OBJECT-NOT-COERCEABLE-TO-FUNCTION-ERROR"
+ "OBJECT-NOT-COMPLEX-ERROR"
+ "OBJECT-NOT-COMPLEX-FLOAT-ERROR"
+ "OBJECT-NOT-COMPLEX-SINGLE-FLOAT-ERROR"
+ "OBJECT-NOT-COMPLEX-LONG-FLOAT-ERROR"
+ "OBJECT-NOT-COMPLEX-DOUBLE-FLOAT-ERROR"
+ "OBJECT-NOT-COMPLEX-RATIONAL-ERROR"
+ "OBJECT-NOT-CONS-ERROR"
+ "OBJECT-NOT-DOUBLE-FLOAT-ERROR" "OBJECT-NOT-FIXNUM-ERROR"
+ "OBJECT-NOT-FLOAT-ERROR" "OBJECT-NOT-FUNCTION-ERROR"
+ "OBJECT-NOT-FUNCTION-OR-SYMBOL-ERROR"
+ "OBJECT-NOT-INSTANCE-ERROR"
+ "OBJECT-NOT-INTEGER-ERROR"
+ "OBJECT-NOT-LIST-ERROR" "OBJECT-NOT-LONG-FLOAT-ERROR"
+ "OBJECT-NOT-NUMBER-ERROR"
+ "OBJECT-NOT-RATIO-ERROR" "OBJECT-NOT-RATIONAL-ERROR"
+ "OBJECT-NOT-REAL-ERROR" "OBJECT-NOT-SAP-ERROR"
+ "OBJECT-NOT-SIGNED-BYTE-32-ERROR"
+ "OBJECT-NOT-SIMPLE-ARRAY-COMPLEX-DOUBLE-FLOAT-ERROR"
+ "OBJECT-NOT-SIMPLE-ARRAY-COMPLEX-LONG-FLOAT-ERROR"
+ "OBJECT-NOT-SIMPLE-ARRAY-COMPLEX-SINGLE-FLOAT-ERROR"
+ "OBJECT-NOT-SIMPLE-ARRAY-DOUBLE-FLOAT-ERROR"
+ "OBJECT-NOT-SIMPLE-ARRAY-ERROR"
+ "OBJECT-NOT-SIMPLE-ARRAY-LONG-FLOAT-ERROR"
+ "OBJECT-NOT-SIMPLE-ARRAY-SINGLE-FLOAT-ERROR"
+ "OBJECT-NOT-SIMPLE-ARRAY-UNSIGNED-BYTE-16-ERROR"
+ "OBJECT-NOT-SIMPLE-ARRAY-UNSIGNED-BYTE-2-ERROR"
+ "OBJECT-NOT-SIMPLE-ARRAY-UNSIGNED-BYTE-32-ERROR"
+ "OBJECT-NOT-SIMPLE-ARRAY-UNSIGNED-BYTE-4-ERROR"
+ "OBJECT-NOT-SIMPLE-ARRAY-UNSIGNED-BYTE-8-ERROR"
+ "OBJECT-NOT-SIMPLE-ARRAY-SIGNED-BYTE-16-ERROR"
+ "OBJECT-NOT-SIMPLE-ARRAY-SIGNED-BYTE-30-ERROR"
+ "OBJECT-NOT-SIMPLE-ARRAY-SIGNED-BYTE-32-ERROR"
+ "OBJECT-NOT-SIMPLE-ARRAY-SIGNED-BYTE-8-ERROR"
+ "OBJECT-NOT-SIMPLE-BIT-VECTOR-ERROR"
+ "OBJECT-NOT-SIMPLE-STRING-ERROR"
+ "OBJECT-NOT-SIMPLE-VECTOR-ERROR"
+ "OBJECT-NOT-SINGLE-FLOAT-ERROR" "OBJECT-NOT-STRING-ERROR"
+ "OBJECT-NOT-INSTANCE-ERROR" "OBJECT-NOT-SYMBOL-ERROR"
+ "OBJECT-NOT-TYPE-ERROR"
+ "OBJECT-NOT-UNSIGNED-BYTE-32-ERROR"
+ "OBJECT-NOT-VECTOR-ERROR" "OBJECT-NOT-WEAK-POINTER-ERROR"
+ "ODD-KEYWORD-ARGUMENTS-ERROR"
+ "OUTPUT-OBJECT" "OUTPUT-UGLY-OBJECT"
+ "PARSE-DEFMACRO" "PARSE-LAMBDA-LIST" "PARSE-UNKNOWN-TYPE"
+ "PARSE-UNKNOWN-TYPE-SPECIFIER"
+ "PATHNAME-DESIGNATOR" "PUNT-IF-TOO-LONG"
+ "READER-PACKAGE-ERROR"
+ #!+gengc "*SAVED-STATE-CHAIN*"
+ "SCALE-DOUBLE-FLOAT" "SCALE-LONG-FLOAT"
+ "SCALE-SINGLE-FLOAT"
+ "SEQUENCE-END" "SET-HEADER-DATA" "SHIFT-TOWARDS-END"
+ "SHIFT-TOWARDS-START" "SHRINK-VECTOR" "SIGNED-BYTE-32-P"
+ "SIMPLE-ARRAY-COMPLEX-DOUBLE-FLOAT-P"
+ "SIMPLE-ARRAY-COMPLEX-LONG-FLOAT-P"
+ "SIMPLE-ARRAY-COMPLEX-SINGLE-FLOAT-P"
+ "SIMPLE-ARRAY-DOUBLE-FLOAT-P" "SIMPLE-ARRAY-LONG-FLOAT-P"
+ "SIMPLE-ARRAY-P"
+ "SIMPLE-ARRAY-SINGLE-FLOAT-P"
+ "SIMPLE-ARRAY-UNSIGNED-BYTE-16-P"
+ "SIMPLE-ARRAY-UNSIGNED-BYTE-2-P"
+ "SIMPLE-ARRAY-UNSIGNED-BYTE-32-P"
+ "SIMPLE-ARRAY-UNSIGNED-BYTE-4-P"
+ "SIMPLE-ARRAY-UNSIGNED-BYTE-8-P"
+ "SIMPLE-ARRAY-SIGNED-BYTE-16-P"
+ "SIMPLE-ARRAY-SIGNED-BYTE-30-P"
+ "SIMPLE-ARRAY-SIGNED-BYTE-32-P"
+ "SIMPLE-ARRAY-SIGNED-BYTE-8-P"
+ "SIMPLE-PACKAGE-ERROR"
+ "SIMPLE-UNBOXED-ARRAY"
+ "SINGLE-FLOAT-BITS" "SINGLE-FLOAT-EXPONENT"
+ "SINGLE-FLOAT-INT-EXPONENT" "SINGLE-FLOAT-P"
+ "SINGLE-FLOAT-SIGNIFICAND"
+ "SINGLE-VALUE-TYPE" "SPECIALIZABLE" "SPECIALIZABLE-VECTOR"
+ "SPECIFIER-TYPE" "STACK-REF"
+ "STREAMLIKE" "STRINGABLE"
+ "STRUCTURE-RAW-SLOT-TYPE-AND-SIZE"
+ "%INSTANCE-LENGTH"
+ "%INSTANCE-REF" "%INSTANCE-SET"
+ "STRING-TO-SIMPLE-STRING"
+ "SYSTEM-AREA-CLEAR"
+ "SYSTEM-AREA-COPY" "TWO-ARG-*"
+ "TRY-TO-RENAME-INTERPRETED-FUNCTION-AS-MACRO"
+ "TWO-ARG-+" "TWO-ARG--"
+ "TWO-ARG-/" "TWO-ARG-/=" "TWO-ARG-<"
+ "TWO-ARG-<=" "TWO-ARG-="
+ "TWO-ARG->" "TWO-ARG->=" "TWO-ARG-AND"
+ "TWO-ARG-GCD" "TWO-ARG-IOR"
+ "TWO-ARG-LCM" "TWO-ARG-XOR"
+ "TYPE-DIFFERENCE" "TYPE-EXPAND"
+ "TYPE-INTERSECT"
+ "TYPE-INTERSECTION" "TYPE-SPECIFIER"
+ "*STANDARD-TYPE-NAMES*" "TYPE-UNION" "TYPE/=" "TYPE="
+ "TYPES-INTERSECT" "UNBOUND-SYMBOL-ERROR" "UNBOXED-ARRAY"
+ "UNDEFINED-SYMBOL-ERROR" "UNION-TYPE" "UNION-TYPE-P"
+ "UNION-TYPE-TYPES" "UNKNOWN-ERROR"
+ "UNKNOWN-KEYWORD-ARGUMENT-ERROR"
+ "UNKNOWN-TYPE" "UNKNOWN-TYPE-P"
+ "UNKNOWN-TYPE-SPECIFIER" "UNSEEN-THROW-TAG-ERROR"
+ "UNSIGNED-BYTE-32-P" "VALUES-SPECIFIER-TYPE"
+ "VALUES-SPECIFIER-TYPE-CACHE-CLEAR" "VALUES-SUBTYPEP"
+ "VALUES-TYPE" "VALUES-TYPE-ALLOWP" "VALUES-TYPE-INTERSECT"
+ "VALUES-TYPE-INTERSECTION" "VALUES-TYPE-KEYP"
+ "VALUES-TYPE-KEYWORDS" "VALUES-TYPE-OPTIONAL"
+ "VALUES-TYPE-P" "VALUES-TYPE-REQUIRED"
+ "VALUES-TYPE-REST" "VALUES-TYPE-UNION"
+ "VALUES-TYPES" "VALUES-TYPES-INTERSECT" "VECTOR-T-P"
+ "VECTOR-TO-VECTOR*" "VECTOR-TO-SIMPLE-STRING*"
+ "VECTOR-TO-BIT-VECTOR*" "VECTOR-TO-SIMPLE-BIT-VECTOR*"
+ "WITH-CIRCULARITY-DETECTION" "WITH-TYPE-CACHES"
+ "WRONG-NUMBER-OF-INDICES-ERROR"
+
+ "FDEFN" "MAKE-FDEFN" "FDEFN-P"
+ "FDEFN-NAME" "FDEFN-FUNCTION"
+ "FDEFN-MAKUNBOUND" "%COERCE-NAME-TO-FUNCTION"
+ "FUNCTION-SUBTYPE" "*MAXIMUM-ERROR-DEPTH*"
+ "%SET-SYMBOL-PLIST" "INFINITE-ERROR-PROTECT"
+ "FIND-CALLER-NAME"
+ "%SET-SYMBOL-VALUE" "%SET-SYMBOL-PACKAGE"
+ "OUTPUT-SYMBOL-NAME"
+ "FSET" "RAW-DEFINITION"
+ "INVOKE-MACROEXPAND-HOOK"
+ "DEFAULT-STRUCTURE-PRINT"
+ "LAYOUT" "LAYOUT-LENGTH" "RATIOP" "FIXNUMP" "TARGET-FIXNUMP"
+ "LAMBDA-WITH-ENVIRONMENT" "LAYOUT-PURE" "DSD-RAW-TYPE"
+ "%COMPILER-DEFSTRUCT"
+ "%COMPILER-ONLY-DEFSTRUCT" "FUNCTION-%COMPILER-ONLY-DEFSTRUCT"
+ "DEFSTRUCT-DESCRIPTION" "UNDEFINE-STRUCTURE"
+ "BIGNUMP" "DD-COPIER" "UNDEFINE-FUNCTION-NAME" "DD-TYPE"
+ "CLASS-STATE" "INSTANCE"
+ "*TYPE-SYSTEM-INITIALIZED*" "WEAK-POINTER-P" "FIND-LAYOUT"
+ "DSD-NAME" "%TYPEP" "DD-RAW-INDEX"
+ "DD-NAME" "CLASS-SUBCLASSES"
+ "CLASS-LAYOUT" "CLASS-%NAME"
+ "DD-RAW-LENGTH" "NOTE-NAME-DEFINED"
+ "%CODE-CODE-SIZE" "DD-SLOTS"
+ "%IMAGPART" "DSD-ACCESSOR"
+ "%CODE-DEBUG-INFO" "DSD-%NAME"
+ "LAYOUT-CLASS" "LAYOUT-INVALID"
+ "%FUNCTION-NAME" "DSD-TYPE" "%INSTANCEP"
+ "DEFSTRUCT-SLOT-DESCRIPTION" "%FUNCTION-ARGLIST"
+ "%FUNCTION-NEXT" "LAYOUT-CLOS-HASH-LENGTH" "DD-PREDICATE"
+ "CLASS-PROPER-NAME" "%NOTE-TYPE-DEFINED" "LAYOUT-INFO"
+ "%SET-INSTANCE-LAYOUT" "DD-DEFAULT-CONSTRUCTOR"
+ "LAYOUT-OF" "%FUNCTION-SELF" "%REALPART"
+ "STRUCTURE-CLASS-P" "DSD-INDEX"
+ "%INSTANCE-LAYOUT" "LAYOUT-CLOS-HASH"
+ "%FUNCTION-TYPE" "PROCLAIM-AS-FUNCTION-NAME"
+ "%%COMPILER-DEFSTRUCT" "%NUMERATOR" "CLASS-TYPEP"
+ "STRUCTURE-CLASS-PRINT-FUNCTION" "DSD-READ-ONLY"
+ "LAYOUT-INHERITS" "DD-LENGTH" "%CODE-ENTRY-POINTS"
+ "%DENOMINATOR"
+ "BYTE-FUNCTION-OR-CLOSURE" "MAKE-STANDARD-CLASS"
+ "BYTE-FUNCTION-NAME" "CLASS-CELL-TYPEP" "BYTE-CLOSURE"
+ "FIND-CLASS-CELL" "EXTRACT-FUNCTION-TYPE"
+ "FUNCALLABLE-STRUCTURE-CLASS"
+ "%RANDOM-DOUBLE-FLOAT" "%RANDOM-LONG-FLOAT"
+ "%RANDOM-SINGLE-FLOAT"
+ "RANDOM-PCL-CLASS" "BASIC-STRUCTURE-CLASS-PRINT-FUNCTION"
+ "%FUNCALLABLE-INSTANCE-INFO" "*EVAL-STACK*" "RANDOM-CHUNK"
+ "MAKE-FUNCALLABLE-STRUCTURE-CLASS" "LAYOUT-CLOS-HASH-MAX"
+ "CLASS-CELL-NAME" "BUILT-IN-CLASS-DIRECT-SUPERCLASSES"
+ "INITIALIZE-BYTE-COMPILED-FUNCTION"
+ "RANDOM-LAYOUT-CLOS-HASH"
+ "CLASS-PCL-CLASS" "FUNCALLABLE-STRUCTURE"
+ "FUNCALLABLE-INSTANCE-FUNCTION"
+ "%FUNCALLABLE-INSTANCE-LAYOUT"
+ "BASIC-STRUCTURE-CLASS" "BYTE-CLOSURE-DATA"
+ "BYTE-CLOSURE-FUNCTION" "BYTE-FUNCTION" "CLASS-CELL-CLASS"
+ "FUNCALLABLE-STRUCTURE-CLASS-P" "REGISTER-LAYOUT"
+ "FUNCALLABLE-INSTANCE" "RANDOM-FIXNUM-MAX"
+ "MAKE-RANDOM-PCL-CLASS" "INSTANCE-LAMBDA"
+ "%FUNCALLABLE-INSTANCE-LEXENV" "%MAKE-SYMBOL"
+ "%FUNCALLABLE-INSTANCE-FUNCTION" "SYMBOL-HASH"
+
+ "MAKE-UNDEFINED-CLASS" "CLASS-DIRECT-SUPERCLASSES" "MAKE-LAYOUT"
+ "BYTE-FUNCTION-TYPE"
+ "REDEFINE-LAYOUT-WARNING" "SLOT-CLASS"
+ "INSURED-FIND-CLASS" "CONDITION-FUNCTION-NAME"
+
+ ;; FIXME: These error-handling things probably belong
+ ;; the SB-INT package, not here.
+ "SIMPLE-CONTROL-ERROR" "SIMPLE-FILE-ERROR"
+ "SIMPLE-PROGRAM-ERROR" "SIMPLE-STYLE-WARNING" "STYLE-WARN"
+
+ "!COLD-INIT"
+ "!GLOBALDB-COLD-INIT" "!FDEFN-COLD-INIT"
+ "!TYPE-CLASS-COLD-INIT" "!TYPEDEFS-COLD-INIT"
+ "!ALIEN-TYPE-COLD-INIT" "!CLASSES-COLD-INIT"
+ "!EARLY-TYPE-COLD-INIT" "!LATE-TYPE-COLD-INIT"
+ "!TARGET-TYPE-COLD-INIT" "!RANDOM-COLD-INIT"
+ "!FILESYS-COLD-INIT" "!READER-COLD-INIT"
+ "STREAM-COLD-INIT-OR-RESET" "!LOADER-COLD-INIT"
+ "!PACKAGE-COLD-INIT" "SIGNAL-COLD-INIT-OR-REINIT"
+ "!SET-SANE-COOKIE-DEFAULTS" "!VM-TYPE-COLD-INIT"
+ "!BACKQ-COLD-INIT" "!SHARPM-COLD-INIT"
+ "!CLASS-FINALIZE" "GC-COLD-INIT-OR-REINIT"
+
+ ;; These belong in an "SB!LOAD" package someday.
+ "*STATIC-FOREIGN-SYMBOLS*" "*ASSEMBLER-ROUTINES*"
+
+ ;; Note: These are out of lexicographical order because in CMU CL
+ ;; they were defined as internal symbols in package "CL"
+ ;; imported into package "C", as opposed to what we're
+ ;; doing here, defining them as external symbols in a package
+ ;; which is used by both "SB!C" and "SB!IMPL". (SBCL's "SB!C" is
+ ;; directly analogous to CMU CL's "C"; and for this purpose,
+ ;; SBCL's "SB!IMPL" is analogous to CMU CL's "CL".) As far
+ ;; as I know there's nothing special about them, so they could
+ ;; be merged into the same order as everything else in the
+ ;; in this package. -- WHN 19990911
+ "STRING>=*" "STRING>*" "STRING=*"
+ "STRING<=*" "STRING<*" "STRING/=*"
+ "SHORT-FLOAT-P" "%SVSET" "%SP-STRING-COMPARE" "%SETNTH"
+ "%SETELT" "%SET-ROW-MAJOR-AREF" "%SET-FILL-POINTER"
+ "%SET-FDEFINITION" "%SCHARSET" "%SBITSET" "%RPLACD"
+ "%RPLACA" "%PUT" "%CHARSET" "%BITSET" "%ASET"
+ "%ARRAY-TYPEP" "%SET-SAP-REF-DESCRIPTOR"
+
+ ;; Note: These are out of lexicographical order only because
+ ;; historically in CMU CL they were imported into package VM
+ ;; from LISP instead of being exported from package VM. In
+ ;; SBCL we achieve more or less the same effect by putting them
+ ;; in SB!KERNEL, where they're visible both in SB!IMPL and in
+ ;; SB!VM. But as far as I can tell, though, there's no
+ ;; fundamental reason that they're different from the other
+ ;; exports. -- WHN 19991020
+ "STATIC-SPACE-START" "READ-ONLY-SPACE-START"
+ "DYNAMIC-1-SPACE-START" "DYNAMIC-0-SPACE-START"
+ "CURRENT-DYNAMIC-SPACE-START" "*STATIC-SPACE-FREE-POINTER*"
+ "*READ-ONLY-SPACE-FREE-POINTER*"))
+
+ #s(sb-cold:package-data
+ :name "SB!LOOP"
+ :doc "private: implementation details of LOOP"
+ :use ("CL")
+ :export ())
+
+ #!+mp
+ #s(sb-cold:package-data
+ :name "SB!MP"
+ :doc "public (but unstable): multiprocessing support"
+ :export ("*ALL-PROCESSES*" "*CURRENT-PROCESS*"
+ "*CURRENT-STACK-GROUP*" "*INITIAL-STACK-GROUP*"
+ "*MULTI-PROCESSING*" "ALL-PROCESSES"
+ "ATOMIC-DECF" "ATOMIC-INCF" "ATOMIC-POP"
+ "ATOMIC-PUSH" "CURRENT-PROCESS"
+ "DESTROY-PROCESS" "DISABLE-PROCESS"
+ "ENABLE-PROCESS" "INIT-STACK-GROUPS"
+ "LOCK" "MAKE-STACK-GROUP" "MAKE-LOCK"
+ "MAKE-PROCESS" "PROCESS-ACTIVE-P" "PROCESS-ALIVE-P"
+ "PROCESS-IDLE-TIME" "PROCESS-INTERRUPT"
+ "PROCESS-NAME" "PROCESS-PRESET"
+ "PROCESS-REAL-TIME" "PROCESS-RUN-TIME"
+ "PROCESS-STATE" "PROCESS-WAIT-UNTIL-FD-USABLE"
+ "PROCESS-WAIT" "PROCESS-WAIT-WITH-TIMEOUT"
+ "PROCESS-WHOSTATE" "PROCESS-YIELD" "PROCESSP"
+ "RESTART-PROCESS" "SHOW-PROCESSES"
+ "STACK-GROUP-RESUME" "WITHOUT-SCHEDULING"
+ "WITH-LOCK-HELD"))
+
+ #s(sb-cold:package-data
+ :name "SB!PCL"
+ :doc
+"semi-public: This package includes useful meta-object protocol
+extensions, but even they are not guaranteed to be present in
+later versions of SBCL, and the other stuff in here is
+definitely not guaranteed to be present in later versions of SBCL."
+ :use ("CL" "SB!ITERATE" "SB!WALKER")
+ :import-from (("SB!KERNEL" "FUNCALLABLE-INSTANCE-P" "SB!INT" "SB!EXT"))
+ :reexport ("ADD-METHOD" "ALLOCATE-INSTANCE"
+ "COMPUTE-APPLICABLE-METHODS"
+ "ENSURE-GENERIC-FUNCTION"
+ "MAKE-INSTANCE" "METHOD-QUALIFIERS"
+ "REMOVE-METHOD")
+ :export ("ADD-DEPENDENT"
+ "ADD-DIRECT-METHOD"
+ "ADD-DIRECT-SUBCLASS"
+ "CLASS-DEFAULT-INITARGS"
+ "CLASS-DIRECT-DEFAULT-INITARGS"
+ "CLASS-DIRECT-SLOTS"
+ "CLASS-DIRECT-SUBCLASSES"
+ "CLASS-DIRECT-SUPERCLASSES"
+ "CLASS-FINALIZED-P"
+ "CLASS-PRECEDENCE-LIST"
+ "CLASS-PROTOTYPE"
+ "CLASS-SLOTS"
+ "COMPUTE-APPLICABLE-METHODS-USING-CLASSES"
+ "COMPUTE-CLASS-PRECEDENCE-LIST"
+ "COMPUTE-DISCRIMINATING-FUNCTION"
+ "COMPUTE-EFFECTIVE-METHOD"
+ "COMPUTE-EFFECTIVE-SLOT-DEFINITION"
+ "COMPUTE-SLOTS"
+ "DIRECT-SLOT-DEFINITION-CLASS"
+ "EFFECTIVE-SLOT-DEFINITION-CLASS"
+ "ENSURE-CLASS"
+ "ENSURE-CLASS-USING-CLASS"
+ "ENSURE-GENERIC-FUNCTION-USING-CLASS"
+ "EQL-SPECIALIZER-INSTANCE"
+ "EXTRACT-LAMBDA-LIST"
+ "EXTRACT-SPECIALIZER-NAMES"
+ "FINALIZE-INHERITANCE"
+ "FIND-METHOD-COMBINATION"
+ "FUNCALLABLE-STANDARD-INSTANCE-ACCESS"
+ "GENERIC-FUNCTION-ARGUMENT-PRECEDENCE-ORDER"
+ "GENERIC-FUNCTION-DECLARATIONS"
+ "GENERIC-FUNCTION-LAMBDA-LIST"
+ "GENERIC-FUNCTION-METHOD-CLASS"
+ "GENERIC-FUNCTION-METHOD-COMBINATION"
+ "GENERIC-FUNCTION-METHODS"
+ "GENERIC-FUNCTION-NAME"
+ "INTERN-EQL-SPECIALIZER"
+ "MAKE-METHOD-LAMBDA"
+ "MAP-DEPENDENTS"
+ "METHOD-FUNCTION"
+ "METHOD-GENERIC-FUNCTION"
+ "METHOD-LAMBDA-LIST"
+ "METHOD-SPECIALIZERS"
+ "ACCESSOR-METHOD-SLOT-DEFINITION"
+ "READER-METHOD-CLASS"
+ "REMOVE-DEPENDENT"
+ "REMOVE-DIRECT-METHOD"
+ "REMOVE-DIRECT-SUBCLASS"
+ "SET-FUNCALLABLE-INSTANCE-FUNCTION"
+ "SLOT-BOUNDP-USING-CLASS"
+ "SLOT-DEFINITION-ALLOCATION"
+ "SLOT-DEFINITION-INITARGS"
+ "SLOT-DEFINITION-INITFORM"
+ "SLOT-DEFINITION-INITFUNCTION"
+ "SLOT-DEFINITION-LOCATION"
+ "SLOT-DEFINITION-NAME"
+ "SLOT-DEFINITION-READERS"
+ "SLOT-DEFINITION-WRITERS"
+ "SLOT-DEFINITION-TYPE"
+ "SLOT-MAKUNBOUND-USING-CLASS"
+ "SLOT-VALUE-USING-CLASS"
+ "SPECIALIZER-DIRECT-GENERIC-FUNCTION"
+ "SPECIALIZER-DIRECT-METHODS"
+ "STANDARD-INSTANCE-ACCESS"
+ "UPDATE-DEPENDENT"
+ "VALIDATE-SUPERCLASS"
+ "WRITER-METHOD-CLASS"))
+
+ #s(sb-cold:package-data
+ :name "SB!PRETTY"
+ :doc "private: implementation of pretty-printing"
+ :use ("CL" "SB!EXT" "SB!INT" "SB!KERNEL")
+ :export ("PRETTY-STREAM" "PRETTY-STREAM-P" "!PPRINT-COLD-INIT"))
+
+ #s(sb-cold:package-data
+ :name "SB!PROFILE"
+ :doc "public: the interface to the profiler"
+ :use ("CL" "SB!EXT" "SB!INT" "SB!KERNEL")
+ :export ("PROFILE" "REPORT" "RESET" "UNPROFILE"))
+
+ #s(sb-cold:package-data
+ :name "SB!SYS"
+ :doc
+"private: In theory, this \"contains functions and information
+necessary for system interfacing\" (said cmu-user.tex at the time
+of the SBCL code fork). That probably was and is a good idea, but in
+practice, the distinctions between this package and SB-KERNEL
+and even SB-VM have become somewhat blurred over the years."
+ :use ("CL" "SB!EXT" "SB!INT")
+ :export ("%ASSEMBLER-CODE-TYPE" "%BIND-ALIGNED-SAP"
+ ;; FIXME: %PRIMITIVE shouldn't be here. (I now know that %SYS
+ ;; is for OS-dependent stuff. %PRIMITIVE should probably be in
+ ;; SB!KERNEL.)
+ "%PRIMITIVE" "%SP-BYTE-BLT" "%SP-FIND-CHARACTER"
+ "%SP-FIND-CHARACTER-WITH-ATTRIBUTE"
+ "%SP-REVERSE-FIND-CHARACTER-WITH-ATTRIBUTE"
+ "%STANDARD-CHAR-P"
+ "*BEEP-FUNCTION*"
+ "*LONG-SITE-NAME*" "*SHORT-SITE-NAME*"
+ "*STDERR*" "*STDIN*"
+ "*STDOUT*" "*TASK-DATA*"
+ "*TASK-NOTIFY*" "*TASK-SELF*" "*TTY*" "*TYPESCRIPTPORT*"
+ "ADD-FD-HANDLER" "ADD-PORT-DEATH-HANDLER"
+ "ADD-PORT-OBJECT"
+ "ALLOCATE-SYSTEM-MEMORY"
+ "BEEP" "BITS" "STRUCTURE!OBJECT"
+ "STRUCTURE!OBJECT-MAKE-LOAD-FORM"
+ "BYTES" "C-PROCEDURE" "CHECK<=" "CHECK="
+ "COMPILER-VERSION"
+ "DEALLOCATE-SYSTEM-MEMORY"
+ "DEFAULT-INTERRUPT" "DEFENUMERATION"
+ "DEFOPERATOR" "DEFRECORD"
+ "DEPORT-BOOLEAN" "DEPORT-INTEGER"
+ "DO-DO-BODY" "DOUBLE-FLOAT-RADIX"
+ "ENABLE-INTERRUPT" "ENUMERATION"
+ "FD-STREAM" "FD-STREAM-FD"
+ "FD-STREAM-P" "FIND-IF-IN-CLOSURE"
+ "FOREIGN-SYMBOL-ADDRESS" "FOREIGN-SYMBOL-ADDRESS-AS-INTEGER"
+ "GET-PAGE-SIZE" "GET-SYSTEM-INFO"
+ "IGNORE-INTERRUPT"
+ "INT-SAP" "INVALIDATE-DESCRIPTOR" "IO-TIMEOUT"
+ "LISP-STREAM" "LONG-FLOAT-RADIX" "LONG-WORDS"
+ "MACRO" "MAKE-FD-STREAM" "MAKE-OBJECT-SET" "MAP-PORT"
+ "NATURALIZE-BOOLEAN" "NATURALIZE-INTEGER"
+ "NULL-TERMINATED-STRING" "OBJECT-SET-OPERATION"
+ "OS-COLD-INIT-OR-REINIT" "OS-CONTEXT-T" "OUTPUT-RAW-BYTES"
+ "PARSE-BODY" "PERQ-STRING" "POINTER"
+ "POINTER<" "POINTER>" "PORT" "POSITIVE-PRIMEP" "PUSH-USING-SETQ"
+ "READ-N-BYTES" "REALLOCATE-SYSTEM-MEMORY" "RECORD-SIZE"
+ "REMOVE-FD-HANDLER" "REMOVE-PORT-DEATH-HANDLER"
+ "REMOVE-PORT-OBJECT"
+ "RESOLVE-LOADED-ASSEMBLER-REFERENCES"
+ "SAP+" "SAP-" "SAP-INT" "SAP-INT-TYPE"
+ "SAP-REF-16" "SAP-REF-32" "SAP-REF-64" "SAP-REF-8"
+ "SAP-REF-DESCRIPTOR"
+ "SAP-REF-DOUBLE" "SAP-REF-LONG"
+ "SAP-REF-SAP" "SAP-REF-SINGLE"
+ "SAP<" "SAP<=" "SAP=" "SAP>" "SAP>="
+ "SCRUB-CONTROL-STACK" "SERVE-ALL-EVENTS"
+ "SERVE-EVENT" "SERVER" "SERVER-MESSAGE"
+ "SHORT-FLOAT-RADIX"
+ "SIGNED-SAP-REF-16" "SIGNED-SAP-REF-32"
+ "SIGNED-SAP-REF-64" "SIGNED-SAP-REF-8"
+ "SINGLE-FLOAT-RADIX" "SYMBOL-MACRO-LET"
+ "SYSTEM-AREA-POINTER" "SYSTEM-AREA-POINTER-P" "VECTOR-SAP"
+ "WAIT-UNTIL-FD-USABLE" "WITH-ENABLED-INTERRUPTS"
+ "WITH-FD-HANDLER"
+ "WITH-INTERRUPTS" "WITH-REPLY-PORT" "WITHOUT-GCING"
+ "WITHOUT-INTERRUPTS" "WORDS"
+ "ALLOCATE-SYSTEM-MEMORY-AT"
+ "GET-DYNAMIC-FOREIGN-SYMBOL-ADDRESS"))
+
+ #s(sb-cold:package-data
+ :name "SB!UNIX"
+ :doc
+"private: a wrapper layer for SBCL itself to use when talking
+with an underlying Unix-y operating system.
+This was a public package in CMU CL, but that was different.
+CMU CL's UNIX package tried to provide a comprehensive,
+stable Unix interface suitable for the end user.
+This package only tries to implement what happens to be
+needed by the current implementation of SBCL, and makes
+no guarantees of interface stability."
+ :use ("CL" "SB!ALIEN" "SB!C-CALL" "SB!SYS" "SB!EXT" "SB!INT")
+ :export ("CADDR-T" "D-INO" "D-NAME" "D-NAMLEN" "D-OFF" "D-RECLEN"
+ "DADDR-T" "DEV-T" "DIRECT" "EXECGRP" "EXECOTH" "EXECOWN" "F-DUPFD"
+ "F-GETFD" "F-GETFL" "F-GETOWN" "F-SETFD" "F-SETFL" "F-SETOWN"
+ "FAPPEND" "FASYNC" "FCREAT" "FEXCL" "FIONREAD" "FNDELAY" "FTRUNC"
+ "F_OK" "GET-UNIX-ERROR-MSG" "GET-ERRNO" "GID-T"
+ "INO-T" "IT-INTERVAL" "IT-VALUE"
+ "ITIMERVAL" "UNIX-SETITIMER" "UNIX-GETITIMER"
+ "KBDCGET" "KBDCRESET" "KBDCRST" "KBDCSET"
+ "KBDCSSTD" "KBDGCLICK" "KBDSCLICK" "KBDSGET" "L_INCR" "L_SET"
+ "L_XTND" "OFF-T" "O_APPEND" "O_CREAT" "O_EXCL" "O_RDONLY" "O_RDWR"
+ "O_TRUNC" "O_WRONLY" "READGRP" "READOTH" "READOWN" "RLIM-CUR"
+ "RLIM-MAX" "RLIMIT" "RU-IDRSS" "RU-INBLOCK" "RU-ISRSS" "RU-IXRSS"
+ "RU-MAJFLT" "RU-MAXRSS" "RU-MINFLT" "RU-MSGRCV" "RU-MSGSND"
+ "RU-NIVCSW" "RU-NSIGNALS" "RU-NSWAP" "RU-NVCSW" "RU-OUBLOCK"
+ "RU-STIME" "RU-UTIME" "RUSAGE_CHILDREN" "RUSAGE_SELF" "RUSEAGE"
+ "R_OK" "S-IEXEC" "S-IFBLK" "S-IFCHR" "S-IFDIR" "S-IFLNK" "S-IFMT"
+ "S-IFREG" "S-IFSOCK" "S-IREAD" "S-ISGID" "S-ISUID" "S-ISVTX"
+ "S-IWRITE" "SAVETEXT" "SC-MASK" "SC-ONSTACK" "SC-PC" "SETGIDEXEC"
+ "SETUIDEXEC" "SG-ERASE" "SG-FLAGS" "SG-ISPEED" "SG-KILL"
+ "SG-OSPEED" "SGTTYB" "SIZE-T" "ST-ATIME" "ST-BLKSIZE"
+ "ST-BLOCKS" "ST-CTIME" "ST-DEV" "ST-GID" "ST-MODE" "ST-MTIME"
+ "ST-NLINK" "ST-RDEV" "ST-SIZE" "ST-UID" "STAT" "SWBLK-T" "T-BRKC"
+ "T-DSUSPC" "T-EOFC" "T-FLUSHC" "T-INTRC" "T-LNEXTC" "T-QUITC"
+ "T-RPRNTC" "T-STARTC" "T-STOPC" "T-SUSPC" "T-WERASC" "TCHARS"
+ "TERMINAL-SPEEDS" "TIME-T" "TIMEVAL" "TIMEZONE" "TIOCFLUSH"
+ "TIOCGETC" "TIOCGETP" "TIOCGLTC" "TIOCGPGRP" "TIOCGWINSZ"
+ "TIOCNOTTY" "TIOCSETC" "TIOCSETP" "TIOCSLTC" "TIOCSPGRP"
+ "TIOCSWINSZ" "TTY-CBREAK" "TTY-CRMOD" "TTY-LCASE"
+ "TTY-RAW" "TTY-TANDEM" "TV-SEC" "TV-USEC" "TZ-DSTTIME"
+ "TZ-MINUTESWEST" "UID-T" "UNIX-ACCEPT" "UNIX-ACCESS" "UNIX-BIND"
+ "UNIX-CHDIR" "UNIX-CHMOD" "UNIX-CHOWN" "UNIX-CLOSE" "UNIX-CONNECT"
+ "UNIX-CREAT" "UNIX-CURRENT-DIRECTORY" "UNIX-DUP" "UNIX-DUP2"
+ "UNIX-EXECVE" "UNIX-EXIT" "UNIX-FCHMOD" "UNIX-FCHOWN"
+ "UNIX-FCNTL" "UNIX-FD" "UNIX-FILE-MODE" "UNIX-FORK" "UNIX-FSTAT"
+ "UNIX-FSYNC" "UNIX-FTRUNCATE" "UNIX-GETDTABLESIZE" "UNIX-GETEGID"
+ "UNIX-GETGID" "UNIX-GETHOSTID" "UNIX-GETHOSTNAME"
+ "UNIX-GETPAGESIZE" "UNIX-GETPEERNAME" "UNIX-GETPGRP"
+ "UNIX-GETPID" "UNIX-GETPPID" "UNIX-GETRUSAGE"
+ "UNIX-GETSOCKNAME" "UNIX-GETTIMEOFDAY" "UNIX-GETUID" "UNIX-GID"
+ "UNIX-IOCTL" "UNIX-ISATTY" "UNIX-LINK" "UNIX-LISTEN" "UNIX-LSEEK"
+ "UNIX-LSTAT" "UNIX-MKDIR" "UNIX-OPEN" "UNIX-PATHNAME" "UNIX-PID"
+ "UNIX-PIPE" "UNIX-READ" "UNIX-READLINK" "UNIX-RECV" "UNIX-RENAME"
+ "UNIX-RMDIR" "UNIX-SELECT" "UNIX-SEND" "UNIX-SETPGRP"
+ "UNIX-SETREGID" "UNIX-SETREUID" "UNIX-SOCKET" "UNIX-STAT"
+ "UNIX-SYMLINK" "UNIX-SYNC"
+ "UNIX-TIMES" "UNIX-TRUNCATE" "UNIX-TTYNAME"
+ "UNIX-UID" "UNIX-UNLINK" "UNIX-UTIMES" "UNIX-WRITE" "WINSIZE"
+ "WRITEGRP" "WRITEOTH" "WRITEOWN" "WS-COL" "WS-ROW" "WS-XPIXEL"
+ "WS-YPIXEL" "W_OK" "X_OK" "SIGSYS" "TCSETPGRP" "FD-ZERO"
+ "SIGEMSG" "SIGQUIT" "SIGCHLD" "SIGSEGV" "FD-CLR" "SIGUSR2"
+ "EALREADY" "SIGPIPE" "EACCES" "CHECK" "SIGXCPU" "EOPNOTSUPP"
+ "SIGFPE" "SIGHUP" "ENOTSOCK" "OPEN-DIR" "SIGMASK" "EINTR"
+ "SIGCONT" "UNIX-RESOLVE-LINKS" "SIGKILL" "EMSGSIZE" "ERANGE"
+ "EPROTOTYPE" "UNIX-SIGNAL-NUMBER" "EPFNOSUPPORT" "SIGILL"
+ "EDOM" "UNIX-SIGPAUSE" "EDQUOT" "FD-SETSIZE" "SIGTSTP"
+ "EAFNOSUPPORT" "TCGETPGRP" "EMFILE" "ECONNRESET"
+ "EADDRNOTAVAIL" "SIGALRM" "ENETDOWN" "EVICEOP"
+ "UNIX-FAST-GETRUSAGE" "EPERM" "SIGINT" "EXDEV" "EDEADLK"
+ "ENOSPC" "ECONNREFUSED" "SIGWINCH" "ENOPROTOOPT" "ESRCH"
+ "EUSERS" "SIGVTALRM" "ENOTCONN" "ESUCCESS" "EPIPE"
+ "UNIX-SIMPLIFY-PATHNAME" "EISCONN" "FD-ISSET" "SIGMSG"
+ "ESHUTDOWN" "EBUSY" "SIGTERM" "ENAMETOOLONG" "EMLINK"
+ "EADDRINUSE" "SIGBUS" "ERESTART" "TTY-PROCESS-GROUP"
+ "UNIX-SIGNAL-NAME" "ETIMEDOUT" "ECHILD" "EFBIG" "SIGTRAP"
+ "UNIX-KILLPG" "ENOTBLK" "SIGIOT" "SIGUSR1" "ECONNABORTED"
+ "EHOSTUNREACH" "EBADF" "EINVAL" "FD-SET" "CLOSE-DIR" "EISDIR"
+ "SIGTTIN" "UNIX-KILL" "ENOTDIR" "EHOSTDOWN" "E2BIG" "ESPIPE"
+ "UNIX-FAST-SELECT" "ENXIO" "ENOTTY" "ELOOP" "LTCHARS"
+ "UNIX-SIGNAL-DESCRIPTION" "SIGXFSZ" "EINPROGRESS" "ENOENT"
+ "EPROTONOSUPPORT" "UNIX-SIGBLOCK" "SIGIO" "ENOMEM" "SIGEMT"
+ "EFAULT" "ENODEV" "EIO" "EVICEERR" "ETXTBSY" "EWOULDBLOCK"
+ "EAGAIN" "EDESTADDRREQ" "ENOEXEC" "ENETUNREACH" "ENOTEMPTY"
+ "READ-DIR" "UNIX-MAYBE-PREPEND-CURRENT-DIRECTORY" "ENFILE"
+ "SIGTTOU" "EEXIST" "SIGPROF" "SIGSTOP" "ENETRESET" "SIGURG"
+ "ENOBUFS" "EPROCLIM" "EROFS" "ETOOMANYREFS" "UNIX-FILE-KIND"
+ "ELOCAL" "UNIX-SIGSETMASK" "EREMOTE" "ESOCKTNOSUPPORT"
+ "TIOCSIGSEND" "SIGWAITING"
+ "C-IFLAG" "UNIX-TCGETATTR" "C-LFLAG" "C-OFLAG"
+ "C-CFLAG" "TCSAFLUSH" "C-CC" "SIOCSPGRP" "TERMIOS"
+ "UNIX-TCSETATTR" "O_NDELAY" "O_NOCTTY"
+ "O_NONBLOCK" "TCSANOW" "TCSADRAIN" "TCIFLUSH" "TCOFLUSH"
+ "TCIOFLUSH" "UNIX-CFGETOSPEED" "UNIX-CFSETOSPEED"
+ "UNIX-CFGETISPEED" "UNIX-CFSETISPEED"
+ "TTY-IGNBRK" "TTY-BRKINT" "TTY-IGNPAR" "TTY-PARMRK"
+ "TTY-INPCK" "TTY-ISTRIP" "TTY-INLCR" "TTY-IGNCR" "TTY-ICRNL"
+ "TTY-IUCLC" "TTY-IXON" "TTY-IXANY" "TTY-IXOFF" "TTY-IENQAK"
+ "TTY-IMAXBEL" "TTY-OPOST" "TTY-OLCUC" "TTY-ONLCR" "TTY-OCRNL"
+ "TTY-ONOCR" "TTY-ONLRET" "TTY-OFILL" "TTY-OFDEL" "TTY-ISIG"
+ "TTY-ICANON" "TTY-XCASE" "TTY-ECHO" "TTY-ECHOE" "TTY-ECHOK"
+ "TTY-ECHONL" "TTY-NOFLSH" "TTY-IEXTEN" "TTY-TOSTOP" "TTY-ECHOCTL"
+ "TTY-ECHOPRT" "TTY-ECHOKE" "TTY-DEFECHO" "TTY-FLUSHO"
+ "TTY-PENDIN" "TTY-CSTOPB" "TTY-CREAD" "TTY-PARENB" "TTY-PARODD"
+ "TTY-HUPCL" "TTY-CLOCAL" "RCV1EN" "XMT1EN" "TTY-LOBLK" "VINTR"
+ "VQUIT" "VERASE" "VKILL" "VEOF" "VEOL" "VEOL2" "TTY-CBAUD"
+ "TTY-CSIZE" "TTY-CS5" "TTY-CS6" "TTY-CS7" "TTY-CS8" "VMIN" "VTIME"
+ "VSUSP" "VSTART" "VSTOP" "VDSUSP" "UNIX-TCSENDBREAK"
+ "UNIX-TCDRAIN" "UNIX-TCFLUSH" "UNIX-TCFLOW"
+ #!+(or svr4 bsd linux) "O_NDELAY"
+ #!+(or svr4 linux) ("EADDRINUSE" "EADDRNOTAVAIL" "EADV"
+ "EAFNOSUPPORT" "EALREADY" "EBADE" "EBADFD"
+ "EBADMSG" "EBADR" "EBADRQC"
+ "EBADSLT" "EBFONT" #!+svr4 "ECANCELED"
+ "ECHRNG" "ECOMM" "ECONNABORTED"
+ "ECONNREFUSED" "ECONNRESET" "EDEADLK"
+ "EDEADLOCK" "EDESTADDRREQ" #!+linux "EDOTDOT"
+ #!+linux "EDQUOT" "EHOSTDOWN" "EHOSTUNREACH"
+ "EIDRM" "EILSEQ" "EINPROGRESS"
+ "EISCONN" #!+linux "EISNAM" "EL2HLT"
+ "EL2NSYNC" "EL3HLT" "EL3RST" "ELIBACC"
+ "ELIBBAD" "ELIBEXEC" "ELIBMAX" "ELIBSCN"
+ "ELNRNG" "ELOOP" "EMSGSIZE" "EMULTIHOP"
+ "ENAMETOOLONG" #!+linux "ENAVAIL"
+ "ENETDOWN" "ENETRESET" "ENETUNREACH" "ENOANO"
+ "ENOBUFS" "ENOCSI" "ENODATA" "ENOLCK"
+ "ENOLINK" "ENOMSG" "ENONET" "ENOPKG"
+ "ENOPROTOOPT" "ENOSR" "ENOSTR" "ENOSYS"
+ "ENOTCONN" "ENOTEMPTY" #!+linux "ENOTNAM"
+ "ENOTSOCK" #!+svr4 "ENOTSUP" "ENOTUNIQ"
+ "EOPNOTSUPP" "EOVERFLOW" "EPFNOSUPPORT"
+ "EPROTO" "EPROTONOSUPPORT" "EPROTOTYPE"
+ "EREMCHG" "EREMOTE" #!+linux "EREMOTEIO"
+ "ERESTART" "ESHUTDOWN" "ESOCKTNOSUPPORT"
+ "ESRMNT" "ESTALE" "ESTRPIPE" "ETIME"
+ "ETIMEDOUT" "ETOOMANYREFS" #!+linux "EUCLEAN"
+ "EUNATCH" "EUSERS" "EWOULDBLOCK" "EXFULL")))
+
+ #s(sb-cold:package-data
+ :name "SB!VM"
+ :doc
+"internal: the default place to hide information about the hardware and data
+structure representations"
+ :use ("CL" "SB!ALIEN" "SB!ALIEN-INTERNALS" "SB!ASSEM"
+ "SB!C" "SB!C-CALL" "SB!EXT" "SB!INT" "SB!KERNEL" "SB!SYS" "SB!UNIX")
+ :export ("*ASSEMBLY-UNIT-LENGTH*" "*PRIMITIVE-OBJECTS*"
+ "AFTER-BREAKPOINT-TRAP"
+ "ANY-REG-SC-NUMBER" "ARRAY-DATA-SLOT" "ARRAY-DIMENSIONS-OFFSET"
+ "ARRAY-DISPLACED-P-SLOT" "ARRAY-DISPLACEMENT-SLOT"
+ "ARRAY-ELEMENTS-SLOT" "ARRAY-FILL-POINTER-P-SLOT"
+ "ARRAY-FILL-POINTER-SLOT" "ATOMIC-FLAG" "BASE-CHAR-REG-SC-NUMBER"
+ "BASE-CHAR-STACK-SC-NUMBER" "BASE-CHAR-TYPE"
+ "BIGNUM-DIGITS-OFFSET" "BIGNUM-TYPE" "BINDING-SIZE"
+ "BINDING-SYMBOL-SLOT" "BINDING-VALUE-SLOT" "BREAKPOINT-TRAP"
+ "BYTE-CODE-CLOSURE-TYPE" "BYTE-CODE-FUNCTION-TYPE"
+ "BYTE-BITS" "BYTE-REG-SC-NUMBER"
+ "CATCH-BLOCK-CURRENT-CODE-SLOT"
+ "CATCH-BLOCK-CURRENT-CONT-SLOT" "CATCH-BLOCK-CURRENT-UWP-SLOT"
+ "CATCH-BLOCK-ENTRY-PC-SLOT" "CATCH-BLOCK-PREVIOUS-CATCH-SLOT"
+ "CATCH-BLOCK-SC-NUMBER" "CATCH-BLOCK-SIZE" "CATCH-BLOCK-SIZE-SLOT"
+ "CATCH-BLOCK-TAG-SLOT" "CERROR-TRAP"
+ "CLOSURE-FUNCTION-HEADER-TYPE" "CLOSURE-FUNCTION-SLOT"
+ "CLOSURE-HEADER-TYPE" "CLOSURE-INFO-OFFSET"
+ "CODE-CODE-SIZE-SLOT" "CODE-CONSTANTS-OFFSET"
+ "CODE-DEBUG-INFO-SLOT" "CODE-ENTRY-POINTS-SLOT" "CODE-HEADER-TYPE"
+ "CODE-TRACE-TABLE-OFFSET-SLOT" "COMPLEX-ARRAY-TYPE"
+ "COMPLEX-BIT-VECTOR-TYPE" "COMPLEX-DOUBLE-FLOAT-FILLER-SLOT"
+ "COMPLEX-DOUBLE-FLOAT-IMAG-SLOT" "COMPLEX-DOUBLE-FLOAT-REAL-SLOT"
+ "COMPLEX-DOUBLE-FLOAT-SIZE" "COMPLEX-DOUBLE-FLOAT-TYPE"
+ "COMPLEX-DOUBLE-REG-SC-NUMBER" "COMPLEX-DOUBLE-STACK-SC-NUMBER"
+ "COMPLEX-IMAG-SLOT" "COMPLEX-REAL-SLOT"
+ "COMPLEX-LONG-FLOAT-IMAG-SLOT" "COMPLEX-LONG-FLOAT-REAL-SLOT"
+ "COMPLEX-LONG-FLOAT-SIZE" "COMPLEX-LONG-FLOAT-TYPE"
+ "COMPLEX-LONG-REG-SC-NUMBER" "COMPLEX-LONG-STACK-SC-NUMBER"
+ "COMPLEX-SINGLE-FLOAT-IMAG-SLOT" "COMPLEX-SINGLE-FLOAT-REAL-SLOT"
+ "COMPLEX-SINGLE-FLOAT-SIZE" "COMPLEX-SINGLE-FLOAT-TYPE"
+ "COMPLEX-SINGLE-REG-SC-NUMBER" "COMPLEX-SINGLE-STACK-SC-NUMBER"
+ "COMPLEX-SIZE" "COMPLEX-STRING-TYPE" "COMPLEX-TYPE"
+ "COMPLEX-VECTOR-TYPE" "CONS-CAR-SLOT" "CONS-CDR-SLOT"
+ "CONS-SIZE" "CONSTANT-SC-NUMBER"
+ "CONTEXT-FLOATING-POINT-MODES" "CONTEXT-FLOAT-REGISTER"
+ "CONTEXT-PC" "CONTEXT-REGISTER"
+ "CONTROL-STACK-FORK" "CONTROL-STACK-RESUME"
+ "CONTROL-STACK-RETURN" "CONTROL-STACK-SC-NUMBER" "COUNT-NO-OPS"
+ "CURRENT-FLOAT-TRAP" "DEFINE-FOR-EACH-PRIMITIVE-OBJECT"
+ "DESCRIPTOR-REG-SC-NUMBER" "DESCRIPTOR-VS-NON-DESCRIPTOR-STORAGE"
+ "DOUBLE-FLOAT-EXPONENT-BYTE" "DOUBLE-FLOAT-BIAS"
+ "DOUBLE-FLOAT-DIGITS" "DOUBLE-FLOAT-EXPONENT-BYTE"
+ "DOUBLE-FLOAT-FILLER-SLOT" "DOUBLE-FLOAT-HIDDEN-BIT"
+ "DOUBLE-FLOAT-NORMAL-EXPONENT-MAX"
+ "DOUBLE-FLOAT-NORMAL-EXPONENT-MIN" "DOUBLE-FLOAT-SIGNIFICAND-BYTE"
+ "DOUBLE-FLOAT-SIZE" "DOUBLE-FLOAT-TRAPPING-NAN-BIT"
+ "DOUBLE-FLOAT-TYPE" "DOUBLE-FLOAT-VALUE-SLOT"
+ "DOUBLE-INT-CARG-REG-SC-NUMBER" "DOUBLE-REG-SC-NUMBER"
+ "DOUBLE-STACK-SC-NUMBER"
+ "ERROR-TRAP" "EVEN-FIXNUM-TYPE"
+ "EXPORTED-STATIC-SYMBOLS" "EXTERN-ALIEN-NAME"
+ "FDEFN-FUNCTION-SLOT" "FDEFN-NAME-SLOT" "FDEFN-RAW-ADDR-SLOT"
+ "FDEFN-SIZE" "FDEFN-TYPE" "FIND-HOLES" "FIXNUMIZE"
+ "FIXUP-CODE-OBJECT" "FLOAT-DENORMAL-TRAP-BIT"
+ "FLOAT-DIVIDE-BY-ZERO-TRAP-BIT"
+ "FLOAT-IMPRECISE-TRAP-BIT" "FLOAT-INVALID-TRAP-BIT"
+ "FLOAT-OVERFLOW-TRAP-BIT" "FLOAT-SIGN-SHIFT"
+ "FLOAT-UNDERFLOW-TRAP-BIT" "FLOATING-POINT-MODES"
+ "FORWARDING-POINTER-TYPE"
+ "FP-CONSTANT-SC-NUMBER"
+ "FP-DOUBLE-ZERO-SC-NUMBER" "FP-SINGLE-ZERO-SC-NUMBER"
+ "FUNCALLABLE-INSTANCE-FUNCTION-SLOT"
+ "FUNCALLABLE-INSTANCE-HEADER-TYPE"
+ "FUNCALLABLE-INSTANCE-INFO-OFFSET"
+ "FUNCTION-ARGLIST-SLOT" "FUNCTION-CODE-OFFSET"
+ "FUNCTION-END-BREAKPOINT-TRAP" "FUNCTION-HEADER-ARGLIST-SLOT"
+ "FUNCTION-HEADER-CODE-OFFSET" "FUNCTION-HEADER-NAME-SLOT"
+ "FUNCTION-HEADER-NEXT-SLOT" "FUNCTION-HEADER-SELF-SLOT"
+ "FUNCTION-HEADER-TYPE" "FUNCTION-HEADER-TYPE-SLOT"
+ "FUNCTION-NAME-SLOT" "FUNCTION-NEXT-SLOT" "FUNCTION-POINTER-TYPE"
+ "FUNCTION-SELF-SLOT" "FUNCTION-TYPE-SLOT"
+ "FUNCALLABLE-INSTANCE-LAYOUT-SLOT"
+ "FUNCALLABLE-INSTANCE-LEXENV-SLOT"
+ "GENESIS" "HALT-TRAP" "IGNORE-ME-SC-NUMBER"
+ "IMMEDIATE-BASE-CHAR-SC-NUMBER" "IMMEDIATE-SAP-SC-NUMBER"
+ "IMMEDIATE-SC-NUMBER"
+ "INSTANCE-HEADER-TYPE" "INSTANCE-POINTER-TYPE"
+ "INSTANCE-SLOTS-OFFSET" "INSTANCE-USAGE"
+ "INTERIOR-REG-SC-NUMBER" "INTERNAL-ERROR-ARGUMENTS"
+ "INTERRUPTED-FLAG" "LIST-ALLOCATED-OBJECTS" "LIST-POINTER-TYPE"
+ "LONG-FLOAT-BIAS" "LONG-FLOAT-DIGITS" "LONG-FLOAT-EXPONENT-BYTE"
+ "LONG-FLOAT-HIDDEN-BIT" "LONG-FLOAT-NORMAL-EXPONENT-MAX"
+ "LONG-FLOAT-NORMAL-EXPONENT-MIN" "LONG-FLOAT-SIGNIFICAND-BYTE"
+ "LONG-FLOAT-SIZE" "LONG-FLOAT-TRAPPING-NAN-BIT" "LONG-FLOAT-TYPE"
+ "LONG-FLOAT-VALUE-SLOT" "LONG-REG-SC-NUMBER"
+ "LONG-STACK-SC-NUMBER"
+ "LOWTAG-BITS" "LOWTAG-LIMIT" "LOWTAG-MASK"
+ "MEMORY-USAGE" "MOST-POSITIVE-COST"
+ "NEGATIVE-IMMEDIATE-SC-NUMBER" "NON-DESCRIPTOR-REG-SC-NUMBER"
+ "NULL-SC-NUMBER" "OBJECT-NOT-LIST-TRAP" "OBJECT-NOT-INSTANCE-TRAP"
+ "ODD-FIXNUM-TYPE" "OFFSET-STATIC-SYMBOL" "OTHER-IMMEDIATE-0-TYPE"
+ "OTHER-IMMEDIATE-1-TYPE" "OTHER-POINTER-TYPE"
+ "PAD-DATA-BLOCK" "PENDING-INTERRUPT-TRAP"
+ "PRIMITIVE-OBJECT" "PRIMITIVE-OBJECT-HEADER"
+ "PRIMITIVE-OBJECT-LOWTAG" "PRIMITIVE-OBJECT-NAME"
+ "PRIMITIVE-OBJECT-OPTIONS" "PRIMITIVE-OBJECT-P"
+ "PRIMITIVE-OBJECT-SIZE" "PRIMITIVE-OBJECT-SLOTS"
+ "PRIMITIVE-OBJECT-VARIABLE-LENGTH" "PRINT-ALLOCATED-OBJECTS"
+ "RANDOM-IMMEDIATE-SC-NUMBER" "RATIO-DENOMINATOR-SLOT"
+ "RATIO-NUMERATOR-SLOT" "RATIO-SIZE" "RATIO-TYPE"
+ "REGISTER-SAVE-PENALTY" "RETURN-PC-HEADER-TYPE"
+ "RETURN-PC-RETURN-POINT-OFFSET" "SANCTIFY-FOR-EXECUTION"
+ "SAP-POINTER-SLOT" "SAP-REG-SC-NUMBER" "SAP-SIZE"
+ "SAP-STACK-SC-NUMBER" "SAP-TYPE"
+ "SIGFPE-HANDLER" "SIGNED-REG-SC-NUMBER" "SIGNED-STACK-SC-NUMBER"
+ "SIMPLE-ARRAY-COMPLEX-DOUBLE-FLOAT-TYPE"
+ "SIMPLE-ARRAY-COMPLEX-LONG-FLOAT-TYPE"
+ "SIMPLE-ARRAY-COMPLEX-SINGLE-FLOAT-TYPE"
+ "SIMPLE-ARRAY-DOUBLE-FLOAT-TYPE"
+ "SIMPLE-ARRAY-LONG-FLOAT-TYPE"
+ "SIMPLE-ARRAY-SINGLE-FLOAT-TYPE"
+ "SIMPLE-ARRAY-TYPE" "SIMPLE-ARRAY-UNSIGNED-BYTE-16-TYPE"
+ "SIMPLE-ARRAY-UNSIGNED-BYTE-2-TYPE"
+ "SIMPLE-ARRAY-UNSIGNED-BYTE-32-TYPE"
+ "SIMPLE-ARRAY-UNSIGNED-BYTE-4-TYPE"
+ "SIMPLE-ARRAY-UNSIGNED-BYTE-8-TYPE"
+ "SIMPLE-ARRAY-SIGNED-BYTE-16-TYPE"
+ "SIMPLE-ARRAY-SIGNED-BYTE-30-TYPE"
+ "SIMPLE-ARRAY-SIGNED-BYTE-32-TYPE"
+ "SIMPLE-ARRAY-SIGNED-BYTE-8-TYPE"
+ "SIMPLE-BIT-VECTOR-TYPE"
+ "SIMPLE-STRING-TYPE" "SIMPLE-VECTOR-TYPE" "SINGLE-FLOAT-BIAS"
+ "SINGLE-FLOAT-DIGITS" "SINGLE-FLOAT-EXPONENT-BYTE"
+ "SINGLE-FLOAT-HIDDEN-BIT" "SINGLE-FLOAT-NORMAL-EXPONENT-MAX"
+ "SINGLE-FLOAT-NORMAL-EXPONENT-MIN" "SINGLE-FLOAT-SIGNIFICAND-BYTE"
+ "SINGLE-FLOAT-SIZE" "SINGLE-FLOAT-TRAPPING-NAN-BIT"
+ "SINGLE-FLOAT-TYPE" "SINGLE-FLOAT-VALUE-SLOT"
+ "SINGLE-INT-CARG-REG-SC-NUMBER"
+ "SINGLE-REG-SC-NUMBER" "SINGLE-STACK-SC-NUMBER"
+ "SINGLE-STEP-BREAKPOINT-TRAP"
+ "SINGLE-VALUE-RETURN-BYTE-OFFSET" "SLOT-DOCS"
+ "SLOT-LENGTH" "SLOT-NAME" "SLOT-OFFSET" "SLOT-OPTIONS"
+ "SLOT-REST-P" "*STATIC-FUNCTIONS*" "STATIC-FUNCTION-OFFSET"
+ "STATIC-SYMBOL-OFFSET" "STATIC-SYMBOL-P" "*STATIC-SYMBOLS*"
+ "STRUCTURE-USAGE" "SYMBOL-FUNCTION-SLOT"
+ "SYMBOL-HASH-SLOT" "SYMBOL-HEADER-TYPE" "SYMBOL-NAME-SLOT"
+ "SYMBOL-PACKAGE-SLOT" "SYMBOL-PLIST-SLOT"
+ "SYMBOL-RAW-FUNCTION-ADDR-SLOT" "SYMBOL-SETF-FUNCTION-SLOT"
+ "SYMBOL-SIZE" "SYMBOL-UNUSED-SLOT" "SYMBOL-VALUE-SLOT"
+ "TARGET-BINDING-STACK-START" "TARGET-BYTE-ORDER"
+ "TARGET-CONTROL-STACK-START" "*TARGET-DYNAMIC-SPACE-START*"
+ "TARGET-FASL-CODE-FORMAT" "TARGET-FASL-FILE-TYPE"
+ "TARGET-HEAP-ADDRESS-SPACE" "*TARGET-MOST-NEGATIVE-FIXNUM*"
+ "*TARGET-MOST-POSITIVE-FIXNUM*" "*TARGET-READ-ONLY-SPACE-START*"
+ "*TARGET-STATIC-SPACE-START*" "TRACE-TABLE-CALL-SITE"
+ "TRACE-TABLE-FUNCTION-EPILOGUE" "TRACE-TABLE-FUNCTION-PROLOGUE"
+ "TRACE-TABLE-NORMAL" "TYPE-BITS" "TYPE-MASK" "UNBOUND-MARKER-TYPE"
+ "UNSIGNED-IMMEDIATE-SC-NUMBER"
+ "UNSIGNED-REG-SC-NUMBER" "UNSIGNED-STACK-SC-NUMBER"
+ "UNWIND-BLOCK-CURRENT-CODE-SLOT" "UNWIND-BLOCK-CURRENT-CONT-SLOT"
+ "UNWIND-BLOCK-CURRENT-UWP-SLOT" "UNWIND-BLOCK-ENTRY-PC-SLOT"
+ "UNWIND-BLOCK-SIZE" "VALUE-CELL-HEADER-TYPE" "VALUE-CELL-SIZE"
+ "VALUE-CELL-VALUE-SLOT" "VECTOR-DATA-OFFSET" "VECTOR-LENGTH-SLOT"
+ "VECTOR-MUST-REHASH-SUBTYPE" "VECTOR-NORMAL-SUBTYPE"
+ "VECTOR-VALID-HASHING-SUBTYPE"
+ "WEAK-POINTER-BROKEN-SLOT" "WEAK-POINTER-NEXT-SLOT"
+ "WEAK-POINTER-SIZE" "WEAK-POINTER-TYPE" "WEAK-POINTER-VALUE-SLOT"
+ "WORD" "WORD-BITS" "WORD-BYTES" "WORD-REG-SC-NUMBER" "WORD-SHIFT"
+ "ZERO-SC-NUMBER"))
+
+ #s(sb-cold:package-data
+ :name "SB!WALKER"
+ :doc "internal: a code walker used by PCL"
+ :use ("CL")
+ :export ("DEFINE-WALKER-TEMPLATE" "WALK-FORM"
+ "*WALK-FORM-EXPAND-MACROS-P*" "NESTED-WALK-FORM"
+ "VARIABLE-LEXICAL-P" "VARIABLE-SPECIAL-P"
+ "VARIABLE-GLOBALLY-SPECIAL-P"
+ "*VARIABLE-DECLARATIONS*" "VARIABLE-DECLARATION"
+ "MACROEXPAND-ALL")))
--- /dev/null
+;;;; the extra code necessary to feed an entire file of assembly code
+;;;; to the assembler
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!C")
+
+(file-comment
+ "$Header$")
+\f
+(defvar *do-assembly* nil
+ #!+sb-doc "If non-NIL, emit assembly code. If NIL, emit VOP templates.")
+
+(defvar *lap-output-file* nil
+ #!+sb-doc "the FASL file currently being output to")
+
+(defvar *entry-points* nil
+ #!+sb-doc "a list of (name . label) for every entry point")
+
+(defvar *assembly-optimize* t
+ #!+sb-doc
+ "Set this to NIL to inhibit assembly-level optimization. For compiler
+ debugging, rather than policy control.")
+
+;;; Note: You might think from the name that this would act like COMPILE-FILE,
+;;; but in fact it's arguably more like LOAD, even down to the return
+;;; convention. It LOADs a file, then writes out any assembly code created
+;;; by the process.
+(defun assemble-file (name
+ &key
+ (output-file (make-pathname :defaults name
+ :type "assem")))
+ ;; FIXME: Consider nuking the filename defaulting logic here.
+ (let* ((*do-assembly* t)
+ (name (pathname name))
+ (*lap-output-file* (open-fasl-file (pathname output-file) name))
+ (*entry-points* nil)
+ (won nil)
+ (*code-segment* nil)
+ (*elsewhere* nil)
+ (*assembly-optimize* nil)
+ (*fixups* nil))
+ (unwind-protect
+ (let ((*features* (cons :sb-assembling *features*)))
+ (init-assembler)
+ (load (merge-pathnames name (make-pathname :type "lisp")))
+ (fasl-dump-cold-load-form `(in-package ,(package-name *package*))
+ *lap-output-file*)
+ (sb!assem:append-segment *code-segment* *elsewhere*)
+ (setf *elsewhere* nil)
+ (let ((length (sb!assem:finalize-segment *code-segment*)))
+ (dump-assembler-routines *code-segment*
+ length
+ *fixups*
+ *entry-points*
+ *lap-output-file*))
+ (setq won t))
+ (close-fasl-file *lap-output-file* (not won)))
+ won))
+
+(defstruct reg-spec
+ (kind :temp :type (member :arg :temp :res))
+ (name nil :type symbol)
+ (temp nil :type symbol)
+ (scs nil :type (or list symbol))
+ (offset nil))
+(def!method print-object ((spec reg-spec) stream)
+ (print-unreadable-object (spec stream :type t)
+ (format stream
+ ":KIND ~S :NAME ~S :SCS ~S :OFFSET ~S"
+ (reg-spec-kind spec)
+ (reg-spec-name spec)
+ (reg-spec-scs spec)
+ (reg-spec-offset spec))))
+
+(defun reg-spec-sc (spec)
+ (if (atom (reg-spec-scs spec))
+ (reg-spec-scs spec)
+ (car (reg-spec-scs spec))))
+
+(defun parse-reg-spec (kind name sc offset)
+ (let ((reg (make-reg-spec :kind kind :name name :scs sc :offset offset)))
+ (ecase kind
+ (:temp)
+ ((:arg :res)
+ (setf (reg-spec-temp reg) (make-symbol (symbol-name name)))))
+ reg))
+
+(defun emit-assemble (name options regs code)
+ (collect ((decls))
+ (loop
+ (if (and (consp code) (consp (car code)) (eq (caar code) 'declare))
+ (decls (pop code))
+ (return)))
+ `(let (,@(mapcar
+ #'(lambda (reg)
+ `(,(reg-spec-name reg)
+ (make-random-tn
+ :kind :normal
+ :sc (sc-or-lose ',(reg-spec-sc reg))
+ :offset ,(reg-spec-offset reg))))
+ regs))
+ ,@(decls)
+ (sb!assem:assemble (*code-segment* ',name)
+ ,name
+ (push (cons ',name ,name) *entry-points*)
+ ,@code
+ ,@(generate-return-sequence
+ (or (cadr (assoc :return-style options)) :raw)))
+ (when sb!xc:*compile-print*
+ (format *error-output* "~S assembled~%" ',name)))))
+
+(defun arg-or-res-spec (reg)
+ `(,(reg-spec-name reg)
+ :scs ,(if (atom (reg-spec-scs reg))
+ (list (reg-spec-scs reg))
+ (reg-spec-scs reg))
+ ,@(unless (eq (reg-spec-kind reg) :res)
+ `(:target ,(reg-spec-temp reg)))))
+
+(defun emit-vop (name options vars)
+ (let* ((args (remove :arg vars :key #'reg-spec-kind :test-not #'eq))
+ (temps (remove :temp vars :key #'reg-spec-kind :test-not #'eq))
+ (results (remove :res vars :key #'reg-spec-kind :test-not #'eq))
+ (return-style (or (cadr (assoc :return-style options)) :raw))
+ (cost (or (cadr (assoc :cost options)) 247))
+ (vop (make-symbol "VOP")))
+ (unless (member return-style '(:raw :full-call :none))
+ (error "unknown return-style for ~S: ~S" name return-style))
+ (multiple-value-bind
+ (call-sequence call-temps)
+ (generate-call-sequence name return-style vop)
+ `(define-vop ,(if (atom name) (list name) name)
+ (:args ,@(mapcar #'arg-or-res-spec args))
+ ,@(let ((index -1))
+ (mapcar #'(lambda (arg)
+ `(:temporary (:sc ,(reg-spec-sc arg)
+ :offset ,(reg-spec-offset arg)
+ :from (:argument ,(incf index))
+ :to (:eval 2))
+ ,(reg-spec-temp arg)))
+ args))
+ ,@(mapcar #'(lambda (temp)
+ `(:temporary (:sc ,(reg-spec-sc temp)
+ :offset ,(reg-spec-offset temp)
+ :from (:eval 1)
+ :to (:eval 3))
+ ,(reg-spec-name temp)))
+ temps)
+ ,@call-temps
+ (:vop-var ,vop)
+ ,@(let ((index -1))
+ (mapcar #'(lambda (res)
+ `(:temporary (:sc ,(reg-spec-sc res)
+ :offset ,(reg-spec-offset res)
+ :from (:eval 2)
+ :to (:result ,(incf index))
+ :target ,(reg-spec-name res))
+ ,(reg-spec-temp res)))
+ results))
+ (:results ,@(mapcar #'arg-or-res-spec results))
+ (:ignore ,@(mapcar #'reg-spec-name temps)
+ ,@(apply #'append
+ (mapcar #'cdr
+ (remove :ignore call-temps
+ :test-not #'eq :key #'car))))
+ ,@(remove-if #'(lambda (x)
+ (member x '(:return-style :cost)))
+ options
+ :key #'car)
+ (:generator ,cost
+ ,@(mapcar #'(lambda (arg)
+ #!+(or hppa alpha) `(move ,(reg-spec-name arg)
+ ,(reg-spec-temp arg))
+ #!-(or hppa alpha) `(move ,(reg-spec-temp arg)
+ ,(reg-spec-name arg)))
+ args)
+ ,@call-sequence
+ ,@(mapcar #'(lambda (res)
+ #!+(or hppa alpha) `(move ,(reg-spec-temp res)
+ ,(reg-spec-name res))
+ #!-(or hppa alpha) `(move ,(reg-spec-name res)
+ ,(reg-spec-temp res)))
+ results))))))
+
+(def!macro define-assembly-routine (name&options vars &body code)
+ (multiple-value-bind (name options)
+ (if (atom name&options)
+ (values name&options nil)
+ (values (car name&options)
+ (cdr name&options)))
+ (let ((regs (mapcar #'(lambda (var) (apply #'parse-reg-spec var)) vars)))
+ (if *do-assembly*
+ (emit-assemble name options regs code)
+ (emit-vop name options regs)))))
--- /dev/null
+;;;; allocating simple objects
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!VM")
+
+(file-comment
+ "$Header$")
+\f
+;;;; from signed/unsigned
+
+;;; KLUDGE: Why don't we want vops for this one and the next
+;;; one? -- WHN 19990916
+#+sb-assembling ; We don't want a vop for this one.
+(define-assembly-routine
+ (move-from-signed)
+ ((:temp eax unsigned-reg eax-offset)
+ (:temp ebx unsigned-reg ebx-offset))
+ (inst mov ebx eax)
+ (inst shl ebx 1)
+ (inst jmp :o bignum)
+ (inst shl ebx 1)
+ (inst jmp :o bignum)
+ (inst ret)
+ BIGNUM
+
+ (with-fixed-allocation (ebx bignum-type (+ bignum-digits-offset 1))
+ (storew eax ebx bignum-digits-offset other-pointer-type))
+
+ (inst ret))
+
+#+sb-assembling ; We don't want a vop for this one either.
+(define-assembly-routine
+ (move-from-unsigned)
+ ((:temp eax unsigned-reg eax-offset)
+ (:temp ebx unsigned-reg ebx-offset))
+
+ (inst test eax #xe0000000)
+ (inst jmp :nz bignum)
+ ;; Fixnum
+ (inst mov ebx eax)
+ (inst shl ebx 2)
+ (inst ret)
+
+ BIGNUM
+ ;;; Note: On the mips port space for a two word bignum is always
+ ;;; allocated and the header size is set to either one or two words
+ ;;; as appropriate. On the mips port this is faster, and smaller
+ ;;; inline, but produces more garbage. The inline x86 version uses
+ ;;; the same approach, but here we save garbage and allocate the
+ ;;; smallest possible bignum.
+ (inst jmp :ns one-word-bignum)
+ (inst mov ebx eax)
+
+ ;; Two word bignum
+ (with-fixed-allocation (ebx bignum-type (+ bignum-digits-offset 2))
+ (storew eax ebx bignum-digits-offset other-pointer-type))
+ (inst ret)
+
+ ONE-WORD-BIGNUM
+ (with-fixed-allocation (ebx bignum-type (+ bignum-digits-offset 1))
+ (storew eax ebx bignum-digits-offset other-pointer-type))
+ (inst ret))
--- /dev/null
+;;;; simple cases for generic arithmetic
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!VM")
+
+(file-comment
+ "$Header$")
+\f
+;;;; addition, subtraction, and multiplication
+
+(macrolet ((define-generic-arith-routine ((fun cost) &body body)
+ `(define-assembly-routine (,(symbolicate "GENERIC-" fun)
+ (:cost ,cost)
+ (:return-style :full-call)
+ (:translate ,fun)
+ (:policy :safe)
+ (:save-p t))
+ ((:arg x (descriptor-reg any-reg) edx-offset)
+ (:arg y (descriptor-reg any-reg)
+ ;; this seems wrong esi-offset -- FIXME: What's it mean?
+ edi-offset)
+
+ (:res res (descriptor-reg any-reg) edx-offset)
+
+ (:temp eax unsigned-reg eax-offset)
+ (:temp ebx unsigned-reg ebx-offset)
+ (:temp ecx unsigned-reg ecx-offset))
+
+ (declare (ignorable ebx))
+
+ (inst test x 3) ; fixnum?
+ (inst jmp :nz DO-STATIC-FUN) ; no - do generic
+ (inst test y 3) ; fixnum?
+ (inst jmp :z DO-BODY) ; yes - doit here
+
+ DO-STATIC-FUN
+ (inst pop eax)
+ (inst push ebp-tn)
+ (inst lea
+ ebp-tn
+ (make-ea :dword :base esp-tn :disp word-bytes))
+ (inst sub esp-tn (fixnumize 2))
+ (inst push eax) ; callers return addr
+ (inst mov ecx (fixnumize 2)) ; arg count
+ (inst jmp
+ (make-ea :dword
+ :disp (+ *nil-value*
+ (static-function-offset
+ ',(symbolicate "TWO-ARG-" fun)))))
+
+ DO-BODY
+ ,@body)))
+
+ (define-generic-arith-routine (+ 10)
+ (move res x)
+ (inst add res y)
+ (inst jmp :no OKAY)
+ (inst rcr res 1) ; carry has correct sign
+ (inst sar res 1) ; remove type bits
+
+ (move ecx res)
+
+ (with-fixed-allocation (res bignum-type (1+ bignum-digits-offset))
+ (storew ecx res bignum-digits-offset other-pointer-type))
+
+ OKAY)
+
+ (define-generic-arith-routine (- 10)
+ ;; FIXME: This is screwed up.
+ ;;; I can't figure out the flags on subtract. Overflow never gets
+ ;;; set and carry always does. (- 0 most-negative-fixnum) can't be
+ ;;; easily detected so just let the upper level stuff do it.
+ (inst jmp DO-STATIC-FUN)
+
+ (move res x)
+ (inst sub res y)
+ (inst jmp :no OKAY)
+ (inst rcr res 1)
+ (inst sar res 1) ; remove type bits
+
+ (move ecx res)
+
+ (with-fixed-allocation (res bignum-type (1+ bignum-digits-offset))
+ (storew ecx res bignum-digits-offset other-pointer-type))
+ OKAY)
+
+ (define-generic-arith-routine (* 30)
+ (move eax x) ; must use eax for 64-bit result
+ (inst sar eax 2) ; remove *4 fixnum bias
+ (inst imul y) ; result in edx:eax
+ (inst jmp :no okay) ; still fixnum
+
+ ;; zzz jrd changed edx to ebx in here, as edx isn't listed as a temp, above
+ ;; pfw says that loses big -- edx is target for arg x and result res
+ ;; note that 'edx' is not defined -- using x
+ (inst shrd eax x 2) ; high bits from edx
+ (inst sar x 2) ; now shift edx too
+
+ (move ecx x) ; save high bits from cdq
+ (inst cdq) ; edx:eax <- sign-extend of eax
+ (inst cmp x ecx)
+ (inst jmp :e SINGLE-WORD-BIGNUM)
+
+ (with-fixed-allocation (res bignum-type (+ bignum-digits-offset 2))
+ (storew eax res bignum-digits-offset other-pointer-type)
+ (storew ecx res (1+ bignum-digits-offset) other-pointer-type))
+ (inst jmp DONE)
+
+ SINGLE-WORD-BIGNUM
+
+ (with-fixed-allocation (res bignum-type (1+ bignum-digits-offset))
+ (storew eax res bignum-digits-offset other-pointer-type))
+ (inst jmp DONE)
+
+ OKAY
+ (move res eax)
+ DONE))
+\f
+;;;; negation
+
+(define-assembly-routine (generic-negate
+ (:cost 10)
+ (:return-style :full-call)
+ (:policy :safe)
+ (:translate %negate)
+ (:save-p t))
+ ((:arg x (descriptor-reg any-reg) edx-offset)
+ (:res res (descriptor-reg any-reg) edx-offset)
+
+ (:temp eax unsigned-reg eax-offset)
+ (:temp ecx unsigned-reg ecx-offset))
+ (inst test x 3)
+ (inst jmp :z FIXNUM)
+
+ (inst pop eax)
+ (inst push ebp-tn)
+ (inst lea ebp-tn (make-ea :dword :base esp-tn :disp word-bytes))
+ (inst sub esp-tn (fixnumize 2))
+ (inst push eax)
+ (inst mov ecx (fixnumize 1)) ; arg count
+ (inst jmp (make-ea :dword
+ :disp (+ *nil-value* (static-function-offset '%negate))))
+
+ FIXNUM
+ (move res x)
+ (inst neg res) ; (- most-negative-fixnum) is BIGNUM
+ (inst jmp :no OKAY)
+ (inst shr res 2) ; sign bit is data - remove type bits
+ (move ecx res)
+
+ (with-fixed-allocation (res bignum-type (1+ bignum-digits-offset))
+ (storew ecx res bignum-digits-offset other-pointer-type))
+
+ OKAY)
+\f
+;;;; comparison
+
+(macrolet ((define-cond-assem-rtn (name translate static-fn test)
+ `(define-assembly-routine (,name
+ (:cost 10)
+ (:return-style :full-call)
+ (:policy :safe)
+ (:translate ,translate)
+ (:save-p t))
+ ((:arg x (descriptor-reg any-reg) edx-offset)
+ (:arg y (descriptor-reg any-reg) edi-offset)
+
+ (:res res descriptor-reg edx-offset)
+
+ (:temp eax unsigned-reg eax-offset)
+ (:temp ecx unsigned-reg ecx-offset))
+
+ ;; KLUDGE: The "3" here is a mask for the bits which will be
+ ;; zero in a fixnum. It should have a symbolic name. (Actually,
+ ;; it might already have a symbolic name which the coder
+ ;; couldn't be bothered to use..) -- WHN 19990917
+ (inst test x 3)
+ (inst jmp :nz TAIL-CALL-TO-STATIC-FN)
+ (inst test y 3)
+ (inst jmp :z INLINE-FIXNUM-COMPARE)
+
+ TAIL-CALL-TO-STATIC-FN
+ (inst pop eax)
+ (inst push ebp-tn)
+ (inst lea ebp-tn (make-ea :dword :base esp-tn :disp word-bytes))
+ (inst sub esp-tn (fixnumize 2)) ; FIXME: Push 2 words on stack,
+ ; weirdly?
+ (inst push eax)
+ (inst mov ecx (fixnumize 2)) ; FIXME: FIXNUMIZE and
+ ; SINGLE-FLOAT-BITS are parallel,
+ ; should be named parallelly.
+ (inst jmp (make-ea :dword
+ :disp (+ *nil-value*
+ (static-function-offset
+ ',static-fn))))
+
+ INLINE-FIXNUM-COMPARE
+ (inst cmp x y)
+ (inst jmp ,test RETURN-TRUE)
+ (inst mov res *nil-value*)
+ ;; FIXME: A note explaining this return convention, or a
+ ;; symbolic name for it, would be nice. (It looks as though we
+ ;; should be hand-crafting the same return sequence as would be
+ ;; produced by GENERATE-RETURN-SEQUENCE, but in that case it's
+ ;; not clear why we don't just jump to the end of this function
+ ;; to share the return sequence there.
+ (inst pop eax)
+ (inst add eax 2)
+ (inst jmp eax)
+
+ RETURN-TRUE
+ (load-symbol res t))))
+
+ (define-cond-assem-rtn generic-< < two-arg-< :l)
+ (define-cond-assem-rtn generic-> > two-arg-> :g))
+
+(define-assembly-routine (generic-eql
+ (:cost 10)
+ (:return-style :full-call)
+ (:policy :safe)
+ (:translate eql)
+ (:save-p t))
+ ((:arg x (descriptor-reg any-reg) edx-offset)
+ (:arg y (descriptor-reg any-reg) edi-offset)
+
+ (:res res descriptor-reg edx-offset)
+
+ (:temp eax unsigned-reg eax-offset)
+ (:temp ecx unsigned-reg ecx-offset))
+ (inst cmp x y)
+ (inst jmp :e RETURN-T)
+ (inst test x 3)
+ (inst jmp :z RETURN-NIL)
+ (inst test y 3)
+ (inst jmp :nz DO-STATIC-FN)
+
+ RETURN-NIL
+ (inst mov res *nil-value*)
+ (inst pop eax)
+ (inst add eax 2)
+ (inst jmp eax)
+
+ DO-STATIC-FN
+ (inst pop eax)
+ (inst push ebp-tn)
+ (inst lea ebp-tn (make-ea :dword :base esp-tn :disp word-bytes))
+ (inst sub esp-tn (fixnumize 2))
+ (inst push eax)
+ (inst mov ecx (fixnumize 2))
+ (inst jmp (make-ea :dword
+ :disp (+ *nil-value* (static-function-offset 'eql))))
+
+ RETURN-T
+ (load-symbol res t)
+ ;; FIXME: I don't understand how we return from here..
+ )
+
+(define-assembly-routine (generic-=
+ (:cost 10)
+ (:return-style :full-call)
+ (:policy :safe)
+ (:translate =)
+ (:save-p t))
+ ((:arg x (descriptor-reg any-reg) edx-offset)
+ (:arg y (descriptor-reg any-reg) edi-offset)
+
+ (:res res descriptor-reg edx-offset)
+
+ (:temp eax unsigned-reg eax-offset)
+ (:temp ecx unsigned-reg ecx-offset)
+ )
+ (inst test x 3) ; descriptor?
+ (inst jmp :nz DO-STATIC-FN) ; yes do it here
+ (inst test y 3) ; descriptor?
+ (inst jmp :nz DO-STATIC-FN)
+ (inst cmp x y)
+ (inst jmp :e RETURN-T) ; ok
+
+ (inst mov res *nil-value*)
+ (inst pop eax)
+ (inst add eax 2)
+ (inst jmp eax)
+
+ DO-STATIC-FN
+ (inst pop eax)
+ (inst push ebp-tn)
+ (inst lea ebp-tn (make-ea :dword :base esp-tn :disp word-bytes))
+ (inst sub esp-tn (fixnumize 2))
+ (inst push eax)
+ (inst mov ecx (fixnumize 2))
+ (inst jmp (make-ea :dword
+ :disp (+ *nil-value* (static-function-offset 'two-arg-=))))
+
+ RETURN-T
+ (load-symbol res t))
+
+\f
+;;; Support for the Mersenne Twister, MT19937, random number generator
+;;; due to Matsumoto and Nishimura.
+;;;
+;;; Makoto Matsumoto and T. Nishimura, "Mersenne twister: A
+;;; 623-dimensionally equidistributed uniform pseudorandom number
+;;; generator.", ACM Transactions on Modeling and Computer Simulation,
+;;; 1997, to appear.
+;;;
+;;; State:
+;;; 0-1: Constant matrix A. [0, #x9908b0df] (not used here)
+;;; 2: Index; init. to 1.
+;;; 3-626: State.
+
+;;; This assembly routine is called from the inline VOP and updates
+;;; the state vector with new random numbers. The state vector is
+;;; passed in the EAX register.
+#+sb-assembling ; We don't want a vop for this one.
+(define-assembly-routine
+ (random-mt19937-update)
+ ((:temp state unsigned-reg eax-offset)
+ (:temp k unsigned-reg ebx-offset)
+ (:temp y unsigned-reg ecx-offset)
+ (:temp tmp unsigned-reg edx-offset))
+
+ ;; Save the temporary registers.
+ (inst push k)
+ (inst push y)
+ (inst push tmp)
+
+ ;; Generate a new set of results.
+ (inst xor k k)
+ LOOP1
+ (inst mov y (make-ea :dword :base state :index k :scale 4
+ :disp (- (* (+ 3 sb!vm:vector-data-offset)
+ sb!vm:word-bytes)
+ sb!vm:other-pointer-type)))
+ (inst mov tmp (make-ea :dword :base state :index k :scale 4
+ :disp (- (* (+ 1 3 sb!vm:vector-data-offset)
+ sb!vm:word-bytes)
+ sb!vm:other-pointer-type)))
+ (inst and y #x80000000)
+ (inst and tmp #x7fffffff)
+ (inst or y tmp)
+ (inst shr y 1)
+ (inst jmp :nc skip1)
+ (inst xor y #x9908b0df)
+ SKIP1
+ (inst xor y (make-ea :dword :base state :index k :scale 4
+ :disp (- (* (+ 397 3 sb!vm:vector-data-offset)
+ sb!vm:word-bytes)
+ sb!vm:other-pointer-type)))
+ (inst mov (make-ea :dword :base state :index k :scale 4
+ :disp (- (* (+ 3 sb!vm:vector-data-offset)
+ sb!vm:word-bytes)
+ sb!vm:other-pointer-type))
+ y)
+ (inst inc k)
+ (inst cmp k (- 624 397))
+ (inst jmp :b loop1)
+ LOOP2
+ (inst mov y (make-ea :dword :base state :index k :scale 4
+ :disp (- (* (+ 3 sb!vm:vector-data-offset)
+ sb!vm:word-bytes)
+ sb!vm:other-pointer-type)))
+ (inst mov tmp (make-ea :dword :base state :index k :scale 4
+ :disp (- (* (+ 1 3 sb!vm:vector-data-offset)
+ sb!vm:word-bytes)
+ sb!vm:other-pointer-type)))
+ (inst and y #x80000000)
+ (inst and tmp #x7fffffff)
+ (inst or y tmp)
+ (inst shr y 1)
+ (inst jmp :nc skip2)
+ (inst xor y #x9908b0df)
+ SKIP2
+ (inst xor y (make-ea :dword :base state :index k :scale 4
+ :disp (- (* (+ (- 397 624) 3 sb!vm:vector-data-offset)
+ sb!vm:word-bytes)
+ sb!vm:other-pointer-type)))
+ (inst mov (make-ea :dword :base state :index k :scale 4
+ :disp (- (* (+ 3 sb!vm:vector-data-offset)
+ sb!vm:word-bytes)
+ sb!vm:other-pointer-type))
+ y)
+ (inst inc k)
+ (inst cmp k (- 624 1))
+ (inst jmp :b loop2)
+
+ (inst mov y (make-ea :dword :base state
+ :disp (- (* (+ (- 624 1) 3 sb!vm:vector-data-offset)
+ sb!vm:word-bytes)
+ sb!vm:other-pointer-type)))
+ (inst mov tmp (make-ea :dword :base state
+ :disp (- (* (+ 0 3 sb!vm:vector-data-offset)
+ sb!vm:word-bytes)
+ sb!vm:other-pointer-type)))
+ (inst and y #x80000000)
+ (inst and tmp #x7fffffff)
+ (inst or y tmp)
+ (inst shr y 1)
+ (inst jmp :nc skip3)
+ (inst xor y #x9908b0df)
+ SKIP3
+ (inst xor y (make-ea :dword :base state
+ :disp (- (* (+ (- 397 1) 3 sb!vm:vector-data-offset)
+ sb!vm:word-bytes)
+ sb!vm:other-pointer-type)))
+ (inst mov (make-ea :dword :base state
+ :disp (- (* (+ (- 624 1) 3 sb!vm:vector-data-offset)
+ sb!vm:word-bytes)
+ sb!vm:other-pointer-type))
+ y)
+
+ ;; Restore the temporary registers and return.
+ (inst pop tmp)
+ (inst pop y)
+ (inst pop k)
+ (inst ret))
--- /dev/null
+;;;; various array operations that are too expensive (in space) to do
+;;;; inline
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!VM")
+
+(file-comment
+ "$Header$")
+\f
+;;;; allocation
+
+(define-assembly-routine (allocate-vector
+ (:policy :fast-safe)
+ (:translate allocate-vector)
+ (:arg-types positive-fixnum
+ positive-fixnum
+ positive-fixnum))
+ ((:arg type unsigned-reg eax-offset)
+ (:arg length any-reg ebx-offset)
+ (:arg words any-reg ecx-offset)
+ (:res result descriptor-reg edx-offset))
+ (inst mov result (+ (1- (ash 1 lowtag-bits))
+ (* vector-data-offset word-bytes)))
+ (inst add result words)
+ (inst and result (lognot sb!vm:lowtag-mask))
+ (pseudo-atomic
+ (allocation result result)
+ (inst lea result (make-ea :byte :base result :disp other-pointer-type))
+ (storew type result 0 other-pointer-type)
+ (storew length result vector-length-slot other-pointer-type))
+ (inst ret))
+\f
+;;;; Note: CMU CL had assembly language primitives for hashing strings,
+;;;; but SBCL doesn't.
--- /dev/null
+;;;; the machine specific support routines needed by the file assembler
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!VM")
+
+(file-comment
+ "$Header$")
+\f
+;;;; RETURN-MULTIPLE
+
+;;; For RETURN-MULTIPLE, we have to move the results from the end of
+;;; the frame for the function that is returning to the end of the
+;;; frame for the function being returned to.
+
+#+sb-assembling ;; We don't want a vop for this one.
+(define-assembly-routine
+ (return-multiple (:return-style :none))
+ (;; These four are really arguments.
+ (:temp eax unsigned-reg eax-offset)
+ (:temp ebx unsigned-reg ebx-offset)
+ (:temp ecx unsigned-reg ecx-offset)
+ (:temp esi unsigned-reg esi-offset)
+
+ ;; These we need as temporaries.
+ (:temp edx unsigned-reg edx-offset)
+ (:temp edi unsigned-reg edi-offset))
+
+ ;; Pick off the cases where everything fits in register args.
+ (inst jecxz zero-values)
+ (inst cmp ecx (fixnumize 1))
+ (inst jmp :e one-value)
+ (inst cmp ecx (fixnumize 2))
+ (inst jmp :e two-values)
+ (inst cmp ecx (fixnumize 3))
+ (inst jmp :e three-values)
+
+ ;; Save the count, because the loop is going to destroy it.
+ (inst mov edx ecx)
+
+ ;; Blit the values down the stack. Note: there might be overlap, so we have
+ ;; to be careful not to clobber values before we've read them. Because the
+ ;; stack builds down, we are coping to a larger address. Therefore, we need
+ ;; to iterate from larger addresses to smaller addresses.
+ ;; pfw-this says copy ecx words from esi to edi counting down.
+ (inst shr ecx 2) ; fixnum to raw word count
+ (inst std) ; count down
+ (inst sub esi 4) ; ?
+ (inst lea edi (make-ea :dword :base ebx :disp (- word-bytes)))
+ (inst rep)
+ (inst movs :dword)
+
+ ;; Restore the count.
+ (inst mov ecx edx)
+
+ ;; Set the stack top to the last result.
+ (inst lea esp-tn (make-ea :dword :base edi :disp word-bytes))
+
+ ;; Load the register args.
+ (loadw edx ebx -1)
+ (loadw edi ebx -2)
+ (loadw esi ebx -3)
+
+ ;; And back we go.
+ (inst jmp eax)
+
+ ;; Handle the register arg cases.
+ ZERO-VALUES
+ (move esp-tn ebx)
+ (inst mov edx *nil-value*)
+ (inst mov edi edx)
+ (inst mov esi edx)
+ (inst jmp eax)
+
+ ONE-VALUE ; Note: we can get this, because the return-multiple vop
+ ; doesn't check for this case when size > speed.
+ (loadw edx esi -1)
+ (inst mov esp-tn ebx)
+ (inst add eax 2)
+ (inst jmp eax)
+
+ TWO-VALUES
+ (loadw edx esi -1)
+ (loadw edi esi -2)
+ (inst mov esi *nil-value*)
+ (inst lea esp-tn (make-ea :dword :base ebx :disp (* -2 word-bytes)))
+ (inst jmp eax)
+
+ THREE-VALUES
+ (loadw edx esi -1)
+ (loadw edi esi -2)
+ (loadw esi esi -3)
+ (inst lea esp-tn (make-ea :dword :base ebx :disp (* -3 word-bytes)))
+ (inst jmp eax))
+\f
+;;;; TAIL-CALL-VARIABLE
+
+;;; For tail-call-variable, we have to copy the arguments from the end of our
+;;; stack frame (were args are produced) to the start of our stack frame
+;;; (were args are expected).
+;;;
+;;; We take the function to call in EAX and a pointer to the arguments in
+;;; ESI. EBP says the same over the jump, and the old frame pointer is
+;;; still saved in the first stack slot. The return-pc is saved in
+;;; the second stack slot, so we have to push it to make it look like
+;;; we actually called. We also have to compute ECX from the difference
+;;; between ESI and the stack top.
+#+sb-assembling ;; No vop for this one either.
+(define-assembly-routine
+ (tail-call-variable
+ (:return-style :none))
+
+ ((:temp eax unsigned-reg eax-offset)
+ (:temp ebx unsigned-reg ebx-offset)
+ (:temp ecx unsigned-reg ecx-offset)
+ (:temp edx unsigned-reg edx-offset)
+ (:temp edi unsigned-reg edi-offset)
+ (:temp esi unsigned-reg esi-offset))
+
+ ;; Calculate NARGS (as a fixnum)
+ (move ecx esi)
+ (inst sub ecx esp-tn)
+
+ ;; Check for all the args fitting the the registers.
+ (inst cmp ecx (fixnumize 3))
+ (inst jmp :le REGISTER-ARGS)
+
+ ;; Save the OLD-FP and RETURN-PC because the blit it going to trash
+ ;; those stack locations. Save the ECX, because the loop is going
+ ;; to trash it.
+ (pushw ebp-tn -1)
+ (loadw ebx ebp-tn -2)
+ (inst push ecx)
+
+ ;; Do the blit. Because we are coping from smaller addresses to larger
+ ;; addresses, we have to start at the largest pair and work our way down.
+ (inst shr ecx 2) ; fixnum to raw words
+ (inst std) ; count down
+ (inst lea edi (make-ea :dword :base ebp-tn :disp (- word-bytes)))
+ (inst sub esi (fixnumize 1))
+ (inst rep)
+ (inst movs :dword)
+
+ ;; Load the register arguments carefully.
+ (loadw edx ebp-tn -1)
+
+ ;; Restore OLD-FP and ECX.
+ (inst pop ecx)
+ (popw ebp-tn -1) ; overwrites a0
+
+ ;; Blow off the stack above the arguments.
+ (inst lea esp-tn (make-ea :dword :base edi :disp word-bytes))
+
+ ;; remaining register args
+ (loadw edi ebp-tn -2)
+ (loadw esi ebp-tn -3)
+
+ ;; Push the (saved) return-pc so it looks like we just called.
+ (inst push ebx)
+
+ ;; And jump into the function.
+ (inst jmp
+ (make-ea :byte :base eax
+ :disp (- (* closure-function-slot word-bytes)
+ function-pointer-type)))
+
+ ;; All the arguments fit in registers, so load them.
+ REGISTER-ARGS
+ (loadw edx esi -1)
+ (loadw edi esi -2)
+ (loadw esi esi -3)
+
+ ;; Clear most of the stack.
+ (inst lea esp-tn
+ (make-ea :dword :base ebp-tn :disp (* -3 word-bytes)))
+
+ ;; Push the return-pc so it looks like we just called.
+ (pushw ebp-tn -2)
+
+ ;; And away we go.
+ (inst jmp (make-ea :byte :base eax
+ :disp (- (* closure-function-slot word-bytes)
+ function-pointer-type))))
+\f
+(define-assembly-routine (throw
+ (:return-style :none))
+ ((:arg target (descriptor-reg any-reg) edx-offset)
+ (:arg start any-reg ebx-offset)
+ (:arg count any-reg ecx-offset)
+ (:temp catch any-reg eax-offset))
+
+ (declare (ignore start count))
+
+ (load-symbol-value catch sb!impl::*current-catch-block*)
+
+ LOOP
+
+ (let ((error (generate-error-code nil unseen-throw-tag-error target)))
+ (inst or catch catch) ; check for NULL pointer
+ (inst jmp :z error))
+
+ (inst cmp target (make-ea-for-object-slot catch catch-block-tag-slot 0))
+ (inst jmp :e exit)
+
+ (loadw catch catch catch-block-previous-catch-slot)
+ (inst jmp loop)
+
+ EXIT
+
+ ;; Hear EAX points to catch block containing symbol pointed to by EDX.
+ (inst jmp (make-fixup 'unwind :assembly-routine)))
+
+;;;; non-local exit noise
+
+(define-assembly-routine (unwind
+ (:return-style :none)
+ (:translate %continue-unwind)
+ (:policy :fast-safe))
+ ((:arg block (any-reg descriptor-reg) eax-offset)
+ (:arg start (any-reg descriptor-reg) ebx-offset)
+ (:arg count (any-reg descriptor-reg) ecx-offset)
+ (:temp uwp unsigned-reg esi-offset))
+ (declare (ignore start count))
+
+ (let ((error (generate-error-code nil invalid-unwind-error)))
+ (inst or block block) ; check for NULL pointer
+ (inst jmp :z error))
+
+ (load-symbol-value uwp sb!impl::*current-unwind-protect-block*)
+
+ ;; Does *cuwpb* match value stored in argument cuwp slot?
+ (inst cmp uwp
+ (make-ea-for-object-slot block unwind-block-current-uwp-slot 0))
+ ;; If a match, return to context in arg block.
+ (inst jmp :e do-exit)
+
+ ;; Not a match - return to *current-unwind-protect-block* context.
+ ;; Important! Must save (and return) the arg 'block' for later use!!
+ (move edx-tn block)
+ (move block uwp)
+ ;; Set next unwind protect context.
+ (loadw uwp uwp unwind-block-current-uwp-slot)
+ (store-symbol-value uwp sb!impl::*current-unwind-protect-block*)
+
+ DO-EXIT
+
+ (loadw ebp-tn block unwind-block-current-cont-slot)
+
+ ;; Uwp-entry expects some things in known locations so that they can
+ ;; be saved on the stack: the block in edx-tn; start in ebx-tn; and
+ ;; count in ecx-tn
+
+ (inst jmp (make-ea :byte :base block
+ :disp (* unwind-block-entry-pc-slot word-bytes))))
--- /dev/null
+;;;; just a dummy file to maintain parallelism with other VMs
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!VM")
+
+(file-comment
+ "$Header$")
--- /dev/null
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!VM")
+
+(file-comment
+ "$Header$")
+
+(def-vm-support-routine generate-call-sequence (name style vop)
+ (ecase style
+ (:raw
+ (values
+ `((inst call (make-fixup ',name :assembly-routine)))
+ nil))
+ (:full-call
+ (values
+ `((note-this-location ,vop :call-site)
+ (inst call (make-fixup ',name :assembly-routine))
+ (note-this-location ,vop :single-value-return)
+ (move esp-tn ebx-tn))
+ '((:save-p :compute-only))))
+ (:none
+ (values
+ `((inst jmp (make-fixup ',name :assembly-routine)))
+ nil))))
+
+(def-vm-support-routine generate-return-sequence (style)
+ (ecase style
+ (:raw
+ `(inst ret))
+ (:full-call
+ `(
+ (inst pop eax-tn)
+
+ (inst add eax-tn 2)
+ (inst jmp eax-tn)))
+ (:none)))
--- /dev/null
+;;;; ALIEN-related type system stuff, done later
+;;;; than other type system stuff because it depends on the definition
+;;;; of the ALIEN-VALUE target structure type
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!KERNEL")
+
+(file-comment
+ "$Header$")
+
+(!begin-collecting-cold-init-forms)
+
+(defstruct (alien-type-type
+ (:include ctype
+ (class-info (type-class-or-lose 'alien)))
+ (:constructor %make-alien-type-type (alien-type)))
+ (alien-type nil :type alien-type))
+
+(define-type-class alien)
+
+(define-type-method (alien :unparse) (type)
+ `(alien ,(unparse-alien-type (alien-type-type-alien-type type))))
+
+(define-type-method (alien :simple-subtypep) (type1 type2)
+ (values (alien-subtype-p (alien-type-type-alien-type type1)
+ (alien-type-type-alien-type type2))
+ t))
+
+;;; KLUDGE: This DEFINE-SUPERCLASSES gets executed much later than the others
+;;; (toplevel form time instead of cold load init time) because ALIEN-VALUE
+;;; itself is a structure which isn't defined until fairly late.
+;;;
+;;; FIXME: I'm somewhat tempted to just punt ALIEN from the type system.
+;;; It's sufficiently unlike the others that it's a bit of a pain, and
+;;; it doesn't seem to be put to any good use either in type inference or
+;;; in type declarations.
+(define-superclasses alien ((alien-value)) progn)
+
+(define-type-method (alien :simple-=) (type1 type2)
+ (let ((alien-type-1 (alien-type-type-alien-type type1))
+ (alien-type-2 (alien-type-type-alien-type type2)))
+ (values (or (eq alien-type-1 alien-type-2)
+ (alien-type-= alien-type-1 alien-type-2))
+ t)))
+
+(def-type-translator alien (&optional (alien-type nil))
+ (typecase alien-type
+ (null
+ (make-alien-type-type))
+ (alien-type
+ (make-alien-type-type alien-type))
+ (t
+ (make-alien-type-type (parse-alien-type alien-type (make-null-lexenv))))))
+
+(defun make-alien-type-type (&optional alien-type)
+ (if alien-type
+ (let ((lisp-rep-type (compute-lisp-rep-type alien-type)))
+ (if lisp-rep-type
+ (specifier-type lisp-rep-type)
+ (%make-alien-type-type alien-type)))
+ *universal-type*))
+
+(!defun-from-collected-cold-init-forms !alien-type-cold-init)
--- /dev/null
+;;;; functions to implement arrays
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!IMPL")
+
+(file-comment
+ "$Header$")
+
+#!-sb-fluid
+(declaim (inline fill-pointer array-has-fill-pointer-p adjustable-array-p
+ array-displacement))
+\f
+;;;; miscellaneous accessor functions
+
+;;; These functions are needed by the interpreter, 'cause the compiler inlines
+;;; them.
+(macrolet ((def-frob (name)
+ `(progn
+ (defun ,name (array)
+ (,name array))
+ (defun (setf ,name) (value array)
+ (setf (,name array) value)))))
+ (def-frob %array-fill-pointer)
+ (def-frob %array-fill-pointer-p)
+ (def-frob %array-available-elements)
+ (def-frob %array-data-vector)
+ (def-frob %array-displacement)
+ (def-frob %array-displaced-p))
+
+(defun %array-rank (array)
+ (%array-rank array))
+
+(defun %array-dimension (array axis)
+ (%array-dimension array axis))
+
+(defun %set-array-dimension (array axis value)
+ (%set-array-dimension array axis value))
+
+(defun %check-bound (array bound index)
+ (declare (type index bound)
+ (fixnum index))
+ (%check-bound array bound index))
+
+;;; The guts of the WITH-ARRAY-DATA macro. Note that this function is
+;;; only called if we have an array header or an error, so it doesn't
+;;; have to be too tense.
+(defun %with-array-data (array start end)
+ (declare (array array) (type index start) (type (or index null) end))
+ ;; FIXME: The VALUES declaration here is correct, but as of SBCL
+ ;; 0.6.6, the corresponding runtime assertion is implemented
+ ;; horribly inefficiently, with a full call to %TYPEP for every
+ ;; call to this function. As a quick fix, I commented it out,
+ ;; but the proper fix would be to fix up type checking.
+ ;;
+ ;; A simpler test case for the optimization bug is
+ ;; (DEFUN FOO (X)
+ ;; (DECLARE (TYPE INDEXOID X))
+ ;; (THE (VALUES INDEXOID)
+ ;; (VALUES X)))
+ ;; which also compiles to a full call to %TYPEP.
+ #+nil (declare (values (simple-array * (*)) index index index))
+ (let* ((size (array-total-size array))
+ (end (cond (end
+ (unless (<= end size)
+ (error "End ~D is greater than total size ~D."
+ end size))
+ end)
+ (t size))))
+ (when (> start end)
+ (error "Start ~D is greater than end ~D." start end))
+ (do ((data array (%array-data-vector data))
+ (cumulative-offset 0
+ (+ cumulative-offset
+ (%array-displacement data))))
+ ((not (array-header-p data))
+ (values (the (simple-array * (*)) data)
+ (the index (+ cumulative-offset start))
+ (the index (+ cumulative-offset end))
+ (the index cumulative-offset)))
+ (declare (type index cumulative-offset)))))
+\f
+;;;; MAKE-ARRAY
+
+(eval-when (:compile-toplevel :execute)
+ (sb!xc:defmacro pick-type (type &rest specs)
+ `(cond ,@(mapcar #'(lambda (spec)
+ `(,(if (eq (car spec) t)
+ t
+ `(subtypep ,type ',(car spec)))
+ ,@(cdr spec)))
+ specs))))
+
+;;; These functions are used in the implementation of MAKE-ARRAY for
+;;; complex arrays. There are lots of transforms to simplify
+;;; MAKE-ARRAY is transformed away for various easy cases, but not for
+;;; all reasonable cases, so e.g. as of sbcl-0.6.6 we still make full
+;;; calls to MAKE-ARRAY for any non-simple array. Thus, there's some
+;;; value to making this somewhat efficient, at least not doing full
+;;; calls to SUBTYPEP in the easy cases.
+(defun %vector-type-code (type)
+ (case type
+ ;; Pick off some easy common cases.
+ ;;
+ ;; (Perhaps we should make a much more exhaustive table of easy
+ ;; common cases here. Or perhaps the effort would be better spent
+ ;; on smarter compiler transforms which do the calculation once
+ ;; and for all in any reasonable user programs.)
+ ((t)
+ (values #.sb!vm:simple-vector-type #.sb!vm:word-bits))
+ ((character base-char)
+ (values #.sb!vm:simple-string-type #.sb!vm:byte-bits))
+ ((bit)
+ (values #.sb!vm:simple-bit-vector-type 1))
+ ;; OK, we have to wade into SUBTYPEPing after all.
+ (t
+ (pick-type type
+ (base-char (values #.sb!vm:simple-string-type #.sb!vm:byte-bits))
+ (bit (values #.sb!vm:simple-bit-vector-type 1))
+ ((unsigned-byte 2)
+ (values #.sb!vm:simple-array-unsigned-byte-2-type 2))
+ ((unsigned-byte 4)
+ (values #.sb!vm:simple-array-unsigned-byte-4-type 4))
+ ((unsigned-byte 8)
+ (values #.sb!vm:simple-array-unsigned-byte-8-type 8))
+ ((unsigned-byte 16)
+ (values #.sb!vm:simple-array-unsigned-byte-16-type 16))
+ ((unsigned-byte 32)
+ (values #.sb!vm:simple-array-unsigned-byte-32-type 32))
+ ((signed-byte 8)
+ (values #.sb!vm:simple-array-signed-byte-8-type 8))
+ ((signed-byte 16)
+ (values #.sb!vm:simple-array-signed-byte-16-type 16))
+ ((signed-byte 30)
+ (values #.sb!vm:simple-array-signed-byte-30-type 32))
+ ((signed-byte 32)
+ (values #.sb!vm:simple-array-signed-byte-32-type 32))
+ (single-float (values #.sb!vm:simple-array-single-float-type 32))
+ (double-float (values #.sb!vm:simple-array-double-float-type 64))
+ #!+long-float
+ (long-float
+ (values #.sb!vm:simple-array-long-float-type #!+x86 96 #!+sparc 128))
+ ((complex single-float)
+ (values #.sb!vm:simple-array-complex-single-float-type 64))
+ ((complex double-float)
+ (values #.sb!vm:simple-array-complex-double-float-type 128))
+ #!+long-float
+ ((complex long-float)
+ (values #.sb!vm:simple-array-complex-long-float-type
+ #!+x86 192
+ #!+sparc 256))
+ (t (values #.sb!vm:simple-vector-type #.sb!vm:word-bits))))))
+(defun %complex-vector-type-code (type)
+ (case type
+ ;; Pick off some easy common cases.
+ ((t)
+ #.sb!vm:complex-vector-type)
+ ((character base-char)
+ #.sb!vm:complex-string-type)
+ ((bit)
+ #.sb!vm:complex-bit-vector-type)
+ ;; OK, we have to wade into SUBTYPEPing after all.
+ (t
+ (pick-type type
+ (base-char #.sb!vm:complex-string-type)
+ (bit #.sb!vm:complex-bit-vector-type)
+ (t #.sb!vm:complex-vector-type)))))
+
+(defun make-array (dimensions &key
+ (element-type t)
+ (initial-element nil initial-element-p)
+ initial-contents adjustable fill-pointer
+ displaced-to displaced-index-offset)
+ #!+sb-doc
+ "Creates an array of the specified Dimensions. See manual for details."
+ (let* ((dimensions (if (listp dimensions) dimensions (list dimensions)))
+ (array-rank (length (the list dimensions)))
+ (simple (and (null fill-pointer)
+ (not adjustable)
+ (null displaced-to))))
+ (declare (fixnum array-rank))
+ (when (and displaced-index-offset (null displaced-to))
+ (error "Can't specify :displaced-index-offset without :displaced-to"))
+ (if (and simple (= array-rank 1))
+ ;; Its a (simple-array * (*))
+ (multiple-value-bind (type bits) (%vector-type-code element-type)
+ (declare (type (unsigned-byte 8) type)
+ (type (integer 1 256) bits))
+ (let* ((length (car dimensions))
+ (array (allocate-vector
+ type
+ length
+ (ceiling (* (if (= type sb!vm:simple-string-type)
+ (1+ length)
+ length)
+ bits)
+ sb!vm:word-bits))))
+ (declare (type index length))
+ (when initial-element-p
+ (fill array initial-element))
+ (when initial-contents
+ (when initial-element
+ (error "Cannot specify both :initial-element and ~
+ :initial-contents"))
+ (unless (= length (length initial-contents))
+ (error "~D elements in the initial-contents, but the ~
+ vector length is ~D."
+ (length initial-contents)
+ length))
+ (replace array initial-contents))
+ array))
+ ;; It's either a complex array or a multidimensional array.
+ (let* ((total-size (reduce #'* dimensions))
+ (data (or displaced-to
+ (data-vector-from-inits
+ dimensions total-size element-type
+ initial-contents initial-element initial-element-p)))
+ (array (make-array-header
+ (cond ((= array-rank 1)
+ (%complex-vector-type-code element-type))
+ (simple sb!vm:simple-array-type)
+ (t sb!vm:complex-array-type))
+ array-rank)))
+ (cond (fill-pointer
+ (unless (= array-rank 1)
+ (error "Only vectors can have fill pointers."))
+ (let ((length (car dimensions)))
+ (declare (fixnum length))
+ (setf (%array-fill-pointer array)
+ (cond ((eq fill-pointer t)
+ length)
+ (t
+ (unless (and (fixnump fill-pointer)
+ (>= fill-pointer 0)
+ (<= fill-pointer length))
+ (error "Invalid fill-pointer ~D"
+ fill-pointer))
+ fill-pointer))))
+ (setf (%array-fill-pointer-p array) t))
+ (t
+ (setf (%array-fill-pointer array) total-size)
+ (setf (%array-fill-pointer-p array) nil)))
+ (setf (%array-available-elements array) total-size)
+ (setf (%array-data-vector array) data)
+ (cond (displaced-to
+ (when (or initial-element-p initial-contents)
+ (error "Neither :initial-element nor :initial-contents ~
+ can be specified along with :displaced-to"))
+ (let ((offset (or displaced-index-offset 0)))
+ (when (> (+ offset total-size)
+ (array-total-size displaced-to))
+ (error "~S doesn't have enough elements." displaced-to))
+ (setf (%array-displacement array) offset)
+ (setf (%array-displaced-p array) t)))
+ (t
+ (setf (%array-displaced-p array) nil)))
+ (let ((axis 0))
+ (dolist (dim dimensions)
+ (setf (%array-dimension array axis) dim)
+ (incf axis)))
+ array))))
+
+;;; DATA-VECTOR-FROM-INITS returns a simple vector that has the specified array
+;;; characteristics. Dimensions is only used to pass to FILL-DATA-VECTOR
+;;; for error checking on the structure of initial-contents.
+(defun data-vector-from-inits (dimensions total-size element-type
+ initial-contents initial-element
+ initial-element-p)
+ (when (and initial-contents initial-element-p)
+ (error "Cannot supply both :initial-contents and :initial-element to
+ either make-array or adjust-array."))
+ (let ((data (if initial-element-p
+ (make-array total-size
+ :element-type element-type
+ :initial-element initial-element)
+ (make-array total-size
+ :element-type element-type))))
+ (cond (initial-element-p
+ (unless (simple-vector-p data)
+ (unless (typep initial-element element-type)
+ (error "~S cannot be used to initialize an array of type ~S."
+ initial-element element-type))
+ (fill (the vector data) initial-element)))
+ (initial-contents
+ (fill-data-vector data dimensions initial-contents)))
+ data))
+
+(defun fill-data-vector (vector dimensions initial-contents)
+ (let ((index 0))
+ (labels ((frob (axis dims contents)
+ (cond ((null dims)
+ (setf (aref vector index) contents)
+ (incf index))
+ (t
+ (unless (typep contents 'sequence)
+ (error "Malformed :INITIAL-CONTENTS. ~S is not a ~
+ sequence, but ~D more layer~:P needed."
+ contents
+ (- (length dimensions) axis)))
+ (unless (= (length contents) (car dims))
+ (error "Malformed :INITIAL-CONTENTS. Dimension of ~
+ axis ~D is ~D, but ~S is ~D long."
+ axis (car dims) contents (length contents)))
+ (if (listp contents)
+ (dolist (content contents)
+ (frob (1+ axis) (cdr dims) content))
+ (dotimes (i (length contents))
+ (frob (1+ axis) (cdr dims) (aref contents i))))))))
+ (frob 0 dimensions initial-contents))))
+
+(defun vector (&rest objects)
+ #!+sb-doc
+ "Construct a SIMPLE-VECTOR from the given objects."
+ (coerce (the list objects) 'simple-vector))
+\f
+;;;; accessor/setter functions
+
+(defun hairy-data-vector-ref (array index)
+ (with-array-data ((vector array) (index index) (end))
+ (declare (ignore end) (optimize (safety 3)))
+ (macrolet ((dispatch (&rest stuff)
+ `(etypecase vector
+ ,@(mapcar #'(lambda (type)
+ (let ((atype `(simple-array ,type (*))))
+ `(,atype
+ (data-vector-ref (the ,atype vector)
+ index))))
+ stuff))))
+ (dispatch
+ t
+ bit
+ character
+ (unsigned-byte 2)
+ (unsigned-byte 4)
+ (unsigned-byte 8)
+ (unsigned-byte 16)
+ (unsigned-byte 32)
+ (signed-byte 8)
+ (signed-byte 16)
+ (signed-byte 30)
+ (signed-byte 32)
+ single-float
+ double-float
+ #!+long-float long-float
+ (complex single-float)
+ (complex double-float)
+ #!+long-float (complex long-float)))))
+
+(defun hairy-data-vector-set (array index new-value)
+ (with-array-data ((vector array) (index index) (end))
+ (declare (ignore end) (optimize (safety 3)))
+ (macrolet ((dispatch (&rest stuff)
+ `(etypecase vector
+ ,@(mapcar #'(lambda (type)
+ (let ((atype `(simple-array ,type (*))))
+ `(,atype
+ (data-vector-set (the ,atype vector)
+ index
+ (the ,type
+ new-value)))))
+ stuff))))
+ (dispatch
+ t
+ bit
+ character
+ (unsigned-byte 2)
+ (unsigned-byte 4)
+ (unsigned-byte 8)
+ (unsigned-byte 16)
+ (unsigned-byte 32)
+ (signed-byte 8)
+ (signed-byte 16)
+ (signed-byte 30)
+ (signed-byte 32)
+ single-float
+ double-float
+ #!+long-float long-float
+ (complex single-float)
+ (complex double-float)
+ #!+long-float (complex long-float)))))
+
+(defun %array-row-major-index (array subscripts
+ &optional (invalid-index-error-p t))
+ (declare (array array)
+ (list subscripts))
+ (let ((rank (array-rank array)))
+ (unless (= rank (length subscripts))
+ (error "Wrong number of subscripts, ~D, for array of rank ~D"
+ (length subscripts) rank))
+ (if (array-header-p array)
+ (do ((subs (nreverse subscripts) (cdr subs))
+ (axis (1- (array-rank array)) (1- axis))
+ (chunk-size 1)
+ (result 0))
+ ((null subs) result)
+ (declare (list subs) (fixnum axis chunk-size result))
+ (let ((index (car subs))
+ (dim (%array-dimension array axis)))
+ (declare (fixnum index dim))
+ (unless (< -1 index dim)
+ (if invalid-index-error-p
+ (error "Invalid index ~D~[~;~:; on axis ~:*~D~] in ~S"
+ index axis array)
+ (return-from %array-row-major-index nil)))
+ (incf result (* chunk-size index))
+ (setf chunk-size (* chunk-size dim))))
+ (let ((index (first subscripts)))
+ (unless (< -1 index (length (the (simple-array * (*)) array)))
+ (if invalid-index-error-p
+ (error "Invalid index ~D in ~S" index array)
+ (return-from %array-row-major-index nil)))
+ index))))
+
+(defun array-in-bounds-p (array &rest subscripts)
+ #!+sb-doc
+ "Returns T if the Subscipts are in bounds for the Array, Nil otherwise."
+ (if (%array-row-major-index array subscripts nil)
+ t))
+
+(defun array-row-major-index (array &rest subscripts)
+ (%array-row-major-index array subscripts))
+
+(defun aref (array &rest subscripts)
+ #!+sb-doc
+ "Returns the element of the Array specified by the Subscripts."
+ (row-major-aref array (%array-row-major-index array subscripts)))
+
+(defun %aset (array &rest stuff)
+ (let ((subscripts (butlast stuff))
+ (new-value (car (last stuff))))
+ (setf (row-major-aref array (%array-row-major-index array subscripts))
+ new-value)))
+
+;;; FIXME: What's supposed to happen with functions
+;;; like AREF when we (DEFUN (SETF FOO) ..) when
+;;; DEFSETF FOO is also defined? It seems as though the logical
+;;; thing to do would be to nuke the macro definition for (SETF FOO)
+;;; and replace it with the (SETF FOO) function, issuing a warning,
+;;; just as for ordinary functions
+;;; * (LISP-IMPLEMENTATION-VERSION)
+;;; "18a+ release x86-linux 2.4.7 6 November 1998 cvs"
+;;; * (DEFMACRO ZOO (X) `(+ ,X ,X))
+;;; ZOO
+;;; * (DEFUN ZOO (X) (* 3 X))
+;;; Warning: ZOO previously defined as a macro.
+;;; ZOO
+;;; But that doesn't seem to be what happens in CMU CL.
+;;;
+;;; Also, it would be nice to make DESCRIBE FOO tell whether a symbol
+;;; has a setf expansion and/or a setf function defined.
+
+#!-sb-fluid (declaim (inline (setf aref)))
+(defun (setf aref) (new-value array &rest subscripts)
+ (declare (type array array))
+ (setf (row-major-aref array (%array-row-major-index array subscripts))
+ new-value))
+
+(defun row-major-aref (array index)
+ #!+sb-doc
+ "Returns the element of array corressponding to the row-major index. This is
+ SETF'able."
+ (declare (optimize (safety 1)))
+ (row-major-aref array index))
+
+(defun %set-row-major-aref (array index new-value)
+ (declare (optimize (safety 1)))
+ (setf (row-major-aref array index) new-value))
+
+(defun svref (simple-vector index)
+ #!+sb-doc
+ "Returns the Index'th element of the given Simple-Vector."
+ (declare (optimize (safety 1)))
+ (aref simple-vector index))
+
+(defun %svset (simple-vector index new)
+ (declare (optimize (safety 1)))
+ (setf (aref simple-vector index) new))
+
+(defun bit (bit-array &rest subscripts)
+ #!+sb-doc
+ "Returns the bit from the Bit-Array at the specified Subscripts."
+ (declare (type (array bit) bit-array) (optimize (safety 1)))
+ (row-major-aref bit-array (%array-row-major-index bit-array subscripts)))
+
+(defun %bitset (bit-array &rest stuff)
+ (declare (type (array bit) bit-array) (optimize (safety 1)))
+ (let ((subscripts (butlast stuff))
+ (new-value (car (last stuff))))
+ (setf (row-major-aref bit-array
+ (%array-row-major-index bit-array subscripts))
+ new-value)))
+
+#!-sb-fluid (declaim (inline (setf bit)))
+(defun (setf bit) (new-value bit-array &rest subscripts)
+ (declare (type (array bit) bit-array) (optimize (safety 1)))
+ (setf (row-major-aref bit-array
+ (%array-row-major-index bit-array subscripts))
+ new-value))
+
+(defun sbit (simple-bit-array &rest subscripts)
+ #!+sb-doc
+ "Returns the bit from the Simple-Bit-Array at the specified Subscripts."
+ (declare (type (simple-array bit) simple-bit-array) (optimize (safety 1)))
+ (row-major-aref simple-bit-array
+ (%array-row-major-index simple-bit-array subscripts)))
+
+;;; KLUDGE: Not all these things (%SET-ROW-MAJOR-AREF, %SET-FILL-POINTER,
+;;; %SET-FDEFINITION, %SCHARSET, %SBITSET..) seem to deserve separate names.
+;;; Could we just DEFUN (SETF SBIT) etc. and get rid of the non-ANSI names?
+;;; -- WHN 19990911
+(defun %sbitset (simple-bit-array &rest stuff)
+ (declare (type (simple-array bit) simple-bit-array) (optimize (safety 1)))
+ (let ((subscripts (butlast stuff))
+ (new-value (car (last stuff))))
+ (setf (row-major-aref simple-bit-array
+ (%array-row-major-index simple-bit-array subscripts))
+ new-value)))
+
+#!-sb-fluid (declaim (inline (setf sbit)))
+(defun (setf sbit) (new-value bit-array &rest subscripts)
+ (declare (type (simple-array bit) bit-array) (optimize (safety 1)))
+ (setf (row-major-aref bit-array
+ (%array-row-major-index bit-array subscripts))
+ new-value))
+\f
+;;;; miscellaneous array properties
+
+(defun array-element-type (array)
+ #!+sb-doc
+ "Returns the type of the elements of the array"
+ (let ((type (get-type array)))
+ (macrolet ((pick-element-type (&rest stuff)
+ `(cond ,@(mapcar #'(lambda (stuff)
+ (cons
+ (let ((item (car stuff)))
+ (cond ((eq item t)
+ t)
+ ((listp item)
+ (cons 'or
+ (mapcar #'(lambda (x)
+ `(= type ,x))
+ item)))
+ (t
+ `(= type ,item))))
+ (cdr stuff)))
+ stuff))))
+ (pick-element-type
+ ((sb!vm:simple-string-type sb!vm:complex-string-type) 'base-char)
+ ((sb!vm:simple-bit-vector-type sb!vm:complex-bit-vector-type) 'bit)
+ (sb!vm:simple-vector-type t)
+ (sb!vm:simple-array-unsigned-byte-2-type '(unsigned-byte 2))
+ (sb!vm:simple-array-unsigned-byte-4-type '(unsigned-byte 4))
+ (sb!vm:simple-array-unsigned-byte-8-type '(unsigned-byte 8))
+ (sb!vm:simple-array-unsigned-byte-16-type '(unsigned-byte 16))
+ (sb!vm:simple-array-unsigned-byte-32-type '(unsigned-byte 32))
+ (sb!vm:simple-array-signed-byte-8-type '(signed-byte 8))
+ (sb!vm:simple-array-signed-byte-16-type '(signed-byte 16))
+ (sb!vm:simple-array-signed-byte-30-type '(signed-byte 30))
+ (sb!vm:simple-array-signed-byte-32-type '(signed-byte 32))
+ (sb!vm:simple-array-single-float-type 'single-float)
+ (sb!vm:simple-array-double-float-type 'double-float)
+ #!+long-float
+ (sb!vm:simple-array-long-float-type 'long-float)
+ (sb!vm:simple-array-complex-single-float-type '(complex single-float))
+ (sb!vm:simple-array-complex-double-float-type '(complex double-float))
+ #!+long-float
+ (sb!vm:simple-array-complex-long-float-type '(complex long-float))
+ ((sb!vm:simple-array-type sb!vm:complex-vector-type
+ sb!vm:complex-array-type)
+ (with-array-data ((array array) (start) (end))
+ (declare (ignore start end))
+ (array-element-type array)))
+ (t
+ (error "~S is not an array." array))))))
+
+(defun array-rank (array)
+ #!+sb-doc
+ "Returns the number of dimensions of the 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."
+ (declare (array array) (type index axis-number))
+ (cond ((not (array-header-p array))
+ (unless (= axis-number 0)
+ (error "Vector axis is not zero: ~S" axis-number))
+ (length (the (simple-array * (*)) array)))
+ ((>= axis-number (%array-rank array))
+ (error "~D is too big; ~S only has ~D dimension~:P"
+ axis-number array (%array-rank array)))
+ (t
+ (%array-dimension array axis-number))))
+
+(defun array-dimensions (array)
+ #!+sb-doc
+ "Returns 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))
+ (index (1- (array-rank array)) (1- index)))
+ ((minusp index) results))
+ (list (array-dimension array 0))))
+
+(defun array-total-size (array)
+ #!+sb-doc
+ "Returns the total number of elements in the Array."
+ (declare (array array))
+ (if (array-header-p array)
+ (%array-available-elements array)
+ (length (the vector 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)))
+
+(defun adjustable-array-p (array)
+ #!+sb-doc
+ "Returns 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)))
+\f
+;;;; fill pointer frobbing stuff
+
+(defun array-has-fill-pointer-p (array)
+ #!+sb-doc
+ "Returns T if the given Array has a fill pointer, or Nil otherwise."
+ (declare (array array))
+ (and (array-header-p array) (%array-fill-pointer-p array)))
+
+(defun fill-pointer (vector)
+ #!+sb-doc
+ "Returns the Fill-Pointer of the given Vector."
+ (declare (vector vector))
+ (if (and (array-header-p vector) (%array-fill-pointer-p vector))
+ (%array-fill-pointer vector)
+ (error 'simple-type-error
+ :datum vector
+ :expected-type '(and vector (satisfies array-has-fill-pointer-p))
+ :format-control
+ "~S is not an array with a fill-pointer."
+ :format-arguments (list vector))))
+
+(defun %set-fill-pointer (vector new)
+ (declare (vector vector) (fixnum new))
+ (if (and (array-header-p vector) (%array-fill-pointer-p vector))
+ (if (> new (%array-available-elements vector))
+ (error "New fill pointer, ~S, is larger than the length of the vector."
+ new)
+ (setf (%array-fill-pointer vector) new))
+ (error 'simple-type-error
+ :datum vector
+ :expected-type '(and vector (satisfies array-has-fill-pointer-p))
+ :format-control "~S is not an array with a fill-pointer."
+ :format-arguments (list vector))))
+
+(defun vector-push (new-el array)
+ #!+sb-doc
+ "Attempts to set the element of Array designated by the fill pointer
+ to New-El and increment fill pointer by one. If the fill pointer is
+ too large, Nil is returned, otherwise the index of the pushed element is
+ returned."
+ (declare (vector array))
+ (let ((fill-pointer (fill-pointer array)))
+ (declare (fixnum fill-pointer))
+ (cond ((= fill-pointer (%array-available-elements array))
+ nil)
+ (t
+ (setf (aref array fill-pointer) new-el)
+ (setf (%array-fill-pointer array) (1+ fill-pointer))
+ fill-pointer))))
+
+(defun vector-push-extend (new-el array &optional
+ (extension (if (zerop (length array))
+ 1
+ (length array))))
+ #!+sb-doc
+ "Like Vector-Push except that if the fill pointer gets too large, the
+ Array is extended rather than Nil being returned."
+ (declare (vector array) (fixnum extension))
+ (let ((fill-pointer (fill-pointer array)))
+ (declare (fixnum fill-pointer))
+ (when (= fill-pointer (%array-available-elements array))
+ (adjust-array array (+ fill-pointer extension)))
+ (setf (aref array fill-pointer) new-el)
+ (setf (%array-fill-pointer array) (1+ fill-pointer))
+ fill-pointer))
+
+(defun vector-pop (array)
+ #!+sb-doc
+ "Attempts to decrease the fill-pointer by 1 and return the element
+ pointer to by the new fill pointer. If the original value of the fill
+ pointer is 0, an error occurs."
+ (declare (vector array))
+ (let ((fill-pointer (fill-pointer array)))
+ (declare (fixnum fill-pointer))
+ (if (zerop fill-pointer)
+ (error "Nothing left to pop.")
+ (aref array
+ (setf (%array-fill-pointer array)
+ (1- fill-pointer))))))
+\f
+;;;; ADJUST-ARRAY
+
+(defun adjust-array (array dimensions &key
+ (element-type (array-element-type array))
+ (initial-element nil initial-element-p)
+ initial-contents fill-pointer
+ displaced-to displaced-index-offset)
+ #!+sb-doc
+ "Adjusts the Array's dimensions to the given Dimensions and stuff."
+ (let ((dimensions (if (listp dimensions) dimensions (list dimensions))))
+ (cond ((/= (the fixnum (length (the list dimensions)))
+ (the fixnum (array-rank array)))
+ (error "Number of dimensions not equal to rank of array."))
+ ((not (subtypep element-type (array-element-type array)))
+ (error "New element type, ~S, is incompatible with old."
+ element-type)))
+ (let ((array-rank (length (the list dimensions))))
+ (declare (fixnum array-rank))
+ (when (and fill-pointer (> array-rank 1))
+ (error "Multidimensional arrays can't have fill pointers."))
+ (cond (initial-contents
+ ;; Array former contents replaced by initial-contents.
+ (if (or initial-element-p displaced-to)
+ (error "Initial contents may not be specified with ~
+ the :initial-element or :displaced-to option."))
+ (let* ((array-size (apply #'* dimensions))
+ (array-data (data-vector-from-inits
+ dimensions array-size element-type
+ initial-contents initial-element
+ initial-element-p)))
+ (if (adjustable-array-p array)
+ (set-array-header array array-data array-size
+ (get-new-fill-pointer array array-size
+ fill-pointer)
+ 0 dimensions nil)
+ (if (array-header-p array)
+ ;; Simple multidimensional or single dimensional array.
+ (make-array dimensions
+ :element-type element-type
+ :initial-contents initial-contents)
+ array-data))))
+ (displaced-to
+ ;; No initial-contents supplied is already established.
+ (when initial-element
+ (error "The :initial-element option may not be specified ~
+ with :displaced-to."))
+ (unless (subtypep element-type (array-element-type displaced-to))
+ (error "One can't displace an array of type ~S into another of ~
+ type ~S."
+ element-type (array-element-type displaced-to)))
+ (let ((displacement (or displaced-index-offset 0))
+ (array-size (apply #'* dimensions)))
+ (declare (fixnum displacement array-size))
+ (if (< (the fixnum (array-total-size displaced-to))
+ (the fixnum (+ displacement array-size)))
+ (error "The :displaced-to array is too small."))
+ (if (adjustable-array-p array)
+ ;; None of the original contents appear in adjusted array.
+ (set-array-header array displaced-to array-size
+ (get-new-fill-pointer array array-size
+ fill-pointer)
+ displacement dimensions t)
+ ;; Simple multidimensional or single dimensional array.
+ (make-array dimensions
+ :element-type element-type
+ :displaced-to displaced-to
+ :displaced-index-offset
+ displaced-index-offset))))
+ ((= array-rank 1)
+ (let ((old-length (array-total-size array))
+ (new-length (car dimensions))
+ new-data)
+ (declare (fixnum old-length new-length))
+ (with-array-data ((old-data array) (old-start)
+ (old-end old-length))
+ (cond ((or (%array-displaced-p array)
+ (< old-length new-length))
+ (setf new-data
+ (data-vector-from-inits
+ dimensions new-length element-type
+ initial-contents initial-element
+ initial-element-p))
+ (replace new-data old-data
+ :start2 old-start :end2 old-end))
+ (t (setf new-data
+ (shrink-vector old-data new-length))))
+ (if (adjustable-array-p array)
+ (set-array-header array new-data new-length
+ (get-new-fill-pointer array new-length
+ fill-pointer)
+ 0 dimensions nil)
+ new-data))))
+ (t
+ (let ((old-length (%array-available-elements array))
+ (new-length (apply #'* dimensions)))
+ (declare (fixnum old-length new-length))
+ (with-array-data ((old-data array) (old-start)
+ (old-end old-length))
+ (declare (ignore old-end))
+ (let ((new-data (if (or (%array-displaced-p array)
+ (> new-length old-length))
+ (data-vector-from-inits
+ dimensions new-length
+ element-type () initial-element
+ initial-element-p)
+ old-data)))
+ (if (or (zerop old-length) (zerop new-length))
+ (when initial-element-p (fill new-data initial-element))
+ (zap-array-data old-data (array-dimensions array)
+ old-start
+ new-data dimensions new-length
+ element-type initial-element
+ initial-element-p))
+ (set-array-header array new-data new-length
+ new-length 0 dimensions nil)))))))))
+
+(defun get-new-fill-pointer (old-array new-array-size fill-pointer)
+ (cond ((not fill-pointer)
+ (when (array-has-fill-pointer-p old-array)
+ (when (> (%array-fill-pointer old-array) new-array-size)
+ (error "Cannot adjust-array an array (~S) to a size (~S) that is ~
+ smaller than its fill pointer (~S)."
+ old-array new-array-size (fill-pointer old-array)))
+ (%array-fill-pointer old-array)))
+ ((not (array-has-fill-pointer-p old-array))
+ (error "Cannot supply a non-NIL value (~S) for :fill-pointer ~
+ in adjust-array unless the array (~S) was originally ~
+ created with a fill pointer."
+ fill-pointer
+ old-array))
+ ((numberp fill-pointer)
+ (when (> fill-pointer new-array-size)
+ (error "Cannot supply a value for :fill-pointer (~S) that is larger ~
+ than the new length of the vector (~S)."
+ fill-pointer new-array-size))
+ fill-pointer)
+ ((eq fill-pointer t)
+ new-array-size)
+ (t
+ (error "Bogus value for :fill-pointer in adjust-array: ~S"
+ fill-pointer))))
+
+(defun shrink-vector (vector new-size)
+ #!+sb-doc
+ "Destructively alters the Vector, changing its length to New-Size, which
+ must be less than or equal to its current size."
+ (declare (vector vector))
+ (unless (array-header-p vector)
+ (macrolet ((frob (name &rest things)
+ `(etypecase ,name
+ ,@(mapcar #'(lambda (thing)
+ `(,(car thing)
+ (fill (truly-the ,(car thing) ,name)
+ ,(cadr thing)
+ :start new-size)))
+ things))))
+ (frob vector
+ (simple-vector 0)
+ (simple-base-string #.default-init-char)
+ (simple-bit-vector 0)
+ ((simple-array (unsigned-byte 2) (*)) 0)
+ ((simple-array (unsigned-byte 4) (*)) 0)
+ ((simple-array (unsigned-byte 8) (*)) 0)
+ ((simple-array (unsigned-byte 16) (*)) 0)
+ ((simple-array (unsigned-byte 32) (*)) 0)
+ ((simple-array (signed-byte 8) (*)) 0)
+ ((simple-array (signed-byte 16) (*)) 0)
+ ((simple-array (signed-byte 30) (*)) 0)
+ ((simple-array (signed-byte 32) (*)) 0)
+ ((simple-array single-float (*)) (coerce 0 'single-float))
+ ((simple-array double-float (*)) (coerce 0 'double-float))
+ #!+long-float
+ ((simple-array long-float (*)) (coerce 0 'long-float))
+ ((simple-array (complex single-float) (*))
+ (coerce 0 '(complex single-float)))
+ ((simple-array (complex double-float) (*))
+ (coerce 0 '(complex double-float)))
+ #!+long-float
+ ((simple-array (complex long-float) (*))
+ (coerce 0 '(complex long-float))))))
+ ;; Only arrays have fill-pointers, but vectors have their length
+ ;; parameter in the same place.
+ (setf (%array-fill-pointer vector) new-size)
+ vector)
+
+(defun set-array-header (array data length fill-pointer displacement dimensions
+ &optional displacedp)
+ #!+sb-doc
+ "Fills in array header with provided information. Returns array."
+ (setf (%array-data-vector array) data)
+ (setf (%array-available-elements array) length)
+ (cond (fill-pointer
+ (setf (%array-fill-pointer array) fill-pointer)
+ (setf (%array-fill-pointer-p array) t))
+ (t
+ (setf (%array-fill-pointer array) length)
+ (setf (%array-fill-pointer-p array) nil)))
+ (setf (%array-displacement array) displacement)
+ (if (listp dimensions)
+ (dotimes (axis (array-rank array))
+ (declare (type index axis))
+ (setf (%array-dimension array axis) (pop dimensions)))
+ (setf (%array-dimension array 0) dimensions))
+ (setf (%array-displaced-p array) displacedp)
+ array)
+\f
+;;;; ZAP-ARRAY-DATA for ADJUST-ARRAY
+
+;;; Make a temporary to be used when old-data and new-data are EQ.
+;;; KLUDGE: Boy, DYNAMIC-EXTENT would be nice.
+(defvar *zap-array-data-temp* (make-array 1000 :initial-element t))
+
+(defun zap-array-data-temp (length element-type initial-element
+ initial-element-p)
+ (declare (fixnum length))
+ (when (> length (the fixnum (length *zap-array-data-temp*)))
+ (setf *zap-array-data-temp*
+ (make-array length :initial-element t)))
+ (when initial-element-p
+ (unless (typep initial-element element-type)
+ (error "~S cannot be used to initialize an array of type ~S."
+ initial-element element-type))
+ (fill (the simple-vector *zap-array-data-temp*) initial-element
+ :end length))
+ *zap-array-data-temp*)
+
+;;; This does the grinding work for ADJUST-ARRAY. It zaps the data from the
+;;; Old-Data in an arrangement specified by the Old-Dims to the New-Data in an
+;;; arrangement specified by the New-Dims. Offset is a displaced offset to be
+;;; added to computed indexes of Old-Data. New-Length, Element-Type,
+;;; Initial-Element, and Initial-Element-P are used when Old-Data and New-Data
+;;; are EQ; in this case, a temporary must be used and filled appropriately.
+;;; When Old-Data and New-Data are not EQ, New-Data has already been filled
+;;; with any specified initial-element.
+(defun zap-array-data (old-data old-dims offset new-data new-dims new-length
+ element-type initial-element initial-element-p)
+ (declare (list old-dims new-dims))
+ (setq old-dims (nreverse old-dims))
+ (setq new-dims (reverse new-dims))
+ (if (eq old-data new-data)
+ (let ((temp (zap-array-data-temp new-length element-type
+ initial-element initial-element-p)))
+ (zap-array-data-aux old-data old-dims offset temp new-dims)
+ (dotimes (i new-length) (setf (aref new-data i) (aref temp i))))
+ (zap-array-data-aux old-data old-dims offset new-data new-dims)))
+
+(defun zap-array-data-aux (old-data old-dims offset new-data new-dims)
+ (declare (fixnum offset))
+ (let ((limits (mapcar #'(lambda (x y)
+ (declare (fixnum x y))
+ (1- (the fixnum (min x y))))
+ old-dims new-dims)))
+ (macrolet ((bump-index-list (index limits)
+ `(do ((subscripts ,index (cdr subscripts))
+ (limits ,limits (cdr limits)))
+ ((null subscripts) nil)
+ (cond ((< (the fixnum (car subscripts))
+ (the fixnum (car limits)))
+ (rplaca subscripts
+ (1+ (the fixnum (car subscripts))))
+ (return ,index))
+ (t (rplaca subscripts 0))))))
+ (do ((index (make-list (length old-dims) :initial-element 0)
+ (bump-index-list index limits)))
+ ((null index))
+ (setf (aref new-data (row-major-index-from-dims index new-dims))
+ (aref old-data
+ (+ (the fixnum (row-major-index-from-dims index old-dims))
+ offset)))))))
+
+;;; Figure out the row-major-order index of an array reference from a
+;;; list of subscripts and a list of dimensions. This is for internal calls
+;;; only, and the subscripts and dim-list variables are assumed to be reversed
+;;; from what the user supplied.
+(defun row-major-index-from-dims (rev-subscripts rev-dim-list)
+ (do ((rev-subscripts rev-subscripts (cdr rev-subscripts))
+ (rev-dim-list rev-dim-list (cdr rev-dim-list))
+ (chunk-size 1)
+ (result 0))
+ ((null rev-dim-list) result)
+ (declare (fixnum chunk-size result))
+ (setq result (+ result
+ (the fixnum (* (the fixnum (car rev-subscripts))
+ chunk-size))))
+ (setq chunk-size (* chunk-size (the fixnum (car rev-dim-list))))))
+\f
+;;;; some bit stuff
+
+(defun bit-array-same-dimensions-p (array1 array2)
+ (declare (type (array bit) array1 array2))
+ (and (= (array-rank array1)
+ (array-rank array2))
+ (dotimes (index (array-rank array1) t)
+ (when (/= (array-dimension array1 index)
+ (array-dimension array2 index))
+ (return nil)))))
+
+(defun pick-result-array (result-bit-array bit-array-1)
+ (case result-bit-array
+ ((t) bit-array-1)
+ ((nil) (make-array (array-dimensions bit-array-1)
+ :element-type 'bit
+ :initial-element 0))
+ (t
+ (unless (bit-array-same-dimensions-p bit-array-1
+ result-bit-array)
+ (error "~S and ~S do not have the same dimensions."
+ bit-array-1 result-bit-array))
+ result-bit-array)))
+
+(defmacro def-bit-array-op (name function)
+ `(defun ,name (bit-array-1 bit-array-2 &optional result-bit-array)
+ ,(format nil
+ "Perform a bit-wise ~A on the elements of BIT-ARRAY-1 and ~
+ BIT-ARRAY-2,~% putting the results in RESULT-BIT-ARRAY. ~
+ If RESULT-BIT-ARRAY is T,~% BIT-ARRAY-1 is used. If ~
+ RESULT-BIT-ARRAY is NIL or omitted, a new array is~% created. ~
+ All the arrays must have the same rank and dimensions."
+ (symbol-name function))
+ (declare (type (array bit) bit-array-1 bit-array-2)
+ (type (or (array bit) (member t nil)) result-bit-array))
+ (unless (bit-array-same-dimensions-p bit-array-1 bit-array-2)
+ (error "~S and ~S do not have the same dimensions."
+ bit-array-1 bit-array-2))
+ (let ((result-bit-array (pick-result-array result-bit-array bit-array-1)))
+ (if (and (simple-bit-vector-p bit-array-1)
+ (simple-bit-vector-p bit-array-2)
+ (simple-bit-vector-p result-bit-array))
+ (locally (declare (optimize (speed 3) (safety 0)))
+ (,name bit-array-1 bit-array-2 result-bit-array))
+ (with-array-data ((data1 bit-array-1) (start1) (end1))
+ (declare (ignore end1))
+ (with-array-data ((data2 bit-array-2) (start2) (end2))
+ (declare (ignore end2))
+ (with-array-data ((data3 result-bit-array) (start3) (end3))
+ (do ((index-1 start1 (1+ index-1))
+ (index-2 start2 (1+ index-2))
+ (index-3 start3 (1+ index-3)))
+ ((>= index-3 end3) result-bit-array)
+ (declare (type index index-1 index-2 index-3))
+ (setf (sbit data3 index-3)
+ (logand (,function (sbit data1 index-1)
+ (sbit data2 index-2))
+ 1))))))))))
+
+(def-bit-array-op bit-and logand)
+(def-bit-array-op bit-ior logior)
+(def-bit-array-op bit-xor logxor)
+(def-bit-array-op bit-eqv logeqv)
+(def-bit-array-op bit-nand lognand)
+(def-bit-array-op bit-nor lognor)
+(def-bit-array-op bit-andc1 logandc1)
+(def-bit-array-op bit-andc2 logandc2)
+(def-bit-array-op bit-orc1 logorc1)
+(def-bit-array-op bit-orc2 logorc2)
+
+(defun bit-not (bit-array &optional result-bit-array)
+ #!+sb-doc
+ "Performs a bit-wise logical NOT on the elements of BIT-ARRAY,
+ putting the results in RESULT-BIT-ARRAY. If RESULT-BIT-ARRAY is T,
+ BIT-ARRAY is used. If RESULT-BIT-ARRAY is NIL or omitted, a new array is
+ created. Both arrays must have the same rank and dimensions."
+ (declare (type (array bit) bit-array)
+ (type (or (array bit) (member t nil)) result-bit-array))
+ (let ((result-bit-array (pick-result-array result-bit-array bit-array)))
+ (if (and (simple-bit-vector-p bit-array)
+ (simple-bit-vector-p result-bit-array))
+ (locally (declare (optimize (speed 3) (safety 0)))
+ (bit-not bit-array result-bit-array))
+ (with-array-data ((src bit-array) (src-start) (src-end))
+ (declare (ignore src-end))
+ (with-array-data ((dst result-bit-array) (dst-start) (dst-end))
+ (do ((src-index src-start (1+ src-index))
+ (dst-index dst-start (1+ dst-index)))
+ ((>= dst-index dst-end) result-bit-array)
+ (declare (type index src-index dst-index))
+ (setf (sbit dst dst-index)
+ (logxor (sbit src src-index) 1))))))))
--- /dev/null
+;;;; the backquote reader macro
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!IMPL")
+
+(file-comment
+ "$Header$")
+
+;;; The flags passed back by BACKQUOTIFY can be interpreted as follows:
+;;;
+;;; |`,|: [a] => a
+;;; NIL: [a] => a ;the NIL flag is used only when a is NIL
+;;; T: [a] => a ;the T flag is used when a is self-evaluating
+;;; QUOTE: [a] => (QUOTE a)
+;;; APPEND: [a] => (APPEND . a)
+;;; NCONC: [a] => (NCONC . a)
+;;; LIST: [a] => (LIST . a)
+;;; LIST*: [a] => (LIST* . a)
+;;;
+;;; The flags are combined according to the following set of rules:
+;;; ([a] means that a should be converted according to the previous table)
+;;;
+;;; \ car || otherwise | QUOTE or | |`,@| | |`,.|
+;;;cdr \ || | T or NIL | |
+;;;================================================================================
+;;; |`,| || LIST* ([a] [d]) | LIST* ([a] [d]) | APPEND (a [d]) | NCONC (a [d])
+;;; NIL || LIST ([a]) | QUOTE (a) | <hair> a | <hair> a
+;;;QUOTE or T|| LIST* ([a] [d]) | QUOTE (a . d) | APPEND (a [d]) | NCONC (a [d])
+;;; APPEND || LIST* ([a] [d]) | LIST* ([a] [d]) | APPEND (a . d) | NCONC (a [d])
+;;; NCONC || LIST* ([a] [d]) | LIST* ([a] [d]) | APPEND (a [d]) | NCONC (a . d)
+;;; LIST || LIST ([a] . d) | LIST ([a] . d) | APPEND (a [d]) | NCONC (a [d])
+;;; LIST* || LIST* ([a] . d) | LIST* ([a] . d) | APPEND (a [d]) | NCONC (a [d])
+;;;
+;;;<hair> involves starting over again pretending you had read ".,a)" instead
+;;; of ",@a)"
+
+(defvar *backquote-count* 0 #!+sb-doc "how deep we are into backquotes")
+(defvar *bq-comma-flag* '(|,|))
+(defvar *bq-at-flag* '(|,@|))
+(defvar *bq-dot-flag* '(|,.|))
+(defvar *bq-vector-flag* '(|bqv|))
+
+;;; the actual character macro
+(defun backquote-macro (stream ignore)
+ (declare (ignore ignore))
+ (let ((*backquote-count* (1+ *backquote-count*)))
+ (multiple-value-bind (flag thing)
+ (backquotify stream (read stream t nil t))
+ (if (eq flag *bq-at-flag*)
+ (%reader-error stream ",@ after backquote in ~S" thing))
+ (if (eq flag *bq-dot-flag*)
+ (%reader-error stream ",. after backquote in ~S" thing))
+ (values (backquotify-1 flag thing) 'list))))
+
+(defun comma-macro (stream ignore)
+ (declare (ignore ignore))
+ (unless (> *backquote-count* 0)
+ (when *read-suppress*
+ (return-from comma-macro nil))
+ (%reader-error stream "comma not inside a backquote"))
+ (let ((c (read-char stream))
+ (*backquote-count* (1- *backquote-count*)))
+ (values
+ (cond ((char= c #\@)
+ (cons *bq-at-flag* (read stream t nil t)))
+ ((char= c #\.)
+ (cons *bq-dot-flag* (read stream t nil t)))
+ (t (unread-char c stream)
+ (cons *bq-comma-flag* (read stream t nil t))))
+ 'list)))
+
+;;; This does the expansion from table 2.
+(defun backquotify (stream code)
+ (cond ((atom code)
+ (cond ((null code) (values nil nil))
+ ((or (numberp code)
+ (eq code t))
+ ;; Keywords are self-evaluating. Install after packages.
+ (values t code))
+ (t (values 'quote code))))
+ ((or (eq (car code) *bq-at-flag*)
+ (eq (car code) *bq-dot-flag*))
+ (values (car code) (cdr code)))
+ ((eq (car code) *bq-comma-flag*)
+ (comma (cdr code)))
+ ((eq (car code) *bq-vector-flag*)
+ (multiple-value-bind (dflag d) (backquotify stream (cdr code))
+ (values 'vector (backquotify-1 dflag d))))
+ (t (multiple-value-bind (aflag a) (backquotify stream (car code))
+ (multiple-value-bind (dflag d) (backquotify stream (cdr code))
+ (if (eq dflag *bq-at-flag*)
+ ;; Get the errors later.
+ (%reader-error stream ",@ after dot in ~S" code))
+ (if (eq dflag *bq-dot-flag*)
+ (%reader-error stream ",. after dot in ~S" code))
+ (cond
+ ((eq aflag *bq-at-flag*)
+ (if (null dflag)
+ (comma a)
+ (values 'append
+ (cond ((eq dflag 'append)
+ (cons a d ))
+ (t (list a (backquotify-1 dflag d)))))))
+ ((eq aflag *bq-dot-flag*)
+ (if (null dflag)
+ (comma a)
+ (values 'nconc
+ (cond ((eq dflag 'nconc)
+ (cons a d))
+ (t (list a (backquotify-1 dflag d)))))))
+ ((null dflag)
+ (if (member aflag '(quote t nil))
+ (values 'quote (list a))
+ (values 'list (list (backquotify-1 aflag a)))))
+ ((member dflag '(quote t))
+ (if (member aflag '(quote t nil))
+ (values 'quote (cons a d ))
+ (values 'list* (list (backquotify-1 aflag a)
+ (backquotify-1 dflag d)))))
+ (t (setq a (backquotify-1 aflag a))
+ (if (member dflag '(list list*))
+ (values dflag (cons a d))
+ (values 'list*
+ (list a (backquotify-1 dflag d)))))))))))
+
+;;; This handles the <hair> cases.
+(defun comma (code)
+ (cond ((atom code)
+ (cond ((null code)
+ (values nil nil))
+ ((or (numberp code) (eq code 't))
+ (values t code))
+ (t (values *bq-comma-flag* code))))
+ ((eq (car code) 'quote)
+ (values (car code) (cadr code)))
+ ((member (car code) '(append list list* nconc))
+ (values (car code) (cdr code)))
+ ((eq (car code) 'cons)
+ (values 'list* (cdr code)))
+ (t (values *bq-comma-flag* code))))
+
+;;; This handles table 1.
+(defun backquotify-1 (flag thing)
+ (cond ((or (eq flag *bq-comma-flag*)
+ (member flag '(t nil)))
+ thing)
+ ((eq flag 'quote)
+ (list 'quote thing))
+ ((eq flag 'list*)
+ (cond ((null (cddr thing))
+ (cons 'backq-cons thing))
+ (t
+ (cons 'backq-list* thing))))
+ ((eq flag 'vector)
+ (list 'backq-vector thing))
+ (t (cons (cdr
+ (assoc flag
+ '((cons . backq-cons)
+ (list . backq-list)
+ (append . backq-append)
+ (nconc . backq-nconc))
+ :test #'equal))
+ thing))))
+\f
+;;;; magic BACKQ- versions of builtin functions
+
+;;; Define synonyms for the lisp functions we use, so that by using them, we
+;;; backquoted material will be recognizable to the pretty-printer.
+(macrolet ((def-frob (b-name name)
+ (let ((args (gensym "ARGS")))
+ ;; FIXME: This function should be INLINE so that the lists
+ ;; aren't consed twice, but I ran into an optimizer bug the
+ ;; first time I tried to make this work for BACKQ-LIST. See
+ ;; whether there's still an optimizer bug, and fix it if so, and
+ ;; then make these INLINE.
+ `(defun ,b-name (&rest ,args)
+ (apply #',name ,args)))))
+ (def-frob backq-list list)
+ (def-frob backq-list* list*)
+ (def-frob backq-append append)
+ (def-frob backq-nconc nconc)
+ (def-frob backq-cons cons))
+
+(defun backq-vector (list)
+ (declare (list list))
+ (coerce list 'simple-vector))
+\f
+;;;; initialization
+
+;;; Install BACKQ stuff in the current *READTABLE*.
+;;;
+;;; In the target Lisp, we have to wait to do this until the readtable has been
+;;; created. In the cross-compilation host Lisp, we can do this right away.
+;;; (You may ask: In the cross-compilation host, which already has its own
+;;; implementation of the backquote readmacro, why do we do this at all?
+;;; Because the cross-compilation host might -- as SBCL itself does -- express
+;;; the backquote expansion in terms of internal, nonportable functions. By
+;;; redefining backquote in terms of functions which are guaranteed to exist on
+;;; the target Lisp, we ensure that backquote expansions in code-generating
+;;; code work properly.)
+(defun !backq-cold-init ()
+ (set-macro-character #\` #'backquote-macro)
+ (set-macro-character #\, #'comma-macro))
+#+sb-xc-host (!backq-cold-init)
--- /dev/null
+;;;; code to implement bignum support
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!BIGNUM")
+
+(file-comment
+ "$Header$")
+\f
+;;;; notes
+
+;;; comments from CMU CL:
+;;; These symbols define the interface to the number code:
+;;; add-bignums multiply-bignums negate-bignum subtract-bignum
+;;; multiply-bignum-and-fixnum multiply-fixnums
+;;; bignum-ashift-right bignum-ashift-left bignum-gcd
+;;; bignum-to-float bignum-integer-length
+;;; bignum-logical-and bignum-logical-ior bignum-logical-xor
+;;; bignum-logical-not bignum-load-byte bignum-deposit-byte
+;;; bignum-truncate bignum-plus-p bignum-compare make-small-bignum
+;;; bignum-logcount
+;;; These symbols define the interface to the compiler:
+;;; bignum-type bignum-element-type bignum-index %allocate-bignum
+;;; %bignum-length %bignum-set-length %bignum-ref %bignum-set
+;;; %digit-0-or-plusp %add-with-carry %subtract-with-borrow
+;;; %multiply-and-add %multiply %lognot %logand %logior %logxor
+;;; %fixnum-to-digit %floor %fixnum-digit-with-correct-sign %ashl
+;;; %ashr %digit-logical-shift-right))
+
+;;; The following interfaces will either be assembler routines or code
+;;; sequences expanded into the code as basic bignum operations:
+;;; General:
+;;; %BIGNUM-LENGTH
+;;; %ALLOCATE-BIGNUM
+;;; %BIGNUM-REF
+;;; %NORMALIZE-BIGNUM
+;;; %BIGNUM-SET-LENGTH
+;;; %FIXNUM-DIGIT-WITH-CORRECT-SIGN
+;;; %SIGN-DIGIT
+;;; %ASHR
+;;; %ASHL
+;;; %BIGNUM-0-OR-PLUSP
+;;; %DIGIT-LOGICAL-SHIFT-RIGHT
+;;; General (May not exist when done due to sole use in %-routines.)
+;;; %DIGIT-0-OR-PLUSP
+;;; Addition:
+;;; %ADD-WITH-CARRY
+;;; Subtraction:
+;;; %SUBTRACT-WITH-BORROW
+;;; Multiplication
+;;; %MULTIPLY
+;;; Negation
+;;; %LOGNOT
+;;; Shifting (in place)
+;;; %NORMALIZE-BIGNUM-BUFFER
+;;; GCD/Relational operators:
+;;; %DIGIT-COMPARE
+;;; %DIGIT-GREATER
+;;; Relational operators:
+;;; %LOGAND
+;;; %LOGIOR
+;;; %LOGXOR
+;;; LDB
+;;; %FIXNUM-TO-DIGIT
+;;; TRUNCATE
+;;; %FLOOR
+;;;
+;;; Note: The floating routines know about the float representation.
+;;;
+;;; PROBLEM 1:
+;;; There might be a problem with various LET's and parameters that take a
+;;; digit value. We need to write these so those things stay in 32-bit
+;;; registers and number stack slots. I bind locals to these values, and I
+;;; use function on them -- ZEROP, ASH, etc.
+;;;
+;;; PROBLEM 2:
+;;; In shifting and byte operations, I use masks and logical operations that
+;;; could result in intermediate bignums. This is hidden by the current system,
+;;; but I may need to write these in a way that keeps these masks and logical
+;;; operations from diving into the Lisp level bignum code.
+;;;
+;;; To do:
+;;; fixnums
+;;; logior, logxor, logand
+;;; depending on relationals, < (twice) and <= (twice)
+;;; or write compare thing (twice).
+;;; LDB on fixnum with bignum result.
+;;; DPB on fixnum with bignum result.
+;;; TRUNCATE returns zero or one as one value and fixnum or minus fixnum
+;;; for the other value when given (truncate fixnum bignum).
+;;; Returns (truncate bignum fixnum) otherwise.
+;;; addition
+;;; subtraction (twice)
+;;; multiply
+;;; GCD
+;;; Write MASK-FIELD and DEPOSIT-FIELD in terms of logical operations.
+;;; DIVIDE
+;;; IF (/ x y) with bignums:
+;;; do the truncate, and if rem is 0, return quotient.
+;;; if rem is non-0
+;;; gcd of x and y.
+;;; "truncate" each by gcd, ignoring remainder 0.
+;;; form ratio of each result, bottom is positive.
+\f
+;;;; What's a bignum?
+
+(eval-when (:compile-toplevel :load-toplevel :execute) ; necessary for DEFTYPE
+
+(defconstant digit-size 32)
+
+(defconstant maximum-bignum-length (1- (ash 1 (- 32 sb!vm:type-bits))))
+
+) ; EVAL-WHEN
+\f
+;;;; internal inline routines
+
+;;; %ALLOCATE-BIGNUM must zero all elements.
+(defun %allocate-bignum (length)
+ (declare (type bignum-index length))
+ (%allocate-bignum length))
+
+;;; Extract the length of the bignum.
+(defun %bignum-length (bignum)
+ (declare (type bignum-type bignum))
+ (%bignum-length bignum))
+
+;;; %BIGNUM-REF needs to access bignums as obviously as possible, and it needs
+;;; to be able to return 32 bits somewhere no one looks for real objects.
+(defun %bignum-ref (bignum i)
+ (declare (type bignum-type bignum)
+ (type bignum-index i))
+ (%bignum-ref bignum i))
+(defun %bignum-set (bignum i value)
+ (declare (type bignum-type bignum)
+ (type bignum-index i)
+ (type bignum-element-type value))
+ (%bignum-set bignum i value))
+
+;;; Return T if digit is positive, or NIL if negative.
+(defun %digit-0-or-plusp (digit)
+ (declare (type bignum-element-type digit))
+ (not (logbitp (1- digit-size) digit)))
+
+#!-sb-fluid (declaim (inline %bignum-0-or-plusp))
+(defun %bignum-0-or-plusp (bignum len)
+ (declare (type bignum-type bignum)
+ (type bignum-index len))
+ (%digit-0-or-plusp (%bignum-ref bignum (1- len))))
+
+;;; This should be in assembler, and should not cons intermediate results. It
+;;; returns a 32bit digit and a carry resulting from adding together a, b, and
+;;; an incoming carry.
+(defun %add-with-carry (a b carry)
+ (declare (type bignum-element-type a b)
+ (type (mod 2) carry))
+ (%add-with-carry a b carry))
+
+;;; This should be in assembler, and should not cons intermediate results. It
+;;; returns a 32bit digit and a borrow resulting from subtracting b from a, and
+;;; subtracting a possible incoming borrow.
+;;;
+;;; We really do: a - b - 1 + borrow, where borrow is either 0 or 1.
+(defun %subtract-with-borrow (a b borrow)
+ (declare (type bignum-element-type a b)
+ (type (mod 2) borrow))
+ (%subtract-with-borrow a b borrow))
+
+;;; Multiply two digit-size (32-bit) numbers, returning a 64-bit result
+;;; split into two 32-bit quantities.
+(defun %multiply (x y)
+ (declare (type bignum-element-type x y))
+ (%multiply x y))
+
+;;; This multiplies x-digit and y-digit, producing high and low digits
+;;; manifesting the result. Then it adds the low digit, res-digit, and
+;;; carry-in-digit. Any carries (note, you still have to add two digits at a
+;;; time possibly producing two carries) from adding these three digits get
+;;; added to the high digit from the multiply, producing the next carry digit.
+;;; Res-digit is optional since two uses of this primitive multiplies a single
+;;; digit bignum by a multiple digit bignum, and in this situation there is no
+;;; need for a result buffer accumulating partial results which is where the
+;;; res-digit comes from.
+(defun %multiply-and-add (x-digit y-digit carry-in-digit
+ &optional (res-digit 0))
+ (declare (type bignum-element-type x-digit y-digit res-digit carry-in-digit))
+ (%multiply-and-add x-digit y-digit carry-in-digit res-digit))
+
+(defun %lognot (digit)
+ (declare (type bignum-element-type digit))
+ (%lognot digit))
+
+;;; Each of these does the 32-bit unsigned op.
+#!-sb-fluid (declaim (inline %logand %logior %logxor))
+(defun %logand (a b)
+ (declare (type bignum-element-type a b))
+ (logand a b))
+(defun %logior (a b)
+ (declare (type bignum-element-type a b))
+ (logior a b))
+(defun %logxor (a b)
+ (declare (type bignum-element-type a b))
+ (logxor a b))
+
+;;; This takes a fixnum and sets it up as an unsigned 32-bit quantity. In
+;;; the new system this will mean shifting it right two bits.
+(defun %fixnum-to-digit (x)
+ (declare (fixnum x))
+ (logand x (1- (ash 1 digit-size))))
+
+#!-32x16-divide
+;;; This takes three digits and returns the FLOOR'ed result of dividing the
+;;; first two as a 64-bit integer by the third.
+;;;
+;;; DO WEIRD let AND setq STUFF TO SLIME THE COMPILER INTO ALLOWING THE %FLOOR
+;;; TRANSFORM TO EXPAND INTO PSEUDO-ASSEMBLER FOR WHICH THE COMPILER CAN LATER
+;;; CORRECTLY ALLOCATE REGISTERS.
+(defun %floor (a b c)
+ (let ((a a) (b b) (c c))
+ (declare (type bignum-element-type a b c))
+ (setq a a b b c c)
+ (%floor a b c)))
+
+;;; Convert the digit to a regular integer assuming that the digit is signed.
+(defun %fixnum-digit-with-correct-sign (digit)
+ (declare (type bignum-element-type digit))
+ (if (logbitp (1- digit-size) digit)
+ (logior digit (ash -1 digit-size))
+ digit))
+
+;;; Do an arithmetic shift right of data even though bignum-element-type is
+;;; unsigned.
+(defun %ashr (data count)
+ (declare (type bignum-element-type data)
+ (type (mod 32) count))
+ (%ashr data count))
+
+;;; This takes a 32-bit quantity and shifts it to the left, returning a 32-bit
+;;; quantity.
+(defun %ashl (data count)
+ (declare (type bignum-element-type data)
+ (type (mod 32) count))
+ (%ashl data count))
+
+;;; Do an unsigned (logical) right shift of a digit by Count.
+(defun %digit-logical-shift-right (data count)
+ (declare (type bignum-element-type data)
+ (type (mod 32) count))
+ (%digit-logical-shift-right data count))
+
+;;; Change the length of bignum to be newlen. Newlen must be the same or
+;;; smaller than the old length, and any elements beyond newlen must be zeroed.
+(defun %bignum-set-length (bignum newlen)
+ (declare (type bignum-type bignum)
+ (type bignum-index newlen))
+ (%bignum-set-length bignum newlen))
+
+;;; This returns 0 or "-1" depending on whether the bignum is positive. This
+;;; is suitable for infinite sign extension to complete additions,
+;;; subtractions, negations, etc. This cannot return a -1 represented as
+;;; a negative fixnum since it would then have to low zeros.
+#!-sb-fluid (declaim (inline %sign-digit))
+(defun %sign-digit (bignum len)
+ (declare (type bignum-type bignum)
+ (type bignum-index len))
+ (%ashr (%bignum-ref bignum (1- len)) (1- digit-size)))
+
+;;; These take two 32 bit quantities and compare or contrast them without
+;;; wasting time with incorrect type checking.
+#!-sb-fluid (declaim (inline %digit-compare %digit-greater))
+(defun %digit-compare (x y)
+ (= x y))
+(defun %digit-greater (x y)
+ (> x y))
+\f
+(declaim (optimize (speed 3) (safety 0)))
+\f
+;;;; addition
+
+(defun add-bignums (a b)
+ (declare (type bignum-type a b))
+ (let ((len-a (%bignum-length a))
+ (len-b (%bignum-length b)))
+ (declare (type bignum-index len-a len-b))
+ (multiple-value-bind (a len-a b len-b)
+ (if (> len-a len-b)
+ (values a len-a b len-b)
+ (values b len-b a len-a))
+ (declare (type bignum-type a b)
+ (type bignum-index len-a len-b))
+ (let* ((len-res (1+ len-a))
+ (res (%allocate-bignum len-res))
+ (carry 0))
+ (declare (type bignum-index len-res)
+ (type bignum-type res)
+ (type (mod 2) carry))
+ (dotimes (i len-b)
+ (declare (type bignum-index i))
+ (multiple-value-bind (v k)
+ (%add-with-carry (%bignum-ref a i) (%bignum-ref b i) carry)
+ (declare (type bignum-element-type v)
+ (type (mod 2) k))
+ (setf (%bignum-ref res i) v)
+ (setf carry k)))
+ (if (/= len-a len-b)
+ (finish-add a res carry (%sign-digit b len-b) len-b len-a)
+ (setf (%bignum-ref res len-a)
+ (%add-with-carry (%sign-digit a len-a)
+ (%sign-digit b len-b)
+ carry)))
+ (%normalize-bignum res len-res)))))
+
+;;; This takes the longer of two bignums and propagates the carry through its
+;;; remaining high order digits.
+(defun finish-add (a res carry sign-digit-b start end)
+ (declare (type bignum-type a res)
+ (type (mod 2) carry)
+ (type bignum-element-type sign-digit-b)
+ (type bignum-index start end))
+ (do ((i start (1+ i)))
+ ((= i end)
+ (setf (%bignum-ref res end)
+ (%add-with-carry (%sign-digit a end) sign-digit-b carry)))
+ (declare (type bignum-index i))
+ (multiple-value-bind (v k)
+ (%add-with-carry (%bignum-ref a i) sign-digit-b carry)
+ (setf (%bignum-ref res i) v)
+ (setf carry k)))
+ (values))
+\f
+;;;; subtraction
+
+(eval-when (:compile-toplevel :execute)
+
+;;; This subtracts b from a plugging result into res. Return-fun is the
+;;; function to call that fixes up the result returning any useful values, such
+;;; as the result. This macro may evaluate its arguments more than once.
+(sb!xc:defmacro subtract-bignum-loop (a len-a b len-b res len-res return-fun)
+ (let ((borrow (gensym))
+ (a-digit (gensym))
+ (a-sign (gensym))
+ (b-digit (gensym))
+ (b-sign (gensym))
+ (i (gensym))
+ (v (gensym))
+ (k (gensym)))
+ `(let* ((,borrow 1)
+ (,a-sign (%sign-digit ,a ,len-a))
+ (,b-sign (%sign-digit ,b ,len-b)))
+ (declare (type bignum-element-type ,a-sign ,b-sign))
+ (dotimes (,i ,len-res)
+ (declare (type bignum-index ,i))
+ (let ((,a-digit (if (< ,i ,len-a) (%bignum-ref ,a ,i) ,a-sign))
+ (,b-digit (if (< ,i ,len-b) (%bignum-ref ,b ,i) ,b-sign)))
+ (declare (type bignum-element-type ,a-digit ,b-digit))
+ (multiple-value-bind (,v ,k)
+ (%subtract-with-borrow ,a-digit ,b-digit ,borrow)
+ (setf (%bignum-ref ,res ,i) ,v)
+ (setf ,borrow ,k))))
+ (,return-fun ,res ,len-res))))
+
+) ;EVAL-WHEN
+
+(defun subtract-bignum (a b)
+ (declare (type bignum-type a b))
+ (let* ((len-a (%bignum-length a))
+ (len-b (%bignum-length b))
+ (len-res (1+ (max len-a len-b)))
+ (res (%allocate-bignum len-res)))
+ (declare (type bignum-index len-a len-b len-res)) ;Test len-res for bounds?
+ (subtract-bignum-loop a len-a b len-b res len-res %normalize-bignum)))
+
+;;; Operations requiring a subtraction without the overhead of intermediate
+;;; results, such as GCD, use this. It assumes Result is big enough for the
+;;; result.
+(defun subtract-bignum-buffers (a len-a b len-b result)
+ (declare (type bignum-type a b)
+ (type bignum-index len-a len-b))
+ (let ((len-res (max len-a len-b)))
+ (subtract-bignum-loop a len-a b len-b result len-res
+ %normalize-bignum-buffer)))
+\f
+;;;; multiplication
+
+(defun multiply-bignums (a b)
+ (declare (type bignum-type a b))
+ (let* ((a-plusp (%bignum-0-or-plusp a (%bignum-length a)))
+ (b-plusp (%bignum-0-or-plusp b (%bignum-length b)))
+ (a (if a-plusp a (negate-bignum a)))
+ (b (if b-plusp b (negate-bignum b)))
+ (len-a (%bignum-length a))
+ (len-b (%bignum-length b))
+ (len-res (+ len-a len-b))
+ (res (%allocate-bignum len-res))
+ (negate-res (not (eq a-plusp b-plusp))))
+ (declare (type bignum-index len-a len-b len-res))
+ (dotimes (i len-a)
+ (declare (type bignum-index i))
+ (let ((carry-digit 0)
+ (x (%bignum-ref a i))
+ (k i))
+ (declare (type bignum-index k)
+ (type bignum-element-type carry-digit x))
+ (dotimes (j len-b)
+ (multiple-value-bind (big-carry res-digit)
+ (%multiply-and-add x
+ (%bignum-ref b j)
+ (%bignum-ref res k)
+ carry-digit)
+ (declare (type bignum-element-type big-carry res-digit))
+ (setf (%bignum-ref res k) res-digit)
+ (setf carry-digit big-carry)
+ (incf k)))
+ (setf (%bignum-ref res k) carry-digit)))
+ (when negate-res (negate-bignum-in-place res))
+ (%normalize-bignum res len-res)))
+
+(defun multiply-bignum-and-fixnum (bignum fixnum)
+ (declare (type bignum-type bignum) (type fixnum fixnum))
+ (let* ((bignum-plus-p (%bignum-0-or-plusp bignum (%bignum-length bignum)))
+ (fixnum-plus-p (not (minusp fixnum)))
+ (bignum (if bignum-plus-p bignum (negate-bignum bignum)))
+ (bignum-len (%bignum-length bignum))
+ (fixnum (if fixnum-plus-p fixnum (- fixnum)))
+ (result (%allocate-bignum (1+ bignum-len)))
+ (carry-digit 0))
+ (declare (type bignum-type bignum result)
+ (type bignum-index bignum-len)
+ (type bignum-element-type fixnum carry-digit))
+ (dotimes (index bignum-len)
+ (declare (type bignum-index index))
+ (multiple-value-bind (next-digit low)
+ (%multiply-and-add (%bignum-ref bignum index) fixnum carry-digit)
+ (declare (type bignum-element-type next-digit low))
+ (setf carry-digit next-digit)
+ (setf (%bignum-ref result index) low)))
+ (setf (%bignum-ref result bignum-len) carry-digit)
+ (unless (eq bignum-plus-p fixnum-plus-p)
+ (negate-bignum-in-place result))
+ (%normalize-bignum result (1+ bignum-len))))
+
+(defun multiply-fixnums (a b)
+ (declare (fixnum a b))
+ (let* ((a-minusp (minusp a))
+ (b-minusp (minusp b)))
+ (multiple-value-bind (high low)
+ (%multiply (if a-minusp (- a) a)
+ (if b-minusp (- b) b))
+ (declare (type bignum-element-type high low))
+ (if (and (zerop high)
+ (%digit-0-or-plusp low))
+ (let ((low (sb!ext:truly-the (unsigned-byte 31)
+ (%fixnum-digit-with-correct-sign low))))
+ (if (eq a-minusp b-minusp)
+ low
+ (- low)))
+ (let ((res (%allocate-bignum 2)))
+ (%bignum-set res 0 low)
+ (%bignum-set res 1 high)
+ (unless (eq a-minusp b-minusp) (negate-bignum-in-place res))
+ (%normalize-bignum res 2))))))
+\f
+;;;; BIGNUM-REPLACE and WITH-BIGNUM-BUFFERS
+
+(eval-when (:compile-toplevel :execute)
+
+(sb!xc:defmacro bignum-replace (dest
+ src
+ &key
+ (start1 '0)
+ end1
+ (start2 '0)
+ end2
+ from-end)
+ (sb!int:once-only ((n-dest dest)
+ (n-src src))
+ (let ((n-start1 (gensym))
+ (n-end1 (gensym))
+ (n-start2 (gensym))
+ (n-end2 (gensym))
+ (i1 (gensym))
+ (i2 (gensym))
+ (end1 (or end1 `(%bignum-length ,n-dest)))
+ (end2 (or end2 `(%bignum-length ,n-src))))
+ (if from-end
+ `(let ((,n-start1 ,start1)
+ (,n-start2 ,start2))
+ (do ((,i1 (1- ,end1) (1- ,i1))
+ (,i2 (1- ,end2) (1- ,i2)))
+ ((or (< ,i1 ,n-start1) (< ,i2 ,n-start2)))
+ (declare (fixnum ,i1 ,i2))
+ (%bignum-set ,n-dest ,i1
+ (%bignum-ref ,n-src ,i2))))
+ `(let ((,n-end1 ,end1)
+ (,n-end2 ,end2))
+ (do ((,i1 ,start1 (1+ ,i1))
+ (,i2 ,start2 (1+ ,i2)))
+ ((or (>= ,i1 ,n-end1) (>= ,i2 ,n-end2)))
+ (declare (type bignum-index ,i1 ,i2))
+ (%bignum-set ,n-dest ,i1
+ (%bignum-ref ,n-src ,i2))))))))
+
+(sb!xc:defmacro with-bignum-buffers (specs &body body)
+ #!+sb-doc
+ "WITH-BIGNUM-BUFFERS ({(var size [init])}*) Form*"
+ (sb!int:collect ((binds)
+ (inits))
+ (dolist (spec specs)
+ (let ((name (first spec))
+ (size (second spec)))
+ (binds `(,name (%allocate-bignum ,size)))
+ (let ((init (third spec)))
+ (when init
+ (inits `(bignum-replace ,name ,init))))))
+ `(let* ,(binds)
+ ,@(inits)
+ ,@body)))
+
+) ;EVAL-WHEN
+\f
+;;;; GCD
+
+(defun bignum-gcd (a b)
+ (declare (type bignum-type a b))
+ (let* ((a (if (%bignum-0-or-plusp a (%bignum-length a))
+ a
+ (negate-bignum a nil)))
+ (b (if (%bignum-0-or-plusp b (%bignum-length b))
+ b
+ (negate-bignum b nil)))
+ (len-a (%bignum-length a))
+ (len-b (%bignum-length b)))
+ (declare (type bignum-index len-a len-b))
+ (with-bignum-buffers ((a-buffer len-a a)
+ (b-buffer len-b b)
+ (res-buffer (max len-a len-b)))
+ (let* ((factors-of-two
+ (bignum-factors-of-two a-buffer len-a
+ b-buffer len-b))
+ (len-a (make-gcd-bignum-odd
+ a-buffer
+ (bignum-buffer-ashift-right a-buffer len-a
+ factors-of-two)))
+ (len-b (make-gcd-bignum-odd
+ b-buffer
+ (bignum-buffer-ashift-right b-buffer len-b
+ factors-of-two))))
+ (declare (type bignum-index len-a len-b))
+ (let ((x a-buffer)
+ (len-x len-a)
+ (y b-buffer)
+ (len-y len-b)
+ (z res-buffer))
+ (loop
+ (multiple-value-bind (u v len-v r len-r)
+ (bignum-gcd-order-and-subtract x len-x y len-y z)
+ (declare (type bignum-index len-v len-r))
+ (when (and (= len-r 1) (zerop (%bignum-ref r 0)))
+ (if (zerop factors-of-two)
+ (let ((ret (%allocate-bignum len-v)))
+ (dotimes (i len-v)
+ (setf (%bignum-ref ret i) (%bignum-ref v i)))
+ (return (%normalize-bignum ret len-v)))
+ (return (bignum-ashift-left v factors-of-two len-v))))
+ (setf x v len-x len-v)
+ (setf y r len-y (make-gcd-bignum-odd r len-r))
+ (setf z u))))))))
+
+(defun bignum-gcd-order-and-subtract (a len-a b len-b res)
+ (declare (type bignum-index len-a len-b) (type bignum-type a b))
+ (cond ((= len-a len-b)
+ (do ((i (1- len-a) (1- i)))
+ ((= i -1)
+ (setf (%bignum-ref res 0) 0)
+ (values a b len-b res 1))
+ (let ((a-digit (%bignum-ref a i))
+ (b-digit (%bignum-ref b i)))
+ (cond ((%digit-compare a-digit b-digit))
+ ((%digit-greater a-digit b-digit)
+ (return
+ (values a b len-b res
+ (subtract-bignum-buffers a len-a b len-b res))))
+ (t
+ (return
+ (values b a len-a res
+ (subtract-bignum-buffers b len-b
+ a len-a
+ res))))))))
+ ((> len-a len-b)
+ (values a b len-b res
+ (subtract-bignum-buffers a len-a b len-b res)))
+ (t
+ (values b a len-a res
+ (subtract-bignum-buffers b len-b a len-a res)))))
+
+(defun make-gcd-bignum-odd (a len-a)
+ (declare (type bignum-type a) (type bignum-index len-a))
+ (dotimes (index len-a)
+ (declare (type bignum-index index))
+ (do ((digit (%bignum-ref a index) (%ashr digit 1))
+ (increment 0 (1+ increment)))
+ ((zerop digit))
+ (declare (type (mod 32) increment))
+ (when (oddp digit)
+ (return-from make-gcd-bignum-odd
+ (bignum-buffer-ashift-right a len-a
+ (+ (* index digit-size)
+ increment)))))))
+
+(defun bignum-factors-of-two (a len-a b len-b)
+ (declare (type bignum-index len-a len-b) (type bignum-type a))
+ (do ((i 0 (1+ i))
+ (end (min len-a len-b)))
+ ((= i end) (error "Unexpected zero bignums?"))
+ (declare (type bignum-index i end))
+ (let ((or-digits (%logior (%bignum-ref a i) (%bignum-ref b i))))
+ (unless (zerop or-digits)
+ (return (do ((j 0 (1+ j))
+ (or-digits or-digits (%ashr or-digits 1)))
+ ((oddp or-digits) (+ (* i digit-size) j))
+ (declare (type (mod 32) j))))))))
+\f
+;;;; negation
+
+(eval-when (:compile-toplevel :execute)
+
+;;; This negates bignum-len digits of bignum, storing the resulting digits into
+;;; result (possibly EQ to bignum) and returning whatever end-carry there is.
+(sb!xc:defmacro bignum-negate-loop (bignum
+ bignum-len
+ &optional (result nil resultp))
+ (let ((carry (gensym))
+ (end (gensym))
+ (value (gensym))
+ (last (gensym)))
+ `(let* (,@(if (not resultp) `(,last))
+ (,carry
+ (multiple-value-bind (,value ,carry)
+ (%add-with-carry (%lognot (%bignum-ref ,bignum 0)) 1 0)
+ ,(if resultp
+ `(setf (%bignum-ref ,result 0) ,value)
+ `(setf ,last ,value))
+ ,carry))
+ (i 1)
+ (,end ,bignum-len))
+ (declare (type bit ,carry)
+ (type bignum-index i ,end))
+ (loop
+ (when (= i ,end) (return))
+ (multiple-value-bind (,value temp)
+ (%add-with-carry (%lognot (%bignum-ref ,bignum i)) 0 ,carry)
+ ,(if resultp
+ `(setf (%bignum-ref ,result i) ,value)
+ `(setf ,last ,value))
+ (setf ,carry temp))
+ (incf i))
+ ,(if resultp carry `(values ,carry ,last)))))
+
+) ; EVAL-WHEN
+
+;;; Fully-normalize is an internal optional. It cause this to always return
+;;; a bignum, without any extraneous digits, and it never returns a fixnum.
+(defun negate-bignum (x &optional (fully-normalize t))
+ (declare (type bignum-type x))
+ (let* ((len-x (%bignum-length x))
+ (len-res (1+ len-x))
+ (res (%allocate-bignum len-res)))
+ (declare (type bignum-index len-x len-res)) ;Test len-res for range?
+ (let ((carry (bignum-negate-loop x len-x res)))
+ (setf (%bignum-ref res len-x)
+ (%add-with-carry (%lognot (%sign-digit x len-x)) 0 carry)))
+ (if fully-normalize
+ (%normalize-bignum res len-res)
+ (%mostly-normalize-bignum res len-res))))
+
+;;; This assumes bignum is positive; that is, the result of negating it will
+;;; stay in the provided allocated bignum.
+(defun negate-bignum-in-place (bignum)
+ (bignum-negate-loop bignum (%bignum-length bignum) bignum)
+ bignum)
+\f
+;;;; shifting
+
+(defconstant all-ones-digit #xFFFFFFFF)
+
+(eval-when (:compile-toplevel :execute)
+
+;;; This macro is used by BIGNUM-ASHIFT-RIGHT, BIGNUM-BUFFER-ASHIFT-RIGHT, and
+;;; BIGNUM-LDB-BIGNUM-RES. They supply a termination form that references
+;;; locals established by this form. Source is the source bignum. Start-digit
+;;; is the first digit in source from which we pull bits. Start-pos is the
+;;; first bit we want. Res-len-form is the form that computes the length of
+;;; the resulting bignum. Termination is a DO termination form with a test and
+;;; body. When result is supplied, it is the variable to which this binds a
+;;; newly allocated bignum.
+;;;
+;;; Given start-pos, 1-31 inclusively, of shift, we form the j'th resulting
+;;; digit from high bits of the i'th source digit and the start-pos number of
+;;; bits from the i+1'th source digit.
+(sb!xc:defmacro shift-right-unaligned (source
+ start-digit
+ start-pos
+ res-len-form
+ termination
+ &optional result)
+ `(let* ((high-bits-in-first-digit (- digit-size ,start-pos))
+ (res-len ,res-len-form)
+ (res-len-1 (1- res-len))
+ ,@(if result `((,result (%allocate-bignum res-len)))))
+ (declare (type bignum-index res-len res-len-1))
+ (do ((i ,start-digit i+1)
+ (i+1 (1+ ,start-digit) (1+ i+1))
+ (j 0 (1+ j)))
+ ,termination
+ (declare (type bignum-index i i+1 j))
+ (setf (%bignum-ref ,(if result result source) j)
+ (%logior (%digit-logical-shift-right (%bignum-ref ,source i)
+ ,start-pos)
+ (%ashl (%bignum-ref ,source i+1)
+ high-bits-in-first-digit))))))
+
+) ; EVAL-WHEN
+
+;;; First compute the number of whole digits to shift, shifting them by
+;;; skipping them when we start to pick up bits, and the number of bits to
+;;; shift the remaining digits into place. If the number of digits is greater
+;;; than the length of the bignum, then the result is either 0 or -1. If we
+;;; shift on a digit boundary (that is, n-bits is zero), then we just copy
+;;; digits. The last branch handles the general case which uses a macro that a
+;;; couple other routines use. The fifth argument to the macro references
+;;; locals established by the macro.
+(defun bignum-ashift-right (bignum count)
+ (declare (type bignum-type bignum)
+ (type unsigned-byte count))
+ (let ((bignum-len (%bignum-length bignum)))
+ (declare (type bignum-index bignum-len))
+ (cond ((fixnump count)
+ (multiple-value-bind (digits n-bits) (truncate count digit-size)
+ (declare (type bignum-index digits))
+ (cond
+ ((>= digits bignum-len)
+ (if (%bignum-0-or-plusp bignum bignum-len) 0 -1))
+ ((zerop n-bits)
+ (bignum-ashift-right-digits bignum digits))
+ (t
+ (shift-right-unaligned bignum digits n-bits (- bignum-len digits)
+ ((= j res-len-1)
+ (setf (%bignum-ref res j)
+ (%ashr (%bignum-ref bignum i) n-bits))
+ (%normalize-bignum res res-len))
+ res)))))
+ ((> count bignum-len)
+ 0)
+ ;; Since a FIXNUM should be big enough to address anything in
+ ;; memory, including arrays of bits, and since arrays of bits
+ ;; take up about the same space as corresponding fixnums, there
+ ;; should be no way that we fall through to this case: any shift
+ ;; right by a bignum should give zero. But let's check anyway:
+ (t (error "bignum overflow: can't shift right by ~S")))))
+
+(defun bignum-ashift-right-digits (bignum digits)
+ (declare (type bignum-type bignum)
+ (type bignum-index digits))
+ (let* ((res-len (- (%bignum-length bignum) digits))
+ (res (%allocate-bignum res-len)))
+ (declare (type bignum-index res-len)
+ (type bignum-type res))
+ (bignum-replace res bignum :start2 digits)
+ (%normalize-bignum res res-len)))
+
+;;; GCD uses this for an in-place shifting operation. This is different enough
+;;; from BIGNUM-ASHIFT-RIGHT that it isn't worth folding the bodies into a
+;;; macro, but they share the basic algorithm. This routine foregoes a first
+;;; test for digits being greater than or equal to bignum-len since that will
+;;; never happen for its uses in GCD. We did fold the last branch into a macro
+;;; since it was duplicated a few times, and the fifth argument to it
+;;; references locals established by the macro.
+(defun bignum-buffer-ashift-right (bignum bignum-len x)
+ (declare (type bignum-index bignum-len) (fixnum x))
+ (multiple-value-bind (digits n-bits) (truncate x digit-size)
+ (declare (type bignum-index digits))
+ (cond
+ ((zerop n-bits)
+ (let ((new-end (- bignum-len digits)))
+ (bignum-replace bignum bignum :end1 new-end :start2 digits
+ :end2 bignum-len)
+ (%normalize-bignum-buffer bignum new-end)))
+ (t
+ (shift-right-unaligned bignum digits n-bits (- bignum-len digits)
+ ((= j res-len-1)
+ (setf (%bignum-ref bignum j)
+ (%ashr (%bignum-ref bignum i) n-bits))
+ (%normalize-bignum-buffer bignum res-len)))))))
+
+;;; This handles shifting a bignum buffer to provide fresh bignum data for some
+;;; internal routines. We know bignum is safe when called with bignum-len.
+;;; First we compute the number of whole digits to shift, shifting them
+;;; starting to store farther along the result bignum. If we shift on a digit
+;;; boundary (that is, n-bits is zero), then we just copy digits. The last
+;;; branch handles the general case.
+(defun bignum-ashift-left (bignum x &optional bignum-len)
+ (declare (type bignum-type bignum)
+ (type unsigned-byte x)
+ (type (or null bignum-index) bignum-len))
+ (if (fixnump x)
+ (multiple-value-bind (digits n-bits) (truncate x digit-size)
+ (let* ((bignum-len (or bignum-len (%bignum-length bignum)))
+ (res-len (+ digits bignum-len 1)))
+ (when (> res-len maximum-bignum-length)
+ (error "can't represent result of left shift"))
+ (if (zerop n-bits)
+ (bignum-ashift-left-digits bignum bignum-len digits)
+ (bignum-ashift-left-unaligned bignum digits n-bits res-len))))
+ ;; Left shift by a number too big to be represented as a fixnum
+ ;; would exceed our memory capacity, since a fixnum is big enough
+ ;; index any array, including a bit array.
+ (error "can't represent result of left shift")))
+
+(defun bignum-ashift-left-digits (bignum bignum-len digits)
+ (declare (type bignum-index bignum-len digits))
+ (let* ((res-len (+ bignum-len digits))
+ (res (%allocate-bignum res-len)))
+ (declare (type bignum-index res-len))
+ (bignum-replace res bignum :start1 digits :end1 res-len :end2 bignum-len
+ :from-end t)
+ res))
+
+;;; BIGNUM-TRUNCATE uses this to store into a bignum buffer by supplying res.
+;;; When res comes in non-nil, then this foregoes allocating a result, and it
+;;; normalizes the buffer instead of the would-be allocated result.
+;;;
+;;; We start storing into one digit higher than digits, storing a whole result
+;;; digit from parts of two contiguous digits from bignum. When the loop
+;;; finishes, we store the remaining bits from bignum's first digit in the
+;;; first non-zero result digit, digits. We also grab some left over high
+;;; bits from the last digit of bignum.
+(defun bignum-ashift-left-unaligned (bignum digits n-bits res-len
+ &optional (res nil resp))
+ (declare (type bignum-index digits res-len)
+ (type (mod #.digit-size) n-bits))
+ (let* ((remaining-bits (- digit-size n-bits))
+ (res-len-1 (1- res-len))
+ (res (or res (%allocate-bignum res-len))))
+ (declare (type bignum-index res-len res-len-1))
+ (do ((i 0 i+1)
+ (i+1 1 (1+ i+1))
+ (j (1+ digits) (1+ j)))
+ ((= j res-len-1)
+ (setf (%bignum-ref res digits)
+ (%ashl (%bignum-ref bignum 0) n-bits))
+ (setf (%bignum-ref res j)
+ (%ashr (%bignum-ref bignum i) remaining-bits))
+ (if resp
+ (%normalize-bignum-buffer res res-len)
+ (%normalize-bignum res res-len)))
+ (declare (type bignum-index i i+1 j))
+ (setf (%bignum-ref res j)
+ (%logior (%digit-logical-shift-right (%bignum-ref bignum i)
+ remaining-bits)
+ (%ashl (%bignum-ref bignum i+1) n-bits))))))
+\f
+;;;; relational operators
+
+;;; Return T iff bignum is positive.
+(defun bignum-plus-p (bignum)
+ (declare (type bignum-type bignum))
+ (%bignum-0-or-plusp bignum (%bignum-length bignum)))
+
+;;; This compares two bignums returning -1, 0, or 1, depending on
+;;; whether a is less than, equal to, or greater than b.
+(declaim (ftype (function (bignum bignum) (integer -1 1)) bignum-compare))
+(defun bignum-compare (a b)
+ (declare (type bignum-type a b))
+ (let* ((len-a (%bignum-length a))
+ (len-b (%bignum-length b))
+ (a-plusp (%bignum-0-or-plusp a len-a))
+ (b-plusp (%bignum-0-or-plusp b len-b)))
+ (declare (type bignum-index len-a len-b))
+ (cond ((not (eq a-plusp b-plusp))
+ (if a-plusp 1 -1))
+ ((= len-a len-b)
+ (do ((i (1- len-a) (1- i)))
+ (())
+ (declare (type bignum-index i))
+ (let ((a-digit (%bignum-ref a i))
+ (b-digit (%bignum-ref b i)))
+ (declare (type bignum-element-type a-digit b-digit))
+ (when (%digit-greater a-digit b-digit)
+ (return 1))
+ (when (%digit-greater b-digit a-digit)
+ (return -1)))
+ (when (zerop i) (return 0))))
+ ((> len-a len-b)
+ (if a-plusp 1 -1))
+ (t (if a-plusp -1 1)))))
+\f
+;;;; float conversion
+
+;;; Make a single or double float with the specified significand,
+;;; exponent and sign.
+(defun single-float-from-bits (bits exp plusp)
+ (declare (fixnum exp))
+ (declare (optimize #-sb-xc-host (sb!ext:inhibit-warnings 3)))
+ (let ((res (dpb exp
+ sb!vm:single-float-exponent-byte
+ (logandc2 (sb!ext:truly-the (unsigned-byte 31)
+ (%bignum-ref bits 1))
+ sb!vm:single-float-hidden-bit))))
+ (make-single-float
+ (if plusp
+ res
+ (logior res (ash -1 sb!vm:float-sign-shift))))))
+(defun double-float-from-bits (bits exp plusp)
+ (declare (fixnum exp))
+ (declare (optimize #-sb-xc-host (sb!ext:inhibit-warnings 3)))
+ (let ((hi (dpb exp
+ sb!vm:double-float-exponent-byte
+ (logandc2 (sb!ext:truly-the (unsigned-byte 31)
+ (%bignum-ref bits 2))
+ sb!vm:double-float-hidden-bit))))
+ (make-double-float
+ (if plusp
+ hi
+ (logior hi (ash -1 sb!vm:float-sign-shift)))
+ (%bignum-ref bits 1))))
+#!+(and long-float x86)
+(defun long-float-from-bits (bits exp plusp)
+ (declare (fixnum exp))
+ (declare (optimize #-sb-xc-host (sb!ext:inhibit-warnings 3)))
+ (make-long-float
+ (if plusp
+ exp
+ (logior exp (ash 1 15)))
+ (%bignum-ref bits 2)
+ (%bignum-ref bits 1)))
+
+;;; Convert Bignum to a float in the specified Format, rounding to the best
+;;; approximation.
+(defun bignum-to-float (bignum format)
+ (let* ((plusp (bignum-plus-p bignum))
+ (x (if plusp bignum (negate-bignum bignum)))
+ (len (bignum-integer-length x))
+ (digits (float-format-digits format))
+ (keep (+ digits digit-size))
+ (shift (- keep len))
+ (shifted (if (minusp shift)
+ (bignum-ashift-right x (- shift))
+ (bignum-ashift-left x shift)))
+ (low (%bignum-ref shifted 0))
+ (round-bit (ash 1 (1- digit-size))))
+ (declare (type bignum-index len digits keep) (fixnum shift))
+ (labels ((round-up ()
+ (let ((rounded (add-bignums shifted round-bit)))
+ (if (> (integer-length rounded) keep)
+ (float-from-bits (bignum-ashift-right rounded 1)
+ (1+ len))
+ (float-from-bits rounded len))))
+ (float-from-bits (bits len)
+ (declare (type bignum-index len))
+ (ecase format
+ (single-float
+ (single-float-from-bits
+ bits
+ (check-exponent len sb!vm:single-float-bias
+ sb!vm:single-float-normal-exponent-max)
+ plusp))
+ (double-float
+ (double-float-from-bits
+ bits
+ (check-exponent len sb!vm:double-float-bias
+ sb!vm:double-float-normal-exponent-max)
+ plusp))
+ #!+long-float
+ (long-float
+ (long-float-from-bits
+ bits
+ (check-exponent len sb!vm:long-float-bias
+ sb!vm:long-float-normal-exponent-max)
+ plusp))))
+ (check-exponent (exp bias max)
+ (declare (type bignum-index len))
+ (let ((exp (+ exp bias)))
+ (when (> exp max)
+ (error "Too large to be represented as a ~S:~% ~S"
+ format x))
+ exp)))
+
+ (cond
+ ;; Round down if round bit is 0.
+ ((zerop (logand round-bit low))
+ (float-from-bits shifted len))
+ ;; If only round bit is set, then round to even.
+ ((and (= low round-bit)
+ (dotimes (i (- (%bignum-length x) (ceiling keep digit-size))
+ t)
+ (unless (zerop (%bignum-ref x i)) (return nil))))
+ (let ((next (%bignum-ref shifted 1)))
+ (if (oddp next)
+ (round-up)
+ (float-from-bits shifted len))))
+ ;; Otherwise, round up.
+ (t
+ (round-up))))))
+\f
+;;;; integer length and logcount
+
+(defun bignum-integer-length (bignum)
+ (declare (type bignum-type bignum))
+ (let* ((len (%bignum-length bignum))
+ (len-1 (1- len))
+ (digit (%bignum-ref bignum len-1)))
+ (declare (type bignum-index len len-1)
+ (type bignum-element-type digit))
+ (+ (integer-length (%fixnum-digit-with-correct-sign digit))
+ (* len-1 digit-size))))
+
+(defun bignum-logcount (bignum)
+ (declare (type bignum-type bignum))
+ (let* ((length (%bignum-length bignum))
+ (plusp (%bignum-0-or-plusp bignum length))
+ (result 0))
+ (declare (type bignum-index length)
+ (fixnum result))
+ (do ((index 0 (1+ index)))
+ ((= index length) result)
+ (let ((digit (%bignum-ref bignum index)))
+ (declare (type bignum-element-type digit))
+ (incf result (logcount (if plusp digit (%lognot digit))))))))
+\f
+;;;; logical operations
+
+;;;; NOT
+
+(defun bignum-logical-not (a)
+ (declare (type bignum-type a))
+ (let* ((len (%bignum-length a))
+ (res (%allocate-bignum len)))
+ (declare (type bignum-index len))
+ (dotimes (i len res)
+ (declare (type bignum-index i))
+ (setf (%bignum-ref res i) (%lognot (%bignum-ref a i))))))
+
+;;;; AND
+
+(defun bignum-logical-and (a b)
+ (declare (type bignum-type a b))
+ (let* ((len-a (%bignum-length a))
+ (len-b (%bignum-length b))
+ (a-plusp (%bignum-0-or-plusp a len-a))
+ (b-plusp (%bignum-0-or-plusp b len-b)))
+ (declare (type bignum-index len-a len-b))
+ (cond
+ ((< len-a len-b)
+ (if a-plusp
+ (logand-shorter-positive a len-a b (%allocate-bignum len-a))
+ (logand-shorter-negative a len-a b len-b (%allocate-bignum len-b))))
+ ((< len-b len-a)
+ (if b-plusp
+ (logand-shorter-positive b len-b a (%allocate-bignum len-b))
+ (logand-shorter-negative b len-b a len-a (%allocate-bignum len-a))))
+ (t (logand-shorter-positive a len-a b (%allocate-bignum len-a))))))
+
+;;; This takes a shorter bignum, a and len-a, that is positive. Because this
+;;; is AND, we don't care about any bits longer than a's since its infinite 0
+;;; sign bits will mask the other bits out of b. The result is len-a big.
+(defun logand-shorter-positive (a len-a b res)
+ (declare (type bignum-type a b res)
+ (type bignum-index len-a))
+ (dotimes (i len-a)
+ (declare (type bignum-index i))
+ (setf (%bignum-ref res i)
+ (%logand (%bignum-ref a i) (%bignum-ref b i))))
+ (%normalize-bignum res len-a))
+
+;;; This takes a shorter bignum, a and len-a, that is negative. Because this
+;;; is AND, we just copy any bits longer than a's since its infinite 1 sign
+;;; bits will include any bits from b. The result is len-b big.
+(defun logand-shorter-negative (a len-a b len-b res)
+ (declare (type bignum-type a b res)
+ (type bignum-index len-a len-b))
+ (dotimes (i len-a)
+ (declare (type bignum-index i))
+ (setf (%bignum-ref res i)
+ (%logand (%bignum-ref a i) (%bignum-ref b i))))
+ (do ((i len-a (1+ i)))
+ ((= i len-b))
+ (declare (type bignum-index i))
+ (setf (%bignum-ref res i) (%bignum-ref b i)))
+ (%normalize-bignum res len-b))
+
+;;;; IOR
+
+(defun bignum-logical-ior (a b)
+ (declare (type bignum-type a b))
+ (let* ((len-a (%bignum-length a))
+ (len-b (%bignum-length b))
+ (a-plusp (%bignum-0-or-plusp a len-a))
+ (b-plusp (%bignum-0-or-plusp b len-b)))
+ (declare (type bignum-index len-a len-b))
+ (cond
+ ((< len-a len-b)
+ (if a-plusp
+ (logior-shorter-positive a len-a b len-b (%allocate-bignum len-b))
+ (logior-shorter-negative a len-a b len-b (%allocate-bignum len-b))))
+ ((< len-b len-a)
+ (if b-plusp
+ (logior-shorter-positive b len-b a len-a (%allocate-bignum len-a))
+ (logior-shorter-negative b len-b a len-a (%allocate-bignum len-a))))
+ (t (logior-shorter-positive a len-a b len-b (%allocate-bignum len-a))))))
+
+;;; This takes a shorter bignum, a and len-a, that is positive. Because this
+;;; is IOR, we don't care about any bits longer than a's since its infinite
+;;; 0 sign bits will mask the other bits out of b out to len-b. The result
+;;; is len-b long.
+(defun logior-shorter-positive (a len-a b len-b res)
+ (declare (type bignum-type a b res)
+ (type bignum-index len-a len-b))
+ (dotimes (i len-a)
+ (declare (type bignum-index i))
+ (setf (%bignum-ref res i)
+ (%logior (%bignum-ref a i) (%bignum-ref b i))))
+ (do ((i len-a (1+ i)))
+ ((= i len-b))
+ (declare (type bignum-index i))
+ (setf (%bignum-ref res i) (%bignum-ref b i)))
+ (%normalize-bignum res len-b))
+
+;;; This takes a shorter bignum, a and len-a, that is negative. Because this
+;;; is IOR, we just copy any bits longer than a's since its infinite 1 sign
+;;; bits will include any bits from b. The result is len-b long.
+(defun logior-shorter-negative (a len-a b len-b res)
+ (declare (type bignum-type a b res)
+ (type bignum-index len-a len-b))
+ (dotimes (i len-a)
+ (declare (type bignum-index i))
+ (setf (%bignum-ref res i)
+ (%logior (%bignum-ref a i) (%bignum-ref b i))))
+ (do ((i len-a (1+ i))
+ (sign (%sign-digit a len-a)))
+ ((= i len-b))
+ (declare (type bignum-index i))
+ (setf (%bignum-ref res i) sign))
+ (%normalize-bignum res len-b))
+
+;;;; XOR
+
+(defun bignum-logical-xor (a b)
+ (declare (type bignum-type a b))
+ (let ((len-a (%bignum-length a))
+ (len-b (%bignum-length b)))
+ (declare (type bignum-index len-a len-b))
+ (if (< len-a len-b)
+ (bignum-logical-xor-aux a len-a b len-b (%allocate-bignum len-b))
+ (bignum-logical-xor-aux b len-b a len-a (%allocate-bignum len-a)))))
+
+;;; This takes the shorter of two bignums in a and len-a. Res is len-b
+;;; long. Do the XOR.
+(defun bignum-logical-xor-aux (a len-a b len-b res)
+ (declare (type bignum-type a b res)
+ (type bignum-index len-a len-b))
+ (dotimes (i len-a)
+ (declare (type bignum-index i))
+ (setf (%bignum-ref res i)
+ (%logxor (%bignum-ref a i) (%bignum-ref b i))))
+ (do ((i len-a (1+ i))
+ (sign (%sign-digit a len-a)))
+ ((= i len-b))
+ (declare (type bignum-index i))
+ (setf (%bignum-ref res i) (%logxor sign (%bignum-ref b i))))
+ (%normalize-bignum res len-b))
+\f
+;;;; LDB (load byte)
+
+#|
+FOR NOW WE DON'T USE LDB OR DPB. WE USE SHIFTS AND MASKS IN NUMBERS.LISP WHICH
+IS LESS EFFICIENT BUT EASIER TO MAINTAIN. BILL SAYS THIS CODE CERTAINLY WORKS!
+
+(defconstant maximum-fixnum-bits #!+ibm-rt-pc 27 #!-ibm-rt-pc 30)
+
+(defun bignum-load-byte (byte bignum)
+ (declare (type bignum-type bignum))
+ (let ((byte-len (byte-size byte))
+ (byte-pos (byte-position byte)))
+ (if (< byte-len maximum-fixnum-bits)
+ (bignum-ldb-fixnum-res bignum byte-len byte-pos)
+ (bignum-ldb-bignum-res bignum byte-len byte-pos))))
+
+;;; This returns a fixnum result of loading a byte from a bignum. In order, we
+;;; check for the following conditions:
+;;; Insufficient bignum digits to start loading a byte --
+;;; Return 0 or byte-len 1's depending on sign of bignum.
+;;; One bignum digit containing the whole byte spec --
+;;; Grab 'em, shift 'em, and mask out what we don't want.
+;;; Insufficient bignum digits to cover crossing a digit boundary --
+;;; Grab the available bits in the last digit, and or in whatever
+;;; virtual sign bits we need to return a full byte spec.
+;;; Else (we cross a digit boundary with all bits available) --
+;;; Make a couple masks, grab what we want, shift it around, and
+;;; LOGIOR it all together.
+;;; Because (< maximum-fixnum-bits digit-size) and
+;;; (< byte-len maximum-fixnum-bits),
+;;; we only cross one digit boundary if any.
+(defun bignum-ldb-fixnum-res (bignum byte-len byte-pos)
+ (multiple-value-bind (skipped-digits pos) (truncate byte-pos digit-size)
+ (let ((bignum-len (%bignum-length bignum))
+ (s-digits+1 (1+ skipped-digits)))
+ (declare (type bignum-index bignum-len s-digits+1))
+ (if (>= skipped-digits bignum-len)
+ (if (%bignum-0-or-plusp bignum bignum-len)
+ 0
+ (%make-ones byte-len))
+ (let ((end (+ pos byte-len)))
+ (cond ((<= end digit-size)
+ (logand (ash (%bignum-ref bignum skipped-digits) (- pos))
+ ;; Must LOGAND after shift here.
+ (%make-ones byte-len)))
+ ((>= s-digits+1 bignum-len)
+ (let* ((available-bits (- digit-size pos))
+ (res (logand (ash (%bignum-ref bignum skipped-digits)
+ (- pos))
+ ;; LOGAND should be unnecessary here
+ ;; with a logical right shift or a
+ ;; correct unsigned-byte-32 one.
+ (%make-ones available-bits))))
+ (if (%bignum-0-or-plusp bignum bignum-len)
+ res
+ (logior (%ashl (%make-ones (- end digit-size))
+ available-bits)
+ res))))
+ (t
+ (let* ((high-bits-in-first-digit (- digit-size pos))
+ (high-mask (%make-ones high-bits-in-first-digit))
+ (low-bits-in-next-digit (- end digit-size))
+ (low-mask (%make-ones low-bits-in-next-digit)))
+ (declare (type bignum-element-type high-mask low-mask))
+ (logior (%ashl (logand (%bignum-ref bignum s-digits+1)
+ low-mask)
+ high-bits-in-first-digit)
+ (logand (ash (%bignum-ref bignum skipped-digits)
+ (- pos))
+ ;; LOGAND should be unnecessary here with
+ ;; a logical right shift or a correct
+ ;; unsigned-byte-32 one.
+ high-mask))))))))))
+
+;;; This returns a bignum result of loading a byte from a bignum. In order, we
+;;; check for the following conditions:
+;;; Insufficient bignum digits to start loading a byte --
+;;; Byte-pos starting on a digit boundary --
+;;; Byte spec contained in one bignum digit --
+;;; Grab the bits we want and stick them in a single digit result.
+;;; Since we know byte-pos is non-zero here, we know our single digit
+;;; will have a zero high sign bit.
+;;; Else (unaligned multiple digits) --
+;;; This is like doing a shift right combined with either masking
+;;; out unwanted high bits from bignum or filling in virtual sign
+;;; bits if bignum had insufficient bits. We use SHIFT-RIGHT-ALIGNED
+;;; and reference lots of local variables this macro establishes.
+(defun bignum-ldb-bignum-res (bignum byte-len byte-pos)
+ (multiple-value-bind (skipped-digits pos) (truncate byte-pos digit-size)
+ (let ((bignum-len (%bignum-length bignum)))
+ (declare (type bignum-index bignum-len))
+ (cond
+ ((>= skipped-digits bignum-len)
+ (make-bignum-virtual-ldb-bits bignum bignum-len byte-len))
+ ((zerop pos)
+ (make-aligned-ldb-bignum bignum bignum-len byte-len skipped-digits))
+ ((< (+ pos byte-len) digit-size)
+ (let ((res (%allocate-bignum 1)))
+ (setf (%bignum-ref res 0)
+ (logand (%ashr (%bignum-ref bignum skipped-digits) pos)
+ (%make-ones byte-len)))
+ res))
+ (t
+ (make-unaligned-ldb-bignum bignum bignum-len
+ byte-len skipped-digits pos))))))
+
+;;; This returns bits from bignum that don't physically exist. These are
+;;; all zero or one depending on the sign of the bignum.
+(defun make-bignum-virtual-ldb-bits (bignum bignum-len byte-len)
+ (if (%bignum-0-or-plusp bignum bignum-len)
+ 0
+ (multiple-value-bind (res-len-1 extra) (truncate byte-len digit-size)
+ (declare (type bignum-index res-len-1))
+ (let* ((res-len (1+ res-len-1))
+ (res (%allocate-bignum res-len)))
+ (declare (type bignum-index res-len))
+ (do ((j 0 (1+ j)))
+ ((= j res-len-1)
+ (setf (%bignum-ref res j) (%make-ones extra))
+ (%normalize-bignum res res-len))
+ (declare (type bignum-index j))
+ (setf (%bignum-ref res j) all-ones-digit))))))
+
+;;; Since we are picking up aligned digits, we just copy the whole digits
+;;; we want and fill in extra bits. We might have a byte-len that extends
+;;; off the end of the bignum, so we may have to fill in extra 1's if the
+;;; bignum is negative.
+(defun make-aligned-ldb-bignum (bignum bignum-len byte-len skipped-digits)
+ (multiple-value-bind (res-len-1 extra) (truncate byte-len digit-size)
+ (declare (type bignum-index res-len-1))
+ (let* ((res-len (1+ res-len-1))
+ (res (%allocate-bignum res-len)))
+ (declare (type bignum-index res-len))
+ (do ((i skipped-digits (1+ i))
+ (j 0 (1+ j)))
+ ((or (= j res-len-1) (= i bignum-len))
+ (cond ((< i bignum-len)
+ (setf (%bignum-ref res j)
+ (logand (%bignum-ref bignum i)
+ (the bignum-element-type (%make-ones extra)))))
+ ((%bignum-0-or-plusp bignum bignum-len))
+ (t
+ (do ((j j (1+ j)))
+ ((= j res-len-1)
+ (setf (%bignum-ref res j) (%make-ones extra)))
+ (setf (%bignum-ref res j) all-ones-digit))))
+ (%normalize-bignum res res-len))
+ (declare (type bignum-index i j))
+ (setf (%bignum-ref res j) (%bignum-ref bignum i))))))
+
+;;; This grabs unaligned bignum bits from bignum assuming byte-len causes at
+;;; least one digit boundary crossing. We use SHIFT-RIGHT-UNALIGNED referencing
+;;; lots of local variables established by it.
+(defun make-unaligned-ldb-bignum (bignum
+ bignum-len
+ byte-len
+ skipped-digits
+ pos)
+ (multiple-value-bind (res-len-1 extra) (truncate byte-len digit-size)
+ (shift-right-unaligned
+ bignum skipped-digits pos (1+ res-len-1)
+ ((or (= j res-len-1) (= i+1 bignum-len))
+ (cond ((= j res-len-1)
+ (cond
+ ((< extra high-bits-in-first-digit)
+ (setf (%bignum-ref res j)
+ (logand (ash (%bignum-ref bignum i) minus-start-pos)
+ ;; Must LOGAND after shift here.
+ (%make-ones extra))))
+ (t
+ (setf (%bignum-ref res j)
+ (logand (ash (%bignum-ref bignum i) minus-start-pos)
+ ;; LOGAND should be unnecessary here with a logical
+ ;; right shift or a correct unsigned-byte-32 one.
+ high-mask))
+ (when (%bignum-0-or-plusp bignum bignum-len)
+ (setf (%bignum-ref res j)
+ (logior (%bignum-ref res j)
+ (%ashl (%make-ones
+ (- extra high-bits-in-first-digit))
+ high-bits-in-first-digit)))))))
+ (t
+ (setf (%bignum-ref res j)
+ (logand (ash (%bignum-ref bignum i) minus-start-pos)
+ ;; LOGAND should be unnecessary here with a logical
+ ;; right shift or a correct unsigned-byte-32 one.
+ high-mask))
+ (unless (%bignum-0-or-plusp bignum bignum-len)
+ ;; Fill in upper half of this result digit with 1's.
+ (setf (%bignum-ref res j)
+ (logior (%bignum-ref res j)
+ (%ashl low-mask high-bits-in-first-digit)))
+ ;; Fill in any extra 1's we need to be byte-len long.
+ (do ((j (1+ j) (1+ j)))
+ ((>= j res-len-1)
+ (setf (%bignum-ref res j) (%make-ones extra)))
+ (setf (%bignum-ref res j) all-ones-digit)))))
+ (%normalize-bignum res res-len))
+ res)))
+\f
+;;;; DPB (deposit byte)
+
+(defun bignum-deposit-byte (new-byte byte-spec bignum)
+ (declare (type bignum-type bignum))
+ (let* ((byte-len (byte-size byte-spec))
+ (byte-pos (byte-position byte-spec))
+ (bignum-len (%bignum-length bignum))
+ (bignum-plusp (%bignum-0-or-plusp bignum bignum-len))
+ (byte-end (+ byte-pos byte-len))
+ (res-len (1+ (max (ceiling byte-end digit-size) bignum-len)))
+ (res (%allocate-bignum res-len)))
+ (declare (type bignum-index bignum-len res-len))
+ ;; Fill in an extra sign digit in case we set what would otherwise be the
+ ;; last digit's last bit. Normalize at the end in case this was
+ ;; unnecessary.
+ (unless bignum-plusp
+ (setf (%bignum-ref res (1- res-len)) all-ones-digit))
+ (multiple-value-bind (end-digit end-bits) (truncate byte-end digit-size)
+ (declare (type bignum-index end-digit))
+ ;; Fill in bits from bignum up to byte-pos.
+ (multiple-value-bind (pos-digit pos-bits) (truncate byte-pos digit-size)
+ (declare (type bignum-index pos-digit))
+ (do ((i 0 (1+ i))
+ (end (min pos-digit bignum-len)))
+ ((= i end)
+ (cond ((< i bignum-len)
+ (unless (zerop pos-bits)
+ (setf (%bignum-ref res i)
+ (logand (%bignum-ref bignum i)
+ (%make-ones pos-bits)))))
+ (bignum-plusp)
+ (t
+ (do ((i i (1+ i)))
+ ((= i pos-digit)
+ (unless (zerop pos-bits)
+ (setf (%bignum-ref res i) (%make-ones pos-bits))))
+ (setf (%bignum-ref res i) all-ones-digit)))))
+ (setf (%bignum-ref res i) (%bignum-ref bignum i)))
+ ;; Fill in bits from new-byte.
+ (if (typep new-byte 'fixnum)
+ (deposit-fixnum-bits new-byte byte-len pos-digit pos-bits
+ end-digit end-bits res)
+ (deposit-bignum-bits new-byte byte-len pos-digit pos-bits
+ end-digit end-bits res)))
+ ;; Fill in remaining bits from bignum after byte-spec.
+ (when (< end-digit bignum-len)
+ (setf (%bignum-ref res end-digit)
+ (logior (logand (%bignum-ref bignum end-digit)
+ (%ashl (%make-ones (- digit-size end-bits))
+ end-bits))
+ ;; DEPOSIT-FIXNUM-BITS and DEPOSIT-BIGNUM-BITS only store
+ ;; bits from new-byte into res's end-digit element, so
+ ;; we don't need to mask out unwanted high bits.
+ (%bignum-ref res end-digit)))
+ (do ((i (1+ end-digit) (1+ i)))
+ ((= i bignum-len))
+ (setf (%bignum-ref res i) (%bignum-ref bignum i)))))
+ (%normalize-bignum res res-len)))
+
+;;; This starts at result's pos-digit skipping pos-bits, and it stores bits
+;;; from new-byte, a fixnum, into result. It effectively stores byte-len
+;;; number of bits, but never stores past end-digit and end-bits in result.
+;;; The first branch fires when all the bits we want from new-byte are present;
+;;; if byte-len crosses from the current result digit into the next, the last
+;;; argument to DEPOSIT-FIXNUM-DIGIT is a mask for those bits. The second
+;;; branch handles the need to grab more bits than the fixnum new-byte has, but
+;;; new-byte is positive; therefore, any virtual bits are zero. The mask for
+;;; bits that don't fit in the current result digit is simply the remaining
+;;; bits in the bignum digit containing new-byte; we don't care if we store
+;;; some extra in the next result digit since they will be zeros. The last
+;;; branch handles the need to grab more bits than the fixnum new-byte has, but
+;;; new-byte is negative; therefore, any virtual bits must be explicitly filled
+;;; in as ones. We call DEPOSIT-FIXNUM-DIGIT to grab what bits actually exist
+;;; and to fill in the current result digit.
+(defun deposit-fixnum-bits (new-byte byte-len pos-digit pos-bits
+ end-digit end-bits result)
+ (declare (type bignum-index pos-digit end-digit))
+ (let ((other-bits (- digit-size pos-bits))
+ (new-byte-digit (%fixnum-to-digit new-byte)))
+ (declare (type bignum-element-type new-byte-digit))
+ (cond ((< byte-len maximum-fixnum-bits)
+ (deposit-fixnum-digit new-byte-digit byte-len pos-digit pos-bits
+ other-bits result
+ (- byte-len other-bits)))
+ ((or (plusp new-byte) (zerop new-byte))
+ (deposit-fixnum-digit new-byte-digit byte-len pos-digit pos-bits
+ other-bits result pos-bits))
+ (t
+ (multiple-value-bind (digit bits)
+ (deposit-fixnum-digit new-byte-digit byte-len pos-digit pos-bits
+ other-bits result
+ (if (< (- byte-len other-bits) digit-size)
+ (- byte-len other-bits)
+ digit-size))
+ (declare (type bignum-index digit))
+ (cond ((< digit end-digit)
+ (setf (%bignum-ref result digit)
+ (logior (%bignum-ref result digit)
+ (%ashl (%make-ones (- digit-size bits)) bits)))
+ (do ((i (1+ digit) (1+ i)))
+ ((= i end-digit)
+ (setf (%bignum-ref result i) (%make-ones end-bits)))
+ (setf (%bignum-ref result i) all-ones-digit)))
+ ((> digit end-digit))
+ ((< bits end-bits)
+ (setf (%bignum-ref result digit)
+ (logior (%bignum-ref result digit)
+ (%ashl (%make-ones (- end-bits bits))
+ bits))))))))))
+
+;;; This fills in the current result digit from new-byte-digit. The first case
+;;; handles everything we want fitting in the current digit, and other-bits is
+;;; the number of bits remaining to be filled in result's current digit. This
+;;; number is digit-size minus pos-bits. The second branch handles filling in
+;;; result's current digit, and it shoves the unused bits of new-byte-digit
+;;; into the next result digit. This is correct regardless of new-byte-digit's
+;;; sign. It returns the new current result digit and how many bits already
+;;; filled in the result digit.
+(defun deposit-fixnum-digit (new-byte-digit byte-len pos-digit pos-bits
+ other-bits result next-digit-bits-needed)
+ (declare (type bignum-index pos-digit)
+ (type bignum-element-type new-byte-digit next-digit-mask))
+ (cond ((<= byte-len other-bits)
+ ;; Bits from new-byte fit in the current result digit.
+ (setf (%bignum-ref result pos-digit)
+ (logior (%bignum-ref result pos-digit)
+ (%ashl (logand new-byte-digit (%make-ones byte-len))
+ pos-bits)))
+ (if (= byte-len other-bits)
+ (values (1+ pos-digit) 0)
+ (values pos-digit (+ byte-len pos-bits))))
+ (t
+ ;; Some of new-byte's bits go in current result digit.
+ (setf (%bignum-ref result pos-digit)
+ (logior (%bignum-ref result pos-digit)
+ (%ashl (logand new-byte-digit (%make-ones other-bits))
+ pos-bits)))
+ (let ((pos-digit+1 (1+ pos-digit)))
+ ;; The rest of new-byte's bits go in the next result digit.
+ (setf (%bignum-ref result pos-digit+1)
+ (logand (ash new-byte-digit (- other-bits))
+ ;; Must LOGAND after shift here.
+ (%make-ones next-digit-bits-needed)))
+ (if (= next-digit-bits-needed digit-size)
+ (values (1+ pos-digit+1) 0)
+ (values pos-digit+1 next-digit-bits-needed))))))
+
+;;; This starts at result's pos-digit skipping pos-bits, and it stores bits
+;;; from new-byte, a bignum, into result. It effectively stores byte-len
+;;; number of bits, but never stores past end-digit and end-bits in result.
+;;; When handling a starting bit unaligned with a digit boundary, we check
+;;; in the second branch for the byte spec fitting into the pos-digit element
+;;; after after pos-bits; DEPOSIT-UNALIGNED-BIGNUM-BITS expects at least one
+;;; digit boundary crossing.
+(defun deposit-bignum-bits (bignum-byte byte-len pos-digit pos-bits
+ end-digit end-bits result)
+ (declare (type bignum-index pos-digit end-digit))
+ (cond ((zerop pos-bits)
+ (deposit-aligned-bignum-bits bignum-byte pos-digit end-digit end-bits
+ result))
+ ((or (= end-digit pos-digit)
+ (and (= end-digit (1+ pos-digit))
+ (zerop end-bits)))
+ (setf (%bignum-ref result pos-digit)
+ (logior (%bignum-ref result pos-digit)
+ (%ashl (logand (%bignum-ref bignum-byte 0)
+ (%make-ones byte-len))
+ pos-bits))))
+ (t (deposit-unaligned-bignum-bits bignum-byte pos-digit pos-bits
+ end-digit end-bits result))))
+
+;;; This deposits bits from bignum-byte into result starting at pos-digit and
+;;; the zero'th bit. It effectively only stores bits to end-bits in the
+;;; end-digit element of result. The loop termination code takes care of
+;;; picking up the last digit's bits or filling in virtual negative sign bits.
+(defun deposit-aligned-bignum-bits (bignum-byte pos-digit end-digit end-bits
+ result)
+ (declare (type bignum-index pos-digit end-digit))
+ (let* ((bignum-len (%bignum-length bignum-byte))
+ (bignum-plusp (%bignum-0-or-plusp bignum-byte bignum-len)))
+ (declare (type bignum-index bignum-len))
+ (do ((i 0 (1+ i ))
+ (j pos-digit (1+ j)))
+ ((or (= j end-digit) (= i bignum-len))
+ (cond ((= j end-digit)
+ (cond ((< i bignum-len)
+ (setf (%bignum-ref result j)
+ (logand (%bignum-ref bignum-byte i)
+ (%make-ones end-bits))))
+ (bignum-plusp)
+ (t
+ (setf (%bignum-ref result j) (%make-ones end-bits)))))
+ (bignum-plusp)
+ (t
+ (do ((j j (1+ j)))
+ ((= j end-digit)
+ (setf (%bignum-ref result j) (%make-ones end-bits)))
+ (setf (%bignum-ref result j) all-ones-digit)))))
+ (setf (%bignum-ref result j) (%bignum-ref bignum-byte i)))))
+
+;;; This assumes at least one digit crossing.
+(defun deposit-unaligned-bignum-bits (bignum-byte pos-digit pos-bits
+ end-digit end-bits result)
+ (declare (type bignum-index pos-digit end-digit))
+ (let* ((bignum-len (%bignum-length bignum-byte))
+ (bignum-plusp (%bignum-0-or-plusp bignum-byte bignum-len))
+ (low-mask (%make-ones pos-bits))
+ (bits-past-pos-bits (- digit-size pos-bits))
+ (high-mask (%make-ones bits-past-pos-bits))
+ (minus-high-bits (- bits-past-pos-bits)))
+ (declare (type bignum-element-type low-mask high-mask)
+ (type bignum-index bignum-len))
+ (do ((i 0 (1+ i))
+ (j pos-digit j+1)
+ (j+1 (1+ pos-digit) (1+ j+1)))
+ ((or (= j end-digit) (= i bignum-len))
+ (cond
+ ((= j end-digit)
+ (setf (%bignum-ref result j)
+ (cond
+ ((>= pos-bits end-bits)
+ (logand (%bignum-ref result j) (%make-ones end-bits)))
+ ((< i bignum-len)
+ (logior (%bignum-ref result j)
+ (%ashl (logand (%bignum-ref bignum-byte i)
+ (%make-ones (- end-bits pos-bits)))
+ pos-bits)))
+ (bignum-plusp
+ (logand (%bignum-ref result j)
+ ;; 0's between pos-bits and end-bits positions.
+ (logior (%ashl (%make-ones (- digit-size end-bits))
+ end-bits)
+ low-mask)))
+ (t (logior (%bignum-ref result j)
+ (%ashl (%make-ones (- end-bits pos-bits))
+ pos-bits))))))
+ (bignum-plusp)
+ (t
+ (setf (%bignum-ref result j)
+ (%ashl (%make-ones bits-past-pos-bits) pos-bits))
+ (do ((j j+1 (1+ j)))
+ ((= j end-digit)
+ (setf (%bignum-ref result j) (%make-ones end-bits)))
+ (declare (type bignum-index j))
+ (setf (%bignum-ref result j) all-ones-digit)))))
+ (declare (type bignum-index i j j+1))
+ (let ((digit (%bignum-ref bignum-byte i)))
+ (declare (type bignum-element-type digit))
+ (setf (%bignum-ref result j)
+ (logior (%bignum-ref result j)
+ (%ashl (logand digit high-mask) pos-bits)))
+ (setf (%bignum-ref result j+1)
+ (logand (ash digit minus-high-bits)
+ ;; LOGAND should be unnecessary here with a logical right
+ ;; shift or a correct unsigned-byte-32 one.
+ low-mask))))))
+|#
+\f
+;;;; TRUNCATE
+
+;;; This is the original sketch of the algorithm from which I implemented this
+;;; TRUNCATE, assuming both operands are bignums. I should modify this to work
+;;; with the documentation on my functions, as a general introduction. I've
+;;; left this here just in case someone needs it in the future. Don't look at
+;;; this unless reading the functions' comments leaves you at a loss. Remember
+;;; this comes from Knuth, so the book might give you the right general
+;;; overview.
+;;;
+;;; (truncate x y):
+;;;
+;;; If X's magnitude is less than Y's, then result is 0 with remainder X.
+;;;
+;;; Make x and y positive, copying x if it is already positive.
+;;;
+;;; Shift y left until there's a 1 in the 30'th bit (most significant, non-sign
+;;; digit)
+;;; Just do most sig digit to determine how much to shift whole number.
+;;; Shift x this much too.
+;;; Remember this initial shift count.
+;;;
+;;; Allocate q to be len-x minus len-y quantity plus 1.
+;;;
+;;; i = last digit of x.
+;;; k = last digit of q.
+;;;
+;;; LOOP
+;;;
+;;; j = last digit of y.
+;;;
+;;; compute guess.
+;;; if x[i] = y[j] then g = #xFFFFFFFF
+;;; else g = x[i]x[i-1]/y[j].
+;;;
+;;; check guess.
+;;; %UNSIGNED-MULTIPLY returns b and c defined below.
+;;; a = x[i-1] - (logand (* g y[j]) #xFFFFFFFF).
+;;; Use %UNSIGNED-MULTIPLY taking low-order result.
+;;; b = (logand (ash (* g y[j-1]) -32) #xFFFFFFFF).
+;;; c = (logand (* g y[j-1]) #xFFFFFFFF).
+;;; if a < b, okay.
+;;; if a > b, guess is too high
+;;; g = g - 1; go back to "check guess".
+;;; if a = b and c > x[i-2], guess is too high
+;;; g = g - 1; go back to "check guess".
+;;; GUESS IS 32-BIT NUMBER, SO USE THING TO KEEP IN SPECIAL REGISTER
+;;; SAME FOR A, B, AND C.
+;;;
+;;; Subtract g * y from x[i - len-y+1]..x[i]. See paper for doing this in step.
+;;; If x[i] < 0, guess is screwed up.
+;;; negative g, then add 1
+;;; zero or positive g, then subtract 1
+;;; AND add y back into x[len-y+1..i].
+;;;
+;;; q[k] = g.
+;;; i = i - 1.
+;;; k = k - 1.
+;;;
+;;; If k>=0, goto LOOP.
+;;;
+;;; Now quotient is good, but remainder is not.
+;;; Shift x right by saved initial left shifting count.
+;;;
+;;; Check quotient and remainder signs.
+;;; x pos y pos --> q pos r pos
+;;; x pos y neg --> q neg r pos
+;;; x neg y pos --> q neg r neg
+;;; x neg y neg --> q pos r neg
+;;;
+;;; Normalize quotient and remainder. Cons result if necessary.
+
+;;; These are used by BIGNUM-TRUNCATE and friends in the general case.
+(defvar *truncate-x*)
+(defvar *truncate-y*)
+
+;;; This divides x by y returning the quotient and remainder. In the general
+;;; case, we shift y to setup for the algorithm, and we use two buffers to save
+;;; consing intermediate values. X gets destructively modified to become the
+;;; remainder, and we have to shift it to account for the initial Y shift.
+;;; After we multiple bind q and r, we first fix up the signs and then return
+;;; the normalized results.
+(defun bignum-truncate (x y)
+ (declare (type bignum-type x y))
+ (let* ((x-plusp (%bignum-0-or-plusp x (%bignum-length x)))
+ (y-plusp (%bignum-0-or-plusp y (%bignum-length y)))
+ (x (if x-plusp x (negate-bignum x nil)))
+ (y (if y-plusp y (negate-bignum y nil)))
+ (len-x (%bignum-length x))
+ (len-y (%bignum-length y)))
+ (multiple-value-bind (q r)
+ (cond ((< len-y 2)
+ (bignum-truncate-single-digit x len-x y))
+ ((plusp (bignum-compare y x))
+ (let ((res (%allocate-bignum len-x)))
+ (dotimes (i len-x)
+ (setf (%bignum-ref res i) (%bignum-ref x i)))
+ (values 0 res)))
+ (t
+ (let ((len-x+1 (1+ len-x)))
+ (with-bignum-buffers ((*truncate-x* len-x+1)
+ (*truncate-y* (1+ len-y)))
+ (let ((y-shift (shift-y-for-truncate y)))
+ (shift-and-store-truncate-buffers x len-x y len-y y-shift)
+ (values (do-truncate len-x+1 len-y)
+ ;; DO-TRUNCATE must execute first.
+ (cond
+ ((zerop y-shift)
+ (let ((res (%allocate-bignum len-y)))
+ (declare (type bignum-type res))
+ (bignum-replace res *truncate-x* :end2 len-y)
+ (%normalize-bignum res len-y)))
+ (t
+ (shift-right-unaligned
+ *truncate-x* 0 y-shift len-y
+ ((= j res-len-1)
+ (setf (%bignum-ref res j)
+ (%ashr (%bignum-ref *truncate-x* i)
+ y-shift))
+ (%normalize-bignum res res-len))
+ res)))))))))
+ (let ((quotient (cond ((eq x-plusp y-plusp) q)
+ ((typep q 'fixnum) (the fixnum (- q)))
+ (t (negate-bignum-in-place q))))
+ (rem (cond (x-plusp r)
+ ((typep r 'fixnum) (the fixnum (- r)))
+ (t (negate-bignum-in-place r)))))
+ (values (if (typep quotient 'fixnum)
+ quotient
+ (%normalize-bignum quotient (%bignum-length quotient)))
+ (if (typep rem 'fixnum)
+ rem
+ (%normalize-bignum rem (%bignum-length rem))))))))
+
+;;; This divides x by y when y is a single bignum digit. BIGNUM-TRUNCATE fixes
+;;; up the quotient and remainder with respect to sign and normalization.
+;;;
+;;; We don't have to worry about shifting y to make its most significant digit
+;;; sufficiently large for %FLOOR to return 32-bit quantities for the q-digit
+;;; and r-digit. If y is a single digit bignum, it is already large enough
+;;; for %FLOOR. That is, it has some bits on pretty high in the digit.
+(defun bignum-truncate-single-digit (x len-x y)
+ (declare (type bignum-index len-x))
+ (let ((q (%allocate-bignum len-x))
+ (r 0)
+ (y (%bignum-ref y 0)))
+ (declare (type bignum-element-type r y))
+ (do ((i (1- len-x) (1- i)))
+ ((minusp i))
+ (multiple-value-bind (q-digit r-digit) (%floor r (%bignum-ref x i) y)
+ (declare (type bignum-element-type q-digit r-digit))
+ (setf (%bignum-ref q i) q-digit)
+ (setf r r-digit)))
+ (let ((rem (%allocate-bignum 1)))
+ (setf (%bignum-ref rem 0) r)
+ (values q rem))))
+
+;;; This divides *truncate-x* by *truncate-y*, and len-x and len-y tell us how
+;;; much of the buffers we care about. TRY-BIGNUM-TRUNCATE-GUESS modifies
+;;; *truncate-x* on each interation, and this buffer becomes our remainder.
+;;;
+;;; *truncate-x* definitely has at least three digits, and it has one more than
+;;; *truncate-y*. This keeps i, i-1, i-2, and low-x-digit happy. Thanks to
+;;; SHIFT-AND-STORE-TRUNCATE-BUFFERS.
+(defun do-truncate (len-x len-y)
+ (declare (type bignum-index len-x len-y))
+ (let* ((len-q (- len-x len-y))
+ ;; Add one for extra sign digit in case high bit is on.
+ (q (%allocate-bignum (1+ len-q)))
+ (k (1- len-q))
+ (y1 (%bignum-ref *truncate-y* (1- len-y)))
+ (y2 (%bignum-ref *truncate-y* (- len-y 2)))
+ (i (1- len-x))
+ (i-1 (1- i))
+ (i-2 (1- i-1))
+ (low-x-digit (- i len-y)))
+ (declare (type bignum-index len-q k i i-1 i-2 low-x-digit)
+ (type bignum-element-type y1 y2))
+ (loop
+ (setf (%bignum-ref q k)
+ (try-bignum-truncate-guess
+ ;; This modifies *truncate-x*. Must access elements each pass.
+ (bignum-truncate-guess y1 y2
+ (%bignum-ref *truncate-x* i)
+ (%bignum-ref *truncate-x* i-1)
+ (%bignum-ref *truncate-x* i-2))
+ len-y low-x-digit))
+ (cond ((zerop k) (return))
+ (t (decf k)
+ (decf low-x-digit)
+ (shiftf i i-1 i-2 (1- i-2)))))
+ q))
+
+;;; This takes a digit guess, multiplies it by *truncate-y* for a result one
+;;; greater in length than len-y, and subtracts this result from *truncate-x*.
+;;; Low-x-digit is the first digit of x to start the subtraction, and we know x
+;;; is long enough to subtract a len-y plus one length bignum from it. Next we
+;;; check the result of the subtraction, and if the high digit in x became
+;;; negative, then our guess was one too big. In this case, return one less
+;;; than guess passed in, and add one value of y back into x to account for
+;;; subtracting one too many. Knuth shows that the guess is wrong on the order
+;;; of 3/b, where b is the base (2 to the digit-size power) -- pretty rarely.
+(defun try-bignum-truncate-guess (guess len-y low-x-digit)
+ (declare (type bignum-index low-x-digit len-y)
+ (type bignum-element-type guess))
+ (let ((carry-digit 0)
+ (borrow 1)
+ (i low-x-digit))
+ (declare (type bignum-element-type carry-digit)
+ (type bignum-index i)
+ (fixnum borrow))
+ ;; Multiply guess and divisor, subtracting from dividend simultaneously.
+ (dotimes (j len-y)
+ (multiple-value-bind (high-digit low-digit)
+ (%multiply-and-add guess
+ (%bignum-ref *truncate-y* j)
+ carry-digit)
+ (declare (type bignum-element-type high-digit low-digit))
+ (setf carry-digit high-digit)
+ (multiple-value-bind (x temp-borrow)
+ (%subtract-with-borrow (%bignum-ref *truncate-x* i)
+ low-digit
+ borrow)
+ (declare (type bignum-element-type x)
+ (fixnum temp-borrow))
+ (setf (%bignum-ref *truncate-x* i) x)
+ (setf borrow temp-borrow)))
+ (incf i))
+ (setf (%bignum-ref *truncate-x* i)
+ (%subtract-with-borrow (%bignum-ref *truncate-x* i)
+ carry-digit borrow))
+ ;; See whether guess is off by one, adding one Y back in if necessary.
+ (cond ((%digit-0-or-plusp (%bignum-ref *truncate-x* i))
+ guess)
+ (t
+ ;; If subtraction has negative result, add one divisor value back
+ ;; in. The guess was one too large in magnitude.
+ (let ((i low-x-digit)
+ (carry 0))
+ (dotimes (j len-y)
+ (multiple-value-bind (v k)
+ (%add-with-carry (%bignum-ref *truncate-y* j)
+ (%bignum-ref *truncate-x* i)
+ carry)
+ (declare (type bignum-element-type v))
+ (setf (%bignum-ref *truncate-x* i) v)
+ (setf carry k))
+ (incf i))
+ (setf (%bignum-ref *truncate-x* i)
+ (%add-with-carry (%bignum-ref *truncate-x* i) 0 carry)))
+ (%subtract-with-borrow guess 1 1)))))
+
+;;; This returns a guess for the next division step. Y1 is the highest y
+;;; digit, and y2 is the second to highest y digit. The x... variables are
+;;; the three highest x digits for the next division step.
+;;;
+;;; From Knuth, our guess is either all ones or x-i and x-i-1 divided by y1,
+;;; depending on whether x-i and y1 are the same. We test this guess by
+;;; determining whether guess*y2 is greater than the three high digits of x
+;;; minus guess*y1 shifted left one digit:
+;;; ------------------------------
+;;; | x-i | x-i-1 | x-i-2 |
+;;; ------------------------------
+;;; ------------------------------
+;;; - | g*y1 high | g*y1 low | 0 |
+;;; ------------------------------
+;;; ... < guess*y2 ???
+;;; If guess*y2 is greater, then we decrement our guess by one and try again.
+;;; This returns a guess that is either correct or one too large.
+(defun bignum-truncate-guess (y1 y2 x-i x-i-1 x-i-2)
+ (declare (type bignum-element-type y1 y2 x-i x-i-1 x-i-2))
+ (let ((guess (if (%digit-compare x-i y1)
+ all-ones-digit
+ (%floor x-i x-i-1 y1))))
+ (declare (type bignum-element-type guess))
+ (loop
+ (multiple-value-bind (high-guess*y1 low-guess*y1) (%multiply guess y1)
+ (declare (type bignum-element-type low-guess*y1 high-guess*y1))
+ (multiple-value-bind (high-guess*y2 low-guess*y2)
+ (%multiply guess y2)
+ (declare (type bignum-element-type high-guess*y2 low-guess*y2))
+ (multiple-value-bind (middle-digit borrow)
+ (%subtract-with-borrow x-i-1 low-guess*y1 1)
+ (declare (type bignum-element-type middle-digit)
+ (fixnum borrow))
+ ;; Supplying borrow of 1 means there was no borrow, and we know
+ ;; x-i-2 minus 0 requires no borrow.
+ (let ((high-digit (%subtract-with-borrow x-i high-guess*y1 borrow)))
+ (declare (type bignum-element-type high-digit))
+ (if (and (%digit-compare high-digit 0)
+ (or (%digit-greater high-guess*y2 middle-digit)
+ (and (%digit-compare middle-digit high-guess*y2)
+ (%digit-greater low-guess*y2 x-i-2))))
+ (setf guess (%subtract-with-borrow guess 1 1))
+ (return guess)))))))))
+
+;;; This returns the amount to shift y to place a one in the second highest
+;;; bit. Y must be positive. If the last digit of y is zero, then y has a
+;;; one in the previous digit's sign bit, so we know it will take one less
+;;; than digit-size to get a one where we want. Otherwise, we count how many
+;;; right shifts it takes to get zero; subtracting this value from digit-size
+;;; tells us how many high zeros there are which is one more than the shift
+;;; amount sought.
+;;;
+;;; Note: This is exactly the same as one less than the integer-length of the
+;;; last digit subtracted from the digit-size.
+;;;
+;;; We shift y to make it sufficiently large that doing the 64-bit by 32-bit
+;;; %FLOOR calls ensures the quotient and remainder fit in 32-bits.
+(defun shift-y-for-truncate (y)
+ (let* ((len (%bignum-length y))
+ (last (%bignum-ref y (1- len))))
+ (declare (type bignum-index len)
+ (type bignum-element-type last))
+ (- digit-size (integer-length last) 1)))
+
+;;; Stores two bignums into the truncation bignum buffers, shifting them on the
+;;; way in. This assumes x and y are positive and at least two in length, and
+;;; it assumes *truncate-x* and *truncate-y* are one digit longer than x and y.
+(defun shift-and-store-truncate-buffers (x len-x y len-y shift)
+ (declare (type bignum-index len-x len-y)
+ (type (integer 0 (#.digit-size)) shift))
+ (cond ((zerop shift)
+ (bignum-replace *truncate-x* x :end1 len-x)
+ (bignum-replace *truncate-y* y :end1 len-y))
+ (t
+ (bignum-ashift-left-unaligned x 0 shift (1+ len-x) *truncate-x*)
+ (bignum-ashift-left-unaligned y 0 shift (1+ len-y) *truncate-y*))))
+\f
+;;;; %FLOOR primitive for BIGNUM-TRUNCATE
+
+;;; When a machine leaves out a 64-bit by 32-bit divide instruction (that is,
+;;; two bignum-digits divided by one), we have to roll our own (the hard way).
+;;; Basically, we treat the operation as four 16-bit digits divided by two
+;;; 16-bit digits. This means we have duplicated most of the code above to do
+;;; this nearly general 16-bit digit bignum divide, but we've unrolled loops
+;;; and made use of other properties of this specific divide situation.
+
+;;;; %FLOOR for machines with a 32x32 divider.
+
+#!-sb-fluid
+(declaim (inline 32x16-subtract-with-borrow 32x16-add-with-carry
+ 32x16-divide 32x16-multiply 32x16-multiply-split))
+
+#!+32x16-divide
+(defconstant 32x16-base-1 #xFFFF)
+
+;;; This is similar to %SUBTRACT-WITH-BORROW. It returns a 16-bit difference
+;;; and a borrow. Returning a 1 for the borrow means there was no borrow, and
+;;; 0 means there was one.
+#!+32x16-divide
+(defun 32x16-subtract-with-borrow (a b borrow)
+ (declare (type (unsigned-byte 16) a b)
+ (type (integer 0 1) borrow))
+ (let ((diff (+ (- a b) borrow 32x16-base-1)))
+ (declare (type (unsigned-byte 17) diff))
+ (values (logand diff #xFFFF)
+ (ash diff -16))))
+
+;;; This adds a and b, 16-bit quantities, with the carry k. It returns a
+;;; 16-bit sum and a second value, 0 or 1, indicating whether there was a
+;;; carry.
+#!+32x16-divide
+(defun 32x16-add-with-carry (a b k)
+ (declare (type (unsigned-byte 16) a b)
+ (type (integer 0 1) k))
+ (let ((res (the fixnum (+ a b k))))
+ (declare (type (unsigned-byte 17) res))
+ (if (zerop (the fixnum (logand #x10000 res)))
+ (values res 0)
+ (values (the (unsigned-byte 16) (logand #xFFFF res))
+ 1))))
+
+;;; This is probably a 32-bit by 32-bit divide instruction.
+#!+32x16-divide
+(defun 32x16-divide (a b c)
+ (declare (type (unsigned-byte 16) a b c))
+ (floor (the bignum-element-type
+ (logior (the bignum-element-type (ash a 16))
+ b))
+ c))
+
+;;; This basically exists since we know the answer won't overflow
+;;; bignum-element-type. It's probably just a basic multiply instruction, but
+;;; it can't cons an intermediate bignum. The result goes in a non-descriptor
+;;; register.
+#!+32x16-divide
+(defun 32x16-multiply (a b)
+ (declare (type (unsigned-byte 16) a b))
+ (the bignum-element-type (* a b)))
+
+;;; This multiplies a and b, 16-bit quantities, and returns the result as two
+;;; 16-bit quantities, high and low.
+#!+32x16-divide
+(defun 32x16-multiply-split (a b)
+ (let ((res (32x16-multiply a b)))
+ (declare (the bignum-element-type res))
+ (values (the (unsigned-byte 16) (logand #xFFFF (ash res -16)))
+ (the (unsigned-byte 16) (logand #xFFFF res)))))
+
+;;; The %FLOOR below uses this buffer the same way BIGNUM-TRUNCATE uses
+;;; *truncate-x*. There's no y buffer since we pass around the two 16-bit
+;;; digits and use them slightly differently than the general truncation
+;;; algorithm above.
+#!+32x16-divide
+(defvar *32x16-truncate-x* (make-array 4 :element-type '(unsigned-byte 16)
+ :initial-element 0))
+
+;;; This does the same thing as the %FLOOR above, but it does it at Lisp level
+;;; when there is no 64x32-bit divide instruction on the machine.
+;;;
+;;; It implements the higher level tactics of BIGNUM-TRUNCATE, but it makes use
+;;; of special situation provided, four 16-bit digits divided by two 16-bit
+;;; digits.
+#!+32x16-divide
+(defun %floor (a b c)
+ (declare (type bignum-element-type a b c))
+ ;; Setup *32x16-truncate-x* buffer from a and b.
+ (setf (aref *32x16-truncate-x* 0)
+ (the (unsigned-byte 16) (logand #xFFFF b)))
+ (setf (aref *32x16-truncate-x* 1)
+ (the (unsigned-byte 16)
+ (logand #xFFFF
+ (the (unsigned-byte 16) (ash b -16)))))
+ (setf (aref *32x16-truncate-x* 2)
+ (the (unsigned-byte 16) (logand #xFFFF a)))
+ (setf (aref *32x16-truncate-x* 3)
+ (the (unsigned-byte 16)
+ (logand #xFFFF
+ (the (unsigned-byte 16) (ash a -16)))))
+ ;; From DO-TRUNCATE, but unroll the loop.
+ (let* ((y1 (logand #xFFFF (ash c -16)))
+ (y2 (logand #xFFFF c))
+ (q (the bignum-element-type
+ (ash (32x16-try-bignum-truncate-guess
+ (32x16-truncate-guess y1 y2
+ (aref *32x16-truncate-x* 3)
+ (aref *32x16-truncate-x* 2)
+ (aref *32x16-truncate-x* 1))
+ y1 y2 1)
+ 16))))
+ (declare (type bignum-element-type q)
+ (type (unsigned-byte 16) y1 y2))
+ (values (the bignum-element-type
+ (logior q
+ (the (unsigned-byte 16)
+ (32x16-try-bignum-truncate-guess
+ (32x16-truncate-guess
+ y1 y2
+ (aref *32x16-truncate-x* 2)
+ (aref *32x16-truncate-x* 1)
+ (aref *32x16-truncate-x* 0))
+ y1 y2 0))))
+ (the bignum-element-type
+ (logior (the bignum-element-type
+ (ash (aref *32x16-truncate-x* 1) 16))
+ (the (unsigned-byte 16)
+ (aref *32x16-truncate-x* 0)))))))
+
+;;; This is similar to TRY-BIGNUM-TRUNCATE-GUESS, but this unrolls the two
+;;; loops. This also substitutes for %DIGIT-0-OR-PLUSP the equivalent
+;;; expression without any embellishment or pretense of abstraction. The first
+;;; loop is unrolled, but we've put the body of the loop into the function
+;;; 32X16-TRY-GUESS-ONE-RESULT-DIGIT.
+#!+32x16-divide
+(defun 32x16-try-bignum-truncate-guess (guess y-high y-low low-x-digit)
+ (declare (type bignum-index low-x-digit)
+ (type (unsigned-byte 16) guess y-high y-low))
+ (let ((high-x-digit (+ 2 low-x-digit)))
+ ;; Multiply guess and divisor, subtracting from dividend simultaneously.
+ (multiple-value-bind (guess*y-hold carry borrow)
+ (32x16-try-guess-one-result-digit guess y-low 0 0 1 low-x-digit)
+ (declare (type (unsigned-byte 16) guess*y-hold)
+ (fixnum carry borrow))
+ (multiple-value-bind (guess*y-hold carry borrow)
+ (32x16-try-guess-one-result-digit guess y-high guess*y-hold
+ carry borrow (1+ low-x-digit))
+ (declare (type (unsigned-byte 16) guess*y-hold)
+ (fixnum borrow)
+ (ignore carry))
+ (setf (aref *32x16-truncate-x* high-x-digit)
+ (32x16-subtract-with-borrow (aref *32x16-truncate-x* high-x-digit)
+ guess*y-hold borrow))))
+ ;; See whether guess is off by one, adding one Y back in if necessary.
+ (cond ((zerop (logand #x8000 (aref *32x16-truncate-x* high-x-digit)))
+ ;; The subtraction result is zero or positive.
+ guess)
+ (t
+ ;; If subtraction has negative result, add one divisor value back
+ ;; in. The guess was one too large in magnitude.
+ (multiple-value-bind (v carry)
+ (32x16-add-with-carry y-low
+ (aref *32x16-truncate-x* low-x-digit)
+ 0)
+ (declare (type (unsigned-byte 16) v))
+ (setf (aref *32x16-truncate-x* low-x-digit) v)
+ (multiple-value-bind (v carry)
+ (32x16-add-with-carry y-high
+ (aref *32x16-truncate-x*
+ (1+ low-x-digit))
+ carry)
+ (setf (aref *32x16-truncate-x* (1+ low-x-digit)) v)
+ (setf (aref *32x16-truncate-x* high-x-digit)
+ (32x16-add-with-carry (aref *32x16-truncate-x* high-x-digit)
+ carry 0))))
+ (if (zerop (logand #x8000 guess))
+ (1- guess)
+ (1+ guess))))))
+
+;;; This is similar to the body of the loop in TRY-BIGNUM-TRUNCATE-GUESS that
+;;; multiplies the guess by y and subtracts the result from x simultaneously.
+;;; This returns the digit remembered as part of the multiplication, the carry
+;;; from additions done on behalf of the multiplication, and the borrow from
+;;; doing the subtraction.
+#!+32x16-divide
+(defun 32x16-try-guess-one-result-digit (guess y-digit guess*y-hold
+ carry borrow x-index)
+ (multiple-value-bind (high-digit low-digit)
+ (32x16-multiply-split guess y-digit)
+ (declare (type (unsigned-byte 16) high-digit low-digit))
+ (multiple-value-bind (low-digit temp-carry)
+ (32x16-add-with-carry low-digit guess*y-hold carry)
+ (declare (type (unsigned-byte 16) low-digit))
+ (multiple-value-bind (high-digit temp-carry)
+ (32x16-add-with-carry high-digit temp-carry 0)
+ (declare (type (unsigned-byte 16) high-digit))
+ (multiple-value-bind (x temp-borrow)
+ (32x16-subtract-with-borrow (aref *32x16-truncate-x* x-index)
+ low-digit borrow)
+ (declare (type (unsigned-byte 16) x))
+ (setf (aref *32x16-truncate-x* x-index) x)
+ (values high-digit temp-carry temp-borrow))))))
+
+;;; This is similar to BIGNUM-TRUNCATE-GUESS, but instead of computing the
+;;; guess exactly as described in the its comments (digit by digit), this
+;;; massages the 16-bit quantities into 32-bit quantities and performs the
+#!+32x16-divide
+(defun 32x16-truncate-guess (y1 y2 x-i x-i-1 x-i-2)
+ (declare (type (unsigned-byte 16) y1 y2 x-i x-i-1 x-i-2))
+ (let ((guess (if (= x-i y1)
+ #xFFFF
+ (32x16-divide x-i x-i-1 y1))))
+ (declare (type (unsigned-byte 16) guess))
+ (loop
+ (let* ((guess*y1 (the bignum-element-type
+ (ash (logand #xFFFF
+ (the bignum-element-type
+ (32x16-multiply guess y1)))
+ 16)))
+ (x-y (%subtract-with-borrow
+ (the bignum-element-type
+ (logior (the bignum-element-type
+ (ash x-i-1 16))
+ x-i-2))
+ guess*y1
+ 1))
+ (guess*y2 (the bignum-element-type (%multiply guess y2))))
+ (declare (type bignum-element-type guess*y1 x-y guess*y2))
+ (if (%digit-greater guess*y2 x-y)
+ (decf guess)
+ (return guess))))))
+\f
+;;;; general utilities
+
+;;; Allocate a single word bignum that holds fixnum. This is useful when
+;;; we are trying to mix fixnum and bignum operands.
+#!-sb-fluid (declaim (inline make-small-bignum))
+(defun make-small-bignum (fixnum)
+ (let ((res (%allocate-bignum 1)))
+ (setf (%bignum-ref res 0) (%fixnum-to-digit fixnum))
+ res))
+
+;;; Internal in-place operations use this to fixup remaining digits in the
+;;; incoming data, such as in-place shifting. This is basically the same as
+;;; the first form in %NORMALIZE-BIGNUM, but we return the length of the buffer
+;;; instead of shrinking the bignum.
+#!-sb-fluid (declaim (sb!ext:maybe-inline %normalize-bignum-buffer))
+(defun %normalize-bignum-buffer (result len)
+ (declare (type bignum-type result)
+ (type bignum-index len))
+ (unless (= len 1)
+ (do ((next-digit (%bignum-ref result (- len 2))
+ (%bignum-ref result (- len 2)))
+ (sign-digit (%bignum-ref result (1- len)) next-digit))
+ ((not (zerop (logxor sign-digit (%ashr next-digit (1- digit-size))))))
+ (decf len)
+ (setf (%bignum-ref result len) 0)
+ (when (= len 1)
+ (return))))
+ len)
+
+;;; This drops the last digit if it is unnecessary sign information. It repeats
+;;; this as needed, possibly ending with a fixnum. If the resulting length from
+;;; shrinking is one, see whether our one word is a fixnum. Shift the possible
+;;; fixnum bits completely out of the word, and compare this with shifting the
+;;; sign bit all the way through. If the bits are all 1's or 0's in both words,
+;;; then there are just sign bits between the fixnum bits and the sign bit. If
+;;; we do have a fixnum, shift it over for the two low-tag bits.
+(defun %normalize-bignum (result len)
+ (declare (type bignum-type result)
+ (type bignum-index len)
+ (inline %normalize-bignum-buffer))
+ (let ((newlen (%normalize-bignum-buffer result len)))
+ (declare (type bignum-index newlen))
+ (unless (= newlen len)
+ (%bignum-set-length result newlen))
+ (if (= newlen 1)
+ (let ((digit (%bignum-ref result 0)))
+ (if (= (%ashr digit 29) (%ashr digit (1- digit-size)))
+ (%fixnum-digit-with-correct-sign digit)
+ result))
+ result)))
+
+;;; This drops the last digit if it is unnecessary sign information. It
+;;; repeats this as needed, possibly ending with a fixnum magnitude but never
+;;; returning a fixnum.
+(defun %mostly-normalize-bignum (result len)
+ (declare (type bignum-type result)
+ (type bignum-index len)
+ (inline %normalize-bignum-buffer))
+ (let ((newlen (%normalize-bignum-buffer result len)))
+ (declare (type bignum-index newlen))
+ (unless (= newlen len)
+ (%bignum-set-length result newlen))
+ result))
+\f
+;;;; hashing
+
+;;; the bignum case of the SXHASH function
+(defun sxhash-bignum (x)
+ (let ((result 316495330))
+ (declare (type fixnum result))
+ (dotimes (i (%bignum-length x))
+ (declare (type index i))
+ (let ((xi (%bignum-ref x i)))
+ (mixf result
+ (logand most-positive-fixnum
+ xi
+ (ash xi -7)))))
+ result))
--- /dev/null
+;;;; functions to implement bitblt-ish operations
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!VM")
+
+(file-comment
+ "$Header$")
+\f
+;;;; constants and types
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+
+(defconstant unit-bits sb!vm:word-bits
+ #!+sb-doc
+ "The number of bits to process at a time.")
+
+(defconstant max-bits (ash most-positive-fixnum -2)
+ #!+sb-doc
+ "The maximum number of bits that can be delt with during a single call.")
+
+(deftype unit ()
+ `(unsigned-byte ,unit-bits))
+
+(deftype offset ()
+ `(integer 0 ,max-bits))
+
+(deftype bit-offset ()
+ `(integer 0 (,unit-bits)))
+
+(deftype bit-count ()
+ `(integer 1 (,unit-bits)))
+
+(deftype word-offset ()
+ `(integer 0 (,(ceiling max-bits unit-bits))))
+
+) ; EVAL-WHEN
+\f
+;;;; support routines
+
+;;; A particular implementation must offer either VOPs to translate
+;;; these, or DEFTRANSFORMs to convert them into something supported
+;;; by the architecture.
+(macrolet ((def-frob (name &rest args)
+ `(defun ,name ,args
+ (,name ,@args))))
+ (def-frob 32bit-logical-not x)
+ (def-frob 32bit-logical-and x y)
+ (def-frob 32bit-logical-or x y)
+ (def-frob 32bit-logical-xor x y)
+ (def-frob 32bit-logical-nor x y)
+ (def-frob 32bit-logical-eqv x y)
+ (def-frob 32bit-logical-nand x y)
+ (def-frob 32bit-logical-andc1 x y)
+ (def-frob 32bit-logical-andc2 x y)
+ (def-frob 32bit-logical-orc1 x y)
+ (def-frob 32bit-logical-orc2 x y))
+
+(defun shift-towards-start (number countoid)
+ #!+sb-doc
+ "Shift NUMBER by the low-order bits of COUNTOID, adding zero bits at
+ the ``end'' and removing bits from the ``start.'' On big-endian
+ machines this is a left-shift and on little-endian machines this is a
+ right-shift."
+ (declare (type unit number) (fixnum countoid))
+ (let ((count (ldb (byte (1- (integer-length unit-bits)) 0) countoid)))
+ (declare (type bit-offset count))
+ (if (zerop count)
+ number
+ (ecase sb!c:*backend-byte-order*
+ (:big-endian
+ (ash (ldb (byte (- unit-bits count) 0) number) count))
+ (:little-endian
+ (ash number (- count)))))))
+
+(defun shift-towards-end (number count)
+ #!+sb-doc
+ "Shift NUMBER by COUNT bits, adding zero bits at the ``start'' and removing
+ bits from the ``end.'' On big-endian machines this is a right-shift and
+ on little-endian machines this is a left-shift."
+ (declare (type unit number) (fixnum count))
+ (let ((count (ldb (byte (1- (integer-length unit-bits)) 0) count)))
+ (declare (type bit-offset count))
+ (if (zerop count)
+ number
+ (ecase sb!c:*backend-byte-order*
+ (:big-endian
+ (ash number (- count)))
+ (:little-endian
+ (ash (ldb (byte (- unit-bits count) 0) number) count))))))
+
+#!-sb-fluid (declaim (inline start-mask end-mask fix-sap-and-offset))
+(defun start-mask (count)
+ #!+sb-doc
+ "Produce a mask that contains 1's for the COUNT ``start'' bits and 0's for
+ the remaining ``end'' bits. Only the lower 5 bits of COUNT are significant."
+ (declare (fixnum count))
+ (shift-towards-start (1- (ash 1 unit-bits)) (- count)))
+
+(defun end-mask (count)
+ #!+sb-doc
+ "Produce a mask that contains 1's for the COUNT ``end'' bits and 0's for
+ the remaining ``start'' bits. Only the lower 5 bits of COUNT are
+ significant."
+ (declare (fixnum count))
+ (shift-towards-end (1- (ash 1 unit-bits)) (- count)))
+
+(defun fix-sap-and-offset (sap offset)
+ #!+sb-doc
+ "Align the SAP to a word boundary, and update the offset accordingly."
+ (declare (type system-area-pointer sap)
+ (type index offset)
+ (values system-area-pointer index))
+ (let ((address (sap-int sap)))
+ (values (int-sap #!-alpha (32bit-logical-andc2 address 3)
+ #!+alpha (ash (ash address -2) 2))
+ (+ (* (logand address 3) byte-bits) offset))))
+
+#!-sb-fluid (declaim (inline word-sap-ref %set-word-sap-ref))
+(defun word-sap-ref (sap offset)
+ (declare (type system-area-pointer sap)
+ (type index offset)
+ (values (unsigned-byte 32))
+ (optimize (speed 3) (safety 0) #-sb-xc-host (inhibit-warnings 3)))
+ (sap-ref-32 sap (the index (ash offset 2))))
+(defun %set-word-sap-ref (sap offset value)
+ (declare (type system-area-pointer sap)
+ (type index offset)
+ (type (unsigned-byte 32) value)
+ (values (unsigned-byte 32))
+ (optimize (speed 3) (safety 0) (inhibit-warnings 3)))
+ (setf (sap-ref-32 sap (the index (ash offset 2))) value))
+\f
+;;;; DO-CONSTANT-BIT-BASH
+
+#!-sb-fluid (declaim (inline do-constant-bit-bash))
+(defun do-constant-bit-bash (dst dst-offset length value dst-ref-fn dst-set-fn)
+ #!+sb-doc
+ "Fill DST with VALUE starting at DST-OFFSET and continuing for LENGTH bits."
+ (declare (type offset dst-offset) (type unit value)
+ (type function dst-ref-fn dst-set-fn))
+ (multiple-value-bind (dst-word-offset dst-bit-offset)
+ (floor dst-offset unit-bits)
+ (declare (type word-offset dst-word-offset)
+ (type bit-offset dst-bit-offset))
+ (multiple-value-bind (words final-bits)
+ (floor (+ dst-bit-offset length) unit-bits)
+ (declare (type word-offset words) (type bit-offset final-bits))
+ (if (zerop words)
+ (unless (zerop length)
+ (funcall dst-set-fn dst dst-word-offset
+ (if (= length unit-bits)
+ value
+ (let ((mask (shift-towards-end (start-mask length)
+ dst-bit-offset)))
+ (declare (type unit mask))
+ (32bit-logical-or
+ (32bit-logical-and value mask)
+ (32bit-logical-andc2
+ (funcall dst-ref-fn dst dst-word-offset)
+ mask))))))
+ (let ((interior (floor (- length final-bits) unit-bits)))
+ (unless (zerop dst-bit-offset)
+ (let ((mask (end-mask (- dst-bit-offset))))
+ (declare (type unit mask))
+ (funcall dst-set-fn dst dst-word-offset
+ (32bit-logical-or
+ (32bit-logical-and value mask)
+ (32bit-logical-andc2
+ (funcall dst-ref-fn dst dst-word-offset)
+ mask))))
+ (incf dst-word-offset))
+ (dotimes (i interior)
+ (funcall dst-set-fn dst dst-word-offset value)
+ (incf dst-word-offset))
+ (unless (zerop final-bits)
+ (let ((mask (start-mask final-bits)))
+ (declare (type unit mask))
+ (funcall dst-set-fn dst dst-word-offset
+ (32bit-logical-or
+ (32bit-logical-and value mask)
+ (32bit-logical-andc2
+ (funcall dst-ref-fn dst dst-word-offset)
+ mask)))))))))
+ (values))
+\f
+;;;; DO-UNARY-BIT-BASH
+
+#!-sb-fluid (declaim (inline do-unary-bit-bash))
+(defun do-unary-bit-bash (src src-offset dst dst-offset length
+ dst-ref-fn dst-set-fn src-ref-fn)
+ (declare (type offset src-offset dst-offset length)
+ (type function dst-ref-fn dst-set-fn src-ref-fn))
+ (multiple-value-bind (dst-word-offset dst-bit-offset)
+ (floor dst-offset unit-bits)
+ (declare (type word-offset dst-word-offset)
+ (type bit-offset dst-bit-offset))
+ (multiple-value-bind (src-word-offset src-bit-offset)
+ (floor src-offset unit-bits)
+ (declare (type word-offset src-word-offset)
+ (type bit-offset src-bit-offset))
+ (cond
+ ((<= (+ dst-bit-offset length) unit-bits)
+ ;; We are only writing one word, so it doesn't matter what order
+ ;; we do it in. But we might be reading from multiple words, so take
+ ;; care.
+ (cond
+ ((zerop length)
+ ;; Actually, we aren't even writing one word. This is real easy.
+ )
+ ((= length unit-bits)
+ ;; DST-BIT-OFFSET must be equal to zero, or we would be writing
+ ;; multiple words. If SRC-BIT-OFFSET is also zero, then we
+ ;; just transfer the single word. Otherwise we have to extract bits
+ ;; from two src words.
+ (funcall dst-set-fn dst dst-word-offset
+ (if (zerop src-bit-offset)
+ (funcall src-ref-fn src src-word-offset)
+ (32bit-logical-or
+ (shift-towards-start
+ (funcall src-ref-fn src src-word-offset)
+ src-bit-offset)
+ (shift-towards-end
+ (funcall src-ref-fn src (1+ src-word-offset))
+ (- src-bit-offset))))))
+ (t
+ ;; We are only writing some portion of the dst word, so we need to
+ ;; preserve the extra bits. Also, we still don't know whether we need
+ ;; one or two source words.
+ (let ((mask (shift-towards-end (start-mask length) dst-bit-offset))
+ (orig (funcall dst-ref-fn dst dst-word-offset))
+ (value
+ (if (> src-bit-offset dst-bit-offset)
+ ;; The source starts further into the word than does
+ ;; the dst, so the source could extend into the next
+ ;; word. If it does, we have to merge the two words,
+ ;; and if not, we can just shift the first word.
+ (let ((src-bit-shift (- src-bit-offset dst-bit-offset)))
+ (if (> (+ src-bit-offset length) unit-bits)
+ (32bit-logical-or
+ (shift-towards-start
+ (funcall src-ref-fn src src-word-offset)
+ src-bit-shift)
+ (shift-towards-end
+ (funcall src-ref-fn src (1+ src-word-offset))
+ (- src-bit-shift)))
+ (shift-towards-start
+ (funcall src-ref-fn src src-word-offset)
+ src-bit-shift)))
+ ;; The dst starts further into the word than does the
+ ;; source, so we know the source can not extend into
+ ;; a second word (or else the dst would too, and we
+ ;; wouldn't be in this branch.
+ (shift-towards-end
+ (funcall src-ref-fn src src-word-offset)
+ (- dst-bit-offset src-bit-offset)))))
+ (declare (type unit mask orig value))
+ ;; Replace the dst word.
+ (funcall dst-set-fn dst dst-word-offset
+ (32bit-logical-or
+ (32bit-logical-and value mask)
+ (32bit-logical-andc2 orig mask)))))))
+ ((= src-bit-offset dst-bit-offset)
+ ;; The source and dst are aligned, so we don't need to shift
+ ;; anything. But we have to pick the direction of the loop
+ ;; in case the source and dst are really the same thing.
+ (multiple-value-bind (words final-bits)
+ (floor (+ dst-bit-offset length) unit-bits)
+ (declare (type word-offset words) (type bit-offset final-bits))
+ (let ((interior (floor (- length final-bits) unit-bits)))
+ (declare (type word-offset interior))
+ (cond
+ ((<= dst-offset src-offset)
+ ;; We need to loop from left to right
+ (unless (zerop dst-bit-offset)
+ ;; We are only writing part of the first word, so mask off the
+ ;; bits we want to preserve.
+ (let ((mask (end-mask (- dst-bit-offset)))
+ (orig (funcall dst-ref-fn dst dst-word-offset))
+ (value (funcall src-ref-fn src src-word-offset)))
+ (declare (type unit mask orig value))
+ (funcall dst-set-fn dst dst-word-offset
+ (32bit-logical-or (32bit-logical-and value mask)
+ (32bit-logical-andc2 orig mask))))
+ (incf src-word-offset)
+ (incf dst-word-offset))
+ ;; Just copy the interior words.
+ (dotimes (i interior)
+ (funcall dst-set-fn dst dst-word-offset
+ (funcall src-ref-fn src src-word-offset))
+ (incf src-word-offset)
+ (incf dst-word-offset))
+ (unless (zerop final-bits)
+ ;; We are only writing part of the last word.
+ (let ((mask (start-mask final-bits))
+ (orig (funcall dst-ref-fn dst dst-word-offset))
+ (value (funcall src-ref-fn src src-word-offset)))
+ (declare (type unit mask orig value))
+ (funcall dst-set-fn dst dst-word-offset
+ (32bit-logical-or
+ (32bit-logical-and value mask)
+ (32bit-logical-andc2 orig mask))))))
+ (t
+ ;; We need to loop from right to left.
+ (incf dst-word-offset words)
+ (incf src-word-offset words)
+ (unless (zerop final-bits)
+ (let ((mask (start-mask final-bits))
+ (orig (funcall dst-ref-fn dst dst-word-offset))
+ (value (funcall src-ref-fn src src-word-offset)))
+ (declare (type unit mask orig value))
+ (funcall dst-set-fn dst dst-word-offset
+ (32bit-logical-or
+ (32bit-logical-and value mask)
+ (32bit-logical-andc2 orig mask)))))
+ (dotimes (i interior)
+ (decf src-word-offset)
+ (decf dst-word-offset)
+ (funcall dst-set-fn dst dst-word-offset
+ (funcall src-ref-fn src src-word-offset)))
+ (unless (zerop dst-bit-offset)
+ (decf src-word-offset)
+ (decf dst-word-offset)
+ (let ((mask (end-mask (- dst-bit-offset)))
+ (orig (funcall dst-ref-fn dst dst-word-offset))
+ (value (funcall src-ref-fn src src-word-offset)))
+ (declare (type unit mask orig value))
+ (funcall dst-set-fn dst dst-word-offset
+ (32bit-logical-or
+ (32bit-logical-and value mask)
+ (32bit-logical-andc2 orig mask))))))))))
+ (t
+ ;; They aren't aligned.
+ (multiple-value-bind (words final-bits)
+ (floor (+ dst-bit-offset length) unit-bits)
+ (declare (type word-offset words) (type bit-offset final-bits))
+ (let ((src-shift (mod (- src-bit-offset dst-bit-offset) unit-bits))
+ (interior (floor (- length final-bits) unit-bits)))
+ (declare (type bit-offset src-shift)
+ (type word-offset interior))
+ (cond
+ ((<= dst-offset src-offset)
+ ;; We need to loop from left to right
+ (let ((prev 0)
+ (next (funcall src-ref-fn src src-word-offset)))
+ (declare (type unit prev next))
+ (flet ((get-next-src ()
+ (setf prev next)
+ (setf next (funcall src-ref-fn src
+ (incf src-word-offset)))))
+ (declare (inline get-next-src))
+ (unless (zerop dst-bit-offset)
+ (when (> src-bit-offset dst-bit-offset)
+ (get-next-src))
+ (let ((mask (end-mask (- dst-bit-offset)))
+ (orig (funcall dst-ref-fn dst dst-word-offset))
+ (value (32bit-logical-or
+ (shift-towards-start prev src-shift)
+ (shift-towards-end next (- src-shift)))))
+ (declare (type unit mask orig value))
+ (funcall dst-set-fn dst dst-word-offset
+ (32bit-logical-or
+ (32bit-logical-and value mask)
+ (32bit-logical-andc2 orig mask)))
+ (incf dst-word-offset)))
+ (dotimes (i interior)
+ (get-next-src)
+ (let ((value (32bit-logical-or
+ (shift-towards-end next (- src-shift))
+ (shift-towards-start prev src-shift))))
+ (declare (type unit value))
+ (funcall dst-set-fn dst dst-word-offset value)
+ (incf dst-word-offset)))
+ (unless (zerop final-bits)
+ (let ((value
+ (if (> (+ final-bits src-shift) unit-bits)
+ (progn
+ (get-next-src)
+ (32bit-logical-or
+ (shift-towards-end next (- src-shift))
+ (shift-towards-start prev src-shift)))
+ (shift-towards-start next src-shift)))
+ (mask (start-mask final-bits))
+ (orig (funcall dst-ref-fn dst dst-word-offset)))
+ (declare (type unit mask orig value))
+ (funcall dst-set-fn dst dst-word-offset
+ (32bit-logical-or
+ (32bit-logical-and value mask)
+ (32bit-logical-andc2 orig mask))))))))
+ (t
+ ;; We need to loop from right to left.
+ (incf dst-word-offset words)
+ (incf src-word-offset
+ (1- (ceiling (+ src-bit-offset length) unit-bits)))
+ (let ((next 0)
+ (prev (funcall src-ref-fn src src-word-offset)))
+ (declare (type unit prev next))
+ (flet ((get-next-src ()
+ (setf next prev)
+ (setf prev (funcall src-ref-fn src
+ (decf src-word-offset)))))
+ (declare (inline get-next-src))
+ (unless (zerop final-bits)
+ (when (> final-bits (- unit-bits src-shift))
+ (get-next-src))
+ (let ((value (32bit-logical-or
+ (shift-towards-end next (- src-shift))
+ (shift-towards-start prev src-shift)))
+ (mask (start-mask final-bits))
+ (orig (funcall dst-ref-fn dst dst-word-offset)))
+ (declare (type unit mask orig value))
+ (funcall dst-set-fn dst dst-word-offset
+ (32bit-logical-or
+ (32bit-logical-and value mask)
+ (32bit-logical-andc2 orig mask)))))
+ (decf dst-word-offset)
+ (dotimes (i interior)
+ (get-next-src)
+ (let ((value (32bit-logical-or
+ (shift-towards-end next (- src-shift))
+ (shift-towards-start prev src-shift))))
+ (declare (type unit value))
+ (funcall dst-set-fn dst dst-word-offset value)
+ (decf dst-word-offset)))
+ (unless (zerop dst-bit-offset)
+ (if (> src-bit-offset dst-bit-offset)
+ (get-next-src)
+ (setf next prev prev 0))
+ (let ((mask (end-mask (- dst-bit-offset)))
+ (orig (funcall dst-ref-fn dst dst-word-offset))
+ (value (32bit-logical-or
+ (shift-towards-start prev src-shift)
+ (shift-towards-end next (- src-shift)))))
+ (declare (type unit mask orig value))
+ (funcall dst-set-fn dst dst-word-offset
+ (32bit-logical-or
+ (32bit-logical-and value mask)
+ (32bit-logical-andc2 orig mask)))))))))))))))
+ (values))
+\f
+;;;; the actual bashers
+
+(defun bit-bash-fill (value dst dst-offset length)
+ (declare (type unit value) (type offset dst-offset length))
+ (locally
+ (declare (optimize (speed 3) (safety 0)))
+ (do-constant-bit-bash dst dst-offset length value
+ #'%raw-bits #'%set-raw-bits)))
+
+(defun system-area-fill (value dst dst-offset length)
+ (declare (type unit value) (type offset dst-offset length))
+ (locally
+ (declare (optimize (speed 3) (safety 0)))
+ (multiple-value-bind (dst dst-offset) (fix-sap-and-offset dst dst-offset)
+ (do-constant-bit-bash dst dst-offset length value
+ #'word-sap-ref #'%set-word-sap-ref))))
+
+(defun bit-bash-copy (src src-offset dst dst-offset length)
+ (declare (type offset src-offset dst-offset length))
+ (locally
+ (declare (optimize (speed 3) (safety 0))
+ (inline do-unary-bit-bash))
+ (do-unary-bit-bash src src-offset dst dst-offset length
+ #'%raw-bits #'%set-raw-bits #'%raw-bits)))
+
+(defun system-area-copy (src src-offset dst dst-offset length)
+ (declare (type offset src-offset dst-offset length))
+ (locally
+ (declare (optimize (speed 3) (safety 0)))
+ (multiple-value-bind (src src-offset) (fix-sap-and-offset src src-offset)
+ (declare (type system-area-pointer src))
+ (multiple-value-bind (dst dst-offset) (fix-sap-and-offset dst dst-offset)
+ (declare (type system-area-pointer dst))
+ (do-unary-bit-bash src src-offset dst dst-offset length
+ #'word-sap-ref #'%set-word-sap-ref
+ #'word-sap-ref)))))
+
+(defun copy-to-system-area (src src-offset dst dst-offset length)
+ (declare (type offset src-offset dst-offset length))
+ (locally
+ (declare (optimize (speed 3) (safety 0)))
+ (multiple-value-bind (dst dst-offset) (fix-sap-and-offset dst dst-offset)
+ (do-unary-bit-bash src src-offset dst dst-offset length
+ #'word-sap-ref #'%set-word-sap-ref #'%raw-bits))))
+
+(defun copy-from-system-area (src src-offset dst dst-offset length)
+ (declare (type offset src-offset dst-offset length))
+ (locally
+ (declare (optimize (speed 3) (safety 0)))
+ (multiple-value-bind (src src-offset) (fix-sap-and-offset src src-offset)
+ (do-unary-bit-bash src src-offset dst dst-offset length
+ #'%raw-bits #'%set-raw-bits #'word-sap-ref))))
+
+;;; a common idiom for calling COPY-TO-SYSTEM-AREA
+;;;
+;;; Copy the entire contents of the vector V to memory starting at SAP+OFFSET.
+(defun copy-byte-vector-to-system-area (bv sap &optional (offset 0))
+ ;; FIXME: There should be a type like SB!VM:BYTE so that we can write this
+ ;; type as (SIMPLE-ARRAY SB!VM:BYTE 1). Except BYTE is an external symbol of
+ ;; package CL; so maybe SB!VM:VM-BYTE?
+ (declare (type (simple-array (unsigned-byte 8) 1) bv))
+ (declare (type sap sap))
+ (declare (type fixnum offset))
+ ;; FIXME: Actually it looks as though this, and most other calls
+ ;; to COPY-TO-SYSTEM-AREA, could be written more concisely with BYTE-BLT.
+ ;; Except that the DST-END-DST-START convention for the length is confusing.
+ ;; Perhaps I could rename BYTE-BLT to BYTE-BLIT and replace the
+ ;; DST-END argument with an N-BYTES argument?
+ (copy-to-system-area bv
+ (* sb!vm:vector-data-offset sb!vm:word-bits)
+ sap
+ offset
+ (* (length bv) sb!vm:byte-bits)))
--- /dev/null
+;;;; extensions which are needed in order to (cross-)compile target-only code
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!EXT")
+
+(file-comment
+ "$Header$")
+
+;;; Lots of code wants to get to the KEYWORD package or the COMMON-LISP package
+;;; without a lot of fuss, so we cache them in variables. TO DO: How much
+;;; does this actually buy us? It sounds sensible, but I don't know for sure
+;;; that it saves space or time.. -- WHN 19990521
+(declaim (type package *cl-package* *keyword-package*))
+(defvar *cl-package* (find-package "COMMON-LISP"))
+(defvar *keyword-package* (find-package "KEYWORD"))
+\f
+;;;; the COLLECT macro
+
+;;; helper functions for COLLECT, which become the expanders of the MACROLET
+;;; definitions created by COLLECT
+;;;
+;;; COLLECT-NORMAL-EXPANDER handles normal collection macros.
+;;;
+;;; COLLECT-LIST-EXPANDER handles the list collection case. N-TAIL
+;;; is the pointer to the current tail of the list, or NIL if the list
+;;; is empty.
+(defun collect-normal-expander (n-value fun forms)
+ `(progn
+ ,@(mapcar #'(lambda (form) `(setq ,n-value (,fun ,form ,n-value))) forms)
+ ,n-value))
+(defun collect-list-expander (n-value n-tail forms)
+ (let ((n-res (gensym)))
+ `(progn
+ ,@(mapcar #'(lambda (form)
+ `(let ((,n-res (cons ,form nil)))
+ (cond (,n-tail
+ (setf (cdr ,n-tail) ,n-res)
+ (setq ,n-tail ,n-res))
+ (t
+ (setq ,n-tail ,n-res ,n-value ,n-res)))))
+ forms)
+ ,n-value)))
+
+;;; the ultimate collection macro...
+(defmacro collect (collections &body body)
+ #!+sb-doc
+ "Collect ({(Name [Initial-Value] [Function])}*) {Form}*
+ Collect some values somehow. Each of the collections specifies a bunch of
+ things which collected during the evaluation of the body of the form. The
+ name of the collection is used to define a local macro, a la MACROLET.
+ Within the body, this macro will evaluate each of its arguments and collect
+ the result, returning the current value after the collection is done. The
+ body is evaluated as a PROGN; to get the final values when you are done, just
+ call the collection macro with no arguments.
+
+ INITIAL-VALUE is the value that the collection starts out with, which
+ defaults to NIL. FUNCTION is the function which does the collection. It is
+ a function which will accept two arguments: the value to be collected and the
+ current collection. The result of the function is made the new value for the
+ collection. As a totally magical special-case, FUNCTION may be COLLECT,
+ which tells us to build a list in forward order; this is the default. If an
+ INITIAL-VALUE is supplied for Collect, the stuff will be RPLACD'd onto the
+ end. Note that FUNCTION may be anything that can appear in the functional
+ position, including macros and lambdas."
+
+ (let ((macros ())
+ (binds ()))
+ (dolist (spec collections)
+ (unless (proper-list-of-length-p spec 1 3)
+ (error "Malformed collection specifier: ~S." spec))
+ (let* ((name (first spec))
+ (default (second spec))
+ (kind (or (third spec) 'collect))
+ (n-value (gensym (concatenate 'string
+ (symbol-name name)
+ "-N-VALUE-"))))
+ (push `(,n-value ,default) binds)
+ (if (eq kind 'collect)
+ (let ((n-tail (gensym (concatenate 'string
+ (symbol-name name)
+ "-N-TAIL-"))))
+ (if default
+ (push `(,n-tail (last ,n-value)) binds)
+ (push n-tail binds))
+ (push `(,name (&rest args)
+ (collect-list-expander ',n-value ',n-tail args))
+ macros))
+ (push `(,name (&rest args)
+ (collect-normal-expander ',n-value ',kind args))
+ macros))))
+ `(macrolet ,macros (let* ,(nreverse binds) ,@body))))
+\f
+(declaim (ftype (function () nil) required-argument))
+(defun required-argument ()
+ #!+sb-doc
+ "This function can be used as the default value for keyword arguments that
+ must be always be supplied. Since it is known by the compiler to never
+ return, it will avoid any compile-time type warnings that would result from a
+ default value inconsistent with the declared type. When this function is
+ called, it signals an error indicating that a required keyword argument was
+ not supplied. This function is also useful for DEFSTRUCT slot defaults
+ corresponding to required arguments."
+ (/show0 "entering REQUIRED-ARGUMENT")
+ (error "A required keyword argument was not supplied."))
+\f
+;;; "the ultimate iteration macro"
+;;;
+;;; note for Schemers: This seems to be identical to Scheme's "named LET".
+(defmacro iterate (name binds &body body)
+ #!+sb-doc
+ "Iterate Name ({(Var Initial-Value)}*) Declaration* Form*
+ This is syntactic sugar for Labels. It creates a local function Name with
+ the specified Vars as its arguments and the Declarations and Forms as its
+ body. This function is then called with the Initial-Values, and the result
+ of the call is returned from the macro."
+ (dolist (x binds)
+ (unless (proper-list-of-length-p x 2)
+ (error "Malformed ITERATE variable spec: ~S." x)))
+ `(labels ((,name ,(mapcar #'first binds) ,@body))
+ (,name ,@(mapcar #'second binds))))
+\f
+;;; Once-Only is a utility useful in writing source transforms and macros.
+;;; It provides an easy way to wrap a LET around some code to ensure that some
+;;; forms are only evaluated once.
+(defmacro once-only (specs &body body)
+ #!+sb-doc
+ "Once-Only ({(Var Value-Expression)}*) Form*
+ Create a Let* which evaluates each Value-Expression, binding a temporary
+ variable to the result, and wrapping the Let* around the result of the
+ evaluation of Body. Within the body, each Var is bound to the corresponding
+ temporary variable."
+ (iterate frob
+ ((specs specs)
+ (body body))
+ (if (null specs)
+ `(progn ,@body)
+ (let ((spec (first specs)))
+ ;; FIXME: should just be DESTRUCTURING-BIND of SPEC
+ (unless (proper-list-of-length-p spec 2)
+ (error "malformed ONCE-ONLY binding spec: ~S" spec))
+ (let* ((name (first spec))
+ (exp-temp (gensym (symbol-name name))))
+ `(let ((,exp-temp ,(second spec))
+ (,name (gensym "OO-")))
+ `(let ((,,name ,,exp-temp))
+ ,,(frob (rest specs) body))))))))
+\f
+;;;; some old-fashioned functions. (They're not just for old-fashioned
+;;;; code, they're also used as optimized forms of the corresponding
+;;;; general functions when the compiler can prove that they're
+;;;; equivalent.)
+
+;;; like (MEMBER ITEM LIST :TEST #'EQ)
+(defun memq (item list)
+ #!+sb-doc
+ "Returns tail of LIST beginning with first element EQ to ITEM."
+ ;; KLUDGE: These could be and probably should be defined as
+ ;; (MEMBER ITEM LIST :TEST #'EQ)),
+ ;; but when I try to cross-compile that, I get an error from
+ ;; LTN-ANALYZE-KNOWN-CALL, "Recursive known function definition". The
+ ;; comments for that error say it "is probably a botched interpreter stub".
+ ;; Rather than try to figure that out, I just rewrote this function from
+ ;; scratch. -- WHN 19990512
+ (do ((i list (cdr i)))
+ ((null i))
+ (when (eq (car i) item)
+ (return i))))
+
+;;; like (ASSOC ITEM ALIST :TEST #'EQ)
+(defun assq (item alist)
+ #!+sb-doc
+ "Return the first pair of ALIST where ITEM is EQ to the key of the pair."
+ ;; KLUDGE: CMU CL defined this with
+ ;; (DECLARE (INLINE ASSOC))
+ ;; (ASSOC ITEM ALIST :TEST #'EQ))
+ ;; which is pretty, but which would have required adding awkward
+ ;; build order constraints on SBCL (or figuring out some way to make
+ ;; inline definitions installable at build-the-cross-compiler time,
+ ;; which was too ambitious for now). Rather than mess with that,
+ ;; we just define ASSQ explicitly in terms of more primitive operations:
+ (dolist (pair alist)
+ (when (eq (car pair) item)
+ (return pair))))
+
+(defun delq (item list)
+ #!+sb-doc
+ "Delete all LIST entries EQ to ITEM (destructively modifying LIST), and
+ return the modified LIST."
+ (let ((list list))
+ (do ((x list (cdr x))
+ (splice '()))
+ ((endp x) list)
+ (cond ((eq item (car x))
+ (if (null splice)
+ (setq list (cdr x))
+ (rplacd splice (cdr x))))
+ (t (setq splice x)))))) ; Move splice along to include element.
--- /dev/null
+;;;; OS interface functions for CMU CL under BSD Unix.
+
+;;;; This code was written as part of the CMU Common Lisp project at
+;;;; Carnegie Mellon University, and has been placed in the public
+;;;; domain.
+
+(sb!int:file-comment
+ "$Header$")
+
+(in-package "SB!SYS")
+
+;;;; Check that target machine features are set up consistently with
+;;;; this file.
+#!-bsd (eval-when (:compile-toplevel :load-toplevel :execute)
+ (error "The :BSD feature is missing, we shouldn't be doing this code."))
+
+(defun software-type ()
+ #!+sb-doc
+ "Return a string describing the supporting software."
+ (the string ; (to force error in case of unsupported BSD variant)
+ #!+FreeBSD "FreeBSD"
+ #!+OpenBSD "OpenBSD"))
+
+(defun software-version ()
+ #!+sb-doc
+ "Return a string describing version of the supporting software, or NIL
+ if not available."
+ #+nil ; won't work until we support RUN-PROGRAM..
+ (unless *software-version*
+ (setf *software-version*
+ (string-trim '(#\newline)
+ (with-output-to-string (stream)
+ (run-program "/usr/bin/uname"
+ '("-r")
+ :output stream)))))
+ nil)
+\f
+;;; OS-COLD-INIT-OR-REINIT initializes our operating-system interface.
+;;; It sets the values of the global port variables to what they
+;;; should be and calls the functions that set up the argument blocks
+;;; for the server interfaces.
+(defun os-cold-init-or-reinit ()
+ (setf *software-version* nil))
+
+;;; Return system time, user time and number of page faults.
+(defun get-system-info ()
+ (multiple-value-bind (err? utime stime maxrss ixrss idrss
+ isrss minflt majflt)
+ (sb!unix:unix-getrusage sb!unix:rusage_self)
+ (declare (ignore maxrss ixrss idrss isrss minflt))
+ (unless err?
+ (error "Unix system call getrusage failed: ~A."
+ (sb!unix:get-unix-error-msg utime)))
+
+ (values utime stime majflt)))
+
+;;; Return the system page size.
+(defun get-page-size ()
+ ;; FIXME: probably should call getpagesize()
+ 4096)
--- /dev/null
+;;;; the byte code interpreter
+
+(in-package "SB!C")
+
+(file-comment
+ "$Header$")
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+;;; We need at least this level of DEBUGness in order for the local
+;;; declaration in WITH-DEBUGGER-INFO to take effect.
+;;;
+;;; FIXME: This will cause source code location information to be
+;;; compiled into the executable, which will probably cause problems
+;;; for users running without the sources and/or without the
+;;; build-the-system readtable.
+(declaim (optimize (debug 2)))
+\f
+;;; Return a function type approximating the type of a byte-compiled
+;;; function. We really only capture the arg signature.
+(defun byte-function-type (x)
+ (specifier-type
+ (etypecase x
+ (simple-byte-function
+ `(function ,(make-list (simple-byte-function-num-args x)
+ :initial-element 't)
+ *))
+ (hairy-byte-function
+ (collect ((res))
+ (let ((min (hairy-byte-function-min-args x))
+ (max (hairy-byte-function-max-args x)))
+ (dotimes (i min) (res 't))
+ (when (> max min)
+ (res '&optional)
+ (dotimes (i (- max min))
+ (res 't))))
+ (when (hairy-byte-function-rest-arg-p x)
+ (res '&rest 't))
+ (ecase (hairy-byte-function-keywords-p x)
+ ((t :allow-others)
+ (res '&key)
+ (dolist (key (hairy-byte-function-keywords x))
+ (res `(,(car key) t)))
+ (when (eql (hairy-byte-function-keywords-p x) :allow-others)
+ (res '&allow-other-keys)))
+ ((nil)))
+ `(function ,(res) *))))))
+\f
+;;;; the evaluation stack
+
+;;; the interpreter's evaluation stack
+(defvar *eval-stack* (make-array 100)) ; will grow as needed
+;;; FIXME: This seems to be used by the ordinary (non-byte) interpreter
+;;; too, judging from a crash I had when I removed byte-interp.lisp from
+;;; the cold build sequence. It would probably be clearer to pull the
+;;; shared interpreter machinery out of the byte interpreter and ordinary
+;;; interpreter files and put them into their own file shared-interp.lisp
+;;; or something.
+
+;;; the index of the next free element of the interpreter's evaluation stack
+(defvar *eval-stack-top* 0)
+
+(defmacro current-stack-pointer () '*eval-stack-top*)
+
+#!-sb-fluid (declaim (inline eval-stack-ref))
+(defun eval-stack-ref (offset)
+ (declare (type stack-pointer offset))
+ (svref sb!eval::*eval-stack* offset))
+
+#!-sb-fluid (declaim (inline (setf eval-stack-ref)))
+(defun (setf eval-stack-ref) (new-value offset)
+ (declare (type stack-pointer offset))
+ (setf (svref sb!eval::*eval-stack* offset) new-value))
+
+(defun push-eval-stack (value)
+ (let ((len (length (the simple-vector sb!eval::*eval-stack*)))
+ (sp (current-stack-pointer)))
+ (when (= len sp)
+ (let ((new-stack (make-array (ash len 1))))
+ (replace new-stack sb!eval::*eval-stack* :end1 len :end2 len)
+ (setf sb!eval::*eval-stack* new-stack)))
+ (setf (current-stack-pointer) (1+ sp))
+ (setf (eval-stack-ref sp) value)))
+
+(defun allocate-eval-stack (amount)
+ (let* ((len (length (the simple-vector sb!eval::*eval-stack*)))
+ (sp (current-stack-pointer))
+ (new-sp (+ sp amount)))
+ (declare (type index sp new-sp))
+ (when (>= new-sp len)
+ (let ((new-stack (make-array (ash new-sp 1))))
+ (replace new-stack sb!eval::*eval-stack* :end1 len :end2 len)
+ (setf sb!eval::*eval-stack* new-stack)))
+ (setf (current-stack-pointer) new-sp)
+ (let ((stack sb!eval::*eval-stack*))
+ (do ((i sp (1+ i))) ; FIXME: DOTIMES? or just :INITIAL-ELEMENT in MAKE-ARRAY?
+ ((= i new-sp))
+ (setf (svref stack i) '#:uninitialized))))
+ (values))
+
+(defun pop-eval-stack ()
+ (let* ((new-sp (1- (current-stack-pointer)))
+ (value (eval-stack-ref new-sp)))
+ (setf (current-stack-pointer) new-sp)
+ value))
+
+(defmacro multiple-value-pop-eval-stack ((&rest vars) &body body)
+ #+nil (declare (optimize (inhibit-warnings 3)))
+ (let ((num-vars (length vars))
+ (index -1)
+ (new-sp-var (gensym "NEW-SP-"))
+ (decls nil))
+ (loop
+ (unless (and (consp body) (consp (car body)) (eq (caar body) 'declare))
+ (return))
+ (push (pop body) decls))
+ `(let ((,new-sp-var (- (current-stack-pointer) ,num-vars)))
+ (declare (type stack-pointer ,new-sp-var))
+ (let ,(mapcar #'(lambda (var)
+ `(,var (eval-stack-ref
+ (+ ,new-sp-var ,(incf index)))))
+ vars)
+ ,@(nreverse decls)
+ (setf (current-stack-pointer) ,new-sp-var)
+ ,@body))))
+
+(defun stack-copy (dest src count)
+ (declare (type stack-pointer dest src count))
+ (let ((stack *eval-stack*))
+ (if (< dest src)
+ (dotimes (i count)
+ (setf (svref stack dest) (svref stack src))
+ (incf dest)
+ (incf src))
+ (do ((si (1- (+ src count))
+ (1- si))
+ (di (1- (+ dest count))
+ (1- di)))
+ ((< si src))
+ (declare (fixnum si di))
+ (setf (svref stack di) (svref stack si)))))
+ (values))
+\f
+;;;; component access magic
+
+#!-sb-fluid (declaim (inline component-ref))
+(defun component-ref (component pc)
+ (declare (type code-component component)
+ (type pc pc))
+ (sap-ref-8 (code-instructions component) pc))
+
+#!-sb-fluid (declaim (inline (setf component-ref)))
+(defun (setf component-ref) (value component pc)
+ (declare (type (unsigned-byte 8) value)
+ (type code-component component)
+ (type pc pc))
+ (setf (sap-ref-8 (code-instructions component) pc) value))
+
+#!-sb-fluid (declaim (inline component-ref-signed))
+(defun component-ref-signed (component pc)
+ (let ((byte (component-ref component pc)))
+ (if (logbitp 7 byte)
+ (logior (ash -1 8) byte)
+ byte)))
+
+#!-sb-fluid (declaim (inline component-ref-24))
+(defun component-ref-24 (component pc)
+ (logior (ash (component-ref component pc) 16)
+ (ash (component-ref component (1+ pc)) 8)
+ (component-ref component (+ pc 2))))
+\f
+;;;; debugging support
+
+;;; This macro binds three magic variables. When the debugger notices that
+;;; these three variables are bound, it makes a byte-code frame out of the
+;;; supplied information instead of a compiled frame. We set each var in
+;;; addition to binding it so the compiler doens't optimize away the binding.
+(defmacro with-debugger-info ((component pc fp) &body body)
+ `(let ((%byte-interp-component ,component)
+ (%byte-interp-pc ,pc)
+ (%byte-interp-fp ,fp))
+ ;; FIXME: This will cause source code location information to be compiled
+ ;; into the executable, which will probably cause problems for users
+ ;; running without the sources and/or without the build-the-system
+ ;; readtable.
+ (declare (optimize (debug 3)))
+ (setf %byte-interp-component %byte-interp-component)
+ (setf %byte-interp-pc %byte-interp-pc)
+ (setf %byte-interp-fp %byte-interp-fp)
+ ,@body))
+
+(defun byte-install-breakpoint (component pc)
+ (declare (type code-component component)
+ (type pc pc)
+ (values (unsigned-byte 8)))
+ (let ((orig (component-ref component pc)))
+ (setf (component-ref component pc)
+ #.(logior byte-xop
+ (xop-index-or-lose 'breakpoint)))
+ orig))
+
+(defun byte-remove-breakpoint (component pc orig)
+ (declare (type code-component component)
+ (type pc pc)
+ (type (unsigned-byte 8) orig)
+ (values (unsigned-byte 8)))
+ (setf (component-ref component pc) orig))
+
+(defun byte-skip-breakpoint (component pc fp orig)
+ (declare (type code-component component)
+ (type pc pc)
+ (type stack-pointer fp)
+ (type (unsigned-byte 8) orig))
+ (byte-interpret-byte component fp pc orig))
+\f
+;;;; system constants
+
+;;; a table mapping system constant indices to run-time values. We don't
+;;; reference the compiler variable at load time, since the interpreter is
+;;; loaded first.
+(defparameter *system-constants*
+ (let ((res (make-array 256)))
+ (dolist (x '#.(collect ((res))
+ (dohash (key value *system-constant-codes*)
+ (res (cons key value)))
+ (res)))
+ (let ((key (car x))
+ (value (cdr x)))
+ (setf (svref res value)
+ (if (and (consp key) (eq (car key) '%fdefinition-marker%))
+ (sb!impl::fdefinition-object (cdr key) t)
+ key))))
+ res))
+\f
+;;;; byte compiled function constructors/extractors
+
+(defun initialize-byte-compiled-function (xep)
+ (declare (type byte-function xep))
+ (push xep (code-header-ref (byte-function-component xep)
+ sb!vm:code-trace-table-offset-slot))
+ (setf (funcallable-instance-function xep)
+ #'(instance-lambda (&more context count)
+ (let ((old-sp (current-stack-pointer)))
+ (declare (type stack-pointer old-sp))
+ (dotimes (i count)
+ (push-eval-stack (%more-arg context i)))
+ (invoke-xep nil 0 old-sp 0 count xep))))
+ xep)
+
+(defun make-byte-compiled-closure (xep closure-vars)
+ (declare (type byte-function xep)
+ (type simple-vector closure-vars))
+ (let ((res (make-byte-closure xep closure-vars)))
+ (setf (funcallable-instance-function res)
+ #'(instance-lambda (&more context count)
+ (let ((old-sp (current-stack-pointer)))
+ (declare (type stack-pointer old-sp))
+ (dotimes (i count)
+ (push-eval-stack (%more-arg context i)))
+ (invoke-xep nil 0 old-sp 0 count
+ (byte-closure-function res)
+ (byte-closure-data res)))))
+ res))
+\f
+;;;; INLINEs
+
+;;; (The idea here seems to be to make sure it's at least 100,
+;;; in order to be able to compile the 32+ inline functions
+;;; in EXPAND-INTO-INLINES as intended. -- WHN 19991206)
+(eval-when (:compile-toplevel :execute)
+ (setq sb!ext:*inline-expansion-limit* 100))
+
+;;; FIXME: This doesn't seem to be needed in the target Lisp, only
+;;; at build-the-system time.
+;;;
+;;; KLUDGE: This expands into code a la
+;;; (IF (ZEROP (LOGAND BYTE 16))
+;;; (IF (ZEROP (LOGAND BYTE 8))
+;;; (IF (ZEROP (LOGAND BYTE 4))
+;;; (IF (ZEROP (LOGAND BYTE 2))
+;;; (IF (ZEROP (LOGAND BYTE 1))
+;;; (ERROR "Unknown inline function, id=~D" 0)
+;;; (ERROR "Unknown inline function, id=~D" 1))
+;;; (IF (ZEROP (LOGAND BYTE 1))
+;;; (ERROR "Unknown inline function, id=~D" 2)
+;;; (ERROR "Unknown inline function, id=~D" 3)))
+;;; (IF (ZEROP (LOGAND BYTE 2))
+;;; ..) ..) ..)
+;;; That's probably more efficient than doing a function call (even a
+;;; local function call) for every byte interpreted, but I doubt it's
+;;; as fast as doing a jump through a table of sixteen addresses.
+;;; Perhaps it would be good to recode this as a straightforward
+;;; CASE statement and redirect the cleverness previously devoted to
+;;; this code to an optimizer for CASE which is smart enough to
+;;; implement suitable code as jump tables.
+(defmacro expand-into-inlines ()
+ #+nil (declare (optimize (inhibit-warnings 3)))
+ (iterate build-dispatch
+ ((bit 4)
+ (base 0))
+ (if (minusp bit)
+ (let ((info (svref *inline-functions* base)))
+ (if info
+ (let* ((spec (type-specifier
+ (inline-function-info-type info)))
+ (arg-types (second spec))
+ (result-type (third spec))
+ (args (mapcar #'(lambda (x)
+ (declare (ignore x))
+ (gensym))
+ arg-types))
+ (func
+ `(the ,result-type
+ (,(inline-function-info-interpreter-function info)
+ ,@args))))
+ `(multiple-value-pop-eval-stack ,args
+ (declare ,@(mapcar #'(lambda (type var)
+ `(type ,type ,var))
+ arg-types args))
+ ,(if (and (consp result-type)
+ (eq (car result-type) 'values))
+ (let ((results
+ (mapcar #'(lambda (x)
+ (declare (ignore x))
+ (gensym))
+ (cdr result-type))))
+ `(multiple-value-bind ,results ,func
+ ,@(mapcar #'(lambda (res)
+ `(push-eval-stack ,res))
+ results)))
+ `(push-eval-stack ,func))))
+ `(error "unknown inline function, id=~D" ,base)))
+ `(if (zerop (logand byte ,(ash 1 bit)))
+ ,(build-dispatch (1- bit) base)
+ ,(build-dispatch (1- bit) (+ base (ash 1 bit)))))))
+
+#!-sb-fluid (declaim (inline value-cell-setf))
+(defun value-cell-setf (value cell)
+ (value-cell-set cell value)
+ value)
+
+#!-sb-fluid (declaim (inline setf-symbol-value))
+(defun setf-symbol-value (value symbol)
+ (setf (symbol-value symbol) value))
+
+#!-sb-fluid (declaim (inline %setf-instance-ref))
+(defun %setf-instance-ref (new-value instance index)
+ (setf (%instance-ref instance index) new-value))
+
+(eval-when (:compile-toplevel)
+
+(sb!xc:defmacro %byte-symbol-value (x)
+ `(let ((x ,x))
+ (unless (boundp x)
+ (with-debugger-info (component pc fp)
+ (error "unbound variable: ~S" x)))
+ (symbol-value x)))
+
+(sb!xc:defmacro %byte-car (x)
+ `(let ((x ,x))
+ (unless (listp x)
+ (with-debugger-info (component pc fp)
+ (error 'simple-type-error :item x :expected-type 'list
+ :format-control "non-list argument to CAR: ~S"
+ :format-arguments (list x))))
+ (car x)))
+
+(sb!xc:defmacro %byte-cdr (x)
+ `(let ((x ,x))
+ (unless (listp x)
+ (with-debugger-info (component pc fp)
+ (error 'simple-type-error :item x :expected-type 'list
+ :format-control "non-list argument to CDR: ~S"
+ :format-arguments (list x))))
+ (cdr x)))
+
+) ; EVAL-WHEN
+
+#!-sb-fluid (declaim (inline %byte-special-bind))
+(defun %byte-special-bind (value symbol)
+ (sb!sys:%primitive bind value symbol)
+ (values))
+
+#!-sb-fluid (declaim (inline %byte-special-unbind))
+(defun %byte-special-unbind ()
+ (sb!sys:%primitive unbind)
+ (values))
+
+;;; obsolete...
+#!-sb-fluid (declaim (inline cons-unique-tag))
+(defun cons-unique-tag ()
+ (list '#:%unique-tag%))
+;;; FIXME: Delete this once the system is working.
+\f
+;;;; two-arg function stubs
+;;;;
+;;;; We have two-arg versions of some n-ary functions that are normally
+;;;; open-coded.
+
+(defun two-arg-char= (x y) (char= x y))
+(defun two-arg-char< (x y) (char< x y))
+(defun two-arg-char> (x y) (char> x y))
+(defun two-arg-char-equal (x y) (char-equal x y))
+(defun two-arg-char-lessp (x y) (char-lessp x y))
+(defun two-arg-char-greaterp (x y) (char-greaterp x y))
+(defun two-arg-string= (x y) (string= x y))
+(defun two-arg-string< (x y) (string= x y))
+(defun two-arg-string> (x y) (string= x y))
+\f
+;;;; miscellaneous primitive stubs
+
+(macrolet ((frob (name &optional (args '(x)))
+ `(defun ,name ,args (,name ,@args))))
+ (frob %CODE-CODE-SIZE)
+ (frob %CODE-DEBUG-INFO)
+ (frob %CODE-ENTRY-POINTS)
+ (frob %FUNCALLABLE-INSTANCE-FUNCTION)
+ (frob %FUNCALLABLE-INSTANCE-LAYOUT)
+ (frob %FUNCALLABLE-INSTANCE-LEXENV)
+ (frob %FUNCTION-NEXT)
+ (frob %FUNCTION-SELF)
+ (frob %SET-FUNCALLABLE-INSTANCE-FUNCTION (fin new-val)))
+\f
+;;;; funny functions
+
+;;; (used both by the byte interpreter and by the IR1 interpreter)
+(defun %progv (vars vals fun)
+ (progv vars vals
+ (funcall fun)))
+\f
+;;;; XOPs
+
+;;; Extension operations (XOPs) are various magic things that the byte
+;;; interpreter needs to do, but can't be represented as a function call.
+;;; When the byte interpreter encounters an XOP in the byte stream, it
+;;; tail-calls the corresponding XOP routine extracted from *byte-xops*.
+;;; The XOP routine can do whatever it wants, probably re-invoking the
+;;; byte interpreter.
+
+;;; Fetch an 8/24 bit operand out of the code stream.
+(eval-when (:compile-toplevel :execute)
+ (sb!xc:defmacro with-extended-operand ((component pc operand new-pc)
+ &body body)
+ (once-only ((n-component component)
+ (n-pc pc))
+ `(multiple-value-bind (,operand ,new-pc)
+ (let ((,operand (component-ref ,n-component ,n-pc)))
+ (if (= ,operand #xff)
+ (values (component-ref-24 ,n-component (1+ ,n-pc))
+ (+ ,n-pc 4))
+ (values ,operand (1+ ,n-pc))))
+ (declare (type index ,operand ,new-pc))
+ ,@body))))
+
+;;; If a real XOP hasn't been defined, this gets invoked and signals an
+;;; error. This shouldn't happen in normal operation.
+(defun undefined-xop (component old-pc pc fp)
+ (declare (ignore component old-pc pc fp))
+ (error "undefined XOP"))
+
+;;; a simple vector of the XOP functions
+(declaim (type (simple-vector 256) *byte-xops*))
+(defvar *byte-xops*
+ (make-array 256 :initial-element #'undefined-xop))
+
+;;; Define a XOP function and install it in *BYTE-XOPS*.
+(eval-when (:compile-toplevel :execute)
+ (sb!xc:defmacro define-xop (name lambda-list &body body)
+ (let ((defun-name (symbolicate "BYTE-" name "-XOP")))
+ `(progn
+ (defun ,defun-name ,lambda-list
+ ,@body)
+ (setf (aref *byte-xops* ,(xop-index-or-lose name)) #',defun-name)
+ ',defun-name))))
+
+;;; This is spliced in by the debugger in order to implement breakpoints.
+(define-xop breakpoint (component old-pc pc fp)
+ (declare (type code-component component)
+ (type pc old-pc)
+ (ignore pc)
+ (type stack-pointer fp))
+ ;; Invoke the debugger.
+ (with-debugger-info (component old-pc fp)
+ (sb!di::handle-breakpoint component old-pc fp))
+ ;; Retry the breakpoint XOP in case it was replaced with the original
+ ;; displaced byte-code.
+ (byte-interpret component old-pc fp))
+
+;;; This just duplicates whatever is on the top of the stack.
+(define-xop dup (component old-pc pc fp)
+ (declare (type code-component component)
+ (ignore old-pc)
+ (type pc pc)
+ (type stack-pointer fp))
+ (let ((value (eval-stack-ref (1- (current-stack-pointer)))))
+ (push-eval-stack value))
+ (byte-interpret component pc fp))
+
+(define-xop make-closure (component old-pc pc fp)
+ (declare (type code-component component)
+ (ignore old-pc)
+ (type pc pc)
+ (type stack-pointer fp))
+ (let* ((num-closure-vars (pop-eval-stack))
+ (closure-vars (make-array num-closure-vars)))
+ (declare (type index num-closure-vars)
+ (type simple-vector closure-vars))
+ (iterate frob ((index (1- num-closure-vars)))
+ (unless (minusp index)
+ (setf (svref closure-vars index) (pop-eval-stack))
+ (frob (1- index))))
+ (push-eval-stack (make-byte-compiled-closure (pop-eval-stack)
+ closure-vars)))
+ (byte-interpret component pc fp))
+
+(define-xop merge-unknown-values (component old-pc pc fp)
+ (declare (type code-component component)
+ (ignore old-pc)
+ (type pc pc)
+ (type stack-pointer fp))
+ (labels ((grovel (remaining-blocks block-count-ptr)
+ (declare (type index remaining-blocks)
+ (type stack-pointer block-count-ptr))
+ (declare (values index stack-pointer))
+ (let ((block-count (eval-stack-ref block-count-ptr)))
+ (declare (type index block-count))
+ (if (= remaining-blocks 1)
+ (values block-count block-count-ptr)
+ (let ((src (- block-count-ptr block-count)))
+ (declare (type index src))
+ (multiple-value-bind (values-above dst)
+ (grovel (1- remaining-blocks) (1- src))
+ (stack-copy dst src block-count)
+ (values (+ values-above block-count)
+ (+ dst block-count))))))))
+ (multiple-value-bind (total-count end-ptr)
+ (grovel (pop-eval-stack) (1- (current-stack-pointer)))
+ (setf (eval-stack-ref end-ptr) total-count)
+ (setf (current-stack-pointer) (1+ end-ptr))))
+ (byte-interpret component pc fp))
+
+(define-xop default-unknown-values (component old-pc pc fp)
+ (declare (type code-component component)
+ (ignore old-pc)
+ (type pc pc)
+ (type stack-pointer fp))
+ (let* ((desired (pop-eval-stack))
+ (supplied (pop-eval-stack))
+ (delta (- desired supplied)))
+ (declare (type index desired supplied)
+ (type fixnum delta))
+ (cond ((minusp delta)
+ (incf (current-stack-pointer) delta))
+ ((plusp delta)
+ (dotimes (i delta)
+ (push-eval-stack nil)))))
+ (byte-interpret component pc fp))
+
+;;; %THROW is compiled down into this xop. The stack contains the tag, the
+;;; values, and then a count of the values. We special case various small
+;;; numbers of values to keep from consing if we can help it.
+;;;
+;;; Basically, we just extract the values and the tag and then do a throw.
+;;; The native compiler will convert this throw into whatever is necessary
+;;; to throw, so we don't have to duplicate all that cruft.
+(define-xop throw (component old-pc pc fp)
+ (declare (type code-component component)
+ (type pc old-pc)
+ (ignore pc)
+ (type stack-pointer fp))
+ (let ((num-results (pop-eval-stack)))
+ (declare (type index num-results))
+ (case num-results
+ (0
+ (let ((tag (pop-eval-stack)))
+ (with-debugger-info (component old-pc fp)
+ (throw tag (values)))))
+ (1
+ (multiple-value-pop-eval-stack
+ (tag result)
+ (with-debugger-info (component old-pc fp)
+ (throw tag result))))
+ (2
+ (multiple-value-pop-eval-stack
+ (tag result0 result1)
+ (with-debugger-info (component old-pc fp)
+ (throw tag (values result0 result1)))))
+ (t
+ (let ((results nil))
+ (dotimes (i num-results)
+ (push (pop-eval-stack) results))
+ (let ((tag (pop-eval-stack)))
+ (with-debugger-info (component old-pc fp)
+ (throw tag (values-list results)))))))))
+
+;;; This is used for both CATCHes and BLOCKs that are closed over. We
+;;; establish a catcher for the supplied tag (from the stack top), and
+;;; recursivly enter the byte interpreter. If the byte interpreter exits,
+;;; it must have been because of a BREAKUP (see below), so we branch (by
+;;; tail-calling the byte interpreter) to the pc returned by BREAKUP.
+;;; If we are thrown to, then we branch to the address encoded in the 3 bytes
+;;; following the catch XOP.
+(define-xop catch (component old-pc pc fp)
+ (declare (type code-component component)
+ (ignore old-pc)
+ (type pc pc)
+ (type stack-pointer fp))
+ (let ((new-pc (block nil
+ (let ((results
+ (multiple-value-list
+ (catch (pop-eval-stack)
+ (return (byte-interpret component (+ pc 3) fp))))))
+ (let ((num-results 0))
+ (declare (type index num-results))
+ (dolist (result results)
+ (push-eval-stack result)
+ (incf num-results))
+ (push-eval-stack num-results))
+ (component-ref-24 component pc)))))
+ (byte-interpret component new-pc fp)))
+
+;;; Blow out of the dynamically nested CATCH or TAGBODY. We just return the
+;;; pc following the BREAKUP XOP and the drop-through code in CATCH or
+;;; TAGBODY will do the correct thing.
+(define-xop breakup (component old-pc pc fp)
+ (declare (ignore component old-pc fp)
+ (type pc pc))
+ pc)
+
+;;; This is exactly like THROW, except that the tag is the last thing on
+;;; the stack instead of the first. This is used for RETURN-FROM (hence the
+;;; name).
+(define-xop return-from (component old-pc pc fp)
+ (declare (type code-component component)
+ (type pc old-pc)
+ (ignore pc)
+ (type stack-pointer fp))
+ (let ((tag (pop-eval-stack))
+ (num-results (pop-eval-stack)))
+ (declare (type index num-results))
+ (case num-results
+ (0
+ (with-debugger-info (component old-pc fp)
+ (throw tag (values))))
+ (1
+ (let ((value (pop-eval-stack)))
+ (with-debugger-info (component old-pc fp)
+ (throw tag value))))
+ (2
+ (multiple-value-pop-eval-stack
+ (result0 result1)
+ (with-debugger-info (component old-pc fp)
+ (throw tag (values result0 result1)))))
+ (t
+ (let ((results nil))
+ (dotimes (i num-results)
+ (push (pop-eval-stack) results))
+ (with-debugger-info (component old-pc fp)
+ (throw tag (values-list results))))))))
+
+;;; Similar to CATCH, except for TAGBODY. One significant difference is that
+;;; when thrown to, we don't want to leave the dynamic extent of the tagbody
+;;; so we loop around and re-enter the catcher. We keep looping until BREAKUP
+;;; is used to blow out. When that happens, we just branch to the pc supplied
+;;; by BREAKUP.
+(define-xop tagbody (component old-pc pc fp)
+ (declare (type code-component component)
+ (ignore old-pc)
+ (type pc pc)
+ (type stack-pointer fp))
+ (let* ((tag (pop-eval-stack))
+ (new-pc (block nil
+ (loop
+ (setf pc
+ (catch tag
+ (return (byte-interpret component pc fp))))))))
+ (byte-interpret component new-pc fp)))
+
+;;; Yup, you guessed it. This XOP implements GO. There are no values to
+;;; pass, so we don't have to mess with them, and multiple exits can all be
+;;; using the same tag so we have to pass the pc we want to go to.
+(define-xop go (component old-pc pc fp)
+ (declare (type code-component component)
+ (type pc old-pc pc)
+ (type stack-pointer fp))
+ (let ((tag (pop-eval-stack))
+ (new-pc (component-ref-24 component pc)))
+ (with-debugger-info (component old-pc fp)
+ (throw tag new-pc))))
+
+;;; UNWIND-PROTECTs are handled significantly different in the byte
+;;; compiler and the native compiler. Basically, we just use the
+;;; native compiler's UNWIND-PROTECT, and let it worry about
+;;; continuing the unwind.
+(define-xop unwind-protect (component old-pc pc fp)
+ (declare (type code-component component)
+ (ignore old-pc)
+ (type pc pc)
+ (type stack-pointer fp))
+ (let ((new-pc nil))
+ (unwind-protect
+ (setf new-pc (byte-interpret component (+ pc 3) fp))
+ (unless new-pc
+ ;; The cleanup function expects 3 values to be one the stack, so
+ ;; we have to put something there.
+ (push-eval-stack nil)
+ (push-eval-stack nil)
+ (push-eval-stack nil)
+ ;; Now run the cleanup code.
+ (byte-interpret component (component-ref-24 component pc) fp)))
+ (byte-interpret component new-pc fp)))
+
+(define-xop fdefn-function-or-lose (component old-pc pc fp)
+ (let* ((fdefn (pop-eval-stack))
+ (fun (fdefn-function fdefn)))
+ (declare (type fdefn fdefn))
+ (cond (fun
+ (push-eval-stack fun)
+ (byte-interpret component pc fp))
+ (t
+ (with-debugger-info (component old-pc fp)
+ (error 'undefined-function :name (fdefn-name fdefn)))))))
+
+;;; This is used to insert placeholder arguments for unused arguments
+;;; to local calls.
+(define-xop push-n-under (component old-pc pc fp)
+ (declare (ignore old-pc))
+ (with-extended-operand (component pc howmany new-pc)
+ (let ((val (pop-eval-stack)))
+ (allocate-eval-stack howmany)
+ (push-eval-stack val))
+ (byte-interpret component new-pc fp)))
+\f
+;;;; type checking
+
+;;; These two hashtables map between type specifiers and type
+;;; predicate functions that test those types. They are initialized
+;;; according to the standard type predicates of the target system.
+(defvar *byte-type-predicates* (make-hash-table :test 'equal))
+(defvar *byte-predicate-types* (make-hash-table :test 'eq))
+
+(loop for (type predicate) in
+ '#.(loop for (type . predicate) in
+ *backend-type-predicates*
+ collect `(,(type-specifier type) ,predicate))
+ do
+ (let ((fun (fdefinition predicate)))
+ (setf (gethash type *byte-type-predicates*) fun)
+ (setf (gethash fun *byte-predicate-types*) type)))
+
+;;; This is called by the loader to convert a type specifier into a
+;;; type predicate (as used by the TYPE-CHECK XOP.) If it is a
+;;; structure type with a predicate or has a predefined predicate,
+;;; then return the predicate function, otherwise return the CTYPE
+;;; structure for the type.
+(defun load-type-predicate (desc)
+ (or (gethash desc *byte-type-predicates*)
+ (let ((type (specifier-type desc)))
+ (if (typep type 'structure-class)
+ (let ((info (layout-info (class-layout type))))
+ (if (and info (eq (dd-type info) 'structure))
+ (let ((pred (dd-predicate info)))
+ (if (and pred (fboundp pred))
+ (fdefinition pred)
+ type))
+ type))
+ type))))
+
+;;; Check the type of the value on the top of the stack. The type is
+;;; designated by an entry in the constants. If the value is a
+;;; function, then it is called as a type predicate. Otherwise, the
+;;; value is a CTYPE object, and we call %TYPEP on it.
+(define-xop type-check (component old-pc pc fp)
+ (declare (type code-component component)
+ (type pc old-pc pc)
+ (type stack-pointer fp))
+ (with-extended-operand (component pc operand new-pc)
+ (let ((value (eval-stack-ref (1- (current-stack-pointer))))
+ (type (code-header-ref component
+ (+ operand sb!vm:code-constants-offset))))
+ (unless (if (functionp type)
+ (funcall type value)
+ (%typep value type))
+ (with-debugger-info (component old-pc fp)
+ (error 'type-error
+ :datum value
+ :expected-type (if (functionp type)
+ (gethash type *byte-predicate-types*)
+ (type-specifier type))))))
+
+ (byte-interpret component new-pc fp)))
+\f
+;;;; the byte-interpreter
+
+;;; The various operations are encoded as follows.
+;;;
+;;; 0000xxxx push-local op
+;;; 0001xxxx push-arg op [push-local, but negative]
+;;; 0010xxxx push-constant op
+;;; 0011xxxx push-system-constant op
+;;; 0100xxxx push-int op
+;;; 0101xxxx push-neg-int op
+;;; 0110xxxx pop-local op
+;;; 0111xxxx pop-n op
+;;; 1000nxxx call op
+;;; 1001nxxx tail-call op
+;;; 1010nxxx multiple-call op
+;;; 10110xxx local-call
+;;; 10111xxx local-tail-call
+;;; 11000xxx local-multiple-call
+;;; 11001xxx return
+;;; 1101000r branch
+;;; 1101001r if-true
+;;; 1101010r if-false
+;;; 1101011r if-eq
+;;; 11011xxx Xop
+;;; 11100000
+;;; to various inline functions.
+;;; 11111111
+;;;
+;;; This encoding is rather hard wired into BYTE-INTERPRET due to the
+;;; binary dispatch tree.
+
+(defvar *byte-trace* nil)
+
+;;; the main entry point to the byte interpreter
+(defun byte-interpret (component pc fp)
+ (declare (type code-component component)
+ (type pc pc)
+ (type stack-pointer fp))
+ (byte-interpret-byte component pc fp (component-ref component pc)))
+
+;;; This is separated from BYTE-INTERPRET in order to let us continue
+;;; from a breakpoint without having to replace the breakpoint with
+;;; the original instruction and arrange to somehow put the breakpoint
+;;; back after executing the instruction. We just leave the breakpoint
+;;; there, and call this function with the byte that the breakpoint
+;;; displaced.
+(defun byte-interpret-byte (component pc fp byte)
+ (declare (type code-component component)
+ (type pc pc)
+ (type stack-pointer fp)
+ (type (unsigned-byte 8) byte))
+ (locally
+ #+nil (declare (optimize (inhibit-warnings 3)))
+ (when *byte-trace*
+ (let ((*byte-trace* nil))
+ (format *trace-output*
+ "pc=~D, fp=~D, sp=~D, byte=#b~,'0X, frame:~% ~S~%"
+ pc fp (current-stack-pointer) byte
+ (subseq sb!eval::*eval-stack* fp (current-stack-pointer))))))
+ (if (zerop (logand byte #x80))
+ ;; Some stack operation. No matter what, we need the operand,
+ ;; so compute it.
+ (multiple-value-bind (operand new-pc)
+ (let ((operand (logand byte #xf)))
+ (if (= operand #xf)
+ (let ((operand (component-ref component (1+ pc))))
+ (if (= operand #xff)
+ (values (component-ref-24 component (+ pc 2))
+ (+ pc 5))
+ (values operand (+ pc 2))))
+ (values operand (1+ pc))))
+ (if (zerop (logand byte #x40))
+ (push-eval-stack (if (zerop (logand byte #x20))
+ (if (zerop (logand byte #x10))
+ (eval-stack-ref (+ fp operand))
+ (eval-stack-ref (- fp operand 5)))
+ (if (zerop (logand byte #x10))
+ (code-header-ref
+ component
+ (+ operand sb!vm:code-constants-offset))
+ (svref *system-constants* operand))))
+ (if (zerop (logand byte #x20))
+ (push-eval-stack (if (zerop (logand byte #x10))
+ operand
+ (- (1+ operand))))
+ (if (zerop (logand byte #x10))
+ (setf (eval-stack-ref (+ fp operand)) (pop-eval-stack))
+ (if (zerop operand)
+ (let ((operand (pop-eval-stack)))
+ (declare (type index operand))
+ (decf (current-stack-pointer) operand))
+ (decf (current-stack-pointer) operand)))))
+ (byte-interpret component new-pc fp))
+ (if (zerop (logand byte #x40))
+ ;; Some kind of call.
+ (let ((args (let ((args (logand byte #x07)))
+ (if (= args #x07)
+ (pop-eval-stack)
+ args))))
+ (if (zerop (logand byte #x20))
+ (let ((named (not (zerop (logand byte #x08)))))
+ (if (zerop (logand byte #x10))
+ ;; Call for single value.
+ (do-call component pc (1+ pc) fp args named)
+ ;; Tail call.
+ (do-tail-call component pc fp args named)))
+ (if (zerop (logand byte #x10))
+ ;; Call for multiple-values.
+ (do-call component pc (- (1+ pc)) fp args
+ (not (zerop (logand byte #x08))))
+ (if (zerop (logand byte #x08))
+ ;; Local call
+ (do-local-call component pc (+ pc 4) fp args)
+ ;; Local tail-call
+ (do-tail-local-call component pc fp args)))))
+ (if (zerop (logand byte #x20))
+ ;; local-multiple-call, Return, branch, or Xop.
+ (if (zerop (logand byte #x10))
+ ;; local-multiple-call or return.
+ (if (zerop (logand byte #x08))
+ ;; Local-multiple-call.
+ (do-local-call component pc (- (+ pc 4)) fp
+ (let ((args (logand byte #x07)))
+ (if (= args #x07)
+ (pop-eval-stack)
+ args)))
+ ;; Return.
+ (let ((num-results
+ (let ((num-results (logand byte #x7)))
+ (if (= num-results 7)
+ (pop-eval-stack)
+ num-results))))
+ (do-return fp num-results)))
+ ;; Branch or Xop.
+ (if (zerop (logand byte #x08))
+ ;; Branch.
+ (if (if (zerop (logand byte #x04))
+ (if (zerop (logand byte #x02))
+ t
+ (pop-eval-stack))
+ (if (zerop (logand byte #x02))
+ (not (pop-eval-stack))
+ (multiple-value-pop-eval-stack
+ (val1 val2)
+ (eq val1 val2))))
+ ;; Branch taken.
+ (byte-interpret
+ component
+ (if (zerop (logand byte #x01))
+ (component-ref-24 component (1+ pc))
+ (+ pc 2
+ (component-ref-signed component (1+ pc))))
+ fp)
+ ;; Branch not taken.
+ (byte-interpret component
+ (if (zerop (logand byte #x01))
+ (+ pc 4)
+ (+ pc 2))
+ fp))
+ ;; Xop.
+ (multiple-value-bind (sub-code new-pc)
+ (let ((operand (logand byte #x7)))
+ (if (= operand #x7)
+ (values (component-ref component (+ pc 1))
+ (+ pc 2))
+ (values operand (1+ pc))))
+ (funcall (the function (svref *byte-xops* sub-code))
+ component pc new-pc fp))))
+ ;; some miscellaneous inline function
+ (progn
+ (expand-into-inlines)
+ (byte-interpret component (1+ pc) fp))))))
+
+(defun do-local-call (component pc old-pc old-fp num-args)
+ (declare (type pc pc)
+ (type return-pc old-pc)
+ (type stack-pointer old-fp)
+ (type (integer 0 #.call-arguments-limit) num-args))
+ (invoke-local-entry-point component (component-ref-24 component (1+ pc))
+ component old-pc
+ (- (current-stack-pointer) num-args)
+ old-fp))
+
+(defun do-tail-local-call (component pc fp num-args)
+ (declare (type code-component component) (type pc pc)
+ (type stack-pointer fp)
+ (type index num-args))
+ (let ((old-fp (eval-stack-ref (- fp 1)))
+ (old-sp (eval-stack-ref (- fp 2)))
+ (old-pc (eval-stack-ref (- fp 3)))
+ (old-component (eval-stack-ref (- fp 4)))
+ (start-of-args (- (current-stack-pointer) num-args)))
+ (stack-copy old-sp start-of-args num-args)
+ (setf (current-stack-pointer) (+ old-sp num-args))
+ (invoke-local-entry-point component (component-ref-24 component (1+ pc))
+ old-component old-pc old-sp old-fp)))
+
+(defun invoke-local-entry-point (component target old-component old-pc old-sp
+ old-fp &optional closure-vars)
+ (declare (type pc target)
+ (type return-pc old-pc)
+ (type stack-pointer old-sp old-fp)
+ (type (or null simple-vector) closure-vars))
+ (when closure-vars
+ (iterate more ((index (1- (length closure-vars))))
+ (unless (minusp index)
+ (push-eval-stack (svref closure-vars index))
+ (more (1- index)))))
+ (push-eval-stack old-component)
+ (push-eval-stack old-pc)
+ (push-eval-stack old-sp)
+ (push-eval-stack old-fp)
+ (multiple-value-bind (stack-frame-size entry-pc)
+ (let ((byte (component-ref component target)))
+ (if (= byte 255)
+ (values (component-ref-24 component (1+ target)) (+ target 4))
+ (values (* byte 2) (1+ target))))
+ (declare (type pc entry-pc))
+ (let ((fp (current-stack-pointer)))
+ (allocate-eval-stack stack-frame-size)
+ (byte-interpret component entry-pc fp))))
+
+;;; Call a function with some arguments popped off of the interpreter
+;;; stack, and restore the SP to the specifier value.
+(defun byte-apply (function num-args restore-sp)
+ (declare (function function) (type index num-args))
+ (let ((start (- (current-stack-pointer) num-args)))
+ (declare (type stack-pointer start))
+ (macrolet ((frob ()
+ `(case num-args
+ ,@(loop for n below 8
+ collect `(,n (call-1 ,n)))
+ (t
+ (let ((args ())
+ (end (+ start num-args)))
+ (declare (type stack-pointer end))
+ (do ((i (1- end) (1- i)))
+ ((< i start))
+ (declare (fixnum i))
+ (push (eval-stack-ref i) args))
+ (setf (current-stack-pointer) restore-sp)
+ (apply function args)))))
+ (call-1 (n)
+ (collect ((binds)
+ (args))
+ (dotimes (i n)
+ (let ((dum (gensym)))
+ (binds `(,dum (eval-stack-ref (+ start ,i))))
+ (args dum)))
+ `(let ,(binds)
+ (setf (current-stack-pointer) restore-sp)
+ (funcall function ,@(args))))))
+ (frob))))
+
+(defun do-call (old-component call-pc ret-pc old-fp num-args named)
+ (declare (type code-component old-component)
+ (type pc call-pc)
+ (type return-pc ret-pc)
+ (type stack-pointer old-fp)
+ (type (integer 0 #.call-arguments-limit) num-args)
+ (type (member t nil) named))
+ (let* ((old-sp (- (current-stack-pointer) num-args 1))
+ (fun-or-fdefn (eval-stack-ref old-sp))
+ (function (if named
+ (or (fdefn-function fun-or-fdefn)
+ (with-debugger-info (old-component call-pc old-fp)
+ (error 'undefined-function
+ :name (fdefn-name fun-or-fdefn))))
+ fun-or-fdefn)))
+ (declare (type stack-pointer old-sp)
+ (type (or function fdefn) fun-or-fdefn)
+ (type function function))
+ (typecase function
+ (byte-function
+ (invoke-xep old-component ret-pc old-sp old-fp num-args function))
+ (byte-closure
+ (invoke-xep old-component ret-pc old-sp old-fp num-args
+ (byte-closure-function function)
+ (byte-closure-data function)))
+ (t
+ (cond ((minusp ret-pc)
+ (let* ((ret-pc (- ret-pc))
+ (results
+ (multiple-value-list
+ (with-debugger-info
+ (old-component ret-pc old-fp)
+ (byte-apply function num-args old-sp)))))
+ (dolist (result results)
+ (push-eval-stack result))
+ (push-eval-stack (length results))
+ (byte-interpret old-component ret-pc old-fp)))
+ (t
+ (push-eval-stack
+ (with-debugger-info
+ (old-component ret-pc old-fp)
+ (byte-apply function num-args old-sp)))
+ (byte-interpret old-component ret-pc old-fp)))))))
+
+(defun do-tail-call (component pc fp num-args named)
+ (declare (type code-component component)
+ (type pc pc)
+ (type stack-pointer fp)
+ (type (integer 0 #.call-arguments-limit) num-args)
+ (type (member t nil) named))
+ (let* ((start-of-args (- (current-stack-pointer) num-args))
+ (fun-or-fdefn (eval-stack-ref (1- start-of-args)))
+ (function (if named
+ (or (fdefn-function fun-or-fdefn)
+ (with-debugger-info (component pc fp)
+ (error 'undefined-function
+ :name (fdefn-name fun-or-fdefn))))
+ fun-or-fdefn))
+ (old-fp (eval-stack-ref (- fp 1)))
+ (old-sp (eval-stack-ref (- fp 2)))
+ (old-pc (eval-stack-ref (- fp 3)))
+ (old-component (eval-stack-ref (- fp 4))))
+ (declare (type stack-pointer old-fp old-sp start-of-args)
+ (type return-pc old-pc)
+ (type (or fdefn function) fun-or-fdefn)
+ (type function function))
+ (typecase function
+ (byte-function
+ (stack-copy old-sp start-of-args num-args)
+ (setf (current-stack-pointer) (+ old-sp num-args))
+ (invoke-xep old-component old-pc old-sp old-fp num-args function))
+ (byte-closure
+ (stack-copy old-sp start-of-args num-args)
+ (setf (current-stack-pointer) (+ old-sp num-args))
+ (invoke-xep old-component old-pc old-sp old-fp num-args
+ (byte-closure-function function)
+ (byte-closure-data function)))
+ (t
+ ;; We are tail-calling native code.
+ (cond ((null old-component)
+ ;; We were called by native code.
+ (byte-apply function num-args old-sp))
+ ((minusp old-pc)
+ ;; We were called for multiple values. So return multiple
+ ;; values.
+ (let* ((old-pc (- old-pc))
+ (results
+ (multiple-value-list
+ (with-debugger-info
+ (old-component old-pc old-fp)
+ (byte-apply function num-args old-sp)))))
+ (dolist (result results)
+ (push-eval-stack result))
+ (push-eval-stack (length results))
+ (byte-interpret old-component old-pc old-fp)))
+ (t
+ ;; We were called for one value. So return one value.
+ (push-eval-stack
+ (with-debugger-info
+ (old-component old-pc old-fp)
+ (byte-apply function num-args old-sp)))
+ (byte-interpret old-component old-pc old-fp)))))))
+
+(defvar *byte-trace-calls* nil)
+
+(defun invoke-xep (old-component ret-pc old-sp old-fp num-args xep
+ &optional closure-vars)
+ (declare (type (or null code-component) old-component)
+ (type index num-args)
+ (type return-pc ret-pc)
+ (type stack-pointer old-sp old-fp)
+ (type byte-function xep)
+ (type (or null simple-vector) closure-vars))
+ ;; FIXME: Perhaps BYTE-TRACE-CALLS stuff should be conditional on SB-SHOW.
+ (when *byte-trace-calls*
+ (let ((*byte-trace-calls* nil)
+ (*byte-trace* nil)
+ (*print-level* sb!debug:*debug-print-level*)
+ (*print-length* sb!debug:*debug-print-length*)
+ (sp (current-stack-pointer)))
+ (format *trace-output*
+ "~&INVOKE-XEP: ocode= ~S[~D]~% ~
+ osp= ~D, ofp= ~D, nargs= ~D, SP= ~D:~% ~
+ Fun= ~S ~@[~S~]~% Args= ~S~%"
+ old-component ret-pc old-sp old-fp num-args sp
+ xep closure-vars (subseq *eval-stack* (- sp num-args) sp))
+ (force-output *trace-output*)))
+
+ (let ((entry-point
+ (cond
+ ((typep xep 'simple-byte-function)
+ (unless (eql (simple-byte-function-num-args xep) num-args)
+ (with-debugger-info (old-component ret-pc old-fp)
+ (error "wrong number of arguments")))
+ (simple-byte-function-entry-point xep))
+ (t
+ (let ((min (hairy-byte-function-min-args xep))
+ (max (hairy-byte-function-max-args xep)))
+ (cond
+ ((< num-args min)
+ (with-debugger-info (old-component ret-pc old-fp)
+ (error "not enough arguments")))
+ ((<= num-args max)
+ (nth (- num-args min) (hairy-byte-function-entry-points xep)))
+ ((null (hairy-byte-function-more-args-entry-point xep))
+ (with-debugger-info (old-component ret-pc old-fp)
+ (error "too many arguments")))
+ (t
+ (let* ((more-args-supplied (- num-args max))
+ (sp (current-stack-pointer))
+ (more-args-start (- sp more-args-supplied))
+ (restp (hairy-byte-function-rest-arg-p xep))
+ (rest (and restp
+ (do ((index (1- sp) (1- index))
+ (result nil
+ (cons (eval-stack-ref index)
+ result)))
+ ((< index more-args-start) result)
+ (declare (fixnum index))))))
+ (declare (type index more-args-supplied)
+ (type stack-pointer more-args-start))
+ (cond
+ ((not (hairy-byte-function-keywords-p xep))
+ (assert restp)
+ (setf (current-stack-pointer) (1+ more-args-start))
+ (setf (eval-stack-ref more-args-start) rest))
+ (t
+ (unless (evenp more-args-supplied)
+ (with-debugger-info (old-component ret-pc old-fp)
+ (error "odd number of keyword arguments")))
+ ;; If there are keyword args, then we need to leave the
+ ;; defaulted and supplied-p values where the more args
+ ;; currently are. There might be more or fewer. And also,
+ ;; we need to flatten the parsed args with the defaults
+ ;; before we scan the keywords. So we copy all the more
+ ;; args to a temporary area at the end of the stack.
+ (let* ((num-more-args
+ (hairy-byte-function-num-more-args xep))
+ (new-sp (+ more-args-start num-more-args))
+ (temp (max sp new-sp))
+ (temp-sp (+ temp more-args-supplied))
+ (keywords (hairy-byte-function-keywords xep)))
+ (declare (type index temp)
+ (type stack-pointer new-sp temp-sp))
+ (allocate-eval-stack (- temp-sp sp))
+ (stack-copy temp more-args-start more-args-supplied)
+ (when restp
+ (setf (eval-stack-ref more-args-start) rest)
+ (incf more-args-start))
+ (let ((index more-args-start))
+ (dolist (keyword keywords)
+ (setf (eval-stack-ref index) (cadr keyword))
+ (incf index)
+ (when (caddr keyword)
+ (setf (eval-stack-ref index) nil)
+ (incf index))))
+ (let ((index temp-sp)
+ (allow (eq (hairy-byte-function-keywords-p xep)
+ :allow-others))
+ (bogus-key nil)
+ (bogus-key-p nil))
+ (declare (type fixnum index))
+ (loop
+ (decf index 2)
+ (when (< index temp)
+ (return))
+ (let ((key (eval-stack-ref index))
+ (value (eval-stack-ref (1+ index))))
+ (if (eq key :allow-other-keys)
+ (setf allow value)
+ (let ((target more-args-start))
+ (declare (type stack-pointer target))
+ (dolist (keyword keywords
+ (setf bogus-key key
+ bogus-key-p t))
+ (cond ((eq (car keyword) key)
+ (setf (eval-stack-ref target) value)
+ (when (caddr keyword)
+ (setf (eval-stack-ref (1+ target))
+ t))
+ (return))
+ ((caddr keyword)
+ (incf target 2))
+ (t
+ (incf target))))))))
+ (when (and bogus-key-p (not allow))
+ (with-debugger-info (old-component ret-pc old-fp)
+ (error "unknown keyword: ~S" bogus-key))))
+ (setf (current-stack-pointer) new-sp)))))
+ (hairy-byte-function-more-args-entry-point xep))))))))
+ (declare (type pc entry-point))
+ (invoke-local-entry-point (byte-function-component xep) entry-point
+ old-component ret-pc old-sp old-fp
+ closure-vars)))
+
+(defun do-return (fp num-results)
+ (declare (type stack-pointer fp) (type index num-results))
+ (let ((old-component (eval-stack-ref (- fp 4))))
+ (typecase old-component
+ (code-component
+ ;; returning to more byte-interpreted code
+ (do-local-return old-component fp num-results))
+ (null
+ ;; returning to native code
+ (let ((old-sp (eval-stack-ref (- fp 2))))
+ (case num-results
+ (0
+ (setf (current-stack-pointer) old-sp)
+ (values))
+ (1
+ (let ((result (pop-eval-stack)))
+ (setf (current-stack-pointer) old-sp)
+ result))
+ (t
+ (let ((results nil))
+ (dotimes (i num-results)
+ (push (pop-eval-stack) results))
+ (setf (current-stack-pointer) old-sp)
+ (values-list results))))))
+ (t
+ ;; ### function end breakpoint?
+ (error "Function-end breakpoints are not supported.")))))
+
+(defun do-local-return (old-component fp num-results)
+ (declare (type stack-pointer fp) (type index num-results))
+ (let ((old-fp (eval-stack-ref (- fp 1)))
+ (old-sp (eval-stack-ref (- fp 2)))
+ (old-pc (eval-stack-ref (- fp 3))))
+ (declare (type (signed-byte 25) old-pc))
+ (if (plusp old-pc)
+ ;; wants single value
+ (let ((result (if (zerop num-results)
+ nil
+ (eval-stack-ref (- (current-stack-pointer)
+ num-results)))))
+ (setf (current-stack-pointer) old-sp)
+ (push-eval-stack result)
+ (byte-interpret old-component old-pc old-fp))
+ ;; wants multiple values
+ (progn
+ (stack-copy old-sp (- (current-stack-pointer) num-results)
+ num-results)
+ (setf (current-stack-pointer) (+ old-sp num-results))
+ (push-eval-stack num-results)
+ (byte-interpret old-component (- old-pc) old-fp)))))
+
--- /dev/null
+;;;; types which are needed to implement byte-compiled functions
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!C")
+
+(file-comment
+ "$Header$")
+\f
+;;;; types
+
+(deftype stack-pointer ()
+ `(integer 0 ,(1- most-positive-fixnum)))
+
+;;; KLUDGE: bare numbers, no documentation, ick.. -- WHN 19990701
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defconstant max-pc (1- (ash 1 24))))
+
+(deftype pc ()
+ `(integer 0 ,max-pc))
+
+(deftype return-pc ()
+ `(integer ,(- max-pc) ,max-pc))
+\f
+;;;; byte functions
+
+;;; This abstract class represents any type of byte-compiled function.
+(defstruct (byte-function-or-closure
+ (:alternate-metaclass funcallable-instance
+ funcallable-structure-class
+ make-funcallable-structure-class)
+ (:type funcallable-structure)
+ (:constructor nil)
+ (:copier nil)))
+
+;;; a byte-compiled closure
+(defstruct (byte-closure
+ (:include byte-function-or-closure)
+ (:constructor make-byte-closure (function data))
+ (:type funcallable-structure)
+ (:print-object
+ (lambda (x stream)
+ (print-unreadable-object (x stream :type t :identity t)
+ (prin1 (byte-function-name (byte-closure-function x))
+ stream)))))
+ ;; the byte function that we call
+ (function (required-argument) :type byte-function)
+ ;; the closure data vector
+ (data (required-argument) :type simple-vector))
+
+;;; any non-closure byte function (including the hidden function
+;;; object for a closure)
+(defstruct (byte-function (:include byte-function-or-closure)
+ (:type funcallable-structure)
+ (:constructor nil))
+ ;; The component that this XEP is an entry point into. NIL until
+ ;; LOAD or MAKE-CORE-BYTE-COMPONENT fills it in. They count on this
+ ;; being the first slot.
+ (component nil :type (or null code-component))
+ ;; Debug name of this function.
+ (name nil))
+(def!method print-object ((x byte-function) stream)
+ ;; FIXME: I think functions should probably print either as
+ ;; #<FUNCTION ..> or as #<COMPILED-FUNCTION ..>, since those are
+ ;; their user-visible types. (And this should be true for
+ ;; BYTE-CLOSURE objects too.)
+ (print-unreadable-object (x stream :identity t)
+ (format stream "byte function ~S" (byte-function-name x))))
+
+;;; fixed-argument byte function
+(defstruct (simple-byte-function (:include byte-function)
+ (:type funcallable-structure))
+ ;; The number of arguments expected.
+ (num-args 0 :type (integer 0 #.call-arguments-limit))
+ ;; The start of the function.
+ (entry-point 0 :type index))
+
+;;; variable-arg-count byte function
+(defstruct (hairy-byte-function (:include byte-function)
+ (:type funcallable-structure))
+ ;; The minimum and maximum number of args, ignoring &REST and &KEY.
+ (min-args 0 :type (integer 0 #.call-arguments-limit))
+ (max-args 0 :type (integer 0 #.call-arguments-limit))
+ ;; List of the entry points for min-args, min-args+1, ... max-args.
+ (entry-points nil :type list)
+ ;; The entry point to use when there are more than max-args. Only
+ ;; filled in where okay. In other words, only when &REST or &KEY is
+ ;; specified.
+ (more-args-entry-point nil :type (or null (unsigned-byte 24)))
+ ;; The number of ``more-arg'' args.
+ (num-more-args 0 :type (integer 0 #.call-arguments-limit))
+ ;; True if there is a rest-arg.
+ (rest-arg-p nil :type (member t nil))
+ ;; True if there are keywords. Note: keywords might still be NIL
+ ;; because having &KEY with no keywords is valid and should result
+ ;; in allow-other-keys processing. If :allow-others, then allow
+ ;; other keys.
+ (keywords-p nil :type (member t nil :allow-others))
+ ;; List of keyword arguments. Each element is a list of:
+ ;; key, default, supplied-p.
+ (keywords nil :type list))
+
+#!-sb-fluid (declaim (freeze-type byte-function-or-closure))
--- /dev/null
+;;;; character functions
+;;;;
+;;;; This file assumes the use of ASCII codes and the specific
+;;;; character formats used in SBCL (and its ancestor, CMU CL). It is
+;;;; optimized for performance rather than for portability and
+;;;; elegance, and may have to be rewritten if the character
+;;;; representation is changed.
+;;;;
+;;;; FIXME: should perhaps be renamed ascii.lisp since it's an
+;;;; unportable ASCII-dependent implementation
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!IMPL")
+
+(file-comment
+ "$Header$")
+
+;;; We compile some trivial character operations via inline expansion.
+#!-sb-fluid
+(declaim (inline standard-char-p graphic-char-p alpha-char-p
+ upper-case-p lower-case-p both-case-p alphanumericp
+ char-int))
+(declaim (maybe-inline digit-char-p digit-weight))
+
+(defconstant char-code-limit 256
+ #!+sb-doc
+ "the upper exclusive bound on values produced by CHAR-CODE")
+
+(deftype char-code ()
+ `(integer 0 (,char-code-limit)))
+
+(macrolet ((frob (char-names-list)
+ (collect ((results))
+ (dolist (code char-names-list)
+ (destructuring-bind (ccode names) code
+ (dolist (name names)
+ (results (cons name (code-char ccode))))))
+ `(defparameter *char-name-alist* ',(results)
+ #!+sb-doc
+ "This is the alist of (character-name . character) for characters with
+ long names. The first name in this list for a given character is used
+ on typeout and is the preferred form for input."))))
+ (frob ((#x00 ("Null" "^@" "Nul"))
+ (#x01 ("^a" "Soh"))
+ (#x02 ("^b" "Stx"))
+ (#x03 ("^c" "Etx"))
+ (#x04 ("^d" "Eot"))
+ (#x05 ("^e" "Enq"))
+ (#x06 ("^f" "Ack"))
+ (#x07 ("Bell" "^g" "Bel"))
+ (#x08 ("Backspace" "^h" "Bs"))
+ (#x09 ("Tab" "^i" "Ht"))
+ (#x0A ("Newline" "Linefeed" "^j" "Lf" "Nl" ))
+ (#x0B ("Vt" "^k"))
+ (#x0C ("Page" "^l" "Form" "Formfeed" "Ff" "Np"))
+ (#x0D ("Return" "^m" "Cr"))
+ (#x0E ("^n" "So"))
+ (#x0F ("^o" "Si"))
+ (#x10 ("^p" "Dle"))
+ (#x11 ("^q" "Dc1"))
+ (#x12 ("^r" "Dc2"))
+ (#x13 ("^s" "Dc3"))
+ (#x14 ("^t" "Dc4"))
+ (#x15 ("^u" "Nak"))
+ (#x16 ("^v" "Syn"))
+ (#x17 ("^w" "Etb"))
+ (#x18 ("^x" "Can"))
+ (#x19 ("^y" "Em"))
+ (#x1A ("^z" "Sub"))
+ (#x1B ("Escape" "^[" "Altmode" "Esc" "Alt"))
+ (#x1C ("^\\" "Fs"))
+ (#x1D ("^]" "Gs"))
+ (#x1E ("^^" "Rs"))
+ (#x1F ("^_" "Us"))
+ (#x20 ("Space" "Sp"))
+ (#x7f ("Rubout" "Delete" "Del")))))
+\f
+;;;; accessor functions
+
+(defun char-code (char)
+ #!+sb-doc
+ "Returns the integer code of CHAR."
+ (etypecase char
+ (base-char (char-code (truly-the base-char char)))))
+
+(defun char-int (char)
+ #!+sb-doc
+ "Returns the integer code of CHAR. This is the same as char-code, as
+ CMU Common Lisp does not implement character bits or fonts."
+ (char-code char))
+
+(defun code-char (code)
+ #!+sb-doc
+ "Returns the character with the code CODE."
+ (declare (type char-code code))
+ (code-char code))
+
+(defun character (object)
+ #!+sb-doc
+ "Coerces its argument into a character object if possible. Accepts
+ characters, strings and symbols of length 1."
+ (flet ((do-error (control args)
+ (error 'simple-type-error
+ :datum object
+ ;;?? how to express "symbol with name of length 1"?
+ :expected-type '(or character (string 1))
+ :format-control control
+ :format-arguments args)))
+ (typecase object
+ (character object)
+ (string (if (= 1 (length (the string object)))
+ (char object 0)
+ (do-error
+ "String is not of length one: ~S" (list object))))
+ (symbol (if (= 1 (length (symbol-name object)))
+ (schar (symbol-name object) 0)
+ (do-error
+ "Symbol name is not of length one: ~S" (list object))))
+ (t (do-error "~S cannot be coerced to a character." (list object))))))
+
+(defun char-name (char)
+ #!+sb-doc
+ "Given a character object, char-name returns the name for that
+ object (a symbol)."
+ (car (rassoc char *char-name-alist*)))
+
+(defun name-char (name)
+ #!+sb-doc
+ "Given an argument acceptable to string, name-char returns a character
+ object whose name is that symbol, if one exists. Otherwise, () is returned."
+ (cdr (assoc (string name) *char-name-alist* :test #'string-equal)))
+\f
+;;;; predicates
+
+(defun standard-char-p (char)
+ #!+sb-doc
+ "The argument must be a character object. Standard-char-p returns T if the
+ argument is a standard character -- one of the 95 ASCII printing characters
+ or <return>."
+ (declare (character char))
+ (and (typep char 'base-char)
+ (let ((n (char-code (the base-char char))))
+ (or (< 31 n 127)
+ (= n 10)))))
+
+(defun %standard-char-p (thing)
+ #!+sb-doc
+ "Return T if and only if THING is a standard-char. Differs from
+ standard-char-p in that THING doesn't have to be a character."
+ (and (characterp thing) (standard-char-p thing)))
+
+(defun graphic-char-p (char)
+ #!+sb-doc
+ "The argument must be a character object. Graphic-char-p returns T if the
+ argument is a printing character (space through ~ in ASCII), otherwise
+ returns ()."
+ (declare (character char))
+ (and (typep char 'base-char)
+ (< 31
+ (char-code (the base-char char))
+ 127)))
+
+(defun alpha-char-p (char)
+ #!+sb-doc
+ "The argument must be a character object. Alpha-char-p returns T if the
+ argument is an alphabetic character, A-Z or a-z; otherwise ()."
+ (declare (character char))
+ (let ((m (char-code char)))
+ (or (< 64 m 91) (< 96 m 123))))
+
+(defun upper-case-p (char)
+ #!+sb-doc
+ "The argument must be a character object; upper-case-p returns T if the
+ argument is an upper-case character, () otherwise."
+ (declare (character char))
+ (< 64
+ (char-code char)
+ 91))
+
+(defun lower-case-p (char)
+ #!+sb-doc
+ "The argument must be a character object; lower-case-p returns T if the
+ argument is a lower-case character, () otherwise."
+ (declare (character char))
+ (< 96
+ (char-code char)
+ 123))
+
+(defun both-case-p (char)
+ #!+sb-doc
+ "The argument must be a character object. Both-case-p returns T if the
+ argument is an alphabetic character and if the character exists in
+ both upper and lower case. For ASCII, this is the same as Alpha-char-p."
+ (declare (character char))
+ (let ((m (char-code char)))
+ (or (< 64 m 91) (< 96 m 123))))
+
+(defun digit-char-p (char &optional (radix 10.))
+ #!+sb-doc
+ "If char is a digit in the specified radix, returns the fixnum for
+ which that digit stands, else returns NIL. Radix defaults to 10
+ (decimal)."
+ (declare (character char) (type (integer 2 36) radix))
+ (let ((m (- (char-code char) 48)))
+ (declare (fixnum m))
+ (cond ((<= radix 10.)
+ ;; Special-case decimal and smaller radices.
+ (if (and (>= m 0) (< m radix)) m nil))
+ ;; Digits 0 - 9 are used as is, since radix is larger.
+ ((and (>= m 0) (< m 10)) m)
+ ;; Check for upper case A - Z.
+ ((and (>= (setq m (- m 7)) 10) (< m radix)) m)
+ ;; Also check lower case a - z.
+ ((and (>= (setq m (- m 32)) 10) (< m radix)) m)
+ ;; Else, fail.
+ (t nil))))
+
+(defun alphanumericp (char)
+ #!+sb-doc
+ "Given a character-object argument, alphanumericp returns T if the
+ argument is either numeric or alphabetic."
+ (declare (character char))
+ (let ((m (char-code char)))
+ (or (< 47 m 58) (< 64 m 91) (< 96 m 123))))
+
+(defun char= (character &rest more-characters)
+ #!+sb-doc
+ "Returns T if all of its arguments are the same character."
+ (do ((clist more-characters (cdr clist)))
+ ((atom clist) T)
+ (unless (eq (car clist) character) (return nil))))
+
+(defun char/= (character &rest more-characters)
+ #!+sb-doc
+ "Returns T if no two of its arguments are the same character."
+ (do* ((head character (car list))
+ (list more-characters (cdr list)))
+ ((atom list) T)
+ (unless (do* ((l list (cdr l))) ;inner loop returns T
+ ((atom l) T) ; iff head /= rest.
+ (if (eq head (car l)) (return nil)))
+ (return nil))))
+
+(defun char< (character &rest more-characters)
+ #!+sb-doc
+ "Returns T if its arguments are in strictly increasing alphabetic order."
+ (do* ((c character (car list))
+ (list more-characters (cdr list)))
+ ((atom list) T)
+ (unless (< (char-int c)
+ (char-int (car list)))
+ (return nil))))
+
+(defun char> (character &rest more-characters)
+ #!+sb-doc
+ "Returns T if its arguments are in strictly decreasing alphabetic order."
+ (do* ((c character (car list))
+ (list more-characters (cdr list)))
+ ((atom list) T)
+ (unless (> (char-int c)
+ (char-int (car list)))
+ (return nil))))
+
+(defun char<= (character &rest more-characters)
+ #!+sb-doc
+ "Returns T if its arguments are in strictly non-decreasing alphabetic order."
+ (do* ((c character (car list))
+ (list more-characters (cdr list)))
+ ((atom list) T)
+ (unless (<= (char-int c)
+ (char-int (car list)))
+ (return nil))))
+
+(defun char>= (character &rest more-characters)
+ #!+sb-doc
+ "Returns T if its arguments are in strictly non-increasing alphabetic order."
+ (do* ((c character (car list))
+ (list more-characters (cdr list)))
+ ((atom list) T)
+ (unless (>= (char-int c)
+ (char-int (car list)))
+ (return nil))))
+
+;;; Equal-Char-Code is used by the following functions as a version of char-int
+;;; which loses font, bits, and case info.
+
+(defmacro equal-char-code (character)
+ `(let ((ch (char-code ,character)))
+ (if (< 96 ch 123) (- ch 32) ch)))
+
+(defun char-equal (character &rest more-characters)
+ #!+sb-doc
+ "Returns T if all of its arguments are the same character.
+ Font, bits, and case are ignored."
+ (do ((clist more-characters (cdr clist)))
+ ((atom clist) T)
+ (unless (= (equal-char-code (car clist))
+ (equal-char-code character))
+ (return nil))))
+
+(defun char-not-equal (character &rest more-characters)
+ #!+sb-doc
+ "Returns T if no two of its arguments are the same character.
+ Font, bits, and case are ignored."
+ (do* ((head character (car list))
+ (list more-characters (cdr list)))
+ ((atom list) T)
+ (unless (do* ((l list (cdr l)))
+ ((atom l) T)
+ (if (= (equal-char-code head)
+ (equal-char-code (car l)))
+ (return nil)))
+ (return nil))))
+
+(defun char-lessp (character &rest more-characters)
+ #!+sb-doc
+ "Returns T if its arguments are in strictly increasing alphabetic order.
+ Font, bits, and case are ignored."
+ (do* ((c character (car list))
+ (list more-characters (cdr list)))
+ ((atom list) T)
+ (unless (< (equal-char-code c)
+ (equal-char-code (car list)))
+ (return nil))))
+
+(defun char-greaterp (character &rest more-characters)
+ #!+sb-doc
+ "Returns T if its arguments are in strictly decreasing alphabetic order.
+ Font, bits, and case are ignored."
+ (do* ((c character (car list))
+ (list more-characters (cdr list)))
+ ((atom list) T)
+ (unless (> (equal-char-code c)
+ (equal-char-code (car list)))
+ (return nil))))
+
+(defun char-not-greaterp (character &rest more-characters)
+ #!+sb-doc
+ "Returns T if its arguments are in strictly non-decreasing alphabetic order.
+ Font, bits, and case are ignored."
+ (do* ((c character (car list))
+ (list more-characters (cdr list)))
+ ((atom list) T)
+ (unless (<= (equal-char-code c)
+ (equal-char-code (car list)))
+ (return nil))))
+
+(defun char-not-lessp (character &rest more-characters)
+ #!+sb-doc
+ "Returns T if its arguments are in strictly non-increasing alphabetic order.
+ Font, bits, and case are ignored."
+ (do* ((c character (car list))
+ (list more-characters (cdr list)))
+ ((atom list) T)
+ (unless (>= (equal-char-code c)
+ (equal-char-code (car list)))
+ (return nil))))
+\f
+;;;; miscellaneous functions
+
+(defun char-upcase (char)
+ #!+sb-doc
+ "Returns CHAR converted to upper-case if that is possible."
+ (declare (character char))
+ (if (lower-case-p char)
+ (code-char (- (char-code char) 32))
+ char))
+
+(defun char-downcase (char)
+ #!+sb-doc
+ "Returns CHAR converted to lower-case if that is possible."
+ (declare (character char))
+ (if (upper-case-p char)
+ (code-char (+ (char-code char) 32))
+ char))
+
+(defun digit-char (weight &optional (radix 10))
+ #!+sb-doc
+ "All arguments must be integers. Returns a character object that
+ represents a digit of the given weight in the specified radix. Returns
+ NIL if no such character exists. The character will have the specified
+ font attributes."
+ (declare (type (integer 2 36) radix) (type unsigned-byte weight))
+ (and (typep weight 'fixnum)
+ (>= weight 0) (< weight radix) (< weight 36)
+ (code-char (if (< weight 10) (+ 48 weight) (+ 55 weight)))))
--- /dev/null
+;;;; We proclaim all the special variables in the COMMON-LISP package
+;;;; here, in one go, just to try to make sure we don't miss any.
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "COMMON-LISP")
+
+(sb!int:file-comment
+ "$Header$")
+
+(sb!xc:proclaim '(special cl:*
+ cl:**
+ cl:***
+ cl:*break-on-signals*
+ cl:*compile-file-pathname*
+ cl:*compile-file-truename*
+ cl:*compile-print*
+ cl:*compile-verbose*
+ cl:*debug-io*
+ cl:*debugger-hook*
+ cl:*default-pathname-defaults*
+ cl:*error-output*
+ cl:*features*
+ cl:*gensym-counter*
+ cl:*load-pathname*
+ cl:*load-print*
+ cl:*load-truename*
+ cl:*load-verbose*
+ cl:*macroexpand-hook*
+ cl:*modules*
+ cl:*package*
+ cl:*print-array*
+ cl:*print-base*
+ cl:*print-case*
+ cl:*print-circle*
+ cl:*print-escape*
+ cl:*print-gensym*
+ cl:*print-length*
+ cl:*print-level*
+ cl:*print-lines*
+ cl:*print-miser-width*
+ cl:*print-pprint-dispatch*
+ cl:*print-pretty*
+ cl:*print-radix*
+ cl:*print-readably*
+ cl:*print-right-margin*
+ cl:*query-io*
+ cl:*random-state*
+ cl:*read-base*
+ cl:*read-default-float-format*
+ cl:*read-eval*
+ cl:*read-suppress*
+ cl:*readtable*
+ cl:*standard-input*
+ cl:*standard-output*
+ cl:*terminal-io*
+ cl:*trace-output*
+ cl:+
+ cl:++
+ cl:+++
+ cl:-
+ cl:/
+ cl://
+ cl:///))
--- /dev/null
+;;;; This file contains structures and functions for the maintenance of
+;;;; basic information about defined types. Different object systems
+;;;; can be supported simultaneously. Some of the functions here are
+;;;; nominally generic, and are overwritten when CLOS is loaded.
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!KERNEL")
+
+(file-comment
+ "$Header$")
+
+(!begin-collecting-cold-init-forms)
+\f
+;;;; the CLASS structure
+
+;;; The CLASS structure is a supertype of all class types. A CLASS is
+;;; also a CTYPE structure as recognized by the type system.
+(def!struct (;; FIXME: Yes, these #+SB-XC/#-SB-XC conditionals are
+ ;; pretty hairy. I'm considering cleaner ways to rewrite
+ ;; the whole build system to avoid these (and other hacks
+ ;; too, e.g. UNCROSS) but I'm not sure yet that I've got
+ ;; it figured out. -- WHN 19990729
+ #-sb-xc sb!xc:class
+ #+sb-xc cl:class
+ (:make-load-form-fun class-make-load-form-fun)
+ (:include ctype
+ (:class-info (type-class-or-lose #-sb-xc 'sb!xc:class
+ #+sb-xc 'cl:class)))
+ (:constructor nil)
+ #-no-ansi-print-object
+ (:print-object
+ (lambda (class stream)
+ (let ((name (sb!xc:class-name class)))
+ (print-unreadable-object (class stream
+ :type t
+ :identity (not name))
+ (format stream
+ ;; FIXME: Make sure that this prints
+ ;; reasonably for anonymous classes.
+ "~:[anonymous~;~:*~S~]~@[ (~(~A~))~]"
+ name
+ (class-state class))))))
+ #-sb-xc-host (:pure nil))
+ ;; the value to be returned by CLASS-NAME. (CMU CL used the raw slot
+ ;; accessor for this slot directly as the definition of
+ ;; CL:CLASS-NAME, but that was slightly wrong, because ANSI says
+ ;; that CL:CLASS-NAME is a generic function.)
+ (%name nil :type symbol)
+ ;; the current layout for this class, or NIL if none assigned yet
+ (layout nil :type (or sb!kernel::layout null))
+ ;; How sure are we that this class won't be redefined?
+ ;; :READ-ONLY = We are committed to not changing the effective
+ ;; slots or superclasses.
+ ;; :SEALED = We can't even add subclasses.
+ ;; NIL = Anything could happen.
+ (state nil :type (member nil :read-only :sealed))
+ ;; direct superclasses of this class
+ (direct-superclasses () :type list)
+ ;; representation of all of the subclasses (direct or indirect) of
+ ;; this class. This is NIL if no subclasses or not initalized yet;
+ ;; otherwise, it's an EQ hash-table mapping CL:CLASS objects to the
+ ;; subclass layout that was in effect at the time the subclass was
+ ;; created.
+ (subclasses nil :type (or null hash-table))
+ ;; the PCL class object for this class, or NIL if none assigned yet
+ (pcl-class nil))
+
+;;; KLUDGE: ANSI says this is a generic function, but we need it for
+;;; bootstrapping before CLOS exists, so we define it as an ordinary
+;;; function and let CLOS code overwrite it later. -- WHN ca. 19990815
+(defun sb!xc:class-name (class)
+ (class-%name class))
+
+(defun class-make-load-form-fun (class)
+ (/show "entering CLASS-MAKE-LOAD-FORM-FUN" class)
+ (let ((name (sb!xc:class-name class)))
+ (unless (and name (eq (sb!xc:find-class name nil) class))
+ (/show "anonymous/undefined class case")
+ (error "can't use anonymous or undefined class as constant:~% ~S"
+ class))
+ `(locally
+ ;; KLUDGE: There's a FIND-CLASS DEFTRANSFORM for constant class
+ ;; names which creates fast but non-cold-loadable, non-compact
+ ;; code. In this context, we'd rather have compact,
+ ;; cold-loadable code. -- WHN 19990928
+ (declare (notinline sb!xc:find-class))
+ (sb!xc:find-class ',name))))
+\f
+;;;; basic LAYOUT stuff
+
+;;; Note: This bound is set somewhat less than MOST-POSITIVE-FIXNUM
+;;; in order to guarantee that several hash values can be added without
+;;; overflowing into a bignum.
+(defconstant layout-clos-hash-max (ash most-positive-fixnum -3)
+ #!+sb-doc
+ "the inclusive upper bound on LAYOUT-CLOS-HASH values")
+
+;;; a list of conses, initialized by genesis
+;;;
+;;; In each cons, the car is the symbol naming the layout, and the
+;;; cdr is the layout itself.
+(defvar *!initial-layouts*)
+
+;;; a table mapping class names to layouts for classes we have
+;;; referenced but not yet loaded. This is initialized from an alist
+;;; created by genesis describing the layouts that genesis created at
+;;; cold-load time.
+(defvar *forward-referenced-layouts*)
+(!cold-init-forms
+ (setq *forward-referenced-layouts* (make-hash-table :test 'equal))
+ #-sb-xc-host (progn
+ (/show0 "processing *!INITIAL-LAYOUTS*")
+ (dolist (x *!initial-layouts*)
+ (setf (gethash (car x) *forward-referenced-layouts*)
+ (cdr x)))
+ (/show0 "done processing *!INITIAL-LAYOUTS*")))
+
+;;; The LAYOUT structure is pointed to by the first cell of instance
+;;; (or structure) objects. It represents what we need to know for
+;;; type checking and garbage collection. Whenever a class is
+;;; incompatibly redefined, a new layout is allocated. If two object's
+;;; layouts are EQ, then they are exactly the same type.
+;;;
+;;; KLUDGE: The genesis code has raw offsets of slots in this
+;;; structure hardwired into it. It would be good to rewrite that code
+;;; so that it looks up those offsets in the compiler's tables, but
+;;; for now if you change this structure, lucky you, you get to grovel
+;;; over the genesis code by hand.:-( -- WHN 19990820
+(def!struct (layout
+ ;; KLUDGE: A special hack keeps this from being
+ ;; called when building code for the
+ ;; cross-compiler. See comments at the DEFUN for
+ ;; this. -- WHN 19990914
+ (:make-load-form-fun #-sb-xc-host ignore-it
+ ;; KLUDGE: DEF!STRUCT at #+SB-XC-HOST
+ ;; time controls both the
+ ;; build-the-cross-compiler behavior
+ ;; and the run-the-cross-compiler
+ ;; behavior. The value below only
+ ;; works for build-the-cross-compiler.
+ ;; There's a special hack in
+ ;; EMIT-MAKE-LOAD-FORM which gives
+ ;; effectively IGNORE-IT behavior for
+ ;; LAYOUT at run-the-cross-compiler
+ ;; time. It would be cleaner to
+ ;; actually have an IGNORE-IT value
+ ;; stored, but it's hard to see how to
+ ;; do that concisely with the current
+ ;; DEF!STRUCT setup. -- WHN 19990930
+ #+sb-xc-host
+ make-load-form-for-layout))
+ ;; hash bits which should be set to constant pseudo-random values
+ ;; for use by CLOS. Sleazily accessed via %INSTANCE-REF, see
+ ;; LAYOUT-CLOS-HASH.
+ ;;
+ ;; FIXME: We should get our story straight on what the type of these
+ ;; values is. (declared INDEX here, described as <=
+ ;; LAYOUT-CLOS-HASH-MAX by the doc string of that constant,
+ ;; generated as strictly positive in RANDOM-LAYOUT-CLOS-HASH..)
+ ;;
+ ;; KLUDGE: The fact that the slots here start at offset 1 is known
+ ;; to the LAYOUT-CLOS-HASH function and to the LAYOUT-dumping code
+ ;; in GENESIS.
+ (clos-hash-0 (random-layout-clos-hash) :type index)
+ (clos-hash-1 (random-layout-clos-hash) :type index)
+ (clos-hash-2 (random-layout-clos-hash) :type index)
+ (clos-hash-3 (random-layout-clos-hash) :type index)
+ (clos-hash-4 (random-layout-clos-hash) :type index)
+ (clos-hash-5 (random-layout-clos-hash) :type index)
+ (clos-hash-6 (random-layout-clos-hash) :type index)
+ (clos-hash-7 (random-layout-clos-hash) :type index)
+ ;; the class that this is a layout for
+ (class (required-argument)
+ ;; FIXME: Do we really know this is a CL:CLASS? Mightn't it
+ ;; be a SB-PCL:CLASS under some circumstances? What goes here
+ ;; when the LAYOUT is in fact a PCL::WRAPPER?
+ :type #-sb-xc sb!xc:class #+sb-xc cl:class)
+ ;; The value of this slot can be
+ ;; * :UNINITIALIZED if not initialized yet;
+ ;; * NIL if this is the up-to-date layout for a class; or
+ ;; * T if this layout has been invalidated (by being replaced by
+ ;; a new, more-up-to-date LAYOUT).
+ ;; * something else (probably a list) if the class is a PCL wrapper
+ ;; and PCL has made it invalid and made a note to itself about it
+ (invalid :uninitialized :type (or cons (member nil t :uninitialized)))
+ ;; The layouts for all classes we inherit. If hierarchical these are
+ ;; in order from most general down to (but not including) this
+ ;; class.
+ ;;
+ ;; FIXME: Couldn't this be (SIMPLE-ARRAY LAYOUT 1) instead of
+ ;; SIMPLE-VECTOR?
+ (inherits #() :type simple-vector)
+ ;; If inheritance is hierarchical, this is -1. If inheritance is not
+ ;; hierarchical, this is the inheritance depth, i.e. (LENGTH INHERITS).
+ ;; Note:
+ ;; (1) This turns out to be a handy encoding for arithmetically
+ ;; comparing deepness; it is generally useful to do a bare numeric
+ ;; comparison of these depthoid values, and we hardly ever need to
+ ;; test whether the values are negative or not.
+ ;; (2) This was called INHERITANCE-DEPTH in classic CMU CL. It was
+ ;; renamed because some of us find it confusing to call something
+ ;; a depth when it isn't quite.
+ (depthoid -1 :type layout-depthoid)
+ ;; The number of top-level descriptor cells in each instance.
+ (length 0 :type index)
+ ;; If this layout has some kind of compiler meta-info, then this is
+ ;; it. If a structure, then we store the DEFSTRUCT-DESCRIPTION here.
+ (info nil)
+ ;; This is true if objects of this class are never modified to
+ ;; contain dynamic pointers in their slots or constant-like
+ ;; substructure (and hence can be copied into read-only space by
+ ;; PURIFY).
+ ;;
+ ;; KLUDGE: This slot is known to the C runtime support code.
+ (pure nil :type (member t nil 0)))
+
+(def!method print-object ((layout layout) stream)
+ (print-unreadable-object (layout stream :type t :identity t)
+ (format stream
+ "for ~S~@[, INVALID=~S~]"
+ (layout-proper-name layout)
+ (layout-invalid layout))))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defun layout-proper-name (layout)
+ (class-proper-name (layout-class layout))))
+\f
+;;;; support for the hash values used by CLOS when working with LAYOUTs
+
+(defconstant layout-clos-hash-length 8)
+#!-sb-fluid (declaim (inline layout-clos-hash))
+(defun layout-clos-hash (layout i)
+ ;; FIXME: Either this I should be declared to be `(MOD
+ ;; ,LAYOUT-CLOS-HASH-LENGTH), or this is used in some inner loop
+ ;; where we can't afford to check that kind of thing and therefore
+ ;; should have some insane level of optimization. (This is true both
+ ;; of this function and of the SETF function below.)
+ (declare (type layout layout) (type index i))
+ ;; FIXME: LAYOUT slots should have type `(MOD ,LAYOUT-CLOS-HASH-MAX),
+ ;; not INDEX.
+ (truly-the index (%instance-ref layout (1+ i))))
+#!-sb-fluid (declaim (inline (setf layout-clos-hash)))
+(defun (setf layout-clos-hash) (new-value layout i)
+ (declare (type layout layout) (type index new-value i))
+ (setf (%instance-ref layout (1+ i)) new-value))
+
+;;; a generator for random values suitable for the CLOS-HASH slots of
+;;; LAYOUTs. We use our own RANDOM-STATE here because we'd like
+;;; pseudo-random values to come the same way in the target even when
+;;; we make minor changes to the system, in order to reduce the
+;;; mysteriousness of possible CLOS bugs.
+(defvar *layout-clos-hash-random-state*)
+(defun random-layout-clos-hash ()
+ ;; FIXME: I'm not sure why this expression is (1+ (RANDOM FOO)),
+ ;; returning a strictly positive value. I copied it verbatim from
+ ;; CMU CL INITIALIZE-LAYOUT-HASH, so presumably it works, but I
+ ;; dunno whether the hash values are really supposed to be 1-based.
+ ;; They're declared as INDEX.. Or is this a hack to try to avoid
+ ;; having to use bignum arithmetic? Or what? An explanation would be
+ ;; nice.
+ (1+ (random layout-clos-hash-max
+ (if (boundp '*layout-clos-hash-random-state*)
+ *layout-clos-hash-random-state*
+ (setf *layout-clos-hash-random-state*
+ (make-random-state))))))
+\f
+;;; If we can't find any existing layout, then we create a new one
+;;; storing it in *FORWARD-REFERENCED-LAYOUTS*. In classic CMU CL, we
+;;; used to immediately check for compatibility, but for
+;;; cross-compilability reasons (i.e. convenience of using this
+;;; function in a MAKE-LOAD-FORM expression) that functionality has
+;;; been split off into INIT-OR-CHECK-LAYOUT.
+(declaim (ftype (function (symbol) layout) find-layout))
+(defun find-layout (name)
+ (let ((class (sb!xc:find-class name nil)))
+ (or (and class (class-layout class))
+ (gethash name *forward-referenced-layouts*)
+ (setf (gethash name *forward-referenced-layouts*)
+ (make-layout :class (or class (make-undefined-class name)))))))
+
+;;; If LAYOUT is uninitialized, initialize it with CLASS, LENGTH,
+;;; INHERITS, and DEPTHOID, otherwise require that it be consistent
+;;; with CLASS, LENGTH, INHERITS, and DEPTHOID.
+;;;
+;;; UNDEFINED-CLASS values are interpreted specially as "we don't know
+;;; anything about the class", so if LAYOUT is initialized, any
+;;; preexisting class slot value is OK, and if it's not initialized,
+;;; its class slot value is set to an UNDEFINED-CLASS. -- FIXME: This
+;;; is no longer true, :UNINITIALIZED used instead.
+(declaim (ftype (function (layout sb!xc:class index simple-vector layout-depthoid) layout)
+ init-or-check-layout))
+(defun init-or-check-layout (layout class length inherits depthoid)
+ (cond ((eq (layout-invalid layout) :uninitialized)
+ ;; There was no layout before, we just created one which
+ ;; we'll now initialize with our information.
+ (setf (layout-length layout) length
+ (layout-inherits layout) inherits
+ (layout-depthoid layout) depthoid
+ (layout-class layout) class
+ (layout-invalid layout) nil))
+ ;; FIXME: Now that LAYOUTs are born :UNINITIALIZED, maybe this
+ ;; clause is not needed?
+ ((not *type-system-initialized*)
+ (setf (layout-class layout) class))
+ (t
+ ;; There was an old layout already initialized with old
+ ;; information, and we'll now check that old information
+ ;; which was known with certainty is consistent with current
+ ;; information which is known with certainty.
+ (check-layout layout class length inherits depthoid)))
+ layout)
+
+;;; In code for the target Lisp, we don't use dump LAYOUTs using the
+;;; standard load form mechanism, we use special fops instead, in
+;;; order to make cold load come out right. But when we're building
+;;; the cross-compiler, we can't do that because we don't have access
+;;; to special non-ANSI low-level things like special fops, and we
+;;; don't need to do that anyway because our code isn't going to be
+;;; cold loaded, so we use the ordinary load form system.
+;;;
+;;; KLUDGE: A special hack causes this not to be called when we are
+;;; building code for the target Lisp. It would be tidier to just not
+;;; have it in place when we're building the target Lisp, but it
+;;; wasn't clear how to do that without rethinking DEF!STRUCT quite a
+;;; bit, so I punted. -- WHN 19990914
+#+sb-xc-host
+(defun make-load-form-for-layout (layout &optional env)
+ (declare (type layout layout))
+ (declare (ignore env))
+ (when (layout-invalid layout)
+ (compiler-error "can't dump reference to obsolete class: ~S"
+ (layout-class layout)))
+ (let ((name (sb!xc:class-name (layout-class layout))))
+ (unless name
+ (compiler-error "can't dump anonymous LAYOUT: ~S" layout))
+ ;; Since LAYOUT refers to a class which refers back to the LAYOUT,
+ ;; we have to do this in two stages, a la the TREE-WITH-PARENT
+ ;; example in the MAKE-LOAD-FORM entry in the ANSI spec.
+ (values
+ ;; "creation" form (which actually doesn't create a new LAYOUT if
+ ;; there's a preexisting one with this name)
+ `(find-layout ',name)
+ ;; "initialization" form (which actually doesn't initialize
+ ;; preexisting LAYOUTs, just checks that they're consistent).
+ `(init-or-check-layout ',layout
+ ',(layout-class layout)
+ ',(layout-length layout)
+ ',(layout-inherits layout)
+ ',(layout-depthoid layout)))))
+
+;;; If LAYOUT's slot values differ from the specified slot values in
+;;; any interesting way, then give a warning and return T.
+(declaim (ftype (function (simple-string
+ layout
+ simple-string
+ index
+ simple-vector
+ layout-depthoid))
+ redefine-layout-warning))
+(defun redefine-layout-warning (old-context old-layout
+ context length inherits depthoid)
+ (declare (type layout old-layout) (type simple-string old-context context))
+ (let ((name (layout-proper-name old-layout)))
+ (or (let ((old-inherits (layout-inherits old-layout)))
+ (or (when (mismatch old-inherits
+ inherits
+ :key #'layout-proper-name)
+ (warn "change in superclasses of class ~S:~% ~
+ ~A superclasses: ~S~% ~
+ ~A superclasses: ~S"
+ name
+ old-context
+ (map 'list #'layout-proper-name old-inherits)
+ context
+ (map 'list #'layout-proper-name inherits))
+ t)
+ (let ((diff (mismatch old-inherits inherits)))
+ (when diff
+ (warn
+ "in class ~S:~% ~
+ ~:(~A~) definition of superclass ~S is incompatible with~% ~
+ ~A definition."
+ name
+ old-context
+ (layout-proper-name (svref old-inherits diff))
+ context)
+ t))))
+ (let ((old-length (layout-length old-layout)))
+ (unless (= old-length length)
+ (warn "change in instance length of class ~S:~% ~
+ ~A length: ~D~% ~
+ ~A length: ~D"
+ name
+ old-context old-length
+ context length)
+ t))
+ (unless (= (layout-depthoid old-layout) depthoid)
+ (warn "change in the inheritance structure of class ~S~% ~
+ between the ~A definition and the ~A definition"
+ name old-context context)
+ t))))
+
+;;; Require that LAYOUT data be consistent with CLASS, LENGTH,
+;;; INHERITS, and DEPTHOID.
+(declaim (ftype (function (layout sb!xc:class index simple-vector layout-depthoid))
+ check-layout))
+(defun check-layout (layout class length inherits depthoid)
+ (assert (eq (layout-class layout) class))
+ (when (redefine-layout-warning "current" layout
+ "compile time" length inherits depthoid)
+ ;; Classic CMU CL had more options here. There are several reasons
+ ;; why they might want more options which are less appropriate for
+ ;; us: (1) It's hard to fit the classic CMU CL flexible approach
+ ;; into the ANSI-style MAKE-LOAD-FORM system, and having a
+ ;; non-MAKE-LOAD-FORM-style system is painful when we're trying to
+ ;; make the cross-compiler run under vanilla ANSI Common Lisp. (2)
+ ;; We have CLOS now, and if you want to be able to flexibly
+ ;; redefine classes without restarting the system, it'd make sense
+ ;; to use that, so supporting complexity in order to allow
+ ;; modifying DEFSTRUCTs without restarting the system is a low
+ ;; priority. (3) We now have the ability to rebuild the SBCL
+ ;; system from scratch, so we no longer need this functionality in
+ ;; order to maintain the SBCL system by modifying running images.
+ (error "The class ~S was not changed, and there's no guarantee that~@
+ the loaded code (which expected another layout) will work."
+ (layout-proper-name layout)))
+ (values))
+
+;;; a common idiom (the same as CMU CL FIND-LAYOUT) rolled up into a
+;;; single function call
+;;;
+;;; Used by the loader to forward-reference layouts for classes whose
+;;; definitions may not have been loaded yet. This allows type tests
+;;; to be loaded when the type definition hasn't been loaded yet.
+(declaim (ftype (function (symbol index simple-vector layout-depthoid) layout)
+ find-and-init-or-check-layout))
+(defun find-and-init-or-check-layout (name length inherits depthoid)
+ (let ((layout (find-layout name)))
+ (init-or-check-layout layout
+ (or (sb!xc:find-class name nil)
+ (make-undefined-class name))
+ length
+ inherits
+ depthoid)))
+
+;;; Record LAYOUT as the layout for its class, adding it as a subtype
+;;; of all superclasses. This is the operation that "installs" a
+;;; layout for a class in the type system, clobbering any old layout.
+;;; However, this does not modify the class namespace; that is a
+;;; separate operation (think anonymous classes.)
+;;; -- If INVALIDATE, then all the layouts for any old definition
+;;; and subclasses are invalidated, and the SUBCLASSES slot is cleared.
+;;; -- If DESTRUCT-LAYOUT, then this is some old layout, and is to be
+;;; destructively modified to hold the same type information.
+(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
+(defun register-layout (layout &key (invalidate t) destruct-layout)
+ (declare (type layout layout) (type (or layout null) destruct-layout))
+ (let* ((class (layout-class layout))
+ (class-layout (class-layout class))
+ (subclasses (class-subclasses class)))
+
+ ;; Attempting to register ourselves with a temporary cookie is
+ ;; almost certainly a programmer error. (I should know, I did it.)
+ ;; -- WHN 19990927
+ (assert (not (undefined-class-p class)))
+
+ ;; This assertion dates from classic CMU CL. The rationale is
+ ;; probably that calling REGISTER-LAYOUT more than once for the
+ ;; same LAYOUT is almost certainly a programmer error.
+ (assert (not (eq class-layout layout)))
+
+ ;; Figure out what classes are affected by the change, and issue
+ ;; appropriate warnings and invalidations.
+ (when class-layout
+ (modify-class class)
+ (when subclasses
+ (dohash (subclass subclass-layout subclasses)
+ (modify-class subclass)
+ (when invalidate
+ (invalidate-layout subclass-layout))))
+ (when invalidate
+ (invalidate-layout class-layout)
+ (setf (class-subclasses class) nil)))
+
+ (if destruct-layout
+ (setf (layout-invalid destruct-layout) nil
+ (layout-inherits destruct-layout) (layout-inherits layout)
+ (layout-depthoid destruct-layout)(layout-depthoid layout)
+ (layout-length destruct-layout) (layout-length layout)
+ (layout-info destruct-layout) (layout-info layout)
+ (class-layout class) destruct-layout)
+ (setf (layout-invalid layout) nil
+ (class-layout class) layout))
+
+ (let ((inherits (layout-inherits layout)))
+ (dotimes (i (length inherits)) ; FIXME: should be DOVECTOR
+ (let* ((super (layout-class (svref inherits i)))
+ (subclasses (or (class-subclasses super)
+ (setf (class-subclasses super)
+ (make-hash-table :test 'eq)))))
+ (when (and (eq (class-state super) :sealed)
+ (not (gethash class subclasses)))
+ (warn "unsealing sealed class ~S in order to subclass it"
+ (sb!xc:class-name super))
+ (setf (class-state super) :read-only))
+ (setf (gethash class subclasses)
+ (or destruct-layout layout))))))
+
+ (values))
+); EVAL-WHEN
+\f
+;;; An UNDEFINED-CLASS is a cookie we make up to stick in forward
+;;; referenced layouts. Users should never see them.
+(def!struct (undefined-class (:include #-sb-xc sb!xc:class
+ #+sb-xc cl:class)
+ (:constructor make-undefined-class (%name))))
+
+;;; BUILT-IN-CLASS is used to represent the standard classes that
+;;; aren't defined with DEFSTRUCT and other specially implemented
+;;; primitive types whose only attribute is their name.
+;;;
+;;; Some BUILT-IN-CLASSes have a TRANSLATION, which means that they
+;;; are effectively DEFTYPE'd to some other type (usually a union of
+;;; other classes or a "primitive" type such as NUMBER, ARRAY, etc.)
+;;; This translation is done when type specifiers are parsed. Type
+;;; system operations (union, subtypep, etc.) should never encounter
+;;; translated classes, only their translation.
+(def!struct (sb!xc:built-in-class (:include #-sb-xc sb!xc:class
+ #+sb-xc cl:class)
+ (:constructor bare-make-built-in-class))
+ ;; the type we translate to on parsing. If NIL, then this class
+ ;; stands on its own; or it can be set to :INITIALIZING for a period
+ ;; during cold-load.
+ (translation nil :type (or ctype (member nil :initializing))))
+(defun make-built-in-class (&rest rest)
+ (apply #'bare-make-built-in-class
+ (rename-keyword-args '((:name :%name)) rest)))
+
+;;; FIXME: In CMU CL, this was a class with a print function, but not
+;;; necessarily a structure class (e.g. CONDITIONs). In SBCL,
+;;; we let CLOS handle our print functions, so that is no longer needed.
+;;; Is there any need for this class any more?
+(def!struct (slot-class (:include #-sb-xc sb!xc:class #+sb-xc cl:class)
+ (:constructor nil)))
+
+;;; STRUCTURE-CLASS represents what we need to know about structure
+;;; classes. Non-structure "typed" defstructs are a special case, and
+;;; don't have a corresponding class.
+(def!struct (basic-structure-class (:include slot-class)
+ (:constructor nil)))
+
+(def!struct (sb!xc:structure-class (:include basic-structure-class)
+ (:constructor bare-make-structure-class))
+ ;; If true, a default keyword constructor for this structure.
+ (constructor nil :type (or function null)))
+(defun make-structure-class (&rest rest)
+ (apply #'bare-make-structure-class
+ (rename-keyword-args '((:name :%name)) rest)))
+
+;;; FUNCALLABLE-STRUCTURE-CLASS is used to represent funcallable
+;;; structures, which are used to implement generic functions.
+(def!struct (funcallable-structure-class (:include basic-structure-class)
+ (:constructor bare-make-funcallable-structure-class)))
+(defun make-funcallable-structure-class (&rest rest)
+ (apply #'bare-make-funcallable-structure-class
+ (rename-keyword-args '((:name :%name)) rest)))
+\f
+;;;; class namespace
+
+;;; We use an indirection to allow forward referencing of class
+;;; definitions with load-time resolution.
+(def!struct (class-cell
+ (:constructor make-class-cell (name &optional class))
+ (:make-load-form-fun (lambda (c)
+ `(find-class-cell ',(class-cell-name c))))
+ #-no-ansi-print-object
+ (:print-object (lambda (s stream)
+ (print-unreadable-object (s stream :type t)
+ (prin1 (class-cell-name s) stream)))))
+ ;; Name of class we expect to find.
+ (name nil :type symbol :read-only t)
+ ;; Class or NIL if not yet defined.
+ (class nil :type (or #-sb-xc sb!xc:class #+sb-xc cl:class
+ null)))
+(defun find-class-cell (name)
+ (or (info :type :class name)
+ (setf (info :type :class name)
+ (make-class-cell name))))
+
+;;; FIXME: When the system is stable, this DECLAIM FTYPE should
+;;; probably go away in favor of the DEFKNOWN for FIND-CLASS.
+(declaim (ftype (function (symbol &optional t (or null sb!c::lexenv))) sb!xc:find-class))
+(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
+(defun sb!xc:find-class (name &optional (errorp t) environment)
+ #!+sb-doc
+ "Return the class with the specified NAME. If ERRORP is false, then NIL is
+ returned when no such class exists."
+ (declare (type symbol name) (ignore environment))
+ (let ((res (class-cell-class (find-class-cell name))))
+ (if (or res (not errorp))
+ res
+ (error "class not yet defined:~% ~S" name))))
+(defun (setf sb!xc:find-class) (new-value name)
+ #-sb-xc (declare (type sb!xc:class new-value))
+ (ecase (info :type :kind name)
+ ((nil))
+ (:instance
+ (let ((old (class-of (sb!xc:find-class name)))
+ (new (class-of new-value)))
+ (unless (eq old new)
+ (warn "changing meta-class of ~S from ~S to ~S"
+ name
+ (class-name old)
+ (class-name new)))))
+ (:primitive
+ (error "illegal to redefine standard type ~S" name))
+ (:defined
+ (warn "redefining DEFTYPE type to be a class: ~S" name)
+ (setf (info :type :expander name) nil)))
+
+ (remhash name *forward-referenced-layouts*)
+ (%note-type-defined name)
+ (setf (info :type :kind name) :instance)
+ (setf (class-cell-class (find-class-cell name)) new-value)
+ (unless (eq (info :type :compiler-layout name)
+ (class-layout new-value))
+ (setf (info :type :compiler-layout name) (class-layout new-value)))
+ new-value)
+) ; EVAL-WHEN
+
+;;; Called when we are about to define NAME as a class meeting some
+;;; predicate (such as a meta-class type test.) The first result is
+;;; always of the desired class. The second result is any existing
+;;; LAYOUT for this name.
+(defun insured-find-class (name predicate constructor)
+ (declare (function predicate constructor))
+ (let* ((old (sb!xc:find-class name nil))
+ (res (if (and old (funcall predicate old))
+ old
+ (funcall constructor :name name)))
+ (found (or (gethash name *forward-referenced-layouts*)
+ (when old (class-layout old)))))
+ (when found
+ (setf (layout-class found) res))
+ (values res found)))
+
+;;; If the class has a proper name, return the name, otherwise return
+;;; the class.
+(defun class-proper-name (class)
+ #-sb-xc (declare (type sb!xc:class class))
+ (let ((name (sb!xc:class-name class)))
+ (if (and name (eq (sb!xc:find-class name nil) class))
+ name
+ class)))
+\f
+;;;; CLASS type operations
+
+(define-type-class sb!xc:class)
+
+;;; Simple methods for TYPE= and SUBTYPEP should never be called when
+;;; the two classes are equal, since there are EQ checks in those
+;;; operations.
+(define-type-method (sb!xc:class :simple-=) (type1 type2)
+ (assert (not (eq type1 type2)))
+ (values nil t))
+
+(define-type-method (sb!xc:class :simple-subtypep) (class1 class2)
+ (assert (not (eq class1 class2)))
+ (let ((subclasses (class-subclasses class2)))
+ (if (and subclasses (gethash class1 subclasses))
+ (values t t)
+ (values nil t))))
+
+;;; When finding the intersection of a sealed class and some other
+;;; class (not hierarchically related) the intersection is the union
+;;; of the currently shared subclasses.
+(defun sealed-class-intersection (sealed other)
+ (declare (type sb!xc:class sealed other))
+ (let ((s-sub (class-subclasses sealed))
+ (o-sub (class-subclasses other)))
+ (if (and s-sub o-sub)
+ (collect ((res *empty-type* type-union))
+ (dohash (subclass layout s-sub)
+ (declare (ignore layout))
+ (when (gethash subclass o-sub)
+ (res (specifier-type subclass))))
+ (values (res) t))
+ (values *empty-type* t))))
+
+;;; If one is a subclass of the other, then that is the intersection,
+;;; but we can only be sure the intersection is otherwise empty if
+;;; they are structure classes, since a subclass of both might be
+;;; defined. If either class is sealed, we can eliminate this
+;;; possibility.
+(define-type-method (sb!xc:class :simple-intersection) (class1 class2)
+ (declare (type sb!xc:class class1 class2))
+ (cond ((eq class1 class2) class1)
+ ((let ((subclasses (class-subclasses class2)))
+ (and subclasses (gethash class1 subclasses)))
+ (values class1 t))
+ ((let ((subclasses (class-subclasses class1)))
+ (and subclasses (gethash class2 subclasses)))
+ (values class2 t))
+ ((or (basic-structure-class-p class1)
+ (basic-structure-class-p class2))
+ (values *empty-type* t))
+ ((eq (class-state class1) :sealed)
+ (sealed-class-intersection class1 class2))
+ ((eq (class-state class2) :sealed)
+ (sealed-class-intersection class2 class1))
+ (t
+ (values class1 nil))))
+
+(define-type-method (sb!xc:class :unparse) (type)
+ (class-proper-name type))
+\f
+;;;; PCL stuff
+
+(def!struct (std-class (:include sb!xc:class)
+ (:constructor nil)))
+(def!struct (sb!xc:standard-class (:include std-class)
+ (:constructor bare-make-standard-class)))
+(def!struct (random-pcl-class (:include std-class)
+ (:constructor bare-make-random-pcl-class)))
+(defun make-standard-class (&rest rest)
+ (apply #'bare-make-standard-class
+ (rename-keyword-args '((:name :%name)) rest)))
+(defun make-random-pcl-class (&rest rest)
+ (apply #'bare-make-random-pcl-class
+ (rename-keyword-args '((:name :%name)) rest)))
+\f
+;;;; built-in classes
+
+;;; The BUILT-IN-CLASSES list is a data structure which configures the
+;;; creation of all the built-in classes. It contains all the info
+;;; that we need to maintain the mapping between classes, compile-time
+;;; types and run-time type codes. These options are defined:
+;;;
+;;; :TRANSLATION (default none)
+;;; When this class is "parsed" as a type specifier, it is
+;;; translated into the specified internal type representation,
+;;; rather than being left as a class. This is used for types
+;;; which we want to canonicalize to some other kind of type
+;;; object because in general we want to be able to include more
+;;; information than just the class (e.g. for numeric types.)
+;;;
+;;; :ENUMERABLE (default NIL)
+;;; The value of the :ENUMERABLE slot in the created class.
+;;; Meaningless in translated classes.
+;;;
+;;; :STATE (default :SEALED)
+;;; The value of CLASS-STATE which we want on completion,
+;;; indicating whether subclasses can be created at run-time.
+;;;
+;;; :HIERARCHICAL-P (default T unless any of the inherits are non-hierarchical)
+;;; True if we can assign this class a unique inheritance depth.
+;;;
+;;; :CODES (default none)
+;;; Run-time type codes which should be translated back to this
+;;; class by CLASS-OF. Unspecified for abstract classes.
+;;;
+;;; :INHERITS (default this class and T)
+;;; The class-precedence list for this class, with this class and
+;;; T implicit.
+;;;
+;;; :DIRECT-SUPERCLASSES (default to head of CPL)
+;;; List of the direct superclasses of this class.
+;;;
+;;; FIXME: This doesn't seem to be needed after cold init (and so can
+;;; probably be uninterned at the end of cold init).
+(defvar *built-in-classes*)
+(!cold-init-forms
+ (/show0 "setting *BUILT-IN-CLASSES*")
+ (setq
+ *built-in-classes*
+ '((t :state :read-only :translation t)
+ (character :enumerable t :translation base-char)
+ (base-char :enumerable t
+ :inherits (character)
+ :codes (#.sb!vm:base-char-type))
+ (symbol :codes (#.sb!vm:symbol-header-type))
+
+ (instance :state :read-only)
+
+ (system-area-pointer :codes (#.sb!vm:sap-type))
+ (weak-pointer :codes (#.sb!vm:weak-pointer-type))
+ (code-component :codes (#.sb!vm:code-header-type))
+ #!-gengc (lra :codes (#.sb!vm:return-pc-header-type))
+ (fdefn :codes (#.sb!vm:fdefn-type))
+ (random-class) ; used for unknown type codes
+
+ (function
+ :codes (#.sb!vm:byte-code-closure-type
+ #.sb!vm:byte-code-function-type
+ #.sb!vm:closure-header-type
+ #.sb!vm:function-header-type)
+ :state :read-only)
+ (funcallable-instance
+ :inherits (function)
+ :state :read-only)
+
+ ;; FIXME: Are COLLECTION and MUTABLE-COLLECTION used for anything
+ ;; any more? COLLECTION is not defined in ANSI Common Lisp..
+ (collection :hierarchical-p nil :state :read-only)
+ (mutable-collection :state :read-only
+ :inherits (collection))
+ (generic-sequence :state :read-only
+ :inherits (collection))
+ (mutable-sequence :state :read-only
+ :direct-superclasses (mutable-collection
+ generic-sequence)
+ :inherits (mutable-collection
+ generic-sequence
+ collection))
+ (generic-array :state :read-only
+ :inherits (mutable-sequence
+ mutable-collection
+ generic-sequence
+ collection))
+ (generic-vector :state :read-only
+ :inherits (generic-array
+ mutable-sequence mutable-collection
+ generic-sequence collection))
+ (array :translation array :codes (#.sb!vm:complex-array-type)
+ :inherits (generic-array mutable-sequence mutable-collection
+ generic-sequence collection))
+ (simple-array
+ :translation simple-array :codes (#.sb!vm:simple-array-type)
+ :inherits (array generic-array mutable-sequence mutable-collection
+ generic-sequence collection))
+ (sequence
+ :translation (or cons (member nil) vector)
+ :inherits (mutable-sequence mutable-collection generic-sequence
+ collection))
+ (vector
+ :translation vector :codes (#.sb!vm:complex-vector-type)
+ :direct-superclasses (array sequence generic-vector)
+ :inherits (array sequence generic-vector generic-array
+ mutable-sequence mutable-collection generic-sequence
+ collection))
+ (simple-vector
+ :translation simple-vector :codes (#.sb!vm:simple-vector-type)
+ :direct-superclasses (vector simple-array)
+ :inherits (vector simple-array array
+ sequence generic-vector generic-array
+ mutable-sequence mutable-collection
+ generic-sequence collection))
+ (bit-vector
+ :translation bit-vector :codes (#.sb!vm:complex-bit-vector-type)
+ :inherits (vector array sequence
+ generic-vector generic-array mutable-sequence
+ mutable-collection generic-sequence collection))
+ (simple-bit-vector
+ :translation simple-bit-vector :codes (#.sb!vm:simple-bit-vector-type)
+ :direct-superclasses (bit-vector simple-array)
+ :inherits (bit-vector vector simple-array
+ array sequence
+ generic-vector generic-array mutable-sequence
+ mutable-collection generic-sequence collection))
+ (simple-array-unsigned-byte-2
+ :translation (simple-array (unsigned-byte 2) (*))
+ :codes (#.sb!vm:simple-array-unsigned-byte-2-type)
+ :direct-superclasses (vector simple-array)
+ :inherits (vector simple-array array sequence
+ generic-vector generic-array mutable-sequence
+ mutable-collection generic-sequence collection))
+ (simple-array-unsigned-byte-4
+ :translation (simple-array (unsigned-byte 4) (*))
+ :codes (#.sb!vm:simple-array-unsigned-byte-4-type)
+ :direct-superclasses (vector simple-array)
+ :inherits (vector simple-array array sequence
+ generic-vector generic-array mutable-sequence
+ mutable-collection generic-sequence collection))
+ (simple-array-unsigned-byte-8
+ :translation (simple-array (unsigned-byte 8) (*))
+ :codes (#.sb!vm:simple-array-unsigned-byte-8-type)
+ :direct-superclasses (vector simple-array)
+ :inherits (vector simple-array array sequence
+ generic-vector generic-array mutable-sequence
+ mutable-collection generic-sequence collection))
+ (simple-array-unsigned-byte-16
+ :translation (simple-array (unsigned-byte 16) (*))
+ :codes (#.sb!vm:simple-array-unsigned-byte-16-type)
+ :direct-superclasses (vector simple-array)
+ :inherits (vector simple-array array sequence
+ generic-vector generic-array mutable-sequence
+ mutable-collection generic-sequence collection))
+ (simple-array-unsigned-byte-32
+ :translation (simple-array (unsigned-byte 32) (*))
+ :codes (#.sb!vm:simple-array-unsigned-byte-32-type)
+ :direct-superclasses (vector simple-array)
+ :inherits (vector simple-array array sequence
+ generic-vector generic-array mutable-sequence
+ mutable-collection generic-sequence collection))
+ (simple-array-signed-byte-8
+ :translation (simple-array (signed-byte 8) (*))
+ :codes (#.sb!vm:simple-array-signed-byte-8-type)
+ :direct-superclasses (vector simple-array)
+ :inherits (vector simple-array array sequence
+ generic-vector generic-array mutable-sequence
+ mutable-collection generic-sequence collection))
+ (simple-array-signed-byte-16
+ :translation (simple-array (signed-byte 16) (*))
+ :codes (#.sb!vm:simple-array-signed-byte-16-type)
+ :direct-superclasses (vector simple-array)
+ :inherits (vector simple-array array sequence
+ generic-vector generic-array mutable-sequence
+ mutable-collection generic-sequence collection))
+ (simple-array-signed-byte-30
+ :translation (simple-array (signed-byte 30) (*))
+ :codes (#.sb!vm:simple-array-signed-byte-30-type)
+ :direct-superclasses (vector simple-array)
+ :inherits (vector simple-array array sequence
+ generic-vector generic-array mutable-sequence
+ mutable-collection generic-sequence collection))
+ (simple-array-signed-byte-32
+ :translation (simple-array (signed-byte 32) (*))
+ :codes (#.sb!vm:simple-array-signed-byte-32-type)
+ :direct-superclasses (vector simple-array)
+ :inherits (vector simple-array array sequence
+ generic-vector generic-array mutable-sequence
+ mutable-collection generic-sequence collection))
+ (simple-array-single-float
+ :translation (simple-array single-float (*))
+ :codes (#.sb!vm:simple-array-single-float-type)
+ :direct-superclasses (vector simple-array)
+ :inherits (vector simple-array array sequence
+ generic-vector generic-array mutable-sequence
+ mutable-collection generic-sequence collection))
+ (simple-array-double-float
+ :translation (simple-array double-float (*))
+ :codes (#.sb!vm:simple-array-double-float-type)
+ :direct-superclasses (vector simple-array)
+ :inherits (vector simple-array array sequence
+ generic-vector generic-array mutable-sequence
+ mutable-collection generic-sequence collection))
+ #!+long-float
+ (simple-array-long-float
+ :translation (simple-array long-float (*))
+ :codes (#.sb!vm:simple-array-long-float-type)
+ :direct-superclasses (vector simple-array)
+ :inherits (vector simple-array array sequence
+ generic-vector generic-array mutable-sequence
+ mutable-collection generic-sequence collection))
+ (simple-array-complex-single-float
+ :translation (simple-array (complex single-float) (*))
+ :codes (#.sb!vm:simple-array-complex-single-float-type)
+ :direct-superclasses (vector simple-array)
+ :inherits (vector simple-array array sequence
+ generic-vector generic-array mutable-sequence
+ mutable-collection generic-sequence collection))
+ (simple-array-complex-double-float
+ :translation (simple-array (complex double-float) (*))
+ :codes (#.sb!vm:simple-array-complex-double-float-type)
+ :direct-superclasses (vector simple-array)
+ :inherits (vector simple-array array sequence
+ generic-vector generic-array mutable-sequence
+ mutable-collection generic-sequence collection))
+ #!+long-float
+ (simple-array-complex-long-float
+ :translation (simple-array (complex long-float) (*))
+ :codes (#.sb!vm:simple-array-complex-long-float-type)
+ :direct-superclasses (vector simple-array)
+ :inherits (vector simple-array array sequence
+ generic-vector generic-array mutable-sequence
+ mutable-collection generic-sequence collection))
+ (generic-string
+ :state :read-only
+ :inherits (mutable-sequence mutable-collection generic-sequence
+ collection))
+ (string
+ :translation string
+ :codes (#.sb!vm:complex-string-type)
+ :direct-superclasses (vector generic-string)
+ :inherits (vector array sequence
+ generic-vector generic-array generic-string
+ mutable-sequence mutable-collection
+ generic-sequence collection))
+ (simple-string
+ :translation simple-string
+ :codes (#.sb!vm:simple-string-type)
+ :direct-superclasses (string simple-array)
+ :inherits (string vector simple-array
+ array sequence
+ generic-string generic-vector generic-array mutable-sequence
+ mutable-collection generic-sequence collection))
+ (generic-number :state :read-only)
+ (number :translation number :inherits (generic-number))
+ (complex
+ :translation complex
+ :inherits (number generic-number)
+ :codes (#.sb!vm:complex-type))
+ (complex-single-float
+ :translation (complex single-float)
+ :inherits (complex number generic-number)
+ :codes (#.sb!vm:complex-single-float-type))
+ (complex-double-float
+ :translation (complex double-float)
+ :inherits (complex number generic-number)
+ :codes (#.sb!vm:complex-double-float-type))
+ #!+long-float
+ (complex-long-float
+ :translation (complex long-float)
+ :inherits (complex number generic-number)
+ :codes (#.sb!vm:complex-long-float-type))
+ (real :translation real :inherits (number generic-number))
+ (float
+ :translation float
+ :inherits (real number generic-number))
+ (single-float
+ :translation single-float
+ :inherits (float real number generic-number)
+ :codes (#.sb!vm:single-float-type))
+ (double-float
+ :translation double-float
+ :inherits (float real number generic-number)
+ :codes (#.sb!vm:double-float-type))
+ #!+long-float
+ (long-float
+ :translation long-float
+ :inherits (float real number generic-number)
+ :codes (#.sb!vm:long-float-type))
+ (rational
+ :translation rational
+ :inherits (real number generic-number))
+ (ratio
+ :translation (and rational (not integer))
+ :inherits (rational real number generic-number)
+ :codes (#.sb!vm:ratio-type))
+ (integer
+ :translation integer
+ :inherits (rational real number generic-number))
+ (fixnum
+ :translation (integer #.sb!vm:*target-most-negative-fixnum*
+ #.sb!vm:*target-most-positive-fixnum*)
+ :inherits (integer rational real number
+ generic-number)
+ :codes (#.sb!vm:even-fixnum-type #.sb!vm:odd-fixnum-type))
+ (bignum
+ :translation (and integer (not fixnum))
+ :inherits (integer rational real number
+ generic-number)
+ :codes (#.sb!vm:bignum-type))
+
+ (list
+ :translation (or cons (member nil))
+ :inherits (sequence mutable-sequence mutable-collection
+ generic-sequence collection))
+ (cons
+ :codes (#.sb!vm:list-pointer-type)
+ :inherits (list sequence
+ mutable-sequence mutable-collection
+ generic-sequence collection))
+ (null
+ :translation (member nil)
+ :inherits (list sequence
+ mutable-sequence mutable-collection
+ generic-sequence collection symbol)
+ :direct-superclasses (list symbol))
+ (stream
+ :hierarchical-p nil
+ :state :read-only
+ :inherits (instance t)))))
+
+;;; comment from CMU CL:
+;;; See also type-init.lisp where we finish setting up the
+;;; translations for built-in types.
+(!cold-init-forms
+ #-sb-xc-host (/show0 "about to loop over *BUILT-IN-CLASSES*")
+ (dolist (x *built-in-classes*)
+ #-sb-xc-host (/show0 "at head of loop over *BUILT-IN-CLASSES*")
+ (destructuring-bind
+ (name &key
+ (translation nil trans-p)
+ inherits
+ codes
+ enumerable
+ state
+ (hierarchical-p t) ; might be modified below
+ (direct-superclasses (if inherits
+ (list (car inherits))
+ '(t))))
+ x
+ (declare (ignore codes state translation))
+ (let ((inherits-list (if (eq name 't)
+ ()
+ (cons 't (reverse inherits))))
+ (class (make-built-in-class
+ :enumerable enumerable
+ :name name
+ :translation (if trans-p :initializing nil)
+ :direct-superclasses
+ (if (eq name 't)
+ nil
+ (mapcar #'sb!xc:find-class direct-superclasses)))))
+ (setf (info :type :kind name) :primitive
+ (class-cell-class (find-class-cell name)) class)
+ (unless trans-p
+ (setf (info :type :builtin name) class))
+ (let* ((inherits-vector
+ (map 'vector
+ (lambda (x)
+ (let ((super-layout
+ (class-layout (sb!xc:find-class x))))
+ (when (minusp (layout-depthoid super-layout))
+ (setf hierarchical-p nil))
+ super-layout))
+ inherits-list))
+ (depthoid (if hierarchical-p (length inherits-vector) -1)))
+ (register-layout
+ (find-and-init-or-check-layout name
+ 0
+ inherits-vector
+ depthoid)
+ :invalidate nil)))))
+ #-sb-xc-host (/show0 "done with loop over *BUILT-IN-CLASSES*"))
+
+;;; Define temporary PCL STANDARD-CLASSes. These will be set up
+;;; correctly and the lisp layout replaced by a PCL wrapper after PCL
+;;; is loaded and the class defined.
+(!cold-init-forms
+ (dolist (x '((fundamental-stream (t instance stream))))
+ (let* ((name (first x))
+ (inherits-list (second x))
+ (class (make-standard-class :name name))
+ (class-cell (find-class-cell name)))
+ (setf (class-cell-class class-cell) class
+ (info :type :class name) class-cell
+ (info :type :kind name) :instance)
+ (let ((inherits (map 'vector
+ (lambda (x)
+ (class-layout (sb!xc:find-class x)))
+ inherits-list)))
+ (register-layout (find-and-init-or-check-layout name 0 inherits -1)
+ :invalidate nil)))))
+
+;;; Now that we have set up the class heterarchy, seal the sealed
+;;; classes. This must be done after the subclasses have been set up.
+(!cold-init-forms
+ (dolist (x *built-in-classes*)
+ (destructuring-bind (name &key (state :sealed) &allow-other-keys) x
+ (setf (class-state (sb!xc:find-class name)) state))))
+\f
+;;;; class definition/redefinition
+
+;;; This is to be called whenever we are altering a class.
+(defun modify-class (class)
+ (clear-type-caches)
+ (when (member (class-state class) '(:read-only :frozen))
+ ;; FIXME: This should probably be CERROR.
+ (warn "making ~(~A~) class ~S writable"
+ (class-state class)
+ (sb!xc:class-name class))
+ (setf (class-state class) nil)))
+
+;;; Mark LAYOUT as invalid. Setting DEPTHOID -1 helps cause unsafe
+;;; structure type tests to fail. Remove class from all superclasses
+;;; too (might not be registered, so might not be in subclasses of the
+;;; nominal superclasses.)
+(defun invalidate-layout (layout)
+ (declare (type layout layout))
+ (setf (layout-invalid layout) t
+ (layout-depthoid layout) -1)
+ (let ((inherits (layout-inherits layout))
+ (class (layout-class layout)))
+ (modify-class class)
+ (dotimes (i (length inherits)) ; FIXME: DOVECTOR
+ (let* ((super (svref inherits i))
+ (subs (class-subclasses (layout-class super))))
+ (when subs
+ (remhash class subs)))))
+ (values))
+\f
+;;;; cold loading initializations
+
+;;; FIXME: It would be good to arrange for this to be called when the
+;;; cross-compiler is being built, not just when the target Lisp is
+;;; being cold loaded. Perhaps this could be moved to its own file
+;;; late in the stems-and-flags.lisp-expr sequence, and be put in
+;;; !COLD-INIT-FORMS there?
+(defun !class-finalize ()
+ (dohash (name layout *forward-referenced-layouts*)
+ (let ((class (sb!xc:find-class name nil)))
+ (cond ((not class)
+ (setf (layout-class layout) (make-undefined-class name)))
+ ((eq (class-layout class) layout)
+ (remhash name *forward-referenced-layouts*))
+ (t
+ ;; FIXME: ERROR?
+ (warn "something strange with forward layout for ~S:~% ~S"
+ name
+ layout))))))
+
+;;; a vector that maps type codes to layouts, used for quickly finding
+;;; the layouts of built-in classes
+(defvar *built-in-class-codes*) ; initialized in cold load
+(declaim (type simple-vector *built-in-class-codes*))
+
+(!cold-init-forms
+ #-sb-xc-host (/show0 "about to set *BUILT-IN-CLASS-CODES*")
+ (setq *built-in-class-codes*
+ (let* ((initial-element
+ (locally
+ ;; KLUDGE: There's a FIND-CLASS DEFTRANSFORM for
+ ;; constant class names which creates fast but
+ ;; non-cold-loadable, non-compact code. In this
+ ;; context, we'd rather have compact, cold-loadable
+ ;; code. -- WHN 19990928
+ (declare (notinline sb!xc:find-class))
+ (class-layout (sb!xc:find-class 'random-class))))
+ (res (make-array 256 :initial-element initial-element)))
+ (dolist (x *built-in-classes* res)
+ (destructuring-bind (name &key codes &allow-other-keys)
+ x
+ (let ((layout (class-layout (sb!xc:find-class name))))
+ (dolist (code codes)
+ (setf (svref res code) layout)))))))
+ #-sb-xc-host (/show0 "done setting *BUILT-IN-CLASS-CODES*"))
+\f
+(!defun-from-collected-cold-init-forms !classes-cold-init)
--- /dev/null
+;;;; COERCE and related code
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!IMPL")
+
+(file-comment
+ "$Header$")
+
+(macrolet ((def-frob (name result access src-type &optional typep)
+ `(defun ,name (object ,@(if typep '(type) ()))
+ (do* ((index 0 (1+ index))
+ (length (length (the ,(ecase src-type
+ (:list 'list)
+ (:vector 'vector))
+ object)))
+ (result ,result)
+ (in-object object))
+ ((= index length) result)
+ (declare (fixnum length index))
+ (setf (,access result index)
+ ,(ecase src-type
+ (:list '(pop in-object))
+ (:vector '(aref in-object index))))))))
+
+ (def-frob list-to-simple-string* (make-string length) schar :list)
+
+ (def-frob list-to-bit-vector* (make-array length :element-type '(mod 2))
+ sbit :list)
+
+ (def-frob list-to-vector* (make-sequence-of-type type length)
+ aref :list t)
+
+ (def-frob vector-to-vector* (make-sequence-of-type type length)
+ aref :vector t)
+
+ (def-frob vector-to-simple-string* (make-string length) schar :vector)
+
+ (def-frob vector-to-bit-vector* (make-array length :element-type '(mod 2))
+ sbit :vector))
+
+(defun vector-to-list* (object)
+ (let ((result (list nil))
+ (length (length object)))
+ (declare (fixnum length))
+ (do ((index 0 (1+ index))
+ (splice result (cdr splice)))
+ ((= index length) (cdr result))
+ (declare (fixnum index))
+ (rplacd splice (list (aref object index))))))
+
+(defun string-to-simple-string* (object)
+ (if (simple-string-p object)
+ object
+ (with-array-data ((data object)
+ (start)
+ (end (length object)))
+ (declare (simple-string data))
+ (subseq data start end))))
+
+(defun bit-vector-to-simple-bit-vector* (object)
+ (if (simple-bit-vector-p object)
+ object
+ (with-array-data ((data object)
+ (start)
+ (end (length object)))
+ (declare (simple-bit-vector data))
+ (subseq data start end))))
+
+(defvar *offending-datum*); FIXME: Remove after debugging COERCE.
+
+;;; These are used both by the full DEFUN function and by various
+;;; optimization transforms in the constant-OUTPUT-TYPE-SPEC case.
+;;;
+;;; Most of them are INLINE so that they can be optimized when the
+;;; argument type is known. It might be better to do this with
+;;; DEFTRANSFORMs, though.
+(declaim (inline coerce-to-list))
+(declaim (inline coerce-to-simple-string coerce-to-bit-vector coerce-to-vector))
+(defun coerce-to-function (object)
+ ;; (Unlike the other COERCE-TO-FOOs, this one isn't inline, because
+ ;; it's so big and because optimizing away the outer ETYPECASE
+ ;; doesn't seem to buy us that much anyway.)
+ (etypecase object
+ (symbol
+ ;; ANSI lets us return ordinary errors (non-TYPE-ERRORs) here.
+ (cond ((macro-function object)
+ (error "~S names a macro." object))
+ ((special-operator-p object)
+ (error "~S is a special operator." object))
+ (t (fdefinition object))))
+ (list
+ (case (first object)
+ ((setf)
+ (fdefinition object))
+ ((lambda instance-lambda)
+ ;; FIXME: If we go to a compiler-only implementation, this can
+ ;; become COMPILE instead of EVAL, which seems nicer to me.
+ (eval `(function ,object)))
+ (t
+ (error 'simple-type-error
+ :datum object
+ :expected-type '(or symbol
+ ;; KLUDGE: ANSI wants us to
+ ;; return a TYPE-ERROR here, and
+ ;; a TYPE-ERROR is supposed to
+ ;; describe the expected type,
+ ;; but it's not obvious how to
+ ;; describe the coerceable cons
+ ;; types, so we punt and just say
+ ;; CONS. -- WHN 20000503
+ cons)
+ :format-control "~S can't be coerced to a function."
+ :format-arguments (list object)))))))
+(defun coerce-to-list (object)
+ (etypecase object
+ (vector (vector-to-list* object))))
+(defun coerce-to-simple-string (object)
+ (etypecase object
+ (list (list-to-simple-string* object))
+ (string (string-to-simple-string* object))
+ (vector (vector-to-simple-string* object))))
+(defun coerce-to-bit-vector (object)
+ (etypecase object
+ (list (list-to-bit-vector* object))
+ (vector (vector-to-bit-vector* object))))
+(defun coerce-to-vector (object output-type-spec)
+ (etypecase object
+ (list (list-to-vector* object output-type-spec))
+ (vector (vector-to-vector* object output-type-spec))))
+
+;;; old working version
+(defun coerce (object output-type-spec)
+ #!+sb-doc
+ "Coerces the Object to an object of type Output-Type-Spec."
+ (flet ((coerce-error ()
+ (/show0 "entering COERCE-ERROR")
+ (error 'simple-type-error
+ :format-control "~S can't be converted to type ~S."
+ :format-arguments (list object output-type-spec)))
+ (check-result (result)
+ #!+high-security
+ (check-type-var result output-type-spec)
+ result))
+ (let ((type (specifier-type output-type-spec)))
+ (cond
+ ((%typep object output-type-spec)
+ object)
+ ((eq type *empty-type*)
+ (coerce-error))
+ ((csubtypep type (specifier-type 'character))
+ (character object))
+ ((csubtypep type (specifier-type 'function))
+ #!+high-security
+ (when (and (or (symbolp object)
+ (and (listp object)
+ (= (length object) 2)
+ (eq (car object) 'setf)))
+ (not (fboundp object)))
+ (error 'simple-type-error
+ :datum object
+ :expected-type '(satisfies fboundp)
+ :format-control "~S isn't fbound."
+ :format-arguments (list object)))
+ #!+high-security
+ (when (and (symbolp object)
+ (sb!xc:macro-function object))
+ (error 'simple-type-error
+ :datum object
+ :expected-type '(not (satisfies sb!xc:macro-function))
+ :format-control "~S is a macro."
+ :format-arguments (list object)))
+ #!+high-security
+ (when (and (symbolp object)
+ (special-operator-p object))
+ (error 'simple-type-error
+ :datum object
+ :expected-type '(not (satisfies special-operator-p))
+ :format-control "~S is a special operator."
+ :format-arguments (list object)))
+ (eval `#',object))
+ ((numberp object)
+ (let ((res
+ (cond
+ ((csubtypep type (specifier-type 'single-float))
+ (%single-float object))
+ ((csubtypep type (specifier-type 'double-float))
+ (%double-float object))
+ #!+long-float
+ ((csubtypep type (specifier-type 'long-float))
+ (%long-float object))
+ ((csubtypep type (specifier-type 'float))
+ (%single-float object))
+ ((csubtypep type (specifier-type '(complex single-float)))
+ (complex (%single-float (realpart object))
+ (%single-float (imagpart object))))
+ ((csubtypep type (specifier-type '(complex double-float)))
+ (complex (%double-float (realpart object))
+ (%double-float (imagpart object))))
+ #!+long-float
+ ((csubtypep type (specifier-type '(complex long-float)))
+ (complex (%long-float (realpart object))
+ (%long-float (imagpart object))))
+ ((csubtypep type (specifier-type 'complex))
+ (complex object))
+ (t
+ (coerce-error)))))
+ ;; If RES has the wrong type, that means that rule of canonical
+ ;; representation for complex rationals was invoked. According to
+ ;; the Hyperspec, (coerce 7/2 'complex) returns 7/2. Thus, if the
+ ;; object was a rational, there is no error here.
+ (unless (or (typep res output-type-spec) (rationalp object))
+ (coerce-error))
+ res))
+ ((csubtypep type (specifier-type 'list))
+ (if (vectorp object)
+ (vector-to-list* object)
+ (coerce-error)))
+ ((csubtypep type (specifier-type 'string))
+ (check-result
+ (typecase object
+ (list (list-to-simple-string* object))
+ (string (string-to-simple-string* object))
+ (vector (vector-to-simple-string* object))
+ (t
+ (coerce-error)))))
+ ((csubtypep type (specifier-type 'bit-vector))
+ (check-result
+ (typecase object
+ (list (list-to-bit-vector* object))
+ (vector (vector-to-bit-vector* object))
+ (t
+ (coerce-error)))))
+ ((csubtypep type (specifier-type 'vector))
+ (check-result
+ (typecase object
+ (list (list-to-vector* object output-type-spec))
+ (vector (vector-to-vector* object output-type-spec))
+ (t
+ (coerce-error)))))
+ (t
+ (coerce-error))))))
+
+;;; new version, which seems as though it should be better, but which
+;;; does not yet work
+#+nil
+(defun coerce (object output-type-spec)
+ #!+sb-doc
+ "Coerces the Object to an object of type Output-Type-Spec."
+ (flet ((coerce-error ()
+ (error 'simple-type-error
+ :format-control "~S can't be converted to type ~S."
+ :format-arguments (list object output-type-spec)))
+ (check-result (result)
+ #!+high-security
+ (check-type-var result output-type-spec)
+ result))
+ (let ((type (specifier-type output-type-spec)))
+ (cond
+ ((%typep object output-type-spec)
+ object)
+ ((eq type *empty-type*)
+ (coerce-error))
+ ((csubtypep type (specifier-type 'character))
+ (character object))
+ ((csubtypep type (specifier-type 'function))
+ (coerce-to-function object))
+ ((numberp object)
+ (let ((res
+ (cond
+ ((csubtypep type (specifier-type 'single-float))
+ (%single-float object))
+ ((csubtypep type (specifier-type 'double-float))
+ (%double-float object))
+ #!+long-float
+ ((csubtypep type (specifier-type 'long-float))
+ (%long-float object))
+ ((csubtypep type (specifier-type 'float))
+ (%single-float object))
+ ((csubtypep type (specifier-type '(complex single-float)))
+ (complex (%single-float (realpart object))
+ (%single-float (imagpart object))))
+ ((csubtypep type (specifier-type '(complex double-float)))
+ (complex (%double-float (realpart object))
+ (%double-float (imagpart object))))
+ #!+long-float
+ ((csubtypep type (specifier-type '(complex long-float)))
+ (complex (%long-float (realpart object))
+ (%long-float (imagpart object))))
+ ((csubtypep type (specifier-type 'complex))
+ (complex object))
+ (t
+ (coerce-error)))))
+ ;; If RES has the wrong type, that means that rule of
+ ;; canonical representation for complex rationals was
+ ;; invoked. According to the ANSI spec, (COERCE 7/2
+ ;; 'COMPLEX) returns 7/2. Thus, if the object was a
+ ;; rational, there is no error here.
+ (unless (or (typep res output-type-spec) (rationalp object))
+ (coerce-error))
+ res))
+ ((csubtypep type (specifier-type 'list))
+ (coerce-to-list object))
+ ((csubtypep type (specifier-type 'string))
+ (check-result (coerce-to-simple-string object)))
+ ((csubtypep type (specifier-type 'bit-vector))
+ (check-result (coerce-to-bit-vector object)))
+ ((csubtypep type (specifier-type 'vector))
+ (check-result (coerce-to-vector object output-type-spec)))
+ (t
+ (coerce-error))))))
--- /dev/null
+;;;; miscellaneous stuff that needs to be in the cold load which would
+;;;; otherwise be byte-compiled
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!CONDITIONS")
+
+(sb!int:file-comment
+ "$Header$")
+
+(defvar *break-on-signals* nil
+ #!+sb-doc
+ "When (TYPEP condition *BREAK-ON-SIGNALS*) is true, then calls to SIGNAL will
+ enter the debugger prior to signalling that condition.")
+
+(defun signal (datum &rest arguments)
+ #!+sb-doc
+ "Invokes the signal facility on a condition formed from DATUM and
+ ARGUMENTS. If the condition is not handled, NIL is returned. If
+ (TYPEP condition *BREAK-ON-SIGNALS*) is true, the debugger is invoked
+ before any signalling is done."
+ (let ((condition (coerce-to-condition datum
+ arguments
+ 'simple-condition
+ 'signal))
+ (*handler-clusters* *handler-clusters*))
+ (let ((old-bos *break-on-signals*)
+ (*break-on-signals* nil))
+ (when (typep condition old-bos)
+ (break "~A~%BREAK was entered because of *BREAK-ON-SIGNALS* (now NIL)."
+ condition)))
+ (loop
+ (unless *handler-clusters* (return))
+ (let ((cluster (pop *handler-clusters*)))
+ (dolist (handler cluster)
+ (when (typep condition (car handler))
+ (funcall (cdr handler) condition)))))
+ nil))
+
+;;; COERCE-TO-CONDITION is used in SIGNAL, ERROR, CERROR, WARN, and
+;;; INVOKE-DEBUGGER for parsing the hairy argument conventions into a single
+;;; argument that's directly usable by all the other routines.
+(defun coerce-to-condition (datum arguments default-type function-name)
+ (cond ((typep datum 'condition)
+ (if arguments
+ (cerror "Ignore the additional arguments."
+ 'simple-type-error
+ :datum arguments
+ :expected-type 'null
+ :format-control "You may not supply additional arguments ~
+ when giving ~S to ~S."
+ :format-arguments (list datum function-name)))
+ datum)
+ ((symbolp datum) ; roughly, (SUBTYPEP DATUM 'CONDITION)
+ (apply #'make-condition datum arguments))
+ ((or (stringp datum) (functionp datum))
+ (make-condition default-type
+ :format-control datum
+ :format-arguments arguments))
+ (t
+ (error 'simple-type-error
+ :datum datum
+ :expected-type '(or symbol string)
+ :format-control "bad argument to ~S: ~S"
+ :format-arguments (list function-name datum)))))
+
+(defun error (datum &rest arguments)
+ #!+sb-doc
+ "Invoke the signal facility on a condition formed from datum and arguments.
+ If the condition is not handled, the debugger is invoked."
+ (/show0 "entering ERROR")
+ #!+sb-show
+ (unless *cold-init-complete-p*
+ (/show0 "ERROR in cold init, arguments=..")
+ #!+sb-show (dolist (argument arguments)
+ (sb!impl::cold-print argument)))
+ (sb!kernel:infinite-error-protect
+ (let ((condition (coerce-to-condition datum arguments
+ 'simple-error 'error))
+ ;; FIXME: Why is *STACK-TOP-HINT* in SB-DEBUG instead of SB-DI?
+ ;; SB-DEBUG should probably be only for true interface stuff.
+ (sb!debug:*stack-top-hint* sb!debug:*stack-top-hint*))
+ (unless (and (condition-function-name condition)
+ sb!debug:*stack-top-hint*)
+ (multiple-value-bind (name frame) (sb!kernel:find-caller-name)
+ (unless (condition-function-name condition)
+ (setf (condition-function-name condition) name))
+ (unless sb!debug:*stack-top-hint*
+ (setf sb!debug:*stack-top-hint* frame))))
+ (let ((sb!debug:*stack-top-hint* nil))
+ (signal condition))
+ (invoke-debugger condition))))
+
+(defun cerror (continue-string datum &rest arguments)
+ (sb!kernel:infinite-error-protect
+ (with-simple-restart
+ (continue "~A" (apply #'format nil continue-string arguments))
+ (let ((condition (if (typep datum 'condition)
+ datum
+ (coerce-to-condition datum
+ arguments
+ 'simple-error
+ 'error)))
+ (sb!debug:*stack-top-hint* sb!debug:*stack-top-hint*))
+ (unless (and (condition-function-name condition)
+ sb!debug:*stack-top-hint*)
+ (multiple-value-bind (name frame) (sb!kernel:find-caller-name)
+ (unless (condition-function-name condition)
+ (setf (condition-function-name condition) name))
+ (unless sb!debug:*stack-top-hint*
+ (setf sb!debug:*stack-top-hint* frame))))
+ (with-condition-restarts condition (list (find-restart 'continue))
+ (let ((sb!debug:*stack-top-hint* nil))
+ (signal condition))
+ (invoke-debugger condition)))))
+ nil)
+
+(defun break (&optional (datum "break") &rest arguments)
+ #!+sb-doc
+ "Print a message and invoke the debugger without allowing any possibility
+ of condition handling occurring."
+ (sb!kernel:infinite-error-protect
+ (with-simple-restart (continue "Return from BREAK.")
+ (let ((sb!debug:*stack-top-hint*
+ (or sb!debug:*stack-top-hint*
+ (nth-value 1 (sb!kernel:find-caller-name)))))
+ (invoke-debugger
+ (coerce-to-condition datum arguments 'simple-condition 'break)))))
+ nil)
+
+(defun warn (datum &rest arguments)
+ #!+sb-doc
+ "Warn about a situation by signalling a condition formed by DATUM and
+ ARGUMENTS. While the condition is being signaled, a MUFFLE-WARNING restart
+ exists that causes WARN to immediately return NIL."
+ (/noshow0 "entering WARN")
+ ;; KLUDGE: The current cold load initialization logic causes several calls
+ ;; to WARN, so we need to be able to handle them without dying. (And calling
+ ;; FORMAT or even PRINC in cold load is a good way to die.) Of course, the
+ ;; ideal would be to clean up cold load so that it doesn't call WARN..
+ ;; -- WHN 19991009
+ (if (not *cold-init-complete-p*)
+ (progn
+ (/show0 "ignoring WARN in cold init, arguments=..")
+ #!+sb-show (dolist (argument arguments)
+ (sb!impl::cold-print argument)))
+ (sb!kernel:infinite-error-protect
+ (let ((condition (coerce-to-condition datum arguments
+ 'simple-warning 'warn)))
+ (check-type condition warning "a warning condition")
+ (restart-case (signal condition)
+ (muffle-warning ()
+ :report "Skip warning."
+ (return-from warn nil)))
+ (let ((badness (etypecase condition
+ (style-warning 'style-warning)
+ (warning 'warning))))
+ (format *error-output*
+ "~&~@<~S: ~3i~:_~A~:>~%"
+ badness
+ condition)))))
+ nil)
--- /dev/null
+;;;; This file contains machinery for collecting forms that, in the
+;;;; target Lisp, must happen before top level forms are run. The
+;;;; forms are stuffed into named functions which will be explicitly
+;;;; called in the appropriate order by !COLD-INIT.
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!KERNEL")
+;;; FIXME: Perhaps this belongs in the %SYS package like some other
+;;; cold load stuff.
+
+(file-comment
+ "$Header$")
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defvar *cold-init-forms*))
+
+(defmacro !begin-collecting-cold-init-forms ()
+ #-sb-xc-host '(eval-when (:compile-toplevel :execute)
+ (when (boundp '*cold-init-forms*)
+ (warn "discarding old *COLD-INIT-FORMS* value"))
+ (setf *cold-init-forms* nil))
+ #+sb-xc-host nil)
+
+;;; Note: Unlike the analogous COLD-INIT macro in CMU CL, this macro
+;;; makes no attempt to simulate a top-level situation by treating
+;;; EVAL-WHEN forms specially.
+(defmacro !cold-init-forms (&rest forms)
+ ;; In the target Lisp, stuff the forms into a named function which
+ ;; will presumably be executed at the appropriate stage of cold load
+ ;; (i.e. basically as soon as possible).
+ #-sb-xc-host (progn
+ (setf *cold-init-forms*
+ (nconc *cold-init-forms* (copy-list forms)))
+ nil)
+ ;; In the cross-compilation host Lisp, cold load might not be a
+ ;; meaningful concept and in any case would have happened long ago,
+ ;; so just execute the forms at load time (i.e. basically as soon as
+ ;; possible).
+ #+sb-xc-host `(let () ,@forms))
+
+(defmacro !defun-from-collected-cold-init-forms (name)
+ #-sb-xc-host `(progn
+ (defun ,name ()
+ ,@*cold-init-forms*
+ (values))
+ (eval-when (:compile-toplevel :execute)
+ (makunbound '*cold-init-forms*)))
+ #+sb-xc-host (declare (ignore name)))
+
+;;; FIXME: These macros should be byte-compiled.
+
+;;; FIXME: Consider renaming this file asap.lisp,
+;;; and the renaming the various things
+;;; *ASAP-FORMS* or *REVERSED-ASAP-FORMS*
+;;; WITH-ASAP-FORMS
+;;; ASAP or EVAL-WHEN-COLD-LOAD
+;;; DEFUN-FROM-ASAP-FORMS
+;;; If so, add a comment explaining that ASAP is colloquial English for "as
+;;; soon as possible", and has nothing to do with "system area pointer".
--- /dev/null
+;;;; cold initialization stuff, plus some other miscellaneous stuff
+;;;; that we don't have any better place for
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!IMPL")
+
+(file-comment
+ "$Header$")
+\f
+;;;; burning our ships behind us
+
+;;; There's a fair amount of machinery which is needed only at cold
+;;; init time, and should be discarded before freezing the final
+;;; system. We discard it by uninterning the associated symbols.
+;;; Rather than using a special table of symbols to be uninterned,
+;;; which might be tedious to maintain, instead we use a hack:
+;;; anything whose name matches a magic character pattern is
+;;; uninterned.
+(defun !unintern-init-only-stuff ()
+ (do ((any-changes? nil nil))
+ (nil)
+ (dolist (package (list-all-packages))
+ (do-symbols (symbol package)
+ (let ((name (symbol-name symbol)))
+ (when (or (string= name "!" :end1 1 :end2 1)
+ (and (>= (length name) 2)
+ (string= name "*!" :end1 2 :end2 2)))
+ (/show0 "uninterning cold-init-only symbol..")
+ #!+sb-show (%primitive print name)
+ (unintern symbol package)
+ (setf any-changes? t)))))
+ (unless any-changes?
+ (return))))
+\f
+;;;; !COLD-INIT
+
+;;; a list of toplevel things set by GENESIS
+(defvar *!reversed-cold-toplevels*)
+
+;;; a SIMPLE-VECTOR set by genesis
+(defvar *!load-time-values*)
+
+#!+gengc
+(defun do-load-time-value-fixup (object offset index)
+ (declare (type index offset))
+ (macrolet ((lose (msg)
+ `(progn
+ (%primitive print ,msg)
+ (%halt))))
+ (let ((value (svref *!load-time-values* index)))
+ (typecase object
+ (list
+ (case offset
+ (0 (setf (car object) value))
+ (1 (setf (cdr object) value))
+ (t (lose "bogus offset in cons cell"))))
+ (instance
+ (setf (%instance-ref object (- offset sb!vm:instance-slots-offset))
+ value))
+ (code-component
+ (setf (code-header-ref object offset) value))
+ (simple-vector
+ (setf (svref object (- offset sb!vm:vector-data-offset)) value))
+ (t
+ (lose "unknown kind of object for load-time-value fixup"))))))
+
+(eval-when (:compile-toplevel :execute)
+ ;; FIXME: Perhaps we should make SHOW-AND-CALL-AND-FMAKUNBOUND, too,
+ ;; and use it for most of the cold-init functions. (Just be careful
+ ;; not to use it for the COLD-INIT-OR-REINIT functions.)
+ (sb!xc:defmacro show-and-call (name)
+ `(progn
+ #!+sb-show (%primitive print ,(symbol-name name))
+ (,name))))
+
+;;; called when a cold system starts up
+(defun !cold-init ()
+ #!+sb-doc "Give the world a shove and hope it spins."
+
+ (/show0 "entering !COLD-INIT")
+
+ ;; FIXME: It'd probably be cleaner to have most of the stuff here
+ ;; handled by calls a la !GC-COLD-INIT, !ERROR-COLD-INIT, and
+ ;; !UNIX-COLD-INIT. And *TYPE-SYSTEM-INITIALIZED* could be changed to
+ ;; *TYPE-SYSTEM-INITIALIZED-WHEN-BOUND* so that it doesn't need to
+ ;; be explicitly set in order to be meaningful.
+ (setf *gc-verbose* nil)
+ (setf *gc-notify-stream* nil)
+ (setf *before-gc-hooks* nil)
+ (setf *after-gc-hooks* nil)
+ #!+gengc (setf sb!conditions::*handler-clusters* nil)
+ #!-gengc (setf *already-maybe-gcing* t
+ *gc-inhibit* t
+ *need-to-collect-garbage* nil
+ sb!unix::*interrupts-enabled* t
+ sb!unix::*interrupt-pending* nil)
+ (setf *break-on-signals* nil)
+ (setf *maximum-error-depth* 10)
+ (setf *current-error-depth* 0)
+ (setf *cold-init-complete-p* nil)
+ (setf *type-system-initialized* nil)
+
+ ;; Anyone might call RANDOM to initialize a hash value or something;
+ ;; and there's nothing which needs to be initialized in order for
+ ;; this to be initialized, so we initialize it right away.
+ (show-and-call !random-cold-init)
+
+ ;; All sorts of things need INFO and/or (SETF INFO).
+ (show-and-call !globaldb-cold-init)
+
+ ;; This needs to be done early, but needs to be after INFO is
+ ;; initialized.
+ (show-and-call !fdefn-cold-init)
+
+ ;; Various toplevel forms call MAKE-ARRAY, which calls SUBTYPEP, so
+ ;; the basic type machinery needs to be initialized before toplevel
+ ;; forms run.
+ (show-and-call !type-class-cold-init)
+ (show-and-call !typedefs-cold-init)
+ (show-and-call !classes-cold-init)
+ (show-and-call !early-type-cold-init)
+ (show-and-call !late-type-cold-init)
+ (show-and-call !alien-type-cold-init)
+ (show-and-call !target-type-cold-init)
+ (show-and-call !vm-type-cold-init)
+ ;; FIXME: It would be tidy to make sure that that these cold init
+ ;; functions are called in the same relative order as the toplevel
+ ;; forms of the corresponding source files.
+
+ (show-and-call !package-cold-init)
+
+ ;; Set sane values for our toplevel forms.
+ (show-and-call !set-sane-cookie-defaults)
+
+ ;; KLUDGE: Why are fixups mixed up with toplevel forms? Couldn't
+ ;; fixups be done separately? Wouldn't that be clearer and better?
+ ;; -- WHN 19991204
+ (/show0 "doing cold toplevel forms and fixups")
+ (/show0 "(LENGTH *!REVERSED-COLD-TOPLEVELS*)=..")
+ #!+sb-show (%primitive print
+ (sb!impl::hexstr (length *!reversed-cold-toplevels*)))
+ (let (#!+sb-show (index-in-cold-toplevels 0)
+ #!+sb-show (filename-in-cold-toplevels nil))
+ #!+sb-show (declare (type fixnum index-in-cold-toplevels))
+ (dolist (toplevel-thing (prog1
+ (nreverse *!reversed-cold-toplevels*)
+ ;; (Now that we've NREVERSEd it, it's
+ ;; somewhat scrambled, so keep anyone
+ ;; else from trying to get at it.)
+ (makunbound '*!reversed-cold-toplevels*)))
+ #!+sb-show
+ (when (zerop (mod index-in-cold-toplevels 1024))
+ (/show0 "INDEX-IN-COLD-TOPLEVELS=..")
+ (%primitive print (sb!impl::hexstr index-in-cold-toplevels)))
+ #!+sb-show
+ (setf index-in-cold-toplevels
+ (the fixnum (1+ index-in-cold-toplevels)))
+ (typecase toplevel-thing
+ (function
+ (funcall toplevel-thing))
+ (cons
+ (case (first toplevel-thing)
+ (:load-time-value
+ (setf (svref *!load-time-values* (third toplevel-thing))
+ (funcall (second toplevel-thing))))
+ (:load-time-value-fixup
+ #!-gengc
+ (setf (sap-ref-32 (second toplevel-thing) 0)
+ (get-lisp-obj-address
+ (svref *!load-time-values* (third toplevel-thing))))
+ #!+gengc
+ (do-load-time-value-fixup (second toplevel-thing)
+ (third toplevel-thing)
+ (fourth toplevel-thing)))
+ #!+(and x86 gencgc)
+ (:load-time-code-fixup
+ (sb!vm::do-load-time-code-fixup (second toplevel-thing)
+ (third toplevel-thing)
+ (fourth toplevel-thing)
+ (fifth toplevel-thing)))
+ (t
+ (%primitive print
+ "bogus fixup code in *!REVERSED-COLD-TOPLEVELS*")
+ (%halt))))
+ (t
+ (%primitive print "bogus function in *!REVERSED-COLD-TOPLEVELS*")
+ (%halt)))))
+ (/show0 "done with loop over cold toplevel forms and fixups")
+
+ ;; Set sane values again, so that the user sees sane values instead of
+ ;; whatever is left over from the last DECLAIM.
+ (show-and-call !set-sane-cookie-defaults)
+
+ ;; Only do this after top level forms have run, 'cause that's where
+ ;; DEFTYPEs are.
+ (setf *type-system-initialized* t)
+
+ (show-and-call os-cold-init-or-reinit)
+ (show-and-call !filesys-cold-init)
+
+ (show-and-call stream-cold-init-or-reset)
+ (show-and-call !loader-cold-init)
+ (show-and-call signal-cold-init-or-reinit)
+ (setf (sb!alien:extern-alien "internal_errors_enabled" boolean) t)
+
+ ;; FIXME: This list of modes should be defined in one place and
+ ;; explicitly shared between here and REINIT.
+ (set-floating-point-modes :traps '(:overflow
+ #!-x86 :underflow
+ :invalid
+ :divide-by-zero))
+
+ (show-and-call !class-finalize)
+
+ ;; The reader and printer are initialized very late, so that they
+ ;; can even do hairy things like invoking the compiler as part of
+ ;; their initialization.
+ (show-and-call !reader-cold-init)
+ (let ((*readtable* *standard-readtable*))
+ (show-and-call !sharpm-cold-init)
+ (show-and-call !backq-cold-init))
+ (setf *readtable* (copy-readtable *standard-readtable*))
+ (setf sb!debug:*debug-readtable* (copy-readtable *standard-readtable*))
+ (sb!pretty:!pprint-cold-init)
+
+ ;; the ANSI-specified initial value of *PACKAGE*
+ (setf *package* (find-package "COMMON-LISP-USER"))
+ ;; FIXME: I'm not sure where it should be done, but CL-USER really
+ ;; ought to USE-PACKAGE publicly accessible packages like SB-DEBUG
+ ;; (for ARG and VAR), SB-EXT, SB-EXT-C-CALL, and SB-EXT-ALIEN so
+ ;; that the user has a hint about which symbols we consider public.
+ ;; (Perhaps SB-DEBUG wouldn't need to be in the list if ARG and VAR
+ ;; could be typed directly, with no parentheses, at the debug prompt
+ ;; the way that e.g. F or BACKTRACE can be?)
+
+ (/show0 "done initializing")
+ (setf *cold-init-complete-p* t)
+
+ ;; Unintern no-longer-needed stuff before we GC.
+ #!-sb-fluid
+ (!unintern-init-only-stuff)
+
+ ;; The system is finally ready for GC.
+ #!-gengc (setf *already-maybe-gcing* nil)
+ (/show0 "enabling GC")
+ (gc-on)
+ (/show0 "doing first GC")
+ (gc :full t)
+ (/show0 "back from first GC")
+
+ ;; The show is on.
+ (terpri)
+ (/show0 "going into toplevel loop")
+ (let ((wot (catch '%end-of-the-world
+ (/show0 "inside CATCH '%END-OF-THE-WORLD")
+ (toplevel))))
+ (flush-standard-output-streams)
+ (sb!unix:unix-exit wot)))
+
+(defun quit (&key recklessly-p (unix-code 0))
+ #!+sb-doc
+ "Terminate the current Lisp. Things are cleaned up (with UNWIND-PROTECT
+ and so forth) unless RECKLESSLY-P is non-NIL. On UNIX-like systems,
+ UNIX-CODE is used as the status code."
+ (declare (type (signed-byte 32) unix-code))
+ (if recklessly-p
+ (sb!unix:unix-exit unix-code)
+ (throw '%end-of-the-world unix-code)))
+\f
+;;;; initialization functions
+
+(defun reinit ()
+ (without-interrupts
+ (without-gcing
+ (os-cold-init-or-reinit)
+ (stream-reinit)
+ (signal-cold-init-or-reinit)
+ (gc-cold-init-or-reinit)
+ (setf (sb!alien:extern-alien "internal_errors_enabled" boolean) t)
+ (set-floating-point-modes :traps
+ ;; PRINT seems to not like x86 NPX denormal
+ ;; floats like LEAST-NEGATIVE-SINGLE-FLOAT, so
+ ;; the :UNDERFLOW exceptions are disabled by
+ ;; default. Joe User can explicitly enable them
+ ;; if desired.
+ '(:overflow #!-x86 :underflow :invalid
+ :divide-by-zero))
+ ;; Clear pseudo atomic in case this core wasn't compiled with
+ ;; support.
+ ;;
+ ;; FIXME: In SBCL our cores are always compiled with support. So
+ ;; we don't need to do this, do we? At least not for this
+ ;; reason.. (Perhaps we should do it anyway in case someone
+ ;; manages to save an image from within a pseudo-atomic-atomic
+ ;; operation?)
+ #!+x86 (setf sb!impl::*pseudo-atomic-atomic* 0))
+ (gc-on)))
+\f
+;;;; some support for any hapless wretches who end up debugging cold
+;;;; init code
+
+;;; Decode THING into hex using only machinery available early in cold
+;;; init.
+#!+sb-show
+(defun hexstr (thing)
+ (let ((addr (sb!kernel:get-lisp-obj-address thing))
+ (str (make-string 10)))
+ (setf (char str 0) #\0
+ (char str 1) #\x)
+ (dotimes (i 8)
+ (let* ((nibble (ldb (byte 4 0) addr))
+ (chr (char "0123456789abcdef" nibble)))
+ (declare (type (unsigned-byte 4) nibble)
+ (base-char chr))
+ (setf (char str (- 9 i)) chr
+ addr (ash addr -4))))
+ str))
+
+#!+sb-show
+(defun cold-print (x)
+ (typecase x
+ (simple-string (sb!sys:%primitive print x))
+ (symbol (sb!sys:%primitive print (symbol-name x)))
+ (list (let ((count 0))
+ (sb!sys:%primitive print "list:")
+ (dolist (i x)
+ (when (>= (incf count) 4)
+ (sb!sys:%primitive print "...")
+ (return))
+ (cold-print i))))
+ (t (sb!sys:%primitive print (hexstr x)))))
--- /dev/null
+;;;; portable implementations or stubs for nonportable floating point
+;;;; things, useful for building Python as a cross-compiler when
+;;;; running under an ordinary ANSI Common Lisp implementation
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!IMPL")
+
+(file-comment
+ "$Header$")
+
+;;; There seems to be no portable way to mask float traps, but we shouldn't
+;;; encounter any float traps when cross-compiling SBCL itself, anyway, so we
+;;; just make this a no-op.
+(defmacro sb!vm::with-float-traps-masked (traps &body body)
+ (declare (ignore traps))
+ ;; FIXME: should become STYLE-WARNING?
+ (format *error-output*
+ "~&(can't portably mask float traps, proceeding anyway)~%")
+ `(progn ,@body))
+
+;;; a helper function for DOUBLE-FLOAT-FOO-BITS functions
+;;;
+;;; Return the low N bits of X as a signed N-bit value.
+(defun mask-and-sign-extend (x n)
+ (assert (plusp n))
+ (let* ((high-bit (ash 1 (1- n)))
+ (mask (1- (ash high-bit 1)))
+ (uresult (logand mask x)))
+ (if (zerop (logand uresult high-bit))
+ uresult
+ (logior uresult
+ (logand -1 (lognot mask))))))
+
+;;; portable implementations of SINGLE-FLOAT-BITS, DOUBLE-FLOAT-LOW-BITS, and
+;;; DOUBLE-FLOAT-HIGH-BITS
+;;;
+;;; KLUDGE: These will fail if the target's floating point isn't IEEE, and so
+;;; I'd be more comfortable if there were an assertion "target's floating point
+;;; is IEEE" in the code, but I can't see how to express that.
+;;;
+;;; KLUDGE: It's sort of weird that these functions return signed 32-bit values
+;;; instead of unsigned 32-bit values. This is the way that the CMU CL
+;;; machine-dependent functions behaved, and I've copied that behavior, but it
+;;; seems to me that it'd be more idiomatic to return unsigned 32-bit values.
+;;; Maybe someday the machine-dependent functions could be tweaked to return
+;;; unsigned 32-bit values?
+(defun single-float-bits (x)
+ (declare (type single-float x))
+ (assert (= (float-radix x) 2))
+ (if (zerop x)
+ 0 ; known property of IEEE floating point: 0.0 is represented as 0.
+ (multiple-value-bind (lisp-significand lisp-exponent lisp-sign)
+ (integer-decode-float x)
+ (assert (plusp lisp-significand))
+ ;; Calculate IEEE-style fields from Common-Lisp-style fields.
+ ;;
+ ;; KLUDGE: This code was written from my foggy memory of what IEEE
+ ;; format looks like, augmented by some experiments with
+ ;; the existing implementation of SINGLE-FLOAT-BITS, and what
+ ;; I found floating around on the net at
+ ;; <http://www.scri.fsu.edu/~jac/MAD3401/Backgrnd/ieee.html>,
+ ;; <http://rodin.cs.uh.edu/~johnson2/ieee.html>,
+ ;; and
+ ;; <http://www.ttu.ee/sidu/cas/IEEE_Floating.htm>.
+ ;; And beyond the probable sheer flakiness of the code, all the bare
+ ;; numbers floating around here are sort of ugly, too. -- WHN 19990711
+ (let* ((significand lisp-significand)
+ (exponent (+ lisp-exponent 23 127))
+ (unsigned-result
+ (if (plusp exponent) ; if not obviously denormalized
+ (do ()
+ (nil)
+ (cond (;; ordinary termination case
+ (>= significand (expt 2 23))
+ (assert (< 0 significand (expt 2 24)))
+ ;; Exponent 0 is reserved for denormalized numbers,
+ ;; and 255 is reserved for specials a la NaN.
+ (assert (< 0 exponent 255))
+ (return (logior (ash exponent 23)
+ (logand significand
+ (1- (ash 1 23))))))
+ (;; special termination case, denormalized float number
+ (zerop exponent)
+ ;; Denormalized numbers have exponent one greater than
+ ;; the exponent field.
+ (return (ash significand -1)))
+ (t
+ ;; Shift as necessary to set bit 24 of significand.
+ (setf significand (ash significand 1)
+ exponent (1- exponent)))))
+ (do ()
+ ((zerop exponent)
+ ;; Denormalized numbers have exponent one greater than the
+ ;; exponent field.
+ (ash significand -1))
+ (unless (zerop (logand significand 1))
+ (warn "denormalized SINGLE-FLOAT-BITS ~S losing bits" x))
+ (setf significand (ash significand -1)
+ exponent (1+ exponent))))))
+ (ecase lisp-sign
+ (1 unsigned-result)
+ (-1 (logior unsigned-result (- (expt 2 31)))))))))
+(defun double-float-bits (x)
+ (declare (type double-float x))
+ (assert (= (float-radix x) 2))
+ (if (zerop x)
+ 0 ; known property of IEEE floating point: 0.0d0 is represented as 0.
+ ;; KLUDGE: As per comments in SINGLE-FLOAT-BITS, above.
+ (multiple-value-bind (lisp-significand lisp-exponent lisp-sign)
+ (integer-decode-float x)
+ (assert (plusp lisp-significand))
+ (let* ((significand lisp-significand)
+ (exponent (+ lisp-exponent 52 1023))
+ (unsigned-result
+ (if (plusp exponent) ; if not obviously denormalized
+ (do ()
+ (nil)
+ (cond (;; ordinary termination case
+ (>= significand (expt 2 52))
+ (assert (< 0 significand (expt 2 53)))
+ ;; Exponent 0 is reserved for denormalized numbers,
+ ;; and 2047 is reserved for specials a la NaN.
+ (assert (< 0 exponent 2047))
+ (return (logior (ash exponent 52)
+ (logand significand
+ (1- (ash 1 52))))))
+ (;; special termination case, denormalized float number
+ (zerop exponent)
+ ;; Denormalized numbers have exponent one greater than
+ ;; the exponent field.
+ (return (ash significand -1)))
+ (t
+ ;; Shift as necessary to set bit 53 of significand.
+ (setf significand (ash significand 1)
+ exponent (1- exponent)))))
+ (do ()
+ ((zerop exponent)
+ ;; Denormalized numbers have exponent one greater than the
+ ;; exponent field.
+ (ash significand -1))
+ (unless (zerop (logand significand 1))
+ (warn "denormalized SINGLE-FLOAT-BITS ~S losing bits" x))
+ (setf significand (ash significand -1)
+ exponent (1+ exponent))))))
+ (ecase lisp-sign
+ (1 unsigned-result)
+ (-1 (logior unsigned-result (- (expt 2 63)))))))))
+(defun double-float-low-bits (x)
+ (declare (type double-float x))
+ (if (zerop x)
+ 0
+ ;; Unlike DOUBLE-FLOAT-HIGH-BITS or SINGLE-FLOAT-BITS, the CMU CL
+ ;; DOUBLE-FLOAT-LOW-BITS seems to return a unsigned value, not a signed
+ ;; value.
+ (logand #xffffffff (double-float-bits x))))
+(defun double-float-high-bits (x)
+ (declare (type double-float x))
+ (if (zerop x)
+ 0
+ (mask-and-sign-extend (ash (double-float-bits x) -32) 32)))
+
+;;; KLUDGE: These functions will blow up on any cross-compilation
+;;; host Lisp which has less floating point precision than the target
+;;; Lisp. In practice, this may not be a major problem: IEEE
+;;; floating point arithmetic is so common these days that most
+;;; cross-compilation host Lisps are likely to have exactly the same
+;;; floating point precision as the target Lisp. If it turns out to be
+;;; a problem, there are possible workarounds involving portable
+;;; representations for target floating point numbers, a la
+;;; (DEFSTRUCT TARGET-SINGLE-FLOAT
+;;; (SIGN (REQUIRED-ARGUMENT) :TYPE BIT)
+;;; (EXPONENT (REQUIRED-ARGUMENT) :TYPE UNSIGNED-BYTE)
+;;; (MANTISSA (REQUIRED-ARGUMENT) :TYPE UNSIGNED-BYTE))
+;;; with some sort of MAKE-LOAD-FORM-ish magic to cause them to be
+;;; written out in the appropriate target format. (And yes, those
+;;; workarounds *do* look messy to me, which is why I just went
+;;; with this quick kludge instead.) -- WHN 19990711
+(defun make-single-float (bits)
+ (if (zerop bits) ; IEEE float special case
+ 0.0
+ (let ((sign (ecase (ldb (byte 1 31) bits)
+ (0 1.0)
+ (1 -1.0)))
+ (expt (- (ldb (byte 8 23) bits) 127))
+ (mant (* (logior (ldb (byte 23 0) bits)
+ (ash 1 23))
+ (expt 0.5 23))))
+ (* sign (expt 2.0 expt) mant))))
+(defun make-double-float (hi lo)
+ (if (and (zerop hi) (zerop lo)) ; IEEE float special case
+ 0.0d0
+ (let* ((bits (logior (ash hi 32) lo))
+ (sign (ecase (ldb (byte 1 63) bits)
+ (0 1.0d0)
+ (1 -1.0d0)))
+ (expt (- (ldb (byte 11 52) bits) 1023))
+ (mant (* (logior (ldb (byte 52 0) bits)
+ (ash 1 52))
+ (expt 0.5d0 52))))
+ (* sign (expt 2.0d0 expt) mant))))
--- /dev/null
+;;;; cross-compiler-only versions of I/O-related stuff
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!IMPL")
+
+(file-comment
+ "$Header$")
+
+;;;; fast-read operations
+;;;;
+;;;; (Portable versions of these are needed at cross-compile time because
+;;;; genesis implements some of its cold fops by cloning ordinary fop
+;;;; implementations, and the ordinary fop implementations are defined in terms
+;;;; of fast-read operations.)
+
+(defmacro prepare-for-fast-read-byte (stream &body forms)
+ `(let ((%frc-stream% ,stream))
+ ,@forms))
+
+(defmacro fast-read-byte (&optional (eof-error-p t) (eof-value nil) any-type)
+ (declare (ignore any-type))
+ `(read-byte %frc-stream% ,eof-error-p ,eof-value))
+
+(defmacro done-with-fast-read-byte ()
+ `(values))
--- /dev/null
+;;;; cross-compile-time-only replacements for miscellaneous unportable
+;;;; stuff
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!IMPL")
+
+(file-comment
+ "$Header$")
+
+;;; In correct code, TRULY-THE has only a performance impact and can be
+;;; safely degraded to ordinary THE.
+(defmacro truly-the (type expr)
+ `(the ,type ,expr))
+
+;;; MAYBE-INLINE and FREEZE-TYPE declarations can be safely ignored
+;;; (possibly at some cost in efficiency).
+(declaim (declaration freeze-type maybe-inline))
+
+;;; INHIBIT-WARNINGS declarations can be safely ignored (although we may then
+;;; have to wade through some irrelevant warnings).
+(declaim (declaration inhibit-warnings))
+
+;;; Interrupt control isn't an issue in the cross-compiler: we don't use
+;;; address-dependent (and thus GC-dependent) hashes, and we only have a single
+;;; thread of control.
+(defmacro without-interrupts (&rest forms)
+ `(progn ,@forms))
+
+;;; When we're running as a cross-compiler in an arbitrary host ANSI Lisp, we
+;;; don't have any hooks available to manipulate the debugging name and
+;;; debugging argument list of an interpreted function object (and don't care
+;;; much about getting debugging name and debugging argument list right
+;;; anyway).
+(defun try-to-rename-interpreted-function-as-macro (f name lambda-list)
+ (declare (ignore f name lambda-list))
+ (values))
+
+;;; When we're running as a cross-compiler in an arbitrary host ANSI Lisp, we
+;;; shouldn't be doing anything which is sensitive to GC. KLUDGE: I (WHN
+;;; 19990131) think the proper long-term solution would be to remove any
+;;; operations from cross-compiler source files (putting them in target-only
+;;; source files) if they refer to these hooks. This is a short-term hack.
+(defvar *before-gc-hooks* nil)
+(defvar *after-gc-hooks* nil)
+
+;;; The GENESIS function works with fasl code which would, in the target SBCL,
+;;; work on LISP-STREAMs. A true LISP-STREAM doesn't seem to be a meaningful
+;;; concept in ANSI Common Lisp, but we can fake it acceptably well using a
+;;; standard STREAM.
+(deftype lisp-stream () 'stream)
+
+;;; In the target SBCL, the INSTANCE type refers to a base implementation
+;;; for compound types. There's no way to express exactly that concept
+;;; portably, but we can get essentially the same effect by testing for
+;;; any of the standard types which would, in the target SBCL, be derived
+;;; from INSTANCE:
+(deftype sb!kernel:instance ()
+ '(or condition standard-object structure-object))
+
+;;; There aren't any FUNCALLABLE-INSTANCEs in the cross-compilation
+;;; host Common Lisp.
+(defun funcallable-instance-p (x)
+ (if (typep x 'generic-function)
+ ;; In the target SBCL, FUNCALLABLE-INSTANCEs are used to implement generic
+ ;; functions, so any case which tests for this might in fact be trying to
+ ;; test for generic functions. My (WHN 19990313) expectation is that this
+ ;; case won't arise in the cross-compiler, but if it does, it deserves a
+ ;; little thought, rather than reflexively returning NIL.
+ (error "not clear how to handle GENERIC-FUNCTION")
+ nil))
+
+;;; This seems to be the portable Common Lisp type test which corresponds
+;;; to the effect of the target SBCL implementation test..
+(defun sb!kernel:array-header-p (x)
+ (and (typep x 'simple-array)
+ (= 1 (array-rank x))))
+
+;;; Genesis needs these at cross-compile time. The target implementation of
+;;; these is reasonably efficient by virtue of its ability to peek into the
+;;; internals of the package implementation; this reimplementation is portable
+;;; but slow.
+(defun package-internal-symbol-count (package)
+ (let ((result 0))
+ (declare (type fixnum result))
+ (do-symbols (i package)
+ ;; KLUDGE: The ANSI Common Lisp specification warns that DO-SYMBOLS may
+ ;; execute its body more than once for symbols that are inherited from
+ ;; multiple packages, and we currently make no attempt to correct for
+ ;; that here. (The current uses of this function at cross-compile time
+ ;; don't really care if the count is a little too high.) -- WHN 19990826
+ (multiple-value-bind (symbol status)
+ (find-symbol (symbol-name i) package)
+ (declare (ignore symbol))
+ (when (member status '(:internal :inherited))
+ (incf result))))
+ result))
+(defun package-external-symbol-count (package)
+ (let ((result 0))
+ (declare (type fixnum result))
+ (do-external-symbols (i package)
+ (declare (ignore i))
+ (incf result))
+ result))
+
+;;; In the target Lisp, INTERN* is the primitive and INTERN is implemented in
+;;; terms of it. This increases efficiency by letting us reuse a fixed-size
+;;; buffer; the alternative would be particularly painful because we don't
+;;; implement DYNAMIC-EXTENT. In the host Lisp, this is only used at
+;;; cold load time, and we don't care as much about efficiency, so it's fine
+;;; to treat the host Lisp's INTERN as primitive and implement INTERN* in
+;;; terms of it.
+(defun intern* (nameoid length package)
+ (intern (replace (make-string length) nameoid :end2 length) package))
+
+;;; In the target Lisp this is implemented by reading a fixed slot in the
+;;; symbol. In portable ANSI Common Lisp the same criteria can be met (more
+;;; slowly, and with the extra property of repeatability between runs) by just
+;;; calling SXHASH.
+(defun symbol-hash (symbol)
+ (declare (type symbol symbol))
+ (sxhash symbol))
--- /dev/null
+;;;; support and placeholders for System Area Pointers (SAPs) in the host
+;;;; Common Lisp at cross-compile time
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!SYS")
+
+(file-comment
+ "$Header$")
+
+;;; SYSTEM-AREA-POINTER is not a primitive type in ANSI Common Lisp, so we
+;;; need a compound type to represent it in the host Common Lisp at
+;;; cross-compile time:
+(defstruct (system-area-pointer (:constructor make-sap) (:conc-name "SAP-"))
+ ;; the integer representation of the address
+ (int (error "missing SAP-INT argument") :type sap-int-type :read-only t))
+
+;;; cross-compilation-host analogues of target-CMU CL primitive SAP operations
+(defun int-sap (int)
+ (make-sap :int int))
+(defun sap+ (sap offset)
+ (declare (type system-area-pointer sap) (type sap-int-type offset))
+ (make-sap :int (+ (sap-int sap) offset)))
+#.`(progn
+ ,@(mapcar (lambda (info)
+ (destructuring-bind (sap-fun int-fun) info
+ `(defun ,sap-fun (x y)
+ (,int-fun (sap-int x) (sap-int y)))))
+ '((sap< <) (sap<= <=) (sap= =) (sap>= >=) (sap> >) (sap- -))))
+
+;;; dummies, defined so that we can declare they never return and thereby
+;;; eliminate a thundering herd of optimization notes a la "can't optimize this
+;;; expression because we don't know the return type of SAP-REF-8"
+(defun sap-ref-stub (name)
+ (error "~S doesn't make sense on cross-compilation host." name))
+#.`(progn
+ ,@(mapcan (lambda (name)
+ `((declaim (ftype (function (system-area-pointer fixnum) nil)
+ ,name))
+ (defun ,name (sap offset)
+ (declare (ignore sap offset))
+ (sap-ref-stub ',name))
+ ,@(let ((setter-stub (gensym "SAP-SETTER-STUB-")))
+ `((defun ,setter-stub (foo sap offset)
+ (declare (ignore foo sap offset))
+ (sap-ref-stub '(setf ,name)))
+ (defsetf ,name ,setter-stub)))))
+ '(sap-ref-8
+ sap-ref-16
+ sap-ref-32
+ sap-ref-sap
+ sap-ref-single
+ sap-ref-double
+ signed-sap-ref-8
+ signed-sap-ref-16
+ signed-sap-ref-32)))
--- /dev/null
+;;;; cross-compiler-only versions of TYPEP, TYPE-OF, and related functions
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!IMPL")
+
+(file-comment
+ "$Header$")
+
+;;; (This was a useful warning when trying to get bootstrapping
+;;; to work, but it's mostly irrelevant noise now that the system
+;;; works.)
+(define-condition cross-type-style-warning (style-warning)
+ ((call :initarg :call
+ :reader cross-type-style-warning-call)
+ (message :reader cross-type-style-warning-message
+ #+cmu :initarg #+cmu :message ; to stop bogus non-STYLE WARNING
+ ))
+ (:report (lambda (c s)
+ (format
+ s
+ "cross-compilation-time type ambiguity (should be OK) in ~S:~%~A"
+ (cross-type-style-warning-call c)
+ (cross-type-style-warning-message c)))))
+
+;;; This warning is issued when giving up on a type calculation where a
+;;; conservative answer is acceptable. Since a conservative answer is
+;;; acceptable, the only downside is lost optimization opportunities.
+(define-condition cross-type-giving-up-conservatively
+ (cross-type-style-warning)
+ ((message :initform "giving up conservatively"
+ #+cmu :reader #+cmu #.(gensym) ; (to stop bogus non-STYLE WARNING)
+ )))
+
+;;; This warning refers to the flexibility in the ANSI spec with regard to
+;;; run-time distinctions between floating point types. (E.g. the
+;;; cross-compilation host might not even distinguish between SINGLE-FLOAT and
+;;; DOUBLE-FLOAT, so a DOUBLE-FLOAT number would test positive as
+;;; SINGLE-FLOAT.) If the target SBCL does make this distinction, then
+;;; information is lost. It's not too hard to contrive situations where this
+;;; would be a problem. In practice we don't tend to run into them because all
+;;; widely used Common Lisp environments do recognize the distinction between
+;;; SINGLE-FLOAT and DOUBLE-FLOAT, and we don't really need the other
+;;; distinctions (e.g. between SHORT-FLOAT and SINGLE-FLOAT), so we call
+;;; WARN-POSSIBLE-CROSS-TYPE-FLOAT-INFO-LOSS to test at runtime whether
+;;; we need to worry about this at all, and not warn unless we do. If we *do*
+;;; have to worry about this at runtime, my (WHN 19990808) guess is that
+;;; the system will break in multiple places, so this is a real
+;;; WARNING, not just a STYLE-WARNING.
+;;;
+;;; KLUDGE: If we ever try to support LONG-FLOAT or SHORT-FLOAT, this
+;;; situation will get a lot more complicated.
+(defun warn-possible-cross-type-float-info-loss (call)
+ (when (or (subtypep 'single-float 'double-float)
+ (subtypep 'double-float 'single-float))
+ (warn "possible floating point information loss in ~S" call)))
+
+(defun sb!xc:type-of (object)
+ (labels (;; FIXME: This function is a no-op now that we no longer have a
+ ;; distinct package T%CL to translate for-the-target-Lisp CL symbols
+ ;; to, and should go away completely.
+ (translate (expr) expr))
+ (let ((raw-result (type-of object)))
+ (cond ((or (subtypep raw-result 'float)
+ (subtypep raw-result 'complex))
+ (warn-possible-cross-type-float-info-loss
+ `(sb!xc:type-of ,object))
+ (translate raw-result))
+ ((subtypep raw-result 'integer)
+ (cond ((<= 0 object 1)
+ 'bit)
+ ((target-fixnump object)
+ 'fixnum)
+ (t
+ 'integer)))
+ ((some (lambda (type) (subtypep raw-result type))
+ '(array character list symbol))
+ (translate raw-result))
+ (t
+ (error "can't handle TYPE-OF ~S in cross-compilation"))))))
+
+;;; Like TYPEP, but asks whether HOST-OBJECT would be of TARGET-TYPE when
+;;; instantiated on the target SBCL. Since this is hard to decide in some
+;;; cases, and since in other cases we just haven't bothered to try, it
+;;; needs to return two values, just like SUBTYPEP: the first value for
+;;; its conservative opinion (never T unless it's certain) and the second
+;;; value to tell whether it's certain.
+(defun cross-typep (host-object target-type)
+ (flet ((warn-and-give-up ()
+ ;; We don't have to keep track of this as long as system performance
+ ;; is acceptable, since giving up conservatively is a safe way out.
+ #+nil
+ (warn 'cross-type-giving-up-conservatively
+ :call `(cross-typep ,host-object ,target-type))
+ (values nil nil))
+ (warn-about-possible-float-info-loss ()
+ (warn-possible-cross-type-float-info-loss
+ `(cross-typep ,host-object ,target-type))))
+ (cond (;; Handle various SBCL-specific types which can't exist on the
+ ;; ANSI cross-compilation host. KLUDGE: This code will need to be
+ ;; tweaked by hand if the names of these types ever change, ugh!
+ (if (consp target-type)
+ (member (car target-type)
+ '(sb!alien:alien))
+ (member target-type
+ '(system-area-pointer
+ funcallable-instance
+ sb!alien-internals:alien-value)))
+ (values nil t))
+ ((typep target-type 'sb!xc::structure-class)
+ ;; SBCL-specific types which have an analogue specially created
+ ;; on the host system
+ (if (sb!xc:subtypep (sb!xc:class-name target-type)
+ 'sb!kernel::structure!object)
+ (values (typep host-object (sb!xc:class-name target-type)) t)
+ (values nil t)))
+ ((and (symbolp target-type)
+ (find-class target-type nil)
+ (subtypep target-type 'sb!kernel::structure!object))
+ (values (typep host-object target-type) t))
+ ((and (symbolp target-type)
+ (sb!xc:find-class target-type nil)
+ (sb!xc:subtypep target-type 'cl:structure-object)
+ (typep host-object '(or symbol number list character)))
+ (values nil t))
+ ((and (not (unknown-type-p (values-specifier-type target-type)))
+ (sb!xc:subtypep target-type 'cl:array))
+ (if (arrayp host-object)
+ (warn-and-give-up) ; general case of arrays being way too hard
+ (values nil t))) ; but "obviously not an array" being easy
+ ((consp target-type)
+ (let ((first (first target-type))
+ (rest (rest target-type)))
+ (case first
+ ;; Many complex types are guaranteed to correspond exactly
+ ;; between any host ANSI Common Lisp and the target SBCL.
+ ((integer member mod rational real signed-byte unsigned-byte)
+ (values (typep host-object target-type) t))
+ ;; Floating point types are guaranteed to correspond, too, but
+ ;; less exactly.
+ ((single-float double-float)
+ (cond ((floatp host-object)
+ (warn-about-possible-float-info-loss)
+ (values (typep host-object target-type) t))
+ (t
+ (values nil t))))
+ ;; Some complex types have translations that are less trivial.
+ (and
+ ;; Note: This could be implemented as a real test, just the way
+ ;; that OR is; I just haven't bothered. -- WHN 19990706
+ (warn-and-give-up))
+ (or (let ((opinion nil)
+ (certain-p t))
+ (dolist (i rest)
+ (multiple-value-bind (sub-opinion sub-certain-p)
+ (cross-typep host-object i)
+ (cond (sub-opinion (setf opinion t
+ certain-p t)
+ (return))
+ ((not sub-certain-p) (setf certain-p nil))))
+ (if certain-p
+ (values opinion t)
+ (warn-and-give-up)))))
+ ;; Some complex types are too hard to handle in the positive
+ ;; case, but at least we can be confident in a large fraction of
+ ;; the negative cases..
+ ((base-string simple-base-string simple-string)
+ (if (stringp host-object)
+ (warn-and-give-up)
+ (values nil t)))
+ ((array simple-array simple-vector vector)
+ (if (arrayp host-object)
+ (warn-and-give-up)
+ (values nil t)))
+ (function
+ (if (functionp host-object)
+ (warn-and-give-up)
+ (values nil t)))
+ ;; And the Common Lisp type system is complicated, and we don't
+ ;; try to implement everything.
+ (otherwise (warn-and-give-up)))))
+ (t
+ (case target-type
+ ((*)
+ ;; KLUDGE: SBCL has * as an explicit wild type. While this is
+ ;; sort of logical (because (e.g. (ARRAY * 1)) is a valid type)
+ ;; it's not ANSI: looking at the ANSI definitions of complex
+ ;; types like like ARRAY shows that they consider * different
+ ;; from other type names. Someday we should probably get rid of
+ ;; this non-ANSIism in base SBCL, but until we do, we might as
+ ;; well here in the cross compiler. And in order to make sure
+ ;; that we don't continue doing it after we someday patch SBCL's
+ ;; type system so that * is no longer a type, we make this
+ ;; assertion:
+ (assert (typep (specifier-type '*) 'named-type))
+ (values t t))
+ ;; Many simple types are guaranteed to correspond exactly between
+ ;; any host ANSI Common Lisp and the target Common Lisp.
+ ((array bit character complex cons float function integer list
+ nil null number rational real signed-byte string symbol t
+ unsigned-byte vector)
+ (values (typep host-object target-type) t))
+ ;; Floating point types are guaranteed to correspond, too, but
+ ;; less exactly.
+ ((single-float double-float)
+ (cond ((floatp host-object)
+ (warn-about-possible-float-info-loss)
+ (values (typep host-object target-type) t))
+ (t
+ (values nil t))))
+ ;; Some types require translation between the cross-compilation
+ ;; host Common Lisp and the target SBCL.
+ (sb!xc:class (values (typep host-object 'sb!xc:class) t))
+ (fixnum (values (target-fixnump host-object) t))
+ ;; Some types are too hard to handle in the positive case, but at
+ ;; least we can be confident in a large fraction of the negative
+ ;; cases..
+ ((base-string simple-base-string simple-string)
+ (if (stringp host-object)
+ (warn-and-give-up)
+ (values nil t)))
+ ((character base-char)
+ (cond ((typep host-object 'standard-char)
+ (values t t))
+ ((not (characterp host-object))
+ (values nil t))
+ (t
+ (warn-and-give-up))))
+ ((stream instance)
+ ;; Neither target CL:STREAM nor target SB!KERNEL:INSTANCE is
+ ;; implemented as a STRUCTURE-OBJECT, so they'll fall through the
+ ;; tests above. We don't want to assume too much about them here,
+ ;; but at least we know enough about them to say that neither T
+ ;; nor NIL nor indeed any other symbol in the cross-compilation
+ ;; host is one. That knowledge suffices to answer so many of the
+ ;; questions that the cross-compiler asks that it's well worth
+ ;; special-casing it here.
+ (if (symbolp host-object)
+ (values nil t)
+ (warn-and-give-up)))
+ ;; And the Common Lisp type system is complicated, and we don't
+ ;; try to implement everything.
+ (otherwise (warn-and-give-up)))))))
+
+;;; An incomplete TYPEP which runs at cross-compile time to tell whether OBJECT
+;;; is the host Lisp representation of a target SBCL type specified by
+;;; TARGET-TYPE-SPEC. It need make no pretense to completeness, since it
+;;; need only handle the cases which arise when building SBCL itself, e.g.
+;;; testing that range limits FOO and BAR in (INTEGER FOO BAR) are INTEGERs.
+(defun sb!xc:typep (host-object target-type-spec &optional (env nil env-p))
+ (declare (ignore env))
+ (assert (null env-p)) ; 'cause we're too lazy to think about it
+ (multiple-value-bind (opinion certain-p)
+ (cross-typep host-object target-type-spec)
+ ;; A program that calls TYPEP doesn't want uncertainty and probably
+ ;; can't handle it.
+ (if certain-p
+ opinion
+ (error "uncertain in SB!XC:TYPEP ~S ~S"
+ host-object
+ target-type-spec))))
+
+;;; This implementation is an incomplete, portable version for use at
+;;; cross-compile time only.
+(defun ctypep (obj ctype)
+ (check-type ctype ctype)
+ (let (;; the Common Lisp type specifier corresponding to CTYPE
+ (type (type-specifier ctype)))
+ (check-type type (or symbol cons))
+ (cross-typep obj type)))
+
+(defparameter *universal-function-type*
+ (make-function-type :wild-args t
+ :returns *wild-type*))
+
+(defun ctype-of (x)
+ (typecase x
+ (function
+ (if (typep x 'generic-function)
+ ;; Since at cross-compile time we build a CLOS-free bootstrap version of
+ ;; SBCL, it's unclear how to explain to it what a generic function is.
+ (error "not implemented: cross CTYPE-OF generic function")
+ ;; There's no ANSI way to find out what the function is declared to
+ ;; be, so we just return the CTYPE for the most-general function.
+ *universal-function-type*))
+ (symbol
+ (make-member-type :members (list x)))
+ (number
+ (let* ((num (if (complexp x) (realpart x) x))
+ (res (make-numeric-type
+ :class (etypecase num
+ (integer 'integer)
+ (rational 'rational)
+ (float 'float))
+ :format (if (floatp num)
+ (float-format-name num)
+ nil))))
+ (cond ((complexp x)
+ (setf (numeric-type-complexp res) :complex)
+ (let ((imag (imagpart x)))
+ (setf (numeric-type-low res) (min num imag))
+ (setf (numeric-type-high res) (max num imag))))
+ (t
+ (setf (numeric-type-low res) num)
+ (setf (numeric-type-high res) num)))
+ res))
+ (array
+ (let ((etype (specifier-type (array-element-type x))))
+ (make-array-type :dimensions (array-dimensions x)
+ :complexp (not (typep x 'simple-array))
+ :element-type etype
+ :specialized-element-type etype)))
+ (cons (sb!xc:find-class 'cons))
+ (character
+ (cond ((typep x 'standard-char)
+ ;; (Note that SBCL doesn't distinguish between BASE-CHAR and
+ ;; CHARACTER.)
+ (sb!xc:find-class 'base-char))
+ ((not (characterp x))
+ nil)
+ (t
+ ;; Beyond this, there seems to be no portable correspondence.
+ (error "can't map host Lisp CHARACTER ~S to target Lisp" x))))
+ (structure!object
+ (sb!xc:find-class (uncross (class-name (class-of x)))))
+ (t
+ ;; There might be more cases which we could handle with sufficient effort;
+ ;; since all we *need* to handle are enough cases for bootstrapping, we
+ ;; don't try to be complete here. -- WHN 19990512
+ (error "can't handle ~S in cross CTYPE-OF" x))))
--- /dev/null
+;;;; structures used for recording debugger information
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!C")
+
+(file-comment
+ "$Header$")
+\f
+;;;; SC-OFFSETs
+;;;;
+;;;; We represent the place where some value is stored with a SC-OFFSET,
+;;;; which is the SC number and offset encoded as an integer.
+
+(defconstant sc-offset-scn-byte (byte 5 0))
+(defconstant sc-offset-offset-byte (byte 22 5))
+(def!type sc-offset () '(unsigned-byte 27))
+
+(defmacro make-sc-offset (scn offset)
+ `(dpb ,scn sc-offset-scn-byte
+ (dpb ,offset sc-offset-offset-byte 0)))
+
+(defmacro sc-offset-scn (sco) `(ldb sc-offset-scn-byte ,sco))
+(defmacro sc-offset-offset (sco) `(ldb sc-offset-offset-byte ,sco))
+\f
+;;;; flags for compiled debug variables
+
+;;; FIXME: old CMU CL representation follows:
+;;; Compiled debug variables are in a packed binary representation in the
+;;; DEBUG-FUNCTION-VARIABLES:
+;;; single byte of boolean flags:
+;;; uninterned name
+;;; packaged name
+;;; environment-live
+;;; has distinct save location
+;;; has ID (name not unique in this fun)
+;;; minimal debug-info argument (name generated as ARG-0, ...)
+;;; deleted: placeholder for unused minimal argument
+;;; [name length in bytes (as var-length integer), if not minimal]
+;;; [...name bytes..., if not minimal]
+;;; [if packaged, var-length integer that is package name length]
+;;; ...package name bytes...]
+;;; [If has ID, ID as var-length integer]
+;;; SC-Offset of primary location (as var-length integer)
+;;; [If has save SC, SC-Offset of save location (as var-length integer)]
+
+;;; FIXME: The first two are no longer used in SBCL.
+;;;(defconstant compiled-debug-var-uninterned #b00000001)
+;;;(defconstant compiled-debug-var-packaged #b00000010)
+(defconstant compiled-debug-var-environment-live #b00000100)
+(defconstant compiled-debug-var-save-loc-p #b00001000)
+(defconstant compiled-debug-var-id-p #b00010000)
+(defconstant compiled-debug-var-minimal-p #b00100000)
+(defconstant compiled-debug-var-deleted-p #b01000000)
+\f
+;;;; compiled debug blocks
+;;;;
+;;;; Compiled debug blocks are in a packed binary representation in the
+;;;; DEBUG-FUNCTION-BLOCKS:
+;;;; number of successors + bit flags (single byte)
+;;;; elsewhere-p
+;;;; ...ordinal number of each successor in the function's blocks vector...
+;;;; number of locations in this block
+;;;; kind of first location (single byte)
+;;;; delta from previous PC (or from 0 if first location in function.)
+;;;; [offset of first top-level form, if no function TLF-NUMBER]
+;;;; form number of first source form
+;;;; first live mask (length in bytes determined by number of VARIABLES)
+;;;; ...more <kind, delta, top-level form offset, form-number, live-set>
+;;;; tuples...
+
+(defconstant compiled-debug-block-nsucc-byte (byte 2 0))
+(defconstant compiled-debug-block-elsewhere-p #b00000100)
+
+(defconstant compiled-code-location-kind-byte (byte 3 0))
+(defconstant compiled-code-location-kinds
+ '#(:unknown-return :known-return :internal-error :non-local-exit
+ :block-start :call-site :single-value-return :non-local-entry))
+\f
+;;;; DEBUG-FUNCTION objects
+
+(def!struct (debug-function (:constructor nil)))
+
+(def!struct (compiled-debug-function (:include debug-function)
+ #-sb-xc-host (:pure t))
+ ;; The name of this function. If from a DEFUN, etc., then this is the
+ ;; function name, otherwise it is a descriptive string.
+ (name (required-argument) :type (or simple-string cons symbol))
+ ;; The kind of function (same as FUNCTIONAL-KIND):
+ (kind nil :type (member nil :optional :external :top-level :cleanup))
+ ;; a description of variable locations for this function, in alphabetical
+ ;; order by name; or NIL if no information is available
+ ;;
+ ;; The variable entries are alphabetically ordered. This ordering is used in
+ ;; lifetime info to refer to variables: the first entry is 0, the second
+ ;; entry is 1, etc. Variable numbers are *not* the byte index at which the
+ ;; representation of the location starts.
+ ;;
+ ;; Each entry is:
+ ;; * a FLAGS value, which is a FIXNUM with various
+ ;; COMPILED-DEBUG-FUNCTION-FOO bits set
+ ;; * the symbol which names this variable, unless debug info is minimal
+ ;; * the variable ID, when it has one
+ ;; * SC-offset of primary location, if it has one
+ ;; * SC-offset of save location, if it has one
+ (variables nil :type (or simple-vector null))
+ ;; A vector of the packed binary representation of the COMPILED-DEBUG-BLOCKs
+ ;; in this function, in the order that the blocks were emitted. The first
+ ;; block is the start of the function. This slot may be NIL to save space.
+ ;;
+ ;; FIXME: The "packed binary representation" description in the comment
+ ;; above is the same as the description of the old representation of
+ ;; VARIABLES which doesn't work properly in SBCL (because it doesn't
+ ;; transform correctly under package renaming). Check whether this slot's
+ ;; data might have the same problem that that slot's data did.
+ (blocks nil :type (or (simple-array (unsigned-byte 8) (*)) null))
+ ;; If all code locations in this function are in the same top-level form,
+ ;; then this is the number of that form, otherwise NIL. If NIL, then each
+ ;; code location represented in the BLOCKS specifies the TLF number.
+ (tlf-number nil :type (or index null))
+ ;; A vector describing the variables that the argument values are stored in
+ ;; within this function. The locations are represented by the ordinal number
+ ;; of the entry in the VARIABLES slot value. The locations are in the order
+ ;; that the arguments are actually passed in, but special marker symbols can
+ ;; be interspersed to indicate the original call syntax:
+ ;;
+ ;; DELETED
+ ;; There was an argument to the function in this position, but it was
+ ;; deleted due to lack of references. The value cannot be recovered.
+ ;;
+ ;; SUPPLIED-P
+ ;; The following location is the supplied-p value for the preceding
+ ;; keyword or optional.
+ ;;
+ ;; OPTIONAL-ARGS
+ ;; Indicates that following unqualified args are optionals, not required.
+ ;;
+ ;; REST-ARG
+ ;; The following location holds the list of rest args.
+ ;;
+ ;; MORE-ARG
+ ;; The following two locations are the more arg context and count.
+ ;;
+ ;; <any other symbol>
+ ;; The following location is the value of the keyword argument with the
+ ;; specified name.
+ ;;
+ ;; This may be NIL to save space. If no symbols are present, then this will
+ ;; be represented with an I-vector with sufficiently large element type. If
+ ;; this is :MINIMAL, then this means that the VARIABLES are all required
+ ;; arguments, and are in the order they appear in the VARIABLES vector. In
+ ;; other words, :MINIMAL stands in for a vector where every element holds its
+ ;; index.
+ (arguments nil :type (or (simple-array * (*)) (member :minimal nil)))
+ ;; There are three alternatives for this slot:
+ ;;
+ ;; A vector
+ ;; A vector of SC-OFFSETS describing the return locations. The
+ ;; vector element type is chosen to hold the largest element.
+ ;;
+ ;; :Standard
+ ;; The function returns using the standard unknown-values convention.
+ ;;
+ ;; :Fixed
+ ;; The function returns using the fixed-values convention, but
+ ;; in order to save space, we elected not to store a vector.
+ (returns :fixed :type (or (simple-array * (*)) (member :standard :fixed)))
+ ;; SC-Offsets describing where the return PC and return FP are kept.
+ (return-pc (required-argument) :type sc-offset)
+ (old-fp (required-argument) :type sc-offset)
+ ;; SC-Offset for the number stack FP in this function, or NIL if no NFP
+ ;; allocated.
+ (nfp nil :type (or sc-offset null))
+ ;; The earliest PC in this function at which the environment is properly
+ ;; initialized (arguments moved from passing locations, etc.)
+ (start-pc (required-argument) :type index)
+ ;; The start of elsewhere code for this function (if any.)
+ (elsewhere-pc (required-argument) :type index))
+\f
+;;;; minimal debug function
+
+;;; The minimal debug info format compactly represents debug-info for some
+;;; cases where the other debug info (variables, blocks) is small enough so
+;;; that the per-function overhead becomes relatively large. The minimal
+;;; debug-info format can represent any function at level 0, and any fixed-arg
+;;; function at level 1.
+;;;
+;;; In the minimal format, the debug functions and function map are packed into
+;;; a single byte-vector which is placed in the
+;;; COMPILED-DEBUG-INFO-FUNCTION-MAP. Because of this, all functions in a
+;;; component must be representable in minimal format for any function to
+;;; actually be dumped in minimal format. The vector is a sequence of records
+;;; in this format:
+;;; name representation + kind + return convention (single byte)
+;;; bit flags (single byte)
+;;; setf, nfp, variables
+;;; [package name length (as var-length int), if name is packaged]
+;;; [...package name bytes, if name is packaged]
+;;; [name length (as var-length int), if there is a name]
+;;; [...name bytes, if there is a name]
+;;; [variables length (as var-length int), if variables flag]
+;;; [...bytes holding variable descriptions]
+;;; If variables are dumped (level 1), then the variables are all
+;;; arguments (in order) with the minimal-arg bit set.
+;;; [If returns is specified, then the number of return values]
+;;; [...sequence of var-length ints holding sc-offsets of the return
+;;; value locations, if fixed return values are specified.]
+;;; return-pc location sc-offset (as var-length int)
+;;; old-fp location sc-offset (as var-length int)
+;;; [nfp location sc-offset (as var-length int), if nfp flag]
+;;; code-start-pc (as a var-length int)
+;;; This field implicitly encodes start of this function's code in the
+;;; function map, as a delta from the previous function's code start.
+;;; If the first function in the component, then this is the delta from
+;;; 0 (i.e. the absolute offset.)
+;;; start-pc (as a var-length int)
+;;; This encodes the environment start PC as an offset from the
+;;; code-start PC.
+;;; elsewhere-pc
+;;; This encodes the elsewhere code start for this function, as a delta
+;;; from the previous function's elsewhere code start. (i.e. the
+;;; encoding is the same as for code-start-pc.)
+
+#|
+### For functions with XEPs, name could be represented more simply and
+compactly as some sort of info about with how to find the function-entry that
+this is a function for. Actually, you really hardly need any info. You can
+just chain through the functions in the component until you find the right one.
+Well, I guess you need to at least know which function is an XEP for the real
+function (which would be useful info anyway).
+|#
+
+;;; Following are definitions of bit-fields in the first byte of the minimal
+;;; debug function:
+(defconstant minimal-debug-function-name-symbol 0)
+(defconstant minimal-debug-function-name-packaged 1)
+(defconstant minimal-debug-function-name-uninterned 2)
+(defconstant minimal-debug-function-name-component 3)
+(defconstant minimal-debug-function-name-style-byte (byte 2 0))
+(defconstant minimal-debug-function-kind-byte (byte 3 2))
+(defconstant minimal-debug-function-kinds
+ '#(nil :optional :external :top-level :cleanup))
+(defconstant minimal-debug-function-returns-standard 0)
+(defconstant minimal-debug-function-returns-specified 1)
+(defconstant minimal-debug-function-returns-fixed 2)
+(defconstant minimal-debug-function-returns-byte (byte 2 5))
+
+;;; The following are bit-flags in the second byte of the minimal debug
+;;; function:
+
+;;; If true, wrap (SETF ...) around the name.
+(defconstant minimal-debug-function-setf-bit (ash 1 0))
+
+;;; If true, there is a NFP.
+(defconstant minimal-debug-function-nfp-bit (ash 1 1))
+
+;;; If true, variables (hence arguments) have been dumped.
+(defconstant minimal-debug-function-variables-bit (ash 1 2))
+\f
+;;;; debug source
+
+(def!struct (debug-source #-sb-xc-host (:pure t))
+ ;; This slot indicates where the definition came from:
+ ;; :File - from a file (Compile-File)
+ ;; :Lisp - from Lisp (Compile)
+ (from (required-argument) :type (member :file :lisp))
+ ;; If :File, the file name, if :Lisp or :Stream, then a vector of the
+ ;; top-level forms. When from COMPILE, form 0 is #'(LAMBDA ...).
+ (name nil)
+ ;; File comment for this file, if any.
+ (comment nil :type (or simple-string null))
+ ;; The universal time that the source was written, or NIL if unavailable.
+ (created nil :type (or unsigned-byte null))
+ ;; The universal time that the source was compiled.
+ (compiled (required-argument) :type unsigned-byte)
+ ;; The source path root number of the first form read from this source (i.e.
+ ;; the total number of forms converted previously in this compilation.)
+ (source-root 0 :type index)
+ ;; The file-positions of each truly top-level form read from this file (if
+ ;; applicable). The vector element type will be chosen to hold the largest
+ ;; element. May be null to save space.
+ (start-positions nil :type (or (simple-array * (*)) null))
+ ;; If from :LISP, this is the function whose source is form 0.
+ (info nil))
+\f
+;;;; DEBUG-INFO structures
+
+(def!struct debug-info
+ ;; Some string describing something about the code in this component.
+ (name (required-argument) :type simple-string)
+ ;; A list of DEBUG-SOURCE structures describing where the code for this
+ ;; component came from, in the order that they were read.
+ ;;
+ ;; *** NOTE: the offset of this slot is wired into the fasl dumper so that it
+ ;; *** can backpatch the source info when compilation is complete.
+ (source nil :type list))
+
+(def!struct (compiled-debug-info
+ (:include debug-info)
+ #-sb-xc-host (:pure t))
+ ;; a simple-vector of alternating DEBUG-FUNCTION objects and fixnum PCs,
+ ;; used to map PCs to functions, so that we can figure out what function we
+ ;; were running in. Each function is valid between the PC before it
+ ;; (inclusive) and the PC after it (exclusive). The PCs are in sorted order,
+ ;; to allow binary search. We omit the first and last PC, since their values
+ ;; are 0 and the length of the code vector.
+ ;;
+ ;; KLUDGE: PC's can't always be represented by FIXNUMs, unless we're always
+ ;; careful to put our code in low memory. Is that how it works? Would this
+ ;; break if we used a more general memory map? -- WHN 20000120
+ (function-map (required-argument) :type simple-vector :read-only t))
--- /dev/null
+;;;; the implementation of the programmer's interface to writing
+;;;; debugging tools
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!DI")
+
+(file-comment
+ "$Header$")
+
+;;; FIXME: There are an awful lot of package prefixes in this code.
+;;; Couldn't we have SB-DI use the SB-C and SB-VM packages?
+\f
+;;;; conditions
+
+;;;; The interface to building debugging tools signals conditions that
+;;;; prevent it from adhering to its contract. These are
+;;;; serious-conditions because the program using the interface must
+;;;; handle them before it can correctly continue execution. These
+;;;; debugging conditions are not errors since it is no fault of the
+;;;; programmers that the conditions occur. The interface does not
+;;;; provide for programs to detect these situations other than
+;;;; calling a routine that detects them and signals a condition. For
+;;;; example, programmers call A which may fail to return successfully
+;;;; due to a lack of debug information, and there is no B the they
+;;;; could have called to realize A would fail. It is not an error to
+;;;; have called A, but it is an error for the program to then ignore
+;;;; the signal generated by A since it cannot continue without A's
+;;;; correctly returning a value or performing some operation.
+;;;;
+;;;; Use DEBUG-SIGNAL to signal these conditions.
+
+(define-condition debug-condition (serious-condition)
+ ()
+ #!+sb-doc
+ (:documentation
+ "All debug-conditions inherit from this type. These are serious conditions
+ that must be handled, but they are not programmer errors."))
+
+(define-condition no-debug-info (debug-condition)
+ ()
+ #!+sb-doc
+ (:documentation "There is absolutely no debugging information available.")
+ (:report (lambda (condition stream)
+ (declare (ignore condition))
+ (fresh-line stream)
+ (write-line "No debugging information available." stream))))
+
+(define-condition no-debug-function-returns (debug-condition)
+ ((debug-function :reader no-debug-function-returns-debug-function
+ :initarg :debug-function))
+ #!+sb-doc
+ (:documentation
+ "The system could not return values from a frame with debug-function since
+ it lacked information about returning values.")
+ (:report (lambda (condition stream)
+ (let ((fun (debug-function-function
+ (no-debug-function-returns-debug-function condition))))
+ (format stream
+ "~&Cannot return values from ~:[frame~;~:*~S~] since ~
+ the debug information lacks details about returning ~
+ values here."
+ fun)))))
+
+(define-condition no-debug-blocks (debug-condition)
+ ((debug-function :reader no-debug-blocks-debug-function
+ :initarg :debug-function))
+ #!+sb-doc
+ (:documentation "The debug-function has no debug-block information.")
+ (:report (lambda (condition stream)
+ (format stream "~&~S has no debug-block information."
+ (no-debug-blocks-debug-function condition)))))
+
+(define-condition no-debug-vars (debug-condition)
+ ((debug-function :reader no-debug-vars-debug-function
+ :initarg :debug-function))
+ #!+sb-doc
+ (:documentation "The debug-function has no DEBUG-VAR information.")
+ (:report (lambda (condition stream)
+ (format stream "~&~S has no debug variable information."
+ (no-debug-vars-debug-function condition)))))
+
+(define-condition lambda-list-unavailable (debug-condition)
+ ((debug-function :reader lambda-list-unavailable-debug-function
+ :initarg :debug-function))
+ #!+sb-doc
+ (:documentation
+ "The debug-function has no lambda-list since argument DEBUG-VARs are
+ unavailable.")
+ (:report (lambda (condition stream)
+ (format stream "~&~S has no lambda-list information available."
+ (lambda-list-unavailable-debug-function condition)))))
+
+(define-condition invalid-value (debug-condition)
+ ((debug-var :reader invalid-value-debug-var :initarg :debug-var)
+ (frame :reader invalid-value-frame :initarg :frame))
+ (:report (lambda (condition stream)
+ (format stream "~&~S has :invalid or :unknown value in ~S."
+ (invalid-value-debug-var condition)
+ (invalid-value-frame condition)))))
+
+(define-condition ambiguous-variable-name (debug-condition)
+ ((name :reader ambiguous-variable-name-name :initarg :name)
+ (frame :reader ambiguous-variable-name-frame :initarg :frame))
+ (:report (lambda (condition stream)
+ (format stream "~&~S names more than one valid variable in ~S."
+ (ambiguous-variable-name-name condition)
+ (ambiguous-variable-name-frame condition)))))
+\f
+;;;; errors and DEBUG-SIGNAL
+
+;;; The debug-internals code tries to signal all programmer errors as
+;;; subtypes of DEBUG-ERROR. There are calls to ERROR signalling
+;;; SIMPLE-ERRORs, but these dummy checks in the code and shouldn't
+;;; come up.
+;;;
+;;; While under development, this code also signals errors in code
+;;; branches that remain unimplemented.
+
+(define-condition debug-error (error) ()
+ #!+sb-doc
+ (:documentation
+ "All programmer errors from using the interface for building debugging
+ tools inherit from this type."))
+
+(define-condition unhandled-condition (debug-error)
+ ((condition :reader unhandled-condition-condition :initarg :condition))
+ (:report (lambda (condition stream)
+ (format stream "~&unhandled DEBUG-CONDITION:~%~A"
+ (unhandled-condition-condition condition)))))
+
+(define-condition unknown-code-location (debug-error)
+ ((code-location :reader unknown-code-location-code-location
+ :initarg :code-location))
+ (:report (lambda (condition stream)
+ (format stream "~&invalid use of an unknown code-location: ~S"
+ (unknown-code-location-code-location condition)))))
+
+(define-condition unknown-debug-var (debug-error)
+ ((debug-var :reader unknown-debug-var-debug-var :initarg :debug-var)
+ (debug-function :reader unknown-debug-var-debug-function
+ :initarg :debug-function))
+ (:report (lambda (condition stream)
+ (format stream "~&~S is not in ~S."
+ (unknown-debug-var-debug-var condition)
+ (unknown-debug-var-debug-function condition)))))
+
+(define-condition invalid-control-stack-pointer (debug-error)
+ ()
+ (:report (lambda (condition stream)
+ (declare (ignore condition))
+ (fresh-line stream)
+ (write-string "invalid control stack pointer" stream))))
+
+(define-condition frame-function-mismatch (debug-error)
+ ((code-location :reader frame-function-mismatch-code-location
+ :initarg :code-location)
+ (frame :reader frame-function-mismatch-frame :initarg :frame)
+ (form :reader frame-function-mismatch-form :initarg :form))
+ (:report (lambda (condition stream)
+ (format stream
+ "~&Form was preprocessed for ~S,~% but called on ~S:~% ~S"
+ (frame-function-mismatch-code-location condition)
+ (frame-function-mismatch-frame condition)
+ (frame-function-mismatch-form condition)))))
+
+;;; This signals debug-conditions. If they go unhandled, then signal an
+;;; unhandled-condition error.
+;;;
+;;; ??? Get SIGNAL in the right package!
+(defmacro debug-signal (datum &rest arguments)
+ `(let ((condition (make-condition ,datum ,@arguments)))
+ (signal condition)
+ (error 'unhandled-condition :condition condition)))
+\f
+;;;; structures
+;;;;
+;;;; Most of these structures model information stored in internal
+;;;; data structures created by the compiler. Whenever comments
+;;;; preface an object or type with "compiler", they refer to the
+;;;; internal compiler thing, not to the object or type with the same
+;;;; name in the "DI" package.
+
+;;;; DEBUG-VARs
+
+;;; These exist for caching data stored in packed binary form in
+;;; compiler debug-functions. Debug-functions store these.
+(defstruct (debug-var (:constructor nil))
+ ;; the name of the variable
+ (symbol (required-argument) :type symbol)
+ ;; a unique integer identification relative to other variables with the same
+ ;; symbol
+ (id 0 :type sb!c::index)
+ ;; Does the variable always have a valid value?
+ (alive-p nil :type boolean))
+(def!method print-object ((debug-var debug-var) stream)
+ (print-unreadable-object (debug-var stream :type t :identity t)
+ (format stream
+ "~S ~D"
+ (debug-var-symbol debug-var)
+ (debug-var-id debug-var))))
+
+#!+sb-doc
+(setf (fdocumentation 'debug-var-id 'function)
+ "Returns the integer that makes DEBUG-VAR's name and package unique
+ with respect to other DEBUG-VARs in the same function.")
+
+(defstruct (compiled-debug-var
+ (:include debug-var)
+ (:constructor make-compiled-debug-var
+ (symbol id alive-p sc-offset save-sc-offset)))
+ ;; Storage class and offset. (unexported).
+ (sc-offset nil :type sb!c::sc-offset)
+ ;; Storage class and offset when saved somewhere.
+ (save-sc-offset nil :type (or sb!c::sc-offset null)))
+
+(defstruct (interpreted-debug-var
+ (:include debug-var (alive-p t))
+ (:constructor make-interpreted-debug-var (symbol ir1-var)))
+ ;; This is the IR1 structure that holds information about interpreted vars.
+ (ir1-var nil :type sb!c::lambda-var))
+
+;;;; frames
+
+;;; These represent call-frames on the stack.
+(defstruct (frame (:constructor nil))
+ ;; the next frame up, or NIL when top frame
+ (up nil :type (or frame null))
+ ;; the previous frame down, or NIL when the bottom frame. Before
+ ;; computing the next frame down, this slot holds the frame pointer
+ ;; to the control stack for the given frame. This lets us get the
+ ;; next frame down and the return-pc for that frame.
+ (%down :unparsed :type (or frame (member nil :unparsed)))
+ ;; the debug-function for the function whose call this frame
+ ;; represents
+ (debug-function nil :type debug-function)
+ ;; the code-location to continue upon return to frame
+ (code-location nil :type code-location)
+ ;; an a-list of catch-tags to code-locations
+ (%catches :unparsed :type (or list (member :unparsed)))
+ ;; pointer to frame on control stack. (unexported) When this frame
+ ;; is an interpreted-frame, this pointer is an index into the
+ ;; interpreter's stack.
+ pointer
+ ;; This is the frame's number for prompt printing. Top is zero.
+ (number 0 :type index))
+
+#!+sb-doc
+(setf (fdocumentation 'frame-up 'function)
+ "Returns the frame immediately above frame on the stack. When frame is
+ the top of the stack, this returns nil.")
+
+#!+sb-doc
+(setf (fdocumentation 'frame-debug-function 'function)
+ "Returns the debug-function for the function whose call frame represents.")
+
+#!+sb-doc
+(setf (fdocumentation 'frame-code-location 'function)
+ "Returns the code-location where the frame's debug-function will continue
+ running when program execution returns to this frame. If someone
+ interrupted this frame, the result could be an unknown code-location.")
+
+(defstruct (compiled-frame
+ (:include frame)
+ (:constructor make-compiled-frame
+ (pointer up debug-function code-location number
+ #!+gengc saved-state-chain
+ &optional escaped)))
+ ;; This indicates whether someone interrupted the frame.
+ ;; (unexported). If escaped, this is a pointer to the state that was
+ ;; saved when we were interrupted. On the non-gengc system, this is
+ ;; a pointer to an os_context_t, i.e. the third argument to an
+ ;; SA_SIGACTION-style signal handler. On the gengc system, this is a
+ ;; state pointer from SAVED-STATE-CHAIN.
+ escaped
+ ;; a list of SAPs to saved states. Each time we unwind past an
+ ;; exception, we pop the next entry off this list. When we get to
+ ;; the end of the list, there is nothing else on the stack.
+ #!+gengc (saved-state-chain nil :type list))
+(def!method print-object ((obj compiled-frame) str)
+ (print-unreadable-object (obj str :type t)
+ (format str
+ "~S~:[~;, interrupted~]"
+ (debug-function-name (frame-debug-function obj))
+ (compiled-frame-escaped obj))))
+
+(defstruct (interpreted-frame
+ (:include frame)
+ (:constructor make-interpreted-frame
+ (pointer up debug-function code-location number
+ real-frame closure)))
+ ;; This points to the compiled-frame for SB!EVAL:INTERNAL-APPLY-LOOP.
+ (real-frame nil :type compiled-frame)
+ ;; This is the closed over data used by the interpreter.
+ (closure nil :type simple-vector))
+(def!method print-object ((obj interpreted-frame) str)
+ (print-unreadable-object (obj str :type t)
+ (prin1 (debug-function-name (frame-debug-function obj)) str)))
+
+;;;; DEBUG-FUNCTIONs
+
+;;; These exist for caching data stored in packed binary form in
+;;; compiler debug-functions. *COMPILED-DEBUG-FUNCTIONS* maps a
+;;; SB!C::DEBUG-FUNCTION to a DEBUG-FUNCTION. There should only be one
+;;; DEBUG-FUNCTION in existence for any function; that is, all
+;;; code-locations and other objects that reference DEBUG-FUNCTIONs
+;;; point to unique objects. This is due to the overhead in cached
+;;; information.
+(defstruct debug-function
+ ;; Some representation of the function arguments. See
+ ;; DEBUG-FUNCTION-LAMBDA-LIST.
+ ;; NOTE: must parse vars before parsing arg list stuff.
+ (%lambda-list :unparsed)
+ ;; Cached DEBUG-VARS information. (unexported).
+ ;; These are sorted by their name.
+ (%debug-vars :unparsed :type (or simple-vector null (member :unparsed)))
+ ;; Cached debug-block information. This is NIL when we have tried to
+ ;; parse the packed binary info, but none is available.
+ (blocks :unparsed :type (or simple-vector null (member :unparsed)))
+ ;; The actual function if available.
+ (%function :unparsed :type (or null function (member :unparsed))))
+(def!method print-object ((obj debug-function) stream)
+ (print-unreadable-object (obj stream :type t)
+ (prin1 (debug-function-name obj) stream)))
+
+(defstruct (compiled-debug-function
+ (:include debug-function)
+ (:constructor %make-compiled-debug-function
+ (compiler-debug-fun component)))
+ ;; Compiler's dumped debug-function information. (unexported).
+ (compiler-debug-fun nil :type sb!c::compiled-debug-function)
+ ;; Code object. (unexported).
+ component
+ ;; The :FUNCTION-START breakpoint (if any) used to facilitate
+ ;; function end breakpoints.
+ (end-starter nil :type (or null breakpoint)))
+
+;;; This maps SB!C::COMPILED-DEBUG-FUNCTIONs to
+;;; COMPILED-DEBUG-FUNCTIONs, so we can get at cached stuff and not
+;;; duplicate COMPILED-DEBUG-FUNCTION structures.
+(defvar *compiled-debug-functions* (make-hash-table :test 'eq))
+
+;;; Make a COMPILED-DEBUG-FUNCTION for a SB!C::COMPILER-DEBUG-FUNCTION
+;;; and its component. This maps the latter to the former in
+;;; *COMPILED-DEBUG-FUNCTIONS*. If there already is a
+;;; COMPILED-DEBUG-FUNCTION, then this returns it from
+;;; *COMPILED-DEBUG-FUNCTIONS*.
+(defun make-compiled-debug-function (compiler-debug-fun component)
+ (or (gethash compiler-debug-fun *compiled-debug-functions*)
+ (setf (gethash compiler-debug-fun *compiled-debug-functions*)
+ (%make-compiled-debug-function compiler-debug-fun component))))
+
+(defstruct (interpreted-debug-function
+ (:include debug-function)
+ (:constructor %make-interpreted-debug-function (ir1-lambda)))
+ ;; This is the IR1 lambda that this debug-function represents.
+ (ir1-lambda nil :type sb!c::clambda))
+
+(defstruct (bogus-debug-function
+ (:include debug-function)
+ (:constructor make-bogus-debug-function
+ (%name &aux (%lambda-list nil) (%debug-vars nil)
+ (blocks nil) (%function nil))))
+ %name)
+
+(defvar *ir1-lambda-debug-function* (make-hash-table :test 'eq))
+
+(defun make-interpreted-debug-function (ir1-lambda)
+ (let ((home-lambda (sb!c::lambda-home ir1-lambda)))
+ (or (gethash home-lambda *ir1-lambda-debug-function*)
+ (setf (gethash home-lambda *ir1-lambda-debug-function*)
+ (%make-interpreted-debug-function home-lambda)))))
+
+;;;; DEBUG-BLOCKs
+
+;;; These exist for caching data stored in packed binary form in compiler
+;;; debug-blocks.
+(defstruct (debug-block (:constructor nil))
+ ;; Code-locations where execution continues after this block.
+ (successors nil :type list)
+ ;; This indicates whether the block is a special glob of code shared by
+ ;; various functions and tucked away elsewhere in a component. This kind of
+ ;; block has no start code-location. In an interpreted-debug-block, this is
+ ;; always nil. This slot is in all debug-blocks since it is an exported
+ ;; interface.
+ (elsewhere-p nil :type boolean))
+(def!method print-object ((obj debug-block) str)
+ (print-unreadable-object (obj str :type t)
+ (prin1 (debug-block-function-name obj) str)))
+
+#!+sb-doc
+(setf (fdocumentation 'debug-block-successors 'function)
+ "Returns the list of possible code-locations where execution may continue
+ when the basic-block represented by debug-block completes its execution.")
+
+#!+sb-doc
+(setf (fdocumentation 'debug-block-elsewhere-p 'function)
+ "Returns whether debug-block represents elsewhere code.")
+
+(defstruct (compiled-debug-block (:include debug-block)
+ (:constructor
+ make-compiled-debug-block
+ (code-locations successors elsewhere-p)))
+ ;; Code-location information for the block.
+ (code-locations nil :type simple-vector))
+
+(defstruct (interpreted-debug-block (:include debug-block
+ (elsewhere-p nil))
+ (:constructor %make-interpreted-debug-block
+ (ir1-block)))
+ ;; This is the IR1 block this debug-block represents.
+ (ir1-block nil :type sb!c::cblock)
+ ;; Code-location information for the block.
+ (locations :unparsed :type (or (member :unparsed) simple-vector)))
+
+(defvar *ir1-block-debug-block* (make-hash-table :test 'eq))
+
+;;; Make a DEBUG-BLOCK for the interpreter's IR1-BLOCK. If we have it
+;;; in the cache, return it. If we need to make it, then first make
+;;; DEBUG-BLOCKs for all the IR1-BLOCKs in IR1-BLOCK's home lambda;
+;;; this makes sure all the successors of IR1-BLOCK have DEBUG-BLOCKs.
+;;; We need this to fill in the resulting DEBUG-BLOCK's successors
+;;; list with DEBUG-BLOCKs, not IR1-BLOCKs. After making all the
+;;; possible DEBUG-BLOCKs we'll need to reference, go back over the
+;;; list of new DEBUG-BLOCKs and fill in their successor slots with
+;;; lists of DEBUG-BLOCKs. Then look up our argument IR1-BLOCK to find
+;;; its DEBUG-BLOCK since we know we have it now.
+(defun make-interpreted-debug-block (ir1-block)
+ (check-type ir1-block sb!c::cblock)
+ (let ((res (gethash ir1-block *ir1-block-debug-block*)))
+ (or res
+ (let ((lambda (sb!c::block-home-lambda ir1-block)))
+ (sb!c::do-blocks (block (sb!c::block-component ir1-block))
+ (when (eq lambda (sb!c::block-home-lambda block))
+ (push (setf (gethash block *ir1-block-debug-block*)
+ (%make-interpreted-debug-block block))
+ res)))
+ (dolist (block res)
+ (let* ((successors nil)
+ (cblock (interpreted-debug-block-ir1-block block))
+ (succ (sb!c::block-succ cblock))
+ (valid-succ
+ (if (and succ
+ (eq (car succ)
+ (sb!c::component-tail
+ (sb!c::block-component cblock))))
+ ()
+ succ)))
+ (dolist (sblock valid-succ)
+ (let ((dblock (gethash sblock *ir1-block-debug-block*)))
+ (when dblock
+ (push dblock successors))))
+ (setf (debug-block-successors block) (nreverse successors))))
+ (gethash ir1-block *ir1-block-debug-block*)))))
+
+;;;; breakpoints
+
+;;; This is an internal structure that manages information about a
+;;; breakpoint locations. See *COMPONENT-BREAKPOINT-OFFSETS*.
+(defstruct (breakpoint-data (:constructor make-breakpoint-data
+ (component offset)))
+ ;; This is the component in which the breakpoint lies.
+ component
+ ;; This is the byte offset into the component.
+ (offset nil :type sb!c::index)
+ ;; The original instruction replaced by the breakpoint.
+ (instruction nil :type (or null (unsigned-byte 32)))
+ ;; A list of user breakpoints at this location.
+ (breakpoints nil :type list))
+(def!method print-object ((obj breakpoint-data) str)
+ (print-unreadable-object (obj str :type t)
+ (format str "~S at ~S"
+ (debug-function-name
+ (debug-function-from-pc (breakpoint-data-component obj)
+ (breakpoint-data-offset obj)))
+ (breakpoint-data-offset obj))))
+
+(defstruct (breakpoint (:constructor %make-breakpoint
+ (hook-function what kind %info)))
+ ;; This is the function invoked when execution encounters the
+ ;; breakpoint. It takes a frame, the breakpoint, and optionally a
+ ;; list of values. Values are supplied for :FUNCTION-END breakpoints
+ ;; as values to return for the function containing the breakpoint.
+ ;; :FUNCTION-END breakpoint hook-functions also take a cookie
+ ;; argument. See COOKIE-FUN slot.
+ (hook-function nil :type function)
+ ;; CODE-LOCATION or DEBUG-FUNCTION
+ (what nil :type (or code-location debug-function))
+ ;; :CODE-LOCATION, :FUNCTION-START, or :FUNCTION-END for that kind
+ ;; of breakpoint. :UNKNOWN-RETURN-PARTNER if this is the partner of
+ ;; a :code-location breakpoint at an :UNKNOWN-RETURN code-location.
+ (kind nil :type (member :code-location :function-start :function-end
+ :unknown-return-partner))
+ ;; Status helps the user and the implementation.
+ (status :inactive :type (member :active :inactive :deleted))
+ ;; This is a backpointer to a breakpoint-data.
+ (internal-data nil :type (or null breakpoint-data))
+ ;; With code-locations whose type is :UNKNOWN-RETURN, there are
+ ;; really two breakpoints: one at the multiple-value entry point,
+ ;; and one at the single-value entry point. This slot holds the
+ ;; breakpoint for the other one, or NIL if this isn't at an
+ ;; :UNKNOWN-RETURN code location.
+ (unknown-return-partner nil :type (or null breakpoint))
+ ;; :FUNCTION-END breakpoints use a breakpoint at the :FUNCTION-START
+ ;; to establish the end breakpoint upon function entry. We do this
+ ;; by frobbing the LRA to jump to a special piece of code that
+ ;; breaks and provides the return values for the returnee. This slot
+ ;; points to the start breakpoint, so we can activate, deactivate,
+ ;; and delete it.
+ (start-helper nil :type (or null breakpoint))
+ ;; This is a hook users supply to get a dynamically unique cookie
+ ;; for identifying :FUNCTION-END breakpoint executions. That is, if
+ ;; there is one :FUNCTION-END breakpoint, but there may be multiple
+ ;; pending calls of its function on the stack. This function takes
+ ;; the cookie, and the hook-function takes the cookie too.
+ (cookie-fun nil :type (or null function))
+ ;; This slot users can set with whatever information they find useful.
+ %info)
+(def!method print-object ((obj breakpoint) str)
+ (let ((what (breakpoint-what obj)))
+ (print-unreadable-object (obj str :type t)
+ (format str
+ "~S~:[~;~:*~S~]"
+ (etypecase what
+ (code-location what)
+ (debug-function (debug-function-name what)))
+ (etypecase what
+ (code-location nil)
+ (debug-function (breakpoint-kind obj)))))))
+
+#!+sb-doc
+(setf (fdocumentation 'breakpoint-hook-function 'function)
+ "Returns the breakpoint's function the system calls when execution encounters
+ the breakpoint, and it is active. This is SETF'able.")
+
+#!+sb-doc
+(setf (fdocumentation 'breakpoint-what 'function)
+ "Returns the breakpoint's what specification.")
+
+#!+sb-doc
+(setf (fdocumentation 'breakpoint-kind 'function)
+ "Returns the breakpoint's kind specification.")
+
+;;;; CODE-LOCATIONs
+
+(defstruct (code-location (:constructor nil))
+ ;; This is the debug-function containing code-location.
+ (debug-function nil :type debug-function)
+ ;; This is initially :UNSURE. Upon first trying to access an
+ ;; :unparsed slot, if the data is unavailable, then this becomes t,
+ ;; and the code-location is unknown. If the data is available, this
+ ;; becomes nil, a known location. We can't use a separate type
+ ;; code-location for this since we must return code-locations before
+ ;; we can tell whether they're known or unknown. For example, when
+ ;; parsing the stack, we don't want to unpack all the variables and
+ ;; blocks just to make frames.
+ (%unknown-p :unsure :type (member t nil :unsure))
+ ;; This is the debug-block containing code-location. Possibly toss
+ ;; this out and just find it in the blocks cache in debug-function.
+ (%debug-block :unparsed :type (or debug-block (member :unparsed)))
+ ;; This is the number of forms processed by the compiler or loader
+ ;; before the top-level form containing this code-location.
+ (%tlf-offset :unparsed :type (or sb!c::index (member :unparsed)))
+ ;; This is the depth-first number of the node that begins
+ ;; code-location within its top-level form.
+ (%form-number :unparsed :type (or sb!c::index (member :unparsed))))
+(def!method print-object ((obj code-location) str)
+ (print-unreadable-object (obj str :type t)
+ (prin1 (debug-function-name (code-location-debug-function obj))
+ str)))
+
+#!+sb-doc
+(setf (fdocumentation 'code-location-debug-function 'function)
+ "Returns the debug-function representing information about the function
+ corresponding to the code-location.")
+
+(defstruct (compiled-code-location
+ (:include code-location)
+ (:constructor make-known-code-location
+ (pc debug-function %tlf-offset %form-number
+ %live-set kind &aux (%unknown-p nil)))
+ (:constructor make-compiled-code-location (pc debug-function)))
+ ;; This is an index into debug-function's component slot.
+ (pc nil :type sb!c::index)
+ ;; This is a bit-vector indexed by a variable's position in
+ ;; DEBUG-FUNCTION-DEBUG-VARS indicating whether the variable has a
+ ;; valid value at this code-location. (unexported).
+ (%live-set :unparsed :type (or simple-bit-vector (member :unparsed)))
+ ;; (unexported) To see SB!C::LOCATION-KIND, do
+ ;; (SB!KERNEL:TYPE-EXPAND 'SB!C::LOCATION-KIND).
+ (kind :unparsed :type (or (member :unparsed) sb!c::location-kind)))
+
+(defstruct (interpreted-code-location
+ (:include code-location
+ (%unknown-p nil))
+ (:constructor make-interpreted-code-location
+ (ir1-node debug-function)))
+ ;; This is an index into debug-function's component slot.
+ (ir1-node nil :type sb!c::node))
+
+;;; DEBUG-SOURCEs
+
+#!-sb-fluid (declaim (inline debug-source-root-number))
+(defun debug-source-root-number (debug-source)
+ #!+sb-doc
+ "Returns the number of top-level forms processed by the compiler before
+ compiling this source. If this source is uncompiled, this is zero. This
+ may be zero even if the source is compiled since the first form in the first
+ file compiled in one compilation, for example, must have a root number of
+ zero -- the compiler saw no other top-level forms before it."
+ (sb!c::debug-source-source-root debug-source))
+
+#!+sb-doc
+(setf (fdocumentation 'sb!c::debug-source-from 'function)
+ "Returns an indication of the type of source. The following are the possible
+ values:
+ :file from a file (obtained by COMPILE-FILE if compiled).
+ :lisp from Lisp (obtained by COMPILE if compiled).")
+
+#!+sb-doc
+(setf (fdocumentation 'sb!c::debug-source-name 'function)
+ "Returns the actual source in some sense represented by debug-source, which
+ is related to DEBUG-SOURCE-FROM:
+ :file the pathname of the file.
+ :lisp a lambda-expression.")
+
+#!+sb-doc
+(setf (fdocumentation 'sb!c::debug-source-created 'function)
+ "Returns the universal time someone created the source. This may be nil if
+ it is unavailable.")
+
+#!+sb-doc
+(setf (fdocumentation 'sb!c::debug-source-compiled 'function)
+ "Returns the time someone compiled the source. This is nil if the source
+ is uncompiled.")
+
+#!+sb-doc
+(setf (fdocumentation 'sb!c::debug-source-start-positions 'function)
+ "This function returns the file position of each top-level form as an array
+ if debug-source is from a :file. If DEBUG-SOURCE-FROM is :lisp,
+ this returns nil.")
+
+#!+sb-doc
+(setf (fdocumentation 'sb!c::debug-source-p 'function)
+ "Returns whether object is a debug-source.")
+\f
+;;;; frames
+
+;;; This is used in FIND-ESCAPE-FRAME and with the bogus components
+;;; and LRAs used for :function-end breakpoints. When a components
+;;; debug-info slot is :bogus-lra, then the real-lra-slot contains the
+;;; real component to continue executing, as opposed to the bogus
+;;; component which appeared in some frame's LRA location.
+(defconstant real-lra-slot sb!vm:code-constants-offset)
+
+;;; These are magically converted by the compiler.
+(defun current-sp () (current-sp))
+(defun current-fp () (current-fp))
+(defun stack-ref (s n) (stack-ref s n))
+(defun %set-stack-ref (s n value) (%set-stack-ref s n value))
+(defun function-code-header (fun) (function-code-header fun))
+#!-gengc (defun lra-code-header (lra) (lra-code-header lra))
+(defun make-lisp-obj (value) (make-lisp-obj value))
+(defun get-lisp-obj-address (thing) (get-lisp-obj-address thing))
+(defun function-word-offset (fun) (function-word-offset fun))
+
+#!-sb-fluid (declaim (inline cstack-pointer-valid-p))
+(defun cstack-pointer-valid-p (x)
+ (declare (type system-area-pointer x))
+ #!-x86
+ (and (sap< x (current-sp))
+ (sap<= #!-gengc (sb!alien:alien-sap
+ (sb!alien:extern-alien "control_stack" (* t)))
+ #!+gengc (mutator-control-stack-base)
+ x)
+ (zerop (logand (sap-int x) #b11)))
+ #!+x86 ;; stack grows to low address values
+ (and (sap>= x (current-sp))
+ (sap> (sb!alien:alien-sap (sb!alien:extern-alien "control_stack_end"
+ (* t)))
+ x)
+ (zerop (logand (sap-int x) #b11))))
+
+#!+(or gengc x86)
+(sb!alien:def-alien-routine component-ptr-from-pc (system-area-pointer)
+ (pc system-area-pointer))
+
+#!+(or gengc x86)
+(defun component-from-component-ptr (component-ptr)
+ (declare (type system-area-pointer component-ptr))
+ (make-lisp-obj (logior (sap-int component-ptr)
+ sb!vm:other-pointer-type)))
+
+;;;; X86 support
+
+#!+x86
+(progn
+
+(defun compute-lra-data-from-pc (pc)
+ (declare (type system-area-pointer pc))
+ (let ((component-ptr (component-ptr-from-pc pc)))
+ (unless (sap= component-ptr (int-sap #x0))
+ (let* ((code (component-from-component-ptr component-ptr))
+ (code-header-len (* (get-header-data code) sb!vm:word-bytes))
+ (pc-offset (- (sap-int pc)
+ (- (get-lisp-obj-address code)
+ sb!vm:other-pointer-type)
+ code-header-len)))
+; (format t "c-lra-fpc ~A ~A ~A~%" pc code pc-offset)
+ (values pc-offset code)))))
+
+(defconstant sb!vm::nargs-offset #.sb!vm::ecx-offset)
+
+;;; Check for a valid return address - it could be any valid C/Lisp
+;;; address.
+;;;
+;;; XXX Could be a little smarter.
+#!-sb-fluid (declaim (inline ra-pointer-valid-p))
+(defun ra-pointer-valid-p (ra)
+ (declare (type system-area-pointer ra))
+ (and
+ ;; Not the first page which is unmapped.
+ (>= (sap-int ra) 4096)
+ ;; Not a Lisp stack pointer.
+ (or (sap< ra (current-sp))
+ (sap>= ra (sb!alien:alien-sap
+ (sb!alien:extern-alien "control_stack_end" (* t)))))))
+
+;;; Try to find a valid previous stack. This is complex on the x86 as
+;;; it can jump between C and Lisp frames. To help find a valid frame
+;;; it searches backwards.
+;;;
+;;; XXX Should probably check whether it has reached the bottom of the
+;;; stack.
+;;;
+;;; XXX Should handle interrupted frames, both Lisp and C. At present it
+;;; manages to find a fp trail, see linux hack below.
+(defun x86-call-context (fp &key (depth 8))
+ (declare (type system-area-pointer fp)
+ (fixnum depth))
+ ;;(format t "*CC ~S ~S~%" fp depth)
+ (cond
+ ((not (cstack-pointer-valid-p fp))
+ #+nil (format t "debug invalid fp ~S~%" fp)
+ nil)
+ (t
+ ;; Check the two possible frame pointers.
+ (let ((lisp-ocfp (sap-ref-sap fp (- (* (1+ sb!vm::ocfp-save-offset) 4))))
+ (lisp-ra (sap-ref-sap fp (- (* (1+ sb!vm::return-pc-save-offset)
+ 4))))
+ (c-ocfp (sap-ref-sap fp (* 0 sb!vm:word-bytes)))
+ (c-ra (sap-ref-sap fp (* 1 sb!vm:word-bytes))))
+ (cond ((and (sap> lisp-ocfp fp) (cstack-pointer-valid-p lisp-ocfp)
+ (ra-pointer-valid-p lisp-ra)
+ (sap> c-ocfp fp) (cstack-pointer-valid-p c-ocfp)
+ (ra-pointer-valid-p c-ra))
+ #+nil (format t
+ "*C Both valid ~S ~S ~S ~S~%"
+ lisp-ocfp lisp-ra c-ocfp c-ra)
+ ;; Look forward another step to check their validity.
+ (let ((lisp-path-fp (x86-call-context lisp-ocfp
+ :depth (- depth 1)))
+ (c-path-fp (x86-call-context c-ocfp :depth (- depth 1))))
+ (cond ((and lisp-path-fp c-path-fp)
+ ;; Both still seem valid - choose the smallest.
+ #+nil (format t "debug: both still valid ~S ~S ~S ~S~%"
+ lisp-ocfp lisp-ra c-ocfp c-ra)
+ (if (sap< lisp-ocfp c-ocfp)
+ (values lisp-ra lisp-ocfp)
+ (values c-ra c-ocfp)))
+ (lisp-path-fp
+ ;; The lisp convention is looking good.
+ #+nil (format t "*C lisp-ocfp ~S ~S~%" lisp-ocfp lisp-ra)
+ (values lisp-ra lisp-ocfp))
+ (c-path-fp
+ ;; The C convention is looking good.
+ #+nil (format t "*C c-ocfp ~S ~S~%" c-ocfp c-ra)
+ (values c-ra c-ocfp))
+ (t
+ ;; Neither seems right?
+ #+nil (format t "debug: no valid2 fp found ~S ~S~%"
+ lisp-ocfp c-ocfp)
+ nil))))
+ ((and (sap> lisp-ocfp fp) (cstack-pointer-valid-p lisp-ocfp)
+ (ra-pointer-valid-p lisp-ra))
+ ;; The lisp convention is looking good.
+ #+nil (format t "*C lisp-ocfp ~S ~S~%" lisp-ocfp lisp-ra)
+ (values lisp-ra lisp-ocfp))
+ ((and (sap> c-ocfp fp) (cstack-pointer-valid-p c-ocfp)
+ #!-linux (ra-pointer-valid-p c-ra))
+ ;; The C convention is looking good.
+ #+nil (format t "*C c-ocfp ~S ~S~%" c-ocfp c-ra)
+ (values c-ra c-ocfp))
+ (t
+ #+nil (format t "debug: no valid fp found ~S ~S~%"
+ lisp-ocfp c-ocfp)
+ nil))))))
+
+) ; #+x86 PROGN
+\f
+;;; Convert the descriptor into a SAP. The bits all stay the same, we just
+;;; change our notion of what we think they are.
+#!-sb-fluid (declaim (inline descriptor-sap))
+(defun descriptor-sap (x)
+ (int-sap (get-lisp-obj-address x)))
+
+(defun top-frame ()
+ #!+sb-doc
+ "Returns the top frame of the control stack as it was before calling this
+ function."
+ (multiple-value-bind (fp pc) (%caller-frame-and-pc)
+ (possibly-an-interpreted-frame
+ (compute-calling-frame (descriptor-sap fp)
+ #!-gengc pc #!+gengc (descriptor-sap pc)
+ nil)
+ nil)))
+
+(defun flush-frames-above (frame)
+ #!+sb-doc
+ "Flush all of the frames above FRAME, and renumber all the frames below
+ FRAME."
+ (setf (frame-up frame) nil)
+ (do ((number 0 (1+ number))
+ (frame frame (frame-%down frame)))
+ ((not (frame-p frame)))
+ (setf (frame-number frame) number)))
+
+;;; We have to access the old-fp and return-pc out of frame and pass them to
+;;; COMPUTE-CALLING-FRAME.
+(defun frame-down (frame)
+ #!+sb-doc
+ "Returns the frame immediately below frame on the stack. When frame is
+ the bottom of the stack, this returns nil."
+ (let ((down (frame-%down frame)))
+ (if (eq down :unparsed)
+ (let* ((real (frame-real-frame frame))
+ (debug-fun (frame-debug-function real)))
+ (setf (frame-%down frame)
+ (etypecase debug-fun
+ (compiled-debug-function
+ (let ((c-d-f (compiled-debug-function-compiler-debug-fun
+ debug-fun)))
+ (possibly-an-interpreted-frame
+ (compute-calling-frame
+ (descriptor-sap
+ (get-context-value
+ real sb!vm::ocfp-save-offset
+ (sb!c::compiled-debug-function-old-fp c-d-f)))
+ #!-gengc
+ (get-context-value
+ real sb!vm::lra-save-offset
+ (sb!c::compiled-debug-function-return-pc c-d-f))
+ #!+gengc
+ (descriptor-sap
+ (get-context-value
+ real sb!vm::ra-save-offset
+ (sb!c::compiled-debug-function-return-pc c-d-f)))
+ frame)
+ frame)))
+ (bogus-debug-function
+ (let ((fp (frame-pointer real)))
+ (when (cstack-pointer-valid-p fp)
+ #!+x86
+ (multiple-value-bind (ra ofp) (x86-call-context fp)
+ (compute-calling-frame ofp ra frame))
+ #!-x86
+ (compute-calling-frame
+ #!-alpha
+ (sap-ref-sap fp (* sb!vm::ocfp-save-offset
+ sb!vm:word-bytes))
+ #!+alpha
+ (int-sap
+ (sap-ref-32 fp (* sb!vm::ocfp-save-offset
+ sb!vm:word-bytes)))
+
+ #!-gengc
+ (stack-ref fp sb!vm::lra-save-offset)
+ #!+gengc
+ (sap-ref-sap fp (* sb!vm::ra-save-offset
+ sb!vm:word-bytes))
+ frame)))))))
+ down)))
+
+;;; Get the old FP or return PC out of FRAME. STACK-SLOT is the
+;;; standard save location offset on the stack. LOC is the saved
+;;; SC-OFFSET describing the main location.
+#!-x86
+(defun get-context-value (frame stack-slot loc)
+ (declare (type compiled-frame frame) (type unsigned-byte stack-slot)
+ (type sb!c::sc-offset loc))
+ (let ((pointer (frame-pointer frame))
+ (escaped (compiled-frame-escaped frame)))
+ (if escaped
+ (sub-access-debug-var-slot pointer loc escaped)
+ (stack-ref pointer stack-slot))))
+#!+x86
+(defun get-context-value (frame stack-slot loc)
+ (declare (type compiled-frame frame) (type unsigned-byte stack-slot)
+ (type sb!c::sc-offset loc))
+ (let ((pointer (frame-pointer frame))
+ (escaped (compiled-frame-escaped frame)))
+ (if escaped
+ (sub-access-debug-var-slot pointer loc escaped)
+ (ecase stack-slot
+ (#.sb!vm::ocfp-save-offset
+ (stack-ref pointer stack-slot))
+ (#.sb!vm::lra-save-offset
+ (sap-ref-sap pointer (- (* (1+ stack-slot) 4))))))))
+
+#!-x86
+(defun (setf get-context-value) (value frame stack-slot loc)
+ (declare (type compiled-frame frame) (type unsigned-byte stack-slot)
+ (type sb!c::sc-offset loc))
+ (let ((pointer (frame-pointer frame))
+ (escaped (compiled-frame-escaped frame)))
+ (if escaped
+ (sub-set-debug-var-slot pointer loc value escaped)
+ (setf (stack-ref pointer stack-slot) value))))
+
+#!+x86
+(defun (setf get-context-value) (value frame stack-slot loc)
+ (declare (type compiled-frame frame) (type unsigned-byte stack-slot)
+ (type sb!c::sc-offset loc))
+ (let ((pointer (frame-pointer frame))
+ (escaped (compiled-frame-escaped frame)))
+ (if escaped
+ (sub-set-debug-var-slot pointer loc value escaped)
+ (ecase stack-slot
+ (#.sb!vm::ocfp-save-offset
+ (setf (stack-ref pointer stack-slot) value))
+ (#.sb!vm::lra-save-offset
+ (setf (sap-ref-sap pointer (- (* (1+ stack-slot) 4))) value))))))
+
+(defvar *debugging-interpreter* nil
+ #!+sb-doc
+ "When set, the debugger foregoes making interpreted-frames, so you can
+ debug the functions that manifest the interpreter.")
+
+;;; This takes a newly computed frame, FRAME, and the frame above it
+;;; on the stack, UP-FRAME, which is possibly NIL. FRAME is NIL when
+;;; we hit the bottom of the control stack. When FRAME represents a
+;;; call to SB!EVAL::INTERNAL-APPLY-LOOP, we make an interpreted frame
+;;; to replace FRAME. The interpreted frame points to FRAME.
+(defun possibly-an-interpreted-frame (frame up-frame)
+ (if (or (not frame)
+ (not (eq (debug-function-name (frame-debug-function frame))
+ 'sb!eval::internal-apply-loop))
+ *debugging-interpreter*
+ (compiled-frame-escaped frame))
+ frame
+ (flet ((get-var (name location)
+ (let ((vars (sb!di:ambiguous-debug-vars
+ (sb!di:frame-debug-function frame) name)))
+ (when (or (null vars) (> (length vars) 1))
+ (error "zero or more than one ~A variable in ~
+ SB!EVAL::INTERNAL-APPLY-LOOP"
+ (string-downcase name)))
+ (if (eq (debug-var-validity (car vars) location)
+ :valid)
+ (car vars)))))
+ (let* ((code-loc (frame-code-location frame))
+ (ptr-var (get-var "FRAME-PTR" code-loc))
+ (node-var (get-var "NODE" code-loc))
+ (closure-var (get-var "CLOSURE" code-loc)))
+ (if (and ptr-var node-var closure-var)
+ (let* ((node (debug-var-value node-var frame))
+ (d-fun (make-interpreted-debug-function
+ (sb!c::block-home-lambda (sb!c::node-block
+ node)))))
+ (make-interpreted-frame
+ (debug-var-value ptr-var frame)
+ up-frame
+ d-fun
+ (make-interpreted-code-location node d-fun)
+ (frame-number frame)
+ frame
+ (debug-var-value closure-var frame)))
+ frame)))))
+
+;;; This returns a frame for the one existing in time immediately
+;;; prior to the frame referenced by current-fp. This is current-fp's
+;;; caller or the next frame down the control stack. If there is no
+;;; down frame, this returns nil for the bottom of the stack. Up-frame
+;;; is the up link for the resulting frame object, and it is nil when
+;;; we call this to get the top of the stack.
+;;;
+;;; The current frame contains the pointer to the temporally previous
+;;; frame we want, and the current frame contains the pc at which we
+;;; will continue executing upon returning to that previous frame.
+;;;
+;;; Note: Sometimes LRA is actually a fixnum. This happens when lisp
+;;; calls into C. In this case, the code object is stored on the stack
+;;; after the LRA, and the LRA is the word offset.
+#!-(or gengc x86)
+(defun compute-calling-frame (caller lra up-frame)
+ (declare (type system-area-pointer caller))
+ (when (cstack-pointer-valid-p caller)
+ (multiple-value-bind (code pc-offset escaped)
+ (if lra
+ (multiple-value-bind (word-offset code)
+ (if (fixnump lra)
+ (let ((fp (frame-pointer up-frame)))
+ (values lra
+ (stack-ref fp (1+ sb!vm::lra-save-offset))))
+ (values (get-header-data lra)
+ (lra-code-header lra)))
+ (if code
+ (values code
+ (* (1+ (- word-offset (get-header-data code)))
+ sb!vm:word-bytes)
+ nil)
+ (values :foreign-function
+ 0
+ nil)))
+ (find-escaped-frame caller))
+ (if (and (code-component-p code)
+ (eq (%code-debug-info code) :bogus-lra))
+ (let ((real-lra (code-header-ref code real-lra-slot)))
+ (compute-calling-frame caller real-lra up-frame))
+ (let ((d-fun (case code
+ (:undefined-function
+ (make-bogus-debug-function
+ "undefined function"))
+ (:foreign-function
+ (make-bogus-debug-function
+ "foreign function call land"))
+ ((nil)
+ (make-bogus-debug-function
+ "bogus stack frame"))
+ (t
+ (debug-function-from-pc code pc-offset)))))
+ (make-compiled-frame caller up-frame d-fun
+ (code-location-from-pc d-fun pc-offset
+ escaped)
+ (if up-frame (1+ (frame-number up-frame)) 0)
+ escaped))))))
+
+#!+x86
+(defun compute-calling-frame (caller ra up-frame)
+ (declare (type system-area-pointer caller ra))
+; (format t "ccf: ~A ~A ~A~%" caller ra up-frame)
+ (when (cstack-pointer-valid-p caller)
+; (format t "ccf2~%")
+ ;; First check for an escaped frame.
+ (multiple-value-bind (code pc-offset escaped) (find-escaped-frame caller)
+ (cond (code
+ ;; If it's escaped it may be a function end breakpoint trap.
+; (format t "ccf2: escaped ~S ~S~%" code pc-offset)
+ (when (and (code-component-p code)
+ (eq (%code-debug-info code) :bogus-lra))
+ ;; If :bogus-lra grab the real lra.
+ (setq pc-offset (code-header-ref
+ code (1+ real-lra-slot)))
+ (setq code (code-header-ref code real-lra-slot))
+; (format t "ccf3 :bogus-lra ~S ~S~%" code pc-offset)
+ (assert code)))
+ (t
+ ;; Not escaped
+ (multiple-value-setq (pc-offset code)
+ (compute-lra-data-from-pc ra))
+; (format t "ccf4 ~S ~S~%" code pc-offset)
+ (unless code
+ (setf code :foreign-function
+ pc-offset 0
+ escaped nil))))
+
+ (let ((d-fun (case code
+ (:undefined-function
+ (make-bogus-debug-function
+ "undefined function"))
+ (:foreign-function
+ (make-bogus-debug-function
+ "foreign function call land"))
+ ((nil)
+ (make-bogus-debug-function
+ "bogus stack frame"))
+ (t
+ (debug-function-from-pc code pc-offset)))))
+ (make-compiled-frame caller up-frame d-fun
+ (code-location-from-pc d-fun pc-offset
+ escaped)
+ (if up-frame (1+ (frame-number up-frame)) 0)
+ escaped)))))
+
+#!-(or gengc x86)
+;;; FIXME: The original CMU CL code had support for this case, but it
+;;; must have been fairly stale even in CMU CL, since it had
+;;; references to the MIPS package, and there have been enough
+;;; relevant changes in SBCL (particularly using
+;;; POSIX/SIGACTION0-style signal context instead of BSD-style
+;;; sigcontext) that this code is unmaintainable (since as of
+;;; sbcl-0.6.7, and for the foreseeable future, we can't test it,
+;;; since we only support X86 and its gencgc).
+;;;
+;;; If we restore this case, the best approach would be to go back to
+;;; the original CMU CL code and start from there.
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (error "hopelessly stale"))
+#!+x86
+(defun find-escaped-frame (frame-pointer)
+ (declare (type system-area-pointer frame-pointer))
+ (dotimes (index sb!impl::*free-interrupt-context-index* (values nil 0 nil))
+ (sb!alien:with-alien
+ ((lisp-interrupt-contexts (array (* os-context-t) nil)
+ :extern))
+ (let ((context (sb!alien:deref lisp-interrupt-contexts index)))
+ (when (= (sap-int frame-pointer)
+ (sb!vm:context-register context sb!vm::cfp-offset))
+ (without-gcing
+ (let* ((component-ptr (component-ptr-from-pc
+ (sb!vm:context-pc context)))
+ (code (if (sap= component-ptr (int-sap #x0))
+ nil ; FIXME: UNLESS might be clearer than IF.
+ (component-from-component-ptr component-ptr))))
+ (when (null code)
+ (return (values code 0 context)))
+ (let* ((code-header-len (* (get-header-data code)
+ sb!vm:word-bytes))
+ (pc-offset
+ (- (sap-int (sb!vm:context-pc context))
+ (- (get-lisp-obj-address code)
+ sb!vm:other-pointer-type)
+ code-header-len)))
+ (unless (<= 0 pc-offset
+ (* (code-header-ref code sb!vm:code-code-size-slot)
+ sb!vm:word-bytes))
+ ;; We were in an assembly routine. Therefore, use the LRA as
+ ;; the pc.
+ (format t "** pc-offset ~S not in code obj ~S?~%"
+ pc-offset code))
+ (return
+ (values code pc-offset context))))))))))
+
+;;; Find the code object corresponding to the object represented by
+;;; bits and return it. We assume bogus functions correspond to the
+;;; undefined-function.
+#!-gengc
+(defun code-object-from-bits (bits)
+ (declare (type (unsigned-byte 32) bits))
+ (let ((object (make-lisp-obj bits)))
+ (if (functionp object)
+ (or (function-code-header object)
+ :undefined-function)
+ (let ((lowtag (get-lowtag object)))
+ (if (= lowtag sb!vm:other-pointer-type)
+ (let ((type (get-type object)))
+ (cond ((= type sb!vm:code-header-type)
+ object)
+ ((= type sb!vm:return-pc-header-type)
+ (lra-code-header object))
+ (t
+ nil))))))))
+
+;;; SB!KERNEL:*SAVED-STATE-CHAIN* -- maintained by the C code as a
+;;; list of SAPs, each SAP pointing to a saved exception state.
+#!+gengc
+(declaim (special *saved-state-chain*))
+
+;;; CMU CL had
+;;; (DEFUN LOOKUP-TRACE-TABLE-ENTRY (COMPONENT PC) ..)
+;;; for this case, but it hasn't been maintained in SBCL.
+#!+gengc
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (error "hopelessly stale"))
+
+;;; CMU CL had
+;;; (DEFUN EXTRACT-INFO-FROM-STATE (STATE) ..)
+;;; for this case, but it hasn't been maintained in SBCL.
+#!+gengc
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (error "hopelessly stale"))
+
+;;; CMU CL had
+;;; (DEFUN COMPUTE-CALLING-FRAME (OCFP RA UP-FRAME) ..)
+;;; for this case, but it hasn't been maintained in SBCL.
+#!+gengc
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (error "hopelessly stale"))
+\f
+;;;; frame utilities
+
+;;; This returns a COMPILED-DEBUG-FUNCTION for code and pc. We fetch
+;;; the SB!C::DEBUG-INFO and run down its function-map to get a
+;;; SB!C::COMPILED-DEBUG-FUNCTION from the pc. The result only needs
+;;; to reference the component, for function constants, and the
+;;; SB!C::COMPILED-DEBUG-FUNCTION.
+(defun debug-function-from-pc (component pc)
+ (let ((info (%code-debug-info component)))
+ (cond
+ ((not info)
+ (debug-signal 'no-debug-info))
+ ((eq info :bogus-lra)
+ (make-bogus-debug-function "function end breakpoint"))
+ (t
+ (let* ((function-map (get-debug-info-function-map info))
+ (len (length function-map)))
+ (declare (simple-vector function-map))
+ (if (= len 1)
+ (make-compiled-debug-function (svref function-map 0) component)
+ (let ((i 1)
+ (elsewhere-p
+ (>= pc (sb!c::compiled-debug-function-elsewhere-pc
+ (svref function-map 0)))))
+ ;; FIXME: I don't think SB!C is the home package of INDEX.
+ (declare (type sb!c::index i))
+ (loop
+ (when (or (= i len)
+ (< pc (if elsewhere-p
+ (sb!c::compiled-debug-function-elsewhere-pc
+ (svref function-map (1+ i)))
+ (svref function-map i))))
+ (return (make-compiled-debug-function
+ (svref function-map (1- i))
+ component)))
+ (incf i 2)))))))))
+
+;;; This returns a code-location for the COMPILED-DEBUG-FUNCTION,
+;;; DEBUG-FUN, and the pc into its code vector. If we stopped at a
+;;; breakpoint, find the CODE-LOCATION for that breakpoint. Otherwise,
+;;; make an :UNSURE code location, so it can be filled in when we
+;;; figure out what is going on.
+(defun code-location-from-pc (debug-fun pc escaped)
+ (or (and (compiled-debug-function-p debug-fun)
+ escaped
+ (let ((data (breakpoint-data
+ (compiled-debug-function-component debug-fun)
+ pc nil)))
+ (when (and data (breakpoint-data-breakpoints data))
+ (let ((what (breakpoint-what
+ (first (breakpoint-data-breakpoints data)))))
+ (when (compiled-code-location-p what)
+ what)))))
+ (make-compiled-code-location pc debug-fun)))
+
+(defun frame-catches (frame)
+ #!+sb-doc
+ "Returns an a-list mapping catch tags to code-locations. These are
+ code-locations at which execution would continue with frame as the top
+ frame if someone threw to the corresponding tag."
+ (let ((catch
+ #!-gengc (descriptor-sap sb!impl::*current-catch-block*)
+ #!+gengc (mutator-current-catch-block))
+ (res nil)
+ (fp (frame-pointer (frame-real-frame frame))))
+ (loop
+ (when (zerop (sap-int catch)) (return (nreverse res)))
+ (when (sap= fp
+ #!-alpha
+ (sap-ref-sap catch
+ (* sb!vm:catch-block-current-cont-slot
+ sb!vm:word-bytes))
+ #!+alpha
+ (:int-sap
+ (sap-ref-32 catch
+ (* sb!vm:catch-block-current-cont-slot
+ sb!vm:word-bytes))))
+ (let* (#!-(or gengc x86)
+ (lra (stack-ref catch sb!vm:catch-block-entry-pc-slot))
+ #!+(or gengc x86)
+ (ra (sap-ref-sap
+ catch (* sb!vm:catch-block-entry-pc-slot
+ sb!vm:word-bytes)))
+ #!-x86
+ (component
+ (stack-ref catch sb!vm:catch-block-current-code-slot))
+ #!+x86
+ (component (component-from-component-ptr
+ (component-ptr-from-pc ra)))
+ (offset
+ #!-(or gengc x86)
+ (* (- (1+ (get-header-data lra))
+ (get-header-data component))
+ sb!vm:word-bytes)
+ #!+gengc
+ (+ (- (sap-int ra)
+ (get-lisp-obj-address component)
+ (get-header-data component))
+ sb!vm:other-pointer-type)
+ #!+x86
+ (- (sap-int ra)
+ (- (get-lisp-obj-address component)
+ sb!vm:other-pointer-type)
+ (* (get-header-data component) sb!vm:word-bytes))))
+ (push (cons #!-x86
+ (stack-ref catch sb!vm:catch-block-tag-slot)
+ #!+x86
+ (make-lisp-obj
+ (sap-ref-32 catch (* sb!vm:catch-block-tag-slot
+ sb!vm:word-bytes)))
+ (make-compiled-code-location
+ offset (frame-debug-function frame)))
+ res)))
+ (setf catch
+ #!-alpha
+ (sap-ref-sap catch
+ (* sb!vm:catch-block-previous-catch-slot
+ sb!vm:word-bytes))
+ #!+alpha
+ (:int-sap
+ (sap-ref-32 catch
+ (* sb!vm:catch-block-previous-catch-slot
+ sb!vm:word-bytes)))))))
+
+;;; If an interpreted frame, return the real frame, otherwise frame.
+(defun frame-real-frame (frame)
+ (etypecase frame
+ (compiled-frame frame)
+ (interpreted-frame (interpreted-frame-real-frame frame))))
+\f
+;;;; operations on DEBUG-FUNCTIONs
+
+(defmacro do-debug-function-blocks ((block-var debug-function &optional result)
+ &body body)
+ #!+sb-doc
+ "Executes the forms in a context with block-var bound to each debug-block in
+ debug-function successively. Result is an optional form to execute for
+ return values, and DO-DEBUG-FUNCTION-BLOCKS returns nil if there is no
+ result form. This signals a no-debug-blocks condition when the
+ debug-function lacks debug-block information."
+ (let ((blocks (gensym))
+ (i (gensym)))
+ `(let ((,blocks (debug-function-debug-blocks ,debug-function)))
+ (declare (simple-vector ,blocks))
+ (dotimes (,i (length ,blocks) ,result)
+ (let ((,block-var (svref ,blocks ,i)))
+ ,@body)))))
+
+(defmacro do-debug-function-variables ((var debug-function &optional result)
+ &body body)
+ #!+sb-doc
+ "Executes body in a context with var bound to each debug-var in
+ debug-function. This returns the value of executing result (defaults to
+ nil). This may iterate over only some of debug-function's variables or none
+ depending on debug policy; for example, possibly the compilation only
+ preserved argument information."
+ (let ((vars (gensym))
+ (i (gensym)))
+ `(let ((,vars (debug-function-debug-vars ,debug-function)))
+ (declare (type (or null simple-vector) ,vars))
+ (if ,vars
+ (dotimes (,i (length ,vars) ,result)
+ (let ((,var (svref ,vars ,i)))
+ ,@body))
+ ,result))))
+
+(defun debug-function-function (debug-function)
+ #!+sb-doc
+ "Returns the Common Lisp function associated with the debug-function. This
+ returns nil if the function is unavailable or is non-existent as a user
+ callable function object."
+ (let ((cached-value (debug-function-%function debug-function)))
+ (if (eq cached-value :unparsed)
+ (setf (debug-function-%function debug-function)
+ (etypecase debug-function
+ (compiled-debug-function
+ (let ((component
+ (compiled-debug-function-component debug-function))
+ (start-pc
+ (sb!c::compiled-debug-function-start-pc
+ (compiled-debug-function-compiler-debug-fun
+ debug-function))))
+ (do ((entry (%code-entry-points component)
+ (%function-next entry)))
+ ((null entry) nil)
+ (when (= start-pc
+ (sb!c::compiled-debug-function-start-pc
+ (compiled-debug-function-compiler-debug-fun
+ (function-debug-function entry))))
+ (return entry)))))
+ (interpreted-debug-function
+ (sb!c::lambda-eval-info-function
+ (sb!c::leaf-info
+ (interpreted-debug-function-ir1-lambda debug-function))))
+ (bogus-debug-function nil)))
+ cached-value)))
+
+(defun debug-function-name (debug-function)
+ #!+sb-doc
+ "Returns the name of the function represented by debug-function. This may
+ be a string or a cons; do not assume it is a symbol."
+ (etypecase debug-function
+ (compiled-debug-function
+ (sb!c::compiled-debug-function-name
+ (compiled-debug-function-compiler-debug-fun debug-function)))
+ (interpreted-debug-function
+ (sb!c::lambda-name (interpreted-debug-function-ir1-lambda
+ debug-function)))
+ (bogus-debug-function
+ (bogus-debug-function-%name debug-function))))
+
+(defun function-debug-function (fun)
+ #!+sb-doc
+ "Returns a debug-function that represents debug information for function."
+ (case (get-type fun)
+ (#.sb!vm:closure-header-type
+ (function-debug-function (%closure-function fun)))
+ (#.sb!vm:funcallable-instance-header-type
+ (cond ((sb!eval:interpreted-function-p fun)
+ (make-interpreted-debug-function
+ (or (sb!eval::interpreted-function-definition fun)
+ (sb!eval::convert-interpreted-fun fun))))
+ (t
+ (function-debug-function (funcallable-instance-function fun)))))
+ ((#.sb!vm:function-header-type #.sb!vm:closure-function-header-type)
+ (let* ((name (%function-name fun))
+ (component (function-code-header fun))
+ (res (find-if
+ #'(lambda (x)
+ (and (sb!c::compiled-debug-function-p x)
+ (eq (sb!c::compiled-debug-function-name x) name)
+ (eq (sb!c::compiled-debug-function-kind x) nil)))
+ (get-debug-info-function-map
+ (%code-debug-info component)))))
+ (if res
+ (make-compiled-debug-function res component)
+ ;; KLUDGE: comment from CMU CL:
+ ;; This used to be the non-interpreted branch, but
+ ;; William wrote it to return the debug-fun of fun's XEP
+ ;; instead of fun's debug-fun. The above code does this
+ ;; more correctly, but it doesn't get or eliminate all
+ ;; appropriate cases. It mostly works, and probably
+ ;; works for all named functions anyway.
+ ;; -- WHN 20000120
+ (debug-function-from-pc component
+ (* (- (function-word-offset fun)
+ (get-header-data component))
+ sb!vm:word-bytes)))))))
+
+(defun debug-function-kind (debug-function)
+ #!+sb-doc
+ "Returns the kind of the function which is one of :OPTIONAL, :EXTERNAL,
+ :TOP-level, :CLEANUP, or NIL."
+ ;; FIXME: This "is one of" information should become part of the function
+ ;; declamation, not just a doc string
+ (etypecase debug-function
+ (compiled-debug-function
+ (sb!c::compiled-debug-function-kind
+ (compiled-debug-function-compiler-debug-fun debug-function)))
+ (interpreted-debug-function
+ (sb!c::lambda-kind (interpreted-debug-function-ir1-lambda
+ debug-function)))
+ (bogus-debug-function
+ nil)))
+
+(defun debug-var-info-available (debug-function)
+ #!+sb-doc
+ "Is there any variable information for DEBUG-FUNCTION?"
+ (not (not (debug-function-debug-vars debug-function))))
+
+(defun debug-function-symbol-variables (debug-function symbol)
+ #!+sb-doc
+ "Returns a list of debug-vars in debug-function having the same name
+ and package as symbol. If symbol is uninterned, then this returns a list of
+ debug-vars without package names and with the same name as symbol. The
+ result of this function is limited to the availability of variable
+ information in debug-function; for example, possibly debug-function only
+ knows about its arguments."
+ (let ((vars (ambiguous-debug-vars debug-function (symbol-name symbol)))
+ (package (and (symbol-package symbol)
+ (package-name (symbol-package symbol)))))
+ (delete-if (if (stringp package)
+ (lambda (var)
+ (let ((p (debug-var-package-name var)))
+ (or (not (stringp p))
+ (string/= p package))))
+ (lambda (var)
+ (stringp (debug-var-package-name var))))
+ vars)))
+
+(defun ambiguous-debug-vars (debug-function name-prefix-string)
+ "Returns a list of debug-vars in debug-function whose names contain
+ name-prefix-string as an intial substring. The result of this function is
+ limited to the availability of variable information in debug-function; for
+ example, possibly debug-function only knows about its arguments."
+ (declare (simple-string name-prefix-string))
+ (let ((variables (debug-function-debug-vars debug-function)))
+ (declare (type (or null simple-vector) variables))
+ (if variables
+ (let* ((len (length variables))
+ (prefix-len (length name-prefix-string))
+ (pos (find-variable name-prefix-string variables len))
+ (res nil))
+ (when pos
+ ;; Find names from pos to variable's len that contain prefix.
+ (do ((i pos (1+ i)))
+ ((= i len))
+ (let* ((var (svref variables i))
+ (name (debug-var-symbol-name var))
+ (name-len (length name)))
+ (declare (simple-string name))
+ (when (/= (or (string/= name-prefix-string name
+ :end1 prefix-len :end2 name-len)
+ prefix-len)
+ prefix-len)
+ (return))
+ (push var res)))
+ (setq res (nreverse res)))
+ res))))
+
+;;; This returns a position in variables for one containing name as an
+;;; initial substring. End is the length of variables if supplied.
+(defun find-variable (name variables &optional end)
+ (declare (simple-vector variables)
+ (simple-string name))
+ (let ((name-len (length name)))
+ (position name variables
+ :test #'(lambda (x y)
+ (let* ((y (debug-var-symbol-name y))
+ (y-len (length y)))
+ (declare (simple-string y))
+ (and (>= y-len name-len)
+ (string= x y :end1 name-len :end2 name-len))))
+ :end (or end (length variables)))))
+
+(defun debug-function-lambda-list (debug-function)
+ #!+sb-doc
+ "Returns a list representing the lambda-list for debug-function. The list
+ has the following structure:
+ (required-var1 required-var2
+ ...
+ (:optional var3 suppliedp-var4)
+ (:optional var5)
+ ...
+ (:rest var6) (:rest var7)
+ ...
+ (:keyword keyword-symbol var8 suppliedp-var9)
+ (:keyword keyword-symbol var10)
+ ...
+ )
+ Each VARi is a DEBUG-VAR; however it may be the symbol :deleted it
+ is unreferenced in debug-function. This signals a lambda-list-unavailable
+ condition when there is no argument list information."
+ (etypecase debug-function
+ (compiled-debug-function
+ (compiled-debug-function-lambda-list debug-function))
+ (interpreted-debug-function
+ (interpreted-debug-function-lambda-list debug-function))
+ (bogus-debug-function
+ nil)))
+
+;;; The hard part is when the lambda-list is unparsed. If it is
+;;; unparsed, and all the arguments are required, this is still pretty
+;;; easy; just whip the appropriate DEBUG-VARs into a list. Otherwise,
+;;; we have to pick out the funny arguments including any suppliedp
+;;; variables. In this situation, the ir1-lambda is an external entry
+;;; point that takes arguments users really pass in. It looks at those
+;;; and computes defaults and suppliedp variables, ultimately passing
+;;; everything defined as a a parameter to the real function as final
+;;; arguments. If this has to compute the lambda list, it caches it in
+;;; debug-function.
+(defun interpreted-debug-function-lambda-list (debug-function)
+ (let ((lambda-list (debug-function-%lambda-list debug-function))
+ (debug-vars (debug-function-debug-vars debug-function))
+ (ir1-lambda (interpreted-debug-function-ir1-lambda debug-function))
+ (res nil))
+ (if (eq lambda-list :unparsed)
+ (flet ((frob (v debug-vars)
+ (if (sb!c::lambda-var-refs v)
+ (find v debug-vars
+ :key #'interpreted-debug-var-ir1-var)
+ :deleted)))
+ (let ((xep-args (sb!c::lambda-optional-dispatch ir1-lambda)))
+ (if (and xep-args
+ (eq (sb!c::optional-dispatch-main-entry xep-args)
+ ir1-lambda))
+ ;; There are rest, optional, keyword, and suppliedp vars.
+ (let ((final-args (sb!c::lambda-vars ir1-lambda)))
+ (dolist (xep-arg (sb!c::optional-dispatch-arglist xep-args))
+ (let ((info (sb!c::lambda-var-arg-info xep-arg))
+ (final-arg (pop final-args)))
+ (cond (info
+ (case (sb!c::arg-info-kind info)
+ (:required
+ (push (frob final-arg debug-vars) res))
+ (:keyword
+ (push (list :keyword
+ (sb!c::arg-info-keyword info)
+ (frob final-arg debug-vars))
+ res))
+ (:rest
+ (push (list :rest (frob final-arg debug-vars))
+ res))
+ (:optional
+ (push (list :optional
+ (frob final-arg debug-vars))
+ res)))
+ (when (sb!c::arg-info-supplied-p info)
+ (nconc
+ (car res)
+ (list (frob (pop final-args) debug-vars)))))
+ (t
+ (push (frob final-arg debug-vars) res)))))
+ (setf (debug-function-%lambda-list debug-function)
+ (nreverse res)))
+ ;; All required args, so return them in a list.
+ (dolist (v (sb!c::lambda-vars ir1-lambda)
+ (setf (debug-function-%lambda-list debug-function)
+ (nreverse res)))
+ (push (frob v debug-vars) res)))))
+ ;; Everything's unparsed and cached, so return it.
+ lambda-list)))
+
+;;; If this has to compute the lambda list, it caches it in debug-function.
+(defun compiled-debug-function-lambda-list (debug-function)
+ (let ((lambda-list (debug-function-%lambda-list debug-function)))
+ (cond ((eq lambda-list :unparsed)
+ (multiple-value-bind (args argsp)
+ (parse-compiled-debug-function-lambda-list debug-function)
+ (setf (debug-function-%lambda-list debug-function) args)
+ (if argsp
+ args
+ (debug-signal 'lambda-list-unavailable
+ :debug-function debug-function))))
+ (lambda-list)
+ ((bogus-debug-function-p debug-function)
+ nil)
+ ((sb!c::compiled-debug-function-arguments
+ (compiled-debug-function-compiler-debug-fun
+ debug-function))
+ ;; If the packed information is there (whether empty or not) as
+ ;; opposed to being nil, then returned our cached value (nil).
+ nil)
+ (t
+ ;; Our cached value is nil, and the packed lambda-list information
+ ;; is nil, so we don't have anything available.
+ (debug-signal 'lambda-list-unavailable
+ :debug-function debug-function)))))
+
+;;; COMPILED-DEBUG-FUNCTION-LAMBDA-LIST calls this when a
+;;; compiled-debug-function has no lambda-list information cached. It
+;;; returns the lambda-list as the first value and whether there was
+;;; any argument information as the second value. Therefore, nil and t
+;;; means there were no arguments, but nil and nil means there was no
+;;; argument information.
+(defun parse-compiled-debug-function-lambda-list (debug-function)
+ (let ((args (sb!c::compiled-debug-function-arguments
+ (compiled-debug-function-compiler-debug-fun
+ debug-function))))
+ (cond
+ ((not args)
+ (values nil nil))
+ ((eq args :minimal)
+ (values (coerce (debug-function-debug-vars debug-function) 'list)
+ t))
+ (t
+ (let ((vars (debug-function-debug-vars debug-function))
+ (i 0)
+ (len (length args))
+ (res nil)
+ (optionalp nil))
+ (declare (type (or null simple-vector) vars))
+ (loop
+ (when (>= i len) (return))
+ (let ((ele (aref args i)))
+ (cond
+ ((symbolp ele)
+ (case ele
+ (sb!c::deleted
+ ;; Deleted required arg at beginning of args array.
+ (push :deleted res))
+ (sb!c::optional-args
+ (setf optionalp t))
+ (sb!c::supplied-p
+ ;; SUPPLIED-P var immediately following keyword or
+ ;; optional. Stick the extra var in the result
+ ;; element representing the keyword or optional,
+ ;; which is the previous one.
+ (nconc (car res)
+ (list (compiled-debug-function-lambda-list-var
+ args (incf i) vars))))
+ (sb!c::rest-arg
+ (push (list :rest
+ (compiled-debug-function-lambda-list-var
+ args (incf i) vars))
+ res))
+ (sb!c::more-arg
+ ;; Just ignore the fact that the next two args are
+ ;; the more arg context and count, and act like they
+ ;; are regular arguments.
+ nil)
+ (t
+ ;; keyword arg
+ (push (list :keyword
+ ele
+ (compiled-debug-function-lambda-list-var
+ args (incf i) vars))
+ res))))
+ (optionalp
+ ;; We saw an optional marker, so the following
+ ;; non-symbols are indexes indicating optional
+ ;; variables.
+ (push (list :optional (svref vars ele)) res))
+ (t
+ ;; Required arg at beginning of args array.
+ (push (svref vars ele) res))))
+ (incf i))
+ (values (nreverse res) t))))))
+
+;;; This is used in COMPILED-DEBUG-FUNCTION-LAMBDA-LIST.
+(defun compiled-debug-function-lambda-list-var (args i vars)
+ (declare (type (simple-array * (*)) args)
+ (simple-vector vars))
+ (let ((ele (aref args i)))
+ (cond ((not (symbolp ele)) (svref vars ele))
+ ((eq ele 'sb!c::deleted) :deleted)
+ (t (error "malformed arguments description")))))
+
+(defun compiled-debug-function-debug-info (debug-fun)
+ (%code-debug-info (compiled-debug-function-component debug-fun)))
+\f
+;;;; unpacking variable and basic block data
+
+(defvar *parsing-buffer*
+ (make-array 20 :adjustable t :fill-pointer t))
+(defvar *other-parsing-buffer*
+ (make-array 20 :adjustable t :fill-pointer t))
+;;; PARSE-DEBUG-BLOCKS, PARSE-DEBUG-VARS and UNCOMPACT-FUNCTION-MAP
+;;; use this to unpack binary encoded information. It returns the
+;;; values returned by the last form in body.
+;;;
+;;; This binds buffer-var to *parsing-buffer*, makes sure it starts at
+;;; element zero, and makes sure if we unwind, we nil out any set
+;;; elements for GC purposes.
+;;;
+;;; This also binds other-var to *other-parsing-buffer* when it is
+;;; supplied, making sure it starts at element zero and that we nil
+;;; out any elements if we unwind.
+;;;
+;;; This defines the local macro RESULT that takes a buffer, copies
+;;; its elements to a resulting simple-vector, nil's out elements, and
+;;; restarts the buffer at element zero. RESULT returns the
+;;; simple-vector.
+(eval-when (:compile-toplevel :execute)
+(sb!xc:defmacro with-parsing-buffer ((buffer-var &optional other-var)
+ &body body)
+ (let ((len (gensym))
+ (res (gensym)))
+ `(unwind-protect
+ (let ((,buffer-var *parsing-buffer*)
+ ,@(if other-var `((,other-var *other-parsing-buffer*))))
+ (setf (fill-pointer ,buffer-var) 0)
+ ,@(if other-var `((setf (fill-pointer ,other-var) 0)))
+ (macrolet ((result (buf)
+ `(let* ((,',len (length ,buf))
+ (,',res (make-array ,',len)))
+ (replace ,',res ,buf :end1 ,',len :end2 ,',len)
+ (fill ,buf nil :end ,',len)
+ (setf (fill-pointer ,buf) 0)
+ ,',res)))
+ ,@body))
+ (fill *parsing-buffer* nil)
+ ,@(if other-var `((fill *other-parsing-buffer* nil))))))
+) ; EVAL-WHEN
+
+;;; The argument is a debug internals structure. This returns the
+;;; debug-blocks for debug-function, regardless of whether we have
+;;; unpacked them yet. It signals a no-debug-blocks condition if it
+;;; can't return the blocks.
+(defun debug-function-debug-blocks (debug-function)
+ (let ((blocks (debug-function-blocks debug-function)))
+ (cond ((eq blocks :unparsed)
+ (setf (debug-function-blocks debug-function)
+ (parse-debug-blocks debug-function))
+ (unless (debug-function-blocks debug-function)
+ (debug-signal 'no-debug-blocks
+ :debug-function debug-function))
+ (debug-function-blocks debug-function))
+ (blocks)
+ (t
+ (debug-signal 'no-debug-blocks
+ :debug-function debug-function)))))
+
+;;; This returns a simple-vector of debug-blocks or nil. NIL indicates
+;;; there was no basic block information.
+(defun parse-debug-blocks (debug-function)
+ (etypecase debug-function
+ (compiled-debug-function
+ (parse-compiled-debug-blocks debug-function))
+ (bogus-debug-function
+ (debug-signal 'no-debug-blocks :debug-function debug-function))
+ (interpreted-debug-function
+ (parse-interpreted-debug-blocks debug-function))))
+
+;;; This does some of the work of PARSE-DEBUG-BLOCKS.
+(defun parse-compiled-debug-blocks (debug-function)
+ (let* ((debug-fun (compiled-debug-function-compiler-debug-fun
+ debug-function))
+ (var-count (length (debug-function-debug-vars debug-function)))
+ (blocks (sb!c::compiled-debug-function-blocks debug-fun))
+ ;; KLUDGE: 8 is a hard-wired constant in the compiler for the
+ ;; element size of the packed binary representation of the
+ ;; blocks data.
+ (live-set-len (ceiling var-count 8))
+ (tlf-number (sb!c::compiled-debug-function-tlf-number debug-fun)))
+ (unless blocks (return-from parse-compiled-debug-blocks nil))
+ (macrolet ((aref+ (a i) `(prog1 (aref ,a ,i) (incf ,i))))
+ (with-parsing-buffer (blocks-buffer locations-buffer)
+ (let ((i 0)
+ (len (length blocks))
+ (last-pc 0))
+ (loop
+ (when (>= i len) (return))
+ (let ((succ-and-flags (aref+ blocks i))
+ (successors nil))
+ (declare (type (unsigned-byte 8) succ-and-flags)
+ (list successors))
+ (dotimes (k (ldb sb!c::compiled-debug-block-nsucc-byte
+ succ-and-flags))
+ (push (sb!c::read-var-integer blocks i) successors))
+ (let* ((locations
+ (dotimes (k (sb!c::read-var-integer blocks i)
+ (result locations-buffer))
+ (let ((kind (svref sb!c::compiled-code-location-kinds
+ (aref+ blocks i)))
+ (pc (+ last-pc
+ (sb!c::read-var-integer blocks i)))
+ (tlf-offset (or tlf-number
+ (sb!c::read-var-integer blocks
+ i)))
+ (form-number (sb!c::read-var-integer blocks i))
+ (live-set (sb!c::read-packed-bit-vector
+ live-set-len blocks i)))
+ (vector-push-extend (make-known-code-location
+ pc debug-function tlf-offset
+ form-number live-set kind)
+ locations-buffer)
+ (setf last-pc pc))))
+ (block (make-compiled-debug-block
+ locations successors
+ (not (zerop (logand
+ sb!c::compiled-debug-block-elsewhere-p
+ succ-and-flags))))))
+ (vector-push-extend block blocks-buffer)
+ (dotimes (k (length locations))
+ (setf (code-location-%debug-block (svref locations k))
+ block))))))
+ (let ((res (result blocks-buffer)))
+ (declare (simple-vector res))
+ (dotimes (i (length res))
+ (let* ((block (svref res i))
+ (succs nil))
+ (dolist (ele (debug-block-successors block))
+ (push (svref res ele) succs))
+ (setf (debug-block-successors block) succs)))
+ res)))))
+
+;;; This does some of the work of PARSE-DEBUG-BLOCKS.
+(defun parse-interpreted-debug-blocks (debug-function)
+ (let ((ir1-lambda (interpreted-debug-function-ir1-lambda debug-function)))
+ (with-parsing-buffer (buffer)
+ (sb!c::do-blocks (block (sb!c::block-component
+ (sb!c::node-block (sb!c::lambda-bind
+ ir1-lambda))))
+ (when (eq ir1-lambda (sb!c::block-home-lambda block))
+ (vector-push-extend (make-interpreted-debug-block block) buffer)))
+ (result buffer))))
+
+;;; The argument is a debug internals structure. This returns nil if
+;;; there is no variable information. It returns an empty
+;;; simple-vector if there were no locals in the function. Otherwise
+;;; it returns a simple-vector of DEBUG-VARs.
+(defun debug-function-debug-vars (debug-function)
+ (let ((vars (debug-function-%debug-vars debug-function)))
+ (if (eq vars :unparsed)
+ (setf (debug-function-%debug-vars debug-function)
+ (etypecase debug-function
+ (compiled-debug-function
+ (parse-compiled-debug-vars debug-function))
+ (bogus-debug-function nil)
+ (interpreted-debug-function
+ (parse-interpreted-debug-vars debug-function))))
+ vars)))
+
+;;; This grabs all the variables from DEBUG-FUN's ir1-lambda, from the
+;;; IR1 lambda vars, and all of its LET's. Each LET is an IR1 lambda.
+;;; For each variable, we make an INTERPRETED-DEBUG-VAR. We then SORT
+;;; all the variables by name. Then we go through, and for any
+;;; duplicated names we distinguish the INTERPRETED-DEBUG-VARs by
+;;; setting their id slots to a distinct number.
+(defun parse-interpreted-debug-vars (debug-fun)
+ (let* ((ir1-lambda (interpreted-debug-function-ir1-lambda debug-fun))
+ (vars (flet ((frob (ir1-lambda buf)
+ (dolist (v (sb!c::lambda-vars ir1-lambda))
+ (vector-push-extend
+ (let* ((id (sb!c::leaf-name v)))
+ (make-interpreted-debug-var id v))
+ buf))))
+ (with-parsing-buffer (buf)
+ (frob ir1-lambda buf)
+ (dolist (let-lambda (sb!c::lambda-lets ir1-lambda))
+ (frob let-lambda buf))
+ (result buf)))))
+ (declare (simple-vector vars))
+ (sort vars #'string< :key #'debug-var-symbol-name)
+ (let ((len (length vars)))
+ (when (> len 1)
+ (let ((i 0)
+ (j 1))
+ (block PUNT
+ (loop
+ (let* ((var-i (svref vars i))
+ (var-j (svref vars j))
+ (name (debug-var-symbol-name var-i)))
+ (when (string= name (debug-var-symbol-name var-j))
+ (let ((count 1))
+ (loop
+ (setf (debug-var-id var-j) count)
+ (when (= (incf j) len) (return-from PUNT))
+ (setf var-j (svref vars j))
+ (when (string/= name (debug-var-symbol-name var-j))
+ (return))
+ (incf count))))
+ (setf i j)
+ (incf j)
+ (when (= j len) (return))))))))
+ vars))
+
+;;; Vars is the parsed variables for a minimal debug function. We need to
+;;; assign names of the form ARG-NNN. We must pad with leading zeros, since
+;;; the arguments must be in alphabetical order.
+(defun assign-minimal-var-names (vars)
+ (declare (simple-vector vars))
+ (let* ((len (length vars))
+ (width (length (format nil "~D" (1- len)))))
+ (dotimes (i len)
+ (setf (compiled-debug-var-symbol (svref vars i))
+ (intern (format nil "ARG-~V,'0D" width i)
+ ;; KLUDGE: It's somewhat nasty to have a bare
+ ;; package name string here. It would probably be
+ ;; better to have #.(FIND-PACKAGE "SB!DEBUG")
+ ;; instead, since then at least it would transform
+ ;; correctly under package renaming and stuff.
+ ;; However, genesis can't handle dumped packages..
+ ;; -- WHN 20000129
+ ;;
+ ;; FIXME: Maybe this could be fixed by moving the
+ ;; whole debug-int.lisp file to warm init? (after
+ ;; which dumping a #.(FIND-PACKAGE ..) expression
+ ;; would work fine) If this is possible, it would
+ ;; probably be a good thing, since minimizing the
+ ;; amount of stuff in cold init is basically good.
+ "SB-DEBUG")))))
+
+;;; Parse the packed representation of DEBUG-VARs from
+;;; DEBUG-FUNCTION's SB!C::COMPILED-DEBUG-FUNCTION, returning a vector
+;;; of DEBUG-VARs, or NIL if there was no information to parse.
+(defun parse-compiled-debug-vars (debug-function)
+ (let* ((cdebug-fun (compiled-debug-function-compiler-debug-fun debug-function))
+ (packed-vars (sb!c::compiled-debug-function-variables cdebug-fun))
+ (args-minimal (eq (sb!c::compiled-debug-function-arguments cdebug-fun)
+ :minimal)))
+ (when packed-vars
+ (do ((i 0)
+ (buffer (make-array 0 :fill-pointer 0 :adjustable t)))
+ ((>= i (length packed-vars))
+ (let ((result (coerce buffer 'simple-vector)))
+ (when args-minimal
+ (assign-minimal-var-names result))
+ result))
+ (flet ((geti () (prog1 (aref packed-vars i) (incf i))))
+ (let* ((flags (geti))
+ (minimal (logtest sb!c::compiled-debug-var-minimal-p flags))
+ (deleted (logtest sb!c::compiled-debug-var-deleted-p flags))
+ (live (logtest sb!c::compiled-debug-var-environment-live flags))
+ (save (logtest sb!c::compiled-debug-var-save-loc-p flags))
+ (symbol (if minimal nil (geti)))
+ (id (if (logtest sb!c::compiled-debug-var-id-p flags)
+ (geti)
+ 0))
+ (sc-offset (if deleted 0 (geti)))
+ (save-sc-offset (if save (geti) nil)))
+ (assert (not (and args-minimal (not minimal))))
+ (vector-push-extend (make-compiled-debug-var symbol
+ id
+ live
+ sc-offset
+ save-sc-offset)
+ buffer)))))))
+\f
+;;;; unpacking minimal debug functions
+
+(eval-when (:compile-toplevel :execute)
+
+;;; sleazoid "macro" to keep our indentation sane in UNCOMPACT-FUNCTION-MAP
+(sb!xc:defmacro make-uncompacted-debug-fun ()
+ '(sb!c::make-compiled-debug-function
+ :name
+ (let ((base (ecase (ldb sb!c::minimal-debug-function-name-style-byte
+ options)
+ (#.sb!c::minimal-debug-function-name-symbol
+ (intern (sb!c::read-var-string map i)
+ (sb!c::compiled-debug-info-package info)))
+ (#.sb!c::minimal-debug-function-name-packaged
+ (let ((pkg (sb!c::read-var-string map i)))
+ (intern (sb!c::read-var-string map i) pkg)))
+ (#.sb!c::minimal-debug-function-name-uninterned
+ (make-symbol (sb!c::read-var-string map i)))
+ (#.sb!c::minimal-debug-function-name-component
+ (sb!c::compiled-debug-info-name info)))))
+ (if (logtest flags sb!c::minimal-debug-function-setf-bit)
+ `(setf ,base)
+ base))
+ :kind (svref sb!c::minimal-debug-function-kinds
+ (ldb sb!c::minimal-debug-function-kind-byte options))
+ :variables
+ (when vars-p
+ (let ((len (sb!c::read-var-integer map i)))
+ (prog1 (subseq map i (+ i len))
+ (incf i len))))
+ :arguments (when vars-p :minimal)
+ :returns
+ (ecase (ldb sb!c::minimal-debug-function-returns-byte options)
+ (#.sb!c::minimal-debug-function-returns-standard
+ :standard)
+ (#.sb!c::minimal-debug-function-returns-fixed
+ :fixed)
+ (#.sb!c::minimal-debug-function-returns-specified
+ (with-parsing-buffer (buf)
+ (dotimes (idx (sb!c::read-var-integer map i))
+ (vector-push-extend (sb!c::read-var-integer map i) buf))
+ (result buf))))
+ :return-pc (sb!c::read-var-integer map i)
+ :old-fp (sb!c::read-var-integer map i)
+ :nfp (when (logtest flags sb!c::minimal-debug-function-nfp-bit)
+ (sb!c::read-var-integer map i))
+ :start-pc
+ (progn
+ (setq code-start-pc (+ code-start-pc (sb!c::read-var-integer map i)))
+ (+ code-start-pc (sb!c::read-var-integer map i)))
+ :elsewhere-pc
+ (setq elsewhere-pc (+ elsewhere-pc (sb!c::read-var-integer map i)))))
+
+) ; EVAL-WHEN
+
+;;; Return a normal function map derived from a minimal debug info
+;;; function map. This involves looping parsing
+;;; minimal-debug-functions and then building a vector out of them.
+;;;
+;;; FIXME: This and its helper macro just above become dead code now
+;;; that we no longer use compacted function maps.
+(defun uncompact-function-map (info)
+ (declare (type sb!c::compiled-debug-info info))
+
+ ;; (This is stubified until we solve the problem of representing
+ ;; debug information in a way which plays nicely with package renaming.)
+ (error "FIXME: dead code UNCOMPACT-FUNCTION-MAP (was stub)")
+
+ (let* ((map (sb!c::compiled-debug-info-function-map info))
+ (i 0)
+ (len (length map))
+ (code-start-pc 0)
+ (elsewhere-pc 0))
+ (declare (type (simple-array (unsigned-byte 8) (*)) map))
+ (sb!int:collect ((res))
+ (loop
+ (when (= i len) (return))
+ (let* ((options (prog1 (aref map i) (incf i)))
+ (flags (prog1 (aref map i) (incf i)))
+ (vars-p (logtest flags
+ sb!c::minimal-debug-function-variables-bit))
+ (dfun (make-uncompacted-debug-fun)))
+ (res code-start-pc)
+ (res dfun)))
+
+ (coerce (cdr (res)) 'simple-vector))))
+
+;;; This variable maps minimal debug-info function maps to an unpacked
+;;; version thereof.
+(defvar *uncompacted-function-maps* (make-hash-table :test 'eq))
+
+;;; Return a function-map for a given compiled-debug-info object. If
+;;; the info is minimal, and has not been parsed, then parse it.
+;;;
+;;; FIXME: Now that we no longer use the minimal-debug-function
+;;; representation, calls to this function can be replaced by calls to
+;;; the bare COMPILED-DEBUG-INFO-FUNCTION-MAP slot accessor function,
+;;; and this function and everything it calls become dead code which
+;;; can be deleted.
+(defun get-debug-info-function-map (info)
+ (declare (type sb!c::compiled-debug-info info))
+ (let ((map (sb!c::compiled-debug-info-function-map info)))
+ (if (simple-vector-p map)
+ map
+ (or (gethash map *uncompacted-function-maps*)
+ (setf (gethash map *uncompacted-function-maps*)
+ (uncompact-function-map info))))))
+\f
+;;;; CODE-LOCATIONs
+
+;;; If we're sure of whether code-location is known, return t or nil.
+;;; If we're :unsure, then try to fill in the code-location's slots.
+;;; This determines whether there is any debug-block information, and
+;;; if code-location is known.
+;;;
+;;; ??? IF this conses closures every time it's called, then break off the
+;;; :unsure part to get the HANDLER-CASE into another function.
+(defun code-location-unknown-p (basic-code-location)
+ #!+sb-doc
+ "Returns whether basic-code-location is unknown. It returns nil when the
+ code-location is known."
+ (ecase (code-location-%unknown-p basic-code-location)
+ ((t) t)
+ ((nil) nil)
+ (:unsure
+ (setf (code-location-%unknown-p basic-code-location)
+ (handler-case (not (fill-in-code-location basic-code-location))
+ (no-debug-blocks () t))))))
+
+(defun code-location-debug-block (basic-code-location)
+ #!+sb-doc
+ "Returns the debug-block containing code-location if it is available. Some
+ debug policies inhibit debug-block information, and if none is available,
+ then this signals a no-debug-blocks condition."
+ (let ((block (code-location-%debug-block basic-code-location)))
+ (if (eq block :unparsed)
+ (etypecase basic-code-location
+ (compiled-code-location
+ (compute-compiled-code-location-debug-block basic-code-location))
+ (interpreted-code-location
+ (setf (code-location-%debug-block basic-code-location)
+ (make-interpreted-debug-block
+ (sb!c::node-block
+ (interpreted-code-location-ir1-node basic-code-location))))))
+ block)))
+
+;;; This stores and returns BASIC-CODE-LOCATION's debug-block. It
+;;; determines the correct one using the code-location's pc. This uses
+;;; DEBUG-FUNCTION-DEBUG-BLOCKS to return the cached block information
+;;; or signal a 'no-debug-blocks condition. The blocks are sorted by
+;;; their first code-location's pc, in ascending order. Therefore, as
+;;; soon as we find a block that starts with a pc greater than
+;;; basic-code-location's pc, we know the previous block contains the
+;;; pc. If we get to the last block, then the code-location is either
+;;; in the second to last block or the last block, and we have to be
+;;; careful in determining this since the last block could be code at
+;;; the end of the function. We have to check for the last block being
+;;; code first in order to see how to compare the code-location's pc.
+(defun compute-compiled-code-location-debug-block (basic-code-location)
+ (let* ((pc (compiled-code-location-pc basic-code-location))
+ (debug-function (code-location-debug-function
+ basic-code-location))
+ (blocks (debug-function-debug-blocks debug-function))
+ (len (length blocks)))
+ (declare (simple-vector blocks))
+ (setf (code-location-%debug-block basic-code-location)
+ (if (= len 1)
+ (svref blocks 0)
+ (do ((i 1 (1+ i))
+ (end (1- len)))
+ ((= i end)
+ (let ((last (svref blocks end)))
+ (cond
+ ((debug-block-elsewhere-p last)
+ (if (< pc
+ (sb!c::compiled-debug-function-elsewhere-pc
+ (compiled-debug-function-compiler-debug-fun
+ debug-function)))
+ (svref blocks (1- end))
+ last))
+ ((< pc
+ (compiled-code-location-pc
+ (svref (compiled-debug-block-code-locations last)
+ 0)))
+ (svref blocks (1- end)))
+ (t last))))
+ (declare (type sb!c::index i end))
+ (when (< pc
+ (compiled-code-location-pc
+ (svref (compiled-debug-block-code-locations
+ (svref blocks i))
+ 0)))
+ (return (svref blocks (1- i)))))))))
+
+(defun code-location-debug-source (code-location)
+ #!+sb-doc
+ "Returns the code-location's debug-source."
+ (etypecase code-location
+ (compiled-code-location
+ (let* ((info (compiled-debug-function-debug-info
+ (code-location-debug-function code-location)))
+ (sources (sb!c::compiled-debug-info-source info))
+ (len (length sources)))
+ (declare (list sources))
+ (when (zerop len)
+ (debug-signal 'no-debug-blocks :debug-function
+ (code-location-debug-function code-location)))
+ (if (= len 1)
+ (car sources)
+ (do ((prev sources src)
+ (src (cdr sources) (cdr src))
+ (offset (code-location-top-level-form-offset code-location)))
+ ((null src) (car prev))
+ (when (< offset (sb!c::debug-source-source-root (car src)))
+ (return (car prev)))))))
+ (interpreted-code-location
+ (first
+ (let ((sb!c::*lexenv* (make-null-lexenv)))
+ (sb!c::debug-source-for-info
+ (sb!c::component-source-info
+ (sb!c::block-component
+ (sb!c::node-block
+ (interpreted-code-location-ir1-node code-location))))))))))
+
+(defun code-location-top-level-form-offset (code-location)
+ #!+sb-doc
+ "Returns the number of top-level forms before the one containing
+ code-location as seen by the compiler in some compilation unit. A
+ compilation unit is not necessarily a single file, see the section on
+ debug-sources."
+ (when (code-location-unknown-p code-location)
+ (error 'unknown-code-location :code-location code-location))
+ (let ((tlf-offset (code-location-%tlf-offset code-location)))
+ (cond ((eq tlf-offset :unparsed)
+ (etypecase code-location
+ (compiled-code-location
+ (unless (fill-in-code-location code-location)
+ ;; This check should be unnecessary. We're missing
+ ;; debug info the compiler should have dumped.
+ (error "internal error: unknown code location"))
+ (code-location-%tlf-offset code-location))
+ (interpreted-code-location
+ (setf (code-location-%tlf-offset code-location)
+ (sb!c::source-path-tlf-number
+ (sb!c::node-source-path
+ (interpreted-code-location-ir1-node code-location)))))))
+ (t tlf-offset))))
+
+(defun code-location-form-number (code-location)
+ #!+sb-doc
+ "Returns the number of the form corresponding to code-location. The form
+ number is derived by a walking the subforms of a top-level form in
+ depth-first order."
+ (when (code-location-unknown-p code-location)
+ (error 'unknown-code-location :code-location code-location))
+ (let ((form-num (code-location-%form-number code-location)))
+ (cond ((eq form-num :unparsed)
+ (etypecase code-location
+ (compiled-code-location
+ (unless (fill-in-code-location code-location)
+ ;; This check should be unnecessary. We're missing
+ ;; debug info the compiler should have dumped.
+ (error "internal error: unknown code location"))
+ (code-location-%form-number code-location))
+ (interpreted-code-location
+ (setf (code-location-%form-number code-location)
+ (sb!c::source-path-form-number
+ (sb!c::node-source-path
+ (interpreted-code-location-ir1-node code-location)))))))
+ (t form-num))))
+
+(defun code-location-kind (code-location)
+ #!+sb-doc
+ "Return the kind of CODE-LOCATION, one of:
+ :interpreted, :unknown-return, :known-return, :internal-error,
+ :non-local-exit, :block-start, :call-site, :single-value-return,
+ :non-local-entry"
+ (when (code-location-unknown-p code-location)
+ (error 'unknown-code-location :code-location code-location))
+ (etypecase code-location
+ (compiled-code-location
+ (let ((kind (compiled-code-location-kind code-location)))
+ (cond ((not (eq kind :unparsed)) kind)
+ ((not (fill-in-code-location code-location))
+ ;; This check should be unnecessary. We're missing
+ ;; debug info the compiler should have dumped.
+ (error "internal error: unknown code location"))
+ (t
+ (compiled-code-location-kind code-location)))))
+ (interpreted-code-location
+ :interpreted)))
+
+;;; This returns CODE-LOCATION's live-set if it is available. If
+;;; there is no debug-block information, this returns NIL.
+(defun compiled-code-location-live-set (code-location)
+ (if (code-location-unknown-p code-location)
+ nil
+ (let ((live-set (compiled-code-location-%live-set code-location)))
+ (cond ((eq live-set :unparsed)
+ (unless (fill-in-code-location code-location)
+ ;; This check should be unnecessary. We're missing debug info
+ ;; the compiler should have dumped.
+ ;;
+ ;; FIXME: This error and comment happen over and over again.
+ ;; Make them a shared function.
+ (error "internal error: unknown code location"))
+ (compiled-code-location-%live-set code-location))
+ (t live-set)))))
+
+(defun code-location= (obj1 obj2)
+ #!+sb-doc
+ "Returns whether obj1 and obj2 are the same place in the code."
+ (etypecase obj1
+ (compiled-code-location
+ (etypecase obj2
+ (compiled-code-location
+ (and (eq (code-location-debug-function obj1)
+ (code-location-debug-function obj2))
+ (sub-compiled-code-location= obj1 obj2)))
+ (interpreted-code-location
+ nil)))
+ (interpreted-code-location
+ (etypecase obj2
+ (compiled-code-location
+ nil)
+ (interpreted-code-location
+ (eq (interpreted-code-location-ir1-node obj1)
+ (interpreted-code-location-ir1-node obj2)))))))
+(defun sub-compiled-code-location= (obj1 obj2)
+ (= (compiled-code-location-pc obj1)
+ (compiled-code-location-pc obj2)))
+
+;;; This fills in CODE-LOCATION's :unparsed slots. It returns t or nil
+;;; depending on whether the code-location was known in its
+;;; debug-function's debug-block information. This may signal a
+;;; NO-DEBUG-BLOCKS condition due to DEBUG-FUNCTION-DEBUG-BLOCKS, and
+;;; it assumes the %UNKNOWN-P slot is already set or going to be set.
+(defun fill-in-code-location (code-location)
+ (declare (type compiled-code-location code-location))
+ (let* ((debug-function (code-location-debug-function code-location))
+ (blocks (debug-function-debug-blocks debug-function)))
+ (declare (simple-vector blocks))
+ (dotimes (i (length blocks) nil)
+ (let* ((block (svref blocks i))
+ (locations (compiled-debug-block-code-locations block)))
+ (declare (simple-vector locations))
+ (dotimes (j (length locations))
+ (let ((loc (svref locations j)))
+ (when (sub-compiled-code-location= code-location loc)
+ (setf (code-location-%debug-block code-location) block)
+ (setf (code-location-%tlf-offset code-location)
+ (code-location-%tlf-offset loc))
+ (setf (code-location-%form-number code-location)
+ (code-location-%form-number loc))
+ (setf (compiled-code-location-%live-set code-location)
+ (compiled-code-location-%live-set loc))
+ (setf (compiled-code-location-kind code-location)
+ (compiled-code-location-kind loc))
+ (return-from fill-in-code-location t))))))))
+\f
+;;;; operations on DEBUG-BLOCKs
+
+(defmacro do-debug-block-locations ((code-var debug-block &optional return)
+ &body body)
+ #!+sb-doc
+ "Executes forms in a context with code-var bound to each code-location in
+ debug-block. This returns the value of executing result (defaults to nil)."
+ (let ((code-locations (gensym))
+ (i (gensym)))
+ `(let ((,code-locations (debug-block-code-locations ,debug-block)))
+ (declare (simple-vector ,code-locations))
+ (dotimes (,i (length ,code-locations) ,return)
+ (let ((,code-var (svref ,code-locations ,i)))
+ ,@body)))))
+
+(defun debug-block-function-name (debug-block)
+ #!+sb-doc
+ "Returns the name of the function represented by debug-function. This may
+ be a string or a cons; do not assume it is a symbol."
+ (etypecase debug-block
+ (compiled-debug-block
+ (let ((code-locs (compiled-debug-block-code-locations debug-block)))
+ (declare (simple-vector code-locs))
+ (if (zerop (length code-locs))
+ "??? Can't get name of debug-block's function."
+ (debug-function-name
+ (code-location-debug-function (svref code-locs 0))))))
+ (interpreted-debug-block
+ (sb!c::lambda-name (sb!c::block-home-lambda
+ (interpreted-debug-block-ir1-block debug-block))))))
+
+(defun debug-block-code-locations (debug-block)
+ (etypecase debug-block
+ (compiled-debug-block
+ (compiled-debug-block-code-locations debug-block))
+ (interpreted-debug-block
+ (interpreted-debug-block-code-locations debug-block))))
+
+(defun interpreted-debug-block-code-locations (debug-block)
+ (let ((code-locs (interpreted-debug-block-locations debug-block)))
+ (if (eq code-locs :unparsed)
+ (with-parsing-buffer (buf)
+ (sb!c::do-nodes (node cont (interpreted-debug-block-ir1-block
+ debug-block))
+ (vector-push-extend (make-interpreted-code-location
+ node
+ (make-interpreted-debug-function
+ (sb!c::block-home-lambda (sb!c::node-block
+ node))))
+ buf))
+ (setf (interpreted-debug-block-locations debug-block)
+ (result buf)))
+ code-locs)))
+\f
+;;;; operations on debug variables
+
+(defun debug-var-symbol-name (debug-var)
+ (symbol-name (debug-var-symbol debug-var)))
+
+;;; FIXME: Make sure that this isn't called anywhere that it wouldn't
+;;; be acceptable to have NIL returned, or that it's only called on
+;;; DEBUG-VARs whose symbols have non-NIL packages.
+(defun debug-var-package-name (debug-var)
+ (package-name (symbol-package (debug-var-symbol debug-var))))
+
+(defun debug-var-valid-value (debug-var frame)
+ #!+sb-doc
+ "Returns the value stored for DEBUG-VAR in frame. If the value is not
+ :valid, then this signals an invalid-value error."
+ (unless (eq (debug-var-validity debug-var (frame-code-location frame))
+ :valid)
+ (error 'invalid-value :debug-var debug-var :frame frame))
+ (debug-var-value debug-var frame))
+
+(defun debug-var-value (debug-var frame)
+ #!+sb-doc
+ "Returns the value stored for DEBUG-VAR in frame. The value may be
+ invalid. This is SETF'able."
+ (etypecase debug-var
+ (compiled-debug-var
+ (check-type frame compiled-frame)
+ (let ((res (access-compiled-debug-var-slot debug-var frame)))
+ (if (indirect-value-cell-p res)
+ (sb!c:value-cell-ref res)
+ res)))
+ (interpreted-debug-var
+ (check-type frame interpreted-frame)
+ (sb!eval::leaf-value-lambda-var
+ (interpreted-code-location-ir1-node (frame-code-location frame))
+ (interpreted-debug-var-ir1-var debug-var)
+ (frame-pointer frame)
+ (interpreted-frame-closure frame)))))
+
+;;; This returns what is stored for the variable represented by
+;;; DEBUG-VAR relative to the FRAME. This may be an indirect value
+;;; cell if the variable is both closed over and set.
+(defun access-compiled-debug-var-slot (debug-var frame)
+ (let ((escaped (compiled-frame-escaped frame)))
+ (if escaped
+ (sub-access-debug-var-slot
+ (frame-pointer frame)
+ (compiled-debug-var-sc-offset debug-var)
+ escaped)
+ (sub-access-debug-var-slot
+ (frame-pointer frame)
+ (or (compiled-debug-var-save-sc-offset debug-var)
+ (compiled-debug-var-sc-offset debug-var))))))
+
+;;; CMU CL had
+;;; (DEFUN SUB-ACCESS-DEBUG-VAR-SLOT (FP SC-OFFSET &OPTIONAL ESCAPED) ..)
+;;; code for this case.
+#!-x86
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (error "hopelessly stale"))
+
+#!+x86
+(defun sub-access-debug-var-slot (fp sc-offset &optional escaped)
+ (declare (type system-area-pointer fp))
+ (macrolet ((with-escaped-value ((var) &body forms)
+ `(if escaped
+ (let ((,var (sb!vm:context-register
+ escaped (sb!c:sc-offset-offset sc-offset))))
+ ,@forms)
+ :invalid-value-for-unescaped-register-storage))
+ (escaped-float-value (format)
+ `(if escaped
+ (sb!vm:context-float-register
+ escaped (sb!c:sc-offset-offset sc-offset) ',format)
+ :invalid-value-for-unescaped-register-storage))
+ (escaped-complex-float-value (format)
+ `(if escaped
+ (complex
+ (sb!vm:context-float-register
+ escaped (sb!c:sc-offset-offset sc-offset) ',format)
+ (sb!vm:context-float-register
+ escaped (1+ (sb!c:sc-offset-offset sc-offset)) ',format))
+ :invalid-value-for-unescaped-register-storage))
+ ;; The debug variable locations are not always valid, and
+ ;; on the x86 locations can contain raw values. To
+ ;; prevent later problems from invalid objects, they are
+ ;; filtered here.
+ (make-valid-lisp-obj (val)
+ `(if (or
+ ;; fixnum
+ (zerop (logand ,val 3))
+ ;; character
+ (and (zerop (logand ,val #xffff0000)) ; Top bits zero
+ (= (logand ,val #xff) sb!vm:base-char-type)) ; Char tag
+ ;; unbound marker
+ (= ,val sb!vm:unbound-marker-type)
+ ;; pointer
+ (and (logand ,val 1)
+ ;; Check that the pointer is valid. XXX Could do a
+ ;; better job.
+ (or (< (sb!impl::read-only-space-start) ,val
+ (* sb!impl::*read-only-space-free-pointer*
+ sb!vm:word-bytes))
+ (< (sb!impl::static-space-start) ,val
+ (* sb!impl::*static-space-free-pointer*
+ sb!vm:word-bytes))
+ (< (sb!impl::current-dynamic-space-start) ,val
+ (sap-int (dynamic-space-free-pointer))))))
+ (make-lisp-obj ,val)
+ :invalid-object)))
+ (ecase (sb!c:sc-offset-scn sc-offset)
+ ((#.sb!vm:any-reg-sc-number #.sb!vm:descriptor-reg-sc-number)
+ (without-gcing
+ (with-escaped-value (val)
+ (make-valid-lisp-obj val))))
+ (#.sb!vm:base-char-reg-sc-number
+ (with-escaped-value (val)
+ (code-char val)))
+ (#.sb!vm:sap-reg-sc-number
+ (with-escaped-value (val)
+ (int-sap val)))
+ (#.sb!vm:signed-reg-sc-number
+ (with-escaped-value (val)
+ (if (logbitp (1- sb!vm:word-bits) val)
+ (logior val (ash -1 sb!vm:word-bits))
+ val)))
+ (#.sb!vm:unsigned-reg-sc-number
+ (with-escaped-value (val)
+ val))
+ (#.sb!vm:single-reg-sc-number
+ (escaped-float-value single-float))
+ (#.sb!vm:double-reg-sc-number
+ (escaped-float-value double-float))
+ #!+long-float
+ (#.sb!vm:long-reg-sc-number
+ (escaped-float-value long-float))
+ (#.sb!vm:complex-single-reg-sc-number
+ (escaped-complex-float-value single-float))
+ (#.sb!vm:complex-double-reg-sc-number
+ (escaped-complex-float-value double-float))
+ #!+long-float
+ (#.sb!vm:complex-long-reg-sc-number
+ (escaped-complex-float-value long-float))
+ (#.sb!vm:single-stack-sc-number
+ (sap-ref-single fp (- (* (1+ (sb!c:sc-offset-offset sc-offset))
+ sb!vm:word-bytes))))
+ (#.sb!vm:double-stack-sc-number
+ (sap-ref-double fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 2)
+ sb!vm:word-bytes))))
+ #!+long-float
+ (#.sb!vm:long-stack-sc-number
+ (sap-ref-long fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 3)
+ sb!vm:word-bytes))))
+ (#.sb!vm:complex-single-stack-sc-number
+ (complex
+ (sap-ref-single fp (- (* (1+ (sb!c:sc-offset-offset sc-offset))
+ sb!vm:word-bytes)))
+ (sap-ref-single fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 2)
+ sb!vm:word-bytes)))))
+ (#.sb!vm:complex-double-stack-sc-number
+ (complex
+ (sap-ref-double fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 2)
+ sb!vm:word-bytes)))
+ (sap-ref-double fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 4)
+ sb!vm:word-bytes)))))
+ #!+long-float
+ (#.sb!vm:complex-long-stack-sc-number
+ (complex
+ (sap-ref-long fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 3)
+ sb!vm:word-bytes)))
+ (sap-ref-long fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 6)
+ sb!vm:word-bytes)))))
+ (#.sb!vm:control-stack-sc-number
+ (stack-ref fp (sb!c:sc-offset-offset sc-offset)))
+ (#.sb!vm:base-char-stack-sc-number
+ (code-char
+ (sap-ref-32 fp (- (* (1+ (sb!c:sc-offset-offset sc-offset))
+ sb!vm:word-bytes)))))
+ (#.sb!vm:unsigned-stack-sc-number
+ (sap-ref-32 fp (- (* (1+ (sb!c:sc-offset-offset sc-offset))
+ sb!vm:word-bytes))))
+ (#.sb!vm:signed-stack-sc-number
+ (signed-sap-ref-32 fp (- (* (1+ (sb!c:sc-offset-offset sc-offset))
+ sb!vm:word-bytes))))
+ (#.sb!vm:sap-stack-sc-number
+ (sap-ref-sap fp (- (* (1+ (sb!c:sc-offset-offset sc-offset))
+ sb!vm:word-bytes)))))))
+
+;;; This stores value as the value of DEBUG-VAR in FRAME. In the
+;;; COMPILED-DEBUG-VAR case, access the current value to determine if
+;;; it is an indirect value cell. This occurs when the variable is
+;;; both closed over and set. For INTERPRETED-DEBUG-VARs just call
+;;; SB!EVAL::SET-LEAF-VALUE-LAMBDA-VAR with the right interpreter
+;;; objects.
+(defun %set-debug-var-value (debug-var frame value)
+ (etypecase debug-var
+ (compiled-debug-var
+ (check-type frame compiled-frame)
+ (let ((current-value (access-compiled-debug-var-slot debug-var frame)))
+ (if (indirect-value-cell-p current-value)
+ (sb!c:value-cell-set current-value value)
+ (set-compiled-debug-var-slot debug-var frame value))))
+ (interpreted-debug-var
+ (check-type frame interpreted-frame)
+ (sb!eval::set-leaf-value-lambda-var
+ (interpreted-code-location-ir1-node (frame-code-location frame))
+ (interpreted-debug-var-ir1-var debug-var)
+ (frame-pointer frame)
+ (interpreted-frame-closure frame)
+ value)))
+ value)
+
+;;; This stores value for the variable represented by debug-var
+;;; relative to the frame. This assumes the location directly contains
+;;; the variable's value; that is, there is no indirect value cell
+;;; currently there in case the variable is both closed over and set.
+(defun set-compiled-debug-var-slot (debug-var frame value)
+ (let ((escaped (compiled-frame-escaped frame)))
+ (if escaped
+ (sub-set-debug-var-slot (frame-pointer frame)
+ (compiled-debug-var-sc-offset debug-var)
+ value escaped)
+ (sub-set-debug-var-slot
+ (frame-pointer frame)
+ (or (compiled-debug-var-save-sc-offset debug-var)
+ (compiled-debug-var-sc-offset debug-var))
+ value))))
+
+#!-x86
+(defun sub-set-debug-var-slot (fp sc-offset value &optional escaped)
+ (macrolet ((set-escaped-value (val)
+ `(if escaped
+ (setf (sb!vm:context-register
+ escaped
+ (sb!c:sc-offset-offset sc-offset))
+ ,val)
+ value))
+ (set-escaped-float-value (format val)
+ `(if escaped
+ (setf (sb!vm:context-float-register
+ escaped
+ (sb!c:sc-offset-offset sc-offset)
+ ',format)
+ ,val)
+ value))
+ (with-nfp ((var) &body body)
+ `(let ((,var (if escaped
+ (int-sap
+ (sb!vm:context-register escaped
+ sb!vm::nfp-offset))
+ #!-alpha
+ (sap-ref-sap fp
+ (* sb!vm::nfp-save-offset
+ sb!vm:word-bytes))
+ #!+alpha
+ (%alpha::make-number-stack-pointer
+ (sap-ref-32 fp
+ (* sb!vm::nfp-save-offset
+ sb!vm:word-bytes))))))
+ ,@body)))
+ (ecase (sb!c:sc-offset-scn sc-offset)
+ ((#.sb!vm:any-reg-sc-number
+ #.sb!vm:descriptor-reg-sc-number
+ #!+rt #.sb!vm:word-pointer-reg-sc-number)
+ (without-gcing
+ (set-escaped-value
+ (get-lisp-obj-address value))))
+ (#.sb!vm:base-char-reg-sc-number
+ (set-escaped-value (char-code value)))
+ (#.sb!vm:sap-reg-sc-number
+ (set-escaped-value (sap-int value)))
+ (#.sb!vm:signed-reg-sc-number
+ (set-escaped-value (logand value (1- (ash 1 sb!vm:word-bits)))))
+ (#.sb!vm:unsigned-reg-sc-number
+ (set-escaped-value value))
+ (#.sb!vm:non-descriptor-reg-sc-number
+ (error "Local non-descriptor register access?"))
+ (#.sb!vm:interior-reg-sc-number
+ (error "Local interior register access?"))
+ (#.sb!vm:single-reg-sc-number
+ (set-escaped-float-value single-float value))
+ (#.sb!vm:double-reg-sc-number
+ (set-escaped-float-value double-float value))
+ #!+long-float
+ (#.sb!vm:long-reg-sc-number
+ (set-escaped-float-value long-float value))
+ (#.sb!vm:complex-single-reg-sc-number
+ (when escaped
+ (setf (sb!vm:context-float-register escaped
+ (sb!c:sc-offset-offset sc-offset)
+ 'single-float)
+ (realpart value))
+ (setf (sb!vm:context-float-register
+ escaped (1+ (sb!c:sc-offset-offset sc-offset))
+ 'single-float)
+ (imagpart value)))
+ value)
+ (#.sb!vm:complex-double-reg-sc-number
+ (when escaped
+ (setf (sb!vm:context-float-register
+ escaped (sb!c:sc-offset-offset sc-offset) 'double-float)
+ (realpart value))
+ (setf (sb!vm:context-float-register
+ escaped
+ (+ (sb!c:sc-offset-offset sc-offset) #!+sparc 2 #!-sparc 1)
+ 'double-float)
+ (imagpart value)))
+ value)
+ #!+long-float
+ (#.sb!vm:complex-long-reg-sc-number
+ (when escaped
+ (setf (sb!vm:context-float-register
+ escaped (sb!c:sc-offset-offset sc-offset) 'long-float)
+ (realpart value))
+ (setf (sb!vm:context-float-register
+ escaped
+ (+ (sb!c:sc-offset-offset sc-offset) #!+sparc 4)
+ 'long-float)
+ (imagpart value)))
+ value)
+ (#.sb!vm:single-stack-sc-number
+ (with-nfp (nfp)
+ (setf (sap-ref-single nfp (* (sb!c:sc-offset-offset sc-offset)
+ sb!vm:word-bytes))
+ (the single-float value))))
+ (#.sb!vm:double-stack-sc-number
+ (with-nfp (nfp)
+ (setf (sap-ref-double nfp (* (sb!c:sc-offset-offset sc-offset)
+ sb!vm:word-bytes))
+ (the double-float value))))
+ #!+long-float
+ (#.sb!vm:long-stack-sc-number
+ (with-nfp (nfp)
+ (setf (sap-ref-long nfp (* (sb!c:sc-offset-offset sc-offset)
+ sb!vm:word-bytes))
+ (the long-float value))))
+ (#.sb!vm:complex-single-stack-sc-number
+ (with-nfp (nfp)
+ (setf (sap-ref-single
+ nfp (* (sb!c:sc-offset-offset sc-offset) sb!vm:word-bytes))
+ (the single-float (realpart value)))
+ (setf (sap-ref-single
+ nfp (* (1+ (sb!c:sc-offset-offset sc-offset))
+ sb!vm:word-bytes))
+ (the single-float (realpart value)))))
+ (#.sb!vm:complex-double-stack-sc-number
+ (with-nfp (nfp)
+ (setf (sap-ref-double
+ nfp (* (sb!c:sc-offset-offset sc-offset) sb!vm:word-bytes))
+ (the double-float (realpart value)))
+ (setf (sap-ref-double
+ nfp (* (+ (sb!c:sc-offset-offset sc-offset) 2)
+ sb!vm:word-bytes))
+ (the double-float (realpart value)))))
+ #!+long-float
+ (#.sb!vm:complex-long-stack-sc-number
+ (with-nfp (nfp)
+ (setf (sap-ref-long
+ nfp (* (sb!c:sc-offset-offset sc-offset) sb!vm:word-bytes))
+ (the long-float (realpart value)))
+ (setf (sap-ref-long
+ nfp (* (+ (sb!c:sc-offset-offset sc-offset) #!+sparc 4)
+ sb!vm:word-bytes))
+ (the long-float (realpart value)))))
+ (#.sb!vm:control-stack-sc-number
+ (setf (stack-ref fp (sb!c:sc-offset-offset sc-offset)) value))
+ (#.sb!vm:base-char-stack-sc-number
+ (with-nfp (nfp)
+ (setf (sap-ref-32 nfp (* (sb!c:sc-offset-offset sc-offset)
+ sb!vm:word-bytes))
+ (char-code (the character value)))))
+ (#.sb!vm:unsigned-stack-sc-number
+ (with-nfp (nfp)
+ (setf (sap-ref-32 nfp (* (sb!c:sc-offset-offset sc-offset)
+ sb!vm:word-bytes))
+ (the (unsigned-byte 32) value))))
+ (#.sb!vm:signed-stack-sc-number
+ (with-nfp (nfp)
+ (setf (signed-sap-ref-32 nfp (* (sb!c:sc-offset-offset sc-offset)
+ sb!vm:word-bytes))
+ (the (signed-byte 32) value))))
+ (#.sb!vm:sap-stack-sc-number
+ (with-nfp (nfp)
+ (setf (sap-ref-sap nfp (* (sb!c:sc-offset-offset sc-offset)
+ sb!vm:word-bytes))
+ (the system-area-pointer value)))))))
+
+#!+x86
+(defun sub-set-debug-var-slot (fp sc-offset value &optional escaped)
+ (macrolet ((set-escaped-value (val)
+ `(if escaped
+ (setf (sb!vm:context-register
+ escaped
+ (sb!c:sc-offset-offset sc-offset))
+ ,val)
+ value)))
+ (ecase (sb!c:sc-offset-scn sc-offset)
+ ((#.sb!vm:any-reg-sc-number #.sb!vm:descriptor-reg-sc-number)
+ (without-gcing
+ (set-escaped-value
+ (get-lisp-obj-address value))))
+ (#.sb!vm:base-char-reg-sc-number
+ (set-escaped-value (char-code value)))
+ (#.sb!vm:sap-reg-sc-number
+ (set-escaped-value (sap-int value)))
+ (#.sb!vm:signed-reg-sc-number
+ (set-escaped-value (logand value (1- (ash 1 sb!vm:word-bits)))))
+ (#.sb!vm:unsigned-reg-sc-number
+ (set-escaped-value value))
+ (#.sb!vm:single-reg-sc-number
+ #+nil ;; don't have escaped floats.
+ (set-escaped-float-value single-float value))
+ (#.sb!vm:double-reg-sc-number
+ #+nil ;; don't have escaped floats -- still in npx?
+ (set-escaped-float-value double-float value))
+ #!+long-float
+ (#.sb!vm:long-reg-sc-number
+ #+nil ;; don't have escaped floats -- still in npx?
+ (set-escaped-float-value long-float value))
+ (#.sb!vm:single-stack-sc-number
+ (setf (sap-ref-single
+ fp (- (* (1+ (sb!c:sc-offset-offset sc-offset))
+ sb!vm:word-bytes)))
+ (the single-float value)))
+ (#.sb!vm:double-stack-sc-number
+ (setf (sap-ref-double
+ fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 2)
+ sb!vm:word-bytes)))
+ (the double-float value)))
+ #!+long-float
+ (#.sb!vm:long-stack-sc-number
+ (setf (sap-ref-long
+ fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 3)
+ sb!vm:word-bytes)))
+ (the long-float value)))
+ (#.sb!vm:complex-single-stack-sc-number
+ (setf (sap-ref-single
+ fp (- (* (1+ (sb!c:sc-offset-offset sc-offset))
+ sb!vm:word-bytes)))
+ (realpart (the (complex single-float) value)))
+ (setf (sap-ref-single
+ fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 2)
+ sb!vm:word-bytes)))
+ (imagpart (the (complex single-float) value))))
+ (#.sb!vm:complex-double-stack-sc-number
+ (setf (sap-ref-double
+ fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 2)
+ sb!vm:word-bytes)))
+ (realpart (the (complex double-float) value)))
+ (setf (sap-ref-double
+ fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 4)
+ sb!vm:word-bytes)))
+ (imagpart (the (complex double-float) value))))
+ #!+long-float
+ (#.sb!vm:complex-long-stack-sc-number
+ (setf (sap-ref-long
+ fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 3)
+ sb!vm:word-bytes)))
+ (realpart (the (complex long-float) value)))
+ (setf (sap-ref-long
+ fp (- (* (+ (sb!c:sc-offset-offset sc-offset) 6)
+ sb!vm:word-bytes)))
+ (imagpart (the (complex long-float) value))))
+ (#.sb!vm:control-stack-sc-number
+ (setf (stack-ref fp (sb!c:sc-offset-offset sc-offset)) value))
+ (#.sb!vm:base-char-stack-sc-number
+ (setf (sap-ref-32 fp (- (* (1+ (sb!c:sc-offset-offset sc-offset))
+ sb!vm:word-bytes)))
+ (char-code (the character value))))
+ (#.sb!vm:unsigned-stack-sc-number
+ (setf (sap-ref-32 fp (- (* (1+ (sb!c:sc-offset-offset sc-offset))
+ sb!vm:word-bytes)))
+ (the (unsigned-byte 32) value)))
+ (#.sb!vm:signed-stack-sc-number
+ (setf (signed-sap-ref-32
+ fp (- (* (1+ (sb!c:sc-offset-offset sc-offset)) sb!vm:word-bytes)))
+ (the (signed-byte 32) value)))
+ (#.sb!vm:sap-stack-sc-number
+ (setf (sap-ref-sap fp (- (* (1+ (sb!c:sc-offset-offset sc-offset))
+ sb!vm:word-bytes)))
+ (the system-area-pointer value))))))
+
+;;; The method for setting and accessing COMPILED-DEBUG-VAR values use
+;;; this to determine if the value stored is the actual value or an
+;;; indirection cell.
+(defun indirect-value-cell-p (x)
+ (and (= (get-lowtag x) sb!vm:other-pointer-type)
+ (= (get-type x) sb!vm:value-cell-header-type)))
+
+;;; If the variable is always alive, then it is valid. If the
+;;; code-location is unknown, then the variable's validity is
+;;; :unknown. Once we've called CODE-LOCATION-UNKNOWN-P, we know the
+;;; live-set information has been cached in the code-location.
+(defun debug-var-validity (debug-var basic-code-location)
+ #!+sb-doc
+ "Returns three values reflecting the validity of DEBUG-VAR's value
+ at BASIC-CODE-LOCATION:
+ :VALID The value is known to be available.
+ :INVALID The value is known to be unavailable.
+ :UNKNOWN The value's availability is unknown."
+ (etypecase debug-var
+ (compiled-debug-var
+ (compiled-debug-var-validity debug-var basic-code-location))
+ (interpreted-debug-var
+ (check-type basic-code-location interpreted-code-location)
+ (let ((validp (rassoc (interpreted-debug-var-ir1-var debug-var)
+ (sb!c::lexenv-variables
+ (sb!c::node-lexenv
+ (interpreted-code-location-ir1-node
+ basic-code-location))))))
+ (if validp :valid :invalid)))))
+
+;;; This is the method for DEBUG-VAR-VALIDITY for COMPILED-DEBUG-VARs.
+;;; For safety, make sure basic-code-location is what we think.
+(defun compiled-debug-var-validity (debug-var basic-code-location)
+ (check-type basic-code-location compiled-code-location)
+ (cond ((debug-var-alive-p debug-var)
+ (let ((debug-fun (code-location-debug-function basic-code-location)))
+ (if (>= (compiled-code-location-pc basic-code-location)
+ (sb!c::compiled-debug-function-start-pc
+ (compiled-debug-function-compiler-debug-fun debug-fun)))
+ :valid
+ :invalid)))
+ ((code-location-unknown-p basic-code-location) :unknown)
+ (t
+ (let ((pos (position debug-var
+ (debug-function-debug-vars
+ (code-location-debug-function basic-code-location)))))
+ (unless pos
+ (error 'unknown-debug-var
+ :debug-var debug-var
+ :debug-function
+ (code-location-debug-function basic-code-location)))
+ ;; There must be live-set info since basic-code-location is known.
+ (if (zerop (sbit (compiled-code-location-live-set basic-code-location)
+ pos))
+ :invalid
+ :valid)))))
+\f
+;;;; sources
+
+;;; This code produces and uses what we call source-paths. A
+;;; source-path is a list whose first element is a form number as
+;;; returned by CODE-LOCATION-FORM-NUMBER and whose last element is a
+;;; top-level-form number as returned by
+;;; CODE-LOCATION-TOP-LEVEL-FORM-NUMBER. The elements from the last to
+;;; the first, exclusively, are the numbered subforms into which to
+;;; descend. For example:
+;;; (defun foo (x)
+;;; (let ((a (aref x 3)))
+;;; (cons a 3)))
+;;; The call to AREF in this example is form number 5. Assuming this
+;;; DEFUN is the 11'th top-level-form, the source-path for the AREF
+;;; call is as follows:
+;;; (5 1 0 1 3 11)
+;;; Given the DEFUN, 3 gets you the LET, 1 gets you the bindings, 0
+;;; gets the first binding, and 1 gets the AREF form.
+
+;;; Temporary buffer used to build form-number => source-path translation in
+;;; FORM-NUMBER-TRANSLATIONS.
+(defvar *form-number-temp* (make-array 10 :fill-pointer 0 :adjustable t))
+
+;;; Table used to detect CAR circularities in FORM-NUMBER-TRANSLATIONS.
+(defvar *form-number-circularity-table* (make-hash-table :test 'eq))
+
+;;; The vector elements are in the same format as the compiler's
+;;; NODE-SOUCE-PATH; that is, the first element is the form number and the last
+;;; is the top-level-form number.
+(defun form-number-translations (form tlf-number)
+ #!+sb-doc
+ "This returns a table mapping form numbers to source-paths. A source-path
+ indicates a descent into the top-level-form form, going directly to the
+ subform corressponding to the form number."
+ (clrhash *form-number-circularity-table*)
+ (setf (fill-pointer *form-number-temp*) 0)
+ (sub-translate-form-numbers form (list tlf-number))
+ (coerce *form-number-temp* 'simple-vector))
+(defun sub-translate-form-numbers (form path)
+ (unless (gethash form *form-number-circularity-table*)
+ (setf (gethash form *form-number-circularity-table*) t)
+ (vector-push-extend (cons (fill-pointer *form-number-temp*) path)
+ *form-number-temp*)
+ (let ((pos 0)
+ (subform form)
+ (trail form))
+ (declare (fixnum pos))
+ (macrolet ((frob ()
+ '(progn
+ (when (atom subform) (return))
+ (let ((fm (car subform)))
+ (when (consp fm)
+ (sub-translate-form-numbers fm (cons pos path)))
+ (incf pos))
+ (setq subform (cdr subform))
+ (when (eq subform trail) (return)))))
+ (loop
+ (frob)
+ (frob)
+ (setq trail (cdr trail)))))))
+
+(defun source-path-context (form path context)
+ #!+sb-doc
+ "Form is a top-level form, and path is a source-path into it. This returns
+ the form indicated by the source-path. Context is the number of enclosing
+ forms to return instead of directly returning the source-path form. When
+ context is non-zero, the form returned contains a marker, #:****HERE****,
+ immediately before the form indicated by path."
+ (declare (type unsigned-byte context))
+ ;; Get to the form indicated by path or the enclosing form indicated
+ ;; by context and path.
+ (let ((path (reverse (butlast (cdr path)))))
+ (dotimes (i (- (length path) context))
+ (let ((index (first path)))
+ (unless (and (listp form) (< index (length form)))
+ (error "Source path no longer exists."))
+ (setq form (elt form index))
+ (setq path (rest path))))
+ ;; Recursively rebuild the source form resulting from the above
+ ;; descent, copying the beginning of each subform up to the next
+ ;; subform we descend into according to path. At the bottom of the
+ ;; recursion, we return the form indicated by path preceded by our
+ ;; marker, and this gets spliced into the resulting list structure
+ ;; on the way back up.
+ (labels ((frob (form path level)
+ (if (or (zerop level) (null path))
+ (if (zerop context)
+ form
+ `(#:***here*** ,form))
+ (let ((n (first path)))
+ (unless (and (listp form) (< n (length form)))
+ (error "Source path no longer exists."))
+ (let ((res (frob (elt form n) (rest path) (1- level))))
+ (nconc (subseq form 0 n)
+ (cons res (nthcdr (1+ n) form))))))))
+ (frob form path context))))
+\f
+;;;; PREPROCESS-FOR-EVAL and EVAL-IN-FRAME
+
+;;; Create a SYMBOL-MACROLET for each variable valid at the location which
+;;; accesses that variable from the frame argument.
+(defun preprocess-for-eval (form loc)
+ #!+sb-doc
+ "Return a function of one argument that evaluates form in the lexical
+ context of the basic-code-location loc. PREPROCESS-FOR-EVAL signals a
+ no-debug-vars condition when the loc's debug-function has no
+ debug-var information available. The returned function takes the frame
+ to get values from as its argument, and it returns the values of form.
+ The returned function signals the following conditions: invalid-value,
+ ambiguous-variable-name, and frame-function-mismatch"
+ (declare (type code-location loc))
+ (let ((n-frame (gensym))
+ (fun (code-location-debug-function loc)))
+ (unless (debug-var-info-available fun)
+ (debug-signal 'no-debug-vars :debug-function fun))
+ (sb!int:collect ((binds)
+ (specs))
+ (do-debug-function-variables (var fun)
+ (let ((validity (debug-var-validity var loc)))
+ (unless (eq validity :invalid)
+ (let* ((sym (debug-var-symbol var))
+ (found (assoc sym (binds))))
+ (if found
+ (setf (second found) :ambiguous)
+ (binds (list sym validity var)))))))
+ (dolist (bind (binds))
+ (let ((name (first bind))
+ (var (third bind)))
+ (ecase (second bind)
+ (:valid
+ (specs `(,name (debug-var-value ',var ,n-frame))))
+ (:unknown
+ (specs `(,name (debug-signal 'invalid-value :debug-var ',var
+ :frame ,n-frame))))
+ (:ambiguous
+ (specs `(,name (debug-signal 'ambiguous-variable-name :name ',name
+ :frame ,n-frame)))))))
+ (let ((res (coerce `(lambda (,n-frame)
+ (declare (ignorable ,n-frame))
+ (symbol-macrolet ,(specs) ,form))
+ 'function)))
+ #'(lambda (frame)
+ ;; This prevents these functions from being used in any
+ ;; location other than a function return location, so
+ ;; maybe this should only check whether frame's
+ ;; debug-function is the same as loc's.
+ (unless (code-location= (frame-code-location frame) loc)
+ (debug-signal 'frame-function-mismatch
+ :code-location loc :form form :frame frame))
+ (funcall res frame))))))
+
+(defun eval-in-frame (frame form)
+ (declare (type frame frame))
+ #!+sb-doc
+ "Evaluate Form in the lexical context of Frame's current code location,
+ returning the results of the evaluation."
+ (funcall (preprocess-for-eval form (frame-code-location frame)) frame))
+\f
+;;;; breakpoints
+
+;;;; user-visible interface
+
+(defun make-breakpoint (hook-function what
+ &key (kind :code-location) info function-end-cookie)
+ #!+sb-doc
+ "This creates and returns a breakpoint. When program execution encounters
+ the breakpoint, the system calls hook-function. Hook-function takes the
+ current frame for the function in which the program is running and the
+ breakpoint object.
+ What and kind determine where in a function the system invokes
+ hook-function. What is either a code-location or a debug-function. Kind is
+ one of :code-location, :function-start, or :function-end. Since the starts
+ and ends of functions may not have code-locations representing them,
+ designate these places by supplying what as a debug-function and kind
+ indicating the :function-start or :function-end. When what is a
+ debug-function and kind is :function-end, then hook-function must take two
+ additional arguments, a list of values returned by the function and a
+ function-end-cookie.
+ Info is information supplied by and used by the user.
+ Function-end-cookie is a function. To implement :function-end breakpoints,
+ the system uses starter breakpoints to establish the :function-end breakpoint
+ for each invocation of the function. Upon each entry, the system creates a
+ unique cookie to identify the invocation, and when the user supplies a
+ function for this argument, the system invokes it on the frame and the
+ cookie. The system later invokes the :function-end breakpoint hook on the
+ same cookie. The user may save the cookie for comparison in the hook
+ function.
+ This signals an error if what is an unknown code-location."
+ (etypecase what
+ (code-location
+ (when (code-location-unknown-p what)
+ (error "cannot make a breakpoint at an unknown code location: ~S"
+ what))
+ (assert (eq kind :code-location))
+ (let ((bpt (%make-breakpoint hook-function what kind info)))
+ (etypecase what
+ (interpreted-code-location
+ (error "Breakpoints in interpreted code are currently unsupported."))
+ (compiled-code-location
+ ;; This slot is filled in due to calling CODE-LOCATION-UNKNOWN-P.
+ (when (eq (compiled-code-location-kind what) :unknown-return)
+ (let ((other-bpt (%make-breakpoint hook-function what
+ :unknown-return-partner
+ info)))
+ (setf (breakpoint-unknown-return-partner bpt) other-bpt)
+ (setf (breakpoint-unknown-return-partner other-bpt) bpt)))))
+ bpt))
+ (compiled-debug-function
+ (ecase kind
+ (:function-start
+ (%make-breakpoint hook-function what kind info))
+ (:function-end
+ (unless (eq (sb!c::compiled-debug-function-returns
+ (compiled-debug-function-compiler-debug-fun what))
+ :standard)
+ (error ":FUNCTION-END breakpoints are currently unsupported ~
+ for the known return convention."))
+
+ (let* ((bpt (%make-breakpoint hook-function what kind info))
+ (starter (compiled-debug-function-end-starter what)))
+ (unless starter
+ (setf starter (%make-breakpoint #'list what :function-start nil))
+ (setf (breakpoint-hook-function starter)
+ (function-end-starter-hook starter what))
+ (setf (compiled-debug-function-end-starter what) starter))
+ (setf (breakpoint-start-helper bpt) starter)
+ (push bpt (breakpoint-%info starter))
+ (setf (breakpoint-cookie-fun bpt) function-end-cookie)
+ bpt))))
+ (interpreted-debug-function
+ (error ":function-end breakpoints are currently unsupported ~
+ for interpreted-debug-functions."))))
+
+;;; These are unique objects created upon entry into a function by a
+;;; :FUNCTION-END breakpoint's starter hook. These are only created
+;;; when users supply :FUNCTION-END-COOKIE to MAKE-BREAKPOINT. Also,
+;;; the :FUNCTION-END breakpoint's hook is called on the same cookie
+;;; when it is created.
+(defstruct (function-end-cookie
+ (:print-object (lambda (obj str)
+ (print-unreadable-object (obj str :type t))))
+ (:constructor make-function-end-cookie (bogus-lra debug-fun)))
+ ;; This is a pointer to the bogus-lra created for :function-end bpts.
+ bogus-lra
+ ;; This is the debug-function associated with the cookie.
+ debug-fun)
+
+;;; This maps bogus-lra-components to cookies, so
+;;; HANDLE-FUNCTION-END-BREAKPOINT can find the appropriate cookie for the
+;;; breakpoint hook.
+(defvar *function-end-cookies* (make-hash-table :test 'eq))
+
+;;; This returns a hook function for the start helper breakpoint
+;;; associated with a :FUNCTION-END breakpoint. The returned function
+;;; makes a fake LRA that all returns go through, and this piece of
+;;; fake code actually breaks. Upon return from the break, the code
+;;; provides the returnee with any values. Since the returned function
+;;; effectively activates FUN-END-BPT on each entry to DEBUG-FUN's
+;;; function, we must establish breakpoint-data about FUN-END-BPT.
+(defun function-end-starter-hook (starter-bpt debug-fun)
+ (declare (type breakpoint starter-bpt)
+ (type compiled-debug-function debug-fun))
+ #'(lambda (frame breakpoint)
+ (declare (ignore breakpoint)
+ (type frame frame))
+ (let ((lra-sc-offset
+ (sb!c::compiled-debug-function-return-pc
+ (compiled-debug-function-compiler-debug-fun debug-fun))))
+ (multiple-value-bind (lra component offset)
+ (make-bogus-lra
+ (get-context-value frame
+ #!-gengc sb!vm::lra-save-offset
+ #!+gengc sb!vm::ra-save-offset
+ lra-sc-offset))
+ (setf (get-context-value frame
+ #!-gengc sb!vm::lra-save-offset
+ #!+gengc sb!vm::ra-save-offset
+ lra-sc-offset)
+ lra)
+ (let ((end-bpts (breakpoint-%info starter-bpt)))
+ (let ((data (breakpoint-data component offset)))
+ (setf (breakpoint-data-breakpoints data) end-bpts)
+ (dolist (bpt end-bpts)
+ (setf (breakpoint-internal-data bpt) data)))
+ (let ((cookie (make-function-end-cookie lra debug-fun)))
+ (setf (gethash component *function-end-cookies*) cookie)
+ (dolist (bpt end-bpts)
+ (let ((fun (breakpoint-cookie-fun bpt)))
+ (when fun (funcall fun frame cookie))))))))))
+
+(defun function-end-cookie-valid-p (frame cookie)
+ #!+sb-doc
+ "This takes a function-end-cookie and a frame, and it returns whether the
+ cookie is still valid. A cookie becomes invalid when the frame that
+ established the cookie has exited. Sometimes cookie holders are unaware
+ of cookie invalidation because their :function-end breakpoint hooks didn't
+ run due to THROW'ing. This takes a frame as an efficiency hack since the
+ user probably has a frame object in hand when using this routine, and it
+ saves repeated parsing of the stack and consing when asking whether a
+ series of cookies is valid."
+ (let ((lra (function-end-cookie-bogus-lra cookie))
+ (lra-sc-offset (sb!c::compiled-debug-function-return-pc
+ (compiled-debug-function-compiler-debug-fun
+ (function-end-cookie-debug-fun cookie)))))
+ (do ((frame frame (frame-down frame)))
+ ((not frame) nil)
+ (when (and (compiled-frame-p frame)
+ (eq lra
+ (get-context-value frame
+ #!-gengc sb!vm::lra-save-offset
+ #!+gengc sb!vm::ra-save-offset
+ lra-sc-offset)))
+ (return t)))))
+
+;;;; ACTIVATE-BREAKPOINT
+
+(defun activate-breakpoint (breakpoint)
+ #!+sb-doc
+ "This causes the system to invoke the breakpoint's hook-function until the
+ next call to DEACTIVATE-BREAKPOINT or DELETE-BREAKPOINT. The system invokes
+ breakpoint hook functions in the opposite order that you activate them."
+ (when (eq (breakpoint-status breakpoint) :deleted)
+ (error "cannot activate a deleted breakpoint: ~S" breakpoint))
+ (unless (eq (breakpoint-status breakpoint) :active)
+ (ecase (breakpoint-kind breakpoint)
+ (:code-location
+ (let ((loc (breakpoint-what breakpoint)))
+ (etypecase loc
+ (interpreted-code-location
+ (error "Breakpoints in interpreted code are currently unsupported."))
+ (compiled-code-location
+ (activate-compiled-code-location-breakpoint breakpoint)
+ (let ((other (breakpoint-unknown-return-partner breakpoint)))
+ (when other
+ (activate-compiled-code-location-breakpoint other)))))))
+ (:function-start
+ (etypecase (breakpoint-what breakpoint)
+ (compiled-debug-function
+ (activate-compiled-function-start-breakpoint breakpoint))
+ (interpreted-debug-function
+ (error "I don't know how you made this, but they're unsupported: ~S"
+ (breakpoint-what breakpoint)))))
+ (:function-end
+ (etypecase (breakpoint-what breakpoint)
+ (compiled-debug-function
+ (let ((starter (breakpoint-start-helper breakpoint)))
+ (unless (eq (breakpoint-status starter) :active)
+ ;; May already be active by some other :function-end breakpoint.
+ (activate-compiled-function-start-breakpoint starter)))
+ (setf (breakpoint-status breakpoint) :active))
+ (interpreted-debug-function
+ (error "I don't know how you made this, but they're unsupported: ~S"
+ (breakpoint-what breakpoint)))))))
+ breakpoint)
+
+(defun activate-compiled-code-location-breakpoint (breakpoint)
+ (declare (type breakpoint breakpoint))
+ (let ((loc (breakpoint-what breakpoint)))
+ (declare (type compiled-code-location loc))
+ (sub-activate-breakpoint
+ breakpoint
+ (breakpoint-data (compiled-debug-function-component
+ (code-location-debug-function loc))
+ (+ (compiled-code-location-pc loc)
+ (if (or (eq (breakpoint-kind breakpoint)
+ :unknown-return-partner)
+ (eq (compiled-code-location-kind loc)
+ :single-value-return))
+ sb!vm:single-value-return-byte-offset
+ 0))))))
+
+(defun activate-compiled-function-start-breakpoint (breakpoint)
+ (declare (type breakpoint breakpoint))
+ (let ((debug-fun (breakpoint-what breakpoint)))
+ (sub-activate-breakpoint
+ breakpoint
+ (breakpoint-data (compiled-debug-function-component debug-fun)
+ (sb!c::compiled-debug-function-start-pc
+ (compiled-debug-function-compiler-debug-fun
+ debug-fun))))))
+
+(defun sub-activate-breakpoint (breakpoint data)
+ (declare (type breakpoint breakpoint)
+ (type breakpoint-data data))
+ (setf (breakpoint-status breakpoint) :active)
+ (without-interrupts
+ (unless (breakpoint-data-breakpoints data)
+ (setf (breakpoint-data-instruction data)
+ (without-gcing
+ (breakpoint-install (get-lisp-obj-address
+ (breakpoint-data-component data))
+ (breakpoint-data-offset data)))))
+ (setf (breakpoint-data-breakpoints data)
+ (append (breakpoint-data-breakpoints data) (list breakpoint)))
+ (setf (breakpoint-internal-data breakpoint) data)))
+
+;;;; DEACTIVATE-BREAKPOINT
+
+(defun deactivate-breakpoint (breakpoint)
+ #!+sb-doc
+ "This stops the system from invoking the breakpoint's hook-function."
+ (when (eq (breakpoint-status breakpoint) :active)
+ (without-interrupts
+ (let ((loc (breakpoint-what breakpoint)))
+ (etypecase loc
+ ((or interpreted-code-location interpreted-debug-function)
+ (error
+ "Breakpoints in interpreted code are currently unsupported."))
+ ((or compiled-code-location compiled-debug-function)
+ (deactivate-compiled-breakpoint breakpoint)
+ (let ((other (breakpoint-unknown-return-partner breakpoint)))
+ (when other
+ (deactivate-compiled-breakpoint other))))))))
+ breakpoint)
+
+(defun deactivate-compiled-breakpoint (breakpoint)
+ (if (eq (breakpoint-kind breakpoint) :function-end)
+ (let ((starter (breakpoint-start-helper breakpoint)))
+ (unless (find-if #'(lambda (bpt)
+ (and (not (eq bpt breakpoint))
+ (eq (breakpoint-status bpt) :active)))
+ (breakpoint-%info starter))
+ (deactivate-compiled-breakpoint starter)))
+ (let* ((data (breakpoint-internal-data breakpoint))
+ (bpts (delete breakpoint (breakpoint-data-breakpoints data))))
+ (setf (breakpoint-internal-data breakpoint) nil)
+ (setf (breakpoint-data-breakpoints data) bpts)
+ (unless bpts
+ (without-gcing
+ (breakpoint-remove (get-lisp-obj-address
+ (breakpoint-data-component data))
+ (breakpoint-data-offset data)
+ (breakpoint-data-instruction data)))
+ (delete-breakpoint-data data))))
+ (setf (breakpoint-status breakpoint) :inactive)
+ breakpoint)
+
+;;;; BREAKPOINT-INFO
+
+(defun breakpoint-info (breakpoint)
+ #!+sb-doc
+ "This returns the user-maintained info associated with breakpoint. This
+ is SETF'able."
+ (breakpoint-%info breakpoint))
+(defun %set-breakpoint-info (breakpoint value)
+ (setf (breakpoint-%info breakpoint) value)
+ (let ((other (breakpoint-unknown-return-partner breakpoint)))
+ (when other
+ (setf (breakpoint-%info other) value))))
+
+;;;; BREAKPOINT-ACTIVE-P and DELETE-BREAKPOINT
+
+(defun breakpoint-active-p (breakpoint)
+ #!+sb-doc
+ "This returns whether breakpoint is currently active."
+ (ecase (breakpoint-status breakpoint)
+ (:active t)
+ ((:inactive :deleted) nil)))
+
+(defun delete-breakpoint (breakpoint)
+ #!+sb-doc
+ "This frees system storage and removes computational overhead associated with
+ breakpoint. After calling this, breakpoint is completely impotent and can
+ never become active again."
+ (let ((status (breakpoint-status breakpoint)))
+ (unless (eq status :deleted)
+ (when (eq status :active)
+ (deactivate-breakpoint breakpoint))
+ (setf (breakpoint-status breakpoint) :deleted)
+ (let ((other (breakpoint-unknown-return-partner breakpoint)))
+ (when other
+ (setf (breakpoint-status other) :deleted)))
+ (when (eq (breakpoint-kind breakpoint) :function-end)
+ (let* ((starter (breakpoint-start-helper breakpoint))
+ (breakpoints (delete breakpoint
+ (the list (breakpoint-info starter)))))
+ (setf (breakpoint-info starter) breakpoints)
+ (unless breakpoints
+ (delete-breakpoint starter)
+ (setf (compiled-debug-function-end-starter
+ (breakpoint-what breakpoint))
+ nil))))))
+ breakpoint)
+
+;;;; C call out stubs
+
+;;; This actually installs the break instruction in the component. It
+;;; returns the overwritten bits. You must call this in a context in
+;;; which GC is disabled, so that Lisp doesn't move objects around
+;;; that C is pointing to.
+(sb!alien:def-alien-routine "breakpoint_install" sb!c-call:unsigned-long
+ (code-obj sb!c-call:unsigned-long)
+ (pc-offset sb!c-call:int))
+
+;;; This removes the break instruction and replaces the original
+;;; instruction. You must call this in a context in which GC is disabled
+;;; so Lisp doesn't move objects around that C is pointing to.
+(sb!alien:def-alien-routine "breakpoint_remove" sb!c-call:void
+ (code-obj sb!c-call:unsigned-long)
+ (pc-offset sb!c-call:int)
+ (old-inst sb!c-call:unsigned-long))
+
+(sb!alien:def-alien-routine "breakpoint_do_displaced_inst" sb!c-call:void
+ (scp (* os-context-t))
+ (orig-inst sb!c-call:unsigned-long))
+
+;;;; breakpoint handlers (layer between C and exported interface)
+
+;;; This maps components to a mapping of offsets to breakpoint-datas.
+(defvar *component-breakpoint-offsets* (make-hash-table :test 'eq))
+
+;;; This returns the breakpoint-data associated with component cross
+;;; offset. If none exists, this makes one, installs it, and returns it.
+(defun breakpoint-data (component offset &optional (create t))
+ (flet ((install-breakpoint-data ()
+ (when create
+ (let ((data (make-breakpoint-data component offset)))
+ (push (cons offset data)
+ (gethash component *component-breakpoint-offsets*))
+ data))))
+ (let ((offsets (gethash component *component-breakpoint-offsets*)))
+ (if offsets
+ (let ((data (assoc offset offsets)))
+ (if data
+ (cdr data)
+ (install-breakpoint-data)))
+ (install-breakpoint-data)))))
+
+;;; We use this when there are no longer any active breakpoints
+;;; corresponding to data.
+(defun delete-breakpoint-data (data)
+ (let* ((component (breakpoint-data-component data))
+ (offsets (delete (breakpoint-data-offset data)
+ (gethash component *component-breakpoint-offsets*)
+ :key #'car)))
+ (if offsets
+ (setf (gethash component *component-breakpoint-offsets*) offsets)
+ (remhash component *component-breakpoint-offsets*)))
+ (values))
+
+;;; The C handler for interrupts calls this when it has a
+;;; debugging-tool break instruction. This does NOT handle all breaks;
+;;; for example, it does not handle breaks for internal errors.
+(defun handle-breakpoint (offset component signal-context)
+ (let ((data (breakpoint-data component offset nil)))
+ (unless data
+ (error "unknown breakpoint in ~S at offset ~S"
+ (debug-function-name (debug-function-from-pc component offset))
+ offset))
+ (let ((breakpoints (breakpoint-data-breakpoints data)))
+ (if (or (null breakpoints)
+ (eq (breakpoint-kind (car breakpoints)) :function-end))
+ (handle-function-end-breakpoint-aux breakpoints data signal-context)
+ (handle-breakpoint-aux breakpoints data
+ offset component signal-context)))))
+
+;;; This holds breakpoint-datas while invoking the breakpoint hooks
+;;; associated with that particular component and location. While they
+;;; are executing, if we hit the location again, we ignore the
+;;; breakpoint to avoid infinite recursion. Function-end breakpoints
+;;; must work differently since the breakpoint-data is unique for each
+;;; invocation.
+(defvar *executing-breakpoint-hooks* nil)
+
+;;; This handles code-location and debug-function :FUNCTION-START
+;;; breakpoints.
+(defun handle-breakpoint-aux (breakpoints data offset component signal-context)
+ (unless breakpoints
+ (error "internal error: breakpoint that nobody wants"))
+ (unless (member data *executing-breakpoint-hooks*)
+ (let ((*executing-breakpoint-hooks* (cons data
+ *executing-breakpoint-hooks*)))
+ (invoke-breakpoint-hooks breakpoints component offset)))
+ ;; At this point breakpoints may not hold the same list as
+ ;; BREAKPOINT-DATA-BREAKPOINTS since invoking hooks may have allowed
+ ;; a breakpoint deactivation. In fact, if all breakpoints were
+ ;; deactivated then data is invalid since it was deleted and so the
+ ;; correct one must be looked up if it is to be used. If there are
+ ;; no more breakpoints active at this location, then the normal
+ ;; instruction has been put back, and we do not need to
+ ;; DO-DISPLACED-INST.
+ (let ((data (breakpoint-data component offset nil)))
+ (when (and data (breakpoint-data-breakpoints data))
+ ;; The breakpoint is still active, so we need to execute the
+ ;; displaced instruction and leave the breakpoint instruction
+ ;; behind. The best way to do this is different on each machine,
+ ;; so we just leave it up to the C code.
+ (breakpoint-do-displaced-inst signal-context
+ (breakpoint-data-instruction data))
+ ; Under HPUX we can't sigreturn so bp-do-disp-i has to return.
+ #!-(or hpux irix x86)
+ (error "BREAKPOINT-DO-DISPLACED-INST returned?"))))
+
+(defun invoke-breakpoint-hooks (breakpoints component offset)
+ (let* ((debug-fun (debug-function-from-pc component offset))
+ (frame (do ((f (top-frame) (frame-down f)))
+ ((eq debug-fun (frame-debug-function f)) f))))
+ (dolist (bpt breakpoints)
+ (funcall (breakpoint-hook-function bpt)
+ frame
+ ;; If this is an :UNKNOWN-RETURN-PARTNER, then pass the
+ ;; hook function the original breakpoint, so that users
+ ;; aren't forced to confront the fact that some
+ ;; breakpoints really are two.
+ (if (eq (breakpoint-kind bpt) :unknown-return-partner)
+ (breakpoint-unknown-return-partner bpt)
+ bpt)))))
+
+(defun handle-function-end-breakpoint (offset component context)
+ (let ((data (breakpoint-data component offset nil)))
+ (unless data
+ (error "unknown breakpoint in ~S at offset ~S"
+ (debug-function-name (debug-function-from-pc component offset))
+ offset))
+ (let ((breakpoints (breakpoint-data-breakpoints data)))
+ (when breakpoints
+ (assert (eq (breakpoint-kind (car breakpoints)) :function-end))
+ (handle-function-end-breakpoint-aux breakpoints data context)))))
+
+;;; Either HANDLE-BREAKPOINT calls this for :FUNCTION-END breakpoints
+;;; [old C code] or HANDLE-FUNCTION-END-BREAKPOINT calls this directly
+;;; [new C code].
+(defun handle-function-end-breakpoint-aux (breakpoints data signal-context)
+ (delete-breakpoint-data data)
+ (let* ((scp
+ (locally
+ (declare (optimize (inhibit-warnings 3)))
+ (sb!alien:sap-alien signal-context (* os-context-t))))
+ (frame (do ((cfp (sb!vm:context-register scp sb!vm::cfp-offset))
+ (f (top-frame) (frame-down f)))
+ ((= cfp (sap-int (frame-pointer f))) f)
+ (declare (type (unsigned-byte #.sb!vm:word-bits) cfp))))
+ (component (breakpoint-data-component data))
+ (cookie (gethash component *function-end-cookies*)))
+ (remhash component *function-end-cookies*)
+ (dolist (bpt breakpoints)
+ (funcall (breakpoint-hook-function bpt)
+ frame bpt
+ (get-function-end-breakpoint-values scp)
+ cookie))))
+
+(defun get-function-end-breakpoint-values (scp)
+ (let ((ocfp (int-sap (sb!vm:context-register
+ scp
+ #!-x86 sb!vm::ocfp-offset
+ #!+x86 sb!vm::ebx-offset)))
+ (nargs (make-lisp-obj
+ (sb!vm:context-register scp sb!vm::nargs-offset)))
+ (reg-arg-offsets '#.sb!vm::register-arg-offsets)
+ (results nil))
+ (without-gcing
+ (dotimes (arg-num nargs)
+ (push (if reg-arg-offsets
+ (make-lisp-obj
+ (sb!vm:context-register scp (pop reg-arg-offsets)))
+ (stack-ref ocfp arg-num))
+ results)))
+ (nreverse results)))
+
+;;;; MAKE-BOGUS-LRA (used for :function-end breakpoints)
+
+(defconstant
+ bogus-lra-constants
+ #!-x86 2 #!+x86 3)
+(defconstant
+ known-return-p-slot
+ (+ sb!vm:code-constants-offset #!-x86 1 #!+x86 2))
+
+;;; FIXME: This is also defined in debug-vm.lisp. Which definition
+;;; takes precedence? (One definition uses ALLOCATE-CODE-OBJECT, and
+;;; the other has been hacked for X86 GENCGC to use
+;;; ALLOCATE-DYNAMIC-CODE-OBJECT..)
+(defun make-bogus-lra (real-lra &optional known-return-p)
+ #!+sb-doc
+ "Make a bogus LRA object that signals a breakpoint trap when returned to. If
+ the breakpoint trap handler returns, REAL-LRA is returned to. Three values
+ are returned: the bogus LRA object, the code component it is part of, and
+ the PC offset for the trap instruction."
+ (without-gcing
+ (let* ((src-start (foreign-symbol-address "function_end_breakpoint_guts"))
+ (src-end (foreign-symbol-address "function_end_breakpoint_end"))
+ (trap-loc (foreign-symbol-address "function_end_breakpoint_trap"))
+ (length (sap- src-end src-start))
+ (code-object
+ (%primitive
+ #!-(and x86 gencgc) sb!c:allocate-code-object
+ #!+(and x86 gencgc) sb!c::allocate-dynamic-code-object
+ (1+ bogus-lra-constants)
+ length))
+ (dst-start (code-instructions code-object)))
+ (declare (type system-area-pointer
+ src-start src-end dst-start trap-loc)
+ (type index length))
+ (setf (%code-debug-info code-object) :bogus-lra)
+ (setf (code-header-ref code-object sb!vm:code-trace-table-offset-slot)
+ length)
+ #!-x86
+ (setf (code-header-ref code-object real-lra-slot) real-lra)
+ #!+x86
+ (multiple-value-bind (offset code) (compute-lra-data-from-pc real-lra)
+ (setf (code-header-ref code-object real-lra-slot) code)
+ (setf (code-header-ref code-object (1+ real-lra-slot)) offset))
+ (setf (code-header-ref code-object known-return-p-slot)
+ known-return-p)
+ (system-area-copy src-start 0 dst-start 0 (* length sb!vm:byte-bits))
+ (sb!vm:sanctify-for-execution code-object)
+ #!+x86
+ (values dst-start code-object (sap- trap-loc src-start))
+ #!-x86
+ (let ((new-lra (make-lisp-obj (+ (sap-int dst-start)
+ sb!vm:other-pointer-type))))
+ (set-header-data
+ new-lra
+ (logandc2 (+ sb!vm:code-constants-offset bogus-lra-constants 1)
+ 1))
+ (sb!vm:sanctify-for-execution code-object)
+ (values new-lra code-object (sap- trap-loc src-start))))))
+\f
+;;;; miscellaneous
+
+;;; This appears here because it cannot go with the debug-function
+;;; interface since DO-DEBUG-BLOCK-LOCATIONS isn't defined until after
+;;; the debug-function routines.
+
+(defun debug-function-start-location (debug-fun)
+ #!+sb-doc
+ "This returns a code-location before the body of a function and after all
+ the arguments are in place. If this cannot determine that location due to
+ a lack of debug information, it returns nil."
+ (etypecase debug-fun
+ (compiled-debug-function
+ (code-location-from-pc debug-fun
+ (sb!c::compiled-debug-function-start-pc
+ (compiled-debug-function-compiler-debug-fun
+ debug-fun))
+ nil))
+ (interpreted-debug-function
+ ;; Return the first location if there are any, otherwise NIL.
+ (handler-case (do-debug-function-blocks (block debug-fun nil)
+ (do-debug-block-locations (loc block nil)
+ (return-from debug-function-start-location loc)))
+ (no-debug-blocks (condx)
+ (declare (ignore condx))
+ nil)))))
+
+(defun print-code-locations (function)
+ (let ((debug-fun (function-debug-function function)))
+ (do-debug-function-blocks (block debug-fun)
+ (do-debug-block-locations (loc block)
+ (fill-in-code-location loc)
+ (format t "~S code location at ~D"
+ (compiled-code-location-kind loc)
+ (compiled-code-location-pc loc))
+ (sb!debug::print-code-location-source-form loc 0)
+ (terpri)))))
--- /dev/null
+;;;; variable-length encoding and other i/o tricks for the debugger
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!C")
+
+(file-comment
+ "$Header$")
+\f
+;;;; reading variable length integers
+;;;;
+;;;; The debug info representation makes extensive use of integers
+;;;; encoded in a byte vector using a variable number of bytes:
+;;;; 0..253 => the integer
+;;;; 254 => read next two bytes for integer
+;;;; 255 => read next four bytes for integer
+
+;;; Given a byte vector Vec and an index variable Index, read a variable
+;;; length integer and advance index.
+(defmacro read-var-integer (vec index)
+ (once-only ((val `(aref ,vec ,index)))
+ `(cond ((<= ,val 253)
+ (incf ,index)
+ ,val)
+ ((= ,val 254)
+ (prog1
+ (logior (aref ,vec (+ ,index 1))
+ (ash (aref ,vec (+ ,index 2)) 8))
+ (incf ,index 3)))
+ (t
+ (prog1
+ (logior (aref ,vec (+ ,index 1))
+ (ash (aref ,vec (+ ,index 2)) 8)
+ (ash (aref ,vec (+ ,index 3)) 16)
+ (ash (aref ,vec (+ ,index 4)) 24))
+ (incf ,index 5))))))
+
+;;; Takes an adjustable vector Vec with a fill pointer and pushes the
+;;; variable length representation of Int on the end.
+(defun write-var-integer (int vec)
+ (declare (type (unsigned-byte 32) int))
+ (cond ((<= int 253)
+ (vector-push-extend int vec))
+ (t
+ (let ((32-p (> int #xFFFF)))
+ (vector-push-extend (if 32-p 255 254) vec)
+ (vector-push-extend (ldb (byte 8 0) int) vec)
+ (vector-push-extend (ldb (byte 8 8) int) vec)
+ (when 32-p
+ (vector-push-extend (ldb (byte 8 16) int) vec)
+ (vector-push-extend (ldb (byte 8 24) int) vec)))))
+ (values))
+\f
+;;;; packed strings
+;;;;
+;;;; A packed string is a variable length integer length followed by the
+;;;; character codes.
+
+;;; Read a packed string from Vec starting at Index, advancing Index.
+(defmacro read-var-string (vec index)
+ (once-only ((len `(read-var-integer ,vec ,index)))
+ (once-only ((res `(make-string ,len)))
+ `(progn
+ (%primitive byte-blt ,vec ,index ,res 0 ,len)
+ (incf ,index ,len)
+ ,res))))
+
+;;; Write String into Vec (adjustable, fill-pointer) represented as the
+;;; length (in a var-length integer) followed by the codes of the characters.
+(defun write-var-string (string vec)
+ (declare (simple-string string))
+ (let ((len (length string)))
+ (write-var-integer len vec)
+ (dotimes (i len)
+ (vector-push-extend (char-code (schar string i)) vec)))
+ (values))
+\f
+;;;; packed bit vectors
+
+;;; Read the specified number of Bytes out of Vec at Index and convert them
+;;; to a bit-vector. Index is incremented.
+(defmacro read-packed-bit-vector (bytes vec index)
+ (once-only ((n-bytes bytes))
+ (once-only ((n-res `(make-array (* ,n-bytes 8) :element-type 'bit)))
+ `(progn
+ (%primitive byte-blt ,vec ,index ,n-res 0 ,n-bytes)
+ (incf ,index ,n-bytes)
+ ,n-res))))
--- /dev/null
+;;;; This is some very low-level support for debugger :FUNCTION-END
+;;;; breakpoints.
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!VM")
+
+(file-comment
+ "$Header$")
+
+(defconstant bogus-lra-constants 2)
+(defconstant real-lra-slot (+ code-constants-offset 0))
+(defconstant known-return-p-slot (+ code-constants-offset 1))
+
+(defun make-bogus-lra (real-lra &optional known-return-p)
+ #!+sb-doc
+ "Make a bogus LRA object that signals a breakpoint trap when returned to. If
+ the breakpoint trap handler returns to the fake component, the fake code
+ template returns to real-lra. This returns three values: the bogus LRA
+ object, the code component it points to, and the pc-offset for the trap
+ instruction."
+ (without-gcing
+ (let* ((src-start (truly-the system-area-pointer
+ (%primitive foreign-symbol-address
+ "function_end_breakpoint_guts")))
+ (src-end (truly-the system-area-pointer
+ (%primitive foreign-symbol-address
+ "function_end_breakpoint_end")))
+ (trap-loc (truly-the system-area-pointer
+ (%primitive foreign-symbol-address
+ "function_end_breakpoint_trap")))
+ (length (sap- src-end src-start))
+ (code-object (%primitive allocate-code-object
+ (1+ bogus-lra-constants)
+ length))
+ (dst-start (code-instructions code-object)))
+ (declare (type system-area-pointer src-start src-end dst-start trap-loc)
+ (type index length))
+ (setf (code-header-ref code-object code-debug-info-slot) nil)
+ (setf (code-header-ref code-object code-trace-table-offset-slot) length)
+ (setf (code-header-ref code-object real-lra-slot) real-lra)
+ (setf (code-header-ref code-object known-return-p-slot) known-return-p)
+ (system-area-copy src-start 0 dst-start 0 (* length byte-bits))
+ (let ((new-lra
+ (make-lisp-obj (+ (sap-int dst-start) other-pointer-type))))
+ (sb!kernel:set-header-data new-lra
+ (logandc2 (+ code-constants-offset
+ bogus-lra-constants
+ 1)
+ 1))
+ (values new-lra
+ code-object
+ (sap- trap-loc src-start))))))
--- /dev/null
+;;;; the debugger
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!DEBUG")
+
+(file-comment
+ "$Header$")
+\f
+;;;; variables and constants
+
+(defvar *debug-print-level* 3
+ #!+sb-doc
+ "*PRINT-LEVEL* for the debugger")
+
+(defvar *debug-print-length* 5
+ #!+sb-doc
+ "*PRINT-LENGTH* for the debugger")
+
+(defvar *debug-readtable*
+ ;; KLUDGE: This can't be initialized in a cold toplevel form, because the
+ ;; *STANDARD-READTABLE* isn't initialized until after cold toplevel forms
+ ;; have run. So instead we initialize it immediately after
+ ;; *STANDARD-READTABLE*. -- WHN 20000205
+ nil
+ #!+sb-doc
+ "*READTABLE* for the debugger")
+
+(defvar *in-the-debugger* nil
+ #!+sb-doc
+ "This is T while in the debugger.")
+
+(defvar *debug-command-level* 0
+ #!+sb-doc
+ "Pushes and pops/exits inside the debugger change this.")
+
+(defvar *stack-top-hint* nil
+ #!+sb-doc
+ "If this is bound before the debugger is invoked, it is used as the stack
+ top by the debugger.")
+(defvar *stack-top* nil)
+(defvar *real-stack-top* nil)
+
+(defvar *current-frame* nil)
+
+;;; the default for *DEBUG-PROMPT*
+(defun debug-prompt ()
+ (let ((*standard-output* *debug-io*))
+ (terpri)
+ (prin1 (sb!di:frame-number *current-frame*))
+ (dotimes (i *debug-command-level*) (princ "]"))
+ (princ " ")
+ (force-output)))
+
+(defparameter *debug-prompt* #'debug-prompt
+ #!+sb-doc
+ "a function of no arguments that prints the debugger prompt on *DEBUG-IO*")
+
+(defparameter *debug-help-string*
+"The prompt is right square brackets, the number indicating how many
+ recursive command loops you are in.
+Any command may be uniquely abbreviated.
+The debugger rebinds various special variables for controlling i/o,
+ sometimes to defaults (a la WITH-STANDARD-IO-SYNTAX) and sometimes to
+ its own values, e.g. SB-DEBUG:*DEBUG-PRINT-LEVEL*.
+Debug commands do not affect * and friends, but evaluation in the debug loop
+ do affect these variables.
+SB-DEBUG:*FLUSH-DEBUG-ERRORS* controls whether errors at the debug prompt
+ drop you into deeper into the debugger.
+
+Getting in and out of the debugger:
+ Q throws to top level.
+ GO calls CONTINUE which tries to proceed with the restart 'CONTINUE.
+ RESTART invokes restart numbered as shown (prompt if not given).
+ ERROR prints the error condition and restart cases.
+
+ The name of any restart, or its number, is a valid command, and is the same
+ as using RESTART to invoke that restart.
+
+Changing frames:
+ U up frame D down frame
+ T top frame B bottom frame
+ F n frame n
+
+Inspecting frames:
+ BACKTRACE [n] shows n frames going down the stack.
+ LIST-LOCALS, L lists locals in current function.
+ PRINT, P displays current function call.
+ SOURCE [n] displays frame's source form with n levels of enclosing forms.
+
+Breakpoints and steps:
+ LIST-LOCATIONS [{function | :c}] List the locations for breakpoints.
+ Specify :c for the current frame.
+ Abbreviation: LL
+ LIST-BREAKPOINTS List the active breakpoints.
+ Abbreviations: LB, LBP
+ DELETE-BREAKPOINT [n] Remove breakpoint n or all breakpoints.
+ Abbreviations: DEL, DBP
+ BREAKPOINT {n | :end | :start} [:break form] [:function function]
+ [{:print form}*] [:condition form]
+ Set a breakpoint.
+ Abbreviations: BR, BP
+ STEP [n] Step to the next location or step n times.
+
+Function and macro commands:
+ (SB-DEBUG:DEBUG-RETURN expression)
+ Exit the debugger, returning expression's values from the current frame.
+ (SB-DEBUG:ARG n)
+ Return the n'th argument in the current frame.
+ (SB-DEBUG:VAR string-or-symbol [id])
+ Returns the value of the specified variable in the current frame.")
+\f
+;;; This is used to communicate to DEBUG-LOOP that we are at a step breakpoint.
+(define-condition step-condition (simple-condition) ())
+\f
+;;;; breakpoint state
+
+(defvar *only-block-start-locations* nil
+ #!+sb-doc
+ "When true, the LIST-LOCATIONS command only displays block start locations.
+ Otherwise, all locations are displayed.")
+
+(defvar *print-location-kind* nil
+ #!+sb-doc
+ "When true, list the code location type in the LIST-LOCATIONS command.")
+
+;;; a list of the types of code-locations that should not be stepped to and
+;;; should not be listed when listing breakpoints
+(defvar *bad-code-location-types* '(:call-site :internal-error))
+(declaim (type list *bad-code-location-types*))
+
+;;; code locations of the possible breakpoints
+(defvar *possible-breakpoints*)
+(declaim (type list *possible-breakpoints*))
+
+;;; a list of the made and active breakpoints, each is a breakpoint-info
+;;; structure
+(defvar *breakpoints* nil)
+(declaim (type list *breakpoints*))
+
+;;; a list of breakpoint-info structures of the made and active step
+;;; breakpoints
+(defvar *step-breakpoints* nil)
+(declaim (type list *step-breakpoints*))
+
+;;; the number of times left to step
+(defvar *number-of-steps* 1)
+(declaim (type integer *number-of-steps*))
+
+;;; This is used when listing and setting breakpoints.
+(defvar *default-breakpoint-debug-function* nil)
+(declaim (type (or list sb!di:debug-function) *default-breakpoint-debug-function*))
+\f
+;;;; code location utilities
+
+;;; Return the first code-location in the passed debug block.
+(defun first-code-location (debug-block)
+ (let ((found nil)
+ (first-code-location nil))
+ (sb!di:do-debug-block-locations (code-location debug-block)
+ (unless found
+ (setf first-code-location code-location)
+ (setf found t)))
+ first-code-location))
+
+;;; Return a list of the next code-locations following the one passed. One of
+;;; the *BAD-CODE-LOCATION-TYPES* will not be returned.
+(defun next-code-locations (code-location)
+ (let ((debug-block (sb!di:code-location-debug-block code-location))
+ (block-code-locations nil))
+ (sb!di:do-debug-block-locations (block-code-location debug-block)
+ (unless (member (sb!di:code-location-kind block-code-location)
+ *bad-code-location-types*)
+ (push block-code-location block-code-locations)))
+ (setf block-code-locations (nreverse block-code-locations))
+ (let* ((code-loc-list (rest (member code-location block-code-locations
+ :test #'sb!di:code-location=)))
+ (next-list (cond (code-loc-list
+ (list (first code-loc-list)))
+ ((map 'list #'first-code-location
+ (sb!di:debug-block-successors debug-block)))
+ (t nil))))
+ (when (and (= (length next-list) 1)
+ (sb!di:code-location= (first next-list) code-location))
+ (setf next-list (next-code-locations (first next-list))))
+ next-list)))
+
+;;; Returns a list of code-locations of the possible breakpoints of the
+;;; debug-function passed.
+(defun possible-breakpoints (debug-function)
+ (let ((possible-breakpoints nil))
+ (sb!di:do-debug-function-blocks (debug-block debug-function)
+ (unless (sb!di:debug-block-elsewhere-p debug-block)
+ (if *only-block-start-locations*
+ (push (first-code-location debug-block) possible-breakpoints)
+ (sb!di:do-debug-block-locations (code-location debug-block)
+ (when (not (member (sb!di:code-location-kind code-location)
+ *bad-code-location-types*))
+ (push code-location possible-breakpoints))))))
+ (nreverse possible-breakpoints)))
+
+;;; Searches the info-list for the item passed (code-location, debug-function,
+;;; or breakpoint-info). If the item passed is a debug function then kind will
+;;; be compared if it was specified. The kind if also compared if a
+;;; breakpoint-info is passed since it's in the breakpoint. The info structure
+;;; is returned if found.
+(defun location-in-list (place info-list &optional (kind nil))
+ (when (breakpoint-info-p place)
+ (setf kind (sb!di:breakpoint-kind (breakpoint-info-breakpoint place)))
+ (setf place (breakpoint-info-place place)))
+ (cond ((sb!di:code-location-p place)
+ (find place info-list
+ :key #'breakpoint-info-place
+ :test #'(lambda (x y) (and (sb!di:code-location-p y)
+ (sb!di:code-location= x y)))))
+ (t
+ (find place info-list
+ :test #'(lambda (x-debug-function y-info)
+ (let ((y-place (breakpoint-info-place y-info))
+ (y-breakpoint (breakpoint-info-breakpoint
+ y-info)))
+ (and (sb!di:debug-function-p y-place)
+ (eq x-debug-function y-place)
+ (or (not kind)
+ (eq kind (sb!di:breakpoint-kind
+ y-breakpoint))))))))))
+
+;;; If Loc is an unknown location, then try to find the block start location.
+;;; Used by source printing to some information instead of none for the user.
+(defun maybe-block-start-location (loc)
+ (if (sb!di:code-location-unknown-p loc)
+ (let* ((block (sb!di:code-location-debug-block loc))
+ (start (sb!di:do-debug-block-locations (loc block)
+ (return loc))))
+ (cond ((and (not (sb!di:debug-block-elsewhere-p block))
+ start)
+ ;; FIXME: Why output on T instead of *DEBUG-FOO* or something?
+ (format t "~%unknown location: using block start~%")
+ start)
+ (t
+ loc)))
+ loc))
+\f
+;;;; the BREAKPOINT-INFO structure
+
+;;; info about a made breakpoint
+(defstruct breakpoint-info
+ ;; where we are going to stop
+ (place (required-argument)
+ :type (or sb!di:code-location sb!di:debug-function))
+ ;; the breakpoint returned by sb!di:make-breakpoint
+ (breakpoint (required-argument) :type sb!di:breakpoint)
+ ;; the function returned from sb!di:preprocess-for-eval. If result is
+ ;; non-NIL, drop into the debugger.
+ (break #'identity :type function)
+ ;; the function returned from sb!di:preprocess-for-eval. If result is
+ ;; non-NIL, eval (each) print and print results.
+ (condition #'identity :type function)
+ ;; the list of functions from sb!di:preprocess-for-eval to evaluate. Results
+ ;; are conditionally printed. Car of each element is the function, cdr is the
+ ;; form it goes with.
+ (print nil :type list)
+ ;; the number used when listing the possible breakpoints within a function.
+ ;; Could also be a symbol such as start or end.
+ (code-location-number (required-argument) :type (or symbol integer))
+ ;; the number used when listing the breakpoints active and to delete
+ ;; breakpoints
+ (breakpoint-number (required-argument) :type integer))
+
+;;; Return a new BREAKPOINT-INFO structure with the info passed.
+(defun create-breakpoint-info (place breakpoint code-location-number
+ &key (break #'identity)
+ (condition #'identity) (print nil))
+ (setf *breakpoints*
+ (sort *breakpoints* #'< :key #'breakpoint-info-breakpoint-number))
+ (let ((breakpoint-number
+ (do ((i 1 (incf i)) (breakpoints *breakpoints* (rest breakpoints)))
+ ((or (> i (length *breakpoints*))
+ (not (= i (breakpoint-info-breakpoint-number
+ (first breakpoints)))))
+
+ i))))
+ (make-breakpoint-info :place place :breakpoint breakpoint
+ :code-location-number code-location-number
+ :breakpoint-number breakpoint-number
+ :break break :condition condition :print print)))
+
+;;; Print the breakpoint info for the breakpoint-info structure passed.
+(defun print-breakpoint-info (breakpoint-info)
+ (let ((place (breakpoint-info-place breakpoint-info))
+ (bp-number (breakpoint-info-breakpoint-number breakpoint-info))
+ (loc-number (breakpoint-info-code-location-number breakpoint-info)))
+ (case (sb!di:breakpoint-kind (breakpoint-info-breakpoint breakpoint-info))
+ (:code-location
+ (print-code-location-source-form place 0)
+ (format t
+ "~&~S: ~S in ~S"
+ bp-number
+ loc-number
+ (sb!di:debug-function-name (sb!di:code-location-debug-function
+ place))))
+ (:function-start
+ (format t "~&~S: FUNCTION-START in ~S" bp-number
+ (sb!di:debug-function-name place)))
+ (:function-end
+ (format t "~&~S: FUNCTION-END in ~S" bp-number
+ (sb!di:debug-function-name place))))))
+\f
+;;;; MAIN-HOOK-FUNCTION for steps and breakpoints
+
+;;; This must be passed as the hook function. It keeps track of where step
+;;; breakpoints are.
+(defun main-hook-function (current-frame breakpoint &optional return-vals
+ function-end-cookie)
+ (setf *default-breakpoint-debug-function*
+ (sb!di:frame-debug-function current-frame))
+ (dolist (step-info *step-breakpoints*)
+ (sb!di:delete-breakpoint (breakpoint-info-breakpoint step-info))
+ (let ((bp-info (location-in-list step-info *breakpoints*)))
+ (when bp-info
+ (sb!di:activate-breakpoint (breakpoint-info-breakpoint bp-info)))))
+ (let ((*stack-top-hint* current-frame)
+ (step-hit-info
+ (location-in-list (sb!di:breakpoint-what breakpoint)
+ *step-breakpoints*
+ (sb!di:breakpoint-kind breakpoint)))
+ (bp-hit-info
+ (location-in-list (sb!di:breakpoint-what breakpoint)
+ *breakpoints*
+ (sb!di:breakpoint-kind breakpoint)))
+ (break)
+ (condition)
+ (string ""))
+ (setf *step-breakpoints* nil)
+ (labels ((build-string (str)
+ (setf string (concatenate 'string string str)))
+ (print-common-info ()
+ (build-string
+ (with-output-to-string (*standard-output*)
+ (when function-end-cookie
+ (format t "~%Return values: ~S" return-vals))
+ (when condition
+ (when (breakpoint-info-print bp-hit-info)
+ (format t "~%")
+ (print-frame-call current-frame))
+ (dolist (print (breakpoint-info-print bp-hit-info))
+ (format t "~& ~S = ~S" (rest print)
+ (funcall (first print) current-frame))))))))
+ (when bp-hit-info
+ (setf break (funcall (breakpoint-info-break bp-hit-info)
+ current-frame))
+ (setf condition (funcall (breakpoint-info-condition bp-hit-info)
+ current-frame)))
+ (cond ((and bp-hit-info step-hit-info (= 1 *number-of-steps*))
+ (build-string (format nil "~&*Step (to a breakpoint)*"))
+ (print-common-info)
+ (break string))
+ ((and bp-hit-info step-hit-info break)
+ (build-string (format nil "~&*Step (to a breakpoint)*"))
+ (print-common-info)
+ (break string))
+ ((and bp-hit-info step-hit-info)
+ (print-common-info)
+ (format t "~A" string)
+ (decf *number-of-steps*)
+ (set-step-breakpoint current-frame))
+ ((and step-hit-info (= 1 *number-of-steps*))
+ (build-string "*Step*")
+ (break (make-condition 'step-condition :format-control string)))
+ (step-hit-info
+ (decf *number-of-steps*)
+ (set-step-breakpoint current-frame))
+ (bp-hit-info
+ (when break
+ (build-string (format nil "~&*Breakpoint hit*")))
+ (print-common-info)
+ (if break
+ (break string)
+ (format t "~A" string)))
+ (t
+ (break "error in main-hook-function: unknown breakpoint"))))))
+\f
+;;; Set breakpoints at the next possible code-locations. After calling
+;;; this, either (CONTINUE) if in the debugger or just let program flow
+;;; return if in a hook function.
+(defun set-step-breakpoint (frame)
+ (cond
+ ((sb!di:debug-block-elsewhere-p (sb!di:code-location-debug-block
+ (sb!di:frame-code-location frame)))
+ ;; FIXME: FORMAT T is used for error output here and elsewhere in
+ ;; the debug code.
+ (format t "cannot step, in elsewhere code~%"))
+ (t
+ (let* ((code-location (sb!di:frame-code-location frame))
+ (next-code-locations (next-code-locations code-location)))
+ (cond
+ (next-code-locations
+ (dolist (code-location next-code-locations)
+ (let ((bp-info (location-in-list code-location *breakpoints*)))
+ (when bp-info
+ (sb!di:deactivate-breakpoint (breakpoint-info-breakpoint
+ bp-info))))
+ (let ((bp (sb!di:make-breakpoint #'main-hook-function code-location
+ :kind :code-location)))
+ (sb!di:activate-breakpoint bp)
+ (push (create-breakpoint-info code-location bp 0)
+ *step-breakpoints*))))
+ (t
+ (let* ((debug-function (sb!di:frame-debug-function *current-frame*))
+ (bp (sb!di:make-breakpoint #'main-hook-function debug-function
+ :kind :function-end)))
+ (sb!di:activate-breakpoint bp)
+ (push (create-breakpoint-info debug-function bp 0)
+ *step-breakpoints*))))))))
+\f
+;;;; STEP
+
+;;; ANSI specifies that this macro shall exist, even if only as a
+;;; trivial placeholder like this.
+(defmacro step (form)
+ "a trivial placeholder implementation of the CL:STEP macro required by
+ the ANSI spec"
+ `(progn
+ ,form))
+\f
+;;;; BACKTRACE
+
+(defun backtrace (&optional (count most-positive-fixnum)
+ (*standard-output* *debug-io*))
+ #!+sb-doc
+ "Show a listing of the call stack going down from the current frame. In the
+ debugger, the current frame is indicated by the prompt. Count is how many
+ frames to show."
+ (fresh-line *standard-output*)
+ (do ((frame (if *in-the-debugger* *current-frame* (sb!di:top-frame))
+ (sb!di:frame-down frame))
+ (count count (1- count)))
+ ((or (null frame) (zerop count)))
+ (print-frame-call frame :number t))
+ (fresh-line *standard-output*)
+ (values))
+\f
+;;;; frame printing
+
+(eval-when (:compile-toplevel :execute)
+
+;;; This is a convenient way to express what to do for each type of lambda-list
+;;; element.
+(sb!xc:defmacro lambda-list-element-dispatch (element
+ &key
+ required
+ optional
+ rest
+ keyword
+ deleted)
+ `(etypecase ,element
+ (sb!di:debug-var
+ ,@required)
+ (cons
+ (ecase (car ,element)
+ (:optional ,@optional)
+ (:rest ,@rest)
+ (:keyword ,@keyword)))
+ (symbol
+ (assert (eq ,element :deleted))
+ ,@deleted)))
+
+(sb!xc:defmacro lambda-var-dispatch (variable location deleted valid other)
+ (let ((var (gensym)))
+ `(let ((,var ,variable))
+ (cond ((eq ,var :deleted) ,deleted)
+ ((eq (sb!di:debug-var-validity ,var ,location) :valid)
+ ,valid)
+ (t ,other)))))
+
+) ; EVAL-WHEN
+
+;;; This is used in constructing arg lists for debugger printing when
+;;; the arg list is unavailable, some arg is unavailable or unused,
+;;; etc.
+(defstruct (unprintable-object
+ (:constructor make-unprintable-object (string))
+ (:print-object (lambda (x s)
+ (print-unreadable-object (x s :type t)
+ (write-string (unprintable-object-string x)
+ s)))))
+ string)
+
+;;; Print frame with verbosity level 1. If we hit a rest-arg, then
+;;; print as many of the values as possible, punting the loop over
+;;; lambda-list variables since any other arguments will be in the
+;;; rest-arg's list of values.
+(defun print-frame-call-1 (frame)
+ (let* ((d-fun (sb!di:frame-debug-function frame))
+ (loc (sb!di:frame-code-location frame))
+ (results (list (sb!di:debug-function-name d-fun))))
+ (handler-case
+ (dolist (ele (sb!di:debug-function-lambda-list d-fun))
+ (lambda-list-element-dispatch ele
+ :required ((push (frame-call-arg ele loc frame) results))
+ :optional ((push (frame-call-arg (second ele) loc frame) results))
+ :keyword ((push (second ele) results)
+ (push (frame-call-arg (third ele) loc frame) results))
+ :deleted ((push (frame-call-arg ele loc frame) results))
+ :rest ((lambda-var-dispatch (second ele) loc
+ nil
+ (progn
+ (setf results
+ (append (reverse (sb!di:debug-var-value
+ (second ele) frame))
+ results))
+ (return))
+ (push (make-unprintable-object "unavailable &REST arg")
+ results)))))
+ (sb!di:lambda-list-unavailable
+ ()
+ (push (make-unprintable-object "lambda list unavailable") results)))
+ (prin1 (mapcar #'ensure-printable-object (nreverse results)))
+ (when (sb!di:debug-function-kind d-fun)
+ (write-char #\[)
+ (prin1 (sb!di:debug-function-kind d-fun))
+ (write-char #\]))))
+
+(defun ensure-printable-object (object)
+ (handler-case
+ (with-open-stream (out (make-broadcast-stream))
+ (prin1 object out)
+ object)
+ (error (cond)
+ (declare (ignore cond))
+ (make-unprintable-object "error printing object"))))
+
+(defun frame-call-arg (var location frame)
+ (lambda-var-dispatch var location
+ (make-unprintable-object "unused arg")
+ (sb!di:debug-var-value var frame)
+ (make-unprintable-object "unavailable arg")))
+
+;;; Prints a representation of the function call causing frame to
+;;; exist. Verbosity indicates the level of information to output;
+;;; zero indicates just printing the debug-function's name, and one
+;;; indicates displaying call-like, one-liner format with argument
+;;; values.
+(defun print-frame-call (frame &key (verbosity 1) (number nil))
+ (cond
+ ((zerop verbosity)
+ (when number
+ (format t "~&~S: " (sb!di:frame-number frame)))
+ (format t "~S" frame))
+ (t
+ (when number
+ (format t "~&~S: " (sb!di:frame-number frame)))
+ (print-frame-call-1 frame)))
+ (when (>= verbosity 2)
+ (let ((loc (sb!di:frame-code-location frame)))
+ (handler-case
+ (progn
+ (sb!di:code-location-debug-block loc)
+ (format t "~%source: ")
+ (print-code-location-source-form loc 0))
+ (sb!di:debug-condition (ignore) ignore)
+ (error (c) (format t "error finding source: ~A" c))))))
+\f
+;;;; INVOKE-DEBUGGER
+
+(defvar *debugger-hook* nil
+ #!+sb-doc
+ "This is either NIL or a function of two arguments, a condition and the value
+ of *DEBUGGER-HOOK*. This function can either handle the condition or return
+ which causes the standard debugger to execute. The system passes the value
+ of this variable to the function because it binds *DEBUGGER-HOOK* to NIL
+ around the invocation.")
+
+;;; These are bound on each invocation of INVOKE-DEBUGGER.
+(defvar *debug-restarts*)
+(defvar *debug-condition*)
+
+(defun invoke-debugger (condition)
+ #!+sb-doc
+ "Enter the debugger."
+ (let ((old-hook *debugger-hook*))
+ (when old-hook
+ (let ((*debugger-hook* nil))
+ (funcall hook condition hook))))
+ (sb!unix:unix-sigsetmask 0)
+ (let ((original-package *package*)) ; protect it from WITH-STANDARD-IO-SYNTAX
+ (with-standard-io-syntax
+ (let* ((*debug-condition* condition)
+ (*debug-restarts* (compute-restarts condition))
+ ;; FIXME: The next two bindings seem flaky, violating the
+ ;; principle of least surprise. But in order to fix them, we'd
+ ;; need to go through all the i/o statements in the debugger,
+ ;; since a lot of them do their thing on *STANDARD-INPUT* and
+ ;; *STANDARD-OUTPUT* instead of *DEBUG-IO*.
+ (*standard-input* *debug-io*) ; in case of setq
+ (*standard-output* *debug-io*) ; '' '' '' ''
+ ;; We also want to set the i/o subsystem into a known, useful
+ ;; state, regardless of where in the debugger was invoked in the
+ ;; program. WITH-STANDARD-IO-SYNTAX does some of that, but
+ ;; 1. It doesn't affect our internal special variables like
+ ;; *CURRENT-LEVEL*.
+ ;; 2. It isn't customizable.
+ ;; 3. It doesn't set *PRINT-READABLY* or *PRINT-PRETTY* to the
+ ;; same value as the toplevel default.
+ ;; 4. It sets *PACKAGE* to COMMON-LISP-USER, which is not
+ ;; helpful behavior for a debugger.
+ ;; We try to remedy all these problems with explicit rebindings
+ ;; here.
+ (sb!kernel:*current-level* 0)
+ (*print-length* *debug-print-length*)
+ (*print-level* *debug-print-level*)
+ (*readtable* *debug-readtable*)
+ (*print-readably* nil)
+ (*print-pretty* t)
+ (*package* original-package))
+ (format *error-output*
+ "~2&debugger invoked on ~S of type ~S:~% ~A~%"
+ '*debug-condition*
+ (type-of *debug-condition*)
+ *debug-condition*)
+ (let (;; FIXME: like the bindings of *STANDARD-INPUT* and
+ ;; *STANDARD-OUTPUT* above..
+ (*error-output* *debug-io*))
+ (unless (typep condition 'step-condition)
+ (show-restarts *debug-restarts* *error-output*))
+ (internal-debug))))))
+
+(defun show-restarts (restarts &optional (s *error-output*))
+ (when restarts
+ (format s "~&restarts:~%")
+ (let ((count 0)
+ (names-used '(nil))
+ (max-name-len 0))
+ (dolist (restart restarts)
+ (let ((name (restart-name restart)))
+ (when name
+ (let ((len (length (princ-to-string name))))
+ (when (> len max-name-len)
+ (setf max-name-len len))))))
+ (unless (zerop max-name-len)
+ (incf max-name-len 3))
+ (dolist (restart restarts)
+ (let ((name (restart-name restart)))
+ (cond ((member name names-used)
+ (format s "~& ~2D: ~@VT~A~%" count max-name-len restart))
+ (t
+ (format s "~& ~2D: [~VA] ~A~%"
+ count (- max-name-len 3) name restart)
+ (push name names-used))))
+ (incf count)))))
+
+;;; This calls DEBUG-LOOP, performing some simple initializations before doing
+;;; so. INVOKE-DEBUGGER calls this to actually get into the debugger.
+;;; SB!CONDITIONS::ERROR-ERROR calls this in emergencies to get into a debug
+;;; prompt as quickly as possible with as little risk as possible for stepping
+;;; on whatever is causing recursive errors.
+(defun internal-debug ()
+ (let ((*in-the-debugger* t)
+ (*read-suppress* nil))
+ (unless (typep *debug-condition* 'step-condition)
+ (clear-input *debug-io*)
+ (format *debug-io*
+ "~&Within the debugger, you can type HELP for help.~%"))
+ #!-mp (debug-loop)
+ #!+mp (sb!mp:without-scheduling (debug-loop))))
+\f
+;;;; DEBUG-LOOP
+
+;;; Note: This defaulted to T in CMU CL. The changed default in SBCL
+;;; was motivated by desire to play nicely with ILISP.
+(defvar *flush-debug-errors* nil
+ #!+sb-doc
+ "When set, avoid calling INVOKE-DEBUGGER recursively when errors occur while
+ executing in the debugger.")
+
+(defun debug-loop ()
+ (let* ((*debug-command-level* (1+ *debug-command-level*))
+ (*real-stack-top* (sb!di:top-frame))
+ (*stack-top* (or *stack-top-hint* *real-stack-top*))
+ (*stack-top-hint* nil)
+ (*current-frame* *stack-top*))
+ (handler-bind ((sb!di:debug-condition (lambda (condition)
+ (princ condition *debug-io*)
+ (throw 'debug-loop-catcher nil))))
+ (fresh-line)
+ (print-frame-call *current-frame* :verbosity 2)
+ (loop
+ (catch 'debug-loop-catcher
+ (handler-bind ((error #'(lambda (condition)
+ (when *flush-debug-errors*
+ (clear-input *debug-io*)
+ (princ condition)
+ ;; FIXME: Doing input on *DEBUG-IO*
+ ;; and output on T seems broken.
+ (format t
+ "~&error flushed (because ~
+ ~S is set)"
+ '*flush-debug-errors*)
+ (throw 'debug-loop-catcher nil)))))
+ ;; We have to bind level for the restart function created by
+ ;; WITH-SIMPLE-RESTART.
+ (let ((level *debug-command-level*)
+ (restart-commands (make-restart-commands)))
+ (with-simple-restart (abort "Return to debug level ~D." level)
+ (funcall *debug-prompt*)
+ (let ((input (sb!int:get-stream-command *debug-io*)))
+ (cond (input
+ (let ((cmd-fun (debug-command-p
+ (sb!int:stream-command-name input)
+ restart-commands)))
+ (cond
+ ((not cmd-fun)
+ (error "unknown stream-command: ~S" input))
+ ((consp cmd-fun)
+ (error "ambiguous debugger command: ~S" cmd-fun))
+ (t
+ (apply cmd-fun
+ (sb!int:stream-command-args input))))))
+ (t
+ (let* ((exp (read))
+ (cmd-fun (debug-command-p exp
+ restart-commands)))
+ (cond ((not cmd-fun)
+ (debug-eval-print exp))
+ ((consp cmd-fun)
+ (format t
+ "~&Your command, ~S, is ambiguous:~%"
+ exp)
+ (dolist (ele cmd-fun)
+ (format t " ~A~%" ele)))
+ (t
+ (funcall cmd-fun)))))))))))))))
+
+(defvar *auto-eval-in-frame* t
+ #!+sb-doc
+ "When set (the default), evaluations in the debugger's command loop occur
+ relative to the current frame's environment without the need of debugger
+ forms that explicitly control this kind of evaluation.")
+
+;;; FIXME: We could probably use INTERACTIVE-EVAL for much of this logic.
+(defun debug-eval-print (exp)
+ (setq +++ ++ ++ + + - - exp)
+ (let* ((values (multiple-value-list
+ (if (and (fboundp 'compile) *auto-eval-in-frame*)
+ (sb!di:eval-in-frame *current-frame* -)
+ (eval -))))
+ (*standard-output* *debug-io*))
+ (fresh-line)
+ (if values (prin1 (car values)))
+ (dolist (x (cdr values))
+ (fresh-line)
+ (prin1 x))
+ (setq /// // // / / values)
+ (setq *** ** ** * * (car values))
+ ;; Make sure that nobody passes back an unbound marker.
+ (unless (boundp '*)
+ (setq * nil)
+ (fresh-line)
+ ;; FIXME: Perhaps this shouldn't be WARN (for fear of complicating
+ ;; the debugging situation?) but at least it should go to *ERROR-OUTPUT*.
+ ;; (And probably it should just be WARN.)
+ (princ "Setting * to NIL (was unbound marker)."))))
+\f
+;;;; debug loop functions
+
+;;; These commands are functions, not really commands, so that users can get
+;;; their hands on the values returned.
+
+(eval-when (:execute :compile-toplevel)
+
+(sb!xc:defmacro define-var-operation (ref-or-set &optional value-var)
+ `(let* ((temp (etypecase name
+ (symbol (sb!di:debug-function-symbol-variables
+ (sb!di:frame-debug-function *current-frame*)
+ name))
+ (simple-string (sb!di:ambiguous-debug-vars
+ (sb!di:frame-debug-function *current-frame*)
+ name))))
+ (location (sb!di:frame-code-location *current-frame*))
+ ;; Let's only deal with valid variables.
+ (vars (remove-if-not #'(lambda (v)
+ (eq (sb!di:debug-var-validity v location)
+ :valid))
+ temp)))
+ (declare (list vars))
+ (cond ((null vars)
+ (error "No known valid variables match ~S." name))
+ ((= (length vars) 1)
+ ,(ecase ref-or-set
+ (:ref
+ '(sb!di:debug-var-value (car vars) *current-frame*))
+ (:set
+ `(setf (sb!di:debug-var-value (car vars) *current-frame*)
+ ,value-var))))
+ (t
+ ;; Since we have more than one, first see whether we have any
+ ;; variables that exactly match the specification.
+ (let* ((name (etypecase name
+ (symbol (symbol-name name))
+ (simple-string name)))
+ ;; FIXME: REMOVE-IF-NOT is deprecated, use STRING/=
+ ;; instead.
+ (exact (remove-if-not (lambda (v)
+ (string= (sb!di:debug-var-symbol-name v)
+ name))
+ vars))
+ (vars (or exact vars)))
+ (declare (simple-string name)
+ (list exact vars))
+ (cond
+ ;; Check now for only having one variable.
+ ((= (length vars) 1)
+ ,(ecase ref-or-set
+ (:ref
+ '(sb!di:debug-var-value (car vars) *current-frame*))
+ (:set
+ `(setf (sb!di:debug-var-value (car vars) *current-frame*)
+ ,value-var))))
+ ;; If there weren't any exact matches, flame about ambiguity
+ ;; unless all the variables have the same name.
+ ((and (not exact)
+ (find-if-not
+ #'(lambda (v)
+ (string= (sb!di:debug-var-symbol-name v)
+ (sb!di:debug-var-symbol-name (car vars))))
+ (cdr vars)))
+ (error "specification ambiguous:~%~{ ~A~%~}"
+ (mapcar #'sb!di:debug-var-symbol-name
+ (delete-duplicates
+ vars :test #'string=
+ :key #'sb!di:debug-var-symbol-name))))
+ ;; All names are the same, so see whether the user ID'ed one of
+ ;; them.
+ (id-supplied
+ (let ((v (find id vars :key #'sb!di:debug-var-id)))
+ (unless v
+ (error
+ "invalid variable ID, ~D: should have been one of ~S"
+ id
+ (mapcar #'sb!di:debug-var-id vars)))
+ ,(ecase ref-or-set
+ (:ref
+ '(sb!di:debug-var-value v *current-frame*))
+ (:set
+ `(setf (sb!di:debug-var-value v *current-frame*)
+ ,value-var)))))
+ (t
+ (error "Specify variable ID to disambiguate ~S. Use one of ~S."
+ name
+ (mapcar #'sb!di:debug-var-id vars)))))))))
+
+) ; EVAL-WHEN
+
+(defun var (name &optional (id 0 id-supplied))
+ #!+sb-doc
+ "Returns a variable's value if possible. Name is a simple-string or symbol.
+ If it is a simple-string, it is an initial substring of the variable's name.
+ If name is a symbol, it has the same name and package as the variable whose
+ value this function returns. If the symbol is uninterned, then the variable
+ has the same name as the symbol, but it has no package.
+
+ If name is the initial substring of variables with different names, then
+ this return no values after displaying the ambiguous names. If name
+ determines multiple variables with the same name, then you must use the
+ optional id argument to specify which one you want. If you left id
+ unspecified, then this returns no values after displaying the distinguishing
+ id values.
+
+ The result of this function is limited to the availability of variable
+ information. This is SETF'able."
+ (define-var-operation :ref))
+(defun (setf var) (value name &optional (id 0 id-supplied))
+ (define-var-operation :set value))
+
+;;; This returns the COUNT'th arg as the user sees it from args, the result of
+;;; SB!DI:DEBUG-FUNCTION-LAMBDA-LIST. If this returns a potential
+;;; DEBUG-VAR from the lambda-list, then the second value is T. If this
+;;; returns a keyword symbol or a value from a rest arg, then the second value
+;;; is NIL.
+(declaim (ftype (function (index list)) nth-arg))
+(defun nth-arg (count args)
+ (let ((n count))
+ (dolist (ele args (error "The argument specification ~S is out of range."
+ n))
+ (lambda-list-element-dispatch ele
+ :required ((if (zerop n) (return (values ele t))))
+ :optional ((if (zerop n) (return (values (second ele) t))))
+ :keyword ((cond ((zerop n)
+ (return (values (second ele) nil)))
+ ((zerop (decf n))
+ (return (values (third ele) t)))))
+ :deleted ((if (zerop n) (return (values ele t))))
+ :rest ((let ((var (second ele)))
+ (lambda-var-dispatch var (sb!di:frame-code-location
+ *current-frame*)
+ (error "unused REST-arg before n'th argument")
+ (dolist (value
+ (sb!di:debug-var-value var *current-frame*)
+ (error
+ "The argument specification ~S is out of range."
+ n))
+ (if (zerop n)
+ (return-from nth-arg (values value nil))
+ (decf n)))
+ (error "invalid REST-arg before n'th argument")))))
+ (decf n))))
+
+(defun arg (n)
+ #!+sb-doc
+ "Returns the N'th argument's value if possible. Argument zero is the first
+ argument in a frame's default printed representation. Count keyword/value
+ pairs as separate arguments."
+ (multiple-value-bind (var lambda-var-p)
+ (nth-arg n (handler-case (sb!di:debug-function-lambda-list
+ (sb!di:frame-debug-function *current-frame*))
+ (sb!di:lambda-list-unavailable ()
+ (error "No argument values are available."))))
+ (if lambda-var-p
+ (lambda-var-dispatch var (sb!di:frame-code-location *current-frame*)
+ (error "Unused arguments have no values.")
+ (sb!di:debug-var-value var *current-frame*)
+ (error "invalid argument value"))
+ var)))
+\f
+;;;; machinery for definition of debug loop commands
+
+(defvar *debug-commands* nil)
+
+;;; Interface to *DEBUG-COMMANDS*. No required arguments in args are
+;;; permitted.
+;;;
+;;; FIXME: This is not needed in the target Lisp system.
+(defmacro def-debug-command (name args &rest body)
+ (let ((fun-name (intern (concatenate 'simple-string name "-DEBUG-COMMAND"))))
+ `(progn
+ (setf *debug-commands*
+ (remove ,name *debug-commands* :key #'car :test #'string=))
+ (defun ,fun-name ,args
+ (unless *in-the-debugger*
+ (error "invoking debugger command while outside the debugger"))
+ ,@body)
+ (push (cons ,name #',fun-name) *debug-commands*)
+ ',fun-name)))
+
+(defun def-debug-command-alias (new-name existing-name)
+ (let ((pair (assoc existing-name *debug-commands* :test #'string=)))
+ (unless pair (error "unknown debug command name: ~S" existing-name))
+ (push (cons new-name (cdr pair)) *debug-commands*))
+ new-name)
+
+;;; This takes a symbol and uses its name to find a debugger command, using
+;;; initial substring matching. It returns the command function if form
+;;; identifies only one command, but if form is ambiguous, this returns a list
+;;; of the command names. If there are no matches, this returns nil. Whenever
+;;; the loop that looks for a set of possibilities encounters an exact name
+;;; match, we return that command function immediately.
+(defun debug-command-p (form &optional other-commands)
+ (if (or (symbolp form) (integerp form))
+ (let* ((name
+ (if (symbolp form)
+ (symbol-name form)
+ (format nil "~D" form)))
+ (len (length name))
+ (res nil))
+ (declare (simple-string name)
+ (fixnum len)
+ (list res))
+
+ ;; Find matching commands, punting if exact match.
+ (flet ((match-command (ele)
+ (let* ((str (car ele))
+ (str-len (length str)))
+ (declare (simple-string str)
+ (fixnum str-len))
+ (cond ((< str-len len))
+ ((= str-len len)
+ (when (string= name str :end1 len :end2 len)
+ (return-from debug-command-p (cdr ele))))
+ ((string= name str :end1 len :end2 len)
+ (push ele res))))))
+ (mapc #'match-command *debug-commands*)
+ (mapc #'match-command other-commands))
+
+ ;; Return the right value.
+ (cond ((not res) nil)
+ ((= (length res) 1)
+ (cdar res))
+ (t ; Just return the names.
+ (do ((cmds res (cdr cmds)))
+ ((not cmds) res)
+ (setf (car cmds) (caar cmds))))))))
+
+;;; Returns a list of debug commands (in the same format as *debug-commands*)
+;;; that invoke each active restart.
+;;;
+;;; Two commands are made for each restart: one for the number, and one for
+;;; the restart name (unless it's been shadowed by an earlier restart of the
+;;; same name).
+(defun make-restart-commands (&optional (restarts *debug-restarts*))
+ (let ((commands)
+ (num 0)) ; better be the same as show-restarts!
+ (dolist (restart restarts)
+ (let ((name (string (restart-name restart))))
+ (unless (find name commands :key #'car :test #'string=)
+ (let ((restart-fun
+ #'(lambda ()
+ (invoke-restart-interactively restart))))
+ (push (cons name restart-fun) commands)
+ (push (cons (format nil "~D" num) restart-fun) commands))))
+ (incf num))
+ commands))
+\f
+;;;; frame-changing commands
+
+(def-debug-command "UP" ()
+ (let ((next (sb!di:frame-up *current-frame*)))
+ (cond (next
+ (setf *current-frame* next)
+ (print-frame-call next))
+ (t
+ (format t "~&Top of stack.")))))
+
+(def-debug-command "DOWN" ()
+ (let ((next (sb!di:frame-down *current-frame*)))
+ (cond (next
+ (setf *current-frame* next)
+ (print-frame-call next))
+ (t
+ (format t "~&Bottom of stack.")))))
+
+(def-debug-command-alias "D" "DOWN")
+
+(def-debug-command "TOP" ()
+ (do ((prev *current-frame* lead)
+ (lead (sb!di:frame-up *current-frame*) (sb!di:frame-up lead)))
+ ((null lead)
+ (setf *current-frame* prev)
+ (print-frame-call prev))))
+
+(def-debug-command "BOTTOM" ()
+ (do ((prev *current-frame* lead)
+ (lead (sb!di:frame-down *current-frame*) (sb!di:frame-down lead)))
+ ((null lead)
+ (setf *current-frame* prev)
+ (print-frame-call prev))))
+
+(def-debug-command-alias "B" "BOTTOM")
+
+(def-debug-command "FRAME" (&optional
+ (n (read-prompting-maybe "frame number: ")))
+ (setf *current-frame*
+ (multiple-value-bind (next-frame-fun limit-string)
+ (if (< n (sb!di:frame-number *current-frame*))
+ (values #'sb!di:frame-up "top")
+ (values #'sb!di:frame-down "bottom"))
+ (do ((frame *current-frame*))
+ ((= n (sb!di:frame-number frame))
+ frame)
+ (let ((next-frame (funcall next-frame-fun frame)))
+ (cond (next-frame
+ (setf frame next-frame))
+ (t
+ (format t
+ "The ~A of the stack was encountered.~%"
+ limit-string)
+ (return frame)))))))
+ (print-frame-call *current-frame*))
+
+(def-debug-command-alias "F" "FRAME")
+\f
+;;;; commands for entering and leaving the debugger
+
+(def-debug-command "QUIT" ()
+ (throw 'sb!impl::top-level-catcher nil))
+
+(def-debug-command "GO" ()
+ (continue *debug-condition*)
+ (error "There is no restart named CONTINUE."))
+
+(def-debug-command "RESTART" ()
+ (let ((num (read-if-available :prompt)))
+ (when (eq num :prompt)
+ (show-restarts *debug-restarts*)
+ (write-string "restart: ")
+ (force-output)
+ (setf num (read *standard-input*)))
+ (let ((restart (typecase num
+ (unsigned-byte
+ (nth num *debug-restarts*))
+ (symbol
+ (find num *debug-restarts* :key #'restart-name
+ :test #'(lambda (sym1 sym2)
+ (string= (symbol-name sym1)
+ (symbol-name sym2)))))
+ (t
+ (format t "~S is invalid as a restart name.~%" num)
+ (return-from restart-debug-command nil)))))
+ (if restart
+ (invoke-restart-interactively restart)
+ ;; FIXME: Even if this isn't handled by WARN, it probably
+ ;; shouldn't go to *STANDARD-OUTPUT*, but *ERROR-OUTPUT* or
+ ;; *QUERY-IO* or something. Look through this file to
+ ;; straighten out stream usage.
+ (princ "There is no such restart.")))))
+\f
+;;;; information commands
+
+(def-debug-command "HELP" ()
+ ;; CMU CL had a little toy pager here, but "if you aren't running
+ ;; ILISP (or a smart windowing system, or something) you deserve to
+ ;; lose", so we've dropped it in SBCL. However, in case some
+ ;; desperate holdout is running this on a dumb terminal somewhere,
+ ;; we tell him where to find the message stored as a string.
+ (format *debug-io*
+ "~&~a~2%(The HELP string is stored in ~S.)~%"
+ *debug-help-string*
+ '*debug-help-string*))
+
+(def-debug-command-alias "?" "HELP")
+
+(def-debug-command "ERROR" ()
+ (format t "~A~%" *debug-condition*)
+ (show-restarts *debug-restarts*))
+
+(def-debug-command "BACKTRACE" ()
+ (backtrace (read-if-available most-positive-fixnum)))
+
+(def-debug-command "PRINT" ()
+ (print-frame-call *current-frame*))
+
+(def-debug-command-alias "P" "PRINT")
+
+(def-debug-command "LIST-LOCALS" ()
+ (let ((d-fun (sb!di:frame-debug-function *current-frame*)))
+ (if (sb!di:debug-var-info-available d-fun)
+ (let ((*standard-output* *debug-io*)
+ (location (sb!di:frame-code-location *current-frame*))
+ (prefix (read-if-available nil))
+ (any-p nil)
+ (any-valid-p nil))
+ (dolist (v (sb!di:ambiguous-debug-vars
+ d-fun
+ (if prefix (string prefix) "")))
+ (setf any-p t)
+ (when (eq (sb!di:debug-var-validity v location) :valid)
+ (setf any-valid-p t)
+ (format t "~S~:[#~D~;~*~] = ~S~%"
+ (sb!di:debug-var-symbol v)
+ (zerop (sb!di:debug-var-id v))
+ (sb!di:debug-var-id v)
+ (sb!di:debug-var-value v *current-frame*))))
+
+ (cond
+ ((not any-p)
+ (format t "There are no local variables ~@[starting with ~A ~]~
+ in the function."
+ prefix))
+ ((not any-valid-p)
+ (format t "All variables ~@[starting with ~A ~]currently ~
+ have invalid values."
+ prefix))))
+ (write-line "There is no variable information available."))))
+
+(def-debug-command-alias "L" "LIST-LOCALS")
+
+(def-debug-command "SOURCE" ()
+ (fresh-line)
+ (print-code-location-source-form (sb!di:frame-code-location *current-frame*)
+ (read-if-available 0)))
+\f
+;;;; source location printing
+
+;;; We cache a stream to the last valid file debug source so that we won't have
+;;; to repeatedly open the file.
+;;; KLUDGE: This sounds like a bug, not a feature. Opening files is fast
+;;; in the 1990s, so the benefit is negligible, less important than the
+;;; potential of extra confusion if someone changes the source during
+;;; a debug session and the change doesn't show up. And removing this
+;;; would simplify the system, which I like. -- WHN 19990903
+(defvar *cached-debug-source* nil)
+(declaim (type (or sb!di:debug-source null) *cached-debug-source*))
+(defvar *cached-source-stream* nil)
+(declaim (type (or stream null) *cached-source-stream*))
+
+;;; To suppress the read-time evaluation #. macro during source read,
+;;; *READTABLE* is modified. *READTABLE* is cached to avoid
+;;; copying it each time, and invalidated when the
+;;; *CACHED-DEBUG-SOURCE* has changed.
+(defvar *cached-readtable* nil)
+(declaim (type (or readtable null) *cached-readtable*))
+
+(pushnew #'(lambda ()
+ (setq *cached-debug-source* nil *cached-source-stream* nil
+ *cached-readtable* nil))
+ sb!int:*before-save-initializations*)
+
+;;; We also cache the last top-level form that we printed a source for so that
+;;; we don't have to do repeated reads and calls to FORM-NUMBER-TRANSLATIONS.
+(defvar *cached-top-level-form-offset* nil)
+(declaim (type (or sb!kernel:index null) *cached-top-level-form-offset*))
+(defvar *cached-top-level-form*)
+(defvar *cached-form-number-translations*)
+
+;;; Given a code location, return the associated form-number translations and
+;;; the actual top-level form. We check our cache --- if there is a miss, we
+;;; dispatch on the kind of the debug source.
+(defun get-top-level-form (location)
+ (let ((d-source (sb!di:code-location-debug-source location)))
+ (if (and (eq d-source *cached-debug-source*)
+ (eql (sb!di:code-location-top-level-form-offset location)
+ *cached-top-level-form-offset*))
+ (values *cached-form-number-translations* *cached-top-level-form*)
+ (let* ((offset (sb!di:code-location-top-level-form-offset location))
+ (res
+ (ecase (sb!di:debug-source-from d-source)
+ (:file (get-file-top-level-form location))
+ (:lisp (svref (sb!di:debug-source-name d-source) offset)))))
+ (setq *cached-top-level-form-offset* offset)
+ (values (setq *cached-form-number-translations*
+ (sb!di:form-number-translations res offset))
+ (setq *cached-top-level-form* res))))))
+
+;;; Locates the source file (if it still exists) and grabs the top-level form.
+;;; If the file is modified, we use the top-level-form offset instead of the
+;;; recorded character offset.
+(defun get-file-top-level-form (location)
+ (let* ((d-source (sb!di:code-location-debug-source location))
+ (tlf-offset (sb!di:code-location-top-level-form-offset location))
+ (local-tlf-offset (- tlf-offset
+ (sb!di:debug-source-root-number d-source)))
+ (char-offset
+ (aref (or (sb!di:debug-source-start-positions d-source)
+ (error "no start positions map"))
+ local-tlf-offset))
+ (name (sb!di:debug-source-name d-source)))
+ (unless (eq d-source *cached-debug-source*)
+ (unless (and *cached-source-stream*
+ (equal (pathname *cached-source-stream*)
+ (pathname name)))
+ (setq *cached-readtable* nil)
+ (when *cached-source-stream* (close *cached-source-stream*))
+ (setq *cached-source-stream* (open name :if-does-not-exist nil))
+ (unless *cached-source-stream*
+ (error "The source file no longer exists:~% ~A" (namestring name)))
+ (format t "~%; file: ~A~%" (namestring name)))
+
+ (setq *cached-debug-source*
+ (if (= (sb!di:debug-source-created d-source)
+ (file-write-date name))
+ d-source nil)))
+
+ (cond
+ ((eq *cached-debug-source* d-source)
+ (file-position *cached-source-stream* char-offset))
+ (t
+ (format t "~%; File has been modified since compilation:~%; ~A~@
+ ; Using form offset instead of character position.~%"
+ (namestring name))
+ (file-position *cached-source-stream* 0)
+ (let ((*read-suppress* t))
+ (dotimes (i local-tlf-offset)
+ (read *cached-source-stream*)))))
+ (unless *cached-readtable*
+ (setq *cached-readtable* (copy-readtable))
+ (set-dispatch-macro-character
+ #\# #\.
+ #'(lambda (stream sub-char &rest rest)
+ (declare (ignore rest sub-char))
+ (let ((token (read stream t nil t)))
+ (format nil "#.~S" token)))
+ *cached-readtable*))
+ (let ((*readtable* *cached-readtable*))
+ (read *cached-source-stream*))))
+
+(defun print-code-location-source-form (location context)
+ (let* ((location (maybe-block-start-location location))
+ (form-num (sb!di:code-location-form-number location)))
+ (multiple-value-bind (translations form) (get-top-level-form location)
+ (unless (< form-num (length translations))
+ (error "The source path no longer exists."))
+ (prin1 (sb!di:source-path-context form
+ (svref translations form-num)
+ context)))))
+\f
+;;; breakpoint and step commands
+
+;;; Step to the next code-location.
+(def-debug-command "STEP" ()
+ (setf *number-of-steps* (read-if-available 1))
+ (set-step-breakpoint *current-frame*)
+ (continue *debug-condition*)
+ (error "couldn't continue"))
+
+;;; List possible breakpoint locations, which ones are active, and where GO
+;;; will continue. Set *POSSIBLE-BREAKPOINTS* to the code-locations which can
+;;; then be used by sbreakpoint.
+(def-debug-command "LIST-LOCATIONS" ()
+ (let ((df (read-if-available *default-breakpoint-debug-function*)))
+ (cond ((consp df)
+ (setf df (sb!di:function-debug-function (eval df)))
+ (setf *default-breakpoint-debug-function* df))
+ ((or (eq ':c df)
+ (not *default-breakpoint-debug-function*))
+ (setf df (sb!di:frame-debug-function *current-frame*))
+ (setf *default-breakpoint-debug-function* df)))
+ (setf *possible-breakpoints* (possible-breakpoints df)))
+ (let ((continue-at (sb!di:frame-code-location *current-frame*)))
+ (let ((active (location-in-list *default-breakpoint-debug-function*
+ *breakpoints* :function-start))
+ (here (sb!di:code-location=
+ (sb!di:debug-function-start-location
+ *default-breakpoint-debug-function*) continue-at)))
+ (when (or active here)
+ (format t "::FUNCTION-START ")
+ (when active (format t " *Active*"))
+ (when here (format t " *Continue here*"))))
+
+ (let ((prev-location nil)
+ (prev-num 0)
+ (this-num 0))
+ (flet ((flush ()
+ (when prev-location
+ (let ((this-num (1- this-num)))
+ (if (= prev-num this-num)
+ (format t "~&~D: " prev-num)
+ (format t "~&~D-~D: " prev-num this-num)))
+ (print-code-location-source-form prev-location 0)
+ (when *print-location-kind*
+ (format t "~S " (sb!di:code-location-kind prev-location)))
+ (when (location-in-list prev-location *breakpoints*)
+ (format t " *Active*"))
+ (when (sb!di:code-location= prev-location continue-at)
+ (format t " *Continue here*")))))
+
+ (dolist (code-location *possible-breakpoints*)
+ (when (or *print-location-kind*
+ (location-in-list code-location *breakpoints*)
+ (sb!di:code-location= code-location continue-at)
+ (not prev-location)
+ (not (eq (sb!di:code-location-debug-source code-location)
+ (sb!di:code-location-debug-source prev-location)))
+ (not (eq (sb!di:code-location-top-level-form-offset
+ code-location)
+ (sb!di:code-location-top-level-form-offset
+ prev-location)))
+ (not (eq (sb!di:code-location-form-number code-location)
+ (sb!di:code-location-form-number prev-location))))
+ (flush)
+ (setq prev-location code-location prev-num this-num))
+
+ (incf this-num))))
+
+ (when (location-in-list *default-breakpoint-debug-function*
+ *breakpoints*
+ :function-end)
+ (format t "~&::FUNCTION-END *Active* "))))
+
+(def-debug-command-alias "LL" "LIST-LOCATIONS")
+
+;;; Set breakpoint at the given number.
+(def-debug-command "BREAKPOINT" ()
+ (let ((index (read-prompting-maybe "location number, :START, or :END: "))
+ (break t)
+ (condition t)
+ (print nil)
+ (print-functions nil)
+ (function nil)
+ (bp)
+ (place *default-breakpoint-debug-function*))
+ (flet ((get-command-line ()
+ (let ((command-line nil)
+ (unique '(nil)))
+ (loop
+ (let ((next-input (read-if-available unique)))
+ (when (eq next-input unique) (return))
+ (push next-input command-line)))
+ (nreverse command-line)))
+ (set-vars-from-command-line (command-line)
+ (do ((arg (pop command-line) (pop command-line)))
+ ((not arg))
+ (ecase arg
+ (:condition (setf condition (pop command-line)))
+ (:print (push (pop command-line) print))
+ (:break (setf break (pop command-line)))
+ (:function
+ (setf function (eval (pop command-line)))
+ (setf *default-breakpoint-debug-function*
+ (sb!di:function-debug-function function))
+ (setf place *default-breakpoint-debug-function*)
+ (setf *possible-breakpoints*
+ (possible-breakpoints
+ *default-breakpoint-debug-function*))))))
+ (setup-function-start ()
+ (let ((code-loc (sb!di:debug-function-start-location place)))
+ (setf bp (sb!di:make-breakpoint #'main-hook-function
+ place
+ :kind :function-start))
+ (setf break (sb!di:preprocess-for-eval break code-loc))
+ (setf condition (sb!di:preprocess-for-eval condition code-loc))
+ (dolist (form print)
+ (push (cons (sb!di:preprocess-for-eval form code-loc) form)
+ print-functions))))
+ (setup-function-end ()
+ (setf bp
+ (sb!di:make-breakpoint #'main-hook-function
+ place
+ :kind :function-end))
+ (setf break
+ ;; FIXME: These and any other old (COERCE `(LAMBDA ..) ..)
+ ;; forms should be converted to shiny new (LAMBDA ..) forms.
+ ;; (Search the sources for "coerce.*\(lambda".)
+ (coerce `(lambda (dummy)
+ (declare (ignore dummy)) ,break)
+ 'function))
+ (setf condition (coerce `(lambda (dummy)
+ (declare (ignore dummy)) ,condition)
+ 'function))
+ (dolist (form print)
+ (push (cons
+ (coerce `(lambda (dummy)
+ (declare (ignore dummy)) ,form) 'function)
+ form)
+ print-functions)))
+ (setup-code-location ()
+ (setf place (nth index *possible-breakpoints*))
+ (setf bp (sb!di:make-breakpoint #'main-hook-function
+ place
+ :kind :code-location))
+ (dolist (form print)
+ (push (cons
+ (sb!di:preprocess-for-eval form place)
+ form)
+ print-functions))
+ (setf break (sb!di:preprocess-for-eval break place))
+ (setf condition (sb!di:preprocess-for-eval condition place))))
+ (set-vars-from-command-line (get-command-line))
+ (cond
+ ((or (eq index :start) (eq index :s))
+ (setup-function-start))
+ ((or (eq index :end) (eq index :e))
+ (setup-function-end))
+ (t
+ (setup-code-location)))
+ (sb!di:activate-breakpoint bp)
+ (let* ((new-bp-info (create-breakpoint-info place bp index
+ :break break
+ :print print-functions
+ :condition condition))
+ (old-bp-info (location-in-list new-bp-info *breakpoints*)))
+ (when old-bp-info
+ (sb!di:deactivate-breakpoint (breakpoint-info-breakpoint
+ old-bp-info))
+ (setf *breakpoints* (remove old-bp-info *breakpoints*))
+ (format t "previous breakpoint removed~%"))
+ (push new-bp-info *breakpoints*))
+ (print-breakpoint-info (first *breakpoints*))
+ (format t "~&added"))))
+
+(def-debug-command-alias "BP" "BREAKPOINT")
+
+;;; List all breakpoints which are set.
+(def-debug-command "LIST-BREAKPOINTS" ()
+ (setf *breakpoints*
+ (sort *breakpoints* #'< :key #'breakpoint-info-breakpoint-number))
+ (dolist (info *breakpoints*)
+ (print-breakpoint-info info)))
+
+(def-debug-command-alias "LB" "LIST-BREAKPOINTS")
+(def-debug-command-alias "LBP" "LIST-BREAKPOINTS")
+
+;;; Remove breakpoint N, or remove all breakpoints if no N given.
+(def-debug-command "DELETE-BREAKPOINT" ()
+ (let* ((index (read-if-available nil))
+ (bp-info
+ (find index *breakpoints* :key #'breakpoint-info-breakpoint-number)))
+ (cond (bp-info
+ (sb!di:delete-breakpoint (breakpoint-info-breakpoint bp-info))
+ (setf *breakpoints* (remove bp-info *breakpoints*))
+ (format t "breakpoint ~S removed~%" index))
+ (index (format t "The breakpoint doesn't exist."))
+ (t
+ (dolist (ele *breakpoints*)
+ (sb!di:delete-breakpoint (breakpoint-info-breakpoint ele)))
+ (setf *breakpoints* nil)
+ (format t "all breakpoints deleted~%")))))
+
+(def-debug-command-alias "DBP" "DELETE-BREAKPOINT")
+\f
+;;; miscellaneous commands
+
+(def-debug-command "DESCRIBE" ()
+ (let* ((curloc (sb!di:frame-code-location *current-frame*))
+ (debug-fun (sb!di:code-location-debug-function curloc))
+ (function (sb!di:debug-function-function debug-fun)))
+ (if function
+ (describe function)
+ (format t "can't figure out the function for this frame"))))
+\f
+;;;; debug loop command utilities
+
+(defun read-prompting-maybe (prompt &optional (in *standard-input*)
+ (out *standard-output*))
+ (unless (sb!int:listen-skip-whitespace in)
+ (princ prompt out)
+ (force-output out))
+ (read in))
+
+(defun read-if-available (default &optional (stream *standard-input*))
+ (if (sb!int:listen-skip-whitespace stream)
+ (read stream)
+ default))
--- /dev/null
+;;;; DEF!MACRO = cold DEFMACRO, a version of DEFMACRO which at
+;;;; build-the-cross-compiler time defines its macro both in the
+;;;; cross-compilation host Lisp and in the target Lisp. Basically,
+;;;; DEF!MACRO does something like
+;;;; (DEFMACRO SB!XC:FOO (,@ARGS) (FOO-EXPANDER ,@ARGS))
+;;;; #+SB-XC-HOST (SB!XC:DEFMACRO FOO (,@ARGS) (FOO-EXPANDER ,@ARGS))
+;;;; an idiom which would otherwise be handwritten repeatedly.
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!IMPL")
+
+(file-comment
+ "$Header$")
+
+#+sb-xc-host
+(progn
+ ;; a description of the DEF!MACRO call to be stored until we get enough
+ ;; of the system running to finish processing it
+ (defstruct delayed-def!macro
+ (args (required-argument) :type cons)
+ (package *package* :type package))
+ ;; a list of DELAYED-DEF!MACROs stored until we get DEF!MACRO working fully
+ ;; so that we can apply it to them. After DEF!MACRO is made to work, this
+ ;; list is processed, and then should no longer be used; it's made unbound in
+ ;; hopes of discouraging any attempt to pushing anything more onto it.
+ ;; (DEF!MACRO knows about this behavior, and uses the unboundness of
+ ;; *DELAYED-DEF!MACROS* as a way to decide to just call SB!XC:DEFMACRO
+ ;; instead of pushing onto *DELAYED-DEF!MACROS*.)
+ (defvar *delayed-def!macros* nil))
+
+;;; KLUDGE: This is unfortunately somewhat tricky. (A lot of the
+;;; cross-compilation-unfriendliness of Common Lisp comes home to roost here.)
+(defmacro def!macro (name &rest rest)
+ #-(or sb-xc-host sb-xc) `(defmacro ,name ,@rest)
+ #+sb-xc-host `(progn
+ (defmacro ,name ,@rest)
+ ,(let ((uncrossed-args `(,(uncross name) ,@rest)))
+ (if (boundp '*delayed-def!macros*)
+ `(push (make-delayed-def!macro :args ',uncrossed-args)
+ *delayed-def!macros*)
+ `(sb!xc:defmacro ,@uncrossed-args))))
+ ;; When cross-compiling, we don't want the DEF!MACRO to have any
+ ;; effect at compile time, because (1) we already defined the macro
+ ;; when building the cross-compiler, so at best it would be redundant
+ ;; and inefficient to replace the current compiled macro body with
+ ;; an interpreted macro body, and (2) because of the various games
+ ;; with SB!XC vs. CL which are played when cross-compiling, we'd
+ ;; be at risk of making an incorrect definition, with something which
+ ;; should be e.g. calling SB!XC:TYPEP instead calling CL:TYPEP
+ ;; and getting all confused. Using an ordinary assignment (and not
+ ;; any special forms like DEFMACRO) guarantees that there are no
+ ;; effects at compile time.
+ #+sb-xc `(defmacro-mundanely ,name ,@rest))
+
+#+sb-xc-host
+(defun force-delayed-def!macros ()
+ (if (boundp '*delayed-def!macros*)
+ (progn
+ (mapcar (lambda (x)
+ (let ((*package* (delayed-def!macro-package x)))
+ (eval `(sb!xc:defmacro ,@(delayed-def!macro-args x)))))
+ (reverse *delayed-def!macros*))
+ ;; We shouldn't need this list any more. Making it unbound serves as a
+ ;; signal to DEF!MACRO that it needn't delayed DEF!MACROs any more.
+ ;; It is also generally a good thing for other reasons: it frees
+ ;; garbage, and it discourages anyone else from pushing anything else
+ ;; onto the list later.
+ (makunbound '*delayed-def!macros*))
+ ;; This condition is probably harmless if it comes up when
+ ;; interactively experimenting with the system by loading a source
+ ;; file into it more than once. But it's worth warning about it
+ ;; because it definitely shouldn't come up in an ordinary build
+ ;; process.
+ (warn "*DELAYED-DEF!MACROS* is already unbound.")))
--- /dev/null
+;;;; DEF!STRUCT = bootstrap DEFSTRUCT, a wrapper around DEFSTRUCT which
+;;;; provides special features to help at bootstrap time:
+;;;; 1. Layout information, inheritance information, and so forth is
+;;;; retained in such a way that we can get to it even on vanilla
+;;;; ANSI Common Lisp at cross-compiler build time.
+;;;; 2. MAKE-LOAD-FORM information is stored in such a way that we can
+;;;; get to it at bootstrap time before CLOS is built.
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!KERNEL")
+
+(file-comment
+ "$Header$")
+
+;;; A bootstrap MAKE-LOAD-FORM method can be a function or the name
+;;; of a function.
+(deftype def!struct-type-make-load-form-fun () '(or function symbol))
+
+;;; a little single-inheritance system to keep track of MAKE-LOAD-FORM
+;;; information for DEF!STRUCT-defined types
+(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
+
+ ;; FIXME: All this could be byte compiled. (Perhaps most of the rest
+ ;; of the file could be, too.)
+
+ ;; (DEF!STRUCT-SUPERTYPE TYPE) is the DEF!STRUCT-defined type that
+ ;; TYPE inherits from, or NIL if none.
+ (defvar *def!struct-supertype* (make-hash-table))
+ (defun def!struct-supertype (type)
+ (multiple-value-bind (value value-p) (gethash type *def!struct-supertype*)
+ (unless value-p
+ (error "~S is not a DEF!STRUCT-defined type." type))
+ value))
+ (defun (setf def!struct-supertype) (value type)
+ (when (and value #-sb-xc-host *type-system-initialized*)
+ (assert (subtypep value 'structure!object))
+ (assert (subtypep type value)))
+ (setf (gethash type *def!struct-supertype*) value))
+
+ ;; (DEF!STRUCT-TYPE-MAKE-LOAD-FORM-FUN TYPE) is the load form
+ ;; generator associated with the DEF!STRUCT-defined structure named
+ ;; TYPE, stored in a way which works independently of CLOS. The
+ ;; *DEF!STRUCT-TYPE-MAKE-LOAD-FORM-FUN* table is used to store the
+ ;; values. All types defined by DEF!STRUCT have an entry in the
+ ;; table; those with no MAKE-LOAD-FORM function have an explicit NIL
+ ;; entry.
+ (defvar *def!struct-type-make-load-form-fun* (make-hash-table))
+ (defun def!struct-type-make-load-form-fun (type)
+ (do ((supertype type))
+ (nil)
+ (multiple-value-bind (value value-p)
+ (gethash supertype *def!struct-type-make-load-form-fun*)
+ (unless value-p
+ (error "~S (supertype of ~S) is not a DEF!STRUCT-defined type."
+ supertype
+ type))
+ (when value
+ (return value))
+ (setf supertype (def!struct-supertype supertype))
+ (unless supertype
+ (error "There is no MAKE-LOAD-FORM function for bootstrap type ~S."
+ type)))))
+ (defun (setf def!struct-type-make-load-form-fun) (new-value type)
+ (when #+sb-xc-host t #-sb-xc-host *type-system-initialized*
+ (assert (subtypep type 'structure!object))
+ (check-type new-value def!struct-type-make-load-form-fun))
+ (setf (gethash type *def!struct-type-make-load-form-fun*) new-value)))
+
+;;; the simplest, most vanilla MAKE-LOAD-FORM function for DEF!STRUCT
+;;; objects
+(defun just-dump-it-normally (object &optional (env nil env-p))
+ (declare (type structure!object object))
+ (if env-p
+ (make-load-form-saving-slots object :environment env)
+ (make-load-form-saving-slots object)))
+
+;;; a MAKE-LOAD-FORM function for objects which don't use the load
+;;; form system. This is used for LAYOUT objects because the special
+;;; dumping requirements of LAYOUT objects are met by using special
+;;; VOPs which bypass the load form system. It's also used for various
+;;; compiler internal structures like nodes and VOP-INFO (FIXME:
+;;; Why?).
+(defun ignore-it (object &optional env)
+ (declare (type structure!object object))
+ (declare (ignore object env))
+ ;; This magic tag is handled specially by the compiler downstream.
+ :ignore-it)
+
+;;; machinery used in the implementation of DEF!STRUCT
+#+sb-xc-host
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ ;; a description of a DEF!STRUCT call to be stored until we get
+ ;; enough of the system running to finish processing it
+ (defstruct delayed-def!struct
+ (args (required-argument) :type cons)
+ (package *package* :type package))
+ ;; a list of DELAYED-DEF!STRUCTs stored until we get DEF!STRUCT
+ ;; working fully so that we can apply it to them then. After
+ ;; DEF!STRUCT is made to work fully, this list is processed, then
+ ;; made unbound, and should no longer be used.
+ (defvar *delayed-def!structs* nil))
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ ;; Parse the arguments for a DEF!STRUCT call, and return
+ ;; (VALUES NAME DEFSTRUCT-ARGS MAKE-LOAD-FORM-FUN DEF!STRUCT-SUPERTYPE),
+ ;; where NAME is the name of the new type, DEFSTRUCT-ARGS is the
+ ;; munged result suitable for passing on to DEFSTRUCT,
+ ;; MAKE-LOAD-FORM-FUN is the make load form function, or NIL if
+ ;; there's none, and DEF!STRUCT-SUPERTYPE is the direct supertype of
+ ;; the type if it is another DEF!STRUCT-defined type, or NIL
+ ;; otherwise.
+ (defun parse-def!struct-args (nameoid &rest rest)
+ (multiple-value-bind (name options) ; Note: OPTIONS can change below.
+ (if (consp nameoid)
+ (values (first nameoid) (rest nameoid))
+ (values nameoid nil))
+ (let* ((include-clause (find :include options :key #'first))
+ (def!struct-supertype nil) ; may change below
+ (mlff-clause (find :make-load-form-fun options :key #'first))
+ (mlff (and mlff-clause (second mlff-clause))))
+ (when (find :type options :key #'first)
+ (error "can't use :TYPE option in DEF!STRUCT"))
+ (when mlff-clause
+ (setf options (remove mlff-clause options)))
+ (when include-clause
+ (setf def!struct-supertype (second include-clause)))
+ (if (eq name 'structure!object) ; if root of hierarchy
+ (assert (not include-clause))
+ (unless include-clause
+ (setf def!struct-supertype 'structure!object)
+ (push `(:include ,def!struct-supertype) options)))
+ (values name `((,name ,@options) ,@rest) mlff def!struct-supertype)))))
+
+;;; Part of the raison d'etre for DEF!STRUCT is to be able to emulate
+;;; these low-level CMU CL functions in a vanilla ANSI Common Lisp
+;;; cross compilation host. (The emulation doesn't need to be
+;;; efficient, since it's needed for things like dumping objects, not
+;;; inner loops.)
+#+sb-xc-host
+(progn
+ (defun %instance-length (instance)
+ (check-type instance structure!object)
+ (layout-length (class-layout (sb!xc:find-class (type-of instance)))))
+ (defun %instance-ref (instance index)
+ (check-type instance structure!object)
+ (let* ((class (sb!xc:find-class (type-of instance)))
+ (layout (class-layout class)))
+ (if (zerop index)
+ layout
+ (let* ((dd (layout-info layout))
+ (dsd (elt (dd-slots dd) (1- index)))
+ (accessor (dsd-accessor dsd)))
+ (declare (type symbol accessor))
+ (funcall accessor instance)))))
+ (defun %instance-set (instance index new-value)
+ (check-type instance structure!object)
+ (let* ((class (sb!xc:find-class (type-of instance)))
+ (layout (class-layout class)))
+ (if (zerop index)
+ (error "can't set %INSTANCE-REF FOO 0 in cross-compilation host")
+ (let* ((dd (layout-info layout))
+ (dsd (elt (dd-slots dd) (1- index)))
+ (accessor (dsd-accessor dsd)))
+ (declare (type symbol accessor))
+ (funcall (fdefinition `(setf ,accessor)) new-value instance))))))
+
+;;; a helper function for DEF!STRUCT in the #+SB-XC-HOST case: Return
+;;; DEFSTRUCT-style arguments with any class names in the SB!XC
+;;; package (i.e. the name of the class being defined, and/or the
+;;; names of classes in :INCLUDE clauses) converted from SB!XC::FOO to
+;;; CL::FOO.
+#+sb-xc-host
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defun uncross-defstruct-args (defstruct-args)
+ (destructuring-bind (name-and-options &rest slots-and-doc) defstruct-args
+ (multiple-value-bind (name options)
+ (if (symbolp name-and-options)
+ (values name-and-options nil)
+ (values (first name-and-options)
+ (rest name-and-options)))
+ (flet ((uncross-option (option)
+ (if (eq (first option) :include)
+ (destructuring-bind
+ (include-keyword included-name &rest rest)
+ option
+ `(,include-keyword
+ ,(uncross included-name)
+ ,@rest))
+ option)))
+ `((,(uncross name)
+ ,@(mapcar #'uncross-option options))
+ ,@slots-and-doc))))))
+
+;;; DEF!STRUCT's arguments are like DEFSTRUCT's arguments, except that
+;;; DEF!STRUCT accepts an extra optional :MAKE-LOAD-FORM-FUN clause.
+;;; DEF!STRUCT also does some magic to ensure that anything it defines
+;;; includes STRUCTURE!OBJECT, so that when CLOS is/becomes available,
+;;; we can hook the DEF!STRUCT system into
+;;; (DEFMETHOD MAKE-LOAD-FORM ((X STRUCTURE!OBJECT) &OPTIONAL ENV) ..)
+;;; and everything will continue to work.
+(defmacro def!struct (&rest args)
+ (multiple-value-bind (name defstruct-args mlff def!struct-supertype)
+ (apply #'parse-def!struct-args args)
+ `(progn
+ ;; (Putting the DEFSTRUCT here, outside the EVAL-WHEN, seems to
+ ;; be necessary in order to cross-compile the hash table
+ ;; implementation. -- WHN 19990809)
+ (defstruct ,@defstruct-args)
+ ;; (Putting this SETF here, outside the EVAL-WHEN, seems to be
+ ;; necessary in order to allow us to put the DEFSTRUCT outside
+ ;; the EVAL-WHEN.)
+ (setf (def!struct-type-make-load-form-fun ',name)
+ ,(if (symbolp mlff)
+ `',mlff
+ mlff)
+ (def!struct-supertype ',name)
+ ',def!struct-supertype)
+ ;; This bit of commented-out code hasn't been needed for quite
+ ;; some time, but the comments here about why not might still
+ ;; be useful to me until I finally get the system to work. When
+ ;; I do remove all this, I should be sure also to remove the
+ ;; "outside the EVAL-WHEN" comments above, since they will no
+ ;; longer make sense. -- WHN 19990803
+ ;;(eval-when (:compile-toplevel :load-toplevel :execute)
+ ;; ;; (The DEFSTRUCT used to be in here, but that failed when trying
+ ;; ;; to cross-compile the hash table implementation.)
+ ;; ;;(defstruct ,@defstruct-args)
+ ;; ;; The (SETF (DEF!STRUCT-TYPE-MAKE-LOAD-FORM-FUN ..) ..) used to
+ ;; ;; be in here too, but that failed an assertion in the SETF
+ ;; ;; definition once we moved the DEFSTRUCT outside.)
+ ;; )
+ #+sb-xc-host ,(let ((u (uncross-defstruct-args defstruct-args)))
+ (if (boundp '*delayed-def!structs*)
+ `(push (make-delayed-def!struct :args ',u)
+ *delayed-def!structs*)
+ `(sb!xc:defstruct ,@u)))
+ ',name)))
+
+;;; When building the cross-compiler, this function has to be called
+;;; some time after SB!XC:DEFSTRUCT is set up, in order to take care
+;;; of any processing which had to be delayed until then.
+#+sb-xc-host
+(defun force-delayed-def!structs ()
+ (if (boundp '*delayed-def!structs*)
+ (progn
+ (mapcar (lambda (x)
+ (let ((*package* (delayed-def!struct-package x)))
+ ;; KLUDGE(?): EVAL is almost always the wrong thing.
+ ;; However, since we have to map DEFSTRUCT over the
+ ;; list, and since ANSI declined to specify any
+ ;; functional primitives corresponding to the
+ ;; DEFSTRUCT macro, it seems to me that EVAL is
+ ;; required in there somewhere..
+ (eval `(sb!xc:defstruct ,@(delayed-def!struct-args x)))))
+ (reverse *delayed-def!structs*))
+ ;; We shouldn't need this list any more. Making it unbound
+ ;; serves as a signal to DEF!STRUCT that it needn't delay
+ ;; DEF!STRUCTs any more. It is also generally a good thing for
+ ;; other reasons: it frees garbage, and it discourages anyone
+ ;; else from pushing anything else onto the list later.
+ (makunbound '*delayed-def!structs*))
+ ;; This condition is probably harmless if it comes up when
+ ;; interactively experimenting with the system by loading a source
+ ;; file into it more than once. But it's worth warning about it
+ ;; because it definitely shouldn't come up in an ordinary build
+ ;; process.
+ (warn "*DELAYED-DEF!STRUCTS* is already unbound.")))
+
+;;; The STRUCTURE!OBJECT abstract class is the base of the type
+;;; hierarchy for objects which use DEF!STRUCT functionality.
+(def!struct (structure!object (:constructor nil)))
+\f
+;;;; hooking this all into the standard MAKE-LOAD-FORM system
+
+(defun structure!object-make-load-form (object &optional env)
+ #!+sb-doc
+ "MAKE-LOAD-FORM for DEF!STRUCT-defined types"
+ (declare (ignore env))
+ (funcall (def!struct-type-make-load-form-fun (type-of object))
+ object))
+
+;;; Do the right thing at cold load time.
+;;;
+;;; (Eventually this MAKE-LOAD-FORM function be overwritten by CLOS's
+;;; generic MAKE-LOAD-FORM, at which time a STRUCTURE!OBJECT method
+;;; should be added to call STRUCTURE!OBJECT-MAKE-LOAD-FORM.)
+(setf (symbol-function 'sb!xc:make-load-form)
+ #'structure!object-make-load-form)
+
+;;; Do the right thing in the vanilla ANSI CLOS of the
+;;; cross-compilation host. (Something similar will have to be done in
+;;; our CLOS, too, but later, some time long after the toplevel forms
+;;; of this file have run.)
+#+sb-xc-host
+(defmethod make-load-form ((obj structure!object) &optional (env nil env-p))
+ (if env-p
+ (structure!object-make-load-form obj env)
+ (structure!object-make-load-form obj)))
--- /dev/null
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!KERNEL")
+
+(file-comment
+ "$Header$")
+\f
+;;;; the DEF!TYPE macro
+
+;;; DEF!MACRO = cold DEFTYPE, a version of DEFTYPE which at
+;;; build-the-cross-compiler time defines its macro both in the
+;;; cross-compilation host Lisp and in the target Lisp. Basically,
+;;; DEF!TYPE does something like
+;;; (DEFTYPE SB!XC:FOO ..)
+;;; #+SB-XC-HOST (SB!XC:DEFTYPE FOO ..)
+;;; except that it also automatically delays the SB!XC:DEFTYPE call,
+;;; if necessary, until the cross-compiler's DEFTYPE machinery has been
+;;; set up.
+
+;;; FIXME: This code was created by cut-and-paste from the
+;;; corresponding code for DEF!MACRO. DEF!TYPE and DEF!MACRO are
+;;; currently very parallel, and if we ever manage to rationalize the
+;;; use of UNCROSS in the cross-compiler, they should become
+;;; completely parallel, at which time they should be merged to
+;;; eliminate the duplicate code.
+
+(defmacro def!type (&rest rest)
+ `(progn
+ (deftype ,@rest)
+ #+sb-xc-host
+ ,(let ((form `(sb!xc:deftype ,@(uncross rest))))
+ (if (boundp '*delayed-def!types*)
+ `(push ',form *delayed-def!types*)
+ form))))
+
+;;; machinery to implement DEF!TYPE delays
+#+sb-xc-host
+(progn
+ (/show "binding *DELAYED-DEF!TYPES*")
+ (defvar *delayed-def!types* nil)
+ (/show "done binding *DELAYED-DEF!TYPES*")
+ (defun force-delayed-def!types ()
+ (if (boundp '*delayed-def!types*)
+ (progn
+ (mapc #'eval *delayed-def!types*)
+ (makunbound '*delayed-def!types*))
+ ;; This condition is probably harmless if it comes up when
+ ;; interactively experimenting with the system by loading a
+ ;; source file into it more than once. But it's worth warning
+ ;; about it because it definitely shouldn't come up in an
+ ;; ordinary build process.
+ (warn "*DELAYED-DEF!TYPES* is already unbound."))))
--- /dev/null
+;;;; bootstrapping fundamental machinery (e.g. DEFUN, DEFCONSTANT,
+;;;; DEFVAR) from special forms and primitive functions
+;;;;
+;;;; KLUDGE: The bootstrapping aspect of this is now obsolete. It was
+;;;; originally intended that this file file would be loaded into a
+;;;; Lisp image which had Common Lisp primitives defined, and DEFMACRO
+;;;; defined, and little else. Since then that approach has been
+;;;; dropped and this file has been modified somewhat to make it work
+;;;; more cleanly when used to predefine macros at
+;;;; build-the-cross-compiler time.
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!IMPL")
+
+(file-comment
+ "$Header$")
+\f
+;;;; IN-PACKAGE
+
+(defmacro-mundanely in-package (package-designator)
+ `(eval-when (:compile-toplevel :load-toplevel :execute)
+ (setq *package* (find-undeleted-package-or-lose ',package-designator))))
+\f
+;;; MULTIPLE-VALUE-FOO
+
+(defun list-of-symbols-p (x)
+ (and (listp x)
+ (every #'symbolp x)))
+
+(defmacro-mundanely multiple-value-bind (vars value-form &body body)
+ (if (list-of-symbols-p vars)
+ ;; It's unclear why it would be important to special-case the LENGTH=1 case
+ ;; at this level, but the CMU CL code did it, so.. -- WHN 19990411
+ (if (= (length vars) 1)
+ `(let ((,(car vars) ,value-form))
+ ,@body)
+ (let ((ignore (gensym)))
+ `(multiple-value-call #'(lambda (&optional ,@vars &rest ,ignore)
+ (declare (ignore ,ignore))
+ ,@body)
+ ,value-form)))
+ (error "Vars is not a list of symbols: ~S" vars)))
+
+(defmacro-mundanely multiple-value-setq (vars value-form)
+ (cond ((null vars)
+ ;; The ANSI spec says that the primary value of VALUE-FORM must be
+ ;; returned. The general-case-handling code below doesn't do this
+ ;; correctly in the special case when there are no vars bound, so we
+ ;; handle this special case separately here.
+ (let ((g (gensym)))
+ `(multiple-value-bind (,g) ,value-form
+ ,g)))
+ ((list-of-symbols-p vars)
+ (let ((temps (mapcar #'(lambda (x)
+ (declare (ignore x))
+ (gensym)) vars)))
+ `(multiple-value-bind ,temps ,value-form
+ ,@(mapcar #'(lambda (var temp)
+ `(setq ,var ,temp))
+ vars temps)
+ ,(car temps))))
+ (t (error "Vars is not a list of symbols: ~S" vars))))
+
+(defmacro-mundanely multiple-value-list (value-form)
+ `(multiple-value-call #'list ,value-form))
+\f
+;;;; various conditional constructs
+
+;;; COND defined in terms of IF
+(defmacro-mundanely cond (&rest clauses)
+ (if (endp clauses)
+ nil
+ (let ((clause (first clauses)))
+ (if (atom clause)
+ (error "Cond clause is not a list: ~S" clause)
+ (let ((test (first clause))
+ (forms (rest clause)))
+ (if (endp forms)
+ (let ((n-result (gensym)))
+ `(let ((,n-result ,test))
+ (if ,n-result
+ ,n-result
+ (cond ,@(rest clauses)))))
+ `(if ,test
+ (progn ,@forms)
+ (cond ,@(rest clauses)))))))))
+
+;;; other things defined in terms of COND
+(defmacro-mundanely when (test &body forms)
+ #!+sb-doc
+ "First arg is a predicate. If it is non-null, the rest of the forms are
+ evaluated as a PROGN."
+ `(cond (,test nil ,@forms)))
+(defmacro-mundanely unless (test &body forms)
+ #!+sb-doc
+ "First arg is a predicate. If it is null, the rest of the forms are
+ evaluated as a PROGN."
+ `(cond ((not ,test) nil ,@forms)))
+(defmacro-mundanely and (&rest forms)
+ (cond ((endp forms) t)
+ ((endp (rest forms)) (first forms))
+ (t
+ `(if ,(first forms)
+ (and ,@(rest forms))
+ nil))))
+(defmacro-mundanely or (&rest forms)
+ (cond ((endp forms) nil)
+ ((endp (rest forms)) (first forms))
+ (t
+ (let ((n-result (gensym)))
+ `(let ((,n-result ,(first forms)))
+ (if ,n-result
+ ,n-result
+ (or ,@(rest forms))))))))
+\f
+;;;; various sequencing constructs
+
+(defmacro-mundanely prog (varlist &body body-decls)
+ (multiple-value-bind (body decls) (parse-body body-decls nil)
+ `(block nil
+ (let ,varlist
+ ,@decls
+ (tagbody ,@body)))))
+
+(defmacro-mundanely prog* (varlist &body body-decls)
+ (multiple-value-bind (body decls) (parse-body body-decls nil)
+ `(block nil
+ (let* ,varlist
+ ,@decls
+ (tagbody ,@body)))))
+
+(defmacro-mundanely prog1 (result &body body)
+ (let ((n-result (gensym)))
+ `(let ((,n-result ,result))
+ ,@body
+ ,n-result)))
+
+(defmacro-mundanely prog2 (form1 result &body body)
+ `(prog1 (progn ,form1 ,result) ,@body))
+\f
+;;; Now that we have the definition of MULTIPLE-VALUE-BIND, we can make a
+;;; reasonably readable definition of DEFUN.
+;;;
+;;; DEFUN expands into %DEFUN which is a function that is treated
+;;; magically by the compiler (through an IR1 transform) in order to
+;;; handle stuff like inlining. After the compiler has gotten the
+;;; information it wants out of macro definition, it compiles a call
+;;; to %%DEFUN which happens at load time.
+(defmacro-mundanely defun (&whole whole name args &body body)
+ (multiple-value-bind (forms decls doc) (parse-body body)
+ (let ((def `(lambda ,args
+ ,@decls
+ (block ,(function-name-block-name name)
+ ,@forms))))
+ `(sb!c::%defun ',name #',def ,doc ',whole))))
+#+sb-xc-host (/show "before PROCLAIM" (sb!c::info :function :kind 'sb!c::%%defun))
+#+sb-xc-host (sb!xc:proclaim '(ftype function sb!c::%%defun)) ; to avoid
+ ; undefined function warnings
+#+sb-xc-host (/show "after PROCLAIM" (sb!c::info :function :kind 'sb!c::%%defun))
+(defun sb!c::%%defun (name def doc &optional inline-expansion)
+ (when (fboundp name)
+ (style-warn "redefining ~S in DEFUN" name))
+ (setf (sb!xc:fdefinition name) def)
+ (when doc
+ ;; FIXME: This should use shared SETF-name parsing logic.
+ (if (and (consp name) (eq (first name) 'setf))
+ (setf (fdocumentation (second name) 'setf) doc)
+ (setf (fdocumentation name 'function) doc)))
+ (sb!c::proclaim-as-function-name name)
+ (if (eq (info :function :where-from name) :assumed)
+ (progn
+ (setf (info :function :where-from name) :defined)
+ (if (info :function :assumed-type name)
+ (setf (info :function :assumed-type name) nil))))
+ (when (or inline-expansion
+ (info :function :inline-expansion name))
+ (setf (info :function :inline-expansion name)
+ inline-expansion))
+ name)
+;;; Ordinarily this definition of SB!C:%DEFUN as an ordinary function is not
+;;; used: the parallel (but different) definition as an IR1 transform takes
+;;; precedence. However, it's still good to define this in order to keep the
+;;; interpreter happy. We define it here (instead of alongside the parallel
+;;; IR1 transform) because while the IR1 transform is needed and appropriate
+;;; in the cross-compiler running in the host Common Lisp, this parallel
+;;; ordinary function definition is only appropriate in the target Lisp.
+(defun sb!c::%defun (name def doc source)
+ (declare (ignore source))
+ (setf (sb!eval:interpreted-function-name def) name)
+ (sb!c::%%defun name def doc))
+\f
+;;;; DEFVAR and DEFPARAMETER
+
+(defmacro-mundanely defvar (var &optional (val nil valp) (doc nil docp))
+ #!+sb-doc
+ "For defining global variables at top level. Declares the variable
+ SPECIAL and, optionally, initializes it. If the variable already has a
+ value, the old value is not clobbered. The third argument is an optional
+ documentation string for the variable."
+ `(progn
+ (declaim (special ,var))
+ ,@(when valp
+ `((unless (boundp ',var)
+ (setq ,var ,val))))
+ ,@(when docp
+ `((funcall #'(setf fdocumentation) ',doc ',var 'variable)))
+ ',var))
+
+(defmacro-mundanely defparameter (var val &optional (doc nil docp))
+ #!+sb-doc
+ "Defines a parameter that is not normally changed by the program,
+ but that may be changed without causing an error. Declares the
+ variable special and sets its value to VAL. The third argument is
+ an optional documentation string for the parameter."
+ `(progn
+ (declaim (special ,var))
+ (setq ,var ,val)
+ ,@(when docp
+ ;; FIXME: The various FUNCALL #'(SETF FDOCUMENTATION) and
+ ;; other FUNCALL #'(SETF FOO) forms in the code should
+ ;; unbogobootstrapized back to ordinary SETF forms.
+ `((funcall #'(setf fdocumentation) ',doc ',var 'variable)))
+ ',var))
+\f
+;;;; iteration constructs
+
+;;; (These macros are defined in terms of a function DO-DO-BODY which is also
+;;; used by SB!INT:DO-ANONYMOUS. Since these macros should not be loaded
+;;; on the cross-compilation host, but SB!INT:DO-ANONYMOUS and DO-DO-BODY
+;;; should be, these macros can't conveniently be in the same file as
+;;; DO-DO-BODY.)
+(defmacro-mundanely do (varlist endlist &body body)
+ #!+sb-doc
+ "DO ({(Var [Init] [Step])}*) (Test Exit-Form*) Declaration* Form*
+ Iteration construct. Each Var is initialized in parallel to the value of the
+ specified Init form. On subsequent iterations, the Vars are assigned the
+ value of the Step form (if any) in parallel. The Test is evaluated before
+ each evaluation of the body Forms. When the Test is true, the Exit-Forms
+ are evaluated as a PROGN, with the result being the value of the DO. A block
+ named NIL is established around the entire expansion, allowing RETURN to be
+ used as an alternate exit mechanism."
+ (do-do-body varlist endlist body 'let 'psetq 'do nil))
+(defmacro-mundanely do* (varlist endlist &body body)
+ #!+sb-doc
+ "DO* ({(Var [Init] [Step])}*) (Test Exit-Form*) Declaration* Form*
+ Iteration construct. Each Var is initialized sequentially (like LET*) to the
+ value of the specified Init form. On subsequent iterations, the Vars are
+ sequentially assigned the value of the Step form (if any). The Test is
+ evaluated before each evaluation of the body Forms. When the Test is true,
+ the Exit-Forms are evaluated as a PROGN, with the result being the value
+ of the DO. A block named NIL is established around the entire expansion,
+ allowing RETURN to be used as an laternate exit mechanism."
+ (do-do-body varlist endlist body 'let* 'setq 'do* nil))
+
+;;; DOTIMES and DOLIST could be defined more concisely using destructuring
+;;; macro lambda lists or DESTRUCTURING-BIND, but then it'd be tricky to use
+;;; them before those things were defined. They're used enough times before
+;;; destructuring mechanisms are defined that it looks as though it's worth
+;;; just implementing them ASAP, at the cost of being unable to use the
+;;; standard destructuring mechanisms.
+(defmacro-mundanely dotimes (var-count-result &body body)
+ (multiple-value-bind ; to roll our own destructuring
+ (var count result)
+ (apply (lambda (var count &optional (result nil))
+ (values var count result))
+ var-count-result)
+ (cond ((numberp count)
+ `(do ((,var 0 (1+ ,var)))
+ ((>= ,var ,count) ,result)
+ (declare (type unsigned-byte ,var))
+ ,@body))
+ (t (let ((v1 (gensym)))
+ `(do ((,var 0 (1+ ,var)) (,v1 ,count))
+ ((>= ,var ,v1) ,result)
+ (declare (type unsigned-byte ,var))
+ ,@body))))))
+(defmacro-mundanely dolist (var-list-result &body body)
+ (multiple-value-bind ; to roll our own destructuring
+ (var list result)
+ (apply (lambda (var list &optional (result nil))
+ (values var list result))
+ var-list-result)
+ ;; We repeatedly bind the var instead of setting it so that we never have
+ ;; to give the var an arbitrary value such as NIL (which might conflict
+ ;; with a declaration). If there is a result form, we introduce a
+ ;; gratuitous binding of the variable to NIL w/o the declarations, then
+ ;; evaluate the result form in that environment. We spuriously reference
+ ;; the gratuitous variable, since we don't want to use IGNORABLE on what
+ ;; might be a special var.
+ (let ((n-list (gensym)))
+ `(do ((,n-list ,list (cdr ,n-list)))
+ ((endp ,n-list)
+ ,@(if result
+ `((let ((,var nil))
+ ,var
+ ,result))
+ '(nil)))
+ (let ((,var (car ,n-list)))
+ ,@body)))))
+\f
+;;;; miscellaneous
+
+(defmacro-mundanely return (&optional (value nil))
+ `(return-from nil ,value))
+
+(defmacro-mundanely psetq (&rest pairs)
+ #!+sb-doc
+ "SETQ {var value}*
+ Set the variables to the values, like SETQ, except that assignments
+ happen in parallel, i.e. no assignments take place until all the
+ forms have been evaluated."
+ ;; (This macro is used in the definition of DO, so we can't use DO in the
+ ;; definition of this macro without getting into confusing bootstrap issues.)
+ (prog ((lets nil)
+ (setqs nil)
+ (pairs pairs))
+ :again
+ (when (atom (cdr pairs))
+ (return `(let ,(nreverse lets)
+ (setq ,@(nreverse setqs))
+ nil)))
+ (let ((gen (gensym)))
+ (setq lets (cons `(,gen ,(cadr pairs)) lets)
+ setqs (list* gen (car pairs) setqs)
+ pairs (cddr pairs)))
+ (go :again)))
+
+(defmacro-mundanely lambda (&whole whole args &body body)
+ (declare (ignore args body))
+ `#',whole)
--- /dev/null
+;;;; DEFMACRO machinery
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!IMPL")
+
+(file-comment
+ "$Header$")
+
+;;; the guts of the DEFMACRO macro, pulled out into a separate
+;;; function in order to make it easier to express the common
+;;; bootstrap idiom
+;;; CL:DEFMACRO SB!XC:DEFMACRO
+;;; SB!XC:DEFMACRO CL:DEFMACRO
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defun %expander-for-defmacro (name lambda-list body)
+ (let ((whole (gensym "WHOLE-"))
+ (environment (gensym "ENV-")))
+ (multiple-value-bind (new-body local-decs doc)
+ (parse-defmacro lambda-list whole body name 'defmacro
+ :environment environment)
+ (let ((def `(lambda (,whole ,environment)
+ ,@local-decs
+ (block ,name
+ ,new-body))))
+ `(sb!c::%defmacro ',name #',def ',lambda-list ,doc))))))
+
+;;; Ordinarily this definition of SB!C:%DEFMACRO as an ordinary
+;;; function is not used: the parallel (but different) definition as
+;;; an IR1 transform takes precedence. However, this definition is
+;;; still useful in the target interpreter, and in the
+;;; cross-compilation host.
+(defun sb!c::%defmacro (name definition lambda-list doc)
+ (try-to-rename-interpreted-function-as-macro definition name lambda-list)
+ (sb!c::%%defmacro name definition doc))
+
+;;; (called by SB!C::%DEFMACRO)
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defun sb!c::%%defmacro (name definition doc)
+ ;; Old note (ca. 1985, maybe:-): "Eventually %%DEFMACRO should deal with
+ ;; clearing old compiler information for the functional value."
+ (clear-info :function :where-from name)
+ ;; FIXME: It would be nice to warn about DEFMACRO of an
+ ;; already-defined macro, but that's slightly hard to do because
+ ;; in common usage DEFMACRO is defined at compile time and then
+ ;; redefined at load time. We'd need to make a distinction between
+ ;; the defined-at-compile-time state and the defined-at-load-time
+ ;; state to make this work. (Trying to warn about duplicate DEFTYPEs
+ ;; runs into the same problem.)
+ #+nil (when (sb!xc:macro-function name)
+ (style-warn "redefining ~S in DEFMACRO" name))
+ (setf (sb!xc:macro-function name) definition
+ (fdocumentation name 'function) doc)
+ name))
+
+;;; Parse the definition and make an expander function. The actual
+;;; definition is done by %DEFMACRO which we expand into, and which is
+;;; handled magically by an IR1 transform. After the compiler has
+;;; gotten the information it wants out of macro definition, it
+;;; compiles a call to %%DEFMACRO which happens at load time.
+(defmacro sb!xc:defmacro (name lambda-list &rest body)
+ (%expander-for-defmacro name lambda-list body))
+
+;;; In the cross-compiler, we not only need to support the definition
+;;; of target macros at cross-compiler-build-time (with SB!XC:DEFMACRO
+;;; running in the cross-compilation host), we also need to support
+;;; the definition of target macros at target compilation time (with
+;;; CL:DEFMACRO processed by the cross-compiler)..
+#+sb-xc-host
+(sb!xc:defmacro defmacro (name lambda-list &rest body)
+ (%expander-for-defmacro name lambda-list body))
+
+;;; 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)
+ `(setf (sb!xc:macro-function ',name)
+ ,(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)
+ ,@local-decs
+ (block ,name
+ ,new-body))))))
--- /dev/null
+;;;; the DEFPACKAGE macro
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!IMPL")
+
+(file-comment
+ "$Header$")
+
+(defmacro defpackage (package &rest options)
+ #!+sb-doc
+ "Defines a new package called PACKAGE. Each of OPTIONS should be one of the
+ following:
+ (:NICKNAMES {package-name}*)
+ (:SIZE <integer>)
+ (:SHADOW {symbol-name}*)
+ (:SHADOWING-IMPORT-FROM <package-name> {symbol-name}*)
+ (:USE {package-name}*)
+ (:IMPORT-FROM <package-name> {symbol-name}*)
+ (:INTERN {symbol-name}*)
+ (:EXPORT {symbol-name}*)
+ (:DOCUMENTATION doc-string)
+ All options except :SIZE and :DOCUMENTATION can be used multiple times."
+ (let ((nicknames nil)
+ (size nil)
+ (shadows nil)
+ (shadowing-imports nil)
+ (use nil)
+ (use-p nil)
+ (imports nil)
+ (interns nil)
+ (exports nil)
+ (doc nil))
+ (dolist (option options)
+ (unless (consp option)
+ (error 'program-error
+ :format-control "bogus DEFPACKAGE option: ~S"
+ :format-arguments (list option)))
+ (case (car option)
+ (:nicknames
+ (setf nicknames (stringify-names (cdr option) "package")))
+ (:size
+ (cond (size
+ (error 'program-error
+ :format-control "can't specify :SIZE twice."))
+ ((and (consp (cdr option))
+ (typep (second option) 'unsigned-byte))
+ (setf size (second option)))
+ (t
+ (error
+ 'program-error
+ :format-control ":SIZE is not a positive integer: ~S"
+ :format-arguments (list (second option))))))
+ (:shadow
+ (let ((new (stringify-names (cdr option) "symbol")))
+ (setf shadows (append shadows new))))
+ (:shadowing-import-from
+ (let ((package-name (stringify-name (second option) "package"))
+ (names (stringify-names (cddr option) "symbol")))
+ (let ((assoc (assoc package-name shadowing-imports
+ :test #'string=)))
+ (if assoc
+ (setf (cdr assoc) (append (cdr assoc) names))
+ (setf shadowing-imports
+ (acons package-name names shadowing-imports))))))
+ (:use
+ (setf use (append use (stringify-names (cdr option) "package") )
+ use-p t))
+ (:import-from
+ (let ((package-name (stringify-name (second option) "package"))
+ (names (stringify-names (cddr option) "symbol")))
+ (let ((assoc (assoc package-name imports
+ :test #'string=)))
+ (if assoc
+ (setf (cdr assoc) (append (cdr assoc) names))
+ (setf imports (acons package-name names imports))))))
+ (:intern
+ (let ((new (stringify-names (cdr option) "symbol")))
+ (setf interns (append interns new))))
+ (:export
+ (let ((new (stringify-names (cdr option) "symbol")))
+ (setf exports (append exports new))))
+ (:documentation
+ (when doc
+ (error 'program-error
+ :format-control "multiple :DOCUMENTATION options"))
+ (setf doc (coerce (second option) 'simple-string)))
+ (t
+ (error 'program-error
+ :format-control "bogus DEFPACKAGE option: ~S"
+ :format-arguments (list option)))))
+ (check-disjoint `(:intern ,@interns) `(:export ,@exports))
+ (check-disjoint `(:intern ,@interns)
+ `(:import-from
+ ,@(apply #'append (mapcar #'rest imports)))
+ `(:shadow ,@shadows)
+ `(:shadowing-import-from
+ ,@(apply #'append (mapcar #'rest shadowing-imports))))
+ `(eval-when (:compile-toplevel :load-toplevel :execute)
+ (%defpackage ,(stringify-name package "package") ',nicknames ',size
+ ',shadows ',shadowing-imports ',(if use-p use :default)
+ ',imports ',interns ',exports ',doc))))
+
+(defun check-disjoint (&rest args)
+ ;; An arg is (:key . set)
+ (do ((list args (cdr list)))
+ ((endp list))
+ (loop
+ with x = (car list)
+ for y in (rest list)
+ for z = (remove-duplicates (intersection (cdr x)(cdr y) :test #'string=))
+ when z do (error 'program-error
+ :format-control "Parameters ~S and ~S must be disjoint ~
+ but have common elements ~% ~S"
+ :format-arguments (list (car x)(car y) z)))))
+
+(defun stringify-name (name kind)
+ (typecase name
+ (simple-string name)
+ (string (coerce name 'simple-string))
+ (symbol (symbol-name name))
+ (base-char (string name))
+ (t
+ (error "bogus ~A name: ~S" kind name))))
+
+(defun stringify-names (names kind)
+ (mapcar #'(lambda (name)
+ (stringify-name name kind))
+ names))
+
+(defun %defpackage (name nicknames size shadows shadowing-imports
+ use imports interns exports doc-string)
+ (declare (type simple-base-string name)
+ (type list nicknames shadows shadowing-imports
+ imports interns exports)
+ (type (or list (member :default)) use)
+ (type (or simple-base-string null) doc-string))
+ (let ((package (or (find-package name)
+ (progn
+ (when (eq use :default)
+ (setf use *default-package-use-list*))
+ (make-package name
+ :use nil
+ :internal-symbols (or size 10)
+ :external-symbols (length exports))))))
+ (unless (string= (the string (package-name package)) name)
+ (error 'simple-package-error
+ :package name
+ :format-control "~A is a nickname for the package ~A"
+ :format-arguments (list name (package-name name))))
+ (enter-new-nicknames package nicknames)
+ ;; Handle shadows and shadowing-imports.
+ (let ((old-shadows (package-%shadowing-symbols package)))
+ (shadow shadows package)
+ (dolist (sym-name shadows)
+ (setf old-shadows (remove (find-symbol sym-name package) old-shadows)))
+ (dolist (simports-from shadowing-imports)
+ (let ((other-package (find-undeleted-package-or-lose
+ (car simports-from))))
+ (dolist (sym-name (cdr simports-from))
+ (let ((sym (find-or-make-symbol sym-name other-package)))
+ (shadowing-import sym package)
+ (setf old-shadows (remove sym old-shadows))))))
+ (when old-shadows
+ (warn "~A also shadows the following symbols:~% ~S"
+ name old-shadows)))
+ ;; Handle USE.
+ (unless (eq use :default)
+ (let ((old-use-list (package-use-list package))
+ (new-use-list (mapcar #'find-undeleted-package-or-lose use)))
+ (use-package (set-difference new-use-list old-use-list) package)
+ (let ((laterize (set-difference old-use-list new-use-list)))
+ (when laterize
+ (unuse-package laterize package)
+ (warn "~A used to use the following packages:~% ~S"
+ name
+ laterize)))))
+ ;; Handle IMPORT and INTERN.
+ (dolist (sym-name interns)
+ (intern sym-name package))
+ (dolist (imports-from imports)
+ (let ((other-package (find-undeleted-package-or-lose (car
+ imports-from))))
+ (dolist (sym-name (cdr imports-from))
+ (import (list (find-or-make-symbol sym-name other-package))
+ package))))
+ ;; Handle exports.
+ (let ((old-exports nil)
+ (exports (mapcar #'(lambda (sym-name) (intern sym-name package))
+ exports)))
+ (do-external-symbols (sym package)
+ (push sym old-exports))
+ (export exports package)
+ (let ((diff (set-difference old-exports exports)))
+ (when diff
+ (warn "~A also exports the following symbols:~% ~S" name diff))))
+ ;; Handle documentation.
+ (setf (package-doc-string package) doc-string)
+ package))
+
+(defun find-or-make-symbol (name package)
+ (multiple-value-bind (symbol how) (find-symbol name package)
+ (cond (how
+ symbol)
+ (t
+ (with-simple-restart (continue "INTERN it.")
+ (error 'simple-package-error
+ :package package
+ :format-control "no symbol named ~S in ~S"
+ :format-arguments (list name (package-name package))))
+ (intern name package)))))
--- /dev/null
+;;;; various DEFSETFs, pulled into one file for convenience in doing
+;;;; them as early in the build process as possible so as to avoid
+;;;; hassles with invoking SETF FOO before DEFSETF FOO and thus
+;;;; compiling a call to some nonexistent function #'(SETF FOO)
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(sb!int:file-comment
+ "$Header$")
+
+(sb!int:/show0 "entering defsetfs.lisp")
+
+;;; from alieneval.lisp
+(in-package "SB!ALIEN")
+(defsetf slot %set-slot)
+(defsetf deref (alien &rest indices) (value)
+ `(%set-deref ,alien ,value ,@indices))
+(defsetf %heap-alien %set-heap-alien)
+
+;;; from bignum.lisp
+(in-package "SB!BIGNUM")
+(defsetf %bignum-ref %bignum-set)
+
+;;; from bit-bash.lisp
+(in-package "SB!VM")
+(defsetf word-sap-ref %set-word-sap-ref)
+
+;;; from debug-int.lisp
+(in-package "SB!DI")
+(defsetf stack-ref %set-stack-ref)
+(defsetf debug-var-value %set-debug-var-value)
+(defsetf debug-var-value %set-debug-var-value)
+(defsetf breakpoint-info %set-breakpoint-info)
+
+;;; from defstruct.lisp
+(in-package "SB!KERNEL")
+(defsetf %instance-ref %instance-set)
+(defsetf %raw-ref-single %raw-set-single)
+(defsetf %raw-ref-double %raw-set-double)
+#!+long-float
+(defsetf %raw-ref-long %raw-set-long)
+(defsetf %raw-ref-complex-single %raw-set-complex-single)
+(defsetf %raw-ref-complex-double %raw-set-complex-double)
+#!+long-float
+(defsetf %raw-ref-complex-long %raw-set-complex-long)
+(defsetf %instance-layout %set-instance-layout)
+(defsetf %funcallable-instance-info %set-funcallable-instance-info)
+
+;;; from early-setf.lisp
+(in-package "SB!IMPL")
+
+;;; KLUDGE: Various of these (e.g. AREF and BIT) have DEFUN (SETF FOO) versions
+;;; too. Do we really need both? -- WHN 19990921
+#-sb-xc-host (defsetf car %rplaca)
+#-sb-xc-host (defsetf cdr %rplacd)
+#-sb-xc-host (defsetf caar (x) (v) `(%rplaca (car ,x) ,v))
+#-sb-xc-host (defsetf cadr (x) (v) `(%rplaca (cdr ,x) ,v))
+#-sb-xc-host (defsetf cdar (x) (v) `(%rplacd (car ,x) ,v))
+#-sb-xc-host (defsetf cddr (x) (v) `(%rplacd (cdr ,x) ,v))
+#-sb-xc-host (defsetf caaar (x) (v) `(%rplaca (caar ,x) ,v))
+#-sb-xc-host (defsetf cadar (x) (v) `(%rplaca (cdar ,x) ,v))
+#-sb-xc-host (defsetf cdaar (x) (v) `(%rplacd (caar ,x) ,v))
+#-sb-xc-host (defsetf cddar (x) (v) `(%rplacd (cdar ,x) ,v))
+#-sb-xc-host (defsetf caadr (x) (v) `(%rplaca (cadr ,x) ,v))
+#-sb-xc-host (defsetf caddr (x) (v) `(%rplaca (cddr ,x) ,v))
+#-sb-xc-host (defsetf cdadr (x) (v) `(%rplacd (cadr ,x) ,v))
+#-sb-xc-host (defsetf cdddr (x) (v) `(%rplacd (cddr ,x) ,v))
+#-sb-xc-host (defsetf caaaar (x) (v) `(%rplaca (caaar ,x) ,v))
+#-sb-xc-host (defsetf cadaar (x) (v) `(%rplaca (cdaar ,x) ,v))
+#-sb-xc-host (defsetf cdaaar (x) (v) `(%rplacd (caaar ,x) ,v))
+#-sb-xc-host (defsetf cddaar (x) (v) `(%rplacd (cdaar ,x) ,v))
+#-sb-xc-host (defsetf caadar (x) (v) `(%rplaca (cadar ,x) ,v))
+#-sb-xc-host (defsetf caddar (x) (v) `(%rplaca (cddar ,x) ,v))
+#-sb-xc-host (defsetf cdadar (x) (v) `(%rplacd (cadar ,x) ,v))
+#-sb-xc-host (defsetf cdddar (x) (v) `(%rplacd (cddar ,x) ,v))
+#-sb-xc-host (defsetf caaadr (x) (v) `(%rplaca (caadr ,x) ,v))
+#-sb-xc-host (defsetf cadadr (x) (v) `(%rplaca (cdadr ,x) ,v))
+#-sb-xc-host (defsetf cdaadr (x) (v) `(%rplacd (caadr ,x) ,v))
+#-sb-xc-host (defsetf cddadr (x) (v) `(%rplacd (cdadr ,x) ,v))
+#-sb-xc-host (defsetf caaddr (x) (v) `(%rplaca (caddr ,x) ,v))
+#-sb-xc-host (defsetf cadddr (x) (v) `(%rplaca (cdddr ,x) ,v))
+#-sb-xc-host (defsetf cdaddr (x) (v) `(%rplacd (caddr ,x) ,v))
+#-sb-xc-host (defsetf cddddr (x) (v) `(%rplacd (cdddr ,x) ,v))
+#-sb-xc-host (defsetf first %rplaca)
+#-sb-xc-host (defsetf second (x) (v) `(%rplaca (cdr ,x) ,v))
+#-sb-xc-host (defsetf third (x) (v) `(%rplaca (cddr ,x) ,v))
+#-sb-xc-host (defsetf fourth (x) (v) `(%rplaca (cdddr ,x) ,v))
+#-sb-xc-host (defsetf fifth (x) (v) `(%rplaca (cddddr ,x) ,v))
+#-sb-xc-host (defsetf sixth (x) (v) `(%rplaca (cdr (cddddr ,x)) ,v))
+#-sb-xc-host (defsetf seventh (x) (v) `(%rplaca (cddr (cddddr ,x)) ,v))
+#-sb-xc-host (defsetf eighth (x) (v) `(%rplaca (cdddr (cddddr ,x)) ,v))
+#-sb-xc-host (defsetf ninth (x) (v) `(%rplaca (cddddr (cddddr ,x)) ,v))
+#-sb-xc-host (defsetf tenth (x) (v) `(%rplaca (cdr (cddddr (cddddr ,x))) ,v))
+#-sb-xc-host (defsetf rest %rplacd)
+#-sb-xc-host (defsetf elt %setelt)
+#-sb-xc-host (defsetf aref %aset)
+#-sb-xc-host (defsetf row-major-aref %set-row-major-aref)
+#-sb-xc-host (defsetf svref %svset)
+#-sb-xc-host (defsetf char %charset)
+#-sb-xc-host (defsetf bit %bitset)
+#-sb-xc-host (defsetf schar %scharset)
+#-sb-xc-host (defsetf sbit %sbitset)
+(defsetf %array-dimension %set-array-dimension)
+(defsetf sb!kernel:%raw-bits sb!kernel:%set-raw-bits)
+#-sb-xc-host (defsetf symbol-value set)
+#-sb-xc-host (defsetf symbol-function fset)
+#-sb-xc-host (defsetf symbol-plist %set-symbol-plist)
+#-sb-xc-host (defsetf nth %setnth)
+#-sb-xc-host (defsetf fill-pointer %set-fill-pointer)
+(defsetf search-list %set-search-list)
+(defsetf sap-ref-8 %set-sap-ref-8)
+(defsetf signed-sap-ref-8 %set-signed-sap-ref-8)
+(defsetf sap-ref-16 %set-sap-ref-16)
+(defsetf signed-sap-ref-16 %set-signed-sap-ref-16)
+(defsetf sap-ref-32 %set-sap-ref-32)
+(defsetf signed-sap-ref-32 %set-signed-sap-ref-32)
+#!+alpha (defsetf sap-ref-64 %set-sap-ref-64)
+#!+alpha (defsetf signed-sap-ref-64 %set-signed-sap-ref-64)
+(defsetf sap-ref-sap %set-sap-ref-sap)
+(defsetf sap-ref-single %set-sap-ref-single)
+(defsetf sap-ref-double %set-sap-ref-double)
+#!+long-float (defsetf sap-ref-long %set-sap-ref-long)
+#-sb-xc-host (defsetf subseq (sequence start &optional (end nil)) (v)
+ `(progn (replace ,sequence ,v :start1 ,start :end1 ,end)
+ ,v))
+
+;;; from fdefinition.lisp
+(in-package "SB!IMPL")
+#-sb-xc-host (defsetf fdefinition %set-fdefinition)
+
+;;; from filesys.lisp
+(in-package "SB!IMPL")
+(defsetf default-directory %set-default-directory)
+
+;;; from kernel.lisp
+(in-package "SB!KERNEL")
+(defsetf code-header-ref code-header-set)
+(defsetf %raw-bits %set-raw-bits)
+
+;;; from serve-event.lisp
+(in-package "SB!IMPL")
+(defsetf object-set-operation %set-object-set-operation
+ #!+sb-doc
+ "Set the handler function for an object set operation.")
+
+;;; from unix.lisp
+(in-package "SB!UNIX")
+(defsetf tty-process-group (&optional fd) (pgrp)
+ #!+sb-doc
+ "Set the tty-process-group for the unix file-descriptor FD to PGRP. If not
+ supplied, FD defaults to /dev/tty."
+ `(%set-tty-process-group ,pgrp ,fd))
+
+;;; from x86-vm.lisp
+(in-package "SB!VM")
+(defsetf context-register %set-context-register)
+(defsetf context-float-register %set-context-float-register)
+
+(sb!int:/show0 "leaving defsetfs.lisp")
--- /dev/null
+;;;; that part of DEFSTRUCT implementation which is needed not just
+;;;; in the target Lisp but also in the cross-compilation host
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!KERNEL")
+
+(file-comment
+ "$Header$")
+\f
+;;;; getting LAYOUTs
+
+;;; Return the compiler layout for Name. (The class referred to by
+;;; NAME must be a structure-like class.)
+(defun compiler-layout-or-lose (name)
+ (let ((res (info :type :compiler-layout name)))
+ (cond ((not res)
+ (error "Class is not yet defined or was undefined: ~S" name))
+ ((not (typep (layout-info res) 'defstruct-description))
+ (error "Class is not a structure class: ~S" name))
+ (t res))))
+
+;;; Delay looking for compiler-layout until the constructor is being
+;;; compiled, since it doesn't exist until after the eval-when
+;;; (compile) is compiled.
+(sb!xc:defmacro %delayed-get-compiler-layout (name)
+ `',(compiler-layout-or-lose name))
+
+;;; Get layout right away.
+(sb!xc:defmacro compile-time-find-layout (name)
+ (find-layout name))
+
+;;; re. %DELAYED-GET-COMPILER-LAYOUT and COMPILE-TIME-FIND-LAYOUT, above..
+;;;
+;;; FIXME: Perhaps both should be defined with DEFMACRO-MUNDANELY?
+;;; FIXME: Do we really need both? If so, their names and implementations
+;;; should probably be tweaked to be more parallel.
+\f
+;;; The DEFSTRUCT-DESCRIPTION structure holds compile-time information about a
+;;; structure type.
+(def!struct (defstruct-description
+ (:conc-name dd-)
+ (:make-load-form-fun just-dump-it-normally)
+ #-sb-xc-host (:pure t)
+ (:constructor make-defstruct-description (name)))
+ ;; name of the structure
+ (name (required-argument) :type symbol)
+ ;; documentation on the structure
+ (doc nil :type (or string null))
+ ;; prefix for slot names. If NIL, none.
+ (conc-name (concat-pnames name '-) :type (or symbol null))
+ ;; the name of the primary standard keyword constructor, or NIL if none
+ (default-constructor nil :type (or symbol null))
+ ;; all the explicit :CONSTRUCTOR specs, with name defaulted
+ (constructors () :type list)
+ ;; name of copying function
+ (copier (concat-pnames 'copy- name) :type (or symbol null))
+ ;; name of type predicate
+ (predicate (concat-pnames name '-p) :type (or symbol null))
+ ;; the arguments to the :INCLUDE option, or NIL if no included
+ ;; structure
+ (include nil :type list)
+ ;; The arguments to the :ALTERNATE-METACLASS option (an extension
+ ;; used to define structure-like objects with an arbitrary
+ ;; superclass and that may not have STRUCTURE-CLASS as the
+ ;; metaclass.) Syntax is:
+ ;; (superclass-name metaclass-name metaclass-constructor)
+ (alternate-metaclass nil :type list)
+ ;; a list of DEFSTRUCT-SLOT-DESCRIPTION objects for all slots
+ ;; (including included ones)
+ (slots () :type list)
+ ;; number of elements we've allocated (See also RAW-LENGTH.)
+ (length 0 :type index)
+ ;; General kind of implementation.
+ (type 'structure :type (member structure vector list
+ funcallable-structure))
+
+ ;; The next three slots are for :TYPE'd structures (which aren't
+ ;; classes, CLASS-STRUCTURE-P = NIL)
+ ;;
+ ;; vector element type
+ (element-type 't)
+ ;; T if :NAMED was explicitly specified, NIL otherwise
+ (named nil :type boolean)
+ ;; any INITIAL-OFFSET option on this direct type
+ (offset nil :type (or index null))
+
+ ;; the argument to the PRINT-FUNCTION option, or NIL if a
+ ;; PRINT-FUNCTION option was given with no argument, or 0 if no
+ ;; PRINT-FUNCTION option was given
+ (print-function 0 :type (or cons symbol (member 0)))
+ ;; the argument to the PRINT-OBJECT option, or NIL if a PRINT-OBJECT
+ ;; option was given with no argument, or 0 if no PRINT-OBJECT option
+ ;; was given
+ (print-object 0 :type (or cons symbol (member 0)))
+ ;; the index of the raw data vector and the number of words in it.
+ ;; NIL and 0 if not allocated yet.
+ (raw-index nil :type (or index null))
+ (raw-length 0 :type index)
+ ;; the value of the :PURE option, or :UNSPECIFIED. This is only
+ ;; meaningful if CLASS-STRUCTURE-P = T.
+ (pure :unspecified :type (member t nil :substructure :unspecified)))
+(def!method print-object ((x defstruct-description) stream)
+ (print-unreadable-object (x stream :type t)
+ (prin1 (dd-name x) stream)))
+
+;;; A DEFSTRUCT-SLOT-DESCRIPTION holds compile-time information about
+;;; a structure slot.
+(def!struct (defstruct-slot-description
+ (:make-load-form-fun just-dump-it-normally)
+ (:conc-name dsd-)
+ (:copier nil)
+ #-sb-xc-host (:pure t))
+ ;; string name of slot
+ %name
+ ;; its position in the implementation sequence
+ (index (required-argument) :type fixnum)
+ ;; Name of accessor, or NIL if this accessor has the same name as an
+ ;; inherited accessor (which we don't want to shadow.)
+ (accessor nil)
+ default ; default value expression
+ (type t) ; declared type specifier
+ ;; If this object does not describe a raw slot, this value is T.
+ ;;
+ ;; If this object describes a raw slot, this value is the type of the
+ ;; value that the raw slot holds. Mostly. (KLUDGE: If the raw slot has
+ ;; type (UNSIGNED-BYTE 32), the value here is UNSIGNED-BYTE, not
+ ;; (UNSIGNED-BYTE 32).)
+ (raw-type t :type (member t single-float double-float
+ #!+long-float long-float
+ complex-single-float complex-double-float
+ #!+long-float complex-long-float
+ unsigned-byte))
+ (read-only nil :type (member t nil)))
+(def!method print-object ((x defstruct-slot-description) stream)
+ (print-unreadable-object (x stream :type t)
+ (prin1 (dsd-name x) stream)))
+
+;;; Is DEFSTRUCT a structure with a class?
+(defun class-structure-p (defstruct)
+ (member (dd-type defstruct) '(structure funcallable-structure)))
+
+;;; Return the name of a defstruct slot as a symbol. We store it as a
+;;; string to avoid creating lots of worthless symbols at load time.
+(defun dsd-name (dsd)
+ (intern (string (dsd-%name dsd))
+ (if (dsd-accessor dsd)
+ (symbol-package (dsd-accessor dsd))
+ *package*)))
+\f
+;;;; typed (non-class) structures
+
+;;; Return a type specifier we can use for testing :TYPE'd structures.
+(defun dd-lisp-type (defstruct)
+ (ecase (dd-type defstruct)
+ (list 'list)
+ (vector `(simple-array ,(dd-element-type defstruct) (*)))))
+\f
+;;;; the legendary DEFSTRUCT macro itself (both CL:DEFSTRUCT and its
+;;;; close personal friend SB!XC:DEFSTRUCT)
+
+;;; Return a list of forms to install print and make-load-form funs, mentioning
+;;; them in the expansion so that they can be compiled.
+(defun class-method-definitions (defstruct)
+ (let ((name (dd-name defstruct)))
+ `((locally
+ ;; KLUDGE: There's a FIND-CLASS DEFTRANSFORM for constant
+ ;; class names which creates fast but non-cold-loadable,
+ ;; non-compact code. In this context, we'd rather have
+ ;; compact, cold-loadable code. -- WHN 19990928
+ (declare (notinline sb!xc:find-class))
+ ,@(let ((pf (dd-print-function defstruct))
+ (po (dd-print-object defstruct))
+ (x (gensym))
+ (s (gensym)))
+ ;; Giving empty :PRINT-OBJECT or :PRINT-FUNCTION options
+ ;; leaves PO or PF equal to NIL. The user-level effect is
+ ;; to generate a PRINT-OBJECT method specialized for the type,
+ ;; implementing the default #S structure-printing behavior.
+ (when (or (eq pf nil) (eq po nil))
+ (setf pf '(default-structure-print)
+ po 0))
+ (flet (;; Given an arg from a :PRINT-OBJECT or :PRINT-FUNCTION
+ ;; option, return the value to pass as an arg to FUNCTION.
+ (farg (oarg)
+ (destructuring-bind (function-name) oarg
+ function-name)))
+ (cond ((not (eql pf 0))
+ `((def!method print-object ((,x ,name) ,s)
+ (funcall #',(farg pf) ,x ,s *current-level*))))
+ ((not (eql po 0))
+ `((def!method print-object ((,x ,name) ,s)
+ (funcall #',(farg po) ,x ,s))))
+ (t nil))))
+ ,@(let ((pure (dd-pure defstruct)))
+ (cond ((eq pure 't)
+ `((setf (layout-pure (class-layout
+ (sb!xc:find-class ',name)))
+ t)))
+ ((eq pure :substructure)
+ `((setf (layout-pure (class-layout
+ (sb!xc:find-class ',name)))
+ 0)))))
+ ,@(let ((def-con (dd-default-constructor defstruct)))
+ (when (and def-con (not (dd-alternate-metaclass defstruct)))
+ `((setf (structure-class-constructor (sb!xc:find-class ',name))
+ #',def-con))))
+ ;; FIXME: MAKE-LOAD-FORM is supposed to be handled here, too.
+ ))))
+;;; FIXME: I really would like to make structure accessors less special,
+;;; just ordinary inline functions. (Or perhaps inline functions with special
+;;; compact implementations of their expansions, to avoid bloating the system.)
+
+;;; shared logic for CL:DEFSTRUCT and SB!XC:DEFSTRUCT
+;;;
+;;; FIXME: There should be some way to make this not be present in the
+;;; target executable, with EVAL-WHEN (COMPILE EXECUTE) and all that good
+;;; stuff, but for now I can't be bothered because of the messiness of
+;;; using CL:DEFMACRO in one case and SB!XC:DEFMACRO in another case.
+;;; Perhaps I could dodge this by defining it as an inline function instead?
+;;; Or perhaps just use MACROLET? I tried MACROLET and got nowhere and thought
+;;; I was tripping over either a compiler bug or ANSI weirdness, but this
+;;; test case seems to work in Debian CMU CL 2.4.9:
+;;; (macrolet ((emit-printer () ''(print "********")))
+;;; (defmacro fizz () (emit-printer)))
+;;; giving
+;;; * (fizz)
+;;; "********"
+;;; "********"
+;;; *
+(defmacro expander-for-defstruct (name-and-options
+ slot-descriptions
+ expanding-into-code-for-xc-host-p)
+ `(let ((name-and-options ,name-and-options)
+ (slot-descriptions ,slot-descriptions)
+ (expanding-into-code-for-xc-host-p
+ ,expanding-into-code-for-xc-host-p))
+ (let* ((dd (parse-name-and-options-and-slot-descriptions
+ name-and-options
+ slot-descriptions))
+ (name (dd-name dd)))
+ (if (class-structure-p dd)
+ (let ((inherits (inherits-for-structure dd)))
+ `(progn
+ (eval-when (:compile-toplevel :load-toplevel :execute)
+ (%compiler-only-defstruct ',dd ',inherits))
+ (%defstruct ',dd ',inherits)
+ ,@(when (eq (dd-type dd) 'structure)
+ `((%compiler-defstruct ',dd)))
+ ,@(unless expanding-into-code-for-xc-host-p
+ (append (raw-accessor-definitions dd)
+ (predicate-definitions dd)
+ ;; FIXME: We've inherited from CMU CL nonparallel
+ ;; code for creating copiers for typed and untyped
+ ;; structures. This should be fixed.
+ ;(copier-definition dd)
+ (constructor-definitions dd)
+ (class-method-definitions dd)))
+ ',name))
+ `(progn
+ (eval-when (:compile-toplevel :load-toplevel :execute)
+ (setf (info :typed-structure :info ',name) ',dd))
+ ,@(unless expanding-into-code-for-xc-host-p
+ (append (typed-accessor-definitions dd)
+ (typed-predicate-definitions dd)
+ (typed-copier-definitions dd)
+ (constructor-definitions dd)))
+ ',name)))))
+
+(sb!xc:defmacro defstruct (name-and-options &rest slot-descriptions)
+ #!+sb-doc
+ "DEFSTRUCT {Name | (Name Option*)} {Slot | (Slot [Default] {Key Value}*)}
+ Define the structure type Name. Instances are created by MAKE-<name>, which
+ takes keyword arguments allowing initial slot values to the specified.
+ A SETF'able function <name>-<slot> is defined for each slot to read and
+ write slot values. <name>-p is a type predicate.
+
+ Popular DEFSTRUCT options (see manual for others):
+
+ (:CONSTRUCTOR Name)
+ (:PREDICATE Name)
+ Specify the name for the constructor or predicate.
+
+ (:CONSTRUCTOR Name Lambda-List)
+ Specify the name and arguments for a BOA constructor
+ (which is more efficient when keyword syntax isn't necessary.)
+
+ (:INCLUDE Supertype Slot-Spec*)
+ Make this type a subtype of the structure type Supertype. The optional
+ Slot-Specs override inherited slot options.
+
+ Slot options:
+
+ :TYPE Type-Spec
+ Asserts that the value of this slot is always of the specified type.
+
+ :READ-ONLY {T | NIL}
+ If true, no setter function is defined for this slot."
+ (expander-for-defstruct name-and-options slot-descriptions nil))
+#+sb-xc-host
+(defmacro sb!xc:defstruct (name-and-options &rest slot-descriptions)
+ #!+sb-doc
+ "Cause information about a target structure to be built into the
+ cross-compiler."
+ (expander-for-defstruct name-and-options slot-descriptions t))
+\f
+;;;; functions to create various parts of DEFSTRUCT definitions
+
+;;; Catch requests to mess up definitions in COMMON-LISP.
+#-sb-xc-host
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defun protect-cl (symbol)
+ (when (and *cold-init-complete-p*
+ (eq (symbol-package symbol) *cl-package*))
+ (cerror "Go ahead and patch the system."
+ "attempting to modify a symbol in the COMMON-LISP package: ~S"
+ symbol))))
+
+;;; Return forms to define readers and writers for raw slots as inline
+;;; functions.
+(defun raw-accessor-definitions (dd)
+ (let* ((name (dd-name dd)))
+ (collect ((res))
+ (dolist (slot (dd-slots dd))
+ (let ((stype (dsd-type slot))
+ (accname (dsd-accessor slot))
+ (argname (gensym "ARG"))
+ (nvname (gensym "NEW-VALUE-")))
+ (multiple-value-bind (accessor offset data)
+ (slot-accessor-form dd slot argname)
+ ;; When accessor exists and is raw
+ (when (and accname (not (eq accessor '%instance-ref)))
+ (res `(declaim (inline ,accname)))
+ (res `(declaim (ftype (function (,name) ,stype) ,accname)))
+ (res `(defun ,accname (,argname)
+ (truly-the ,stype (,accessor ,data ,offset))))
+ (unless (dsd-read-only slot)
+ (res `(declaim (inline (setf ,accname))))
+ (res `(declaim (ftype (function (,stype ,name) ,stype)
+ (setf ,accname))))
+ ;; FIXME: I rewrote this somewhat from the CMU CL definition.
+ ;; Do some basic tests to make sure that reading and writing
+ ;; raw slots still works correctly.
+ (res `(defun (setf ,accname) (,nvname ,argname)
+ (setf (,accessor ,data ,offset) ,nvname)
+ ,nvname)))))))
+ (res))))
+
+;;; Return a list of forms which create a predicate for an untyped DEFSTRUCT.
+(defun predicate-definitions (dd)
+ (let ((pred (dd-predicate dd))
+ (argname (gensym)))
+ (when pred
+ (if (eq (dd-type dd) 'funcallable-structure)
+ ;; FIXME: Why does this need to be special-cased for
+ ;; FUNCALLABLE-STRUCTURE? CMU CL did it, but without explanation.
+ ;; Could we do without it? What breaks if we do? Or could we
+ ;; perhaps get by with no predicates for funcallable structures?
+ `((declaim (inline ,pred))
+ (defun ,pred (,argname) (typep ,argname ',(dd-name dd))))
+ `((protect-cl ',pred)
+ (declaim (inline ,pred))
+ (defun ,pred (,argname)
+ (declare (optimize (speed 3) (safety 0)))
+ (typep-to-layout ,argname
+ (compile-time-find-layout ,(dd-name dd)))))))))
+
+;;; Return a list of forms which create a predicate function for a typed
+;;; DEFSTRUCT.
+(defun typed-predicate-definitions (defstruct)
+ (let ((name (dd-name defstruct))
+ (pred (dd-predicate defstruct))
+ (argname (gensym)))
+ (when (and pred (dd-named defstruct))
+ (let ((ltype (dd-lisp-type defstruct)))
+ `((defun ,pred (,argname)
+ (and (typep ,argname ',ltype)
+ (eq (elt (the ,ltype ,argname)
+ ,(cdr (car (last (find-name-indices defstruct)))))
+ ',name))))))))
+
+;;; FIXME: We've inherited from CMU CL code to do typed structure copiers
+;;; in a completely different way than untyped structure copiers. Fix this.
+;;; (This function was my first attempt to fix this, but I stopped before
+;;; figuring out how to install it completely and remove the parallel
+;;; code which simply SETF's the FDEFINITION of the DD-COPIER name.
+#|
+;;; Return the copier definition for an untyped DEFSTRUCT.
+(defun copier-definition (dd)
+ (when (and (dd-copier dd)
+ ;; FUNCALLABLE-STRUCTUREs don't need copiers, and this
+ ;; implementation wouldn't work for them anyway, since
+ ;; COPY-STRUCTURE returns a STRUCTURE-OBJECT and they're not.
+ (not (eq (dd-type info) 'funcallable-structure)))
+ (let ((argname (gensym)))
+ `(progn
+ (protect-cl ',(dd-copier dd))
+ (defun ,(dd-copier dd) (,argname)
+ (declare (type ,(dd-name dd) ,argname))
+ (copy-structure ,argname))))))
+|#
+
+;;; Return a list of forms to create a copier function of a typed DEFSTRUCT.
+(defun typed-copier-definitions (defstruct)
+ (when (dd-copier defstruct)
+ `((setf (fdefinition ',(dd-copier defstruct)) #'copy-seq)
+ (declaim (ftype function ,(dd-copier defstruct))))))
+
+;;; Return a list of function definitions for accessing and setting the
+;;; slots of a typed DEFSTRUCT. The functions are proclaimed to be inline,
+;;; and the types of their arguments and results are declared as well. We
+;;; count on the compiler to do clever things with ELT.
+(defun typed-accessor-definitions (defstruct)
+ (collect ((stuff))
+ (let ((ltype (dd-lisp-type defstruct)))
+ (dolist (slot (dd-slots defstruct))
+ (let ((name (dsd-accessor slot))
+ (index (dsd-index slot))
+ (slot-type `(and ,(dsd-type slot)
+ ,(dd-element-type defstruct))))
+ (stuff `(proclaim '(inline ,name (setf ,name))))
+ ;; FIXME: The arguments in the next two DEFUNs should be
+ ;; gensyms. (Otherwise e.g. if NEW-VALUE happened to be the
+ ;; name of a special variable, things could get weird.)
+ (stuff `(defun ,name (structure)
+ (declare (type ,ltype structure))
+ (the ,slot-type (elt structure ,index))))
+ (unless (dsd-read-only slot)
+ (stuff
+ `(defun (setf ,name) (new-value structure)
+ (declare (type ,ltype structure) (type ,slot-type new-value))
+ (setf (elt structure ,index) new-value)))))))
+ (stuff)))
+\f
+;;;; parsing
+
+(defun require-no-print-options-so-far (defstruct)
+ (unless (and (eql (dd-print-function defstruct) 0)
+ (eql (dd-print-object defstruct) 0))
+ (error "no more than one of the following options may be specified:
+ :PRINT-FUNCTION, :PRINT-OBJECT, :TYPE")))
+
+;;; Parse a single defstruct option and store the results in DEFSTRUCT.
+(defun parse-1-option (option defstruct)
+ (let ((args (rest option))
+ (name (dd-name defstruct)))
+ (case (first option)
+ (:conc-name
+ (destructuring-bind (conc-name) args
+ (setf (dd-conc-name defstruct)
+ (if (symbolp conc-name)
+ conc-name
+ (make-symbol (string conc-name))))))
+ (:constructor
+ (destructuring-bind (&optional (cname (concat-pnames 'make- name))
+ &rest stuff)
+ args
+ (push (cons cname stuff) (dd-constructors defstruct))))
+ (:copier
+ (destructuring-bind (&optional (copier (concat-pnames 'copy- name)))
+ args
+ (setf (dd-copier defstruct) copier)))
+ (:predicate
+ (destructuring-bind (&optional (pred (concat-pnames name '-p))) args
+ (setf (dd-predicate defstruct) pred)))
+ (:include
+ (when (dd-include defstruct)
+ (error "more than one :INCLUDE option"))
+ (setf (dd-include defstruct) args))
+ (:alternate-metaclass
+ (setf (dd-alternate-metaclass defstruct) args))
+ (:print-function
+ (require-no-print-options-so-far defstruct)
+ (setf (dd-print-function defstruct)
+ (the (or symbol cons) args)))
+ (:print-object
+ (require-no-print-options-so-far defstruct)
+ (setf (dd-print-object defstruct)
+ (the (or symbol cons) args)))
+ (:type
+ (destructuring-bind (type) args
+ (cond ((eq type 'funcallable-structure)
+ (setf (dd-type defstruct) type))
+ ((member type '(list vector))
+ (setf (dd-element-type defstruct) 't)
+ (setf (dd-type defstruct) type))
+ ((and (consp type) (eq (first type) 'vector))
+ (destructuring-bind (vector vtype) type
+ (declare (ignore vector))
+ (setf (dd-element-type defstruct) vtype)
+ (setf (dd-type defstruct) 'vector)))
+ (t
+ (error "~S is a bad :TYPE for Defstruct." type)))))
+ (:named
+ (error "The DEFSTRUCT option :NAMED takes no arguments."))
+ (:initial-offset
+ (destructuring-bind (offset) args
+ (setf (dd-offset defstruct) offset)))
+ (:pure
+ (destructuring-bind (fun) args
+ (setf (dd-pure defstruct) fun)))
+ (t (error "unknown DEFSTRUCT option:~% ~S" option)))))
+
+;;; Given name and options, return a DD holding that info.
+(eval-when (:compile-toplevel :load-toplevel :execute)
+(defun parse-name-and-options (name-and-options)
+ (destructuring-bind (name &rest options) name-and-options
+ (let ((defstruct (make-defstruct-description name)))
+ (dolist (option options)
+ (cond ((consp option)
+ (parse-1-option option defstruct))
+ ((eq option :named)
+ (setf (dd-named defstruct) t))
+ ((member option '(:constructor :copier :predicate :named))
+ (parse-1-option (list option) defstruct))
+ (t
+ (error "unrecognized DEFSTRUCT option: ~S" option))))
+
+ (case (dd-type defstruct)
+ (structure
+ (when (dd-offset defstruct)
+ (error ":OFFSET can't be specified unless :TYPE is specified."))
+ (unless (dd-include defstruct)
+ (incf (dd-length defstruct))))
+ (funcallable-structure)
+ (t
+ (require-no-print-options-so-far defstruct)
+ (when (dd-named defstruct)
+ (incf (dd-length defstruct)))
+ (let ((offset (dd-offset defstruct)))
+ (when offset (incf (dd-length defstruct) offset)))))
+
+ (when (dd-include defstruct)
+ (do-inclusion-stuff defstruct))
+
+ defstruct)))
+
+;;; Given name and options and slot descriptions (and possibly doc
+;;; string at the head of slot descriptions) return a DD holding that
+;;; info.
+(defun parse-name-and-options-and-slot-descriptions (name-and-options
+ slot-descriptions)
+ (/noshow "PARSE-NAME-AND-OPTIONS-AND-SLOT-DESCRIPTIONS" name-and-options)
+ (let ((result (parse-name-and-options (if (atom name-and-options)
+ (list name-and-options)
+ name-and-options))))
+ (when (stringp (car slot-descriptions))
+ (setf (dd-doc result) (pop slot-descriptions)))
+ (dolist (slot slot-descriptions)
+ (allocate-1-slot result (parse-1-dsd result slot)))
+ result))
+
+) ; EVAL-WHEN
+\f
+;;;; stuff to parse slot descriptions
+
+;;; Parse a slot description for DEFSTRUCT, add it to the description
+;;; and return it. If supplied, ISLOT is a pre-initialized DSD that we
+;;; modify to get the new slot. This is supplied when handling
+;;; included slots. If the new accessor name is already an accessor
+;;; for same slot in some included structure, then set the
+;;; DSD-ACCESSOR to NIL so that we don't clobber the more general
+;;; accessor.
+(defun parse-1-dsd (defstruct spec &optional
+ (islot (make-defstruct-slot-description :%name ""
+ :index 0
+ :type t)))
+ (multiple-value-bind (name default default-p type type-p read-only ro-p)
+ (cond
+ ((listp spec)
+ (destructuring-bind
+ (name
+ &optional (default nil default-p)
+ &key (type nil type-p) (read-only nil ro-p))
+ spec
+ (values name
+ default default-p
+ (uncross type) type-p
+ read-only ro-p)))
+ (t
+ (when (keywordp spec)
+ ;; FIXME: should be style warning
+ (warn "Keyword slot name indicates probable syntax ~
+ error in DEFSTRUCT -- ~S."
+ spec))
+ spec))
+
+ (when (find name (dd-slots defstruct) :test #'string= :key #'dsd-%name)
+ (error 'program-error
+ :format-control "duplicate slot name ~S"
+ :format-arguments (list name)))
+ (setf (dsd-%name islot) (string name))
+ (setf (dd-slots defstruct) (nconc (dd-slots defstruct) (list islot)))
+
+ (let* ((accname (concat-pnames (dd-conc-name defstruct) name))
+ (existing (info :function :accessor-for accname)))
+ (if (and (structure-class-p existing)
+ (not (eq (sb!xc:class-name existing) (dd-name defstruct)))
+ (string= (dsd-%name (find accname
+ (dd-slots
+ (layout-info
+ (class-layout existing)))
+ :key #'dsd-accessor))
+ name))
+ (setf (dsd-accessor islot) nil)
+ (setf (dsd-accessor islot) accname)))
+
+ (when default-p
+ (setf (dsd-default islot) default))
+ (when type-p
+ (setf (dsd-type islot)
+ (if (eq (dsd-type islot) 't)
+ type
+ `(and ,(dsd-type islot) ,type))))
+ (when ro-p
+ (if read-only
+ (setf (dsd-read-only islot) t)
+ (when (dsd-read-only islot)
+ (error "Slot ~S is :READ-ONLY in parent and must be :READ-ONLY in subtype ~S."
+ name
+ (dsd-name islot)))))
+ islot))
+
+;;; When a value of type TYPE is stored in a structure, should it be
+;;; stored in a raw slot? Return (VALUES RAW? RAW-TYPE WORDS), where
+;;; RAW? is true if TYPE should be stored in a raw slot.
+;;; RAW-TYPE is the raw slot type, or NIL if no raw slot.
+;;; WORDS is the number of words in the raw slot, or NIL if no raw slot.
+(defun structure-raw-slot-type-and-size (type)
+ (/noshow "in STRUCTURE-RAW-SLOT-TYPE-AND-SIZE" type (sb!xc:subtypep type 'fixnum))
+ (cond #+nil
+ (;; FIXME: For now we suppress raw slots, since there are various
+ ;; issues about the way that the cross-compiler handles them.
+ (not (boundp '*dummy-placeholder-to-stop-compiler-warnings*))
+ (values nil nil nil))
+ ((and (sb!xc:subtypep type '(unsigned-byte 32))
+ (multiple-value-bind (fixnum? fixnum-certain?)
+ (sb!xc:subtypep type 'fixnum)
+ (/noshow fixnum? fixnum-certain?)
+ ;; (The extra test for FIXNUM-CERTAIN? here is
+ ;; intended for bootstrapping the system. In
+ ;; particular, in sbcl-0.6.2, we set up LAYOUT before
+ ;; FIXNUM is defined, and so could bogusly end up
+ ;; putting INDEX-typed values into raw slots if we
+ ;; didn't test FIXNUM-CERTAIN?.)
+ (and (not fixnum?) fixnum-certain?)))
+ (values t 'unsigned-byte 1))
+ ((sb!xc:subtypep type 'single-float)
+ (values t 'single-float 1))
+ ((sb!xc:subtypep type 'double-float)
+ (values t 'double-float 2))
+ #!+long-float
+ ((sb!xc:subtypep type 'long-float)
+ (values t 'long-float #!+x86 3 #!+sparc 4))
+ ((sb!xc:subtypep type '(complex single-float))
+ (values t 'complex-single-float 2))
+ ((sb!xc:subtypep type '(complex double-float))
+ (values t 'complex-double-float 4))
+ #!+long-float
+ ((sb!xc:subtypep type '(complex long-float))
+ (values t 'complex-long-float #!+x86 6 #!+sparc 8))
+ (t
+ (values nil nil nil))))
+
+;;; Allocate storage for a DSD in DEFSTRUCT. This is where we decide
+;;; whether a slot is raw or not. If raw, and we haven't allocated a
+;;; raw-index yet for the raw data vector, then do it. Raw objects are
+;;; aligned on the unit of their size.
+(defun allocate-1-slot (defstruct dsd)
+ (multiple-value-bind (raw? raw-type words)
+ (if (eq (dd-type defstruct) 'structure)
+ (structure-raw-slot-type-and-size (dsd-type dsd))
+ (values nil nil nil))
+ (/noshow "ALLOCATE-1-SLOT" dsd raw? raw-type words)
+ (cond ((not raw?)
+ (setf (dsd-index dsd) (dd-length defstruct))
+ (incf (dd-length defstruct)))
+ (t
+ (unless (dd-raw-index defstruct)
+ (setf (dd-raw-index defstruct) (dd-length defstruct))
+ (incf (dd-length defstruct)))
+ (let ((off (rem (dd-raw-length defstruct) words)))
+ (unless (zerop off)
+ (incf (dd-raw-length defstruct) (- words off))))
+ (setf (dsd-raw-type dsd) raw-type)
+ (setf (dsd-index dsd) (dd-raw-length defstruct))
+ (incf (dd-raw-length defstruct) words))))
+ (values))
+
+(defun typed-structure-info-or-lose (name)
+ (or (info :typed-structure :info name)
+ (error ":TYPE'd DEFSTRUCT ~S not found for inclusion." name)))
+
+;;; Process any included slots pretty much like they were specified.
+;;; Also inherit various other attributes.
+(defun do-inclusion-stuff (defstruct)
+ (destructuring-bind
+ (included-name &rest modified-slots)
+ (dd-include defstruct)
+ (let* ((type (dd-type defstruct))
+ (included-structure
+ (if (class-structure-p defstruct)
+ (layout-info (compiler-layout-or-lose included-name))
+ (typed-structure-info-or-lose included-name))))
+ (unless (and (eq type (dd-type included-structure))
+ (type= (specifier-type (dd-element-type included-structure))
+ (specifier-type (dd-element-type defstruct))))
+ (error ":TYPE option mismatch between structures ~S and ~S."
+ (dd-name defstruct) included-name))
+
+ (incf (dd-length defstruct) (dd-length included-structure))
+ (when (class-structure-p defstruct)
+ (let ((mc (rest (dd-alternate-metaclass included-structure))))
+ (when (and mc (not (dd-alternate-metaclass defstruct)))
+ (setf (dd-alternate-metaclass defstruct)
+ (cons included-name mc))))
+ (when (eq (dd-pure defstruct) :unspecified)
+ (setf (dd-pure defstruct) (dd-pure included-structure)))
+ (setf (dd-raw-index defstruct) (dd-raw-index included-structure))
+ (setf (dd-raw-length defstruct) (dd-raw-length included-structure)))
+
+ (dolist (islot (dd-slots included-structure))
+ (let* ((iname (dsd-name islot))
+ (modified (or (find iname modified-slots
+ :key #'(lambda (x) (if (atom x) x (car x)))
+ :test #'string=)
+ `(,iname))))
+ (parse-1-dsd defstruct modified (copy-structure islot)))))))
+\f
+;;; This function is called at macroexpand time to compute the INHERITS
+;;; vector for a structure type definition.
+(defun inherits-for-structure (info)
+ (declare (type defstruct-description info))
+ (let* ((include (dd-include info))
+ (superclass-opt (dd-alternate-metaclass info))
+ (super
+ (if include
+ (compiler-layout-or-lose (first include))
+ (class-layout (sb!xc:find-class
+ (or (first superclass-opt)
+ 'structure-object))))))
+ (if (eq (dd-name info) 'lisp-stream)
+ ;; a hack to added the stream class as a mixin for LISP-STREAMs
+ (concatenate 'simple-vector
+ (layout-inherits super)
+ (vector super
+ (class-layout (sb!xc:find-class 'stream))))
+ (concatenate 'simple-vector
+ (layout-inherits super)
+ (vector super)))))
+
+;;; Do miscellaneous (LOAD EVAL) time actions for the structure
+;;; described by INFO. Create the class & layout, checking for
+;;; incompatible redefinition. Define setters, accessors, copier,
+;;; predicate, documentation, instantiate definition in load-time env.
+;;; This is only called for default structures.
+(defun %defstruct (info inherits)
+ (declare (type defstruct-description info))
+ (multiple-value-bind (class layout old-layout)
+ (ensure-structure-class info inherits "current" "new")
+ (cond ((not old-layout)
+ (unless (eq (class-layout class) layout)
+ (register-layout layout)))
+ (t
+ (let ((old-info (layout-info old-layout)))
+ (when (defstruct-description-p old-info)
+ (dolist (slot (dd-slots old-info))
+ (fmakunbound (dsd-accessor slot))
+ (unless (dsd-read-only slot)
+ (fmakunbound `(setf ,(dsd-accessor slot)))))))
+ (%redefine-defstruct class old-layout layout)
+ (setq layout (class-layout class))))
+
+ (setf (sb!xc:find-class (dd-name info)) class)
+
+ ;; Set FDEFINITIONs for structure accessors, setters, predicates,
+ ;; and copiers.
+ #-sb-xc-host
+ (unless (eq (dd-type info) 'funcallable-structure)
+
+ (dolist (slot (dd-slots info))
+ (let ((dsd slot))
+ (when (and (dsd-accessor slot)
+ (eq (dsd-raw-type slot) t))
+ (protect-cl (dsd-accessor slot))
+ (setf (symbol-function (dsd-accessor slot))
+ (structure-slot-getter layout dsd))
+ (unless (dsd-read-only slot)
+ (setf (fdefinition `(setf ,(dsd-accessor slot)))
+ (structure-slot-setter layout dsd))))))
+
+ ;; FIXME: See comment on corresponding code in %%COMPILER-DEFSTRUCT.
+ #|
+ (when (dd-predicate info)
+ (protect-cl (dd-predicate info))
+ (setf (symbol-function (dd-predicate info))
+ #'(lambda (object)
+ (declare (optimize (speed 3) (safety 0)))
+ (typep-to-layout object layout))))
+ |#
+
+ (when (dd-copier info)
+ (protect-cl (dd-copier info))
+ (setf (symbol-function (dd-copier info))
+ #'(lambda (structure)
+ (declare (optimize (speed 3) (safety 0)))
+ (flet ((layout-test (structure)
+ (typep-to-layout structure layout)))
+ (unless (layout-test structure)
+ (error 'simple-type-error
+ :datum structure
+ :expected-type '(satisfies layout-test)
+ :format-control
+ "Structure for copier is not a ~S:~% ~S"
+ :format-arguments
+ (list (sb!xc:class-name (layout-class layout))
+ structure))))
+ (copy-structure structure))))))
+
+ (when (dd-doc info)
+ (setf (fdocumentation (dd-name info) 'type) (dd-doc info)))
+
+ (values))
+
+;;; This function is called at compile-time to do the
+;;; compile-time-only actions for defining a structure type. It
+;;; installs the class in the type system in a similar way to
+;;; %DEFSTRUCT, but is quieter and safer in the case of redefinition.
+;;;
+;;; The comments for the classic CMU CL version of this function said
+;;; that EVAL-WHEN doesn't do the right thing when nested or
+;;; non-top-level, and so CMU CL had the function magically called by
+;;; the compiler. Unfortunately, this doesn't do the right thing
+;;; either: compiling a function (DEFUN FOO () (DEFSTRUCT FOO X Y))
+;;; causes the class FOO to become defined, even though FOO is never
+;;; loaded or executed. Even more unfortunately, I've been unable to
+;;; come up with any EVAL-WHEN tricks which work -- I finally gave up
+;;; on this approach when trying to get the system to cross-compile
+;;; error.lisp. (Just because I haven't found it doesn't mean that it
+;;; doesn't exist, of course. Alas, I continue to have some trouble
+;;; understanding compile/load semantics in Common Lisp.) So we
+;;; continue to use the IR1 transformation approach, even though it's
+;;; known to be buggy. -- WHN 19990507
+;;;
+;;; Basically, this function avoids trashing the compiler by only
+;;; actually defining the class if there is no current definition.
+;;; Instead, we just set the INFO TYPE COMPILER-LAYOUT. This behavior
+;;; is left over from classic CMU CL and may not be necessary in the
+;;; new build system. -- WHN 19990507
+;;;
+;;; FUNCTION-%COMPILER-ONLY-DEFSTRUCT is an ordinary function, called
+;;; by both the IR1 transform version of %COMPILER-ONLY-DEFSTRUCT and
+;;; by the ordinary function version of %COMPILER-ONLY-DEFSTRUCT. (The
+;;; ordinary function version is there for the interpreter and for
+;;; code walkers.)
+(defun %compiler-only-defstruct (info inherits)
+ (function-%compiler-only-defstruct info inherits))
+(defun function-%compiler-only-defstruct (info inherits)
+ (multiple-value-bind (class layout old-layout)
+ (multiple-value-bind (clayout clayout-p)
+ (info :type :compiler-layout (dd-name info))
+ (ensure-structure-class info
+ inherits
+ (if clayout-p "previously compiled" "current")
+ "compiled"
+ :compiler-layout clayout))
+ (cond (old-layout
+ (undefine-structure (layout-class old-layout))
+ (when (and (class-subclasses class)
+ (not (eq layout old-layout)))
+ (collect ((subs))
+ (dohash (class layout (class-subclasses class))
+ (declare (ignore layout))
+ (undefine-structure class)
+ (subs (class-proper-name class)))
+ (when (subs)
+ (warn "Removing old subclasses of ~S:~% ~S"
+ (sb!xc:class-name class)
+ (subs))))))
+ (t
+ (unless (eq (class-layout class) layout)
+ (register-layout layout :invalidate nil))
+ (setf (sb!xc:find-class (dd-name info)) class)))
+
+ (setf (info :type :compiler-layout (dd-name info)) layout))
+ (values))
+
+;;; This function does the (COMPILE LOAD EVAL) time actions for updating the
+;;; compiler's global meta-information to represent the definition of the
+;;; structure described by Info. This primarily amounts to setting up info
+;;; about the accessor and other implicitly defined functions. The constructors
+;;; are explicitly defined by top-level code.
+(defun %%compiler-defstruct (info)
+ (declare (type defstruct-description info))
+ (let* ((name (dd-name info))
+ (class (sb!xc:find-class name)))
+ (let ((copier (dd-copier info)))
+ (when copier
+ (proclaim `(ftype (function (,name) ,name) ,copier))))
+
+ ;; FIXME: This (and corresponding code in %DEFSTRUCT) are the way
+ ;; that CMU CL defined the predicate, instead of using DEFUN.
+ ;; Perhaps it would be better to go back to to the CMU CL way, or
+ ;; something similar. I want to reduce the amount of magic in
+ ;; defstruct functions, but making the predicate be a closure
+ ;; looks like a good thing, and can even be done without magic.
+ ;; (OTOH, there are some bootstrapping issues involved, since
+ ;; GENESIS understands DEFUN but doesn't understand a
+ ;; (SETF SYMBOL-FUNCTION) call inside %DEFSTRUCT.)
+ #|
+ (let ((pred (dd-predicate info)))
+ (when pred
+ (proclaim-as-defstruct-function-name pred)
+ (setf (info :function :inlinep pred) :inline)
+ (setf (info :function :inline-expansion pred)
+ `(lambda (x) (typep x ',name)))))
+ |#
+
+ (dolist (slot (dd-slots info))
+ (let* ((fun (dsd-accessor slot))
+ (setf-fun `(setf ,fun)))
+ (when (and fun (eq (dsd-raw-type slot) t))
+ (proclaim-as-defstruct-function-name fun)
+ (setf (info :function :accessor-for fun) class)
+ (unless (dsd-read-only slot)
+ (proclaim-as-defstruct-function-name setf-fun)
+ (setf (info :function :accessor-for setf-fun) class))))))
+
+ (values))
+
+;;; Ordinarily this is preempted by an IR1 transformation, but this
+;;; definition is still useful for the interpreter and code walkers.
+(defun %compiler-defstruct (info)
+ (%%compiler-defstruct info))
+\f
+;;;; redefinition stuff
+
+;;; Compare the slots of OLD and NEW, returning 3 lists of slot names:
+;;; 1. Slots which have moved,
+;;; 2. Slots whose type has changed,
+;;; 3. Deleted slots.
+(defun compare-slots (old new)
+ (let* ((oslots (dd-slots old))
+ (nslots (dd-slots new))
+ (onames (mapcar #'dsd-name oslots))
+ (nnames (mapcar #'dsd-name nslots)))
+ (collect ((moved)
+ (retyped))
+ (dolist (name (intersection onames nnames))
+ (let ((os (find name oslots :key #'dsd-name))
+ (ns (find name nslots :key #'dsd-name)))
+ (unless (subtypep (dsd-type ns) (dsd-type os))
+ (/noshow "found retyped slots" ns os (dsd-type ns) (dsd-type os))
+ (retyped name))
+ (unless (and (= (dsd-index os) (dsd-index ns))
+ (eq (dsd-raw-type os) (dsd-raw-type ns)))
+ (moved name))))
+ (values (moved)
+ (retyped)
+ (set-difference onames nnames)))))
+
+;;; If we are redefining a structure with different slots than in the
+;;; currently loaded version, give a warning and return true.
+(defun redefine-structure-warning (class old new)
+ (declare (type defstruct-description old new)
+ (type sb!xc:class class)
+ (ignore class))
+ (let ((name (dd-name new)))
+ (multiple-value-bind (moved retyped deleted) (compare-slots old new)
+ (when (or moved retyped deleted)
+ (warn
+ "incompatibly redefining slots of structure class ~S~@
+ Make sure any uses of affected accessors are recompiled:~@
+ ~@[ These slots were moved to new positions:~% ~S~%~]~
+ ~@[ These slots have new incompatible types:~% ~S~%~]~
+ ~@[ These slots were deleted:~% ~S~%~]"
+ name moved retyped deleted)
+ t))))
+
+;;; This function is called when we are incompatibly redefining a
+;;; structure Class to have the specified New-Layout. We signal an
+;;; error with some proceed options and return the layout that should
+;;; be used.
+(defun %redefine-defstruct (class old-layout new-layout)
+ (declare (type sb!xc:class class) (type layout old-layout new-layout))
+ (let ((name (class-proper-name class)))
+ (restart-case
+ (error "redefining class ~S incompatibly with the current definition"
+ name)
+ (continue ()
+ :report "Invalidate current definition."
+ (warn "Previously loaded ~S accessors will no longer work." name)
+ (register-layout new-layout))
+ (clobber-it ()
+ :report "Smash current layout, preserving old code."
+ (warn "Any old ~S instances will be in a bad way.~@
+ I hope you know what you're doing..."
+ name)
+ (register-layout new-layout :invalidate nil
+ :destruct-layout old-layout))))
+ (values))
+
+;;; This is called when we are about to define a structure class. It
+;;; returns a (possibly new) class object and the layout which should
+;;; be used for the new definition (may be the current layout, and
+;;; also might be an uninstalled forward referenced layout.) The third
+;;; value is true if this is an incompatible redefinition, in which
+;;; case it is the old layout.
+(defun ensure-structure-class (info inherits old-context new-context
+ &key compiler-layout)
+ (multiple-value-bind (class old-layout)
+ (destructuring-bind
+ (&optional
+ name
+ (class 'sb!xc:structure-class)
+ (constructor 'make-structure-class))
+ (dd-alternate-metaclass info)
+ (declare (ignore name))
+ (insured-find-class (dd-name info)
+ (if (eq class 'sb!xc:structure-class)
+ (lambda (x)
+ (typep x 'sb!xc:structure-class))
+ (lambda (x)
+ (sb!xc:typep x (sb!xc:find-class class))))
+ (fdefinition constructor)))
+ (setf (class-direct-superclasses class)
+ (if (eq (dd-name info) 'lisp-stream)
+ ;; a hack to add STREAM as a superclass mixin to LISP-STREAMs
+ (list (layout-class (svref inherits (1- (length inherits))))
+ (layout-class (svref inherits (- (length inherits) 2))))
+ (list (layout-class (svref inherits (1- (length inherits)))))))
+ (let ((new-layout (make-layout :class class
+ :inherits inherits
+ :depthoid (length inherits)
+ :length (dd-length info)
+ :info info))
+ (old-layout (or compiler-layout old-layout)))
+ (cond
+ ((not old-layout)
+ (values class new-layout nil))
+ (;; This clause corresponds to an assertion in REDEFINE-LAYOUT-WARNING
+ ;; of classic CMU CL. I moved it out to here because it was only
+ ;; exercised in this code path anyway. -- WHN 19990510
+ (not (eq (layout-class new-layout) (layout-class old-layout)))
+ (error "shouldn't happen: weird state of OLD-LAYOUT?"))
+ ((not *type-system-initialized*)
+ (setf (layout-info old-layout) info)
+ (values class old-layout nil))
+ ((redefine-layout-warning old-context
+ old-layout
+ new-context
+ (layout-length new-layout)
+ (layout-inherits new-layout)
+ (layout-depthoid new-layout))
+ (values class new-layout old-layout))
+ (t
+ (let ((old-info (layout-info old-layout)))
+ (typecase old-info
+ ((or defstruct-description)
+ (cond ((redefine-structure-warning class old-info info)
+ (values class new-layout old-layout))
+ (t
+ (setf (layout-info old-layout) info)
+ (values class old-layout nil))))
+ (null
+ (setf (layout-info old-layout) info)
+ (values class old-layout nil))
+ (t
+ (error "shouldn't happen! strange thing in LAYOUT-INFO:~% ~S"
+ old-layout)
+ (values class new-layout old-layout)))))))))
+
+;;; Blow away all the compiler info for the structure CLASS. Iterate
+;;; over this type, clearing the compiler structure type info, and
+;;; undefining all the associated functions.
+(defun undefine-structure (class)
+ (let ((info (layout-info (class-layout class))))
+ (when (defstruct-description-p info)
+ (let ((type (dd-name info)))
+ (setf (info :type :compiler-layout type) nil)
+ (undefine-function-name (dd-copier info))
+ (undefine-function-name (dd-predicate info))
+ (dolist (slot (dd-slots info))
+ (let ((fun (dsd-accessor slot)))
+ (undefine-function-name fun)
+ (unless (dsd-read-only slot)
+ (undefine-function-name `(setf ,fun))))))
+ ;; Clear out the SPECIFIER-TYPE cache so that subsequent
+ ;; references are unknown types.
+ (values-specifier-type-cache-clear)))
+ (values))
+\f
+;;; Return a list of pairs (name . index). Used for :TYPE'd
+;;; constructors to find all the names that we have to splice in &
+;;; where. Note that these types don't have a layout, so we can't look
+;;; at LAYOUT-INHERITS.
+(defun find-name-indices (defstruct)
+ (collect ((res))
+ (let ((infos ()))
+ (do ((info defstruct
+ (typed-structure-info-or-lose (first (dd-include info)))))
+ ((not (dd-include info))
+ (push info infos))
+ (push info infos))
+
+ (let ((i 0))
+ (dolist (info infos)
+ (incf i (or (dd-offset info) 0))
+ (when (dd-named info)
+ (res (cons (dd-name info) i)))
+ (setq i (dd-length info)))))
+
+ (res)))
+\f
+;;;; slot accessors for raw slots
+
+;;; Return info about how to read/write a slot in the value stored in
+;;; OBJECT. This is also used by constructors (we can't use the
+;;; accessor function, since some slots are read-only.) If supplied,
+;;; DATA is a variable holding the raw-data vector.
+;;;
+;;; returned values:
+;;; 1. accessor function name (SETFable)
+;;; 2. index to pass to accessor.
+;;; 3. object form to pass to accessor
+(defun slot-accessor-form (defstruct slot object &optional data)
+ (let ((rtype (dsd-raw-type slot)))
+ (values
+ (ecase rtype
+ (single-float '%raw-ref-single)
+ (double-float '%raw-ref-double)
+ #!+long-float
+ (long-float '%raw-ref-long)
+ (complex-single-float '%raw-ref-complex-single)
+ (complex-double-float '%raw-ref-complex-double)
+ #!+long-float
+ (complex-long-float '%raw-ref-complex-long)
+ (unsigned-byte 'aref)
+ ((t)
+ (if (eq (dd-type defstruct) 'funcallable-structure)
+ '%funcallable-instance-info
+ '%instance-ref)))
+ (case rtype
+ #!+long-float
+ (complex-long-float
+ (truncate (dsd-index slot) #!+x86 6 #!+sparc 8))
+ #!+long-float
+ (long-float
+ (truncate (dsd-index slot) #!+x86 3 #!+sparc 4))
+ (double-float
+ (ash (dsd-index slot) -1))
+ (complex-double-float
+ (ash (dsd-index slot) -2))
+ (complex-single-float
+ (ash (dsd-index slot) -1))
+ (t
+ (dsd-index slot)))
+ (cond
+ ((eq rtype 't) object)
+ (data)
+ (t
+ `(truly-the (simple-array (unsigned-byte 32) (*))
+ (%instance-ref ,object ,(dd-raw-index defstruct))))))))
+\f
+;;; These functions are called to actually make a constructor after we
+;;; have processed the arglist. The correct variant (according to the
+;;; DD-TYPE) should be called. The function is defined with the
+;;; specified name and arglist. Vars and Types are used for argument
+;;; type declarations. Values are the values for the slots (in order.)
+;;;
+;;; This is split four ways because:
+;;; 1] list & vector structures need "name" symbols stuck in at various weird
+;;; places, whereas STRUCTURE structures have a LAYOUT slot.
+;;; 2] We really want to use LIST to make list structures, instead of
+;;; MAKE-LIST/(SETF ELT).
+;;; 3] STRUCTURE structures can have raw slots that must also be allocated and
+;;; indirectly referenced. We use SLOT-ACCESSOR-FORM to compute how to set
+;;; the slots, which deals with raw slots.
+;;; 4] funcallable structures are weird.
+(defun create-vector-constructor
+ (defstruct cons-name arglist vars types values)
+ (let ((temp (gensym))
+ (etype (dd-element-type defstruct)))
+ `(defun ,cons-name ,arglist
+ (declare ,@(mapcar #'(lambda (var type) `(type (and ,type ,etype) ,var))
+ vars types))
+ (let ((,temp (make-array ,(dd-length defstruct)
+ :element-type ',(dd-element-type defstruct))))
+ ,@(mapcar #'(lambda (x)
+ `(setf (aref ,temp ,(cdr x)) ',(car x)))
+ (find-name-indices defstruct))
+ ,@(mapcar #'(lambda (dsd value)
+ `(setf (aref ,temp ,(dsd-index dsd)) ,value))
+ (dd-slots defstruct) values)
+ ,temp))))
+(defun create-list-constructor
+ (defstruct cons-name arglist vars types values)
+ (let ((vals (make-list (dd-length defstruct) :initial-element nil)))
+ (dolist (x (find-name-indices defstruct))
+ (setf (elt vals (cdr x)) `',(car x)))
+ (loop for dsd in (dd-slots defstruct) and val in values do
+ (setf (elt vals (dsd-index dsd)) val))
+
+ `(defun ,cons-name ,arglist
+ (declare ,@(mapcar #'(lambda (var type) `(type ,type ,var))
+ vars types))
+ (list ,@vals))))
+(defun create-structure-constructor
+ (defstruct cons-name arglist vars types values)
+ (let* ((temp (gensym))
+ (raw-index (dd-raw-index defstruct))
+ (n-raw-data (when raw-index (gensym))))
+ `(defun ,cons-name ,arglist
+ (declare ,@(mapcar #'(lambda (var type) `(type ,type ,var))
+ vars types))
+ (let ((,temp (truly-the ,(dd-name defstruct)
+ (%make-instance ,(dd-length defstruct))))
+ ,@(when n-raw-data
+ `((,n-raw-data
+ (make-array ,(dd-raw-length defstruct)
+ :element-type '(unsigned-byte 32))))))
+ (setf (%instance-layout ,temp)
+ (%delayed-get-compiler-layout ,(dd-name defstruct)))
+ ,@(when n-raw-data
+ `((setf (%instance-ref ,temp ,raw-index) ,n-raw-data)))
+ ,@(mapcar #'(lambda (dsd value)
+ (multiple-value-bind (accessor index data)
+ (slot-accessor-form defstruct dsd temp n-raw-data)
+ `(setf (,accessor ,data ,index) ,value)))
+ (dd-slots defstruct)
+ values)
+ ,temp))))
+(defun create-fin-constructor
+ (defstruct cons-name arglist vars types values)
+ (let ((temp (gensym)))
+ `(defun ,cons-name ,arglist
+ (declare ,@(mapcar #'(lambda (var type) `(type ,type ,var))
+ vars types))
+ (let ((,temp (truly-the
+ ,(dd-name defstruct)
+ (%make-funcallable-instance
+ ,(dd-length defstruct)
+ (%delayed-get-compiler-layout ,(dd-name defstruct))))))
+ ,@(mapcar #'(lambda (dsd value)
+ `(setf (%funcallable-instance-info
+ ,temp ,(dsd-index dsd))
+ ,value))
+ (dd-slots defstruct) values)
+ ,temp))))
+
+;;; Create a default (non-BOA) keyword constructor.
+(defun create-keyword-constructor (defstruct creator)
+ (collect ((arglist (list '&key))
+ (types)
+ (vals))
+ (dolist (slot (dd-slots defstruct))
+ (let ((dum (gensym))
+ (name (dsd-name slot)))
+ (arglist `((,(intern (string name) "KEYWORD") ,dum)
+ ,(dsd-default slot)))
+ (types (dsd-type slot))
+ (vals dum)))
+ (funcall creator
+ defstruct (dd-default-constructor defstruct)
+ (arglist) (vals) (types) (vals))))
+
+;;; Given a structure and a BOA constructor spec, call Creator with
+;;; the appropriate args to make a constructor.
+(defun create-boa-constructor (defstruct boa creator)
+ (multiple-value-bind (req opt restp rest keyp keys allowp aux)
+ (sb!kernel:parse-lambda-list (second boa))
+ (collect ((arglist)
+ (vars)
+ (types))
+ (labels ((get-slot (name)
+ (let ((res (find name (dd-slots defstruct)
+ :test #'string=
+ :key #'dsd-name)))
+ (if res
+ (values (dsd-type res) (dsd-default res))
+ (values t nil))))
+ (do-default (arg)
+ (multiple-value-bind (type default) (get-slot arg)
+ (arglist `(,arg ,default))
+ (vars arg)
+ (types type))))
+ (dolist (arg req)
+ (arglist arg)
+ (vars arg)
+ (types (get-slot arg)))
+
+ (when opt
+ (arglist '&optional)
+ (dolist (arg opt)
+ (cond ((consp arg)
+ (destructuring-bind
+ (name &optional (def (nth-value 1 (get-slot name))))
+ arg
+ (arglist `(,name ,def))
+ (vars name)
+ (types (get-slot name))))
+ (t
+ (do-default arg)))))
+
+ (when restp
+ (arglist '&rest rest)
+ (vars rest)
+ (types 'list))
+
+ (when keyp
+ (arglist '&key)
+ (dolist (key keys)
+ (if (consp key)
+ (destructuring-bind (wot &optional (def nil def-p)) key
+ (let ((name (if (consp wot)
+ (destructuring-bind (key var) wot
+ (declare (ignore key))
+ var)
+ wot)))
+ (multiple-value-bind (type slot-def) (get-slot name)
+ (arglist `(,wot ,(if def-p def slot-def)))
+ (vars name)
+ (types type))))
+ (do-default key))))
+
+ (when allowp (arglist '&allow-other-keys))
+
+ (when aux
+ (arglist '&aux)
+ (dolist (arg aux)
+ (let* ((arg (if (consp arg) arg (list arg)))
+ (var (first arg)))
+ (arglist arg)
+ (vars var)
+ (types (get-slot var))))))
+
+ (funcall creator defstruct (first boa)
+ (arglist) (vars) (types)
+ (mapcar #'(lambda (slot)
+ (or (find (dsd-name slot) (vars) :test #'string=)
+ (dsd-default slot)))
+ (dd-slots defstruct))))))
+
+;;; Grovel the constructor options, and decide what constructors (if
+;;; any) to create.
+(defun constructor-definitions (defstruct)
+ (let ((no-constructors nil)
+ (boas ())
+ (defaults ())
+ (creator (ecase (dd-type defstruct)
+ (structure #'create-structure-constructor)
+ (funcallable-structure #'create-fin-constructor)
+ (vector #'create-vector-constructor)
+ (list #'create-list-constructor))))
+ (dolist (constructor (dd-constructors defstruct))
+ (destructuring-bind (name &optional (boa-ll nil boa-p)) constructor
+ (declare (ignore boa-ll))
+ (cond ((not name) (setq no-constructors t))
+ (boa-p (push constructor boas))
+ (t (push name defaults)))))
+
+ (when no-constructors
+ (when (or defaults boas)
+ (error "(:CONSTRUCTOR NIL) combined with other :CONSTRUCTORs"))
+ (return-from constructor-definitions ()))
+
+ (unless (or defaults boas)
+ (push (concat-pnames 'make- (dd-name defstruct)) defaults))
+
+ (collect ((res))
+ (when defaults
+ (let ((cname (first defaults)))
+ (setf (dd-default-constructor defstruct) cname)
+ (res (create-keyword-constructor defstruct creator))
+ (dolist (other-name (rest defaults))
+ (res `(setf (fdefinition ',other-name) (fdefinition ',cname)))
+ (res `(declaim (ftype function ',other-name))))))
+
+ (dolist (boa boas)
+ (res (create-boa-constructor defstruct boa creator)))
+
+ (res))))
+\f
+;;;; compiler stuff
+
+;;; Like PROCLAIM-AS-FUNCTION-NAME, but we also set the kind to
+;;; :DECLARED and blow away any ASSUMED-TYPE. Also, if the thing is a
+;;; slot accessor currently, quietly unaccessorize it. And if there
+;;; are any undefined warnings, we nuke them.
+(defun proclaim-as-defstruct-function-name (name)
+ (when name
+ (when (info :function :accessor-for name)
+ (setf (info :function :accessor-for name) nil))
+ (proclaim-as-function-name name)
+ (note-name-defined name :function)
+ (setf (info :function :where-from name) :declared)
+ (when (info :function :assumed-type name)
+ (setf (info :function :assumed-type name) nil)))
+ (values))
+\f
+;;;; finalizing bootstrapping
+
+;;; early structure placeholder definitions: Set up layout and class
+;;; data for structures which are needed early.
+(dolist (args
+ '#.(sb-cold:read-from-file
+ "src/code/early-defstruct-args.lisp-expr"))
+ (let* ((defstruct (parse-name-and-options-and-slot-descriptions
+ (first args)
+ (rest args)))
+ (inherits (inherits-for-structure defstruct)))
+ (function-%compiler-only-defstruct defstruct inherits)))
--- /dev/null
+;;;; definitions of types for the target (output of the compiler)
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!KERNEL")
+
+(file-comment
+ "$Header$")
+\f
+;;;; Now that DEFTYPE is set up, any pending requests for it can
+;;;; be honored.
+
+#+sb-xc-host
+(progn
+ (/show "about to force delayed DEF!TYPEs")
+ (force-delayed-def!types)
+ (/show "done forcing delayed DEF!TYPEs"))
+\f
+;;;; standard types
+
+(sb!xc:deftype boolean () '(member t nil))
+
+(sb!xc:deftype mod (n)
+ (unless (and (integerp n) (> n 0))
+ (error "bad modulus specified for MOD type specifier: ~S" n))
+ `(integer 0 ,(1- n)))
+
+(sb!xc:deftype signed-byte (&optional s)
+ (cond ((eq s '*) 'integer)
+ ((and (integerp s) (> s 1))
+ (let ((bound (ash 1 (1- s))))
+ `(integer ,(- bound) ,(1- bound))))
+ (t
+ (error "bad size specified for SIGNED-BYTE type specifier: ~S" s))))
+
+(sb!xc:deftype unsigned-byte (&optional s)
+ (cond ((eq s '*) '(integer 0))
+ ((and (integerp s) (> s 0))
+ `(integer 0 ,(1- (ash 1 s))))
+ (t
+ (error "bad size specified for UNSIGNED-BYTE type specifier: ~S" s))))
+
+(sb!xc:deftype bit () '(integer 0 1))
+
+(sb!xc:deftype compiled-function () 'function)
+
+(sb!xc:deftype atom () '(not cons))
+
+(sb!xc:deftype extended-char ()
+ #!+sb-doc
+ "Type of characters that aren't base-char's. None in CMU CL."
+ '(and character (not base-char)))
+
+(sb!xc:deftype standard-char ()
+ #!+sb-doc
+ "Type corresponding to the characters required by the standard."
+ '(member
+ #\NEWLINE #\SPACE #\! #\" #\# #\$ #\% #\& #\' #\( #\) #\* #\+ #\,
+ #\- #\. #\/ #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\: #\; #\< #\=
+ #\> #\? #\@ #\A #\B #\C #\D #\E #\F #\G #\H #\I #\J #\K #\L #\M
+ #\N #\O #\P #\Q #\R #\S #\T #\U #\V #\W #\X #\Y #\Z #\[ #\\ #\]
+ #\^ #\_ #\` #\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k #\l #\m
+ #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z #\{
+ #\| #\} #\~))
+
+;;; FIXME: Would type inference be able to get more traction on this
+;;; if it were defined as (AND SYMBOL (SATISFIES KEYWORDP))?
+(sb!xc:deftype keyword ()
+ #!+sb-doc
+ "Type for any keyword symbol."
+ '(satisfies keywordp))
+
+(sb!xc:deftype eql (n) `(member ,n))
+
+(sb!xc:deftype vector (&optional element-type size)
+ `(array ,element-type (,size)))
+
+(sb!xc:deftype simple-vector (&optional size)
+ `(simple-array t (,size)))
+
+(sb!xc:deftype base-string (&optional size)
+ `(array base-char (,size)))
+(sb!xc:deftype simple-base-string (&optional size)
+ `(simple-array base-char (,size)))
+(sb!xc:deftype string (&optional size)
+ `(or (array character (,size))
+ (base-string ,size)))
+(sb!xc:deftype simple-string (&optional size)
+ `(or (simple-array character (,size))
+ (simple-base-string ,size)))
+
+(sb!xc:deftype bit-vector (&optional size)
+ `(array bit (,size)))
+
+(sb!xc:deftype simple-bit-vector (&optional size)
+ `(simple-array bit (,size)))
+\f
+;;;; some private types that we use in defining the standard functions
+
+;;; a type specifier
+(sb!xc:deftype type-specifier () '(or list symbol sb!xc:class))
+
+;;; array rank, total size...
+(sb!xc:deftype array-rank () `(integer 0 (,sb!xc:array-rank-limit)))
+(sb!xc:deftype array-total-size ()
+ `(integer 0 (,sb!xc:array-total-size-limit)))
+
+;;; something legal in an evaluated context
+;;; FIXME: could probably go away
+(sb!xc:deftype form () 't)
+
+;;; Maclisp compatibility...
+;;; FIXME: should be STRING-DESIGNATOR (the term used in the ANSI spec)
+(sb!xc:deftype stringable () '(or string symbol character))
+
+;;; a thing legal in places where we want the name of a file
+(sb!xc:deftype filename () '(or string pathname))
+
+;;; a legal arg to pathname functions
+(sb!xc:deftype pathname-designator ()
+ '(or string pathname stream))
+
+;;; a thing returned by the irrational functions. We assume that they
+;;; never compute a rational result.
+(sb!xc:deftype irrational ()
+ '(or float (complex float)))
+
+;;; character components
+(sb!xc:deftype char-code () `(integer 0 (,char-code-limit)))
+
+;;; a consed sequence result. If a vector, is a simple array.
+(sb!xc:deftype consed-sequence () '(or list (simple-array * (*))))
+
+;;; the :END arg to a sequence
+(sb!xc:deftype sequence-end () '(or null index))
+
+;;; a valid argument to a stream function
+;;;
+;;; FIXME: should probably be STREAM-DESIGNATOR, after the term
+;;; used in the ANSI spec (if this is in fact exactly the same thing)
+(sb!xc:deftype streamlike () '(or stream (member nil t)))
+
+;;; a thing that can be passed to FUNCALL & friends
+;;;
+;;; FIXME: should be FUNCTION-DESIGNATOR?
+(sb!xc:deftype callable () '(or function symbol))
+
+;;; decomposing floats into integers
+(sb!xc:deftype single-float-exponent ()
+ `(integer ,(- sb!vm:single-float-normal-exponent-min
+ sb!vm:single-float-bias
+ sb!vm:single-float-digits)
+ ,(- sb!vm:single-float-normal-exponent-max
+ sb!vm:single-float-bias)))
+(sb!xc:deftype double-float-exponent ()
+ `(integer ,(- sb!vm:double-float-normal-exponent-min
+ sb!vm:double-float-bias
+ sb!vm:double-float-digits)
+ ,(- sb!vm:double-float-normal-exponent-max
+ sb!vm:double-float-bias)))
+(sb!xc:deftype single-float-int-exponent ()
+ `(integer ,(- sb!vm:single-float-normal-exponent-min
+ sb!vm:single-float-bias
+ (* sb!vm:single-float-digits 2))
+ ,(- sb!vm:single-float-normal-exponent-max
+ sb!vm:single-float-bias
+ sb!vm:single-float-digits)))
+(sb!xc:deftype double-float-int-exponent ()
+ `(integer ,(- sb!vm:double-float-normal-exponent-min sb!vm:double-float-bias
+ (* sb!vm:double-float-digits 2))
+ ,(- sb!vm:double-float-normal-exponent-max sb!vm:double-float-bias
+ sb!vm:double-float-digits)))
+(sb!xc:deftype single-float-significand ()
+ `(integer 0 (,(ash 1 sb!vm:single-float-digits))))
+(sb!xc:deftype double-float-significand ()
+ `(integer 0 (,(ash 1 sb!vm:double-float-digits))))
--- /dev/null
+;;;; most of the DESCRIBE mechanism -- that part which isn't derived
+;;;; from PCL code
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB-IMPL")
+
+(file-comment
+ "$Header$")
+\f
+(defvar *describe-indentation-step* 3
+ #+sb-doc
+ "the number of spaces that sets off each line of a recursive description")
+
+(declaim (ftype (function (t stream)) describe-object))
+(defgeneric describe-object ((x t) stream))
+
+(defun describe (x &optional (stream-designator *standard-output*))
+ #+sb-doc
+ "Print a description of the object X."
+ (let ((stream (out-synonym-of stream-designator)))
+ #+nil (fresh-line stream)
+ (pprint-logical-block (stream nil)
+ (describe-object x stream)))
+ (values))
+\f
+;;;; miscellaneous DESCRIBE-OBJECT methods
+
+(defmethod describe-object ((x t) s)
+ (format s "~@<~S ~_is a ~S.~:>" x (type-of x)))
+
+(defmethod describe-object ((x cons) s)
+ (call-next-method)
+ (when (and (legal-function-name-p x)
+ (fboundp x))
+ (format s "Its FDEFINITION is ~S.~@:_" (fdefinition x))
+ ;; TO DO: should check for SETF documentation.
+ ;; TO DO: should make it clear whether the definition is a
+ ;; DEFUN (SETF FOO) or DEFSETF FOO or what.
+ ))
+
+(defmethod describe-object ((x array) s)
+ (let ((rank (array-rank x)))
+ (cond ((> rank 1)
+ (format s "~S ~_is " x)
+ (write-string (if (%array-displaced-p x) "a displaced" "an") s)
+ (format s " array of rank ~S." rank)
+ (format s "~@:_Its dimensions are ~S." (array-dimensions x)))
+ (t
+ (format s
+ "~@:_~S is a ~:[~;displaced ~]vector of length ~S." x
+ (and (array-header-p x) (%array-displaced-p x)) (length x))
+ (when (array-has-fill-pointer-p x)
+ (format s "~@:_It has a fill pointer, currently ~S."
+ (fill-pointer x))))))
+ (let ((array-element-type (array-element-type x)))
+ (unless (eq array-element-type t)
+ (format s
+ "~@:_Its element type is specialized to ~S."
+ array-element-type))))
+
+(defmethod describe-object ((x hash-table) s)
+ (declare (type stream s))
+ (format s "~@<~S ~_is an ~S hash table.~:>" x (hash-table-test x))
+ (format s "~_Its SIZE is ~S." (hash-table-size x))
+ (format s
+ "~@:_~@<Its REHASH-SIZE is ~S. ~_Its REHASH-THRESHOLD is ~S.~:>"
+ (hash-table-rehash-size x)
+ (hash-table-rehash-threshold x))
+ (let ((count (hash-table-count x)))
+ (format s "~@:_It holds ~S key/value pair~:P~:[: ~2I~_~;.~]"
+ count (zerop count))
+ (let ((n 0))
+ (declare (type index n))
+ (dohash (k v x)
+ (unless (zerop n)
+ (write-char #\space s))
+ (incf n)
+ (when (and *print-length* (> n *print-length*))
+ (format s "~:_...")
+ (return))
+ (format s "~:_(~S ~S)" k v)))))
+\f
+;;;; DESCRIBE-OBJECT methods for symbols and functions, including all
+;;;; sorts of messy stuff about documentation, type information,
+;;;; packaging, function implementation, etc..
+
+;;; Print the specified kind of documentation about the given NAME. If
+;;; NAME is null, or not a valid name, then don't print anything.
+(declaim (ftype (function (symbol stream t t) (values)) %describe-doc))
+(defun %describe-doc (name s kind kind-doc)
+ (when (and name (typep name '(or symbol cons)))
+ (let ((doc (fdocumentation name kind)))
+ (when doc
+ (format s "~_~@(~A documentation:~)~@:_ ~A"
+ (or kind-doc kind) doc))))
+ (values))
+
+;;; Describe various stuff about the functional semantics attached to
+;;; the specified Name. Type-Spec is the function type specifier
+;;; extracted from the definition, or NIL if none.
+(declaim (ftype (function ((or symbol cons) stream t)) %describe-function-name))
+(defun %describe-function-name (name s type-spec)
+ (multiple-value-bind (type where)
+ (if (or (symbolp name) (and (listp name) (eq (car name) 'setf)))
+ (values (type-specifier (info :function :type name))
+ (info :function :where-from name))
+ (values type-spec :defined))
+ (when (consp type)
+ (format s "~@:_Its ~(~A~) argument types are:~@:_ ~S"
+ where (second type))
+ (format s "~@:_Its result type is:~@:_ ~S" (third type))))
+ (let ((inlinep (info :function :inlinep name)))
+ (when inlinep
+ (format s "~@:_It is currently declared ~(~A~);~
+ ~:[no~;~] expansion is available."
+ inlinep (info :function :inline-expansion name)))))
+
+;;; Interpreted function describing; handles both closure and
+;;; non-closure functions. Instead of printing the compiled-from info,
+;;; we print the definition.
+(defun %describe-function-interpreted (x s kind name)
+ (declare (type stream s))
+ (multiple-value-bind (exp closure-p dname)
+ (sb-eval:interpreted-function-lambda-expression x)
+ (let ((args (sb-eval:interpreted-function-arglist x)))
+ (format s "~@:_~@(~@[~A ~]arguments:~@:_~)" kind)
+ (if args
+ (format s " ~<~S~:>" args)
+ (write-string " There are no arguments." s)))
+ (let ((name (or name dname)))
+ (%describe-doc name s 'function kind)
+ (unless (eq kind :macro)
+ (%describe-function-name
+ name
+ s
+ (type-specifier (sb-eval:interpreted-function-type x)))))
+ (when closure-p
+ (format s "~@:_Its closure environment is:")
+ (pprint-logical-block (s nil)
+ (pprint-indent :current 2)
+ (let ((clos (sb-eval:interpreted-function-closure x)))
+ (dotimes (i (length clos))
+ (format s "~@:_~S: ~S" i (svref clos i))))))
+ (format s "~@:_Its definition is:~@:_ ~S" exp)))
+
+;;; Print information from the debug-info about where CODE-OBJ was
+;;; compiled from.
+(defun %describe-compiled-from (code-obj s)
+ (declare (type stream s))
+ (let ((info (sb-kernel:%code-debug-info code-obj)))
+ (when info
+ (let ((sources (sb-c::debug-info-source info)))
+ (format s "~@:_On ~A it was compiled from:"
+ ;; FIXME: The FORMAT-UNIVERSAL-TIME calls in the system
+ ;; should become more consistent, probably not using
+ ;; any nondefault options.
+ (format-universal-time nil
+ (sb-c::debug-source-compiled
+ (first sources))
+ :style :abbreviated))
+ (dolist (source sources)
+ (let ((name (sb-c::debug-source-name source)))
+ (ecase (sb-c::debug-source-from source)
+ (:file
+ (format s "~@:_~A~@:_ Created: " (namestring name))
+ (sb-int:format-universal-time t (sb-c::debug-source-created
+ source))
+ (let ((comment (sb-c::debug-source-comment source)))
+ (when comment
+ (format s "~@:_ Comment: ~A" comment))))
+ (:lisp (format s "~@:_~S" name)))))))))
+
+;;; Describe a compiled function. The closure case calls us to print
+;;; the guts.
+(defun %describe-function-compiled (x s kind name)
+ (declare (type stream s))
+ ;; FIXME: The lowercaseness of %FUNCTION-ARGLIST results, and the
+ ;; non-sentenceness of the "Arguments" label, makes awkward output.
+ ;; Better would be "Its arguments are: ~S" (with uppercase argument
+ ;; names) when arguments are known, and otherwise "There is no
+ ;; information available about its arguments." or "It has no
+ ;; arguments." (And why is %FUNCTION-ARGLIST a string instead of a
+ ;; list of symbols anyway?)
+ (let ((args (%function-arglist x)))
+ (format s "~@:_~@(~@[~A ~]arguments:~@:_~)" kind)
+ (cond ((not args)
+ (format s " There is no argument information available."))
+ ((string= args "()")
+ (write-string " There are no arguments." s))
+ (t
+ (write-string " " s)
+ (pprint-logical-block (s nil)
+ (pprint-indent :current 2)
+ (write-string args s)))))
+ (let ((name (or name (%function-name x))))
+ (%describe-doc name s 'function kind)
+ (unless (eq kind :macro)
+ (%describe-function-name name s (%function-type x))))
+ (%describe-compiled-from (sb-kernel:function-code-header x) s))
+
+(defun %describe-function-byte-compiled (x s kind name)
+ (declare (type stream s))
+ (let ((name (or name (sb-c::byte-function-name x))))
+ (%describe-doc name s 'function kind)
+ (unless (eq kind :macro)
+ (%describe-function-name name s 'function)))
+ (%describe-compiled-from (sb-c::byte-function-component x) s))
+
+;;; Describe a function with the specified kind and name. The latter
+;;; arguments provide some information about where the function came
+;;; from. Kind NIL means not from a name.
+(defun %describe-function (x s &optional (kind nil) name)
+ (declare (type function x))
+ (declare (type stream s))
+ (declare (type (member :macro :function nil) kind))
+ (fresh-line s)
+ (ecase kind
+ (:macro (format s "Macro-function: ~S" x))
+ (:function (format s "Function: ~S" x))
+ ((nil) (format s "~S is a function." x)))
+ (case (get-type x)
+ (#.sb-vm:closure-header-type
+ (%describe-function-compiled (%closure-function x) s kind name)
+ (format s "~@:_Its closure environment is:")
+ (pprint-logical-block (s nil)
+ (pprint-indent :current 8)
+ (dotimes (i (- (get-closure-length x) (1- sb-vm:closure-info-offset)))
+ (format s "~@:_~S: ~S" i (%closure-index-ref x i)))))
+ ((#.sb-vm:function-header-type #.sb-vm:closure-function-header-type)
+ (%describe-function-compiled x s kind name))
+ (#.sb-vm:funcallable-instance-header-type
+ (typecase x
+ (sb-kernel:byte-function
+ (%describe-function-byte-compiled x s kind name))
+ (sb-kernel:byte-closure
+ (%describe-function-byte-compiled (byte-closure-function x)
+ s kind name)
+ (format s "~@:_Its closure environment is:")
+ (pprint-logical-block (s nil)
+ (pprint-indent :current 8)
+ (let ((data (byte-closure-data x)))
+ (dotimes (i (length data))
+ (format s "~@:_~S: ~S" i (svref data i))))))
+ (sb-eval:interpreted-function
+ (%describe-function-interpreted x s kind name))
+ (standard-generic-function
+ ;; There should be a special method for this case; we'll
+ ;; delegate to that.
+ (describe-object x s))
+ (t
+ (format s "~@:_It is an unknown type of funcallable instance."))))
+ (t
+ (format s "~@:_It is an unknown type of function."))))
+
+(defmethod describe-object ((x function) s)
+ (%describe-function x s))
+
+(defmethod describe-object ((x symbol) s)
+ (declare (type stream s))
+
+ ;; Describe the packaging.
+ (let ((package (symbol-package x)))
+ (if package
+ (multiple-value-bind (symbol status)
+ (find-symbol (symbol-name x) package)
+ (declare (ignore symbol))
+ (format s "~S is an ~(~A~) symbol in ~S."
+ x status (symbol-package x)))
+ (format s "~S is an uninterned symbol." x)))
+ ;; TO DO: We could grovel over all packages looking for and
+ ;; reporting other phenomena, e.g. IMPORT and SHADOW, or
+ ;; availability in some package even after (SYMBOL-PACKAGE X) has
+ ;; been set to NIL.
+
+ ;; Describe the value cell.
+ (let* ((kind (info :variable :kind x))
+ (wot (ecase kind
+ (:special "special variable")
+ (:constant "constant")
+ (:global "undefined variable")
+ (:alien nil))))
+ (cond
+ ((eq kind :alien)
+ (let ((info (info :variable :alien-info x)))
+ (format s "~@:_~@<It is an alien at #X~8,'0X of type ~3I~:_~S.~:>~@:_"
+ (sap-int (eval (sb-alien::heap-alien-info-sap-form info)))
+ (sb-alien-internals:unparse-alien-type
+ (sb-alien::heap-alien-info-type info)))
+ (format s "~@<Its current value is ~3I~:_~S.~:>"
+ (eval x))))
+ ((boundp x)
+ (format s "~@:_It is a ~A; its value is ~S." wot (symbol-value x)))
+ ((not (eq kind :global))
+ (format s "~@:_It is a ~A; no current value." wot)))
+
+ (when (eq (info :variable :where-from x) :declared)
+ (format s "~@:_Its declared type is ~S."
+ (type-specifier (info :variable :type x))))
+
+ (%describe-doc x s 'variable kind))
+
+ ;; Print out properties.
+ (format s "~@[~@:_Its SYMBOL-PLIST is ~@<~2I~_~S~:>.~]" (symbol-plist x))
+
+ ;; Describe the function cell.
+ (cond ((macro-function x)
+ (%describe-function (macro-function x) s :macro x))
+ ((special-operator-p x)
+ (%describe-doc x s 'function "Special form"))
+ ((fboundp x)
+ (%describe-function (fdefinition x) s :function x)))
+
+ ;; TO DO: Print out other stuff from the INFO database:
+ ;; * Does it name a type or class?
+ ;; * Is it a structure accessor? (important since those are
+ ;; magical in some ways, e.g. blasting the structure if you
+ ;; redefine them)
+
+ ;; Print other documentation.
+ (%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))))
--- /dev/null
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!IMPL")
+
+(file-comment
+ "$Header$")
+
+(defmacro-mundanely destructuring-bind (lambda-list arg-list &rest body)
+ #!+sb-doc
+ "Bind the variables in LAMBDA-LIST to the contents of ARG-LIST."
+ (let* ((arg-list-name (gensym "ARG-LIST-")))
+ (multiple-value-bind (body local-decls)
+ (parse-defmacro lambda-list arg-list-name body nil 'destructuring-bind
+ :anonymousp t
+ :doc-string-allowed nil)
+ `(let ((,arg-list-name ,arg-list))
+ ,@local-decls
+ ,body))))
--- /dev/null
+;;;; runtime support for dynamic VOP statistics collection
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!DYNCOUNT")
+
+(file-comment
+ "$Header$")
+
+#|
+Make sure multi-cycle instruction costs are plausible.
+VOP classification.
+ Make tables of %cost for benchmark X class.
+ Could be represented as a sort of bar chart.
+|#
+
+(eval-when (:compile-toplevel)
+ (when *collect-dynamic-statistics*
+ (error "Compiling this file with dynamic stat collection turned on would ~
+ be a very bad idea.")))
+\f
+;;;; hash utilities
+
+(defun make-hash-table-like (table)
+ #!+sb-doc
+ "Make a hash-table with the same test as table."
+ (declare (type hash-table table))
+ (make-hash-table :test (sb!impl::hash-table-kind table)))
+
+(defun hash-difference (table1 table2)
+ #!+sb-doc
+ "Return a hash-table containing only the entries in Table1 whose key is not
+ also a key in Table2." (declare (type hash-table table1 table2))
+ (let ((res (make-hash-table-like table1)))
+ (dohash (k v table1)
+ (unless (nth-value 1 (gethash k table2))
+ (setf (gethash k res) v)))
+ res))
+
+(defun hash-list (table)
+ #!+sb-doc
+ "Return a list of the values in Table."
+ (declare (type hash-table table))
+ (collect ((res))
+ (dohash (k v table)
+ (declare (ignore k))
+ (res v))
+ (res)))
+
+;;; Read (or write) a hashtable from (or to) a file.
+(defun read-hash-table (file)
+ (with-open-file (s file :direction :input)
+ (dotimes (i 3)
+ (format t "~%; ~A" (read-line s)))
+ (let* ((eof '(nil))
+ (test (read s))
+ (reader (read s))
+ (res (make-hash-table :test test)))
+ (read s); Discard writer...
+ (loop
+ (let ((key (read s nil eof)))
+ (when (eq key eof) (return))
+ (setf (gethash key res)
+ (funcall reader s key))))
+ res)))
+(defun write-hash-table (table file &key
+ (comment (format nil "Contents of ~S" table))
+ (reader 'read) (writer 'prin1) (test 'equal))
+ (with-open-file (s file :direction :output :if-exists :new-version)
+ (with-standard-io-syntax
+ (let ((*print-readably* nil))
+ (format s
+ "~A~%~A version ~A on ~A~%"
+ comment
+ (lisp-implementation-type)
+ (lisp-implementation-version)
+ (machine-instance))
+ (format-universal-time s (get-universal-time))
+ (terpri s)
+ (format s "~S ~S ~S~%" test reader writer)
+ (dohash (k v table)
+ (prin1 k s)
+ (write-char #\space s)
+ (funcall writer v s)
+ (terpri s)))))
+ table)
+\f
+;;;; info accumulation
+
+;;; Used to accumulate info about the usage of a single VOP. Cost and count
+;;; are kept as double-floats, which lets us get more bits and avoid annoying
+;;; overflows.
+(deftype count-vector () '(simple-array double-float (2)))
+(defstruct (vop-stats
+ (:constructor %make-vop-stats (name))
+ (:constructor make-vop-stats-key))
+ (name (required-argument) :type simple-string)
+ (data (make-array 2 :element-type 'double-float) :type count-vector))
+
+(defmacro vop-stats-count (x) `(aref (vop-stats-data ,x) 0))
+(defmacro vop-stats-cost (x) `(aref (vop-stats-data ,x) 1))
+
+(defun make-vop-stats (&key name count cost)
+ (let ((res (%make-vop-stats name)))
+ (setf (vop-stats-count res) count)
+ (setf (vop-stats-cost res) cost)
+ res))
+
+#!-sb-fluid (declaim (freeze-type dyncount-info vop-stats))
+
+;;; Add the Info into the cumulative result on the VOP name plist. We use
+;;; plists so that we will touch minimal system code outside of this file
+;;; (which may be compiled with profiling on.)
+(defun note-dyncount-info (info)
+ (declare (type dyncount-info info) (inline get %put)
+ (optimize (speed 2)))
+ (let ((counts (dyncount-info-counts info))
+ (vops (dyncount-info-vops info)))
+ (dotimes (index (length counts))
+ (declare (type index index))
+ (let ((count (coerce (the (unsigned-byte 31)
+ (aref counts index))
+ 'double-float)))
+ (when (minusp count)
+ (warn "Oops: overflow.")
+ (return-from note-dyncount-info nil))
+ (unless (zerop count)
+ (let* ((vop-info (svref vops index))
+ (length (length vop-info)))
+ (declare (simple-vector vop-info))
+ (do ((i 0 (+ i 4)))
+ ((>= i length))
+ (declare (type index i))
+ (let* ((name (svref vop-info i))
+ (entry (or (get name 'vop-stats)
+ (setf (get name 'vop-stats)
+ (%make-vop-stats (symbol-name name))))))
+ (incf (vop-stats-count entry)
+ (* (coerce (the index (svref vop-info (1+ i)))
+ 'double-float)
+ count))
+ (incf (vop-stats-cost entry)
+ (* (coerce (the index (svref vop-info (+ i 2)))
+ 'double-float)
+ count))))))))))
+
+(defun clear-dyncount-info (info)
+ (declare (type dyncount-info info))
+ (declare (optimize (speed 3) (safety 0)))
+ (let ((counts (dyncount-info-counts info)))
+ (dotimes (i (length counts))
+ (setf (aref counts i) 0))))
+
+;;; Clear any VOP-COUNTS properties and the counts vectors for all code
+;;; objects. The latter loop must not call any random functions.
+(defun clear-vop-counts (&optional (spaces '(:dynamic)))
+ #!+sb-doc
+ "Clear all dynamic VOP counts for code objects in the specified spaces."
+ (dohash (k v *backend-template-names*)
+ (declare (ignore v))
+ (remprop k 'vop-stats))
+
+ (locally
+ (declare (optimize (speed 3) (safety 0))
+ (inline sb!vm::map-allocated-objects))
+ (without-gcing
+ (dolist (space spaces)
+ (sb!vm::map-allocated-objects
+ #'(lambda (object type-code size)
+ (declare (ignore type-code size))
+ (when (dyncount-info-p object)
+ (clear-dyncount-info object)))
+ space)))))
+
+;;; Call NOTE-DYNCOUNT-INFO on all DYNCOUNT-INFO structure allocated in the
+;;; specified spaces. Return a hashtable describing the counts. The initial
+;;; loop must avoid calling any functions outside this file to prevent adding
+;;; noise to the data, since other files may be compiled with profiling.
+(defun get-vop-counts (&optional (spaces '(:dynamic)) &key (clear nil))
+ #!+sb-doc
+ "Return a hash-table mapping string VOP names to VOP-STATS structures
+ describing the VOPs executed. If clear is true, then reset all counts to
+ zero as a side-effect."
+ (locally
+ (declare (optimize (speed 3) (safety 0))
+ (inline sb!vm::map-allocated-objects))
+ (without-gcing
+ (dolist (space spaces)
+ (sb!vm::map-allocated-objects
+ #'(lambda (object type-code size)
+ (declare (ignore type-code size))
+ (when (dyncount-info-p object)
+ (note-dyncount-info object)
+ (when clear
+ (clear-dyncount-info object))))
+ space))))
+
+ (let ((counts (make-hash-table :test 'equal)))
+ (dohash (k v *backend-template-names*)
+ (declare (ignore v))
+ (let ((stats (get k 'vop-stats)))
+ (when stats
+ (setf (gethash (symbol-name k) counts) stats)
+ (when clear
+ (remprop k 'vop-stats)))))
+ counts))
+
+;;; Return the DYNCOUNT-INFO for FUNCTION.
+(defun find-info-for (function)
+ (declare (type function function))
+ (let* ((function (%primitive closure-function function))
+ (component (sb!di::function-code-header function)))
+ (do ((end (get-header-data component))
+ (i sb!vm:code-constants-offset (1+ i)))
+ ((= end i))
+ (let ((constant (code-header-ref component i)))
+ (when (dyncount-info-p constant)
+ (return constant))))))
+
+(defun vop-counts-apply (function args &key (spaces '(:dynamic)) by-space)
+ #!+sb-doc
+ "Apply Function to Args, collecting dynamic statistics on the running.
+ Spaces are the spaces to scan for counts. If By-Space is true, we return a
+ list of result tables, instead of a single table. In this case, specify
+ :READ-ONLY first."
+ (clear-vop-counts spaces)
+ (apply function args)
+ (if by-space
+ (mapcar #'(lambda (space)
+ (get-vop-counts (list space) :clear t))
+ spaces)
+ (get-vop-counts spaces)))
+\f
+;;;; adjustments
+
+(defun get-vop-costs ()
+ #!+sb-doc
+ "Return a hash-table mapping string VOP names to the cost recorded in the
+ generator for all VOPs which are also the names of assembly routines."
+ (let ((res (make-hash-table :test 'equal)))
+ (dohash (name v *assembler-routines*)
+ (declare (ignore v))
+ (let ((vop (gethash name *backend-template-names*)))
+ (when vop
+ (setf (gethash (symbol-name name) res)
+ (template-cost (template-or-lose name))))))
+ res))
+
+(defvar *native-costs* (get-vop-costs)
+ #!+sb-doc
+ "Costs of assember routines on this machine.")
+\f
+;;;; classification
+
+(defparameter *basic-classes*
+ '(("Integer multiplication"
+ "*/FIXNUM" "*/SIGNED" "*/UNSIGNED" "SIGNED-*" "FIXNUM-*" "GENERIC-*")
+ ("Integer division" "TRUNCATE")
+ ("Generic arithmetic" "GENERIC" "TWO-ARG")
+ ("Inline EQL" "EQL")
+ ("Inline compare less/greater" "</" ">/" "<-C/" ">-C/")
+ ("Inline arith" "*/" "//" "+/" "-/" "NEGATE" "ABS" "+-C" "--C")
+ ("Inline logic" "-ASH" "$ASH" "LOG")
+ ("CAR/CDR" "CAR" "CDR")
+ ("Array type test" "ARRAYP" "VECTORP" "ARRAY-HEADER-P")
+ ;; FIXME: STRUCTUREP? This looks somewhat stale..
+ ("Simple type predicate" "STRUCTUREP" "LISTP" "FIXNUMP")
+ ("Simple type check" "CHECK-LIST" "CHECK-FIXNUM" "CHECK-STRUCTURE")
+ ("Array bounds check" "CHECK-BOUND")
+ ("Complex type check" "$CHECK-" "COERCE-TO-FUNCTION")
+ ("Special read" "SYMBOL-VALUE")
+ ("Special bind" "BIND$")
+ ("Tagging" "MOVE-FROM")
+ ("Untagging" "MOVE-TO" "MAKE-FIXNUM")
+ ("Move" "MOVE")
+ ("Non-local exit" "CATCH" "THROW" "DYNAMIC-STATE" "NLX" "UNWIND")
+ ("Array write" "DATA-VECTOR-SET" "$SET-RAW-BITS$")
+ ("Array read" "DATA-VECTOR-REF" "$RAW-BITS$" "VECTOR-LENGTH"
+ "LENGTH/SIMPLE" "ARRAY-HEADER")
+ ("List/string utility" "LENGTH/LIST" "SXHASH" "BIT-BASH" "$LENGTH$")
+ ("Alien operations" "SAP" "ALLOC-NUMBER-STACK" "$CALL-OUT$")
+ ("Function call/return" "CALL" "RETURN" "ALLOCATE-FRAME"
+ "COPY-MORE-ARG" "LISTIFY-REST-ARG" "VERIFY-ARGUMENT-COUNT")
+ ("Allocation" "MAKE-" "ALLOC" "$CONS$" "$LIST$" "$LIST*$")
+ ("Float conversion" "%SINGLE-FLOAT" "%DOUBLE-FLOAT" "-BITS$")
+ ("Complex type predicate" "P$")))
+
+;;; Return true if Name patches a specified pattern. Pattern is a string
+;;; (or symbol) or a list of strings (or symbols). If any specified string
+;;; appears as a substring of name, the pattern is matched. #\$'s are wapped
+;;; around name, allowing the use of $ to force a match at the beginning or
+;;; end.
+(defun matches-pattern (name pattern)
+ (declare (simple-string name))
+ (let ((name (concatenate 'string "$" name "$")))
+ (dolist (pat (if (listp pattern) pattern (list pattern)) nil)
+ (when (search (the simple-string (string pat))
+ name :test #'char=)
+ (return t)))))
+
+;;; Utilities for debugging classification rules. FIND-MATCHES returns a
+;;; list of all the VOP names in Table that match Pattern. WHAT-CLASS returns
+;;; the class that NAME would be placed in.
+(defun find-matches (table pattern)
+ (collect ((res))
+ (dohash (key value table)
+ (declare (ignore value))
+ (when (matches-pattern key pattern) (res key)))
+ (res)))
+(defun what-class (name classes)
+ (dolist (class classes nil)
+ (when (matches-pattern name (rest class)) (return (first class)))))
+
+;;; Given a VOP-STATS hash-table, return a new one with VOPs in the same
+;;; class merged into a single entry for that class. The classes are
+;;; represented as a list of lists: (class-name pattern*). Each pattern is a
+;;; string (or symbol) that can appear as a subsequence of the VOP name. A VOP
+;;; is placed in the first class that it matches, or is left alone if it
+;;; matches no class.
+(defun classify-costs (table classes)
+ (let ((res (make-hash-table-like table)))
+ (dohash (key value table)
+ (let ((class (dolist (class classes nil)
+ (when (matches-pattern key (rest class))
+ (return (first class))))))
+ (if class
+ (let ((found (or (gethash class res)
+ (setf (gethash class res)
+ (%make-vop-stats class)))))
+ (incf (vop-stats-count found) (vop-stats-count value))
+ (incf (vop-stats-cost found) (vop-stats-cost value)))
+ (setf (gethash key res) value))))
+ res))
+\f
+;;;; analysis
+
+;;; Sum the count and costs.
+(defun cost-summary (table)
+ (let ((total-count 0d0)
+ (total-cost 0d0))
+ (dohash (k v table)
+ (declare (ignore k))
+ (incf total-count (vop-stats-count v))
+ (incf total-cost (vop-stats-cost v)))
+ (values total-count total-cost)))
+
+;;; Return a hashtable of DYNCOUNT-INFO structures, with cost adjustments
+;;; according to the Costs table. Any VOPs in the list IGNORE are ignored.
+(defun compensate-costs (table costs &optional ignore)
+ (let ((res (make-hash-table-like table)))
+ (dohash (key value table)
+ (unless (or (string= key "COUNT-ME")
+ (member key ignore :test #'string=))
+ (let ((cost (gethash key costs)))
+ (if cost
+ (let* ((count (vop-stats-count value))
+ (sum (+ (* cost count)
+ (vop-stats-cost value))))
+ (setf (gethash key res)
+ (make-vop-stats :name key :count count :cost sum)))
+ (setf (gethash key res) value)))))
+ res))
+
+;;; Take two tables of vop-stats and return a table of entries where the
+;;; entries have been compared. The counts are normalized to Compared. The
+;;; costs are the difference of the costs adjusted by the difference in counts:
+;;; the cost for Original is modified to correspond to the count in Compared.
+(defun compare-stats (original compared)
+ (declare (type hash-table original compared))
+ (let ((res (make-hash-table-like original)))
+ (dohash (k cv compared)
+ (let ((ov (gethash k original)))
+ (when ov
+ (let ((norm-cnt (/ (vop-stats-count ov) (vop-stats-count cv))))
+ (setf (gethash k res)
+ (make-vop-stats
+ :name k
+ :count norm-cnt
+ :cost (- (/ (vop-stats-cost ov) norm-cnt)
+ (vop-stats-cost cv))))))))
+ res))
+
+(defun combine-stats (&rest tables)
+ #!+sb-doc
+ "Sum the VOP stats for the specified tables, returning a new table with the
+ combined results."
+ (let ((res (make-hash-table-like (first tables))))
+ (dolist (table tables)
+ (dohash (k v table)
+ (let ((found (or (gethash k res)
+ (setf (gethash k res) (%make-vop-stats k)))))
+ (incf (vop-stats-count found) (vop-stats-count v))
+ (incf (vop-stats-cost found) (vop-stats-cost v)))))
+ res))
+\f
+;;;; report generation
+
+(defun sort-result (table by)
+ (sort (hash-list table) #'>
+ :key #'(lambda (x)
+ (abs (ecase by
+ (:count (vop-stats-count x))
+ (:cost (vop-stats-cost x)))))))
+
+;;; Report about VOPs in the list of stats structures.
+(defun entry-report (entries cut-off compensated compare total-cost)
+ (let ((counter (if (and cut-off (> (length entries) cut-off))
+ cut-off
+ most-positive-fixnum)))
+ (dolist (entry entries)
+ (let* ((cost (vop-stats-cost entry))
+ (name (vop-stats-name entry))
+ (entry-count (vop-stats-count entry))
+ (comp-entry (if compare (gethash name compare) entry))
+ (count (vop-stats-count comp-entry)))
+ (format t "~30<~A~>: ~:[~13:D~;~13,2F~] ~9,2F ~5,2,2F%~%"
+ (vop-stats-name entry)
+ compare
+ (if compare entry-count (round entry-count))
+ (/ cost count)
+ (/ (if compare
+ (- (vop-stats-cost (gethash name compensated))
+ (vop-stats-cost comp-entry))
+ cost)
+ total-cost))
+ (when (zerop (decf counter))
+ (format t "[End of top ~D]~%" cut-off))))))
+
+;;; Divide SORTED into two lists, the first CUT-OFF elements long. Any VOP
+;;; names that match one of the report strings are moved into the REPORT list
+;;; even if they would otherwise fall below the CUT-OFF.
+(defun find-cut-off (sorted cut-off report)
+ (if (or (not cut-off) (<= (length sorted) cut-off))
+ (values sorted ())
+ (let ((not-cut (subseq sorted 0 cut-off)))
+ (collect ((select)
+ (reject))
+ (dolist (el (nthcdr cut-off sorted))
+ (let ((name (vop-stats-name el)))
+ (if (matches-pattern name report)
+ (select el)
+ (reject el))))
+ (values (append not-cut (select)) (reject))))))
+
+;;; Display information about entries that were not displayed due to the
+;;; cut-off. Note: if compare, we find the total cost delta and the geometric
+;;; mean of the normalized counts.
+(defun cut-off-report (other compare total-cost)
+ (let ((rest-cost 0d0)
+ (rest-count 0d0)
+ (rest-entry-count (if compare 1d0 0d0)))
+ (dolist (entry other)
+ (incf rest-cost (vop-stats-cost entry))
+ (incf rest-count
+ (vop-stats-count
+ (if compare
+ (gethash (vop-stats-name entry) compare)
+ entry)))
+ (if compare
+ (setq rest-entry-count
+ (* rest-entry-count (vop-stats-count entry)))
+ (incf rest-entry-count (vop-stats-count entry))))
+
+ (let ((count (if compare
+ (expt rest-entry-count
+ (/ (coerce (length other) 'double-float)))
+ (round rest-entry-count))))
+ (format t "~30<Other~>: ~:[~13:D~;~13,2F~] ~9,2F ~@[~5,2,2F%~]~%"
+ compare count
+ (/ rest-cost rest-count)
+ (unless compare
+ (/ rest-cost total-cost))))))
+
+;;; Report summary information about the difference between the comparison
+;;; and base data sets.
+(defun compare-report (total-count total-cost compare-total-count
+ compare-total-cost compensated compare)
+ (format t "~30<Relative total~>: ~13,2F ~9,2F~%"
+ (/ total-count compare-total-count)
+ (/ total-cost compare-total-cost))
+ (flet ((frob (a b sign wot)
+ (multiple-value-bind (cost count)
+ (cost-summary (hash-difference a b))
+ (unless (zerop count)
+ (format t "~30<~A~>: ~13:D ~9,2F ~5,2,2F%~%"
+ wot (* sign (round count))
+ (* sign (/ cost count))
+ (* sign (/ cost compare-total-cost)))))))
+ (frob compensated compare 1 "Not in comparison")
+ (frob compare compensated -1 "Only in comparison"))
+ (format t "~30<Comparison total~>: ~13,2E ~9,2E~%"
+ compare-total-count compare-total-cost))
+
+;;; The fraction of system time that we guess happened during GC.
+(defparameter *gc-system-fraction* 2/3)
+
+;;; Estimate CPI from CPU time and cycles accounted in profiling information.
+(defun find-cpi (total-cost user system gc clock)
+ (let ((adj-time (if (zerop gc)
+ user
+ (- user (- gc (* system *gc-system-fraction*))))))
+ (/ (* adj-time clock) total-cost)))
+
+;;; Generate a report from the specified table.
+(defun generate-report (table &key (cut-off 15) (sort-by :cost)
+ (costs *native-costs*)
+ ((:compare uncomp-compare))
+ (compare-costs costs)
+ ignore report
+ (classes *basic-classes*)
+ user (system 0d0) (gc 0d0)
+ (clock 25d6))
+ (let* ((compensated
+ (classify-costs
+ (if costs
+ (compensate-costs table costs ignore)
+ table)
+ classes))
+ (compare
+ (when uncomp-compare
+ (classify-costs
+ (if compare-costs
+ (compensate-costs uncomp-compare compare-costs ignore)
+ uncomp-compare)
+ classes)))
+ (compared (if compare
+ (compare-stats compensated compare)
+ compensated))
+ (*gc-verbose* nil)
+ (*gc-notify-stream* nil))
+ (multiple-value-bind (total-count total-cost) (cost-summary compensated)
+ (multiple-value-bind (compare-total-count compare-total-cost)
+ (when compare (cost-summary compare))
+ (format t "~2&~30<Vop~> ~13<Count~> ~9<Cost~> ~6:@<Percent~>~%")
+ (let ((sorted (sort-result compared sort-by))
+ (base-total (if compare compare-total-cost total-cost)))
+ (multiple-value-bind (report other)
+ (find-cut-off sorted cut-off report)
+ (entry-report report cut-off compensated compare base-total)
+ (when other
+ (cut-off-report other compare base-total))))
+
+ (when compare
+ (compare-report total-count total-cost compare-total-count
+ compare-total-cost compensated compare))
+
+ (format t "~30<Total~>: ~13,2E ~9,2E~%" total-count total-cost)
+ (when user
+ (format t "~%Cycles per instruction = ~,2F~%"
+ (find-cpi total-cost user system gc clock))))))
+ (values))
+
+;;; Read & write VOP stats using hash IO utility.
+(defun stats-reader (stream key)
+ (make-vop-stats :name key :count (read stream) :cost (read stream)))
+(defun stats-writer (object stream)
+ (format stream "~S ~S" (vop-stats-count object) (vop-stats-cost object)))
--- /dev/null
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!ALIEN")
+
+(file-comment
+ "$Header$")
+
+(defvar *alien-type-classes* (make-hash-table :test 'eq))
+
+(defvar *new-auxiliary-types* nil)
+
+;;; the list of record types that have already been unparsed. This is
+;;; used to keep from outputting the slots again if the same structure
+;;; shows up twice.
+(defvar *record-types-already-unparsed*)
--- /dev/null
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!IMPL")
+
+(file-comment
+ "$Header$")
+
+(defconstant sb!xc:array-rank-limit 65529
+ #!+sb-doc
+ "the exclusive upper bound on the rank of an array")
+
+(defconstant sb!xc:array-dimension-limit sb!vm:*target-most-positive-fixnum*
+ #!+sb-doc
+ "the exclusive upper bound on any given dimension of an array")
+
+(defconstant sb!xc:array-total-size-limit sb!vm:*target-most-positive-fixnum*
+ #!+sb-doc
+ "the exclusive upper bound on the total number of elements in an array")
--- /dev/null
+;;;; miscellaneous stuff about the ANSI standard
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!KERNEL")
+
+(file-comment
+ "$Header$")
+
+;;; Common Lisp special variables which have SB-XC versions
+(proclaim '(special sb!xc:*macroexpand-hook*))
+
+;;; the Common Lisp defined type specifier symbols
+(declaim (type list *standard-type-names*))
+(defparameter *standard-type-names*
+ '(array atom bignum bit bit-vector character compiled-function
+ complex cons double-float extended-char fixnum float function
+ hash-table integer keyword list long-float nil null number package
+ pathname random-state ratio rational real readtable sequence
+ short-float simple-array simple-bit-vector simple-string simple-vector
+ single-float standard-char stream string base-char symbol t vector))
--- /dev/null
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!IMPL")
+
+(file-comment
+ "$Header$")
+
+#+sb-xc-host
+(defmacro def!method (&rest args)
+ `(defmethod ,@args))
--- /dev/null
+;;;; target bootstrapping stuff which needs to be visible on the
+;;;; cross-compilation host too
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!EXT")
+
+(file-comment
+ "$Header$")
+
+;;; helper function for various macros which expect clauses of a given
+;;; length, etc.
+;;;
+;;; KLUDGE: This implementation will hang on circular list structure. Since
+;;; this is an error-checking utility, i.e. its job is to deal with screwed-up
+;;; input, it'd be good style to fix it so that it can deal with circular list
+;;; structure.
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ ;; Return true if X is a proper list whose length is between MIN and
+ ;; MAX (inclusive).
+ (defun proper-list-of-length-p (x min &optional (max min))
+ (cond ((minusp max)
+ nil)
+ ((null x)
+ (zerop min))
+ ((consp x)
+ (and (plusp max)
+ (proper-list-of-length-p (cdr x)
+ (if (plusp (1- min))
+ (1- min)
+ 0)
+ (1- max))))
+ (t nil))))
+\f
+;;;; DO-related stuff which needs to be visible on the cross-compilation host
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defun do-do-body (varlist endlist decls-and-code bind step name block)
+ (let* ((r-inits nil) ; accumulator for reversed list
+ (r-steps nil) ; accumulator for reversed list
+ (label-1 (gensym))
+ (label-2 (gensym)))
+ ;; Check for illegal old-style DO.
+ (when (or (not (listp varlist)) (atom endlist))
+ (error "Ill-formed ~S -- possibly illegal old style DO?" name))
+ ;; Parse VARLIST to get R-INITS and R-STEPS.
+ (dolist (v varlist)
+ (flet (;; (We avoid using CL:PUSH here so that CL:PUSH can be defined
+ ;; in terms of CL:SETF, and CL:SETF can be defined in terms of
+ ;; CL:DO, and CL:DO can be defined in terms of the current
+ ;; function.)
+ (push-on-r-inits (x)
+ (setq r-inits (cons x r-inits)))
+ ;; common error-handling
+ (illegal-varlist ()
+ (error "~S is an illegal form for a ~S varlist." v name)))
+ (cond ((symbolp v) (push-on-r-inits v))
+ ((listp v)
+ (unless (symbolp (first v))
+ (error "~S step variable is not a symbol: ~S"
+ name
+ (first v)))
+ (let ((lv (length v)))
+ ;; (We avoid using CL:CASE here so that CL:CASE can be
+ ;; defined in terms of CL:SETF, and CL:SETF can be defined
+ ;; in terms of CL:DO, and CL:DO can be defined in terms of
+ ;; the current function.)
+ (cond ((= lv 1)
+ (push-on-r-inits (first v)))
+ ((= lv 2)
+ (push-on-r-inits v))
+ ((= lv 3)
+ (push-on-r-inits (list (first v) (second v)))
+ (setq r-steps (list* (third v) (first v) r-steps)))
+ (t (illegal-varlist)))))
+ (t (illegal-varlist)))))
+ ;; Construct the new form.
+ (multiple-value-bind (code decls) (parse-body decls-and-code nil)
+ `(block ,block
+ (,bind ,(nreverse r-inits)
+ ,@decls
+ (tagbody
+ (go ,label-2)
+ ,label-1
+ ,@code
+ (,step ,@(nreverse r-steps))
+ ,label-2
+ (unless ,(first endlist) (go ,label-1))
+ (return-from ,block (progn ,@(rest endlist))))))))))
+
+(defmacro do-anonymous (varlist endlist &rest body)
+ #!+sb-doc
+ "DO-ANONYMOUS ({(Var [Init] [Step])}*) (Test Exit-Form*) Declaration* Form*
+ Like DO, but has no implicit NIL block. Each Var is initialized in parallel
+ to the value of the specified Init form. On subsequent iterations, the Vars
+ are assigned the value of the Step form (if any) in parallel. The Test is
+ evaluated before each evaluation of the body Forms. When the Test is true,
+ the Exit-Forms are evaluated as a PROGN, with the result being the value
+ of the DO."
+ (do-do-body varlist endlist body 'let 'psetq 'do-anonymous (gensym)))
--- /dev/null
+;;;; descriptions of DEFSTRUCTs which are to be handled before any others
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+;;;; $Header$
+
+(;; Define the STRUCTURE-OBJECT class as a subclass of
+ ;; INSTANCE. This has to be handled early because the design of the
+ ;; DEFSTRUCT system, dating back to pre-1999 CMU CL, requires that
+ ;; STRUCTURE-OBJECT be the first DEFSTRUCT executed.
+ ((structure-object (:alternate-metaclass sb!kernel:instance)
+ (:copier nil))
+ ;; (There are no slots.)
+ )
+
+ ;; The target ALIEN-VALUE class must be defined early in the cross-compiler
+ ;; build sequence in order to set up superclass relationships involving it.
+ ;;
+ ;; FIXME: Since this definition refers to SB!ALIEN:ALIEN-TYPE, which is also
+ ;; defined as a structure, perhaps it might be reasonable to add an entry,
+ ;; somewhere before this definition, to define SB!ALIEN:ALIEN-TYPE? That
+ ;; way, any tests for SB!ALIEN:ALIEN-TYPE in the slot accessor functions
+ ;; could be implemented more efficiently.
+ ((sb!alien-internals:alien-value)
+ (sap (required-argument) :type sb!sys:system-area-pointer)
+ (type (required-argument) :type sb!alien::alien-type)))
--- /dev/null
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!KERNEL")
+
+(file-comment
+ "$Header$")
+
+#.`(progn
+ ,@(mapcar (lambda (args)
+ `(defstruct ,@args))
+ (sb-cold:read-from-file "src/code/early-defstruct-args.lisp-expr")))
--- /dev/null
+;;;; This file contains definitions and declarations for the
+;;;; EXTENSIONS package which must be available at early cross-compile
+;;;; time, and perhaps also some things which might as well be built
+;;;; at cross-compile time even if they're not strictly needed, since
+;;;; that's harmless. Things which can't be built at cross-compile
+;;;; time (e.g. because they need machinery which only exists inside
+;;;; CMU CL's implementation of the LISP package) do not belong in
+;;;; this file.
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!EXT")
+
+(file-comment
+ "$Header$")
+
+;;; the default value used for initializing character data. The ANSI
+;;; spec says this is arbitrary. CMU CL used #\NULL, which we avoid
+;;; because it's not in the ANSI table of portable characters.
+(defconstant default-init-char #\space)
+
+;;; CHAR-CODE values for ASCII characters which we care about but
+;;; which aren't defined in section "2.1.3 Standard Characters" of the
+;;; ANSI specification for Lisp
+;;;
+;;; KLUDGE: These are typically used in the idiom (CODE-CHAR
+;;; FOO-CHAR-CODE). I suspect that the current implementation is
+;;; expanding this idiom into a full call to CODE-CHAR, which is an
+;;; annoying overhead. I should check whether this is happening, and
+;;; if so, perhaps implement a DEFTRANSFORM or something to stop it.
+;;; (or just find a nicer way of expressing characters portably?) --
+;;; WHN 19990713
+(defconstant bell-char-code 7)
+(defconstant tab-char-code 9)
+(defconstant form-feed-char-code 12)
+(defconstant return-char-code 13)
+(defconstant escape-char-code 27)
+(defconstant rubout-char-code 127)
+\f
+;;; Concatenate together the names of some strings and symbols,
+;;; producing a symbol in the current package.
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (declaim (ftype (function (&rest (or string symbol)) symbol) symbolicate))
+ (defun symbolicate (&rest things)
+ (values (intern (apply #'concatenate
+ 'string
+ (mapcar #'string things))))))
+
+;;; like SYMBOLICATE, but producing keywords
+(defun keywordicate (&rest things)
+ (let ((*package* *keyword-package*))
+ (apply #'symbolicate things)))
+\f
+;;;; miscellaneous iteration extensions
+
+(defmacro dovector ((elt vector &optional result) &rest forms)
+ #!+sb-doc
+ "just like DOLIST, but with one-dimensional arrays"
+ (let ((index (gensym))
+ (length (gensym))
+ (vec (gensym)))
+ `(let ((,vec ,vector))
+ (declare (type vector ,vec))
+ (do ((,index 0 (1+ ,index))
+ (,length (length ,vec)))
+ ((>= ,index ,length) ,result)
+ (let ((,elt (aref ,vec ,index)))
+ ,@forms)))))
+
+(defmacro dohash ((key-var value-var table &optional result) &body body)
+ #!+sb-doc
+ "DOHASH (Key-Var Value-Var Table [Result]) Declaration* Form*
+ Iterate over the entries in a hash-table."
+ (multiple-value-bind (forms decls) (parse-body body nil)
+ (let ((gen (gensym))
+ (n-more (gensym)))
+ `(with-hash-table-iterator (,gen ,table)
+ (loop
+ (multiple-value-bind (,n-more ,key-var ,value-var) (,gen)
+ ,@decls
+ (unless ,n-more (return ,result))
+ ,@forms))))))
+\f
+;;;; hash cache utility
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defvar *profile-hash-cache* nil))
+
+;;; :INIT-WRAPPER is set to COLD-INIT-FORMS in type system definitions
+;;; so that caches will be created before top-level forms run.
+(defmacro define-hash-cache (name args &key hash-function hash-bits default
+ (init-wrapper 'progn)
+ (values 1))
+ #!+sb-doc
+ "DEFINE-HASH-CACHE Name ({(Arg-Name Test-Function)}*) {Key Value}*
+ Define a hash cache that associates some number of argument values to a
+ result value. The Test-Function paired with each Arg-Name is used to compare
+ the value for that arg in a cache entry with a supplied arg. The
+ Test-Function must not error when passed NIL as its first arg, but need not
+ return any particular value. Test-Function may be any thing that can be
+ placed in CAR position.
+
+ Name is used to define these functions:
+
+ <name>-CACHE-LOOKUP Arg*
+ See whether there is an entry for the specified Args in the cache. If
+ not present, the :DEFAULT keyword (default NIL) determines the result(s).
+
+ <name>-CACHE-ENTER Arg* Value*
+ Encache the association of the specified args with Value.
+
+ <name>-CACHE-CLEAR
+ Reinitialize the cache, invalidating all entries and allowing the
+ arguments and result values to be GC'd.
+
+ These other keywords are defined:
+
+ :HASH-BITS <n>
+ The size of the cache as a power of 2.
+
+ :HASH-FUNCTION function
+ Some thing that can be placed in CAR position which will compute a value
+ between 0 and (1- (expt 2 <hash-bits>)).
+
+ :VALUES <n>
+ The number of values cached.
+
+ :INIT-WRAPPER <name>
+ The code for initializing the cache is wrapped in a form with the
+ specified name. Default PROGN."
+
+ (let* ((var-name (symbolicate "*" name "-CACHE-VECTOR*"))
+ (nargs (length args))
+ (entry-size (+ nargs values))
+ (size (ash 1 hash-bits))
+ (total-size (* entry-size size))
+ (default-values (if (and (consp default) (eq (car default) 'values))
+ (cdr default)
+ (list default)))
+ (n-index (gensym))
+ (n-cache (gensym)))
+
+ (unless (= (length default-values) values)
+ (error "The number of default values ~S differs from :VALUES ~D."
+ default values))
+
+ (collect ((inlines)
+ (forms)
+ (inits)
+ (tests)
+ (sets)
+ (arg-vars)
+ (values-indices)
+ (values-names))
+ (dotimes (i values)
+ (values-indices `(+ ,n-index ,(+ nargs i)))
+ (values-names (gensym)))
+ (let ((n 0))
+ (dolist (arg args)
+ (unless (= (length arg) 2)
+ (error "bad arg spec: ~S" arg))
+ (let ((arg-name (first arg))
+ (test (second arg)))
+ (arg-vars arg-name)
+ (tests `(,test (svref ,n-cache (+ ,n-index ,n)) ,arg-name))
+ (sets `(setf (svref ,n-cache (+ ,n-index ,n)) ,arg-name)))
+ (incf n)))
+
+ (when *profile-hash-cache*
+ (let ((n-probe (symbolicate "*" name "-CACHE-PROBES*"))
+ (n-miss (symbolicate "*" name "-CACHE-MISSES*")))
+ (inits `(setq ,n-probe 0))
+ (inits `(setq ,n-miss 0))
+ (forms `(defvar ,n-probe))
+ (forms `(defvar ,n-miss))
+ (forms `(declaim (fixnum ,n-miss ,n-probe)))))
+
+ (let ((fun-name (symbolicate name "-CACHE-LOOKUP")))
+ (inlines fun-name)
+ (forms
+ `(defun ,fun-name ,(arg-vars)
+ ,@(when *profile-hash-cache*
+ `((incf ,(symbolicate "*" name "-CACHE-PROBES*"))))
+ (let ((,n-index (* (,hash-function ,@(arg-vars)) ,entry-size))
+ (,n-cache ,var-name))
+ (declare (type fixnum ,n-index))
+ (cond ((and ,@(tests))
+ (values ,@(mapcar (lambda (x) `(svref ,n-cache ,x))
+ (values-indices))))
+ (t
+ ,@(when *profile-hash-cache*
+ `((incf ,(symbolicate "*" name "-CACHE-MISSES*"))))
+ ,default))))))
+
+ (let ((fun-name (symbolicate name "-CACHE-ENTER")))
+ (inlines fun-name)
+ (forms
+ `(defun ,fun-name (,@(arg-vars) ,@(values-names))
+ (let ((,n-index (* (,hash-function ,@(arg-vars)) ,entry-size))
+ (,n-cache ,var-name))
+ (declare (type fixnum ,n-index))
+ ,@(sets)
+ ,@(mapcar #'(lambda (i val)
+ `(setf (svref ,n-cache ,i) ,val))
+ (values-indices)
+ (values-names))
+ (values)))))
+
+ (let ((fun-name (symbolicate name "-CACHE-CLEAR")))
+ (forms
+ `(defun ,fun-name ()
+ (do ((,n-index ,(- total-size entry-size) (- ,n-index ,entry-size))
+ (,n-cache ,var-name))
+ ((minusp ,n-index))
+ (declare (type fixnum ,n-index))
+ ,@(collect ((arg-sets))
+ (dotimes (i nargs)
+ (arg-sets `(setf (svref ,n-cache (+ ,n-index ,i)) nil)))
+ (arg-sets))
+ ,@(mapcar #'(lambda (i val)
+ `(setf (svref ,n-cache ,i) ,val))
+ (values-indices)
+ default-values))
+ (values)))
+ (forms `(,fun-name)))
+
+ (inits `(unless (boundp ',var-name)
+ (setq ,var-name (make-array ,total-size))))
+
+ `(progn
+ (defvar ,var-name)
+ (declaim (type (simple-vector ,total-size) ,var-name))
+ #!-sb-fluid (declaim (inline ,@(inlines)))
+ (,init-wrapper ,@(inits))
+ ,@(forms)
+ ',name))))
+
+(defmacro defun-cached ((name &rest options &key (values 1) default
+ &allow-other-keys)
+ args &body body-decls-doc)
+ #!+sb-doc
+ "DEFUN-CACHED (Name {Key Value}*) ({(Arg-Name Test-Function)}*) Form*
+ Some syntactic sugar for defining a function whose values are cached by
+ DEFINE-HASH-CACHE."
+ (let ((default-values (if (and (consp default) (eq (car default) 'values))
+ (cdr default)
+ (list default)))
+ (arg-names (mapcar #'car args)))
+ (collect ((values-names))
+ (dotimes (i values)
+ (values-names (gensym)))
+ (multiple-value-bind (body decls doc) (parse-body body-decls-doc)
+ `(progn
+ (define-hash-cache ,name ,args ,@options)
+ (defun ,name ,arg-names
+ ,@decls
+ ,doc
+ (multiple-value-bind ,(values-names)
+ (,(symbolicate name "-CACHE-LOOKUP") ,@arg-names)
+ (if (and ,@(mapcar #'(lambda (val def)
+ `(eq ,val ,def))
+ (values-names) default-values))
+ (multiple-value-bind ,(values-names)
+ (progn ,@body)
+ (,(symbolicate name "-CACHE-ENTER") ,@arg-names
+ ,@(values-names))
+ (values ,@(values-names)))
+ (values ,@(values-names))))))))))
+\f
+;;;; package idioms
+
+;;; Note: Almost always you want to use FIND-UNDELETED-PACKAGE-OR-LOSE
+;;; instead of this function. (The distinction only actually matters when
+;;; PACKAGE-DESIGNATOR is actually a deleted package, and in that case
+;;; you generally do want to signal an error instead of proceeding.)
+(defun %find-package-or-lose (package-designator)
+ (or (find-package package-designator)
+ (error 'sb!kernel:simple-package-error
+ :package package-designator
+ :format-control "The name ~S does not designate any package."
+ :format-arguments (list package-designator))))
+
+;;; ANSI specifies (in the section for FIND-PACKAGE) that the
+;;; consequences of most operations on deleted packages are
+;;; unspecified. We try to signal errors in such cases.
+(defun find-undeleted-package-or-lose (package-designator)
+ (let ((maybe-result (%find-package-or-lose package-designator)))
+ (if (package-name maybe-result) ; if not deleted
+ maybe-result
+ (error 'sb!kernel:simple-package-error
+ :package maybe-result
+ :format-control "The package ~S has been deleted."
+ :format-arguments (list maybe-result)))))
+\f
+;;;; miscellany
+
+;;; FIXME: What is this used for that SYMBOLICATE couldn't be used for instead?
+;;; If nothing, replace it.
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defun concat-pnames (name1 name2)
+ (declare (symbol name1 name2))
+ (if name1
+ (intern (concatenate 'simple-string
+ (symbol-name name1)
+ (symbol-name name2)))
+ name2)))
+
+;;; Is NAME a legal function name?
+(defun legal-function-name-p (name)
+ (or (symbolp name)
+ (and (consp name)
+ (eq (car name) 'setf)
+ (consp (cdr name))
+ (symbolp (cadr name))
+ (null (cddr name)))))
+
+;;; Given a function name, return the name for the BLOCK which encloses its
+;;; body (e.g. in DEFUN, DEFINE-COMPILER-MACRO, or FLET).
+(declaim (ftype (function ((or symbol cons)) symbol) function-name-block-name))
+(defun function-name-block-name (function-name)
+ (cond ((symbolp function-name)
+ function-name)
+ ((and (consp function-name)
+ (= (length function-name) 2)
+ (eq (first function-name) 'setf))
+ (second function-name))
+ (t
+ (error "not legal as a function name: ~S" function-name))))
+
+;;; Is X a (possibly-improper) list of at least N elements?
+(defun list-of-length-at-least-p (x n)
+ (declare (type (and unsigned-byte fixnum) n))
+ (or (zerop n) ; since anything can be considered an improper list of length 0
+ (and (consp x)
+ (list-of-length-at-least-p (cdr x) (1- n)))))
+\f
+#|
+;;; REMOVEME when done testing byte cross-compiler
+(defun byte-compiled-foo (x y)
+ (declare (optimize (speed 0) (debug 1)))
+ (if x
+ x
+ (cons y y)))
+|#
\ No newline at end of file
--- /dev/null
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!FORMAT")
+
+(file-comment
+ "$Header$")
+
+(defparameter *format-whitespace-chars*
+ (vector #\space
+ #\newline
+ ;; We leave out this non-STANDARD-CHARACTER entry from this table
+ ;; when we're running in the cross-compilation host, since ANSI
+ ;; doesn't require the cross-compilation host to know what a tab is.
+ #-sb-xc-host (code-char tab-char-code)))
+
+(defvar *format-directive-expanders*
+ (make-array char-code-limit :initial-element nil))
+(defvar *format-directive-interpreters*
+ (make-array char-code-limit :initial-element nil))
+
+(defvar *default-format-error-control-string* nil)
+(defvar *default-format-error-offset* nil)
+\f
+;;;; specials used to communicate information
+
+;;; Used both by the expansion stuff and the interpreter stuff. When it is
+;;; non-NIL, up-up-and-out (~:^) is allowed. Otherwise, ~:^ isn't allowed.
+(defvar *up-up-and-out-allowed* nil)
+
+;;; Used by the interpreter stuff. When it non-NIL, its a function that will
+;;; invoke PPRINT-POP in the right lexical environemnt.
+(defvar *logical-block-popper* nil)
+
+;;; Used by the expander stuff. This is bindable so that ~<...~:>
+;;; can change it.
+(defvar *expander-next-arg-macro* 'expander-next-arg)
+
+;;; Used by the expander stuff. Initially starts as T, and gets set to NIL
+;;; if someone needs to do something strange with the arg list (like use
+;;; the rest, or something).
+(defvar *only-simple-args*)
+
+;;; Used by the expander stuff. We do an initial pass with this as NIL.
+;;; If someone doesn't like this, they (throw 'need-orig-args nil) and we try
+;;; again with it bound to T. If this is T, we don't try to do anything
+;;; fancy with args.
+(defvar *orig-args-available* nil)
+
+;;; Used by the expander stuff. List of (symbol . offset) for simple args.
+(defvar *simple-args*)
--- /dev/null
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!IMPL")
+
+(file-comment
+ "$Header$")
+
+;;; entries in STATIC-SYMBOLS table, references to which can be compiled
+;;; as though they're special variables
+(declaim (special *posix-argv*
+ *!initial-fdefn-objects*
+ *read-only-space-free-pointer*
+ *static-space-free-pointer*
+ *initial-dynamic-space-free-pointer*
+ *current-catch-block*
+ *current-unwind-protect-block*
+ sb!c::*eval-stack-top*
+ sb!vm::*alien-stack*
+ ;; KLUDGE: I happened to notice that these should be #!+X86.
+ ;; There could easily be others in the list, too.
+ #!+x86 *pseudo-atomic-atomic*
+ #!+x86 *pseudo-atomic-interrupted*
+ sb!unix::*interrupts-enabled*
+ sb!unix::*interrupt-pending*
+ *free-interrupt-context-index*
+ sb!vm::*allocation-pointer*
+ sb!vm::*binding-stack-pointer*
+ sb!vm::*internal-gc-trigger*
+ sb!vm::*fp-constant-0d0*
+ sb!vm::*fp-constant-1d0*
+ sb!vm::*fp-constant-0s0*
+ sb!vm::*fp-constant-1s0*
+ sb!vm::*fp-constant-0l0*
+ sb!vm::*fp-constant-1l0*
+ sb!vm::*fp-constant-pi*
+ sb!vm::*fp-constant-l2t*
+ sb!vm::*fp-constant-l2e*
+ sb!vm::*fp-constant-lg2*
+ sb!vm::*fp-constant-ln2*
+ sb!vm::*scavenge-read-only-space*
+ sb!vm::*control-stacks*
+ sb!pcl::..slot-unbound..
+ sb!vm::*x86-cgc-active-p*
+ sb!vm::*static-blue-bag*))
--- /dev/null
+;;;; needed-early stuff for the loader
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!IMPL")
+
+(file-comment
+ "$Header$")
+
+;;; information about non-Lisp-level linkage
+;;;
+;;; Note:
+;;; Assembler routines are named by full Lisp symbols: they
+;;; have packages and that sort of native Lisp stuff associated
+;;; with them. We can compare them with EQ.
+;;; Foreign symbols are named by Lisp strings: the Lisp package
+;;; system doesn't extend out to symbols in languages like C.
+;;; We want to use EQUAL to compare them.
+;;; *STATIC-FOREIGN-SYMBOLS* are static as opposed to "dynamic" (not
+;;; as opposed to "extern"). The table contains symbols known at
+;;; the time that the program was built, but not symbols defined
+;;; in object files which have been loaded dynamically since then.
+(declaim (type hash-table *assembler-routines* *static-foreign-symbols*))
+(defvar *assembler-routines* (make-hash-table :test 'eq))
+(defvar *static-foreign-symbols* (make-hash-table :test 'equal))
+
+;;; the FOP database
+(defvar *fop-names* (make-array 256 :initial-element nil)
+ #!+sb-doc
+ "a vector indexed by a FaslOP that yields the FOP's name")
+(defvar *fop-functions*
+ (make-array 256
+ :initial-element (lambda ()
+ (error "corrupt fasl file: losing FOP")))
+ #!+sb-doc
+ "a vector indexed by a FaslOP that yields a function of 0 arguments which
+ will perform the operation")
+(declaim (simple-vector *fop-names* *fop-functions*))
+
+(defvar *load-code-verbose* nil)
+
+;;; Moving native code during a GC or purify is not trivial on the x86
+;;; port, so there are a few options for code placement.
+;;;
+;;; Byte-compiled code objects can always be moved so can be place in
+;;; the dynamics heap. This is enabled with
+;;; *load-byte-compiled-code-to-dynamic-space*.
+;;; FIXME: See whether this really works. Also, now that we have gencgc
+;;; and all code moves, perhaps we could just remove this conditional
+;;; and make this fixed behavior.
+;;;
+;;; Native code top level forms only have a short life so can be
+;;; safely loaded into the dynamic heap (without fixups) so long as
+;;; the GC is not active. This could be handy during a world load to
+;;; save core space without the need to enable the support for moving
+;;; x86 native code. Enable with *load-x86-tlf-to-dynamic-space*.
+;;; FIXME: Yikes! Could we punt this?
+;;;
+;;; One strategy for allowing the loading of x86 native code into the
+;;; dynamic heap requires that the addresses of fixups be saved for
+;;; all these code objects. After a purify these fixups can be
+;;; dropped. This is enabled with *enable-dynamic-space-code*.
+;;;
+;;; A little analysis of the header information is used to determine
+;;; if a code object is byte compiled, or native code.
+(defvar *load-byte-compiled-code-to-dynamic-space* t)
+(defvar *load-x86-tlf-to-dynamic-space* nil) ; potentially dangerous with CGC.
+ ; KLUDGE: Yikes squared!
+(defvar *enable-dynamic-space-code* #!-gencgc nil #!+gencgc t)
+;;; FIXME: I think all of these should go away. I can't see a good reason
+;;; not to just make everything relocatable.
--- /dev/null
+;;;; pretty printer stuff which has to be defined early (e.g. DEFMACROs)
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!PRETTY")
+
+(file-comment
+ "$Header$")
+\f
+;;;; utilities
+
+(defmacro with-pretty-stream ((stream-var
+ &optional (stream-expression stream-var))
+ &body body)
+ (let ((flet-name (gensym "WITH-PRETTY-STREAM-")))
+ `(flet ((,flet-name (,stream-var)
+ ,@body))
+ (let ((stream ,stream-expression))
+ (if (pretty-stream-p stream)
+ (,flet-name stream)
+ (catch 'line-limit-abbreviation-happened
+ (let ((stream (make-pretty-stream stream)))
+ (,flet-name stream)
+ (force-pretty-output stream)))))
+ nil)))
+\f
+;;;; user interface to the pretty printer
+
+(defmacro pprint-logical-block ((stream-symbol
+ object
+ &key
+ prefix
+ per-line-prefix
+ (suffix ""))
+ &body body)
+ #!+sb-doc
+ "Group some output into a logical block. STREAM-SYMBOL should be either a
+ stream, T (for *TERMINAL-IO*), or NIL (for *STANDARD-OUTPUT*). The printer
+ control variable *PRINT-LEVEL* is automatically handled."
+ (when (and prefix per-line-prefix)
+ (error "cannot specify both PREFIX and a PER-LINE-PREFIX values"))
+ (multiple-value-bind (stream-var stream-expression)
+ (case stream-symbol
+ ((nil)
+ (values '*standard-output* '*standard-output*))
+ ((t)
+ (values '*terminal-io* '*terminal-io*))
+ (t
+ (values stream-symbol
+ (once-only ((stream stream-symbol))
+ `(case ,stream
+ ((nil) *standard-output*)
+ ((t) *terminal-io*)
+ (t ,stream))))))
+ (let* ((object-var (if object (gensym) nil))
+ (block-name (gensym "PPRINT-LOGICAL-BLOCK-"))
+ (count-name (gensym "PPRINT-LOGICAL-BLOCK-LENGTH-"))
+ (pp-pop-name (gensym "PPRINT-POP-"))
+ (body
+ ;; FIXME: It looks as though PPRINT-LOGICAL-BLOCK might
+ ;; expand into a boatload of code, since DESCEND-INTO is a
+ ;; macro too. It might be worth looking at this to make
+ ;; sure it's not too bloated, since PPRINT-LOGICAL-BLOCK
+ ;; is called many times from system pretty-printing code.
+ `(descend-into (,stream-var)
+ (let ((,count-name 0))
+ (declare (type index ,count-name) (ignorable ,count-name))
+ (start-logical-block ,stream-var
+ (the (or null string)
+ ,(or prefix per-line-prefix))
+ ,(if per-line-prefix t nil)
+ (the string ,suffix))
+ (block ,block-name
+ (flet ((,pp-pop-name ()
+ ,@(when object
+ `((unless (listp ,object-var)
+ (write-string ". " ,stream-var)
+ (output-object ,object-var ,stream-var)
+ (return-from ,block-name nil))))
+ (when (and (not *print-readably*)
+ (eql ,count-name *print-length*))
+ (write-string "..." ,stream-var)
+ (return-from ,block-name nil))
+ ,@(when object
+ `((when (and ,object-var
+ (plusp ,count-name)
+ (check-for-circularity
+ ,object-var))
+ (write-string ". " ,stream-var)
+ (output-object ,object-var ,stream-var)
+ (return-from ,block-name nil))))
+ (incf ,count-name)
+ ,@(when object
+ `((pop ,object-var)))))
+ (declare (ignorable #',pp-pop-name))
+ (macrolet ((pprint-pop ()
+ '(,pp-pop-name))
+ (pprint-exit-if-list-exhausted ()
+ ,(if object
+ `'(when (null ,object-var)
+ (return-from ,block-name nil))
+ `'(return-from ,block-name nil))))
+ ,@body)))
+ ;; FIXME: Don't we need UNWIND-PROTECT to ensure this
+ ;; always gets executed?
+ (end-logical-block ,stream-var)))))
+ (when object
+ (setf body
+ `(let ((,object-var ,object))
+ (if (listp ,object-var)
+ ,body
+ (output-object ,object-var ,stream-var)))))
+ `(with-pretty-stream (,stream-var ,stream-expression)
+ ,body))))
+
+(defmacro pprint-exit-if-list-exhausted ()
+ #!+sb-doc
+ "Cause the closest enclosing use of PPRINT-LOGICAL-BLOCK to return
+ if its list argument is exhausted. Can only be used inside
+ PPRINT-LOGICAL-BLOCK, and only when the LIST argument to
+ PPRINT-LOGICAL-BLOCK is supplied."
+ (error "PPRINT-EXIT-IF-LIST-EXHAUSTED must be lexically inside ~
+ PPRINT-LOGICAL-BLOCK."))
+
+(defmacro pprint-pop ()
+ #!+sb-doc
+ "Return the next element from LIST argument to the closest enclosing
+ use of PPRINT-LOGICAL-BLOCK, automatically handling *PRINT-LENGTH*
+ and *PRINT-CIRCLE*. Can only be used inside PPRINT-LOGICAL-BLOCK.
+ If the LIST argument to PPRINT-LOGICAL-BLOCK was NIL, then nothing
+ is popped, but the *PRINT-LENGTH* testing still happens."
+ (error "PPRINT-POP must be lexically inside PPRINT-LOGICAL-BLOCK."))
--- /dev/null
+;;;; printer stuff which has to be defined early (e.g. DEFMACROs)
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!IMPL")
+
+(file-comment
+ "$Header$")
+\f
+;;;; level and length abbreviations
+
+(defvar *current-level* 0
+ #!+sb-doc
+ "The current level we are printing at, to be compared against *PRINT-LEVEL*.
+ See the macro DESCEND-INTO for a handy interface to depth abbreviation.")
+
+(defmacro descend-into ((stream) &body body)
+ #!+sb-doc
+ "Automatically handle *PRINT-LEVEL* abbreviation. If we are too deep, then
+ a # is printed to STREAM and BODY is ignored."
+ (let ((flet-name (gensym)))
+ `(flet ((,flet-name ()
+ ,@body))
+ (cond ((and (null *print-readably*)
+ *print-level*
+ (>= *current-level* *print-level*))
+ (write-char #\# ,stream))
+ (t
+ (let ((*current-level* (1+ *current-level*)))
+ (,flet-name)))))))
+
+(defmacro punt-if-too-long (index stream)
+ #!+sb-doc
+ "Punt if INDEX is equal or larger then *PRINT-LENGTH* (and *PRINT-READABLY*
+ is NIL) by outputting \"...\" and returning from the block named NIL."
+ `(when (and (not *print-readably*)
+ *print-length*
+ (>= ,index *print-length*))
+ (write-string "..." ,stream)
+ (return)))
--- /dev/null
+;;;; SETF and friends (except for stuff defined with COLLECT, which
+;;;; comes later)
+;;;;
+;;;; Note: The expansions for SETF and friends sometimes create
+;;;; needless LET-bindings of argument values. The compiler will
+;;;; remove most of these spurious bindings, so SETF doesn't worry too
+;;;; much about creating them.
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!IMPL")
+
+(file-comment
+ "$Header$")
+
+;;; The inverse for a generalized-variable reference function is stored in
+;;; one of two ways:
+;;;
+;;; A SETF inverse property corresponds to the short form of DEFSETF. It is
+;;; the name of a function takes the same args as the reference form, plus a
+;;; new-value arg at the end.
+;;;
+;;; A SETF method expander is created by the long form of DEFSETF or
+;;; by DEFINE-SETF-EXPANDER. It is a function that is called on the reference
+;;; form and that produces five values: a list of temporary variables, a list
+;;; of value forms, a list of the single store-value form, a storing function,
+;;; and an accessing function.
+(declaim (ftype (function (t &optional (or null sb!c::lexenv))) sb!xc:get-setf-expansion))
+(defun sb!xc:get-setf-expansion (form &optional environment)
+ #!+sb-doc
+ "Returns five values needed by the SETF machinery: a list of temporary
+ variables, a list of values with which to fill them, a list of temporaries
+ for the new values, the setting function, and the accessing function."
+ (let (temp)
+ (cond ((symbolp form)
+ (multiple-value-bind (expansion expanded)
+ (sb!xc:macroexpand-1 form environment)
+ (if expanded
+ (sb!xc:get-setf-expansion expansion environment)
+ (let ((new-var (gensym)))
+ (values nil nil (list new-var)
+ `(setq ,form ,new-var) form)))))
+ ;; Local functions inhibit global SETF methods.
+ ((and environment
+ (let ((name (car form)))
+ (dolist (x (sb!c::lexenv-functions environment))
+ (when (and (eq (car x) name)
+ (not (sb!c::defined-function-p (cdr x))))
+ (return t)))))
+ (expand-or-get-setf-inverse form environment))
+ ((setq temp (info :setf :inverse (car form)))
+ (get-setf-method-inverse form `(,temp) nil))
+ ((setq temp (info :setf :expander (car form)))
+ ;; KLUDGE: It may seem as though this should go through
+ ;; *MACROEXPAND-HOOK*, but the ANSI spec seems fairly explicit
+ ;; that *MACROEXPAND-HOOK* is a hook for MACROEXPAND-1, not
+ ;; for macroexpansion in general. -- WHN 19991128
+ (funcall temp
+ form
+ ;; As near as I can tell from the ANSI spec, macroexpanders
+ ;; have a right to expect an actual lexical environment,
+ ;; not just a NIL which is to be interpreted as a null
+ ;; lexical environment. -- WHN 19991128
+ (or environment (make-null-lexenv))))
+ (t
+ (expand-or-get-setf-inverse form environment)))))
+
+;;; GET-SETF-METHOD existed in pre-ANSI Common Lisp, and various code inherited
+;;; from CMU CL uses it repeatedly, so rather than rewrite a lot of code to not
+;;; use it, we just define it in terms of ANSI's GET-SETF-EXPANSION (or
+;;; actually, the cross-compiler version of that, i.e.
+;;; SB!XC:GET-SETF-EXPANSION).
+(declaim (ftype (function (t &optional (or null sb!c::lexenv))) get-setf-method))
+(defun get-setf-method (form &optional environment)
+ #!+sb-doc
+ "This is a specialized-for-one-value version of GET-SETF-EXPANSION (and
+a relic from pre-ANSI Common Lisp). Portable ANSI code should use
+GET-SETF-EXPANSION directly."
+ (multiple-value-bind (temps value-forms store-vars store-form access-form)
+ (sb!xc:get-setf-expansion form environment)
+ (when (cdr store-vars)
+ (error "GET-SETF-METHOD used for a form with multiple store ~
+ variables:~% ~S"
+ form))
+ (values temps value-forms store-vars store-form access-form)))
+
+;;; If a macro, expand one level and try again. If not, go for the
+;;; SETF function.
+(declaim (ftype (function (t sb!c::lexenv)) expand-or-get-setf-inverse))
+(defun expand-or-get-setf-inverse (form environment)
+ (multiple-value-bind (expansion expanded)
+ (sb!xc:macroexpand-1 form environment)
+ (if expanded
+ (sb!xc:get-setf-expansion expansion environment)
+ (get-setf-method-inverse form
+ `(funcall #'(setf ,(car form)))
+ t))))
+
+(defun get-setf-method-inverse (form inverse setf-function)
+ (let ((new-var (gensym))
+ (vars nil)
+ (vals nil))
+ (dolist (x (cdr form))
+ (push (gensym) vars)
+ (push x vals))
+ (setq vals (nreverse vals))
+ (values vars vals (list new-var)
+ (if setf-function
+ `(,@inverse ,new-var ,@vars)
+ `(,@inverse ,@vars ,new-var))
+ `(,(car form) ,@vars))))
+\f
+;;;; SETF itself
+
+;;; Except for atoms, we always call GET-SETF-EXPANSION, since it has some
+;;; non-trivial semantics. But when there is a setf inverse, and G-S-E uses
+;;; it, then we return a call to the inverse, rather than returning a hairy let
+;;; form. This is probably important mainly as a convenience in allowing the
+;;; use of SETF inverses without the full interpreter.
+(defmacro-mundanely setf (&rest args &environment env)
+ #!+sb-doc
+ "Takes pairs of arguments like SETQ. The first is a place and the second
+ is the value that is supposed to go into that place. Returns the last
+ value. The place argument may be any of the access forms for which SETF
+ knows a corresponding setting form."
+ (let ((nargs (length args)))
+ (cond
+ ((= nargs 2)
+ (let ((place (first args))
+ (value-form (second args)))
+ (if (atom place)
+ `(setq ,place ,value-form)
+ (multiple-value-bind (dummies vals newval setter getter)
+ (sb!xc:get-setf-expansion place env)
+ (declare (ignore getter))
+ (let ((inverse (info :setf :inverse (car place))))
+ (if (and inverse (eq inverse (car setter)))
+ `(,inverse ,@(cdr place) ,value-form)
+ `(let* (,@(mapcar #'list dummies vals))
+ (multiple-value-bind ,newval ,value-form
+ ,setter))))))))
+ ((oddp nargs)
+ (error "odd number of args to SETF"))
+ (t
+ (do ((a args (cddr a))
+ (reversed-setfs nil))
+ ((null a)
+ `(progn ,@(nreverse reversed-setfs)))
+ (push (list 'setf (car a) (cadr a)) reversed-setfs))))))
+\f
+;;;; various SETF-related macros
+
+(defmacro-mundanely shiftf (&whole form &rest args &environment env)
+ #!+sb-doc
+ "One or more SETF-style place expressions, followed by a single
+ value expression. Evaluates all of the expressions in turn, then
+ assigns the value of each expression to the place on its left,
+ returning the value of the leftmost."
+ (when (< (length args) 2)
+ (error "~S called with too few arguments: ~S" 'shiftf form))
+ (let ((resultvar (gensym)))
+ (do ((arglist args (cdr arglist))
+ (bindlist nil)
+ (storelist nil)
+ (lastvar resultvar))
+ ((atom (cdr arglist))
+ (push `(,lastvar ,(first arglist)) bindlist)
+ `(let* ,(nreverse bindlist) ,@(nreverse storelist) ,resultvar))
+ (multiple-value-bind (sm1 sm2 sm3 sm4 sm5)
+ (get-setf-method (first arglist) env)
+ (mapc #'(lambda (var val)
+ (push `(,var ,val) bindlist))
+ sm1
+ sm2)
+ (push `(,lastvar ,sm5) bindlist)
+ (push sm4 storelist)
+ (setq lastvar (first sm3))))))
+
+(defmacro-mundanely push (obj place &environment env)
+ #!+sb-doc
+ "Takes an object and a location holding a list. Conses the object onto
+ the list, returning the modified list. OBJ is evaluated before PLACE."
+ (if (symbolp place)
+ `(setq ,place (cons ,obj ,place))
+ (multiple-value-bind
+ (dummies vals newval setter getter)
+ (get-setf-method place env)
+ (let ((g (gensym)))
+ `(let* ((,g ,obj)
+ ,@(mapcar #'list dummies vals)
+ (,(car newval) (cons ,g ,getter)))
+ ,setter)))))
+
+(defmacro-mundanely pushnew (obj place &rest keys &environment env)
+ #!+sb-doc
+ "Takes an object and a location holding a list. If the object is already
+ in the list, does nothing. Else, conses the object onto the list. Returns
+ NIL. If there is a :TEST keyword, this is used for the comparison."
+ (if (symbolp place)
+ `(setq ,place (adjoin ,obj ,place ,@keys))
+ (multiple-value-bind (dummies vals newval setter getter)
+ (get-setf-method place env)
+ (do* ((d dummies (cdr d))
+ (v vals (cdr v))
+ (let-list nil))
+ ((null d)
+ (push (list (car newval) `(adjoin ,obj ,getter ,@keys))
+ let-list)
+ `(let* ,(nreverse let-list)
+ ,setter))
+ (push (list (car d) (car v)) let-list)))))
+
+(defmacro-mundanely pop (place &environment env)
+ #!+sb-doc
+ "The argument is a location holding a list. Pops one item off the front
+ of the list and returns it."
+ (if (symbolp place)
+ `(prog1 (car ,place) (setq ,place (cdr ,place)))
+ (multiple-value-bind (dummies vals newval setter getter)
+ (get-setf-method place env)
+ (do* ((d dummies (cdr d))
+ (v vals (cdr v))
+ (let-list nil))
+ ((null d)
+ (push (list (car newval) getter) let-list)
+ `(let* ,(nreverse let-list)
+ (prog1 (car ,(car newval))
+ (setq ,(car newval) (cdr ,(car newval)))
+ ,setter)))
+ (push (list (car d) (car v)) let-list)))))
+
+(defmacro-mundanely remf (place indicator &environment env)
+ #!+sb-doc
+ "Place may be any place expression acceptable to SETF, and is expected
+ to hold a property list or (). This list is destructively altered to
+ remove the property specified by the indicator. Returns T if such a
+ property was present, NIL if not."
+ (multiple-value-bind (dummies vals newval setter getter)
+ (get-setf-method place env)
+ (do* ((d dummies (cdr d))
+ (v vals (cdr v))
+ (let-list nil)
+ (ind-temp (gensym))
+ (local1 (gensym))
+ (local2 (gensym)))
+ ((null d)
+ (push (list (car newval) getter) let-list)
+ (push (list ind-temp indicator) let-list)
+ `(let* ,(nreverse let-list)
+ (do ((,local1 ,(car newval) (cddr ,local1))
+ (,local2 nil ,local1))
+ ((atom ,local1) nil)
+ (cond ((atom (cdr ,local1))
+ (error "Odd-length property list in REMF."))
+ ((eq (car ,local1) ,ind-temp)
+ (cond (,local2
+ (rplacd (cdr ,local2) (cddr ,local1))
+ (return t))
+ (t (setq ,(car newval) (cddr ,(car newval)))
+ ,setter
+ (return t))))))))
+ (push (list (car d) (car v)) let-list))))
+\f
+;;;; DEFINE-MODIFY-MACRO stuff
+
+(def!macro sb!xc:define-modify-macro (name lambda-list function &optional doc-string)
+ #!+sb-doc
+ "Creates a new read-modify-write macro like PUSH or INCF."
+ (let ((other-args nil)
+ (rest-arg nil)
+ (env (gensym))
+ (reference (gensym)))
+ ;; Parse out the variable names and &REST arg from the lambda list.
+ (do ((ll lambda-list (cdr ll))
+ (arg nil))
+ ((null ll))
+ (setq arg (car ll))
+ (cond ((eq arg '&optional))
+ ((eq arg '&rest)
+ (if (symbolp (cadr ll))
+ (setq rest-arg (cadr ll))
+ (error "Non-symbol &REST arg in definition of ~S." name))
+ (if (null (cddr ll))
+ (return nil)
+ (error "Illegal stuff after &REST arg.")))
+ ((memq arg '(&key &allow-other-keys &aux))
+ (error "~S not allowed in DEFINE-MODIFY-MACRO lambda list." arg))
+ ((symbolp arg)
+ (push arg other-args))
+ ((and (listp arg) (symbolp (car arg)))
+ (push (car arg) other-args))
+ (t (error "Illegal stuff in lambda list."))))
+ (setq other-args (nreverse other-args))
+ `(#-sb-xc-host sb!xc:defmacro
+ #+sb-xc-host defmacro-mundanely
+ ,name (,reference ,@lambda-list &environment ,env)
+ ,doc-string
+ (multiple-value-bind (dummies vals newval setter getter)
+ (get-setf-method ,reference ,env)
+ (do ((d dummies (cdr d))
+ (v vals (cdr v))
+ (let-list nil (cons (list (car d) (car v)) let-list)))
+ ((null d)
+ (push (list (car newval)
+ ,(if rest-arg
+ `(list* ',function getter ,@other-args ,rest-arg)
+ `(list ',function getter ,@other-args)))
+ let-list)
+ `(let* ,(nreverse let-list)
+ ,setter)))))))
+
+(sb!xc:define-modify-macro incf (&optional (delta 1)) +
+ #!+sb-doc
+ "The first argument is some location holding a number. This number is
+ incremented by the second argument, DELTA, which defaults to 1.")
+
+(sb!xc:define-modify-macro decf (&optional (delta 1)) -
+ #!+sb-doc
+ "The first argument is some location holding a number. This number is
+ decremented by the second argument, DELTA, which defaults to 1.")
+\f
+;;;; DEFSETF
+
+(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
+ ;;; Assign setf macro information for NAME, making all appropriate checks.
+ (defun assign-setf-macro (name expander inverse doc)
+ (cond ((gethash name sb!c:*setf-assumed-fboundp*)
+ (warn
+ "defining setf macro for ~S when ~S was previously ~
+ treated as a function"
+ name
+ `(setf ,name)))
+ ((not (fboundp `(setf ,name)))
+ ;; All is well, we don't need any warnings.
+ (values))
+ ((info :function :accessor-for name)
+ (warn "defining SETF macro for DEFSTRUCT slot ~
+ accessor; redefining as a normal function: ~S"
+ name)
+ (sb!c::proclaim-as-function-name name))
+ ((not (eq (symbol-package name) (symbol-package 'aref)))
+ (style-warn "defining setf macro for ~S when ~S is fbound"
+ name `(setf ,name))))
+ (remhash name sb!c:*setf-assumed-fboundp*)
+ ;; FIXME: It's probably possible to join these checks into one form which
+ ;; is appropriate both on the cross-compilation host and on the target.
+ (when (or inverse (info :setf :inverse name))
+ (setf (info :setf :inverse name) inverse))
+ (when (or expander (info :setf :expander name))
+ (setf (info :setf :expander name) expander))
+ (when doc
+ (setf (fdocumentation name 'setf) doc))
+ name))
+
+(def!macro sb!xc:defsetf (access-fn &rest rest)
+ #!+sb-doc
+ "Associates a SETF update function or macro with the specified access
+ function or macro. The format is complex. See the manual for details."
+ (cond ((not (listp (car rest)))
+ `(eval-when (:load-toplevel :compile-toplevel :execute)
+ (assign-setf-macro ',access-fn
+ nil
+ ',(car rest)
+ ,(when (and (car rest) (stringp (cadr rest)))
+ `',(cadr rest)))))
+ ((and (cdr rest) (listp (cadr rest)))
+ (destructuring-bind
+ (lambda-list (&rest store-variables) &body body)
+ rest
+ (let ((arglist-var (gensym "ARGS-"))
+ (access-form-var (gensym "ACCESS-FORM-"))
+ (env-var (gensym "ENVIRONMENT-")))
+ (multiple-value-bind (body local-decs doc)
+ (parse-defmacro `(,lambda-list ,@store-variables)
+ arglist-var body access-fn 'defsetf
+ :anonymousp t)
+ `(eval-when (:compile-toplevel :load-toplevel :execute)
+ (assign-setf-macro
+ ',access-fn
+ #'(lambda (,access-form-var ,env-var)
+ (declare (ignore ,env-var))
+ (%defsetf ,access-form-var ,(length store-variables)
+ #'(lambda (,arglist-var)
+ ,@local-decs
+ (block ,access-fn
+ ,body))))
+ nil
+ ',doc))))))
+ (t
+ (error "ill-formed DEFSETF for ~S" access-fn))))
+
+(defun %defsetf (orig-access-form num-store-vars expander)
+ (let (subforms
+ subform-vars
+ subform-exprs
+ store-vars)
+ (dolist (subform (cdr orig-access-form))
+ (if (constantp subform)
+ (push subform subforms)
+ (let ((var (gensym)))
+ (push var subforms)
+ (push var subform-vars)
+ (push subform subform-exprs))))
+ (dotimes (i num-store-vars)
+ (push (gensym) store-vars))
+ (let ((r-subforms (nreverse subforms))
+ (r-subform-vars (nreverse subform-vars))
+ (r-subform-exprs (nreverse subform-exprs))
+ (r-store-vars (nreverse store-vars)))
+ (values r-subform-vars
+ r-subform-exprs
+ r-store-vars
+ (funcall expander (cons r-subforms r-store-vars))
+ `(,(car orig-access-form) ,@r-subforms)))))
+\f
+;;;; DEFMACRO DEFINE-SETF-EXPANDER and various DEFINE-SETF-EXPANDERs
+
+;;; DEFINE-SETF-EXPANDER is a lot like DEFMACRO.
+(def!macro sb!xc:define-setf-expander (access-fn lambda-list &body body)
+ #!+sb-doc
+ "Syntax like DEFMACRO, but creates a Setf-Method generator. The body
+ must be a form that returns the five magical values."
+ (unless (symbolp access-fn)
+ (error "DEFINE-SETF-EXPANDER access-function name ~S is not a symbol."
+ access-fn))
+ (let ((whole (gensym "WHOLE-"))
+ (environment (gensym "ENV-")))
+ (multiple-value-bind (body local-decs doc)
+ (parse-defmacro lambda-list whole body access-fn
+ 'sb!xc:define-setf-expander
+ :environment environment)
+ `(eval-when (:compile-toplevel :load-toplevel :execute)
+ (assign-setf-macro ',access-fn
+ #'(lambda (,whole ,environment)
+ ,@local-decs
+ (block ,access-fn ,body))
+ nil
+ ',doc)))))
+
+(sb!xc:define-setf-expander getf (place prop
+ &optional default
+ &environment env)
+ (declare (type sb!c::lexenv env))
+ (multiple-value-bind (temps values stores set get)
+ (get-setf-method place env)
+ (let ((newval (gensym))
+ (ptemp (gensym))
+ (def-temp (if default (gensym))))
+ (values `(,@temps ,ptemp ,@(if default `(,def-temp)))
+ `(,@values ,prop ,@(if default `(,default)))
+ `(,newval)
+ `(let ((,(car stores) (%putf ,get ,ptemp ,newval)))
+ ,set
+ ,newval)
+ `(getf ,get ,ptemp ,@(if default `(,def-temp)))))))
+
+(sb!xc:define-setf-expander get (symbol prop &optional default)
+ (let ((symbol-temp (gensym))
+ (prop-temp (gensym))
+ (def-temp (gensym))
+ (newval (gensym)))
+ (values `(,symbol-temp ,prop-temp ,@(if default `(,def-temp)))
+ `(,symbol ,prop ,@(if default `(,default)))
+ (list newval)
+ `(%put ,symbol-temp ,prop-temp ,newval)
+ `(get ,symbol-temp ,prop-temp ,@(if default `(,def-temp))))))
+
+(sb!xc:define-setf-expander gethash (key hashtable &optional default)
+ (let ((key-temp (gensym))
+ (hashtable-temp (gensym))
+ (default-temp (gensym))
+ (new-value-temp (gensym)))
+ (values
+ `(,key-temp ,hashtable-temp ,@(if default `(,default-temp)))
+ `(,key ,hashtable ,@(if default `(,default)))
+ `(,new-value-temp)
+ `(%puthash ,key-temp ,hashtable-temp ,new-value-temp)
+ `(gethash ,key-temp ,hashtable-temp ,@(if default `(,default-temp))))))
+
+(sb!xc:define-setf-expander logbitp (index int &environment env)
+ (declare (type sb!c::lexenv env))
+ (multiple-value-bind (temps vals stores store-form access-form)
+ (get-setf-method int env)
+ (let ((ind (gensym))
+ (store (gensym))
+ (stemp (first stores)))
+ (values `(,ind ,@temps)
+ `(,index
+ ,@vals)
+ (list store)
+ `(let ((,stemp
+ (dpb (if ,store 1 0) (byte 1 ,ind) ,access-form)))
+ ,store-form
+ ,store)
+ `(logbitp ,ind ,access-form)))))
+
+;;; CMU CL had a comment here that:
+;;; Evil hack invented by the gnomes of Vassar Street (though not as evil as
+;;; it used to be.) The function arg must be constant, and is converted to
+;;; an APPLY of the SETF function, which ought to exist.
+;;;
+;;; It may not be clear (wasn't to me..) that this is a standard thing, but See
+;;; "5.1.2.5 APPLY Forms as Places" in the ANSI spec. I haven't actually
+;;; verified that this code has any correspondence to that code, but at least
+;;; ANSI has some place for SETF APPLY. -- WHN 19990604
+(sb!xc:define-setf-expander apply (functionoid &rest args)
+ (unless (and (listp functionoid)
+ (= (length functionoid) 2)
+ (eq (first functionoid) 'function)
+ (symbolp (second functionoid)))
+ (error "SETF of APPLY is only defined for function args like #'SYMBOL."))
+ (let ((function (second functionoid))
+ (new-var (gensym))
+ (vars (mapcar #'(lambda (x)
+ (declare (ignore x))
+ (gensym))
+ args)))
+ (values vars args (list new-var)
+ `(apply #'(setf ,function) ,new-var ,@vars)
+ `(apply #',function ,@vars))))
+
+;;; Special-case a BYTE bytespec so that the compiler can recognize it.
+(sb!xc:define-setf-expander ldb (bytespec place &environment env)
+ #!+sb-doc
+ "The first argument is a byte specifier. The second is any place form
+ acceptable to SETF. Replaces the specified byte of the number in this
+ place with bits from the low-order end of the new value."
+ (declare (type sb!c::lexenv env))
+ (multiple-value-bind (dummies vals newval setter getter)
+ (get-setf-method place env)
+ (if (and (consp bytespec) (eq (car bytespec) 'byte))
+ (let ((n-size (gensym))
+ (n-pos (gensym))
+ (n-new (gensym)))
+ (values (list* n-size n-pos dummies)
+ (list* (second bytespec) (third bytespec) vals)
+ (list n-new)
+ `(let ((,(car newval) (dpb ,n-new (byte ,n-size ,n-pos)
+ ,getter)))
+ ,setter
+ ,n-new)
+ `(ldb (byte ,n-size ,n-pos) ,getter)))
+ (let ((btemp (gensym))
+ (gnuval (gensym)))
+ (values (cons btemp dummies)
+ (cons bytespec vals)
+ (list gnuval)
+ `(let ((,(car newval) (dpb ,gnuval ,btemp ,getter)))
+ ,setter
+ ,gnuval)
+ `(ldb ,btemp ,getter))))))
+
+(sb!xc:define-setf-expander mask-field (bytespec place &environment env)
+ #!+sb-doc
+ "The first argument is a byte specifier. The second is any place form
+ acceptable to SETF. Replaces the specified byte of the number in this place
+ with bits from the corresponding position in the new value."
+ (declare (type sb!c::lexenv env))
+ (multiple-value-bind (dummies vals newval setter getter)
+ (get-setf-method place env)
+ (let ((btemp (gensym))
+ (gnuval (gensym)))
+ (values (cons btemp dummies)
+ (cons bytespec vals)
+ (list gnuval)
+ `(let ((,(car newval) (deposit-field ,gnuval ,btemp ,getter)))
+ ,setter
+ ,gnuval)
+ `(mask-field ,btemp ,getter)))))
+
+(sb!xc:define-setf-expander the (type place &environment env)
+ (declare (type sb!c::lexenv env))
+ (multiple-value-bind (dummies vals newval setter getter)
+ (get-setf-method place env)
+ (values dummies
+ vals
+ newval
+ (subst `(the ,type ,(car newval)) (car newval) setter)
+ `(the ,type ,getter))))
--- /dev/null
+;;;; that part of the condition system which can or should come early
+;;;; (mostly macro-related)
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!CONDITIONS")
+
+(sb!int:file-comment
+ "$Header$")
+\f
+;;;; restarts
+
+;;; a list of lists of restarts
+(defvar *restart-clusters* '())
+
+;;; An ALIST (condition . restarts) which records the restarts currently
+;;; associated with Condition.
+(defvar *condition-restarts* ())
+
+(defun compute-restarts (&optional condition)
+ #!+sb-doc
+ "Return a list of all the currently active restarts ordered from most
+ recently established to less recently established. If Condition is
+ specified, then only restarts associated with Condition (or with no
+ condition) will be returned."
+ (let ((associated ())
+ (other ()))
+ (dolist (alist *condition-restarts*)
+ (if (eq (car alist) condition)
+ (setq associated (cdr alist))
+ (setq other (append (cdr alist) other))))
+ (collect ((res))
+ (dolist (restart-cluster *restart-clusters*)
+ (dolist (restart restart-cluster)
+ (when (and (or (not condition)
+ (member restart associated)
+ (not (member restart other)))
+ (funcall (restart-test-function restart) condition))
+ (res restart))))
+ (res))))
+
+(defstruct restart
+ name
+ function
+ report-function
+ interactive-function
+ (test-function #'(lambda (cond) (declare (ignore cond)) t)))
+(def!method print-object ((restart restart) stream)
+ (if *print-escape*
+ (print-unreadable-object (restart stream :type t :identity t))
+ (restart-report restart stream)))
+
+#!+sb-doc
+(setf (fdocumentation 'restart-name 'function)
+ "Returns the name of the given restart object.")
+
+(defun restart-report (restart stream)
+ (funcall (or (restart-report-function restart)
+ (let ((name (restart-name restart)))
+ #'(lambda (stream)
+ (if name (format stream "~S" name)
+ (format stream "~S" restart)))))
+ stream))
+
+(defmacro with-condition-restarts (condition-form restarts-form &body body)
+ #!+sb-doc
+ "WITH-CONDITION-RESTARTS Condition-Form Restarts-Form Form*
+ Evaluates the Forms in a dynamic environment where the restarts in the list
+ Restarts-Form are associated with the condition returned by Condition-Form.
+ This allows FIND-RESTART, etc., to recognize restarts that are not related
+ to the error currently being debugged. See also RESTART-CASE."
+ (let ((n-cond (gensym)))
+ `(let ((*condition-restarts*
+ (cons (let ((,n-cond ,condition-form))
+ (cons ,n-cond
+ (append ,restarts-form
+ (cdr (assoc ,n-cond *condition-restarts*)))))
+ *condition-restarts*)))
+ ,@body)))
+
+(defmacro restart-bind (bindings &body forms)
+ #!+sb-doc
+ "Executes forms in a dynamic context where the given restart bindings are
+ in effect. Users probably want to use RESTART-CASE. When clauses contain
+ the same restart name, FIND-RESTART will find the first such clause."
+ `(let ((*restart-clusters*
+ (cons (list
+ ,@(mapcar #'(lambda (binding)
+ (unless (or (car binding)
+ (member :report-function
+ binding
+ :test #'eq))
+ (warn "Unnamed restart does not have a ~
+ report function: ~S"
+ binding))
+ `(make-restart
+ :name ',(car binding)
+ :function ,(cadr binding)
+ ,@(cddr binding)))
+ bindings))
+ *restart-clusters*)))
+ ,@forms))
+
+(defun find-restart (name &optional condition)
+ #!+sb-doc
+ "Returns the first restart named name. If name is a restart, it is returned
+ if it is currently active. If no such restart is found, nil is returned.
+ It is an error to supply nil as a name. If Condition is specified and not
+ NIL, then only restarts associated with that condition (or with no
+ condition) will be returned."
+ (find-if #'(lambda (x)
+ (or (eq x name)
+ (eq (restart-name x) name)))
+ (compute-restarts condition)))
+
+(defun invoke-restart (restart &rest values)
+ #!+sb-doc
+ "Calls the function associated with the given restart, passing any given
+ arguments. If the argument restart is not a restart or a currently active
+ non-nil restart name, then a control-error is signalled."
+ (let ((real-restart (find-restart restart)))
+ (unless real-restart
+ (error 'simple-control-error
+ :format-control "Restart ~S is not active."
+ :format-arguments (list restart)))
+ (apply (restart-function real-restart) values)))
+
+(defun invoke-restart-interactively (restart)
+ #!+sb-doc
+ "Calls the function associated with the given restart, prompting for any
+ necessary arguments. If the argument restart is not a restart or a
+ currently active non-nil restart name, then a control-error is signalled."
+ (let ((real-restart (find-restart restart)))
+ (unless real-restart
+ (error 'simple-control-error
+ :format-control "Restart ~S is not active."
+ :format-arguments (list restart)))
+ (apply (restart-function real-restart)
+ (let ((interactive-function
+ (restart-interactive-function real-restart)))
+ (if interactive-function
+ (funcall interactive-function)
+ '())))))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+;;; Wrap the RESTART-CASE expression in a WITH-CONDITION-RESTARTS if
+;;; appropriate. Gross, but it's what the book seems to say...
+(defun munge-restart-case-expression (expression data)
+ (let ((exp (macroexpand expression)))
+ (if (consp exp)
+ (let* ((name (car exp))
+ (args (if (eq name 'cerror) (cddr exp) (cdr exp))))
+ (if (member name '(signal error cerror warn))
+ (once-only ((n-cond `(coerce-to-condition
+ ,(first args)
+ (list ,@(rest args))
+ ',(case name
+ (warn 'simple-warning)
+ (signal 'simple-condition)
+ (t 'simple-error))
+ ',name)))
+ `(with-condition-restarts
+ ,n-cond
+ (list ,@(mapcar #'(lambda (da)
+ `(find-restart ',(nth 0 da)))
+ data))
+ ,(if (eq name 'cerror)
+ `(cerror ,(second expression) ,n-cond)
+ `(,name ,n-cond))))
+ expression))
+ expression)))
+) ; EVAL-WHEN
+
+;;; FIXME: I did a fair amount of rearrangement of this code in order to
+;;; get WITH-KEYWORD-PAIRS to work cleanly. This code should be tested..
+(defmacro restart-case (expression &body clauses)
+ #!+sb-doc
+ "(RESTART-CASE form
+ {(case-name arg-list {keyword value}* body)}*)
+ The form is evaluated in a dynamic context where the clauses have special
+ meanings as points to which control may be transferred (see INVOKE-RESTART).
+ When clauses contain the same case-name, FIND-RESTART will find the first
+ such clause. If Expression is a call to SIGNAL, ERROR, CERROR or WARN (or
+ macroexpands into such) then the signalled condition will be associated with
+ the new restarts."
+ (flet ((transform-keywords (&key report interactive test)
+ (let ((result '()))
+ (when report
+ (setq result (list* (if (stringp report)
+ `#'(lambda (stream)
+ (write-string ,report stream))
+ `#',report)
+ :report-function
+ result)))
+ (when interactive
+ (setq result (list* `#',interactive
+ :interactive-function
+ result)))
+ (when test
+ (setq result (list* `#',test
+ :test-function
+ result)))
+ (nreverse result)))
+ (parse-keyword-pairs (list keys)
+ (do ((l list (cddr l))
+ (k '() (list* (cadr l) (car l) k)))
+ ((or (null l) (not (member (car l) keys)))
+ (values (nreverse k) l)))))
+ (let ((block-tag (gensym))
+ (temp-var (gensym))
+ (data
+ (macrolet (;; KLUDGE: This started as an old DEFMACRO
+ ;; WITH-KEYWORD-PAIRS general utility, which was used
+ ;; only in this one place in the code. It was translated
+ ;; literally into this MACROLET in order to avoid some
+ ;; cross-compilation bootstrap problems. It would almost
+ ;; certainly be clearer, and it would certainly be more
+ ;; concise, to do a more idiomatic translation, merging
+ ;; this with the TRANSFORM-KEYWORDS logic above.
+ ;; -- WHN 19990925
+ (with-keyword-pairs ((names expression) &body forms)
+ (let ((temp (member '&rest names)))
+ (unless (= (length temp) 2)
+ (error "&REST keyword is ~:[missing~;misplaced~]."
+ temp))
+ (let* ((key-vars (ldiff names temp))
+ (keywords (mapcar #'keywordicate key-vars))
+ (key-var (gensym))
+ (rest-var (cadr temp)))
+ `(multiple-value-bind (,key-var ,rest-var)
+ (parse-keyword-pairs ,expression ',keywords)
+ (let ,(mapcar (lambda (var keyword)
+ `(,var (getf ,key-var
+ ,keyword)))
+ key-vars keywords)
+ ,@forms))))))
+ (mapcar (lambda (clause)
+ (with-keyword-pairs ((report interactive test
+ &rest forms)
+ (cddr clause))
+ (list (car clause) ;name=0
+ (gensym) ;tag=1
+ (transform-keywords :report report ;keywords=2
+ :interactive interactive
+ :test test)
+ (cadr clause) ;bvl=3
+ forms))) ;body=4
+ clauses))))
+ `(block ,block-tag
+ (let ((,temp-var nil))
+ (tagbody
+ (restart-bind
+ ,(mapcar #'(lambda (datum)
+ (let ((name (nth 0 datum))
+ (tag (nth 1 datum))
+ (keys (nth 2 datum)))
+ `(,name #'(lambda (&rest temp)
+ (setq ,temp-var temp)
+ (go ,tag))
+ ,@keys)))
+ data)
+ (return-from ,block-tag
+ ,(munge-restart-case-expression expression data)))
+ ,@(mapcan #'(lambda (datum)
+ (let ((tag (nth 1 datum))
+ (bvl (nth 3 datum))
+ (body (nth 4 datum)))
+ (list tag
+ `(return-from ,block-tag
+ (apply #'(lambda ,bvl ,@body)
+ ,temp-var)))))
+ data)))))))
+
+(defmacro with-simple-restart ((restart-name format-string
+ &rest format-arguments)
+ &body forms)
+ #!+sb-doc
+ "(WITH-SIMPLE-RESTART (restart-name format-string format-arguments)
+ body)
+ If restart-name is not invoked, then all values returned by forms are
+ returned. If control is transferred to this restart, it immediately
+ returns the values nil and t."
+ `(restart-case
+ ;; If there's just one body form, then don't use PROGN. This allows
+ ;; RESTART-CASE to "see" calls to ERROR, etc.
+ ,(if (= (length forms) 1) (car forms) `(progn ,@forms))
+ (,restart-name ()
+ :report (lambda (stream)
+ (format stream ,format-string ,@format-arguments))
+ (values nil t))))
+\f
+;;;; HANDLER-BIND
+
+(defvar *handler-clusters* nil)
+
+(defmacro handler-bind (bindings &body forms)
+ #!+sb-doc
+ "(HANDLER-BIND ( {(type handler)}* ) body)
+ Executes body in a dynamic context where the given handler bindings are
+ in effect. Each handler must take the condition being signalled as an
+ argument. The bindings are searched first to last in the event of a
+ signalled condition."
+ (let ((member-if (member-if (lambda (x)
+ (not (proper-list-of-length-p x 2)))
+ bindings)))
+ (when member-if
+ (error "ill-formed handler binding: ~S" (first member-if))))
+ `(let ((*handler-clusters*
+ (cons (list ,@(mapcar #'(lambda (x) `(cons ',(car x) ,(cadr x)))
+ bindings))
+ *handler-clusters*)))
+ (multiple-value-prog1
+ ,@forms
+ ;; Wait for any float exceptions
+ #!+x86 (float-wait))))
+\f
+;;;; 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
+ 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
+ var specification."
+ (let ((no-error-clause (assoc ':no-error cases)))
+ (if no-error-clause
+ (let ((normal-return (make-symbol "normal-return"))
+ (error-return (make-symbol "error-return")))
+ `(block ,error-return
+ (multiple-value-call #'(lambda ,@(cdr no-error-clause))
+ (block ,normal-return
+ (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))
+ (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
+ (handler-bind
+ ,(mapcar #'(lambda (annotated-case)
+ `(,(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))))
+ 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))
+ ,@body))
+ body))))
+ annotated-cases))))))))
+
+;;; FIXME: Delete this when the system is stable.
+#|
+This macro doesn't work in our system due to lossage in closing over tags.
+The previous version sets up unique run-time tags.
+
+(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
+ 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
+ var specification."
+ (let ((no-error-clause (assoc ':no-error cases)))
+ (if no-error-clause
+ (let ((normal-return (make-symbol "normal-return"))
+ (error-return (make-symbol "error-return")))
+ `(block ,error-return
+ (multiple-value-call #'(lambda ,@(cdr no-error-clause))
+ (block ,normal-return
+ (return-from ,error-return
+ (handler-case (return-from ,normal-return ,form)
+ ,@(remove no-error-clause cases)))))))
+ (let ((tag (gensym))
+ (var (gensym))
+ (annotated-cases (mapcar #'(lambda (case) (cons (gensym) case))
+ cases)))
+ `(block ,tag
+ (let ((,var nil))
+ ,var ;ignorable
+ (tagbody
+ (handler-bind
+ ,(mapcar #'(lambda (annotated-case)
+ (list (cadr annotated-case)
+ `#'(lambda (temp)
+ ,(if (caddr annotated-case)
+ `(setq ,var temp)
+ '(declare (ignore temp)))
+ (go ,(car annotated-case)))))
+ annotated-cases)
+ (return-from ,tag ,form))
+ ,@(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))
+ ((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."
+ `(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
+
+(defun assert-error (assertion places datum &rest arguments)
+ (let ((cond (if datum
+ (sb!conditions::coerce-to-condition datum
+ arguments
+ 'simple-error
+ 'error)
+ (make-condition 'simple-error
+ :format-control "The assertion ~S failed."
+ :format-arguments (list assertion)))))
+ (restart-case
+ (error cond)
+ (continue ()
+ :report (lambda (stream)
+ (format stream "Retry assertion")
+ (if places
+ (format stream
+ " with new value~P for ~{~S~^, ~}."
+ (length places)
+ places)
+ (format stream ".")))
+ nil))))
+
+;;; READ-EVALUATED-FORM is used as the interactive method for restart cases
+;;; setup by the Common Lisp "casing" (e.g., CCASE and CTYPECASE) macros
+;;; and by CHECK-TYPE.
+(defun read-evaluated-form ()
+ (format *query-io* "~&Type a form to be evaluated:~%")
+ (list (eval (read *query-io*))))
+
+(defun check-type-error (place place-value type type-string)
+ (let ((cond (if type-string
+ (make-condition 'simple-type-error
+ :datum place
+ :expected-type type
+ :format-control
+ "The value of ~S is ~S, which is not ~A."
+ :format-arguments (list place
+ place-value
+ type-string))
+ (make-condition 'simple-type-error
+ :datum place
+ :expected-type type
+ :format-control
+ "The value of ~S is ~S, which is not of type ~S."
+ :format-arguments (list place
+ place-value
+ type)))))
+ (restart-case (error cond)
+ (store-value (value)
+ :report (lambda (stream)
+ (format stream "Supply a new value for ~S." place))
+ :interactive read-evaluated-form
+ value))))
+
+(defun case-body-error (name keyform keyform-value expected-type keys)
+ (restart-case
+ (error 'sb!conditions::case-failure
+ :name name
+ :datum keyform-value
+ :expected-type expected-type
+ :possibilities keys)
+ (store-value (value)
+ :report (lambda (stream)
+ (format stream "Supply a new value for ~S." keyform))
+ :interactive read-evaluated-form
+ value)))
--- /dev/null
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!KERNEL")
+
+(file-comment
+ "$Header$")
+
+(!begin-collecting-cold-init-forms)
+
+;;; Has the type system been properly initialized? (I.e. is it OK to
+;;; use it?)
+(defvar *type-system-initialized* #+sb-xc-host nil) ; (set in cold load)
+\f
+;;; Return the type structure corresponding to a type specifier. We
+;;; pick off structure types as a special case.
+;;;
+;;; Note: VALUES-SPECIFIER-TYPE-CACHE-CLEAR must be called whenever a
+;;; type is defined (or redefined).
+(defun-cached (values-specifier-type
+ :hash-function (lambda (x)
+ ;; FIXME: the THE FIXNUM stuff is
+ ;; redundant in SBCL (or modern CMU
+ ;; CL) because of type inference.
+ (the fixnum
+ (logand (the fixnum (sxhash x))
+ #x3FF)))
+ :hash-bits 10
+ :init-wrapper !cold-init-forms)
+ ((orig eq))
+ (let ((u (uncross orig)))
+ (or (info :type :builtin u)
+ (let ((spec (type-expand u)))
+ (cond
+ ((and (not (eq spec u))
+ (info :type :builtin spec)))
+ ((eq (info :type :kind spec) :instance)
+ (sb!xc:find-class spec))
+ ((typep spec 'class)
+ ;; There doesn't seem to be any way to translate
+ ;; (TYPEP SPEC 'BUILT-IN-CLASS) into something which can be
+ ;; executed on the host Common Lisp at cross-compilation time.
+ #+sb-xc-host (error
+ "stub: (TYPEP SPEC 'BUILT-IN-CLASS) on xc host")
+ (if (typep spec 'built-in-class)
+ (or (built-in-class-translation spec) spec)
+ spec))
+ (t
+ (let* ((lspec (if (atom spec) (list spec) spec))
+ (fun (info :type :translator (car lspec))))
+ (cond (fun (funcall fun lspec))
+ ((or (and (consp spec) (symbolp (car spec)))
+ (symbolp spec))
+ (when *type-system-initialized*
+ (signal 'parse-unknown-type :specifier spec))
+ ;; (The RETURN-FROM here inhibits caching.)
+ (return-from values-specifier-type
+ (make-unknown-type :specifier spec)))
+ (t
+ (error "bad thing to be a type specifier: ~S"
+ spec))))))))))
+
+;;; Like VALUES-SPECIFIER-TYPE, except that we guarantee to never
+;;; return a VALUES type.
+(defun specifier-type (x)
+ (let ((res (values-specifier-type x)))
+ (when (values-type-p res)
+ (error "VALUES type illegal in this context:~% ~S" x))
+ res))
+
+;;; Similar to MACROEXPAND, but expands DEFTYPEs. We don't bother
+;;; returning a second value.
+(defun type-expand (form)
+ (let ((def (cond ((symbolp form)
+ (info :type :expander form))
+ ((and (consp form) (symbolp (car form)))
+ (info :type :expander (car form)))
+ (t nil))))
+ (if def
+ (type-expand (funcall def (if (consp form) form (list form))))
+ form)))
+
+;;; A HAIRY-TYPE represents anything too weird to be described
+;;; reasonably or to be useful, such as AND, NOT and SATISFIES and
+;;; unknown types. We just remember the original type spec.
+(defstruct (hairy-type (:include ctype
+ (class-info (type-class-or-lose 'hairy))
+ (enumerable t))
+ #!+cmu (:pure nil))
+ ;; the Common Lisp type-specifier
+ (specifier nil :type t))
+
+(define-type-class hairy)
+
+;;; An UNKNOWN-TYPE is a type not known to the type system (not yet
+;;; defined). We make this distinction since we don't want to complain
+;;; about types that are hairy but defined.
+(defstruct (unknown-type (:include hairy-type)))
+
+;;; ARGS-TYPE objects are used both to represent VALUES types and
+;;; to represent FUNCTION types.
+(defstruct (args-type (:include ctype)
+ (:constructor nil))
+ ;; Lists of the type for each required and optional argument.
+ (required nil :type list)
+ (optional nil :type list)
+ ;; The type for the rest arg. NIL if there is no rest arg.
+ (rest nil :type (or ctype null))
+ ;; True if keyword arguments are specified.
+ (keyp nil :type boolean)
+ ;; List of key-info structures describing the keyword arguments.
+ (keywords nil :type list)
+ ;; True if other keywords are allowed.
+ (allowp nil :type boolean))
+
+(defstruct (values-type
+ (:include args-type
+ (class-info (type-class-or-lose 'values)))))
+
+(define-type-class values)
+
+(defstruct (function-type
+ (:include args-type
+ (class-info (type-class-or-lose 'function))))
+ ;; True if the arguments are unrestrictive, i.e. *.
+ (wild-args nil :type boolean)
+ ;; Type describing the return values. This is a values type
+ ;; when multiple values were specified for the return.
+ (returns (required-argument) :type ctype))
+
+;;; The CONSTANT-TYPE structure represents a use of the
+;;; CONSTANT-ARGUMENT "type specifier", which is only meaningful in
+;;; function argument type specifiers used within the compiler. (It
+;;; represents something that the compiler knows to be a constant.)
+(defstruct (constant-type
+ (:include ctype
+ (class-info (type-class-or-lose 'constant))))
+ ;; The type which the argument must be a constant instance of for this type
+ ;; specifier to win.
+ (type (required-argument) :type ctype))
+
+;;; The NAMED-TYPE is used to represent *, T and NIL. These types must be
+;;; super or sub types of all types, not just classes and * & NIL aren't
+;;; classes anyway, so it wouldn't make much sense to make them built-in
+;;; classes.
+(defstruct (named-type (:include ctype
+ (class-info (type-class-or-lose 'named))))
+ (name nil :type symbol))
+
+;;; The Numeric-Type is used to represent all numeric types, including things
+;;; such as FIXNUM.
+(defstruct (numeric-type (:include ctype
+ (class-info (type-class-or-lose
+ 'number)))
+ #!+negative-zero-is-not-zero
+ (:constructor %make-numeric-type))
+ ;; The kind of numeric type we have. NIL if not specified (just NUMBER or
+ ;; COMPLEX).
+ ;;
+ ;; KLUDGE: A slot named CLASS for a non-CLASS value is bad.
+ ;; Especially when a CLASS value *is* stored in another slot (called
+ ;; CLASS-INFO:-). Perhaps this should be called CLASS-NAME? Also
+ ;; weird that comment above says "Numeric-Type is used to represent
+ ;; all numeric types" but this slot doesn't allow COMPLEX as an
+ ;; option.. how does this fall into "not specified" NIL case above?
+ (class nil :type (member integer rational float nil))
+ ;; Format for a float type. NIL if not specified or not a float. Formats
+ ;; which don't exist in a given implementation don't appear here.
+ (format nil :type (or float-format null))
+ ;; Is this a complex numeric type? Null if unknown (only in NUMBER.)
+ ;;
+ ;; FIXME: I'm bewildered by FOO-P names for things not intended to
+ ;; interpreted as truth values. Perhaps rename this COMPLEXNESS?
+ (complexp :real :type (member :real :complex nil))
+ ;; The upper and lower bounds on the value. If null, there is no bound. If
+ ;; a list of a number, the bound is exclusive. Integer types never have
+ ;; exclusive bounds.
+ (low nil :type (or number cons null))
+ (high nil :type (or number cons null)))
+
+;;; The Array-Type is used to represent all array types, including
+;;; things such as SIMPLE-STRING.
+(defstruct (array-type (:include ctype
+ (class-info (type-class-or-lose 'array))))
+ ;; The dimensions of the array. * if unspecified. If a dimension is
+ ;; unspecified, it is *.
+ (dimensions '* :type (or list (member *)))
+ ;; Is this not a simple array type? (:MAYBE means that we don't know.)
+ (complexp :maybe :type (member t nil :maybe))
+ ;; The element type as originally specified.
+ (element-type (required-argument) :type ctype)
+ ;; The element type as it is specialized in this implementation.
+ (specialized-element-type *wild-type* :type ctype))
+
+;;; The Member-Type represents uses of the MEMBER type specifier. We
+;;; bother with this at this level because MEMBER types are fairly
+;;; important and union and intersection are well defined.
+(defstruct (member-type (:include ctype
+ (class-info (type-class-or-lose 'member))
+ (enumerable t))
+ #-sb-xc-host (:pure nil))
+ ;; The things in the set, with no duplications.
+ (members nil :type list))
+
+;;; A UNION-TYPE represents a use of the OR type specifier which can't
+;;; be canonicalized to something simpler. Canonical form:
+;;; 1. There is never more than one Member-Type component.
+;;; 2. There are never any Union-Type components.
+(defstruct (union-type (:include ctype
+ (class-info (type-class-or-lose 'union)))
+ (:constructor %make-union-type (enumerable types)))
+ ;; The types in the union.
+ (types nil :type list))
+\f
+;;; Note that the type Name has been (re)defined, updating the
+;;; undefined warnings and VALUES-SPECIFIER-TYPE cache.
+(defun %note-type-defined (name)
+ (declare (symbol name))
+ (note-name-defined name :type)
+ (when (boundp 'sb!kernel::*values-specifier-type-cache-vector*)
+ (values-specifier-type-cache-clear))
+ (values))
+\f
+;;;; KLUDGE: not clear this really belongs here, but where?
+
+;;; Is X a fixnum in the target Lisp?
+(defun target-fixnump (x)
+ (and (integerp x)
+ (<= sb!vm:*target-most-negative-fixnum*
+ x
+ sb!vm:*target-most-positive-fixnum*)))
+
+(!defun-from-collected-cold-init-forms !early-type-cold-init)
--- /dev/null
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!IMPL")
+
+(file-comment
+ "$Header$")
+
+;;; These specials are used by ERROR-ERROR to track the success of recovery
+;;; attempts.
+(defvar *error-error-depth* 0)
+(defvar *error-throw-up-count* 0)
+
+;;; ERROR-ERROR can be called when the error system is in trouble and needs to
+;;; punt fast. It prints a message without using FORMAT. If we get into this
+;;; recursively, then we halt.
+(defun error-error (&rest messages)
+ (let ((*error-error-depth* (1+ *error-error-depth*)))
+ (when (> *error-throw-up-count* 50)
+ (%primitive sb!c:halt)
+ (throw 'sb!impl::top-level-catcher nil))
+ (case *error-error-depth*
+ (1)
+ (2
+ (stream-cold-init-or-reset))
+ (3
+ (incf *error-throw-up-count*)
+ (throw 'sb!impl::top-level-catcher nil))
+ (t
+ (%primitive sb!c:halt)
+ (throw 'sb!impl::top-level-catcher nil)))
+
+ (with-standard-io-syntax
+ (let ((*print-readably* nil))
+ (dolist (item messages)
+ (princ item *terminal-io*))
+ (sb!debug:internal-debug)))))
--- /dev/null
+;;;; SBCL-specific parts of the condition system, i.e. parts which
+;;;; don't duplicate/clobber functionality already provided by the
+;;;; cross-compilation host Common Lisp
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!CONDITIONS")
+
+(sb!int:file-comment
+ "$Header$")
+
+(define-condition simple-style-warning (simple-condition style-warning) ())
+
+;;; not sure this is the right place, but where else?
+(defun style-warn (format-control &rest format-arguments)
+ (warn 'simple-style-warning
+ :format-control format-control
+ :format-arguments format-arguments))
+
+(define-condition simple-type-error (simple-condition type-error) ())
+
+(define-condition sb!kernel:layout-invalid (type-error)
+ ()
+ (:report
+ (lambda (condition stream)
+ (format stream "Layout-invalid error in ~S:~@
+ Type test of class ~S was passed obsolete instance:~% ~S"
+ (condition-function-name condition)
+ (sb!kernel:class-proper-name (type-error-expected-type condition))
+ (type-error-datum condition)))))
+
+(define-condition case-failure (type-error)
+ ((name :reader case-failure-name :initarg :name)
+ (possibilities :reader case-failure-possibilities :initarg :possibilities))
+ (:report
+ (lambda (condition stream)
+ (format stream "~@<~S fell through ~S expression. ~:_Wanted one of ~:S.~:>"
+ (type-error-datum condition)
+ (case-failure-name condition)
+ (case-failure-possibilities condition)))))
+
+(define-condition simple-file-error (simple-condition file-error)())
+(define-condition simple-program-error (simple-condition program-error)())
+(define-condition simple-control-error (simple-condition control-error)())
+
+;;; This condition is signalled whenever we make a UNKNOWN-TYPE so that
+;;; compiler warnings can be emitted as appropriate.
+(define-condition parse-unknown-type (condition)
+ ((specifier :reader parse-unknown-type-specifier :initarg :specifier)))
+
--- /dev/null
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!EVAL")
+
+(file-comment
+ "$Header$")
+
+;;; This flag is used by EVAL-WHEN to keep track of when code has already been
+;;; evaluated so that it can avoid multiple evaluation of nested EVAL-WHEN
+;;; (COMPILE)s.
+(defvar *already-evaled-this* nil)
--- /dev/null
+;;;; streams for UNIX file descriptors
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!IMPL")
+
+(file-comment
+ "$Header$")
+
+(deftype file-stream () 'fd-stream)
+\f
+;;;; buffer manipulation routines
+
+(defvar *available-buffers* ()
+ #!+sb-doc
+ "List of available buffers. Each buffer is an sap pointing to
+ bytes-per-buffer of memory.")
+
+(defconstant bytes-per-buffer (* 4 1024)
+ #!+sb-doc
+ "Number of bytes per buffer.")
+
+;;; Return the next available buffer, creating one if necessary.
+#!-sb-fluid (declaim (inline next-available-buffer))
+(defun next-available-buffer ()
+ (if *available-buffers*
+ (pop *available-buffers*)
+ (allocate-system-memory bytes-per-buffer)))
+\f
+;;;; the FD-STREAM structure
+
+(defstruct (fd-stream
+ (:constructor %make-fd-stream)
+ (:include lisp-stream
+ (misc #'fd-stream-misc-routine)))
+
+ (name nil) ; The name of this stream
+ (file nil) ; The file this stream is for
+ ;; The backup file namestring for the old file, for :if-exists :rename or
+ ;; :rename-and-delete.
+ (original nil :type (or simple-string null))
+ (delete-original nil) ; for :if-exists :rename-and-delete
+ ;;; Number of bytes per element.
+ (element-size 1 :type index)
+ (element-type 'base-char) ; The type of element being transfered.
+ (fd -1 :type fixnum) ; The file descriptor
+ ;; Controls when the output buffer is flushed.
+ (buffering :full :type (member :full :line :none))
+ ;; Character position if known.
+ (char-pos nil :type (or index null))
+ ;; T if input is waiting on FD. :EOF if we hit EOF.
+ (listen nil :type (member nil t :eof))
+ ;; The input buffer.
+ (unread nil)
+ (ibuf-sap nil :type (or system-area-pointer null))
+ (ibuf-length nil :type (or index null))
+ (ibuf-head 0 :type index)
+ (ibuf-tail 0 :type index)
+
+ ;; The output buffer.
+ (obuf-sap nil :type (or system-area-pointer null))
+ (obuf-length nil :type (or index null))
+ (obuf-tail 0 :type index)
+
+ ;; Output flushed, but not written due to non-blocking io.
+ (output-later nil)
+ (handler nil)
+ ;; Timeout specified for this stream, or NIL if none.
+ (timeout nil :type (or index null))
+ ;; Pathname of the file this stream is opened to (returned by PATHNAME.)
+ (pathname nil :type (or pathname null)))
+(def!method print-object ((fd-stream fd-stream) stream)
+ (declare (type stream stream))
+ (print-unreadable-object (fd-stream stream :type t :identity t)
+ (format stream "for ~S" (fd-stream-name fd-stream))))
+\f
+;;;; output routines and related noise
+
+(defvar *output-routines* ()
+ #!+sb-doc
+ "List of all available output routines. Each element is a list of the
+ element-type output, the kind of buffering, the function name, and the number
+ of bytes per element.")
+
+;;; Called by the server when we can write to the given file descriptor.
+;;; Attempt to write the data again. If it worked, remove the data from the
+;;; output-later list. If it didn't work, something is wrong.
+(defun do-output-later (stream)
+ (let* ((stuff (pop (fd-stream-output-later stream)))
+ (base (car stuff))
+ (start (cadr stuff))
+ (end (caddr stuff))
+ (reuse-sap (cadddr stuff))
+ (length (- end start)))
+ (declare (type index start end length))
+ (multiple-value-bind (count errno)
+ (sb!unix:unix-write (fd-stream-fd stream)
+ base
+ start
+ length)
+ (cond ((not count)
+ (if (= errno sb!unix:ewouldblock)
+ (error "Write would have blocked, but SERVER told us to go.")
+ (error "while writing ~S: ~A"
+ stream
+ (sb!unix:get-unix-error-msg errno))))
+ ((eql count length) ; Hot damn, it worked.
+ (when reuse-sap
+ (push base *available-buffers*)))
+ ((not (null count)) ; Sorta worked.
+ (push (list base
+ (the index (+ start count))
+ end)
+ (fd-stream-output-later stream))))))
+ (unless (fd-stream-output-later stream)
+ (sb!sys:remove-fd-handler (fd-stream-handler stream))
+ (setf (fd-stream-handler stream) nil)))
+
+;;; Arange to output the string when we can write on the file descriptor.
+(defun output-later (stream base start end reuse-sap)
+ (cond ((null (fd-stream-output-later stream))
+ (setf (fd-stream-output-later stream)
+ (list (list base start end reuse-sap)))
+ (setf (fd-stream-handler stream)
+ (sb!sys:add-fd-handler (fd-stream-fd stream)
+ :output
+ #'(lambda (fd)
+ (declare (ignore fd))
+ (do-output-later stream)))))
+ (t
+ (nconc (fd-stream-output-later stream)
+ (list (list base start end reuse-sap)))))
+ (when reuse-sap
+ (let ((new-buffer (next-available-buffer)))
+ (setf (fd-stream-obuf-sap stream) new-buffer)
+ (setf (fd-stream-obuf-length stream) bytes-per-buffer))))
+
+;;; Output the given noise. Check to see whether there are any pending writes.
+;;; If so, just queue this one. Otherwise, try to write it. If this would
+;;; block, queue it.
+(defun do-output (stream base start end reuse-sap)
+ (declare (type fd-stream stream)
+ (type (or system-area-pointer (simple-array * (*))) base)
+ (type index start end))
+ (if (not (null (fd-stream-output-later stream))) ; something buffered.
+ (progn
+ (output-later stream base start end reuse-sap)
+ ;; ### check to see whether any of this noise can be output
+ )
+ (let ((length (- end start)))
+ (multiple-value-bind (count errno)
+ (sb!unix:unix-write (fd-stream-fd stream) base start length)
+ (cond ((not count)
+ (if (= errno sb!unix:ewouldblock)
+ (output-later stream base start end reuse-sap)
+ ;; FIXME: This and various other errors in this file
+ ;; should probably be STREAM-ERROR.
+ (error "while writing ~S: ~A"
+ stream
+ (sb!unix:get-unix-error-msg errno))))
+ ((not (eql count length))
+ (output-later stream base (the index (+ start count))
+ end reuse-sap)))))))
+
+;;; Flush any data in the output buffer.
+(defun flush-output-buffer (stream)
+ (let ((length (fd-stream-obuf-tail stream)))
+ (unless (= length 0)
+ (do-output stream (fd-stream-obuf-sap stream) 0 length t)
+ (setf (fd-stream-obuf-tail stream) 0))))
+
+;;; Define output routines that output numbers size bytes long for the
+;;; given bufferings. Use body to do the actual output.
+(defmacro def-output-routines ((name size &rest bufferings) &body body)
+ (declare (optimize (speed 1)))
+ (cons 'progn
+ (mapcar
+ #'(lambda (buffering)
+ (let ((function
+ (intern (let ((*print-case* :upcase))
+ (format nil name (car buffering))))))
+ `(progn
+ (defun ,function (stream byte)
+ ,(unless (eq (car buffering) :none)
+ `(when (< (fd-stream-obuf-length stream)
+ (+ (fd-stream-obuf-tail stream)
+ ,size))
+ (flush-output-buffer stream)))
+ ,@body
+ (incf (fd-stream-obuf-tail stream) ,size)
+ ,(ecase (car buffering)
+ (:none
+ `(flush-output-buffer stream))
+ (:line
+ `(when (eq (char-code byte) (char-code #\Newline))
+ (flush-output-buffer stream)))
+ (:full
+ ))
+ (values))
+ (setf *output-routines*
+ (nconc *output-routines*
+ ',(mapcar
+ #'(lambda (type)
+ (list type
+ (car buffering)
+ function
+ size))
+ (cdr buffering)))))))
+ bufferings)))
+
+(def-output-routines ("OUTPUT-CHAR-~A-BUFFERED"
+ 1
+ (:none character)
+ (:line character)
+ (:full character))
+ (if (and (base-char-p byte) (char= byte #\Newline))
+ (setf (fd-stream-char-pos stream) 0)
+ (incf (fd-stream-char-pos stream)))
+ (setf (sap-ref-8 (fd-stream-obuf-sap stream) (fd-stream-obuf-tail stream))
+ (char-code byte)))
+
+(def-output-routines ("OUTPUT-UNSIGNED-BYTE-~A-BUFFERED"
+ 1
+ (:none (unsigned-byte 8))
+ (:full (unsigned-byte 8)))
+ (setf (sap-ref-8 (fd-stream-obuf-sap stream) (fd-stream-obuf-tail stream))
+ byte))
+
+(def-output-routines ("OUTPUT-SIGNED-BYTE-~A-BUFFERED"
+ 1
+ (:none (signed-byte 8))
+ (:full (signed-byte 8)))
+ (setf (signed-sap-ref-8 (fd-stream-obuf-sap stream)
+ (fd-stream-obuf-tail stream))
+ byte))
+
+(def-output-routines ("OUTPUT-UNSIGNED-SHORT-~A-BUFFERED"
+ 2
+ (:none (unsigned-byte 16))
+ (:full (unsigned-byte 16)))
+ (setf (sap-ref-16 (fd-stream-obuf-sap stream) (fd-stream-obuf-tail stream))
+ byte))
+
+(def-output-routines ("OUTPUT-SIGNED-SHORT-~A-BUFFERED"
+ 2
+ (:none (signed-byte 16))
+ (:full (signed-byte 16)))
+ (setf (signed-sap-ref-16 (fd-stream-obuf-sap stream)
+ (fd-stream-obuf-tail stream))
+ byte))
+
+(def-output-routines ("OUTPUT-UNSIGNED-LONG-~A-BUFFERED"
+ 4
+ (:none (unsigned-byte 32))
+ (:full (unsigned-byte 32)))
+ (setf (sap-ref-32 (fd-stream-obuf-sap stream) (fd-stream-obuf-tail stream))
+ byte))
+
+(def-output-routines ("OUTPUT-SIGNED-LONG-~A-BUFFERED"
+ 4
+ (:none (signed-byte 32))
+ (:full (signed-byte 32)))
+ (setf (signed-sap-ref-32 (fd-stream-obuf-sap stream)
+ (fd-stream-obuf-tail stream))
+ byte))
+
+;;; Does the actual output. If there is space to buffer the string, buffer
+;;; it. If the string would normally fit in the buffer, but doesn't because
+;;; of other stuff in the buffer, flush the old noise out of the buffer and
+;;; put the string in it. Otherwise we have a very long string, so just
+;;; send it directly (after flushing the buffer, of course).
+(defun output-raw-bytes (fd-stream thing &optional start end)
+ #!+sb-doc
+ "Output THING to FD-STREAM. THING can be any kind of vector or a SAP. If
+ THING is a SAP, END must be supplied (as length won't work)."
+ (let ((start (or start 0))
+ (end (or end (length (the (simple-array * (*)) thing)))))
+ (declare (type index start end))
+ (let* ((len (fd-stream-obuf-length fd-stream))
+ (tail (fd-stream-obuf-tail fd-stream))
+ (space (- len tail))
+ (bytes (- end start))
+ (newtail (+ tail bytes)))
+ (cond ((minusp bytes) ; error case
+ (cerror "Just go on as if nothing happened."
+ "~S called with :END before :START!"
+ 'output-raw-bytes))
+ ((zerop bytes)) ; Easy case
+ ((<= bytes space)
+ (if (system-area-pointer-p thing)
+ (system-area-copy thing
+ (* start sb!vm:byte-bits)
+ (fd-stream-obuf-sap fd-stream)
+ (* tail sb!vm:byte-bits)
+ (* bytes sb!vm:byte-bits))
+ ;; FIXME: There should be some type checking somewhere to
+ ;; verify that THING here is a vector, not just <not a SAP>.
+ (copy-to-system-area thing
+ (+ (* start sb!vm:byte-bits)
+ (* sb!vm:vector-data-offset
+ sb!vm:word-bits))
+ (fd-stream-obuf-sap fd-stream)
+ (* tail sb!vm:byte-bits)
+ (* bytes sb!vm:byte-bits)))
+ (setf (fd-stream-obuf-tail fd-stream) newtail))
+ ((<= bytes len)
+ (flush-output-buffer fd-stream)
+ (if (system-area-pointer-p thing)
+ (system-area-copy thing
+ (* start sb!vm:byte-bits)
+ (fd-stream-obuf-sap fd-stream)
+ 0
+ (* bytes sb!vm:byte-bits))
+ ;; FIXME: There should be some type checking somewhere to
+ ;; verify that THING here is a vector, not just <not a SAP>.
+ (copy-to-system-area thing
+ (+ (* start sb!vm:byte-bits)
+ (* sb!vm:vector-data-offset
+ sb!vm:word-bits))
+ (fd-stream-obuf-sap fd-stream)
+ 0
+ (* bytes sb!vm:byte-bits)))
+ (setf (fd-stream-obuf-tail fd-stream) bytes))
+ (t
+ (flush-output-buffer fd-stream)
+ (do-output fd-stream thing start end nil))))))
+
+;;; Routine to use to output a string. If the stream is unbuffered, slam
+;;; the string down the file descriptor, otherwise use OUTPUT-RAW-BYTES to
+;;; buffer the string. Update charpos by checking to see where the last newline
+;;; was.
+;;;
+;;; Note: some bozos (the FASL dumper) call write-string with things other
+;;; than strings. Therefore, we must make sure we have a string before calling
+;;; position on it.
+;;; KLUDGE: It would be better to fix the bozos instead of trying to
+;;; cover for them here. -- WHN 20000203
+(defun fd-sout (stream thing start end)
+ (let ((start (or start 0))
+ (end (or end (length (the vector thing)))))
+ (declare (fixnum start end))
+ (if (stringp thing)
+ (let ((last-newline (and (find #\newline (the simple-string thing)
+ :start start :end end)
+ (position #\newline (the simple-string thing)
+ :from-end t
+ :start start
+ :end end))))
+ (ecase (fd-stream-buffering stream)
+ (:full
+ (output-raw-bytes stream thing start end))
+ (:line
+ (output-raw-bytes stream thing start end)
+ (when last-newline
+ (flush-output-buffer stream)))
+ (:none
+ (do-output stream thing start end nil)))
+ (if last-newline
+ (setf (fd-stream-char-pos stream)
+ (- end last-newline 1))
+ (incf (fd-stream-char-pos stream)
+ (- end start))))
+ (ecase (fd-stream-buffering stream)
+ ((:line :full)
+ (output-raw-bytes stream thing start end))
+ (:none
+ (do-output stream thing start end nil))))))
+
+;;; Find an output routine to use given the type and buffering. Return as
+;;; multiple values the routine, the real type transfered, and the number of
+;;; bytes per element.
+(defun pick-output-routine (type buffering)
+ (dolist (entry *output-routines*)
+ (when (and (subtypep type (car entry))
+ (eq buffering (cadr entry)))
+ (return (values (symbol-function (caddr entry))
+ (car entry)
+ (cadddr entry))))))
+\f
+;;;; input routines and related noise
+
+(defvar *input-routines* ()
+ #!+sb-doc
+ "List of all available input routines. Each element is a list of the
+ element-type input, the function name, and the number of bytes per element.")
+
+;;; Fills the input buffer, and returns the first character. Throws to
+;;; eof-input-catcher if the eof was reached. Drops into system:server if
+;;; necessary.
+(defun do-input (stream)
+ (let ((fd (fd-stream-fd stream))
+ (ibuf-sap (fd-stream-ibuf-sap stream))
+ (buflen (fd-stream-ibuf-length stream))
+ (head (fd-stream-ibuf-head stream))
+ (tail (fd-stream-ibuf-tail stream)))
+ (declare (type index head tail))
+ (unless (zerop head)
+ (cond ((eql head tail)
+ (setf head 0)
+ (setf tail 0)
+ (setf (fd-stream-ibuf-head stream) 0)
+ (setf (fd-stream-ibuf-tail stream) 0))
+ (t
+ (decf tail head)
+ (system-area-copy ibuf-sap (* head sb!vm:byte-bits)
+ ibuf-sap 0 (* tail sb!vm:byte-bits))
+ (setf head 0)
+ (setf (fd-stream-ibuf-head stream) 0)
+ (setf (fd-stream-ibuf-tail stream) tail))))
+ (setf (fd-stream-listen stream) nil)
+ (multiple-value-bind (count errno)
+ ;; FIXME: Judging from compiler warnings, this WITH-ALIEN form expands
+ ;; into something which uses the not-yet-defined type
+ ;; (SB!ALIEN-INTERNALS:ALIEN (* (SB!ALIEN:STRUCT SB!UNIX:FD-SET))).
+ ;; This is probably inefficient and unsafe and generally bad, so
+ ;; try to find some way to make that type known before
+ ;; this is compiled.
+ (sb!alien:with-alien ((read-fds (sb!alien:struct sb!unix:fd-set)))
+ (sb!unix:fd-zero read-fds)
+ (sb!unix:fd-set fd read-fds)
+ (sb!unix:unix-fast-select (1+ fd)
+ (sb!alien:addr read-fds)
+ nil
+ nil
+ 0
+ 0))
+ (case count
+ (1)
+ (0
+ (unless #!-mp (sb!sys:wait-until-fd-usable
+ fd :input (fd-stream-timeout stream))
+ #!+mp (sb!mp:process-wait-until-fd-usable
+ fd :input (fd-stream-timeout stream))
+ (error 'io-timeout :stream stream :direction :read)))
+ (t
+ (error "problem checking to see whether ~S is readable: ~A"
+ stream
+ (sb!unix:get-unix-error-msg errno)))))
+ (multiple-value-bind (count errno)
+ (sb!unix:unix-read fd
+ (sb!sys:int-sap (+ (sb!sys:sap-int ibuf-sap) tail))
+ (- buflen tail))
+ (cond ((null count)
+ (if (eql errno sb!unix:ewouldblock)
+ (progn
+ (unless #!-mp (sb!sys:wait-until-fd-usable
+ fd :input (fd-stream-timeout stream))
+ #!+mp (sb!mp:process-wait-until-fd-usable
+ fd :input (fd-stream-timeout stream))
+ (error 'io-timeout :stream stream :direction :read))
+ (do-input stream))
+ (error "error reading ~S: ~A"
+ stream
+ (sb!unix:get-unix-error-msg errno))))
+ ((zerop count)
+ (setf (fd-stream-listen stream) :eof)
+ (throw 'eof-input-catcher nil))
+ (t
+ (incf (fd-stream-ibuf-tail stream) count))))))
+
+;;; Makes sure there are at least ``bytes'' number of bytes in the input
+;;; buffer. Keeps calling do-input until that condition is met.
+(defmacro input-at-least (stream bytes)
+ (let ((stream-var (gensym))
+ (bytes-var (gensym)))
+ `(let ((,stream-var ,stream)
+ (,bytes-var ,bytes))
+ (loop
+ (when (>= (- (fd-stream-ibuf-tail ,stream-var)
+ (fd-stream-ibuf-head ,stream-var))
+ ,bytes-var)
+ (return))
+ (do-input ,stream-var)))))
+
+;;; INPUT-WRAPPER -- intenal
+;;;
+;;; Macro to wrap around all input routines to handle eof-error noise.
+(defmacro input-wrapper ((stream bytes eof-error eof-value) &body read-forms)
+ (let ((stream-var (gensym))
+ (element-var (gensym)))
+ `(let ((,stream-var ,stream))
+ (if (fd-stream-unread ,stream-var)
+ (prog1
+ (fd-stream-unread ,stream-var)
+ (setf (fd-stream-unread ,stream-var) nil)
+ (setf (fd-stream-listen ,stream-var) nil))
+ (let ((,element-var
+ (catch 'eof-input-catcher
+ (input-at-least ,stream-var ,bytes)
+ ,@read-forms)))
+ (cond (,element-var
+ (incf (fd-stream-ibuf-head ,stream-var) ,bytes)
+ ,element-var)
+ (t
+ (eof-or-lose ,stream-var ,eof-error ,eof-value))))))))
+
+;;; Defines an input routine.
+(defmacro def-input-routine (name
+ (type size sap head)
+ &rest body)
+ `(progn
+ (defun ,name (stream eof-error eof-value)
+ (input-wrapper (stream ,size eof-error eof-value)
+ (let ((,sap (fd-stream-ibuf-sap stream))
+ (,head (fd-stream-ibuf-head stream)))
+ ,@body)))
+ (setf *input-routines*
+ (nconc *input-routines*
+ (list (list ',type ',name ',size))))))
+
+;;; Routine to use in stream-in slot for reading string chars.
+(def-input-routine input-character
+ (character 1 sap head)
+ (code-char (sap-ref-8 sap head)))
+
+;;; Routine to read in an unsigned 8 bit number.
+(def-input-routine input-unsigned-8bit-byte
+ ((unsigned-byte 8) 1 sap head)
+ (sap-ref-8 sap head))
+
+;;; Routine to read in a signed 8 bit number.
+(def-input-routine input-signed-8bit-number
+ ((signed-byte 8) 1 sap head)
+ (signed-sap-ref-8 sap head))
+
+;;; Routine to read in an unsigned 16 bit number.
+(def-input-routine input-unsigned-16bit-byte
+ ((unsigned-byte 16) 2 sap head)
+ (sap-ref-16 sap head))
+
+;;; Routine to read in a signed 16 bit number.
+(def-input-routine input-signed-16bit-byte
+ ((signed-byte 16) 2 sap head)
+ (signed-sap-ref-16 sap head))
+
+;;; Routine to read in a unsigned 32 bit number.
+(def-input-routine input-unsigned-32bit-byte
+ ((unsigned-byte 32) 4 sap head)
+ (sap-ref-32 sap head))
+
+;;; Routine to read in a signed 32 bit number.
+(def-input-routine input-signed-32bit-byte
+ ((signed-byte 32) 4 sap head)
+ (signed-sap-ref-32 sap head))
+
+;;; Find an input routine to use given the type. Return as multiple values
+;;; the routine, the real type transfered, and the number of bytes per element.
+(defun pick-input-routine (type)
+ (dolist (entry *input-routines*)
+ (when (subtypep type (car entry))
+ (return (values (symbol-function (cadr entry))
+ (car entry)
+ (caddr entry))))))
+
+;;; Returns a string constructed from the sap, start, and end.
+(defun string-from-sap (sap start end)
+ (declare (type index start end))
+ (let* ((length (- end start))
+ (string (make-string length)))
+ (copy-from-system-area sap (* start sb!vm:byte-bits)
+ string (* sb!vm:vector-data-offset sb!vm:word-bits)
+ (* length sb!vm:byte-bits))
+ string))
+
+;;; old version, not good for implementing READ-SEQUENCE (and just complex)
+;;; FIXME: Remove once new FD-STREAM-READ-N-BYTES (below) is stable.
+#+nil
+(defun fd-stream-read-n-bytes (stream buffer start requested eof-error-p)
+ (declare (type stream stream) (type index start requested))
+ (let* ((sap (fd-stream-ibuf-sap stream))
+ (offset start)
+ (head (fd-stream-ibuf-head stream))
+ (tail (fd-stream-ibuf-tail stream))
+ (available (- tail head))
+ (copy (min requested available)))
+ (declare (type index offset head tail available copy))
+ (unless (zerop copy)
+ (if (typep buffer 'system-area-pointer)
+ (system-area-copy sap (* head sb!vm:byte-bits)
+ buffer (* offset sb!vm:byte-bits)
+ (* copy sb!vm:byte-bits))
+ (copy-from-system-area sap (* head sb!vm:byte-bits)
+ buffer (+ (* offset sb!vm:byte-bits)
+ (* sb!vm:vector-data-offset
+ sb!vm:word-bits))
+ (* copy sb!vm:byte-bits)))
+ (incf (fd-stream-ibuf-head stream) copy))
+ (cond
+ ((or (= copy requested)
+ (and (not eof-error-p) (/= copy 0)))
+ copy)
+ (t
+ (setf (fd-stream-ibuf-head stream) 0)
+ (setf (fd-stream-ibuf-tail stream) 0)
+ (setf (fd-stream-listen stream) nil)
+ (let ((now-needed (- requested copy))
+ (len (fd-stream-ibuf-length stream)))
+ (declare (type index now-needed len))
+ (cond
+ ((> now-needed len)
+ ;; If the desired amount is greater than the stream buffer size, then
+ ;; read directly into the destination, incrementing the start
+ ;; accordingly. In this case, we never leave anything in the stream
+ ;; buffer.
+ (sb!sys:without-gcing
+ (loop
+ (multiple-value-bind (count err)
+ (sb!unix:unix-read (fd-stream-fd stream)
+ (sap+ (if (typep buffer
+ 'system-area-pointer)
+ buffer
+ (vector-sap buffer))
+ (+ offset copy))
+ now-needed)
+ (declare (type (or index null) count))
+ (unless count
+ (error "error reading ~S: ~A"
+ stream
+ (sb!unix:get-unix-error-msg err)))
+ (if eof-error-p
+ (when (zerop count)
+ (error 'end-of-file :stream stream))
+ (return (- requested now-needed)))
+ (decf now-needed count)
+ (when (zerop now-needed)
+ (return requested))
+ (incf offset count)))))
+ (t
+ ;; If we want less than the buffer size, then loop trying to fill the
+ ;; stream buffer and copying what we get into the destination. When
+ ;; we have enough, we leave what's left in the stream buffer.
+ (loop
+ (multiple-value-bind (count err)
+ (sb!unix:unix-read (fd-stream-fd stream) sap len)
+ (declare (type (or index null) count))
+ (unless count
+ (error "error reading ~S: ~A"
+ stream
+ (sb!unix:get-unix-error-msg err)))
+ (when (and eof-error-p (zerop count))
+ (error 'end-of-file :stream stream))
+
+ (let* ((copy (min now-needed count))
+ (copy-bits (* copy sb!vm:byte-bits))
+ (buffer-start-bits
+ (* (+ offset available) sb!vm:byte-bits)))
+ (declare (type index copy copy-bits buffer-start-bits))
+ (if (typep buffer 'system-area-pointer)
+ (system-area-copy sap 0
+ buffer buffer-start-bits
+ copy-bits)
+ (copy-from-system-area sap 0
+ buffer (+ buffer-start-bits
+ (* sb!vm:vector-data-offset
+ sb!vm:word-bits))
+ copy-bits))
+
+ (decf now-needed copy)
+ (when (or (zerop now-needed) (not eof-error-p))
+ (setf (fd-stream-ibuf-head stream) copy)
+ (setf (fd-stream-ibuf-tail stream) count)
+ (return (- requested now-needed)))
+ (incf offset copy)))))))))))
+
+;;; the N-BIN method for FD-STREAMs. This blocks in UNIX-READ. It is generally
+;;; used where there is a definite amount of reading to be done, so blocking
+;;; isn't too problematical.
+(defun fd-stream-read-n-bytes (stream buffer start requested eof-error-p)
+ (declare (type fd-stream stream))
+ (declare (type index start requested))
+ (do ((total-copied 0))
+ (nil)
+ (declare (type index total-copied))
+ (let* ((remaining-request (- requested total-copied))
+ (head (fd-stream-ibuf-head stream))
+ (tail (fd-stream-ibuf-tail stream))
+ (available (- tail head))
+ (this-copy (min remaining-request available))
+ (this-start (+ start total-copied))
+ (sap (fd-stream-ibuf-sap stream)))
+ (declare (type index remaining-request head tail available))
+ (declare (type index this-copy))
+ #+nil
+ (format t
+ "/TOTAL-COPIED=~D HEAD=~D TAIL=~D THIS-COPY=~D~%"
+ total-copied
+ head
+ tail
+ this-copy)
+ ;; Copy data from stream buffer into user's buffer.
+ (if (typep buffer 'system-area-pointer)
+ (system-area-copy sap (* head sb!vm:byte-bits)
+ buffer (* this-start sb!vm:byte-bits)
+ (* this-copy sb!vm:byte-bits))
+ (copy-from-system-area sap (* head sb!vm:byte-bits)
+ buffer (+ (* this-start sb!vm:byte-bits)
+ (* sb!vm:vector-data-offset
+ sb!vm:word-bits))
+ (* this-copy sb!vm:byte-bits)))
+ (incf (fd-stream-ibuf-head stream) this-copy)
+ (incf total-copied this-copy)
+ ;; Maybe we need to refill the stream buffer.
+ (cond (;; If there were enough data in the stream buffer, we're done.
+ (= total-copied requested)
+ #+nil
+ (format t "/enough data~%")
+ (return total-copied))
+ (;; If EOF, we're done in another way.
+ (zerop (refill-fd-stream-buffer stream))
+ #+nil
+ (format t "/end of file~%")
+ (if eof-error-p
+ (error 'end-of-file :stream stream)
+ (return total-copied)))
+ ;; Otherwise we refilled the stream buffer, so fall through into
+ ;; another pass of the loop.
+ ))))
+
+;;; Try to refill the stream buffer. Return the number of bytes read. (For EOF,
+;;; the return value will be zero, otherwise positive.)
+(defun refill-fd-stream-buffer (stream)
+ ;; We don't have any logic to preserve leftover bytes in the buffer,
+ ;; so we should only be called when the buffer is empty.
+ (assert (= (fd-stream-ibuf-head stream) (fd-stream-ibuf-tail stream)))
+ (multiple-value-bind (count err)
+ (sb!unix:unix-read (fd-stream-fd stream)
+ (fd-stream-ibuf-sap stream)
+ (fd-stream-ibuf-length stream))
+ (declare (type (or index null) count))
+ (when (null count)
+ (error "error reading ~S: ~A"
+ stream
+ (sb!unix:get-unix-error-msg err)))
+ (setf (fd-stream-listen stream) nil
+ (fd-stream-ibuf-head stream) 0
+ (fd-stream-ibuf-tail stream) count)
+; (format t "~%buffer=~%--~%")
+; (dotimes (i count)
+; (write-char (code-char (sap-ref-8 (fd-stream-ibuf-sap stream) i))))
+; (format t "~%--~%")
+ #+nil
+ (format t "/REFILL-FD-STREAM-BUFFER = ~D~%" count)
+ count))
+\f
+;;;; utility functions (misc routines, etc)
+
+;;; Fill in the various routine slots for the given type. Input-p and
+;;; output-p indicate what slots to fill. The buffering slot must be set prior
+;;; to calling this routine.
+(defun set-routines (stream type input-p output-p buffer-p)
+ (let ((target-type (case type
+ ((:default unsigned-byte)
+ '(unsigned-byte 8))
+ (signed-byte
+ '(signed-byte 8))
+ (t
+ type)))
+ (input-type nil)
+ (output-type nil)
+ (input-size nil)
+ (output-size nil))
+
+ (when (fd-stream-obuf-sap stream)
+ (push (fd-stream-obuf-sap stream) *available-buffers*)
+ (setf (fd-stream-obuf-sap stream) nil))
+ (when (fd-stream-ibuf-sap stream)
+ (push (fd-stream-ibuf-sap stream) *available-buffers*)
+ (setf (fd-stream-ibuf-sap stream) nil))
+
+ (when input-p
+ (multiple-value-bind (routine type size)
+ (pick-input-routine target-type)
+ (unless routine
+ (error "could not find any input routine for ~S" target-type))
+ (setf (fd-stream-ibuf-sap stream) (next-available-buffer))
+ (setf (fd-stream-ibuf-length stream) bytes-per-buffer)
+ (setf (fd-stream-ibuf-tail stream) 0)
+ (if (subtypep type 'character)
+ (setf (fd-stream-in stream) routine
+ (fd-stream-bin stream) #'ill-bin)
+ (setf (fd-stream-in stream) #'ill-in
+ (fd-stream-bin stream) routine))
+ (when (eql size 1)
+ (setf (fd-stream-n-bin stream) #'fd-stream-read-n-bytes)
+ (when buffer-p
+ (setf (lisp-stream-in-buffer stream)
+ (make-array in-buffer-length
+ :element-type '(unsigned-byte 8)))))
+ (setf input-size size)
+ (setf input-type type)))
+
+ (when output-p
+ (multiple-value-bind (routine type size)
+ (pick-output-routine target-type (fd-stream-buffering stream))
+ (unless routine
+ (error "could not find any output routine for ~S buffered ~S"
+ (fd-stream-buffering stream)
+ target-type))
+ (setf (fd-stream-obuf-sap stream) (next-available-buffer))
+ (setf (fd-stream-obuf-length stream) bytes-per-buffer)
+ (setf (fd-stream-obuf-tail stream) 0)
+ (if (subtypep type 'character)
+ (setf (fd-stream-out stream) routine
+ (fd-stream-bout stream) #'ill-bout)
+ (setf (fd-stream-out stream)
+ (or (if (eql size 1)
+ (pick-output-routine 'base-char
+ (fd-stream-buffering stream)))
+ #'ill-out)
+ (fd-stream-bout stream) routine))
+ (setf (fd-stream-sout stream)
+ (if (eql size 1) #'fd-sout #'ill-out))
+ (setf (fd-stream-char-pos stream) 0)
+ (setf output-size size)
+ (setf output-type type)))
+
+ (when (and input-size output-size
+ (not (eq input-size output-size)))
+ (error "Element sizes for input (~S:~S) and output (~S:~S) differ?"
+ input-type input-size
+ output-type output-size))
+ (setf (fd-stream-element-size stream)
+ (or input-size output-size))
+
+ (setf (fd-stream-element-type stream)
+ (cond ((equal input-type output-type)
+ input-type)
+ ((null output-type)
+ input-type)
+ ((null input-type)
+ output-type)
+ ((subtypep input-type output-type)
+ input-type)
+ ((subtypep output-type input-type)
+ output-type)
+ (t
+ (error "Input type (~S) and output type (~S) are unrelated?"
+ input-type
+ output-type))))))
+
+;;; Handle miscellaneous operations on fd-stream.
+(defun fd-stream-misc-routine (stream operation &optional arg1 arg2)
+ (declare (ignore arg2))
+ ;; FIXME: Declare TYPE FD-STREAM STREAM?
+ (case operation
+ (:listen
+ (or (not (eql (fd-stream-ibuf-head stream)
+ (fd-stream-ibuf-tail stream)))
+ (fd-stream-listen stream)
+ (setf (fd-stream-listen stream)
+ (eql (sb!alien:with-alien ((read-fds (sb!alien:struct
+ sb!unix:fd-set)))
+ (sb!unix:fd-zero read-fds)
+ (sb!unix:fd-set (fd-stream-fd stream) read-fds)
+ (sb!unix:unix-fast-select (1+ (fd-stream-fd stream))
+ (sb!alien:addr read-fds)
+ nil nil 0 0))
+ 1))))
+ (:unread
+ (setf (fd-stream-unread stream) arg1)
+ (setf (fd-stream-listen stream) t))
+ (:close
+ (cond (arg1
+ ;; We got us an abort on our hands.
+ (when (fd-stream-handler stream)
+ (sb!sys:remove-fd-handler (fd-stream-handler stream))
+ (setf (fd-stream-handler stream) nil))
+ (when (and (fd-stream-file stream)
+ (fd-stream-obuf-sap stream))
+ ;; Can't do anything unless we know what file were dealing with,
+ ;; and we don't want to do anything strange unless we were
+ ;; writing to the file.
+ (if (fd-stream-original stream)
+ ;; We have a handle on the original, just revert.
+ (multiple-value-bind (okay err)
+ (sb!unix:unix-rename (fd-stream-original stream)
+ (fd-stream-file stream))
+ (unless okay
+ (cerror "Go on as if nothing bad happened."
+ "could not restore ~S to its original contents: ~A"
+ (fd-stream-file stream)
+ (sb!unix:get-unix-error-msg err))))
+ ;; Can't restore the orignal, so nuke that puppy.
+ (multiple-value-bind (okay err)
+ (sb!unix:unix-unlink (fd-stream-file stream))
+ (unless okay
+ (cerror "Go on as if nothing bad happened."
+ "Could not remove ~S: ~A"
+ (fd-stream-file stream)
+ (sb!unix:get-unix-error-msg err)))))))
+ (t
+ (fd-stream-misc-routine stream :finish-output)
+ (when (and (fd-stream-original stream)
+ (fd-stream-delete-original stream))
+ (multiple-value-bind (okay err)
+ (sb!unix:unix-unlink (fd-stream-original stream))
+ (unless okay
+ (cerror "Go on as if nothing bad happened."
+ "could not delete ~S during close of ~S: ~A"
+ (fd-stream-original stream)
+ stream
+ (sb!unix:get-unix-error-msg err)))))))
+ (when (fboundp 'cancel-finalization)
+ (cancel-finalization stream))
+ (sb!unix:unix-close (fd-stream-fd stream))
+ (when (fd-stream-obuf-sap stream)
+ (push (fd-stream-obuf-sap stream) *available-buffers*)
+ (setf (fd-stream-obuf-sap stream) nil))
+ (when (fd-stream-ibuf-sap stream)
+ (push (fd-stream-ibuf-sap stream) *available-buffers*)
+ (setf (fd-stream-ibuf-sap stream) nil))
+ (sb!impl::set-closed-flame stream))
+ (:clear-input
+ (setf (fd-stream-unread stream) nil)
+ (setf (fd-stream-ibuf-head stream) 0)
+ (setf (fd-stream-ibuf-tail stream) 0)
+ (catch 'eof-input-catcher
+ (loop
+ (let ((count (sb!alien:with-alien ((read-fds (sb!alien:struct
+ sb!unix:fd-set)))
+ (sb!unix:fd-zero read-fds)
+ (sb!unix:fd-set (fd-stream-fd stream) read-fds)
+ (sb!unix:unix-fast-select (1+ (fd-stream-fd stream))
+ (sb!alien:addr read-fds)
+ nil
+ nil
+ 0
+ 0))))
+ (cond ((eql count 1)
+ (do-input stream)
+ (setf (fd-stream-ibuf-head stream) 0)
+ (setf (fd-stream-ibuf-tail stream) 0))
+ (t
+ (return t)))))))
+ (:force-output
+ (flush-output-buffer stream))
+ (:finish-output
+ (flush-output-buffer stream)
+ (do ()
+ ((null (fd-stream-output-later stream)))
+ (sb!sys:serve-all-events)))
+ (:element-type
+ (fd-stream-element-type stream))
+ (:interactive-p
+ (sb!unix:unix-isatty (fd-stream-fd stream)))
+ (:line-length
+ 80)
+ (:charpos
+ (fd-stream-char-pos stream))
+ (:file-length
+ (multiple-value-bind (okay dev ino mode nlink uid gid rdev size
+ atime mtime ctime blksize blocks)
+ (sb!unix:unix-fstat (fd-stream-fd stream))
+ (declare (ignore ino nlink uid gid rdev
+ atime mtime ctime blksize blocks))
+ (unless okay
+ (error "error fstat'ing ~S: ~A"
+ stream
+ (sb!unix:get-unix-error-msg dev)))
+ (if (zerop (the index mode))
+ nil
+ ;; FIXME: It's not safe to assume that SIZE is an INDEX, there
+ ;; are files bigger than that.
+ (truncate (the index size) (fd-stream-element-size stream)))))
+ (:file-position
+ (fd-stream-file-position stream arg1))))
+
+(defun fd-stream-file-position (stream &optional newpos)
+ (declare (type fd-stream stream)
+ (type (or index (member nil :start :end)) newpos))
+ (if (null newpos)
+ (sb!sys:without-interrupts
+ ;; First, find the position of the UNIX file descriptor in the
+ ;; file.
+ (multiple-value-bind (posn errno)
+ (sb!unix:unix-lseek (fd-stream-fd stream) 0 sb!unix:l_incr)
+ (declare (type (or index null) posn))
+ (cond ((fixnump posn)
+ ;; Adjust for buffered output:
+ ;; If there is any output buffered, the *real* file position
+ ;; will be larger than reported by lseek because lseek
+ ;; obviously cannot take into account output we have not
+ ;; sent yet.
+ (dolist (later (fd-stream-output-later stream))
+ (incf posn (- (the index (caddr later))
+ (the index (cadr later)))))
+ (incf posn (fd-stream-obuf-tail stream))
+ ;; Adjust for unread input:
+ ;; If there is any input read from UNIX but not supplied to
+ ;; the user of the stream, the *real* file position will
+ ;; smaller than reported, because we want to look like the
+ ;; unread stuff is still available.
+ (decf posn (- (fd-stream-ibuf-tail stream)
+ (fd-stream-ibuf-head stream)))
+ (when (fd-stream-unread stream)
+ (decf posn))
+ ;; Divide bytes by element size.
+ (truncate posn (fd-stream-element-size stream)))
+ ((eq errno sb!unix:espipe)
+ nil)
+ (t
+ (sb!sys:with-interrupts
+ (error "error LSEEK'ing ~S: ~A"
+ stream
+ (sb!unix:get-unix-error-msg errno)))))))
+ (let ((offset 0) origin)
+ (declare (type index offset))
+ ;; Make sure we don't have any output pending, because if we move the
+ ;; file pointer before writing this stuff, it will be written in the
+ ;; wrong location.
+ (flush-output-buffer stream)
+ (do ()
+ ((null (fd-stream-output-later stream)))
+ (sb!sys:serve-all-events))
+ ;; Clear out any pending input to force the next read to go to the
+ ;; disk.
+ (setf (fd-stream-unread stream) nil)
+ (setf (fd-stream-ibuf-head stream) 0)
+ (setf (fd-stream-ibuf-tail stream) 0)
+ ;; Trash cached value for listen, so that we check next time.
+ (setf (fd-stream-listen stream) nil)
+ ;; Now move it.
+ (cond ((eq newpos :start)
+ (setf offset 0 origin sb!unix:l_set))
+ ((eq newpos :end)
+ (setf offset 0 origin sb!unix:l_xtnd))
+ ((typep newpos 'index)
+ (setf offset (* newpos (fd-stream-element-size stream))
+ origin sb!unix:l_set))
+ (t
+ (error "invalid position given to file-position: ~S" newpos)))
+ (multiple-value-bind (posn errno)
+ (sb!unix:unix-lseek (fd-stream-fd stream) offset origin)
+ (cond ((typep posn 'fixnum)
+ t)
+ ((eq errno sb!unix:espipe)
+ nil)
+ (t
+ (error "error lseek'ing ~S: ~A"
+ stream
+ (sb!unix:get-unix-error-msg errno))))))))
+\f
+;;;; creation routines (MAKE-FD-STREAM and OPEN)
+
+;;; Returns a FD-STREAM on the given file.
+(defun make-fd-stream (fd
+ &key
+ (input nil input-p)
+ (output nil output-p)
+ (element-type 'base-char)
+ (buffering :full)
+ timeout
+ file
+ original
+ delete-original
+ pathname
+ input-buffer-p
+ (name (if file
+ (format nil "file ~S" file)
+ (format nil "descriptor ~D" fd)))
+ auto-close)
+ (declare (type index fd) (type (or index null) timeout)
+ (type (member :none :line :full) buffering))
+ #!+sb-doc
+ "Create a stream for the given unix file descriptor.
+ If input is non-nil, allow input operations.
+ If output is non-nil, allow output operations.
+ If neither input nor output are specified, default to allowing input.
+ Element-type indicates the element type to use (as for open).
+ Buffering indicates the kind of buffering to use.
+ Timeout (if true) is the number of seconds to wait for input. If NIL (the
+ default), then wait forever. When we time out, we signal IO-TIMEOUT.
+ File is the name of the file (will be returned by PATHNAME).
+ Name is used to identify the stream when printed."
+ (cond ((not (or input-p output-p))
+ (setf input t))
+ ((not (or input output))
+ (error "File descriptor must be opened either for input or output.")))
+ (let ((stream (%make-fd-stream :fd fd
+ :name name
+ :file file
+ :original original
+ :delete-original delete-original
+ :pathname pathname
+ :buffering buffering
+ :timeout timeout)))
+ (set-routines stream element-type input output input-buffer-p)
+ (when (and auto-close (fboundp 'finalize))
+ (finalize stream
+ (lambda ()
+ (sb!unix:unix-close fd)
+ #!+sb-show
+ (format *terminal-io* "** closed file descriptor ~D **~%"
+ fd))))
+ stream))
+
+;;; Pick a name to use for the backup file.
+(defvar *backup-extension* ".BAK"
+ #!+sb-doc
+ "This is a string that OPEN tacks on the end of a file namestring to produce
+ a name for the :if-exists :rename-and-delete and :rename options. Also,
+ this can be a function that takes a namestring and returns a complete
+ namestring.")
+(defun pick-backup-name (name)
+ (declare (type simple-string name))
+ (let ((ext *backup-extension*))
+ (etypecase ext
+ (simple-string (concatenate 'simple-string name ext))
+ (function (funcall ext name)))))
+
+;;; Ensure that the given arg is one of the given list of valid things.
+;;; Allow the user to fix any problems.
+;;; FIXME: Why let the user fix any problems?
+(defun ensure-one-of (item list what)
+ (unless (member item list)
+ (loop
+ (cerror "Enter new value for ~*~S"
+ "~S is invalid for ~S. Must be one of~{ ~S~}"
+ item
+ what
+ list)
+ (format (the stream *query-io*) "Enter new value for ~S: " what)
+ (force-output *query-io*)
+ (setf item (read *query-io*))
+ (when (member item list)
+ (return))))
+ item)
+
+;;; Rename Namestring to Original. First, check whether we have write access,
+;;; since we don't want to trash unwritable files even if we technically can.
+;;; We return true if we succeed in renaming.
+(defun do-old-rename (namestring original)
+ (unless (sb!unix:unix-access namestring sb!unix:w_ok)
+ (cerror "Try to rename it anyway."
+ "File ~S is not writable."
+ namestring))
+ (multiple-value-bind (okay err) (sb!unix:unix-rename namestring original)
+ (cond (okay t)
+ (t
+ (cerror "Use :SUPERSEDE instead."
+ "Could not rename ~S to ~S: ~A."
+ namestring
+ original
+ (sb!unix:get-unix-error-msg err))
+ nil))))
+
+(defun open (filename
+ &key
+ (direction :input)
+ (element-type 'base-char)
+ (if-exists nil if-exists-given)
+ (if-does-not-exist nil if-does-not-exist-given)
+ (external-format :default)
+ &aux ; Squelch assignment warning.
+ (direction direction)
+ (if-does-not-exist if-does-not-exist)
+ (if-exists if-exists))
+ #!+sb-doc
+ "Return a stream which reads from or writes to Filename.
+ Defined keywords:
+ :direction - one of :input, :output, :io, or :probe
+ :element-type - Type of object to read or write, default BASE-CHAR
+ :if-exists - one of :error, :new-version, :rename, :rename-and-delete,
+ :overwrite, :append, :supersede or nil
+ :if-does-not-exist - one of :error, :create or nil
+ See the manual for details."
+
+ (unless (eq external-format :default)
+ (error 'simple-error
+ :format-control
+ "Any external format other than :DEFAULT isn't recognized."))
+
+ ;; First, make sure that DIRECTION is valid. Allow it to be changed
+ ;; if not.
+ ;;
+ ;; FIXME: Why allow it to be changed if not?
+ (setf direction
+ (ensure-one-of direction
+ '(:input :output :io :probe)
+ :direction))
+
+ ;; Calculate useful stuff.
+ (multiple-value-bind (input output mask)
+ (case direction
+ (:input (values t nil sb!unix:o_rdonly))
+ (:output (values nil t sb!unix:o_wronly))
+ (:io (values t t sb!unix:o_rdwr))
+ (:probe (values t nil sb!unix:o_rdonly)))
+ (declare (type index mask))
+ (let* ((pathname (pathname filename))
+ (namestring
+ (cond ((unix-namestring pathname input))
+ ((and input (eq if-does-not-exist :create))
+ (unix-namestring pathname nil)))))
+ ;; Process if-exists argument if we are doing any output.
+ (cond (output
+ (unless if-exists-given
+ (setf if-exists
+ (if (eq (pathname-version pathname) :newest)
+ :new-version
+ :error)))
+ (setf if-exists ; FIXME: should just die, not allow resetting
+ (ensure-one-of if-exists
+ '(:error :new-version :rename
+ :rename-and-delete :overwrite
+ :append :supersede nil)
+ :if-exists))
+ (case if-exists
+ ((:error nil)
+ (setf mask (logior mask sb!unix:o_excl)))
+ ((:rename :rename-and-delete)
+ (setf mask (logior mask sb!unix:o_creat)))
+ ((:new-version :supersede)
+ (setf mask (logior mask sb!unix:o_trunc)))
+ (:append
+ (setf mask (logior mask sb!unix:o_append)))))
+ (t
+ (setf if-exists :ignore-this-arg)))
+
+ (unless if-does-not-exist-given
+ (setf if-does-not-exist
+ (cond ((eq direction :input) :error)
+ ((and output
+ (member if-exists '(:overwrite :append)))
+ :error)
+ ((eq direction :probe)
+ nil)
+ (t
+ :create))))
+ (setf if-does-not-exist ; FIXME: should just die, not allow resetting
+ (ensure-one-of if-does-not-exist
+ '(:error :create nil)
+ :if-does-not-exist))
+ (if (eq if-does-not-exist :create)
+ (setf mask (logior mask sb!unix:o_creat)))
+
+ (let ((original (if (member if-exists
+ '(:rename :rename-and-delete))
+ (pick-backup-name namestring)))
+ (delete-original (eq if-exists :rename-and-delete))
+ (mode #o666))
+ (when original
+ ;; We are doing a :RENAME or :RENAME-AND-DELETE.
+ ;; Determine whether the file already exists, make sure the original
+ ;; file is not a directory, and keep the mode.
+ (let ((exists
+ (and namestring
+ (multiple-value-bind (okay err/dev inode orig-mode)
+ (sb!unix:unix-stat namestring)
+ (declare (ignore inode)
+ (type (or index null) orig-mode))
+ (cond
+ (okay
+ (when (and output (= (logand orig-mode #o170000)
+ #o40000))
+ (error "cannot open ~S for output: is a directory"
+ namestring))
+ (setf mode (logand orig-mode #o777))
+ t)
+ ((eql err/dev sb!unix:enoent)
+ nil)
+ (t
+ (error "cannot find ~S: ~A"
+ namestring
+ (sb!unix:get-unix-error-msg err/dev))))))))
+ (unless (and exists
+ (do-old-rename namestring original))
+ (setf original nil)
+ (setf delete-original nil)
+ ;; In order to use :SUPERSEDE instead, we have to make sure
+ ;; SB!UNIX:O_CREAT corresponds to IF-DOES-NOT-EXIST.
+ ;; SB!UNIX:O_CREAT was set before because of IF-EXISTS being
+ ;; :RENAME.
+ (unless (eq if-does-not-exist :create)
+ (setf mask
+ (logior (logandc2 mask sb!unix:o_creat)
+ sb!unix:o_trunc)))
+ (setf if-exists :supersede))))
+
+ ;; Okay, now we can try the actual open.
+ (loop
+ (multiple-value-bind (fd errno)
+ (if namestring
+ (sb!unix:unix-open namestring mask mode)
+ (values nil sb!unix:enoent))
+ (cond ((numberp fd)
+ (return
+ (case direction
+ ((:input :output :io)
+ (make-fd-stream fd
+ :input input
+ :output output
+ :element-type element-type
+ :file namestring
+ :original original
+ :delete-original delete-original
+ :pathname pathname
+ :input-buffer-p t
+ :auto-close t))
+ (:probe
+ (let ((stream
+ (%make-fd-stream :name namestring :fd fd
+ :pathname pathname
+ :element-type element-type)))
+ (close stream)
+ stream)))))
+ ((eql errno sb!unix:enoent)
+ (case if-does-not-exist
+ (:error
+ (cerror "Return NIL."
+ 'simple-file-error
+ :pathname pathname
+ :format-control "error opening ~S: ~A"
+ :format-arguments
+ (list pathname
+ (sb!unix:get-unix-error-msg errno))))
+ (:create
+ (cerror "Return NIL."
+ 'simple-error
+ :format-control
+ "error creating ~S: Path does not exist."
+ :format-arguments
+ (list pathname))))
+ (return nil))
+ ((eql errno sb!unix:eexist)
+ (unless (eq nil if-exists)
+ (cerror "Return NIL."
+ 'simple-file-error
+ :pathname pathname
+ :format-control "error opening ~S: ~A"
+ :format-arguments
+ (list pathname
+ (sb!unix:get-unix-error-msg errno))))
+ (return nil))
+ ((eql errno sb!unix:eacces)
+ (cerror "Try again."
+ "error opening ~S: ~A"
+ pathname
+ (sb!unix:get-unix-error-msg errno)))
+ (t
+ (cerror "Return NIL."
+ "error opening ~S: ~A"
+ pathname
+ (sb!unix:get-unix-error-msg errno))
+ (return nil)))))))))
+\f
+;;;; initialization
+
+(defvar *tty* nil
+ #!+sb-doc
+ "The stream connected to the controlling terminal or NIL if there is none.")
+(defvar *stdin* nil
+ #!+sb-doc
+ "The stream connected to the standard input (file descriptor 0).")
+(defvar *stdout* nil
+ #!+sb-doc
+ "The stream connected to the standard output (file descriptor 1).")
+(defvar *stderr* nil
+ #!+sb-doc
+ "The stream connected to the standard error output (file descriptor 2).")
+
+;;; This is called when the cold load is first started up, and may also
+;;; be called in an attempt to recover from nested errors.
+(defun stream-cold-init-or-reset ()
+ (stream-reinit)
+ (setf *terminal-io* (make-synonym-stream '*tty*))
+ (setf *standard-output* (make-synonym-stream '*stdout*))
+ (setf *standard-input*
+ (#!-high-security
+ ;; FIXME: Why is *STANDARD-INPUT* a TWO-WAY-STREAM? ANSI says it's
+ ;; an input stream.
+ make-two-way-stream
+ #!+high-security
+ %make-two-way-stream (make-synonym-stream '*stdin*)
+ *standard-output*))
+ (setf *error-output* (make-synonym-stream '*stderr*))
+ (setf *query-io* (make-synonym-stream '*terminal-io*))
+ (setf *debug-io* *query-io*)
+ (setf *trace-output* *standard-output*)
+ nil)
+
+;;; This is called whenever a saved core is restarted.
+(defun stream-reinit ()
+ (setf *available-buffers* nil)
+ (setf *stdin*
+ (make-fd-stream 0 :name "standard input" :input t :buffering :line))
+ (setf *stdout*
+ (make-fd-stream 1 :name "standard output" :output t :buffering :line))
+ (setf *stderr*
+ (make-fd-stream 2 :name "standard error" :output t :buffering :line))
+ (let ((tty (sb!unix:unix-open "/dev/tty" sb!unix:o_rdwr #o666)))
+ (if tty
+ (setf *tty*
+ (make-fd-stream tty
+ :name "the terminal"
+ :input t
+ :output t
+ :buffering :line
+ :auto-close t))
+ (setf *tty* (make-two-way-stream *stdin* *stdout*))))
+ nil)
+\f
+;;;; beeping
+
+(defun default-beep-function (stream)
+ (write-char (code-char bell-char-code) stream)
+ (finish-output stream))
+
+(defvar *beep-function* #'default-beep-function
+ #!+sb-doc
+ "This is called in BEEP to feep the user. It takes a stream.")
+
+(defun beep (&optional (stream *terminal-io*))
+ (funcall *beep-function* stream))
+\f
+;;; Kind of like FILE-POSITION, but is an internal hack used by the filesys
+;;; stuff to get and set the file name.
+(defun file-name (stream &optional new-name)
+ (when (typep stream 'fd-stream)
+ (cond (new-name
+ (setf (fd-stream-pathname stream) new-name)
+ (setf (fd-stream-file stream)
+ (unix-namestring new-name nil))
+ t)
+ (t
+ (fd-stream-pathname stream)))))
+\f
+;;;; international character support (which is trivial for our simple
+;;;; character sets)
+
+;;;; (Those who do Lisp only in English might not remember that ANSI requires
+;;;; these functions to be exported from package COMMON-LISP.)
+
+(defun file-string-length (stream object)
+ (declare (type (or string character) object) (type file-stream stream))
+ #!+sb-doc
+ "Return the delta in STREAM's FILE-POSITION that would be caused by writing
+ Object to Stream. Non-trivial only in implementations that support
+ international character sets."
+ (declare (ignore stream))
+ (etypecase object
+ (character 1)
+ (string (length object))))
+
+(defun stream-external-format (stream)
+ (declare (type file-stream stream) (ignore stream))
+ #!+sb-doc
+ "Return :DEFAULT."
+ :default)
--- /dev/null
+;;;; This file contains functions that hack on the global function
+;;;; namespace (primarily concerned with SETF functions here). Also,
+;;;; function encapsulation and routines that set and return
+;;;; definitions disregarding whether they might be encapsulated.
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!IMPL")
+
+(file-comment
+ "$Header$")
+
+(sb!int::/show0 "fdefinition.lisp 22")
+\f
+;;;; fdefinition (fdefn) objects
+
+(defun make-fdefn (name)
+ (make-fdefn name))
+
+(defun fdefn-name (fdefn)
+ (declare (type fdefn fdefn))
+ (fdefn-name fdefn))
+
+(defun fdefn-function (fdefn)
+ (declare (type fdefn fdefn)
+ (values (or function null)))
+ (fdefn-function fdefn))
+
+(defun (setf fdefn-function) (fun fdefn)
+ (declare (type function fun)
+ (type fdefn fdefn)
+ (values function))
+ (setf (fdefn-function fdefn) fun))
+
+(defun fdefn-makunbound (fdefn)
+ (declare (type fdefn fdefn))
+ (fdefn-makunbound fdefn))
+
+;;; This function is called by !COLD-INIT after the globaldb has been
+;;; initialized, but before anything else. We need to install these
+;;; fdefn objects into the globaldb before any top level forms run, or
+;;; we will end up with two different fdefn objects being used for the
+;;; same function name. *!INITIAL-FDEFN-OBJECTS* is set up by GENESIS.
+(defvar *!initial-fdefn-objects*)
+(defun !fdefn-cold-init ()
+ (dolist (fdefn *!initial-fdefn-objects*)
+ (setf (info :function :definition (fdefn-name fdefn)) fdefn)))
+
+(defun fdefinition-object (name create)
+ #!+sb-doc
+ "Return the fdefn object for NAME. If it doesn't already exist and CREATE
+ is non-NIL, create a new (unbound) one."
+ (declare (values (or fdefn null)))
+ (unless (or (symbolp name)
+ (and (consp name)
+ (eq (car name) 'setf)
+ (let ((cdr (cdr name)))
+ (and (consp cdr)
+ (symbolp (car cdr))
+ (null (cdr cdr))))))
+ (error 'simple-type-error
+ :datum name
+ :expected-type '(or symbol list)
+ :format-control "invalid function name: ~S"
+ :format-arguments (list name)))
+ (let ((fdefn (info :function :definition name)))
+ (if (and (null fdefn) create)
+ (setf (info :function :definition name) (make-fdefn name))
+ fdefn)))
+
+;;; FIXME: If the fundamental operation performed when
+;;; funcalling a symbol is %COERCE-NAME-TO-FUNCTION, which expands into
+;;; FDEFINITION-OBJECT, which does (INFO :FUNCTION :DEFINITION NAME),
+;;; that's a horrendously heavyweight way to implement SYMBOL-FUNCTION.
+;;; What compelling reason is there for all this hairiness? The only
+;;; thing I can think of is that it does give a place to store
+;;; SETF functions, but I don't think that's a good enough reason.
+;;; It might even be that the FDEFINITION arrangement saves a little
+;;; space, if the proportion of function-less symbols is high enough,
+;;; but I don't think that's a good enough reason, either.
+;;; I'd really like to wipe out FDEFN stuff root and branch, and
+;;; just store SETF functions in the symbol property list.
+;;;
+;;; One problem with just doing the simple thing: What happens when
+;;; people call symbols which have no function definitions?
+;;; 1. Just hit "undefined function" error -- with no clue as to
+;;; what undefined function it was. (This might actually not be
+;;; too horrible, since the compiler warns you about undefined
+;;; functions and the debugger aims, with incomplete success,
+;;; to show you what form caused an error.)
+;;; 2. various solutions involving closures in the function slot,
+;;; all of which have the drawback of extra memory use and extra
+;;; difficulty in detecting when functions are undefined
+;;; 2a. Have every single symbol have an undefined function closure
+;;; which points back to it to tell you which undefined symbol it
+;;; was. (4 extra words per undefined symbol)
+;;; 2b. Play tricks with FDEFINITION, where the default SYMBOL-FUNCTION
+;;; for any function is an anonymous "undefined function" error
+;;; which doesn't tell you what the problem was, but if FDEFINITION
+;;; is ever called on an undefined symbol, it helpfully changes the
+;;; function definition to point to a closure which knows which
+;;; symbol caused the problem.
+;;; 4. Just don't sweat it except when DEBUG>SPEED, where the calling
+;;; convention gets tweaked to test for the undefined-function
+;;; function at call time and bail out with helpful information
+;;; if it's there.
+;;; 5. Require that the function calling convention be stereotyped
+;;; along the lines of
+;;; mov %ebx, local_immediate_3 ; Point to symbol.
+;;; mov %eax, symbol_function_offset(%eax) ; Point to function.
+;;; call *function_code_pointer(%eax) ; Go.
+;;; That way, it's guaranteed that on entry to a function, %EBX points
+;;; back to the symbol which was used to indirect into the function,
+;;; so the undefined function handler can base its complaint on that.
+;;;
+;;; Another problem with doing the simple thing: people will want to indirect
+;;; through something in order to get to SETF functions, in order to be able to
+;;; redefine them. What will they indirect through? This could be done with a
+;;; hack, making an anonymous symbol and linking it to the main symbol's
+;;; SB!KERNEL:SETF-FUNCTION property. The anonymous symbol could even point
+;;; back to the symbol it's the SETF function for, so that if the SETF function
+;;; was undefined at the time a call was made, the debugger could say which
+;;; function caused the problem. It'd probably be cleaner, though, to use a new
+;;; type of primitive object (SYMBOLOID?) instead. It could probably be like
+;;; symbol except that its name could be any object and its value points back
+;;; to the symbol which owns it. Then the setf functions for FOO could be on
+;;; the list (GET FOO 'SB!KERNEL:SYMBOLOIDS)
+;;;
+;;; FIXME: Oh, my. Now that I've started thinking about it, I appreciate more
+;;; fully how weird and twisted FDEFNs might be. Look at the calling sequence
+;;; for full calls. It goes and reads the address of a function object from its
+;;; own table of immediate values, then jumps into that. Consider how weird
+;;; that is. Not only is it not doing indirection through a symbol (which I'd
+;;; already realized) but it's not doing indirection through
+
+;;; The compiler emits calls to this when someone tries to funcall a symbol.
+(defun %coerce-name-to-function (name)
+ #!+sb-doc
+ "Returns the definition for name, including any encapsulations. Settable
+ with SETF."
+ (let ((fdefn (fdefinition-object name nil)))
+ (or (and fdefn (fdefn-function fdefn))
+ (error 'undefined-function :name name))))
+
+;;; This is just another name for %COERCE-NAME-TO-FUNCTION.
+#!-sb-fluid (declaim (inline raw-definition))
+(defun raw-definition (name)
+ ;; We know that we are calling %COERCE-NAME-TO-FUNCTION, so don't remind us.
+ (declare (optimize (inhibit-warnings 3)))
+ (%coerce-name-to-function name))
+(defun (setf raw-definition) (function name)
+ (let ((fdefn (fdefinition-object name t)))
+ (setf (fdefn-function fdefn) function)))
+
+;;; FIXME: There seems to be no good reason to have both
+;;; %COERCE-NAME-TO-FUNCTION and RAW-DEFINITION names for the same
+;;; thing. And despite what the doc string of %COERCE-NAME-TO-FUNCTION
+;;; says, it's doesn't look settable. Perhaps we could collapse
+;;; %COERCE-TO-FUNCTION, RAW-DEFINITION, and (SETF RAW-DEFINITION)
+;;; into RAW-FDEFINITION and (SETF RAW-FDEFINITION), or
+;;; OUTER-FDEFINITION and (SETF OUTER-FDEFINITION).
+\f
+;;;; definition encapsulation
+
+(defstruct (encapsulation-info (:constructor make-encapsulation-info
+ (type definition)))
+ ;; This is definition's encapsulation type. The encapsulated
+ ;; definition is in the previous encapsulation-info element or
+ ;; installed as the global definition of some function name.
+ type
+ ;; the previous, encapsulated definition. This used to be installed
+ ;; as a global definition for some function name, but it was
+ ;; replaced by an encapsulation of type TYPE.
+ (definition nil :type function))
+
+;;; We must bind and close over info. Consider the case where we
+;;; encapsulate (the second) an encapsulated (the first) definition,
+;;; and later someone unencapsulates the encapsulated (first)
+;;; definition. We don't want our encapsulation (second) to bind
+;;; basic-definition to the encapsulated (first) definition when it no
+;;; longer exists. When unencapsulating, we make sure to clobber the
+;;; appropriate info structure to allow basic-definition to be bound
+;;; to the next definition instead of an encapsulation that no longer
+;;; exists.
+(defun encapsulate (name type body)
+ #!+sb-doc
+ "Replaces the definition of NAME with a function that binds name's arguments
+ a variable named argument-list, binds name's definition to a variable named
+ basic-definition, and evaluates BODY in that context. TYPE is
+ whatever you would like to associate with this encapsulation for
+ identification in case you need multiple encapsuations of the same name."
+ (let ((fdefn (fdefinition-object name nil)))
+ (unless (and fdefn (fdefn-function fdefn))
+ (error 'undefined-function :name name))
+ (let ((info (make-encapsulation-info type (fdefn-function fdefn))))
+ (setf (fdefn-function fdefn)
+ #'(lambda (&rest argument-list)
+ (declare (special argument-list))
+ (let ((basic-definition (encapsulation-info-definition info)))
+ (declare (special basic-definition))
+ (eval body)))))))
+
+;;; Finds the encapsulation info that has been closed over.
+(defun encapsulation-info (fun)
+ (and (functionp fun)
+ (= (get-type fun) sb!vm:closure-header-type)
+ (find-if-in-closure #'encapsulation-info-p fun)))
+
+;;; When removing an encapsulation, we must remember that
+;;; encapsulating definitions close over a reference to the
+;;; encapsulation-info that describes the encapsulating definition.
+;;; When you find an info with the target type, the previous info in
+;;; the chain has the ensulating definition of that type. We take the
+;;; encapsulated definition from the info with the target type, and we
+;;; store it in the previous info structure whose encapsulating
+;;; definition it describes looks to this previous info structure for
+;;; a definition to bind (see ENCAPSULATE). When removing the first
+;;; info structure, we do something conceptually equal, but
+;;; mechanically it is different.
+(defun unencapsulate (name type)
+ #!+sb-doc
+ "Removes NAME's most recent encapsulation of the specified TYPE."
+ (let* ((fdefn (fdefinition-object name nil))
+ (encap-info (encapsulation-info (fdefn-function fdefn))))
+ (declare (type (or encapsulation-info null) encap-info))
+ (cond ((not encap-info)
+ ;; It disappeared on us, so don't worry about it.
+ )
+ ((eq (encapsulation-info-type encap-info) type)
+ ;; It's the first one, so change the fdefn object.
+ (setf (fdefn-function fdefn)
+ (encapsulation-info-definition encap-info)))
+ (t
+ ;; It must be an interior one, so find it.
+ (loop
+ (let ((next-info (encapsulation-info
+ (encapsulation-info-definition encap-info))))
+ (unless next-info
+ ;; Not there, so don't worry about it.
+ (return))
+ (when (eq (encapsulation-info-type next-info) type)
+ ;; This is it, so unlink us.
+ (setf (encapsulation-info-definition encap-info)
+ (encapsulation-info-definition next-info))
+ (return))
+ (setf encap-info next-info))))))
+ t)
+
+(defun encapsulated-p (name type)
+ #!+sb-doc
+ "Returns t if name has an encapsulation of the given type, otherwise nil."
+ (let ((fdefn (fdefinition-object name nil)))
+ (do ((encap-info (encapsulation-info (fdefn-function fdefn))
+ (encapsulation-info
+ (encapsulation-info-definition encap-info))))
+ ((null encap-info) nil)
+ (declare (type (or encapsulation-info null) encap-info))
+ (when (eq (encapsulation-info-type encap-info) type)
+ (return t)))))
+\f
+;;;; FDEFINITION
+
+;;; KLUDGE: Er, it looks as though this means that
+;;; (FUNCALL (FDEFINITION 'FOO))
+;;; doesn't do the same thing as
+;;; (FUNCALL 'FOO).
+;;; That doesn't look like ANSI behavior to me. Look e.g. at the
+;;; ANSI definition of TRACE: "Whenever a traced function is invoked,
+;;; information about the call, ..". Try this:
+;;; (DEFUN FOO () (PRINT "foo"))
+;;; (TRACE FOO)
+;;; (FUNCALL 'FOO)
+;;; (FUNCALL (FDEFINITION 'FOO))
+;;; What to do? ANSI says TRACE "Might change the definitions of the functions
+;;; named by function-names." Might it be OK to just get punt all this
+;;; encapsulation stuff and go back to a simple but correct implementation of
+;;; TRACE? We'd lose the ability to redefine a TRACEd function and keep the
+;;; trace in place, but that seems tolerable to me. (Is the wrapper stuff
+;;; needed for anything else besides TRACE?)
+;;;
+;;; The only problem I can see with not having a wrapper: If tracing
+;;; EQ, EQL, EQUAL, or EQUALP causes its function address to change,
+;;; it will mess up the MAKE-HASH-TABLE logic which uses EQ tests
+;;; on those function values. -- WHN 19990906
+(defun fdefinition (name)
+ #!+sb-doc
+ "Return name's global function definition taking care to respect any
+ encapsulations and to return the innermost encapsulated definition.
+ This is SETF'able."
+ (let ((fun (raw-definition name)))
+ (loop
+ (let ((encap-info (encapsulation-info fun)))
+ (if encap-info
+ (setf fun (encapsulation-info-definition encap-info))
+ (return fun))))))
+
+(defvar *setf-fdefinition-hook* nil
+ #!+sb-doc
+ "This holds functions that (SETF FDEFINITION) invokes before storing the
+ new value. These functions take the function name and the new value.")
+
+(defun %set-fdefinition (name new-value)
+ #!+sb-doc
+ "Set NAME's global function definition."
+ (declare (type function new-value) (optimize (safety 1)))
+ (let ((fdefn (fdefinition-object name t)))
+ ;; *SETF-FDEFINITION-HOOK* won't be bound when initially running top-level
+ ;; forms in the kernel core startup.
+ (when (boundp '*setf-fdefinition-hook*)
+ (dolist (f *setf-fdefinition-hook*)
+ (funcall f name new-value)))
+
+ (let ((encap-info (encapsulation-info (fdefn-function fdefn))))
+ (cond (encap-info
+ (loop
+ (let ((more-info
+ (encapsulation-info
+ (encapsulation-info-definition encap-info))))
+ (if more-info
+ (setf encap-info more-info)
+ (return
+ (setf (encapsulation-info-definition encap-info)
+ new-value))))))
+ (t
+ (setf (fdefn-function fdefn) new-value))))))
+\f
+;;;; FBOUNDP and FMAKUNBOUND
+
+(defun fboundp (name)
+ #!+sb-doc
+ "Return true if name has a global function definition."
+ (let ((fdefn (fdefinition-object name nil)))
+ (and fdefn (fdefn-function fdefn) t)))
+
+(defun fmakunbound (name)
+ #!+sb-doc
+ "Make Name have no global function definition."
+ (let ((fdefn (fdefinition-object name nil)))
+ (when fdefn
+ (fdefn-makunbound fdefn)))
+ name)
--- /dev/null
+;;;; file system interface functions -- fairly Unix-specific
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!IMPL")
+
+(file-comment
+ "$Header$")
+\f
+;;;; Unix pathname host support
+
+;;; Unix namestrings have the following format:
+;;;
+;;; namestring := [ directory ] [ file [ type [ version ]]]
+;;; directory := [ "/" | search-list ] { file "/" }*
+;;; search-list := [^:/]*:
+;;; file := [^/]*
+;;; type := "." [^/.]*
+;;; version := "." ([0-9]+ | "*")
+;;;
+;;; FIXME: Search lists are no longer supported.
+;;;
+;;; Note: this grammar is ambiguous. The string foo.bar.5 can be
+;;; parsed as either just the file specified or as specifying the
+;;; file, type, and version. Therefore, we use the following rules
+;;; when confronted with an ambiguous file.type.version string:
+;;;
+;;; - If the first character is a dot, it's part of the file. It is not
+;;; considered a dot in the following rules.
+;;;
+;;; - If there is only one dot, it separates the file and the type.
+;;;
+;;; - If there are multiple dots and the stuff following the last dot
+;;; is a valid version, then that is the version and the stuff between
+;;; the second to last dot and the last dot is the type.
+;;;
+;;; Wildcard characters:
+;;;
+;;; If the directory, file, type components contain any of the
+;;; following characters, it is considered part of a wildcard pattern
+;;; and has the following meaning.
+;;;
+;;; ? - matches any character
+;;; * - matches any zero or more characters.
+;;; [abc] - matches any of a, b, or c.
+;;; {str1,str2,...,strn} - matches any of str1, str2, ..., or strn.
+;;;
+;;; Any of these special characters can be preceded by a backslash to
+;;; cause it to be treated as a regular character.
+(defun remove-backslashes (namestr start end)
+ #!+sb-doc
+ "Remove any occurrences of #\\ from the string because we've already
+ checked for whatever they may have protected."
+ (declare (type simple-base-string namestr)
+ (type index start end))
+ (let* ((result (make-string (- end start)))
+ (dst 0)
+ (quoted nil))
+ (do ((src start (1+ src)))
+ ((= src end))
+ (cond (quoted
+ (setf (schar result dst) (schar namestr src))
+ (setf quoted nil)
+ (incf dst))
+ (t
+ (let ((char (schar namestr src)))
+ (cond ((char= char #\\)
+ (setq quoted t))
+ (t
+ (setf (schar result dst) char)
+ (incf dst)))))))
+ (when quoted
+ (error 'namestring-parse-error
+ :complaint "backslash in a bad place"
+ :namestring namestr
+ :offset (1- end)))
+ (shrink-vector result dst)))
+
+(defvar *ignore-wildcards* nil)
+
+(/show0 "filesys.lisp 86")
+
+(defun maybe-make-pattern (namestr start end)
+ (declare (type simple-base-string namestr)
+ (type index start end))
+ (if *ignore-wildcards*
+ (subseq namestr start end)
+ (collect ((pattern))
+ (let ((quoted nil)
+ (any-quotes nil)
+ (last-regular-char nil)
+ (index start))
+ (flet ((flush-pending-regulars ()
+ (when last-regular-char
+ (pattern (if any-quotes
+ (remove-backslashes namestr
+ last-regular-char
+ index)
+ (subseq namestr last-regular-char index)))
+ (setf any-quotes nil)
+ (setf last-regular-char nil))))
+ (loop
+ (when (>= index end)
+ (return))
+ (let ((char (schar namestr index)))
+ (cond (quoted
+ (incf index)
+ (setf quoted nil))
+ ((char= char #\\)
+ (setf quoted t)
+ (setf any-quotes t)
+ (unless last-regular-char
+ (setf last-regular-char index))
+ (incf index))
+ ((char= char #\?)
+ (flush-pending-regulars)
+ (pattern :single-char-wild)
+ (incf index))
+ ((char= char #\*)
+ (flush-pending-regulars)
+ (pattern :multi-char-wild)
+ (incf index))
+ ((char= char #\[)
+ (flush-pending-regulars)
+ (let ((close-bracket
+ (position #\] namestr :start index :end end)))
+ (unless close-bracket
+ (error 'namestring-parse-error
+ :complaint "#\\[ with no corresponding #\\]"
+ :namestring namestr
+ :offset index))
+ (pattern (list :character-set
+ (subseq namestr
+ (1+ index)
+ close-bracket)))
+ (setf index (1+ close-bracket))))
+ (t
+ (unless last-regular-char
+ (setf last-regular-char index))
+ (incf index)))))
+ (flush-pending-regulars)))
+ (cond ((null (pattern))
+ "")
+ ((null (cdr (pattern)))
+ (let ((piece (first (pattern))))
+ (typecase piece
+ ((member :multi-char-wild) :wild)
+ (simple-string piece)
+ (t
+ (make-pattern (pattern))))))
+ (t
+ (make-pattern (pattern)))))))
+
+(/show0 "filesys.lisp 160")
+
+(defun extract-name-type-and-version (namestr start end)
+ (declare (type simple-base-string namestr)
+ (type index start end))
+ (let* ((last-dot (position #\. namestr :start (1+ start) :end end
+ :from-end t))
+ (second-to-last-dot (and last-dot
+ (position #\. namestr :start (1+ start)
+ :end last-dot :from-end t)))
+ (version :newest))
+ ;; If there is a second-to-last dot, check to see whether there is a valid
+ ;; version after the last dot.
+ (when second-to-last-dot
+ (cond ((and (= (+ last-dot 2) end)
+ (char= (schar namestr (1+ last-dot)) #\*))
+ (setf version :wild))
+ ((and (< (1+ last-dot) end)
+ (do ((index (1+ last-dot) (1+ index)))
+ ((= index end) t)
+ (unless (char<= #\0 (schar namestr index) #\9)
+ (return nil))))
+ (setf version
+ (parse-integer namestr :start (1+ last-dot) :end end)))
+ (t
+ (setf second-to-last-dot nil))))
+ (cond (second-to-last-dot
+ (values (maybe-make-pattern namestr start second-to-last-dot)
+ (maybe-make-pattern namestr
+ (1+ second-to-last-dot)
+ last-dot)
+ version))
+ (last-dot
+ (values (maybe-make-pattern namestr start last-dot)
+ (maybe-make-pattern namestr (1+ last-dot) end)
+ version))
+ (t
+ (values (maybe-make-pattern namestr start end)
+ nil
+ version)))))
+
+(/show0 "filesys.lisp 200")
+
+;;; Take a string and return a list of cons cells that mark the char
+;;; separated subseq. The first value t if absolute directories location.
+(defun split-at-slashes (namestr start end)
+ (declare (type simple-base-string namestr)
+ (type index start end))
+ (let ((absolute (and (/= start end)
+ (char= (schar namestr start) #\/))))
+ (when absolute
+ (incf start))
+ ;; Next, split the remainder into slash-separated chunks.
+ (collect ((pieces))
+ (loop
+ (let ((slash (position #\/ namestr :start start :end end)))
+ (pieces (cons start (or slash end)))
+ (unless slash
+ (return))
+ (setf start (1+ slash))))
+ (values absolute (pieces)))))
+
+(defun maybe-extract-search-list (namestr start end)
+ (declare (type simple-base-string namestr)
+ (type index start end))
+ (let ((quoted nil))
+ (do ((index start (1+ index)))
+ ((= index end)
+ (values nil start))
+ (if quoted
+ (setf quoted nil)
+ (case (schar namestr index)
+ (#\\
+ (setf quoted t))
+ (#\:
+ (return (values (remove-backslashes namestr start index)
+ (1+ index)))))))))
+
+(defun parse-unix-namestring (namestr start end)
+ (declare (type simple-base-string namestr)
+ (type index start end))
+ (multiple-value-bind (absolute pieces) (split-at-slashes namestr start end)
+ (let ((search-list (if absolute
+ nil
+ (let ((first (car pieces)))
+ (multiple-value-bind (search-list new-start)
+ (maybe-extract-search-list namestr
+ (car first)
+ (cdr first))
+ (when search-list
+ (setf absolute t)
+ (setf (car first) new-start))
+ search-list)))))
+ (multiple-value-bind (name type version)
+ (let* ((tail (car (last pieces)))
+ (tail-start (car tail))
+ (tail-end (cdr tail)))
+ (unless (= tail-start tail-end)
+ (setf pieces (butlast pieces))
+ (extract-name-type-and-version namestr tail-start tail-end)))
+ ;; PVE: make sure there are no illegal characters in
+ ;; the name, illegal being (code-char 0) and #\/
+ #!+high-security
+ (when (and (stringp name)
+ (find-if #'(lambda (x) (or (char= x (code-char 0))
+ (char= x #\/)))
+ name))
+ (error 'parse-error))
+
+ ;; Now we have everything we want. So return it.
+ (values nil ; no host for unix namestrings.
+ nil ; no devices for unix namestrings.
+ (collect ((dirs))
+ (when search-list
+ (dirs (intern-search-list search-list)))
+ (dolist (piece pieces)
+ (let ((piece-start (car piece))
+ (piece-end (cdr piece)))
+ (unless (= piece-start piece-end)
+ (cond ((string= namestr ".." :start1 piece-start
+ :end1 piece-end)
+ (dirs :up))
+ ((string= namestr "**" :start1 piece-start
+ :end1 piece-end)
+ (dirs :wild-inferiors))
+ (t
+ (dirs (maybe-make-pattern namestr
+ piece-start
+ piece-end)))))))
+ (cond (absolute
+ (cons :absolute (dirs)))
+ ((dirs)
+ (cons :relative (dirs)))
+ (t
+ nil)))
+ name
+ type
+ version)))))
+
+(/show0 "filesys.lisp 300")
+
+(defun unparse-unix-host (pathname)
+ (declare (type pathname pathname)
+ (ignore pathname))
+ "Unix")
+
+(defun unparse-unix-piece (thing)
+ (etypecase thing
+ ((member :wild) "*")
+ (simple-string
+ (let* ((srclen (length thing))
+ (dstlen srclen))
+ (dotimes (i srclen)
+ (case (schar thing i)
+ ((#\* #\? #\[)
+ (incf dstlen))))
+ (let ((result (make-string dstlen))
+ (dst 0))
+ (dotimes (src srclen)
+ (let ((char (schar thing src)))
+ (case char
+ ((#\* #\? #\[)
+ (setf (schar result dst) #\\)
+ (incf dst)))
+ (setf (schar result dst) char)
+ (incf dst)))
+ result)))
+ (pattern
+ (collect ((strings))
+ (dolist (piece (pattern-pieces thing))
+ (etypecase piece
+ (simple-string
+ (strings piece))
+ (symbol
+ (ecase piece
+ (:multi-char-wild
+ (strings "*"))
+ (:single-char-wild
+ (strings "?"))))
+ (cons
+ (case (car piece)
+ (:character-set
+ (strings "[")
+ (strings (cdr piece))
+ (strings "]"))
+ (t
+ (error "invalid pattern piece: ~S" piece))))))
+ (apply #'concatenate
+ 'simple-string
+ (strings))))))
+
+(defun unparse-unix-directory-list (directory)
+ (declare (type list directory))
+ (collect ((pieces))
+ (when directory
+ (ecase (pop directory)
+ (:absolute
+ (cond ((search-list-p (car directory))
+ (pieces (search-list-name (pop directory)))
+ (pieces ":"))
+ (t
+ (pieces "/"))))
+ (:relative
+ ;; Nothing special.
+ ))
+ (dolist (dir directory)
+ (typecase dir
+ ((member :up)
+ (pieces "../"))
+ ((member :back)
+ (error ":BACK cannot be represented in namestrings."))
+ ((member :wild-inferiors)
+ (pieces "**/"))
+ ((or simple-string pattern)
+ (pieces (unparse-unix-piece dir))
+ (pieces "/"))
+ (t
+ (error "invalid directory component: ~S" dir)))))
+ (apply #'concatenate 'simple-string (pieces))))
+
+(defun unparse-unix-directory (pathname)
+ (declare (type pathname pathname))
+ (unparse-unix-directory-list (%pathname-directory pathname)))
+
+(defun unparse-unix-file (pathname)
+ (declare (type pathname pathname))
+ (collect ((strings))
+ (let* ((name (%pathname-name pathname))
+ (type (%pathname-type pathname))
+ (type-supplied (not (or (null type) (eq type :unspecific))))
+ (version (%pathname-version pathname))
+ (version-supplied (not (or (null version) (eq version :newest)))))
+ (when name
+ (strings (unparse-unix-piece name)))
+ (when type-supplied
+ (unless name
+ (error "cannot specify the type without a file: ~S" pathname))
+ (strings ".")
+ (strings (unparse-unix-piece type)))
+ (when version-supplied
+ (unless type-supplied
+ (error "cannot specify the version without a type: ~S" pathname))
+ (strings (if (eq version :wild)
+ ".*"
+ (format nil ".~D" version)))))
+ (apply #'concatenate 'simple-string (strings))))
+
+(/show0 "filesys.lisp 406")
+
+(defun unparse-unix-namestring (pathname)
+ (declare (type pathname pathname))
+ (concatenate 'simple-string
+ (unparse-unix-directory pathname)
+ (unparse-unix-file pathname)))
+
+(defun unparse-unix-enough (pathname defaults)
+ (declare (type pathname pathname defaults))
+ (flet ((lose ()
+ (error "~S cannot be represented relative to ~S."
+ pathname defaults)))
+ (collect ((strings))
+ (let* ((pathname-directory (%pathname-directory pathname))
+ (defaults-directory (%pathname-directory defaults))
+ (prefix-len (length defaults-directory))
+ (result-dir
+ (cond ((and (> prefix-len 1)
+ (>= (length pathname-directory) prefix-len)
+ (compare-component (subseq pathname-directory
+ 0 prefix-len)
+ defaults-directory))
+ ;; Pathname starts with a prefix of default. So
+ ;; just use a relative directory from then on out.
+ (cons :relative (nthcdr prefix-len pathname-directory)))
+ ((eq (car pathname-directory) :absolute)
+ ;; We are an absolute pathname, so we can just use it.
+ pathname-directory)
+ (t
+ ;; We are a relative directory. So we lose.
+ (lose)))))
+ (strings (unparse-unix-directory-list result-dir)))
+ (let* ((pathname-version (%pathname-version pathname))
+ (version-needed (and pathname-version
+ (not (eq pathname-version :newest))))
+ (pathname-type (%pathname-type pathname))
+ (type-needed (or version-needed
+ (and pathname-type
+ (not (eq pathname-type :unspecific)))))
+ (pathname-name (%pathname-name pathname))
+ (name-needed (or type-needed
+ (and pathname-name
+ (not (compare-component pathname-name
+ (%pathname-name
+ defaults)))))))
+ (when name-needed
+ (unless pathname-name (lose))
+ (strings (unparse-unix-piece pathname-name)))
+ (when type-needed
+ (when (or (null pathname-type) (eq pathname-type :unspecific))
+ (lose))
+ (strings ".")
+ (strings (unparse-unix-piece pathname-type)))
+ (when version-needed
+ (typecase pathname-version
+ ((member :wild)
+ (strings ".*"))
+ (integer
+ (strings (format nil ".~D" pathname-version)))
+ (t
+ (lose)))))
+ (apply #'concatenate 'simple-string (strings)))))
+
+(/show0 "filesys.lisp 471")
+
+(def!struct (unix-host
+ (:make-load-form-fun make-unix-host-load-form)
+ (:include host
+ (parse #'parse-unix-namestring)
+ (unparse #'unparse-unix-namestring)
+ (unparse-host #'unparse-unix-host)
+ (unparse-directory #'unparse-unix-directory)
+ (unparse-file #'unparse-unix-file)
+ (unparse-enough #'unparse-unix-enough)
+ (customary-case :lower))))
+
+(/show0 "filesys.lisp 486")
+
+(defvar *unix-host* (make-unix-host))
+
+(/show0 "filesys.lisp 488")
+
+(defun make-unix-host-load-form (host)
+ (declare (ignore host))
+ '*unix-host*)
+\f
+;;;; wildcard matching stuff
+
+(/show0 "filesys.lisp 498")
+
+;;; FIXME: could maybe be EVAL-WHEN (COMPILE EVAL)
+(defmacro enumerate-matches ((var pathname &optional result
+ &key (verify-existence t))
+ &body body)
+ (let ((body-name (gensym)))
+ `(block nil
+ (flet ((,body-name (,var)
+ ,@body))
+ (%enumerate-matches (pathname ,pathname)
+ ,verify-existence
+ #',body-name)
+ ,result))))
+
+(/show0 "filesys.lisp 500")
+
+(defun %enumerate-matches (pathname verify-existence function)
+ (/show0 "entering %ENUMERATE-MATCHES")
+ (when (pathname-type pathname)
+ (unless (pathname-name pathname)
+ (error "cannot supply a type without a name:~% ~S" pathname)))
+ (when (and (integerp (pathname-version pathname))
+ (member (pathname-type pathname) '(nil :unspecific)))
+ (error "cannot supply a version without a type:~% ~S" pathname))
+ (let ((directory (pathname-directory pathname)))
+ (/show0 "computed DIRECTORY")
+ (if directory
+ (ecase (car directory)
+ (:absolute
+ (/show0 "absolute directory")
+ (%enumerate-directories "/" (cdr directory) pathname
+ verify-existence function))
+ (:relative
+ (/show0 "relative directory")
+ (%enumerate-directories "" (cdr directory) pathname
+ verify-existence function)))
+ (%enumerate-files "" pathname verify-existence function))))
+
+(defun %enumerate-directories (head tail pathname verify-existence function)
+ (declare (simple-string head))
+ (if tail
+ (let ((piece (car tail)))
+ (etypecase piece
+ (simple-string
+ (%enumerate-directories (concatenate 'string head piece "/")
+ (cdr tail) pathname verify-existence
+ function))
+ ((or pattern (member :wild :wild-inferiors))
+ (let ((dir (sb!unix:open-dir head)))
+ (when dir
+ (unwind-protect
+ (loop
+ (let ((name (sb!unix:read-dir dir)))
+ (cond ((null name)
+ (return))
+ ((string= name "."))
+ ((string= name ".."))
+ ((pattern-matches piece name)
+ (let ((subdir (concatenate 'string
+ head name "/")))
+ (when (eq (sb!unix:unix-file-kind subdir)
+ :directory)
+ (%enumerate-directories
+ subdir (cdr tail) pathname verify-existence
+ function)))))))
+ (sb!unix:close-dir dir)))))
+ ((member :up)
+ (%enumerate-directories (concatenate 'string head "../")
+ (cdr tail) pathname verify-existence
+ function))))
+ (%enumerate-files head pathname verify-existence function)))
+
+;;; REMOVEME after finding bug.
+#!+sb-show (defvar *show-directory*)
+#!+sb-show (defvar *show-name*)
+
+(defun %enumerate-files (directory pathname verify-existence function)
+ (declare (simple-string directory))
+ (/show0 "entering %ENUMERATE-FILES")
+ (let ((name (%pathname-name pathname))
+ (type (%pathname-type pathname))
+ (version (%pathname-version pathname)))
+ (/show0 "computed NAME, TYPE, and VERSION")
+ (cond ((member name '(nil :unspecific))
+ (/show0 "UNSPECIFIC, more or less")
+ (when (or (not verify-existence)
+ (sb!unix:unix-file-kind directory))
+ (funcall function directory)))
+ ((or (pattern-p name)
+ (pattern-p type)
+ (eq name :wild)
+ (eq type :wild))
+ (/show0 "WILD, more or less")
+ (let ((dir (sb!unix:open-dir directory)))
+ (when dir
+ (unwind-protect
+ (loop
+ (/show0 "at head of LOOP")
+ (let ((file (sb!unix:read-dir dir)))
+ (if file
+ (unless (or (string= file ".")
+ (string= file ".."))
+ (multiple-value-bind
+ (file-name file-type file-version)
+ (let ((*ignore-wildcards* t))
+ (extract-name-type-and-version
+ file 0 (length file)))
+ (when (and (components-match file-name name)
+ (components-match file-type type)
+ (components-match file-version
+ version))
+ (funcall function
+ (concatenate 'string
+ directory
+ file)))))
+ (return))))
+ (sb!unix:close-dir dir)))))
+ (t
+ (/show0 "default case")
+
+ ;; Put DIRECTORY and NAME somewhere we can find them even when
+ ;; things are too screwed up for the debugger.
+ #!+sb-show (progn
+ (setf *show-directory* directory
+ *show-name* name))
+
+ (let ((file (concatenate 'string directory name)))
+ (/show0 "computed basic FILE=..")
+ #!+sb-show (%primitive print file)
+ (unless (or (null type) (eq type :unspecific))
+ (/show0 "tweaking FILE for more-or-less-:UNSPECIFIC case")
+ (setf file (concatenate 'string file "." type)))
+ (unless (member version '(nil :newest :wild))
+ (/show0 "tweaking FILE for more-or-less-:WILD case")
+ (setf file (concatenate 'string file "."
+ (quick-integer-to-string version))))
+ (/show0 "finished possibly tweaking FILE=..")
+ #!+sb-show (%primitive print file)
+ (when (or (not verify-existence)
+ (sb!unix:unix-file-kind file t))
+ (/show0 "calling FUNCTION on FILE")
+ (funcall function file)))))))
+
+(/show0 "filesys.lisp 603")
+
+;;; FIXME: Why do we need this?
+(defun quick-integer-to-string (n)
+ (declare (type integer n))
+ (cond ((not (fixnump n))
+ (write-to-string n :base 10 :radix nil))
+ ((zerop n) "0")
+ ((eql n 1) "1")
+ ((minusp n)
+ (concatenate 'simple-string "-"
+ (the simple-string (quick-integer-to-string (- n)))))
+ (t
+ (do* ((len (1+ (truncate (integer-length n) 3)))
+ (res (make-string len))
+ (i (1- len) (1- i))
+ (q n)
+ (r 0))
+ ((zerop q)
+ (incf i)
+ (replace res res :start2 i :end2 len)
+ (shrink-vector res (- len i)))
+ (declare (simple-string res)
+ (fixnum len i r q))
+ (multiple-value-setq (q r) (truncate q 10))
+ (setf (schar res i) (schar "0123456789" r))))))
+\f
+;;;; UNIX-NAMESTRING
+
+(defun unix-namestring (pathname &optional (for-input t) executable-only)
+ #!+sb-doc
+ "Convert PATHNAME into a string that can be used with UNIX system calls.
+ Search-lists and wild-cards are expanded."
+ ;; toy@rtp.ericsson.se: Let unix-namestring also handle logical
+ ;; pathnames too.
+ ;; FIXME: What does this ^ mean? A bug? A remark on a change already made?
+ (/show0 "entering UNIX-NAMESTRING")
+ (let ((path (let ((lpn (pathname pathname)))
+ (if (typep lpn 'logical-pathname)
+ (namestring (translate-logical-pathname lpn))
+ pathname))))
+ (/show0 "PATH computed, enumerating search list")
+ (enumerate-search-list
+ (pathname path)
+ (collect ((names))
+ (/show0 "collecting NAMES")
+ (enumerate-matches (name pathname nil :verify-existence for-input)
+ (when (or (not executable-only)
+ (and (eq (sb!unix:unix-file-kind name)
+ :file)
+ (sb!unix:unix-access name
+ sb!unix:x_ok)))
+ (names name)))
+ (/show0 "NAMES collected")
+ (let ((names (names)))
+ (when names
+ (/show0 "NAMES is true.")
+ (when (cdr names)
+ (/show0 "Alas! CDR NAMES")
+ (error 'simple-file-error
+ :format-control "~S is ambiguous:~{~% ~A~}"
+ :format-arguments (list pathname names)))
+ (/show0 "returning from UNIX-NAMESTRING")
+ (return (car names))))))))
+\f
+;;;; TRUENAME and PROBE-FILE
+
+;;; Another silly file function trivially different from another function.
+(defun truename (pathname)
+ #!+sb-doc
+ "Return the pathname for the actual file described by the pathname
+ An error of type file-error is signalled if no such file exists,
+ or the pathname is wild."
+ (if (wild-pathname-p pathname)
+ (error 'simple-file-error
+ :format-control "bad place for a wild pathname"
+ :pathname pathname)
+ (let ((result (probe-file pathname)))
+ (unless result
+ (error 'simple-file-error
+ :pathname pathname
+ :format-control "The file ~S does not exist."
+ :format-arguments (list (namestring pathname))))
+ result)))
+
+;;; If PATHNAME exists, return its truename, otherwise NIL.
+(defun probe-file (pathname)
+ #!+sb-doc
+ "Return a pathname which is the truename of the file if it exists, NIL
+ otherwise. An error of type file-error is signaled if pathname is wild."
+ (/show0 "entering PROBE-FILE")
+ (if (wild-pathname-p pathname)
+ (error 'simple-file-error
+ :pathname pathname
+ :format-control "bad place for a wild pathname")
+ (let ((namestring (unix-namestring pathname t)))
+ (/show0 "NAMESTRING computed")
+ (when (and namestring (sb!unix:unix-file-kind namestring))
+ (/show0 "NAMESTRING is promising.")
+ (let ((truename (sb!unix:unix-resolve-links
+ (sb!unix:unix-maybe-prepend-current-directory
+ namestring))))
+ (/show0 "TRUENAME computed")
+ (when truename
+ (/show0 "TRUENAME is true.")
+ (let ((*ignore-wildcards* t))
+ (pathname (sb!unix:unix-simplify-pathname truename)))))))))
+\f
+;;;; miscellaneous other operations
+
+(/show0 "filesys.lisp 700")
+
+(defun rename-file (file new-name)
+ #!+sb-doc
+ "Rename File to have the specified New-Name. If file is a stream open to a
+ file, then the associated file is renamed."
+ (let* ((original (truename file))
+ (original-namestring (unix-namestring original t))
+ (new-name (merge-pathnames new-name original))
+ (new-namestring (unix-namestring new-name nil)))
+ (unless new-namestring
+ (error 'simple-file-error
+ :pathname new-name
+ :format-control "~S can't be created."
+ :format-arguments (list new-name)))
+ (multiple-value-bind (res error)
+ (sb!unix:unix-rename original-namestring new-namestring)
+ (unless res
+ (error 'simple-file-error
+ :pathname new-name
+ :format-control "failed to rename ~A to ~A: ~A"
+ :format-arguments (list original new-name
+ (sb!unix:get-unix-error-msg error))))
+ (when (streamp file)
+ (file-name file new-namestring))
+ (values new-name original (truename new-name)))))
+
+(defun delete-file (file)
+ #!+sb-doc
+ "Delete the specified file."
+ (let ((namestring (unix-namestring file t)))
+ (when (streamp file)
+ (close file :abort t))
+ (unless namestring
+ (error 'simple-file-error
+ :pathname file
+ :format-control "~S doesn't exist."
+ :format-arguments (list file)))
+
+ (multiple-value-bind (res err) (sb!unix:unix-unlink namestring)
+ (unless res
+ (error 'simple-file-error
+ :pathname namestring
+ :format-control "could not delete ~A: ~A"
+ :format-arguments (list namestring
+ (sb!unix:get-unix-error-msg err))))))
+ t)
+\f
+;;; Return Home:, which is set up for us at initialization time.
+(defun user-homedir-pathname (&optional host)
+ #!+sb-doc
+ "Returns the home directory of the logged in user as a pathname.
+ This is obtained from the logical name \"home:\"."
+ (declare (ignore host))
+ ;; Note: CMU CL did #P"home:" here instead of using a call to
+ ;; PATHNAME. Delaying construction of the pathname until we're
+ ;; running in a target Lisp lets us avoid figuring out how to dump
+ ;; cross-compilation host Lisp PATHNAME objects into a target Lisp
+ ;; object file. It also might have a small positive effect on
+ ;; efficiency, in that we don't allocate a PATHNAME we don't need,
+ ;; but it it could also have a larger negative effect. Hopefully
+ ;; it'll be OK. -- WHN 19990714
+ (pathname "home:"))
+
+(defun file-write-date (file)
+ #!+sb-doc
+ "Return file's creation date, or NIL if it doesn't exist.
+ An error of type file-error is signaled if file is a wild pathname"
+ (if (wild-pathname-p file)
+ ;; FIXME: This idiom appears many times in this file. Perhaps it
+ ;; should turn into (CANNOT-BE-WILD-PATHNAME FILE). (C-B-W-P
+ ;; should be a macro, not a function, so that the error message
+ ;; is reported as coming from e.g. FILE-WRITE-DATE instead of
+ ;; from CANNOT-BE-WILD-PATHNAME itself.)
+ (error 'simple-file-error
+ :pathname file
+ :format-control "bad place for a wild pathname")
+ (let ((name (unix-namestring file t)))
+ (when name
+ (multiple-value-bind
+ (res dev ino mode nlink uid gid rdev size atime mtime)
+ (sb!unix:unix-stat name)
+ (declare (ignore dev ino mode nlink uid gid rdev size atime))
+ (when res
+ (+ unix-to-universal-time mtime)))))))
+
+(defun file-author (file)
+ #!+sb-doc
+ "Returns the file author as a string, or nil if the author cannot be
+ determined. Signals an error of type file-error if file doesn't exist,
+ or file is a wild pathname."
+ (if (wild-pathname-p file)
+ (error 'simple-file-error
+ :pathname file
+ "bad place for a wild pathname")
+ (let ((name (unix-namestring (pathname file) t)))
+ (unless name
+ (error 'simple-file-error
+ :pathname file
+ :format-control "~S doesn't exist."
+ :format-arguments (list file)))
+ (multiple-value-bind (winp dev ino mode nlink uid)
+ (sb!unix:unix-stat name)
+ (declare (ignore dev ino mode nlink))
+ (if winp (lookup-login-name uid))))))
+\f
+;;;; DIRECTORY
+
+(/show0 "filesys.lisp 800")
+
+(defun directory (pathname &key (all t) (check-for-subdirs t)
+ (follow-links t))
+ #!+sb-doc
+ "Returns a list of pathnames, one for each file that matches the given
+ pathname. Supplying :ALL as nil causes this to ignore Unix dot files. This
+ never includes Unix dot and dot-dot in the result. If :FOLLOW-LINKS is NIL,
+ then symblolic links in the result are not expanded. This is not the
+ default because TRUENAME does follow links, and the result pathnames are
+ defined to be the TRUENAME of the pathname (the truename of a link may well
+ be in another directory.)"
+ (let ((results nil))
+ (enumerate-search-list
+ (pathname (merge-pathnames pathname
+ (make-pathname :name :wild
+ :type :wild
+ :version :wild)))
+ (enumerate-matches (name pathname)
+ (when (or all
+ (let ((slash (position #\/ name :from-end t)))
+ (or (null slash)
+ (= (1+ slash) (length name))
+ (char/= (schar name (1+ slash)) #\.))))
+ (push name results))))
+ (let ((*ignore-wildcards* t))
+ (mapcar #'(lambda (name)
+ (let ((name (if (and check-for-subdirs
+ (eq (sb!unix:unix-file-kind name)
+ :directory))
+ (concatenate 'string name "/")
+ name)))
+ (if follow-links (truename name) (pathname name))))
+ (sort (delete-duplicates results :test #'string=) #'string<)))))
+\f
+;;;; translating Unix uid's
+;;;;
+;;;; FIXME: should probably move into unix.lisp
+
+(defvar *uid-hash-table* (make-hash-table)
+ #!+sb-doc
+ "hash table for keeping track of uid's and login names")
+
+(/show0 "filesys.lisp 844")
+
+;;; LOOKUP-LOGIN-NAME translates a user id into a login name. Previous
+;;; lookups are cached in a hash table since groveling the passwd(s)
+;;; files is somewhat expensive. The table may hold NIL for id's that
+;;; cannot be looked up since this keeps the files from having to be
+;;; searched in their entirety each time this id is translated.
+(defun lookup-login-name (uid)
+ (multiple-value-bind (login-name foundp) (gethash uid *uid-hash-table*)
+ (if foundp
+ login-name
+ (setf (gethash uid *uid-hash-table*)
+ (get-group-or-user-name :user uid)))))
+
+;;; GET-GROUP-OR-USER-NAME first tries "/etc/passwd" ("/etc/group")
+;;; since it is a much smaller file, contains all the local id's, and
+;;; most uses probably involve id's on machines one would login into.
+;;; Then if necessary, we look in "/etc/passwds" ("/etc/groups") which
+;;; is really long and has to be fetched over the net.
+;;;
+;;; FIXME: Now that we no longer have lookup-group-name, we no longer need
+;;; the GROUP-OR-USER argument.
+(defun get-group-or-user-name (group-or-user id)
+ #!+sb-doc
+ "Returns the simple-string user or group name of the user whose uid or gid
+ is id, or NIL if no such user or group exists. Group-or-user is either
+ :group or :user."
+ (let ((id-string (let ((*print-base* 10)) (prin1-to-string id))))
+ (declare (simple-string id-string))
+ (multiple-value-bind (file1 file2)
+ (ecase group-or-user
+ (:group (values "/etc/group" "/etc/groups"))
+ (:user (values "/etc/passwd" "/etc/passwd")))
+ (or (get-group-or-user-name-aux id-string file1)
+ (get-group-or-user-name-aux id-string file2)))))
+
+;;; FIXME: Isn't there now a POSIX routine to parse the passwd file?
+;;; getpwent? getpwuid?
+(defun get-group-or-user-name-aux (id-string passwd-file)
+ (with-open-file (stream passwd-file)
+ (loop
+ (let ((entry (read-line stream nil)))
+ (unless entry (return nil))
+ (let ((name-end (position #\: (the simple-string entry)
+ :test #'char=)))
+ (when name-end
+ (let ((id-start (position #\: (the simple-string entry)
+ :start (1+ name-end) :test #'char=)))
+ (when id-start
+ (incf id-start)
+ (let ((id-end (position #\: (the simple-string entry)
+ :start id-start :test #'char=)))
+ (when (and id-end
+ (string= id-string entry
+ :start2 id-start :end2 id-end))
+ (return (subseq entry 0 name-end))))))))))))
+\f
+(/show0 "filesys.lisp 899")
+
+;;; Predicate to order pathnames by. Goes by name.
+(defun pathname-order (x y)
+ (let ((xn (%pathname-name x))
+ (yn (%pathname-name y)))
+ (if (and xn yn)
+ (let ((res (string-lessp xn yn)))
+ (cond ((not res) nil)
+ ((= res (length (the simple-string xn))) t)
+ ((= res (length (the simple-string yn))) nil)
+ (t t)))
+ xn)))
+\f
+(defun default-directory ()
+ #!+sb-doc
+ "Returns the pathname for the default directory. This is the place where
+ a file will be written if no directory is specified. This may be changed
+ with setf."
+ (multiple-value-bind (gr dir-or-error) (sb!unix:unix-current-directory)
+ (if gr
+ (let ((*ignore-wildcards* t))
+ (pathname (concatenate 'simple-string dir-or-error "/")))
+ (error dir-or-error))))
+
+(defun %set-default-directory (new-val)
+ (let ((namestring (unix-namestring new-val t)))
+ (unless namestring
+ (error "~S doesn't exist." new-val))
+ (multiple-value-bind (gr error) (sb!unix:unix-chdir namestring)
+ (if gr
+ (setf (search-list "default:") (default-directory))
+ (error (sb!unix:get-unix-error-msg error))))
+ new-val))
+
+(/show0 "filesys.lisp 934")
+
+(defun !filesys-cold-init ()
+ (/show0 "entering !FILESYS-COLD-INIT")
+ (setf *default-pathname-defaults*
+ (%make-pathname *unix-host* nil nil nil nil :newest))
+ (setf (search-list "default:") (default-directory))
+ (/show0 "leaving !FILESYS-COLD-INIT")
+ nil)
+\f
+(defun ensure-directories-exist (pathspec &key verbose (mode #o777))
+ #!+sb-doc
+ "Tests whether the directories containing the specified file
+ actually exist, and attempts to create them if they do not.
+ Portable programs should avoid using the :MODE keyword argument."
+ (let* ((pathname (pathname pathspec))
+ (pathname (if (typep pathname 'logical-pathname)
+ (translate-logical-pathname pathname)
+ pathname))
+ (created-p nil))
+ (when (wild-pathname-p pathname)
+ (error 'simple-file-error
+ :format-control "bad place for a wild pathname"
+ :pathname pathspec))
+ (enumerate-search-list (pathname pathname)
+ (let ((dir (pathname-directory pathname)))
+ (loop for i from 1 upto (length dir)
+ do (let ((newpath (make-pathname
+ :host (pathname-host pathname)
+ :device (pathname-device pathname)
+ :directory (subseq dir 0 i))))
+ (unless (probe-file newpath)
+ (let ((namestring (namestring newpath)))
+ (when verbose
+ (format *standard-output*
+ "~&creating directory: ~A~%"
+ namestring))
+ (sb!unix:unix-mkdir namestring mode)
+ (unless (probe-file namestring)
+ (error 'simple-file-error
+ :pathname pathspec
+ :format-control "can't create directory ~A"
+ :format-arguments (list namestring)))
+ (setf created-p t)))))
+ ;; Only the first path in a search-list is considered.
+ (return (values pathname created-p))))))
+
+(/show0 "filesys.lisp 1000")
--- /dev/null
+;;;; finalization based on weak pointers
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!EXT")
+
+(file-comment
+ "$Header$")
+
+(defvar *objects-pending-finalization* nil)
+
+(defun finalize (object function)
+ #!+sb-doc
+ "Arrange for FUNCTION to be called when there are no more references to
+ OBJECT."
+ (declare (type function function))
+ (sb!sys:without-gcing
+ (push (cons (make-weak-pointer object) function)
+ *objects-pending-finalization*))
+ object)
+
+(defun cancel-finalization (object)
+ #!+sb-doc
+ "Cancel any finalization registers for OBJECT."
+ (when object
+ ;; We check to make sure object isn't nil because if there are any
+ ;; broken weak pointers, their value will show up as nil. Therefore,
+ ;; they would be deleted from the list, but not finalized. Broken
+ ;; weak pointers shouldn't be left in the list, but why take chances?
+ (sb!sys:without-gcing
+ (setf *objects-pending-finalization*
+ (delete object *objects-pending-finalization*
+ :key #'(lambda (pair)
+ (values (weak-pointer-value (car pair))))))))
+ nil)
+
+(defun finalize-corpses ()
+ (setf *objects-pending-finalization*
+ (delete-if #'(lambda (pair)
+ (multiple-value-bind (object valid)
+ (weak-pointer-value (car pair))
+ (declare (ignore object))
+ (unless valid
+ (funcall (cdr pair))
+ t)))
+ *objects-pending-finalization*))
+ nil)
+
+(pushnew 'finalize-corpses *after-gc-hooks*)
--- /dev/null
+;;;; This file contains stuff for controlling floating point traps. It
+;;;; is IEEE float specific, but should work for pretty much any FPU
+;;;; where the state fits in one word and exceptions are represented
+;;;; by bits being set.
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!VM")
+
+(file-comment
+ "$Header$")
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+
+(defconstant float-trap-alist
+ (list (cons :underflow float-underflow-trap-bit)
+ (cons :overflow float-overflow-trap-bit)
+ (cons :inexact float-inexact-trap-bit)
+ (cons :invalid float-invalid-trap-bit)
+ (cons :divide-by-zero float-divide-by-zero-trap-bit)
+ #!+x86 (cons :denormalized-operand float-denormal-trap-bit)))
+
+;;; Return a mask with all the specified float trap bits set.
+(defun float-trap-mask (names)
+ (reduce #'logior
+ (mapcar #'(lambda (x)
+ (or (cdr (assoc x float-trap-alist))
+ (error "Unknown float trap kind: ~S." x)))
+ names)))
+
+(defconstant rounding-mode-alist
+ (list (cons :nearest float-round-to-nearest)
+ (cons :zero float-round-to-zero)
+ (cons :positive-infinity float-round-to-positive)
+ (cons :negative-infinity float-round-to-negative)))
+
+); Eval-When (Compile Load Eval)
+
+;;; interpreter stubs
+(defun floating-point-modes () (floating-point-modes))
+(defun (setf floating-point-modes) (new) (setf (floating-point-modes) new))
+
+(defun set-floating-point-modes (&key (traps nil traps-p)
+ (rounding-mode nil round-p)
+ (current-exceptions nil current-x-p)
+ (accrued-exceptions nil accrued-x-p)
+ (fast-mode nil fast-mode-p))
+ #!+sb-doc
+ "This function sets options controlling the floating-point hardware. If a
+ keyword is not supplied, then the current value is preserved. Possible
+ keywords:
+
+ :TRAPS
+ A list of the exception conditions that should cause traps. Possible
+ exceptions are :UNDERFLOW, :OVERFLOW, :INEXACT, :INVALID,
+ :DIVIDE-BY-ZERO, and on the X86 :DENORMALIZED-OPERAND. Initially
+ all traps except :INEXACT are enabled.
+
+ :ROUNDING-MODE
+ The rounding mode to use when the result is not exact. Possible values
+ are :NEAREST, :POSITIVE-INFINITY, :NEGATIVE-INFINITY and :ZERO.
+ Initially, the rounding mode is :NEAREST.
+
+ :CURRENT-EXCEPTIONS
+ :ACCRUED-EXCEPTIONS
+ These arguments allow setting of the exception flags. The main use is
+ setting the accrued exceptions to NIL to clear them.
+
+ :FAST-MODE
+ Set the hardware's \"fast mode\" flag, if any. When set, IEEE
+ conformance or debuggability may be impaired. Some machines may not
+ have this feature, in which case the value is always NIL.
+
+ GET-FLOATING-POINT-MODES may be used to find the floating point modes
+ currently in effect."
+ (let ((modes (floating-point-modes)))
+ (when traps-p
+ (setf (ldb float-traps-byte modes) (float-trap-mask traps)))
+ (when round-p
+ (setf (ldb float-rounding-mode modes)
+ (or (cdr (assoc rounding-mode rounding-mode-alist))
+ (error "Unknown rounding mode: ~S." rounding-mode))))
+ (when current-x-p
+ (setf (ldb float-exceptions-byte modes)
+ (float-trap-mask current-exceptions)))
+ (when accrued-x-p
+ (setf (ldb float-sticky-bits modes)
+ (float-trap-mask accrued-exceptions)))
+ (when fast-mode-p
+ (if fast-mode
+ (setq modes (logior float-fast-bit modes))
+ (setq modes (logand (lognot float-fast-bit) modes))))
+ (setf (floating-point-modes) modes))
+
+ (values))
+
+(defun get-floating-point-modes ()
+ #!+sb-doc
+ "This function returns a list representing the state of the floating point
+ modes. The list is in the same format as the keyword arguments to
+ SET-FLOATING-POINT-MODES, i.e.
+ (apply #'set-floating-point-modes (get-floating-point-modes))
+
+ sets the floating point modes to their current values (and thus is a no-op)."
+ (flet ((exc-keys (bits)
+ (macrolet ((frob ()
+ `(collect ((res))
+ ,@(mapcar #'(lambda (x)
+ `(when (logtest bits ,(cdr x))
+ (res ',(car x))))
+ float-trap-alist)
+ (res))))
+ (frob))))
+ (let ((modes (floating-point-modes)))
+ `(:traps ,(exc-keys (ldb float-traps-byte modes))
+ :rounding-mode ,(car (rassoc (ldb float-rounding-mode modes)
+ rounding-mode-alist))
+ :current-exceptions ,(exc-keys (ldb float-exceptions-byte modes))
+ :accrued-exceptions ,(exc-keys (ldb float-sticky-bits modes))
+ :fast-mode ,(logtest float-fast-bit modes)))))
+
+(defmacro current-float-trap (&rest traps)
+ #!+sb-doc
+ "Current-Float-Trap Trap-Name*
+ Return true if any of the named traps are currently trapped, false
+ otherwise."
+ `(not (zerop (logand ,(dpb (float-trap-mask traps) float-traps-byte 0)
+ (floating-point-modes)))))
+
+;;; Signal the appropriate condition when we get a floating-point error.
+(defun sigfpe-handler (signal info context)
+ (declare (ignore signal info))
+ (declare (type system-area-pointer context))
+ ;; FIXME: The find-the-detailed-problem code below went stale with
+ ;; the big switchover to POSIX signal handling and signal contexts
+ ;; which are opaque at the Lisp level ca plod-0.6.7. It needs to be
+ ;; revived, which will require writing a C-level os-dependent
+ ;; function to extract floating point modes, and a Lisp-level
+ ;; DEF-ALIEN-ROUTINE to get to the C-level os-dependent function.
+ ;; Meanwhile we just say "something went wrong".
+ (error 'floating-point-exception)
+ #|
+ (let* ((modes (context-floating-point-modes
+ (sb!alien:sap-alien context (* os-context-t))))
+ (traps (logand (ldb float-exceptions-byte modes)
+ (ldb float-traps-byte modes))))
+ (cond ((not (zerop (logand float-divide-by-zero-trap-bit traps)))
+ (error 'division-by-zero))
+ ((not (zerop (logand float-invalid-trap-bit traps)))
+ (error 'floating-point-invalid-operation))
+ ((not (zerop (logand float-overflow-trap-bit traps)))
+ (error 'floating-point-overflow))
+ ((not (zerop (logand float-underflow-trap-bit traps)))
+ (error 'floating-point-underflow))
+ ((not (zerop (logand float-inexact-trap-bit traps)))
+ (error 'floating-point-inexact))
+ #!+FreeBSD
+ ((zerop (ldb float-exceptions-byte modes))
+ ;; I can't tell what caused the exception!!
+ (error 'floating-point-exception
+ :traps (getf (get-floating-point-modes) :traps)))
+ (t
+ (error "SIGFPE with no exceptions currently enabled?"))))
+ |#
+ )
+
+(defmacro with-float-traps-masked (traps &body body)
+ #!+sb-doc
+ "Execute BODY with the floating point exceptions listed in TRAPS
+ masked (disabled). TRAPS should be a list of possible exceptions
+ which includes :UNDERFLOW, :OVERFLOW, :INEXACT, :INVALID and
+ :DIVIDE-BY-ZERO and on the X86 :DENORMALIZED-OPERAND. The respective
+ accrued exceptions are cleared at the start of the body to support
+ their testing within, and restored on exit."
+ (let ((traps (dpb (float-trap-mask traps) float-traps-byte 0))
+ (exceptions (dpb (float-trap-mask traps) float-sticky-bits 0))
+ (trap-mask (dpb (lognot (float-trap-mask traps))
+ float-traps-byte #xffffffff))
+ (exception-mask (dpb (lognot (sb!vm::float-trap-mask traps))
+ float-sticky-bits #xffffffff)))
+ `(let ((orig-modes (floating-point-modes)))
+ (unwind-protect
+ (progn
+ (setf (floating-point-modes)
+ (logand orig-modes ,(logand trap-mask exception-mask)))
+ ,@body)
+ ;; Restore the original traps and exceptions.
+ (setf (floating-point-modes)
+ (logior (logand orig-modes ,(logior traps exceptions))
+ (logand (floating-point-modes)
+ ,(logand trap-mask exception-mask))))))))
--- /dev/null
+;;;; This file contains the definitions of float specific number
+;;;; support (other than irrational stuff, which is in irrat.) There is
+;;;; code in here that assumes there are only two float formats: IEEE
+;;;; single and double. (Long-float support has been added, but bugs
+;;;; may still remain due to old code which assumes this dichotomy.)
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!KERNEL")
+
+(file-comment
+ "$Header$")
+\f
+;;;; utilities
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+
+;;; These functions let us create floats from bits with the significand
+;;; uniformly represented as an integer. This is less efficient for double
+;;; floats, but is more convenient when making special values, etc.
+(defun single-from-bits (sign exp sig)
+ (declare (type bit sign) (type (unsigned-byte 24) sig)
+ (type (unsigned-byte 8) exp))
+ (make-single-float
+ (dpb exp sb!vm:single-float-exponent-byte
+ (dpb sig sb!vm:single-float-significand-byte
+ (if (zerop sign) 0 -1)))))
+(defun double-from-bits (sign exp sig)
+ (declare (type bit sign) (type (unsigned-byte 53) sig)
+ (type (unsigned-byte 11) exp))
+ (make-double-float (dpb exp sb!vm:double-float-exponent-byte
+ (dpb (ash sig -32) sb!vm:double-float-significand-byte
+ (if (zerop sign) 0 -1)))
+ (ldb (byte 32 0) sig)))
+#!+(and long-float x86)
+(defun long-from-bits (sign exp sig)
+ (declare (type bit sign) (type (unsigned-byte 64) sig)
+ (type (unsigned-byte 15) exp))
+ (make-long-float (logior (ash sign 15) exp)
+ (ldb (byte 32 32) sig)
+ (ldb (byte 32 0) sig)))
+
+) ; EVAL-WHEN
+\f
+;;;; float parameters
+
+(defconstant least-positive-single-float (single-from-bits 0 0 1))
+(defconstant least-positive-short-float least-positive-single-float)
+(defconstant least-negative-single-float (single-from-bits 1 0 1))
+(defconstant least-negative-short-float least-negative-single-float)
+(defconstant least-positive-double-float (double-from-bits 0 0 1))
+#!-long-float
+(defconstant least-positive-long-float least-positive-double-float)
+#!+(and long-float x86)
+(defconstant least-positive-long-float (long-from-bits 0 0 1))
+(defconstant least-negative-double-float (double-from-bits 1 0 1))
+#!-long-float
+(defconstant least-negative-long-float least-negative-double-float)
+#!+(and long-float x86)
+(defconstant least-negative-long-float (long-from-bits 1 0 1))
+
+(defconstant least-positive-normalized-single-float
+ (single-from-bits 0 sb!vm:single-float-normal-exponent-min 0))
+(defconstant least-positive-normalized-short-float
+ least-positive-normalized-single-float)
+(defconstant least-negative-normalized-single-float
+ (single-from-bits 1 sb!vm:single-float-normal-exponent-min 0))
+(defconstant least-negative-normalized-short-float
+ least-negative-normalized-single-float)
+(defconstant least-positive-normalized-double-float
+ (double-from-bits 0 sb!vm:double-float-normal-exponent-min 0))
+#!-long-float
+(defconstant least-positive-normalized-long-float
+ least-positive-normalized-double-float)
+#!+(and long-float x86)
+(defconstant least-positive-normalized-long-float
+ (long-from-bits 0 sb!vm:long-float-normal-exponent-min
+ (ash sb!vm:long-float-hidden-bit 32)))
+(defconstant least-negative-normalized-double-float
+ (double-from-bits 1 sb!vm:double-float-normal-exponent-min 0))
+#!-long-float
+(defconstant least-negative-normalized-long-float
+ least-negative-normalized-double-float)
+#!+(and long-float x86)
+(defconstant least-negative-normalized-long-float
+ (long-from-bits 1 sb!vm:long-float-normal-exponent-min
+ (ash sb!vm:long-float-hidden-bit 32)))
+
+(defconstant most-positive-single-float
+ (single-from-bits 0 sb!vm:single-float-normal-exponent-max
+ (ldb sb!vm:single-float-significand-byte -1)))
+(defconstant most-positive-short-float most-positive-single-float)
+(defconstant most-negative-single-float
+ (single-from-bits 1 sb!vm:single-float-normal-exponent-max
+ (ldb sb!vm:single-float-significand-byte -1)))
+(defconstant most-negative-short-float most-negative-single-float)
+(defconstant most-positive-double-float
+ (double-from-bits 0 sb!vm:double-float-normal-exponent-max
+ (ldb (byte sb!vm:double-float-digits 0) -1)))
+#!-long-float
+(defconstant most-positive-long-float most-positive-double-float)
+#!+(and long-float x86)
+(defconstant most-positive-long-float
+ (long-from-bits 0 sb!vm:long-float-normal-exponent-max
+ (ldb (byte sb!vm:long-float-digits 0) -1)))
+(defconstant most-negative-double-float
+ (double-from-bits 1 sb!vm:double-float-normal-exponent-max
+ (ldb (byte sb!vm:double-float-digits 0) -1)))
+#!-long-float
+(defconstant most-negative-long-float most-negative-double-float)
+#!+(and long-float x86)
+(defconstant most-negative-long-float
+ (long-from-bits 1 sb!vm:long-float-normal-exponent-max
+ (ldb (byte sb!vm:long-float-digits 0) -1)))
+
+#!+sb-infinities
+(defconstant single-float-positive-infinity
+ (single-from-bits 0 (1+ sb!vm:single-float-normal-exponent-max) 0))
+#!+sb-infinities
+(defconstant short-float-positive-infinity single-float-positive-infinity)
+#!+sb-infinities
+(defconstant single-float-negative-infinity
+ (single-from-bits 1 (1+ sb!vm:single-float-normal-exponent-max) 0))
+#!+sb-infinities
+(defconstant short-float-negative-infinity single-float-negative-infinity)
+#!+sb-infinities
+(defconstant double-float-positive-infinity
+ (double-from-bits 0 (1+ sb!vm:double-float-normal-exponent-max) 0))
+#!+(and sb-infinities (not long-float))
+(defconstant long-float-positive-infinity double-float-positive-infinity)
+#!+(and sb-infinities long-float x86)
+(defconstant long-float-positive-infinity
+ (long-from-bits 0 (1+ sb!vm:long-float-normal-exponent-max)
+ (ash sb!vm:long-float-hidden-bit 32)))
+#!+sb-infinities
+(defconstant double-float-negative-infinity
+ (double-from-bits 1 (1+ sb!vm:double-float-normal-exponent-max) 0))
+#!+(and sb-infinities (not long-float))
+(defconstant long-float-negative-infinity double-float-negative-infinity)
+#!+(and sb-infinities long-float x86)
+(defconstant long-float-negative-infinity
+ (long-from-bits 1 (1+ sb!vm:long-float-normal-exponent-max)
+ (ash sb!vm:long-float-hidden-bit 32)))
+
+(defconstant single-float-epsilon
+ (single-from-bits 0 (- sb!vm:single-float-bias
+ (1- sb!vm:single-float-digits)) 1))
+(defconstant short-float-epsilon single-float-epsilon)
+(defconstant single-float-negative-epsilon
+ (single-from-bits 0 (- sb!vm:single-float-bias sb!vm:single-float-digits) 1))
+(defconstant short-float-negative-epsilon single-float-negative-epsilon)
+(defconstant double-float-epsilon
+ (double-from-bits 0 (- sb!vm:double-float-bias
+ (1- sb!vm:double-float-digits)) 1))
+#!-long-float
+(defconstant long-float-epsilon double-float-epsilon)
+#!+(and long-float x86)
+(defconstant long-float-epsilon
+ (long-from-bits 0 (- sb!vm:long-float-bias (1- sb!vm:long-float-digits))
+ (+ 1 (ash sb!vm:long-float-hidden-bit 32))))
+(defconstant double-float-negative-epsilon
+ (double-from-bits 0 (- sb!vm:double-float-bias sb!vm:double-float-digits) 1))
+#!-long-float
+(defconstant long-float-negative-epsilon double-float-negative-epsilon)
+#!+(and long-float x86)
+(defconstant long-float-negative-epsilon
+ (long-from-bits 0 (- sb!vm:long-float-bias sb!vm:long-float-digits)
+ (+ 1 (ash sb!vm:long-float-hidden-bit 32))))
+\f
+;;;; float predicates and environment query
+
+#!-sb-fluid
+(declaim (maybe-inline float-denormalized-p float-infinity-p float-nan-p
+ float-trapping-nan-p))
+
+(defun float-denormalized-p (x)
+ #!+sb-doc
+ "Return true if the float X is denormalized."
+ (number-dispatch ((x float))
+ ((single-float)
+ (and (zerop (ldb sb!vm:single-float-exponent-byte (single-float-bits x)))
+ (not (zerop x))))
+ ((double-float)
+ (and (zerop (ldb sb!vm:double-float-exponent-byte
+ (double-float-high-bits x)))
+ (not (zerop x))))
+ #!+(and long-float x86)
+ ((long-float)
+ (and (zerop (ldb sb!vm:long-float-exponent-byte (long-float-exp-bits x)))
+ (not (zerop x))))))
+
+(macrolet ((def-frob (name doc single double #!+(and long-float x86) long)
+ `(defun ,name (x)
+ ,doc
+ (number-dispatch ((x float))
+ ((single-float)
+ (let ((bits (single-float-bits x)))
+ (and (> (ldb sb!vm:single-float-exponent-byte bits)
+ sb!vm:single-float-normal-exponent-max)
+ ,single)))
+ ((double-float)
+ (let ((hi (double-float-high-bits x))
+ (lo (double-float-low-bits x)))
+ (declare (ignorable lo))
+ (and (> (ldb sb!vm:double-float-exponent-byte hi)
+ sb!vm:double-float-normal-exponent-max)
+ ,double)))
+ #!+(and long-float x86)
+ ((long-float)
+ (let ((exp (long-float-exp-bits x))
+ (hi (long-float-high-bits x))
+ (lo (long-float-low-bits x)))
+ (declare (ignorable lo))
+ (and (> (ldb sb!vm:long-float-exponent-byte exp)
+ sb!vm:long-float-normal-exponent-max)
+ ,long)))))))
+
+ (def-frob float-infinity-p
+ "Return true if the float X is an infinity (+ or -)."
+ (zerop (ldb sb!vm:single-float-significand-byte bits))
+ (and (zerop (ldb sb!vm:double-float-significand-byte hi))
+ (zerop lo))
+ #!+(and long-float x86)
+ (and (zerop (ldb sb!vm:long-float-significand-byte hi))
+ (zerop lo)))
+
+ (def-frob float-nan-p
+ "Return true if the float X is a NaN (Not a Number)."
+ (not (zerop (ldb sb!vm:single-float-significand-byte bits)))
+ (or (not (zerop (ldb sb!vm:double-float-significand-byte hi)))
+ (not (zerop lo)))
+ #!+(and long-float x86)
+ (or (not (zerop (ldb sb!vm:long-float-significand-byte hi)))
+ (not (zerop lo))))
+
+ (def-frob float-trapping-nan-p
+ "Return true if the float X is a trapping NaN (Not a Number)."
+ (zerop (logand (ldb sb!vm:single-float-significand-byte bits)
+ sb!vm:single-float-trapping-nan-bit))
+ (zerop (logand (ldb sb!vm:double-float-significand-byte hi)
+ sb!vm:double-float-trapping-nan-bit))
+ #!+(and long-float x86)
+ (zerop (logand (ldb sb!vm:long-float-significand-byte hi)
+ sb!vm:long-float-trapping-nan-bit))))
+
+;;; If denormalized, use a subfunction from INTEGER-DECODE-FLOAT to find the
+;;; actual exponent (and hence how denormalized it is), otherwise we just
+;;; return the number of digits or 0.
+#!-sb-fluid (declaim (maybe-inline float-precision))
+(defun float-precision (f)
+ #!+sb-doc
+ "Returns a non-negative number of significant digits in its float argument.
+ Will be less than FLOAT-DIGITS if denormalized or zero."
+ (macrolet ((frob (digits bias decode)
+ `(cond ((zerop f) 0)
+ ((float-denormalized-p f)
+ (multiple-value-bind (ignore exp) (,decode f)
+ (declare (ignore ignore))
+ (truly-the fixnum
+ (+ ,digits (1- ,digits) ,bias exp))))
+ (t
+ ,digits))))
+ (number-dispatch ((f float))
+ ((single-float)
+ (frob sb!vm:single-float-digits sb!vm:single-float-bias
+ integer-decode-single-denorm))
+ ((double-float)
+ (frob sb!vm:double-float-digits sb!vm:double-float-bias
+ integer-decode-double-denorm))
+ #!+long-float
+ ((long-float)
+ (frob sb!vm:long-float-digits sb!vm:long-float-bias
+ integer-decode-long-denorm)))))
+
+(defun float-sign (float1 &optional (float2 (float 1 float1)))
+ #!+sb-doc
+ "Returns a floating-point number that has the same sign as
+ float1 and, if float2 is given, has the same absolute value
+ as float2."
+ (declare (float float1 float2))
+ (* (if (etypecase float1
+ (single-float (minusp (single-float-bits float1)))
+ (double-float (minusp (double-float-high-bits float1)))
+ #!+long-float
+ (long-float (minusp (long-float-exp-bits float1))))
+ (float -1 float1)
+ (float 1 float1))
+ (abs float2)))
+
+(defun float-format-digits (format)
+ (ecase format
+ ((short-float single-float) sb!vm:single-float-digits)
+ ((double-float #!-long-float long-float) sb!vm:double-float-digits)
+ #!+long-float
+ (long-float sb!vm:long-float-digits)))
+
+#!-sb-fluid (declaim (inline float-digits float-radix))
+
+(defun float-digits (f)
+ (number-dispatch ((f float))
+ ((single-float) sb!vm:single-float-digits)
+ ((double-float) sb!vm:double-float-digits)
+ #!+long-float
+ ((long-float) sb!vm:long-float-digits)))
+
+(defun float-radix (x)
+ #!+sb-doc
+ "Returns (as an integer) the radix b of its floating-point
+ argument."
+ (declare (type float x) (ignore x))
+ 2)
+\f
+;;;; INTEGER-DECODE-FLOAT and DECODE-FLOAT
+
+#!-sb-fluid
+(declaim (maybe-inline integer-decode-single-float
+ integer-decode-double-float))
+
+;;; Handle the denormalized case of INTEGER-DECODE-FLOAT for SINGLE-FLOAT.
+(defun integer-decode-single-denorm (x)
+ (declare (type single-float x))
+ (let* ((bits (single-float-bits (abs x)))
+ (sig (ash (ldb sb!vm:single-float-significand-byte bits) 1))
+ (extra-bias 0))
+ (declare (type (unsigned-byte 24) sig)
+ (type (integer 0 23) extra-bias))
+ (loop
+ (unless (zerop (logand sig sb!vm:single-float-hidden-bit))
+ (return))
+ (setq sig (ash sig 1))
+ (incf extra-bias))
+ (values sig
+ (- (- sb!vm:single-float-bias)
+ sb!vm:single-float-digits
+ extra-bias)
+ (if (minusp (float-sign x)) -1 1))))
+
+;;; Handle the single-float case of INTEGER-DECODE-FLOAT. If an infinity or
+;;; NaN, error. If a denorm, call i-d-s-DENORM to handle it.
+(defun integer-decode-single-float (x)
+ (declare (single-float x))
+ (let* ((bits (single-float-bits (abs x)))
+ (exp (ldb sb!vm:single-float-exponent-byte bits))
+ (sig (ldb sb!vm:single-float-significand-byte bits))
+ (sign (if (minusp (float-sign x)) -1 1))
+ (biased (- exp sb!vm:single-float-bias sb!vm:single-float-digits)))
+ (declare (fixnum biased))
+ (unless (<= exp sb!vm:single-float-normal-exponent-max)
+ (error "can't decode NaN or infinity: ~S" x))
+ (cond ((and (zerop exp) (zerop sig))
+ (values 0 biased sign))
+ ((< exp sb!vm:single-float-normal-exponent-min)
+ (integer-decode-single-denorm x))
+ (t
+ (values (logior sig sb!vm:single-float-hidden-bit) biased sign)))))
+
+;;; Like INTEGER-DECODE-SINGLE-DENORM, only doubly so.
+(defun integer-decode-double-denorm (x)
+ (declare (type double-float x))
+ (let* ((high-bits (double-float-high-bits (abs x)))
+ (sig-high (ldb sb!vm:double-float-significand-byte high-bits))
+ (low-bits (double-float-low-bits x))
+ (sign (if (minusp (float-sign x)) -1 1))
+ (biased (- (- sb!vm:double-float-bias) sb!vm:double-float-digits)))
+ (if (zerop sig-high)
+ (let ((sig low-bits)
+ (extra-bias (- sb!vm:double-float-digits 33))
+ (bit (ash 1 31)))
+ (declare (type (unsigned-byte 32) sig) (fixnum extra-bias))
+ (loop
+ (unless (zerop (logand sig bit)) (return))
+ (setq sig (ash sig 1))
+ (incf extra-bias))
+ (values (ash sig (- sb!vm:double-float-digits 32))
+ (truly-the fixnum (- biased extra-bias))
+ sign))
+ (let ((sig (ash sig-high 1))
+ (extra-bias 0))
+ (declare (type (unsigned-byte 32) sig) (fixnum extra-bias))
+ (loop
+ (unless (zerop (logand sig sb!vm:double-float-hidden-bit))
+ (return))
+ (setq sig (ash sig 1))
+ (incf extra-bias))
+ (values (logior (ash sig 32) (ash low-bits (1- extra-bias)))
+ (truly-the fixnum (- biased extra-bias))
+ sign)))))
+
+;;; Like INTEGER-DECODE-SINGLE-FLOAT, only doubly so.
+(defun integer-decode-double-float (x)
+ (declare (double-float x))
+ (let* ((abs (abs x))
+ (hi (double-float-high-bits abs))
+ (lo (double-float-low-bits abs))
+ (exp (ldb sb!vm:double-float-exponent-byte hi))
+ (sig (ldb sb!vm:double-float-significand-byte hi))
+ (sign (if (minusp (float-sign x)) -1 1))
+ (biased (- exp sb!vm:double-float-bias sb!vm:double-float-digits)))
+ (declare (fixnum biased))
+ (unless (<= exp sb!vm:double-float-normal-exponent-max)
+ (error "Can't decode NaN or infinity: ~S." x))
+ (cond ((and (zerop exp) (zerop sig) (zerop lo))
+ (values 0 biased sign))
+ ((< exp sb!vm:double-float-normal-exponent-min)
+ (integer-decode-double-denorm x))
+ (t
+ (values
+ (logior (ash (logior (ldb sb!vm:double-float-significand-byte hi)
+ sb!vm:double-float-hidden-bit)
+ 32)
+ lo)
+ biased sign)))))
+
+#!+(and long-float x86)
+(defun integer-decode-long-denorm (x)
+ (declare (type long-float x))
+ (let* ((high-bits (long-float-high-bits (abs x)))
+ (sig-high (ldb sb!vm:long-float-significand-byte high-bits))
+ (low-bits (long-float-low-bits x))
+ (sign (if (minusp (float-sign x)) -1 1))
+ (biased (- (- sb!vm:long-float-bias) sb!vm:long-float-digits)))
+ (if (zerop sig-high)
+ (let ((sig low-bits)
+ (extra-bias (- sb!vm:long-float-digits 33))
+ (bit (ash 1 31)))
+ (declare (type (unsigned-byte 32) sig) (fixnum extra-bias))
+ (loop
+ (unless (zerop (logand sig bit)) (return))
+ (setq sig (ash sig 1))
+ (incf extra-bias))
+ (values (ash sig (- sb!vm:long-float-digits 32))
+ (truly-the fixnum (- biased extra-bias))
+ sign))
+ (let ((sig (ash sig-high 1))
+ (extra-bias 0))
+ (declare (type (unsigned-byte 32) sig) (fixnum extra-bias))
+ (loop
+ (unless (zerop (logand sig sb!vm:long-float-hidden-bit))
+ (return))
+ (setq sig (ash sig 1))
+ (incf extra-bias))
+ (values (logior (ash sig 32) (ash low-bits (1- extra-bias)))
+ (truly-the fixnum (- biased extra-bias))
+ sign)))))
+
+#!+(and long-float x86)
+(defun integer-decode-long-float (x)
+ (declare (long-float x))
+ (let* ((hi (long-float-high-bits x))
+ (lo (long-float-low-bits x))
+ (exp-bits (long-float-exp-bits x))
+ (exp (ldb sb!vm:long-float-exponent-byte exp-bits))
+ (sign (if (minusp exp-bits) -1 1))
+ (biased (- exp sb!vm:long-float-bias sb!vm:long-float-digits)))
+ (declare (fixnum biased))
+ (unless (<= exp sb!vm:long-float-normal-exponent-max)
+ (error "can't decode NaN or infinity: ~S" x))
+ (cond ((and (zerop exp) (zerop hi) (zerop lo))
+ (values 0 biased sign))
+ ((< exp sb!vm:long-float-normal-exponent-min)
+ (integer-decode-long-denorm x))
+ (t
+ (values (logior (ash hi 32) lo) biased sign)))))
+
+;;; Dispatch to the correct type-specific i-d-f function.
+(defun integer-decode-float (x)
+ #!+sb-doc
+ "Returns three values:
+ 1) an integer representation of the significand.
+ 2) the exponent for the power of 2 that the significand must be multiplied
+ by to get the actual value. This differs from the DECODE-FLOAT exponent
+ by FLOAT-DIGITS, since the significand has been scaled to have all its
+ digits before the radix point.
+ 3) -1 or 1 (i.e. the sign of the argument.)"
+ (number-dispatch ((x float))
+ ((single-float)
+ (integer-decode-single-float x))
+ ((double-float)
+ (integer-decode-double-float x))
+ #!+long-float
+ ((long-float)
+ (integer-decode-long-float x))))
+
+#!-sb-fluid (declaim (maybe-inline decode-single-float decode-double-float))
+
+;;; Handle the denormalized case of DECODE-SINGLE-FLOAT. We call
+;;; INTEGER-DECODE-SINGLE-DENORM and then make the result into a float.
+(defun decode-single-denorm (x)
+ (declare (type single-float x))
+ (multiple-value-bind (sig exp sign) (integer-decode-single-denorm x)
+ (values (make-single-float
+ (dpb sig sb!vm:single-float-significand-byte
+ (dpb sb!vm:single-float-bias
+ sb!vm:single-float-exponent-byte
+ 0)))
+ (truly-the fixnum (+ exp sb!vm:single-float-digits))
+ (float sign x))))
+
+;;; Handle the single-float case of DECODE-FLOAT. If an infinity or NaN,
+;;; error. If a denorm, call d-s-DENORM to handle it.
+(defun decode-single-float (x)
+ (declare (single-float x))
+ (let* ((bits (single-float-bits (abs x)))
+ (exp (ldb sb!vm:single-float-exponent-byte bits))
+ (sign (float-sign x))
+ (biased (truly-the single-float-exponent
+ (- exp sb!vm:single-float-bias))))
+ (unless (<= exp sb!vm:single-float-normal-exponent-max)
+ (error "can't decode NaN or infinity: ~S" x))
+ (cond ((zerop x)
+ (values 0.0f0 biased sign))
+ ((< exp sb!vm:single-float-normal-exponent-min)
+ (decode-single-denorm x))
+ (t
+ (values (make-single-float
+ (dpb sb!vm:single-float-bias
+ sb!vm:single-float-exponent-byte
+ bits))
+ biased sign)))))
+
+;;; Like DECODE-SINGLE-DENORM, only doubly so.
+(defun decode-double-denorm (x)
+ (declare (double-float x))
+ (multiple-value-bind (sig exp sign) (integer-decode-double-denorm x)
+ (values (make-double-float
+ (dpb (logand (ash sig -32) (lognot sb!vm:double-float-hidden-bit))
+ sb!vm:double-float-significand-byte
+ (dpb sb!vm:double-float-bias
+ sb!vm:double-float-exponent-byte 0))
+ (ldb (byte 32 0) sig))
+ (truly-the fixnum (+ exp sb!vm:double-float-digits))
+ (float sign x))))
+
+;;; Like DECODE-SINGLE-FLOAT, only doubly so.
+(defun decode-double-float (x)
+ (declare (double-float x))
+ (let* ((abs (abs x))
+ (hi (double-float-high-bits abs))
+ (lo (double-float-low-bits abs))
+ (exp (ldb sb!vm:double-float-exponent-byte hi))
+ (sign (float-sign x))
+ (biased (truly-the double-float-exponent
+ (- exp sb!vm:double-float-bias))))
+ (unless (<= exp sb!vm:double-float-normal-exponent-max)
+ (error "can't decode NaN or infinity: ~S" x))
+ (cond ((zerop x)
+ (values 0.0d0 biased sign))
+ ((< exp sb!vm:double-float-normal-exponent-min)
+ (decode-double-denorm x))
+ (t
+ (values (make-double-float
+ (dpb sb!vm:double-float-bias
+ sb!vm:double-float-exponent-byte hi)
+ lo)
+ biased sign)))))
+
+#!+(and long-float x86)
+(defun decode-long-denorm (x)
+ (declare (long-float x))
+ (multiple-value-bind (sig exp sign) (integer-decode-long-denorm x)
+ (values (make-long-float sb!vm:long-float-bias (ash sig -32)
+ (ldb (byte 32 0) sig))
+ (truly-the fixnum (+ exp sb!vm:long-float-digits))
+ (float sign x))))
+
+#!+(and long-float x86)
+(defun decode-long-float (x)
+ (declare (long-float x))
+ (let* ((hi (long-float-high-bits x))
+ (lo (long-float-low-bits x))
+ (exp-bits (long-float-exp-bits x))
+ (exp (ldb sb!vm:long-float-exponent-byte exp-bits))
+ (sign (if (minusp exp-bits) -1l0 1l0))
+ (biased (truly-the long-float-exponent
+ (- exp sb!vm:long-float-bias))))
+ (unless (<= exp sb!vm:long-float-normal-exponent-max)
+ (error "can't decode NaN or infinity: ~S" x))
+ (cond ((zerop x)
+ (values 0.0l0 biased sign))
+ ((< exp sb!vm:long-float-normal-exponent-min)
+ (decode-long-denorm x))
+ (t
+ (values (make-long-float
+ (dpb sb!vm:long-float-bias sb!vm:long-float-exponent-byte
+ exp-bits)
+ hi
+ lo)
+ biased sign)))))
+
+;;; Dispatch to the appropriate type-specific function.
+(defun decode-float (f)
+ #!+sb-doc
+ "Returns three values:
+ 1) a floating-point number representing the significand. This is always
+ between 0.5 (inclusive) and 1.0 (exclusive).
+ 2) an integer representing the exponent.
+ 3) -1.0 or 1.0 (i.e. the sign of the argument.)"
+ (number-dispatch ((f float))
+ ((single-float)
+ (decode-single-float f))
+ ((double-float)
+ (decode-double-float f))
+ #!+long-float
+ ((long-float)
+ (decode-long-float f))))
+\f
+;;;; SCALE-FLOAT
+
+#!-sb-fluid (declaim (maybe-inline scale-single-float scale-double-float))
+
+;;; Handle float scaling where the X is denormalized or the result is
+;;; denormalized or underflows to 0.
+(defun scale-float-maybe-underflow (x exp)
+ (multiple-value-bind (sig old-exp) (integer-decode-float x)
+ (let* ((digits (float-digits x))
+ (new-exp (+ exp old-exp digits
+ (etypecase x
+ (single-float sb!vm:single-float-bias)
+ (double-float sb!vm:double-float-bias))))
+ (sign (if (minusp (float-sign x)) 1 0)))
+ (cond
+ ((< new-exp
+ (etypecase x
+ (single-float sb!vm:single-float-normal-exponent-min)
+ (double-float sb!vm:double-float-normal-exponent-min)))
+ (when (sb!vm:current-float-trap :inexact)
+ (error 'floating-point-inexact :operation 'scale-float
+ :operands (list x exp)))
+ (when (sb!vm:current-float-trap :underflow)
+ (error 'floating-point-underflow :operation 'scale-float
+ :operands (list x exp)))
+ (let ((shift (1- new-exp)))
+ (if (< shift (- (1- digits)))
+ (float-sign x 0.0)
+ (etypecase x
+ (single-float (single-from-bits sign 0 (ash sig shift)))
+ (double-float (double-from-bits sign 0 (ash sig shift)))))))
+ (t
+ (etypecase x
+ (single-float (single-from-bits sign new-exp sig))
+ (double-float (double-from-bits sign new-exp sig))))))))
+
+;;; Called when scaling a float overflows, or the original float was a NaN
+;;; or infinity. If overflow errors are trapped, then error, otherwise return
+;;; the appropriate infinity. If a NaN, signal or not as appropriate.
+(defun scale-float-maybe-overflow (x exp)
+ (cond
+ ((float-infinity-p x)
+ ;; Infinity is infinity, no matter how small...
+ x)
+ ((float-nan-p x)
+ (when (and (float-trapping-nan-p x)
+ (sb!vm:current-float-trap :invalid))
+ (error 'floating-point-invalid-operation :operation 'scale-float
+ :operands (list x exp)))
+ x)
+ (t
+ (when (sb!vm:current-float-trap :overflow)
+ (error 'floating-point-overflow :operation 'scale-float
+ :operands (list x exp)))
+ (when (sb!vm:current-float-trap :inexact)
+ (error 'floating-point-inexact :operation 'scale-float
+ :operands (list x exp)))
+ (infinite (* (float-sign x)
+ (etypecase x
+ (single-float single-float-positive-infinity)
+ (double-float double-float-positive-infinity)))))))
+
+;;; Scale a single or double float, calling the correct over/underflow
+;;; functions.
+(defun scale-single-float (x exp)
+ (declare (single-float x) (fixnum exp))
+ (let* ((bits (single-float-bits x))
+ (old-exp (ldb sb!vm:single-float-exponent-byte bits))
+ (new-exp (+ old-exp exp)))
+ (cond
+ ((zerop x) x)
+ ((or (< old-exp sb!vm:single-float-normal-exponent-min)
+ (< new-exp sb!vm:single-float-normal-exponent-min))
+ (scale-float-maybe-underflow x exp))
+ ((or (> old-exp sb!vm:single-float-normal-exponent-max)
+ (> new-exp sb!vm:single-float-normal-exponent-max))
+ (scale-float-maybe-overflow x exp))
+ (t
+ (make-single-float (dpb new-exp
+ sb!vm:single-float-exponent-byte
+ bits))))))
+(defun scale-double-float (x exp)
+ (declare (double-float x) (fixnum exp))
+ (let* ((hi (double-float-high-bits x))
+ (lo (double-float-low-bits x))
+ (old-exp (ldb sb!vm:double-float-exponent-byte hi))
+ (new-exp (+ old-exp exp)))
+ (cond
+ ((zerop x) x)
+ ((or (< old-exp sb!vm:double-float-normal-exponent-min)
+ (< new-exp sb!vm:double-float-normal-exponent-min))
+ (scale-float-maybe-underflow x exp))
+ ((or (> old-exp sb!vm:double-float-normal-exponent-max)
+ (> new-exp sb!vm:double-float-normal-exponent-max))
+ (scale-float-maybe-overflow x exp))
+ (t
+ (make-double-float (dpb new-exp sb!vm:double-float-exponent-byte hi)
+ lo)))))
+
+#!+(and x86 long-float)
+(defun scale-long-float (x exp)
+ (declare (long-float x) (fixnum exp))
+ (scale-float x exp))
+
+;;; Dispatch to the correct type-specific scale-float function.
+(defun scale-float (f ex)
+ #!+sb-doc
+ "Returns the value (* f (expt (float 2 f) ex)), but with no unnecessary loss
+ of precision or overflow."
+ (number-dispatch ((f float))
+ ((single-float)
+ (scale-single-float f ex))
+ ((double-float)
+ (scale-double-float f ex))
+ #!+long-float
+ ((long-float)
+ (scale-long-float f ex))))
+\f
+;;;; converting to/from floats
+
+(defun float (number &optional (other () otherp))
+ #!+sb-doc
+ "Converts any REAL to a float. If OTHER is not provided, it returns a
+ SINGLE-FLOAT if NUMBER is not already a FLOAT. If OTHER is provided, the
+ result is the same float format as OTHER."
+ (if otherp
+ (number-dispatch ((number real) (other float))
+ (((foreach rational single-float double-float #!+long-float long-float)
+ (foreach single-float double-float #!+long-float long-float))
+ (coerce number '(dispatch-type other))))
+ (if (floatp number)
+ number
+ (coerce number 'single-float))))
+
+(macrolet ((frob (name type)
+ `(defun ,name (x)
+ (number-dispatch ((x real))
+ (((foreach single-float double-float #!+long-float long-float
+ fixnum))
+ (coerce x ',type))
+ ((bignum)
+ (bignum-to-float x ',type))
+ ((ratio)
+ (float-ratio x ',type))))))
+ (frob %single-float single-float)
+ (frob %double-float double-float)
+ #!+long-float
+ (frob %long-float long-float))
+
+;;; Convert a ratio to a float. We avoid any rounding error by doing an
+;;; integer division. Accuracy is important to preserve read/print
+;;; consistency, since this is ultimately how the reader reads a float. We
+;;; scale the numerator by a power of two until the division results in the
+;;; desired number of fraction bits, then do round-to-nearest.
+(defun float-ratio (x format)
+ (let* ((signed-num (numerator x))
+ (plusp (plusp signed-num))
+ (num (if plusp signed-num (- signed-num)))
+ (den (denominator x))
+ (digits (float-format-digits format))
+ (scale 0))
+ (declare (fixnum digits scale))
+ ;; Strip any trailing zeros from the denominator and move it into the scale
+ ;; factor (to minimize the size of the operands.)
+ (let ((den-twos (1- (integer-length (logxor den (1- den))))))
+ (declare (fixnum den-twos))
+ (decf scale den-twos)
+ (setq den (ash den (- den-twos))))
+ ;; Guess how much we need to scale by from the magnitudes of the numerator
+ ;; and denominator. We want one extra bit for a guard bit.
+ (let* ((num-len (integer-length num))
+ (den-len (integer-length den))
+ (delta (- den-len num-len))
+ (shift (1+ (the fixnum (+ delta digits))))
+ (shifted-num (ash num shift)))
+ (declare (fixnum delta shift))
+ (decf scale delta)
+ (labels ((float-and-scale (bits)
+ (let* ((bits (ash bits -1))
+ (len (integer-length bits)))
+ (cond ((> len digits)
+ (assert (= len (the fixnum (1+ digits))))
+ (scale-float (floatit (ash bits -1)) (1+ scale)))
+ (t
+ (scale-float (floatit bits) scale)))))
+ (floatit (bits)
+ (let ((sign (if plusp 0 1)))
+ (case format
+ (single-float
+ (single-from-bits sign sb!vm:single-float-bias bits))
+ (double-float
+ (double-from-bits sign sb!vm:double-float-bias bits))
+ #!+long-float
+ (long-float
+ (long-from-bits sign sb!vm:long-float-bias bits))))))
+ (loop
+ (multiple-value-bind (fraction-and-guard rem)
+ (truncate shifted-num den)
+ (let ((extra (- (integer-length fraction-and-guard) digits)))
+ (declare (fixnum extra))
+ (cond ((/= extra 1)
+ (assert (> extra 1)))
+ ((oddp fraction-and-guard)
+ (return
+ (if (zerop rem)
+ (float-and-scale
+ (if (zerop (logand fraction-and-guard 2))
+ fraction-and-guard
+ (1+ fraction-and-guard)))
+ (float-and-scale (1+ fraction-and-guard)))))
+ (t
+ (return (float-and-scale fraction-and-guard)))))
+ (setq shifted-num (ash shifted-num -1))
+ (incf scale)))))))
+
+#|
+These might be useful if we ever have a machine w/o float/integer conversion
+hardware. For now, we'll use special ops that uninterruptibly frob the
+rounding modes & do ieee round-to-integer.
+
+;;; The compiler compiles a call to this when we are doing %UNARY-TRUNCATE
+;;; and the result is known to be a fixnum. We can avoid some generic
+;;; arithmetic in this case.
+(defun %unary-truncate-single-float/fixnum (x)
+ (declare (single-float x) (values fixnum))
+ (locally (declare (optimize (speed 3) (safety 0)))
+ (let* ((bits (single-float-bits x))
+ (exp (ldb sb!vm:single-float-exponent-byte bits))
+ (frac (logior (ldb sb!vm:single-float-significand-byte bits)
+ sb!vm:single-float-hidden-bit))
+ (shift (- exp sb!vm:single-float-digits sb!vm:single-float-bias)))
+ (when (> exp sb!vm:single-float-normal-exponent-max)
+ (error 'floating-point-invalid-operation :operator 'truncate
+ :operands (list x)))
+ (if (<= shift (- sb!vm:single-float-digits))
+ 0
+ (let ((res (ash frac shift)))
+ (declare (type (unsigned-byte 31) res))
+ (if (minusp bits)
+ (- res)
+ res))))))
+
+;;; Double-float version of this operation (see above single op).
+(defun %unary-truncate-double-float/fixnum (x)
+ (declare (double-float x) (values fixnum))
+ (locally (declare (optimize (speed 3) (safety 0)))
+ (let* ((hi-bits (double-float-high-bits x))
+ (exp (ldb sb!vm:double-float-exponent-byte hi-bits))
+ (frac (logior (ldb sb!vm:double-float-significand-byte hi-bits)
+ sb!vm:double-float-hidden-bit))
+ (shift (- exp (- sb!vm:double-float-digits sb!vm:word-bits)
+ sb!vm:double-float-bias)))
+ (when (> exp sb!vm:double-float-normal-exponent-max)
+ (error 'floating-point-invalid-operation :operator 'truncate
+ :operands (list x)))
+ (if (<= shift (- sb!vm:word-bits sb!vm:double-float-digits))
+ 0
+ (let* ((res-hi (ash frac shift))
+ (res (if (plusp shift)
+ (logior res-hi
+ (the fixnum
+ (ash (double-float-low-bits x)
+ (- shift sb!vm:word-bits))))
+ res-hi)))
+ (declare (type (unsigned-byte 31) res-hi res))
+ (if (minusp hi-bits)
+ (- res)
+ res))))))
+|#
+
+;;; This function is called when we are doing a truncate without any funky
+;;; divisor, i.e. converting a float or ratio to an integer. Note that we do
+;;; *not* return the second value of truncate, so it must be computed by the
+;;; caller if needed.
+;;;
+;;; In the float case, we pick off small arguments so that compiler can use
+;;; special-case operations. We use an exclusive test, since (due to round-off
+;;; error), (float most-positive-fixnum) may be greater than
+;;; most-positive-fixnum.
+(defun %unary-truncate (number)
+ (number-dispatch ((number real))
+ ((integer) number)
+ ((ratio) (values (truncate (numerator number) (denominator number))))
+ (((foreach single-float double-float #!+long-float long-float))
+ (if (< (float most-negative-fixnum number)
+ number
+ (float most-positive-fixnum number))
+ (truly-the fixnum (%unary-truncate number))
+ (multiple-value-bind (bits exp) (integer-decode-float number)
+ (let ((res (ash bits exp)))
+ (if (minusp number)
+ (- res)
+ res)))))))
+
+;;; Similar to %UNARY-TRUNCATE, but rounds to the nearest integer. If we
+;;; can't use the round primitive, then we do our own round-to-nearest on the
+;;; result of i-d-f. [Note that this rounding will really only happen with
+;;; double floats, since the whole single-float fraction will fit in a fixnum,
+;;; so all single-floats larger than most-positive-fixnum can be precisely
+;;; represented by an integer.]
+(defun %unary-round (number)
+ (number-dispatch ((number real))
+ ((integer) number)
+ ((ratio) (values (round (numerator number) (denominator number))))
+ (((foreach single-float double-float #!+long-float long-float))
+ (if (< (float most-negative-fixnum number)
+ number
+ (float most-positive-fixnum number))
+ (truly-the fixnum (%unary-round number))
+ (multiple-value-bind (bits exp) (integer-decode-float number)
+ (let* ((shifted (ash bits exp))
+ (rounded (if (and (minusp exp)
+ (oddp shifted)
+ (eql (logand bits
+ (lognot (ash -1 (- exp))))
+ (ash 1 (- -1 exp))))
+ (1+ shifted)
+ shifted)))
+ (if (minusp number)
+ (- rounded)
+ rounded)))))))
+
+(defun rational (x)
+ #!+sb-doc
+ "RATIONAL produces a rational number for any real numeric argument. This is
+ more efficient than RATIONALIZE, but it assumes that floating-point is
+ completely accurate, giving a result that isn't as pretty."
+ (number-dispatch ((x real))
+ (((foreach single-float double-float #!+long-float long-float))
+ (multiple-value-bind (bits exp) (integer-decode-float x)
+ (if (eql bits 0)
+ 0
+ (let* ((int (if (minusp x) (- bits) bits))
+ (digits (float-digits x))
+ (ex (+ exp digits)))
+ (if (minusp ex)
+ (integer-/-integer int (ash 1 (+ digits (- ex))))
+ (integer-/-integer (ash int ex) (ash 1 digits)))))))
+ ((rational) x)))
+
+(defun rationalize (x)
+ #!+sb-doc
+ "Converts any REAL to a RATIONAL. Floats are converted to a simple rational
+ representation exploiting the assumption that floats are only accurate to
+ their precision. RATIONALIZE (and also RATIONAL) preserve the invariant:
+ (= x (float (rationalize x) x))"
+ (number-dispatch ((x real))
+ (((foreach single-float double-float #!+long-float long-float))
+ ;; Thanks to Kim Fateman, who stole this function rationalize-float from
+ ;; macsyma's rational. Macsyma'a rationalize was written by the legendary
+ ;; Gosper (rwg). Guy Steele said about Gosper, "He has been called the
+ ;; only living 17th century mathematician and is also the best pdp-10
+ ;; hacker I know." So, if you can understand or debug this code you win
+ ;; big.
+ (cond ((minusp x) (- (rationalize (- x))))
+ ((zerop x) 0)
+ (t
+ (let ((eps (etypecase x
+ (single-float single-float-epsilon)
+ (double-float double-float-epsilon)
+ #!+long-float
+ (long-float long-float-epsilon)))
+ (y ())
+ (a ()))
+ (do ((xx x (setq y (/ (float 1.0 x) (- xx (float a x)))))
+ (num (setq a (truncate x))
+ (+ (* (setq a (truncate y)) num) onum))
+ (den 1 (+ (* a den) oden))
+ (onum 1 num)
+ (oden 0 den))
+ ((and (not (zerop den))
+ (not (> (abs (/ (- x (/ (float num x)
+ (float den x)))
+ x))
+ eps)))
+ (integer-/-integer num den))
+ (declare ((dispatch-type x) xx)))))))
+ ((rational) x)))
--- /dev/null
+;;;; FOP definitions
+
+(in-package "SB!IMPL")
+
+(file-comment
+ "$Header$")
+
+;;; Define NAME as a fasl operation, with op-code FOP-CODE. PUSHP
+;;; describes what the body does to the fop stack:
+;;; :NOPE
+;;; The body neither pushes or pops the fop stack.
+;;; T
+;;; The body might pop the fop stack. The result of the body is
+;;; pushed on the fop stack.
+;;; NIL
+;;; The body might pop the fop stack. The result of the body is
+;;; discarded.
+;;;
+;;; FIXME: Make PUSHP into a &KEY argument accepting a booleana value.
+;;; Handle the :PUSHP :NOPE case with a separate :STACKP NIL argument,
+;;; meaning "the body doesn't interact with the FOP stack."
+(defmacro define-fop ((name fop-code &optional (pushp t)) &rest forms)
+ `(progn
+ (defun ,name ()
+ ,(if (eq pushp :nope)
+ `(progn ,@forms)
+ `(with-fop-stack ,pushp ,@forms)))
+ (%define-fop ',name ,fop-code)))
+
+;;; FIXME: This can be byte coded.
+(defun %define-fop (name code)
+ (let ((oname (svref *fop-names* code)))
+ (when (and oname (not (eq oname name)))
+ (error "multiple names for fop code ~D: ~S and ~S" code name oname)))
+ ;; KLUDGE: It's mnemonically suboptimal to use 'FOP-CODE as the name of the
+ ;; tag which associates names with codes when it's also used as one of
+ ;; the names. Perhaps the fops named FOP-CODE and FOP-SMALL-CODE could
+ ;; be renamed to something more mnemonic? -- WHN 19990902
+ (let ((ocode (get name 'fop-code)))
+ (when (and ocode (/= ocode code))
+ (error "multiple codes for fop name ~S: ~D and ~D" name code ocode)))
+ (setf (svref *fop-names* code) name
+ (get name 'fop-code) code
+ (svref *fop-functions* code) (symbol-function name))
+ (values))
+
+;;; Define a pair of fops which are identical except that one reads
+;;; a four-byte argument while the other reads a one-byte argument. The
+;;; argument can be accessed by using the Clone-Arg macro.
+;;;
+;;; KLUDGE: It would be nice if the definition here encapsulated which
+;;; value ranges went with which fop variant, and chose the correct
+;;; fop code to use. Currently, since such logic isn't encapsulated,
+;;; we see callers doing stuff like
+;;; (cond ((and (< num-consts #x100) (< total-length #x10000))
+;;; (dump-fop 'sb!impl::fop-small-code file)
+;;; (dump-byte num-consts file)
+;;; (dump-integer-as-n-bytes total-length 2 file))
+;;; (t
+;;; (dump-fop 'sb!impl::fop-code file)
+;;; (dump-unsigned-32 num-consts file)
+;;; (dump-unsigned-32 total-length file))))
+;;; in several places. It would be cleaner if this could be replaced with
+;;; something like
+;;; (dump-fop file fop-code num-consts total-length)
+;;; Some of this logic is already in DUMP-FOP*, but that still requires the
+;;; caller to know that it's a 1-byte-arg/4-byte-arg cloned fop pair, and to
+;;; know both the 1-byte-arg and the 4-byte-arg fop names. -- WHN 19990902
+(defmacro define-cloned-fops ((name code &optional (pushp t))
+ (small-name small-code) &rest forms)
+ (check-type pushp (member nil t :nope))
+ `(progn
+ (macrolet ((clone-arg () '(read-arg 4)))
+ (define-fop (,name ,code ,pushp) ,@forms))
+ (macrolet ((clone-arg () '(read-arg 1)))
+ (define-fop (,small-name ,small-code ,pushp) ,@forms))))
+
+;;; a helper function for reading string values from FASL files: sort of like
+;;; READ-SEQUENCE specialized for files of (UNSIGNED-BYTE 8), with an automatic
+;;; conversion from (UNSIGNED-BYTE 8) into CHARACTER for each element read
+(declaim (ftype (function (stream simple-string &optional index) (values)) read-string-as-bytes))
+(defun read-string-as-bytes (stream string &optional (length (length string)))
+ (dotimes (i length)
+ (setf (aref string i)
+ (code-char (read-byte stream))))
+ ;; FIXME: The classic CMU CL code to do this was
+ ;; (READ-N-BYTES FILE STRING START END).
+ ;; It was changed for SBCL because we needed a portable version for
+ ;; bootstrapping. Benchmark the non-portable version and see whether it's
+ ;; significantly better than the portable version here. If it is, then use
+ ;; add as an alternate definition, protected with #-SB-XC-HOST.
+ (values))
+\f
+;;;; miscellaneous fops
+
+;;; FIXME: POP-STACK should be called something more mnemonic. (POP-FOP-STACK?
+;;; But that would conflict with PUSH-FOP-TABLE. Something, anyway..)
+
+;;; Setting this variable causes execution of a FOP-NOP4 to produce
+;;; output to *DEBUG-IO*. This can be handy when trying to follow the
+;;; progress of FASLOAD.
+#!+sb-show
+(defvar *show-fop-nop4-p* nil)
+
+;;; CMU CL had a single no-op fop, FOP-NOP, with fop code 0. Since 0 occurs
+;;; disproportionately often in fasl files for other reasons, FOP-NOP is less
+;;; than ideal for writing human-readable patterns into fasl files for
+;;; debugging purposes. There's no shortage of unused fop codes, so we add this
+;;; second NOP, which reads 4 arbitrary bytes and discards them.
+(define-fop (fop-nop4 137 :nope)
+ (let ((arg (read-arg 4)))
+ (declare (ignorable arg))
+ #!+sb-show
+ (when *show-fop-nop4-p*
+ (format *debug-io* "~&/FOP-NOP4 ARG=~D=#X~X~%" arg arg))))
+
+(define-fop (fop-nop 0 :nope))
+(define-fop (fop-pop 1 nil) (push-fop-table (pop-stack)))
+(define-fop (fop-push 2) (svref *current-fop-table* (read-arg 4)))
+(define-fop (fop-byte-push 3) (svref *current-fop-table* (read-arg 1)))
+
+(define-fop (fop-empty-list 4) ())
+(define-fop (fop-truth 5) t)
+;;; CMU CL had FOP-POP-FOR-EFFECT as fop 65, but it was never used and seemed
+;;; to have no possible use.
+(define-fop (fop-misc-trap 66)
+ #+sb-xc-host ; since xc host doesn't know how to compile %PRIMITIVE
+ (error "FOP-MISC-TRAP can't be defined without %PRIMITIVE.")
+ #-sb-xc-host
+ (%primitive sb!c:make-other-immediate-type 0 sb!vm:unbound-marker-type))
+
+(define-fop (fop-character 68)
+ (code-char (read-arg 3)))
+;;; CMU CL had FOP-CHARACTER as fop 68, but it's not needed in current
+;;; SBCL as we have no extended characters, only 1-byte characters.
+;;; (Ditto for CMU CL, actually: FOP-CHARACTER was speculative generality.)
+(define-fop (fop-short-character 69)
+ (code-char (read-arg 1)))
+
+(define-cloned-fops (fop-struct 48) (fop-small-struct 49)
+ (let* ((size (clone-arg))
+ (res (%make-instance size)))
+ (declare (type index size))
+ (do ((n (1- size) (1- n)))
+ ((minusp n))
+ (declare (type (integer -1 #.most-positive-fixnum) n))
+ (setf (%instance-ref res n) (pop-stack)))
+ res))
+
+(define-fop (fop-layout 45)
+ (let ((length (pop-stack))
+ (depthoid (pop-stack))
+ (inherits (pop-stack))
+ (name (pop-stack)))
+ (find-and-init-or-check-layout name length inherits depthoid)))
+
+(define-fop (fop-end-group 64 :nope)
+ (throw 'fasl-group-end t))
+
+;;; In the normal loader, we just ignore these. GENESIS overwrites
+;;; FOP-MAYBE-COLD-LOAD with something that knows whether to revert to
+;;; cold-loading or not.
+(define-fop (fop-normal-load 81 :nope))
+(define-fop (fop-maybe-cold-load 82 :nope))
+
+(define-fop (fop-verify-table-size 62 :nope)
+ (let ((expected-index (read-arg 4)))
+ (unless (= *current-fop-table-index* expected-index)
+ (error "internal error: fasl table of improper size"))))
+(define-fop (fop-verify-empty-stack 63 :nope)
+ (unless (= *fop-stack-pointer* *fop-stack-pointer-on-entry*)
+ (error "internal error: fasl stack not empty when it should be")))
+\f
+;;;; fops for loading symbols
+
+(defvar *load-symbol-buffer* (make-string 100))
+(declaim (simple-string *load-symbol-buffer*))
+(defvar *load-symbol-buffer-size* 100)
+(declaim (type index *load-symbol-buffer-size*))
+;;; FIXME:
+;;; (1) *LOAD-SYMBOL-BUFFER-SIZE* is redundant, should just be
+;;; (LENGTH *LOAD-SYMBOL-BUFFER*).
+;;; (2) *LOAD-SYMBOL-BUFFER* should not have a global value, but should
+;;; be bound on entry to FASLOAD, and it should be renamed to
+;;; *FASLOAD-SYMBOL-BUFFER*.
+
+(macrolet (;; FIXME: Should all this code really be duplicated inside
+ ;; each fop? Perhaps it would be better for this shared
+ ;; code to live in FLET FROB1 and FLET FROB4 (for the
+ ;; two different sizes of counts).
+ (frob (name code name-size package)
+ (let ((n-package (gensym))
+ (n-size (gensym))
+ (n-buffer (gensym)))
+ `(define-fop (,name ,code)
+ (prepare-for-fast-read-byte *fasl-file*
+ (let ((,n-package ,package)
+ (,n-size (fast-read-u-integer ,name-size)))
+ (when (> ,n-size *load-symbol-buffer-size*)
+ (setq *load-symbol-buffer*
+ (make-string (setq *load-symbol-buffer-size*
+ (* ,n-size 2)))))
+ (done-with-fast-read-byte)
+ (let ((,n-buffer *load-symbol-buffer*))
+ (read-string-as-bytes *fasl-file*
+ ,n-buffer
+ ,n-size)
+ (push-fop-table (intern* ,n-buffer
+ ,n-size
+ ,n-package)))))))))
+
+ ;; Note: CMU CL had FOP-SYMBOL-SAVE and FOP-SMALL-SYMBOL-SAVE, but since they
+ ;; made the behavior of the fasloader depend on the *PACKAGE* variable, not
+ ;; only were they a pain to support (because they required various hacks to
+ ;; handle *PACKAGE*-manipulation forms) they were basically broken by design,
+ ;; because ANSI gives the user so much flexibility in manipulating *PACKAGE*
+ ;; at load-time that no reasonable hacks could possibly make things work
+ ;; right. The ones used in CMU CL certainly didn't, as shown by e.g.
+ ;; (IN-PACKAGE :CL-USER)
+ ;; (DEFVAR CL::*FOO* 'FOO-VALUE)
+ ;; (EVAL-WHEN (:COMPILE-TOPLEVEL :LOAD-TOPLEVEL :EXECUTE)
+ ;; (SETF *PACKAGE* (FIND-PACKAGE :CL)))
+ ;; which in CMU CL 2.4.9 defines a variable CL-USER::*FOO* instead of
+ ;; defining CL::*FOO*. Therefore, we don't use those fops in SBCL.
+ ;;(frob fop-symbol-save 6 4 *package*)
+ ;;(frob fop-small-symbol-save 7 1 *package*)
+
+ (frob fop-lisp-symbol-save 75 4 *cl-package*)
+ (frob fop-lisp-small-symbol-save 76 1 *cl-package*)
+ (frob fop-keyword-symbol-save 77 4 *keyword-package*)
+ (frob fop-keyword-small-symbol-save 78 1 *keyword-package*)
+
+ ;; FIXME: Because we don't have FOP-SYMBOL-SAVE any more, an enormous number
+ ;; of symbols will fall through to this case, probably resulting in bloated
+ ;; fasl files. A new
+ ;; FOP-SYMBOL-IN-LAST-PACKAGE-SAVE/FOP-SMALL-SYMBOL-IN-LAST-PACKAGE-SAVE
+ ;; cloned fop pair could undo some of this bloat.
+ (frob fop-symbol-in-package-save 8 4
+ (svref *current-fop-table* (fast-read-u-integer 4)))
+ (frob fop-small-symbol-in-package-save 9 1
+ (svref *current-fop-table* (fast-read-u-integer 4)))
+ (frob fop-symbol-in-byte-package-save 10 4
+ (svref *current-fop-table* (fast-read-u-integer 1)))
+ (frob fop-small-symbol-in-byte-package-save 11 1
+ (svref *current-fop-table* (fast-read-u-integer 1))))
+
+(define-cloned-fops (fop-uninterned-symbol-save 12)
+ (fop-uninterned-small-symbol-save 13)
+ (let* ((arg (clone-arg))
+ (res (make-string arg)))
+ (read-string-as-bytes *fasl-file* res)
+ (push-fop-table (make-symbol res))))
+
+(define-fop (fop-package 14)
+ (find-undeleted-package-or-lose (pop-stack)))
+\f
+;;;; fops for loading numbers
+
+;;; Load a signed integer LENGTH bytes long from *FASL-FILE*.
+(defun load-s-integer (length)
+ (declare (fixnum length))
+ ;; #+cmu (declare (optimize (inhibit-warnings 2)))
+ (do* ((index length (1- index))
+ (byte 0 (read-byte *fasl-file*))
+ (result 0 (+ result (ash byte bits)))
+ (bits 0 (+ bits 8)))
+ ((= index 0)
+ (if (logbitp 7 byte) ; look at sign bit
+ (- result (ash 1 bits))
+ result))
+ (declare (fixnum index byte bits))))
+
+(define-cloned-fops (fop-integer 33) (fop-small-integer 34)
+ (load-s-integer (clone-arg)))
+
+(define-fop (fop-word-integer 35)
+ (prepare-for-fast-read-byte *fasl-file*
+ (prog1
+ (fast-read-s-integer 4)
+ (done-with-fast-read-byte))))
+
+(define-fop (fop-byte-integer 36)
+ (prepare-for-fast-read-byte *fasl-file*
+ (prog1
+ (fast-read-s-integer 1)
+ (done-with-fast-read-byte))))
+
+(define-fop (fop-ratio 70)
+ (let ((den (pop-stack)))
+ (%make-ratio (pop-stack) den)))
+
+(define-fop (fop-complex 71)
+ (let ((im (pop-stack)))
+ (%make-complex (pop-stack) im)))
+
+(define-fop (fop-complex-single-float 72)
+ (prepare-for-fast-read-byte *fasl-file*
+ (prog1
+ (complex (make-single-float (fast-read-s-integer 4))
+ (make-single-float (fast-read-s-integer 4)))
+ (done-with-fast-read-byte))))
+
+(define-fop (fop-complex-double-float 73)
+ (prepare-for-fast-read-byte *fasl-file*
+ (prog1
+ (let* ((re-lo (fast-read-u-integer 4))
+ (re-hi (fast-read-u-integer 4))
+ (re (make-double-float re-hi re-lo))
+ (im-lo (fast-read-u-integer 4))
+ (im-hi (fast-read-u-integer 4))
+ (im (make-double-float im-hi im-lo)))
+ (complex re im))
+ (done-with-fast-read-byte))))
+
+#!+long-float
+(define-fop (fop-complex-long-float 67)
+ (prepare-for-fast-read-byte *fasl-file*
+ (prog1
+ (let* ((re-lo (fast-read-u-integer 4))
+ #!+sparc (re-mid (fast-read-u-integer 4))
+ (re-hi (fast-read-u-integer 4))
+ (re-exp (fast-read-s-integer #!+x86 2 #!+sparc 4))
+ (re (make-long-float re-exp re-hi #!+sparc re-mid re-lo))
+ (im-lo (fast-read-u-integer 4))
+ #!+sparc (im-mid (fast-read-u-integer 4))
+ (im-hi (fast-read-u-integer 4))
+ (im-exp (fast-read-s-integer #!+x86 2 #!+sparc 4))
+ (im (make-long-float im-exp im-hi #!+sparc im-mid im-lo)))
+ (complex re im))
+ (done-with-fast-read-byte))))
+
+(define-fop (fop-single-float 46)
+ (prepare-for-fast-read-byte *fasl-file*
+ (prog1 (make-single-float (fast-read-s-integer 4))
+ (done-with-fast-read-byte))))
+
+(define-fop (fop-double-float 47)
+ (prepare-for-fast-read-byte *fasl-file*
+ (prog1
+ (let ((lo (fast-read-u-integer 4)))
+ (make-double-float (fast-read-s-integer 4) lo))
+ (done-with-fast-read-byte))))
+
+#!+long-float
+(define-fop (fop-long-float 52)
+ (prepare-for-fast-read-byte *fasl-file*
+ (prog1
+ (let ((lo (fast-read-u-integer 4))
+ #!+sparc (mid (fast-read-u-integer 4))
+ (hi (fast-read-u-integer 4))
+ (exp (fast-read-s-integer #!+x86 2 #!+sparc 4)))
+ (make-long-float exp hi #!+sparc mid lo))
+ (done-with-fast-read-byte))))
+\f
+;;;; loading lists
+
+(define-fop (fop-list 15)
+ (do ((res () (cons (pop-stack) res))
+ (n (read-arg 1) (1- n)))
+ ((zerop n) res)
+ (declare (type index n))))
+
+(define-fop (fop-list* 16)
+ (do ((res (pop-stack) (cons (pop-stack) res))
+ (n (read-arg 1) (1- n)))
+ ((zerop n) res)
+ (declare (type index n))))
+
+(macrolet ((frob (name op fun n)
+ `(define-fop (,name ,op)
+ (call-with-popped-things ,fun ,n))))
+
+ (frob fop-list-1 17 list 1)
+ (frob fop-list-2 18 list 2)
+ (frob fop-list-3 19 list 3)
+ (frob fop-list-4 20 list 4)
+ (frob fop-list-5 21 list 5)
+ (frob fop-list-6 22 list 6)
+ (frob fop-list-7 23 list 7)
+ (frob fop-list-8 24 list 8)
+
+ (frob fop-list*-1 25 list* 2)
+ (frob fop-list*-2 26 list* 3)
+ (frob fop-list*-3 27 list* 4)
+ (frob fop-list*-4 28 list* 5)
+ (frob fop-list*-5 29 list* 6)
+ (frob fop-list*-6 30 list* 7)
+ (frob fop-list*-7 31 list* 8)
+ (frob fop-list*-8 32 list* 9))
+\f
+;;;; fops for loading arrays
+
+(define-cloned-fops (fop-string 37) (fop-small-string 38)
+ (let* ((arg (clone-arg))
+ (res (make-string arg)))
+ (read-string-as-bytes *fasl-file* res)
+ res))
+
+(define-cloned-fops (fop-vector 39) (fop-small-vector 40)
+ (let* ((size (clone-arg))
+ (res (make-array size)))
+ (declare (fixnum size))
+ (do ((n (1- size) (1- n)))
+ ((minusp n))
+ (setf (svref res n) (pop-stack)))
+ res))
+
+(define-fop (fop-array 83)
+ (let* ((rank (read-arg 4))
+ (vec (pop-stack))
+ (length (length vec))
+ (res (make-array-header sb!vm:simple-array-type rank)))
+ (declare (simple-array vec)
+ (type (unsigned-byte 24) rank))
+ (set-array-header res vec length length 0
+ (do ((i rank (1- i))
+ (dimensions () (cons (pop-stack) dimensions)))
+ ((zerop i) dimensions)
+ (declare (type index i)))
+ nil)
+ res))
+
+(define-fop (fop-single-float-vector 84)
+ (let* ((length (read-arg 4))
+ (result (make-array length :element-type 'single-float)))
+ (read-n-bytes *fasl-file* result 0 (* length sb!vm:word-bytes))
+ result))
+
+(define-fop (fop-double-float-vector 85)
+ (let* ((length (read-arg 4))
+ (result (make-array length :element-type 'double-float)))
+ (read-n-bytes *fasl-file* result 0 (* length sb!vm:word-bytes 2))
+ result))
+
+#!+long-float
+(define-fop (fop-long-float-vector 88)
+ (let* ((length (read-arg 4))
+ (result (make-array length :element-type 'long-float)))
+ (read-n-bytes *fasl-file*
+ result
+ 0
+ (* length sb!vm:word-bytes #!+x86 3 #!+sparc 4))
+ result))
+
+(define-fop (fop-complex-single-float-vector 86)
+ (let* ((length (read-arg 4))
+ (result (make-array length :element-type '(complex single-float))))
+ (read-n-bytes *fasl-file* result 0 (* length sb!vm:word-bytes 2))
+ result))
+
+(define-fop (fop-complex-double-float-vector 87)
+ (let* ((length (read-arg 4))
+ (result (make-array length :element-type '(complex double-float))))
+ (read-n-bytes *fasl-file* result 0 (* length sb!vm:word-bytes 2 2))
+ result))
+
+#!+long-float
+(define-fop (fop-complex-long-float-vector 89)
+ (let* ((length (read-arg 4))
+ (result (make-array length :element-type '(complex long-float))))
+ (read-n-bytes *fasl-file* result 0
+ (* length sb!vm:word-bytes #!+x86 3 #!+sparc 4 2))
+ result))
+
+;;; *** NOT *** the FOP-INT-VECTOR as currently documented in rtguts. Size
+;;; must be a directly supported I-vector element size, with no extra bits.
+;;; This must be packed according to the local byte-ordering, allowing us to
+;;; directly read the bits.
+(define-fop (fop-int-vector 43)
+ (prepare-for-fast-read-byte *fasl-file*
+ (let* ((len (fast-read-u-integer 4))
+ (size (fast-read-byte))
+ (res (case size
+ (1 (make-array len :element-type 'bit))
+ (2 (make-array len :element-type '(unsigned-byte 2)))
+ (4 (make-array len :element-type '(unsigned-byte 4)))
+ (8 (make-array len :element-type '(unsigned-byte 8)))
+ (16 (make-array len :element-type '(unsigned-byte 16)))
+ (32 (make-array len :element-type '(unsigned-byte 32)))
+ (t (error "internal error: losing i-vector element size: ~S"
+ size)))))
+ (declare (type index len))
+ (done-with-fast-read-byte)
+ (read-n-bytes *fasl-file*
+ res
+ 0
+ (ceiling (the index (* size len))
+ sb!vm:byte-bits))
+ res)))
+
+;;; FOP-SIGNED-INT-VECTOR
+;;;
+;;; Same as FOP-INT-VECTOR, except this is for signed simple-arrays.
+;;; It appears that entry 50 and 51 are clear.
+(define-fop (fop-signed-int-vector 50)
+ (prepare-for-fast-read-byte *fasl-file*
+ (let* ((len (fast-read-u-integer 4))
+ (size (fast-read-byte))
+ (res (case size
+ (8 (make-array len :element-type '(signed-byte 8)))
+ (16 (make-array len :element-type '(signed-byte 16)))
+ (30 (make-array len :element-type '(signed-byte 30)))
+ (32 (make-array len :element-type '(signed-byte 32)))
+ (t (error "internal error: losing si-vector element size: ~S"
+ size)))))
+ (declare (type index len))
+ (done-with-fast-read-byte)
+ (read-n-bytes *fasl-file*
+ res
+ 0
+ (ceiling (the index (* (if (= size 30)
+ 32 ; Adjust for (signed-byte 30)
+ size) len)) sb!vm:byte-bits))
+ res)))
+
+(define-fop (fop-eval 53)
+ (let ((result (eval (pop-stack))))
+ ;; FIXME: CMU CL had this code here:
+ ;; (when *load-print*
+ ;; (load-fresh-line)
+ ;; (prin1 result)
+ ;; (terpri))
+ ;; Unfortunately, this dependence on the *LOAD-PRINT* global variable is
+ ;; non-ANSI, so for now we've just punted printing in fasload.
+ result))
+
+(define-fop (fop-eval-for-effect 54 nil)
+ (let ((result (eval (pop-stack))))
+ ;; FIXME: See the comment about *LOAD-PRINT* in FOP-EVAL.
+ (declare (ignore result))
+ #+nil (when *load-print*
+ (load-fresh-line)
+ (prin1 result)
+ (terpri))))
+
+(define-fop (fop-funcall 55)
+ (let ((arg (read-arg 1)))
+ (if (zerop arg)
+ (funcall (pop-stack))
+ (do ((args () (cons (pop-stack) args))
+ (n arg (1- n)))
+ ((zerop n) (apply (pop-stack) args))
+ (declare (type index n))))))
+
+(define-fop (fop-funcall-for-effect 56 nil)
+ (let ((arg (read-arg 1)))
+ (if (zerop arg)
+ (funcall (pop-stack))
+ (do ((args () (cons (pop-stack) args))
+ (n arg (1- n)))
+ ((zerop n) (apply (pop-stack) args))
+ (declare (type index n))))))
+\f
+;;;; fops for fixing up circularities
+
+(define-fop (fop-rplaca 200 nil)
+ (let ((obj (svref *current-fop-table* (read-arg 4)))
+ (idx (read-arg 4))
+ (val (pop-stack)))
+ (setf (car (nthcdr idx obj)) val)))
+
+(define-fop (fop-rplacd 201 nil)
+ (let ((obj (svref *current-fop-table* (read-arg 4)))
+ (idx (read-arg 4))
+ (val (pop-stack)))
+ (setf (cdr (nthcdr idx obj)) val)))
+
+(define-fop (fop-svset 202 nil)
+ (let* ((obi (read-arg 4))
+ (obj (svref *current-fop-table* obi))
+ (idx (read-arg 4))
+ (val (pop-stack)))
+ (if (typep obj 'instance)
+ (setf (%instance-ref obj idx) val)
+ (setf (svref obj idx) val))))
+
+(define-fop (fop-structset 204 nil)
+ (setf (%instance-ref (svref *current-fop-table* (read-arg 4))
+ (read-arg 4))
+ (pop-stack)))
+
+(define-fop (fop-nthcdr 203 t)
+ (nthcdr (read-arg 4) (pop-stack)))
+\f
+;;;; fops for loading functions
+
+;;; (In CMU CL there was a FOP-CODE-FORMAT (47) which was
+;;; conventionally placed at the beginning of each fasl file to test
+;;; for compatibility between the fasl file and the CMU CL which
+;;; loaded it. In SBCL, this functionality has been replaced by
+;;; putting the implementation and version in required fields in the
+;;; fasl file header.)
+
+(define-fop (fop-code 58 :nope)
+ (load-code (read-arg 4) (read-arg 4)))
+
+(define-fop (fop-small-code 59 :nope)
+ (load-code (read-arg 1) (read-arg 2)))
+
+(define-fop (fop-fdefinition 60)
+ (fdefinition-object (pop-stack) t))
+
+(define-fop (fop-sanctify-for-execution 61)
+ (let ((component (pop-stack)))
+ (sb!vm:sanctify-for-execution component)
+ component))
+
+;;; This a no-op except in cold load. (In ordinary warm load, everything
+;;; involved with function definition can be handled nicely by ordinary
+;;; toplevel code.)
+(define-fop (fop-fset 74 nil)
+ (pop-stack)
+ (pop-stack))
+
+;;; Modify a slot in a Constants object.
+(define-cloned-fops (fop-alter-code 140 nil) (fop-byte-alter-code 141)
+ (let ((value (pop-stack))
+ (code (pop-stack)))
+ (setf (code-header-ref code (clone-arg)) value)
+ (values)))
+
+(define-fop (fop-function-entry 142)
+ #+sb-xc-host ; since xc host doesn't know how to compile %PRIMITIVE
+ (error "FOP-FUNCTION-ENTRY can't be defined without %PRIMITIVE.")
+ #-sb-xc-host
+ (let ((type (pop-stack))
+ (arglist (pop-stack))
+ (name (pop-stack))
+ (code-object (pop-stack))
+ (offset (read-arg 4)))
+ (declare (type index offset))
+ (unless (zerop (logand offset sb!vm:lowtag-mask))
+ (error "internal error: unaligned function object, offset = #X~X"
+ offset))
+ (let ((fun (%primitive sb!c:compute-function code-object offset)))
+ (setf (%function-self fun) fun)
+ (setf (%function-next fun) (%code-entry-points code-object))
+ (setf (%code-entry-points code-object) fun)
+ (setf (%function-name fun) name)
+ (setf (%function-arglist fun) arglist)
+ (setf (%function-type fun) type)
+ ;; FIXME: See the comment about *LOAD-PRINT* in FOP-EVAL.
+ #+nil (when *load-print*
+ (load-fresh-line)
+ (format t "~S defined~%" fun))
+ fun)))
+
+(define-fop (fop-make-byte-compiled-function 143)
+ (let* ((size (read-arg 1))
+ (layout (pop-stack))
+ (res (%make-funcallable-instance size layout)))
+ (declare (type index size))
+ (do ((n (1- size) (1- n)))
+ ((minusp n))
+ (declare (type (integer -1 #.most-positive-fixnum) n))
+ (setf (%funcallable-instance-info res n) (pop-stack)))
+ (initialize-byte-compiled-function res)
+ ;; FIXME: See the comment about *LOAD-PRINT* in FOP-EVAL.
+ #+nil (when *load-print*
+ (load-fresh-line)
+ (format t "~S defined~%" res))
+ res))
+\f
+;;;; Some Dylan fops used to live here. By 1 November 1998 the code was
+;;;; sufficiently stale that the functions it called were no longer defined,
+;;;; so I (William Harold Newman) deleted it.
+;;;;
+;;;; In case someone in the future is trying to make sense of FOP layout,
+;;;; it might be worth recording that the Dylan FOPs were
+;;;; 100 FOP-DYLAN-SYMBOL-SAVE
+;;;; 101 FOP-SMALL-DYLAN-SYMBOL-SAVE
+;;;; 102 FOP-DYLAN-KEYWORD-SAVE
+;;;; 103 FOP-SMALL-DYLAN-KEYWORD-SAVE
+;;;; 104 FOP-DYLAN-VARINFO-VALUE
+\f
+;;;; assemblerish fops
+
+(define-fop (fop-foreign-fixup 147)
+ (let* ((kind (pop-stack))
+ (code-object (pop-stack))
+ (len (read-arg 1))
+ (sym (make-string len)))
+ (read-n-bytes *fasl-file* sym 0 len)
+ (sb!vm:fixup-code-object code-object
+ (read-arg 4)
+ (foreign-symbol-address-as-integer sym)
+ kind)
+ code-object))
+
+(define-fop (fop-assembler-code 144)
+ (error "cannot load assembler code except at cold load"))
+
+(define-fop (fop-assembler-routine 145)
+ (error "cannot load assembler code except at cold load"))
+
+(define-fop (fop-assembler-fixup 148)
+ (let ((routine (pop-stack))
+ (kind (pop-stack))
+ (code-object (pop-stack)))
+ (multiple-value-bind (value found) (gethash routine *assembler-routines*)
+ (unless found
+ (error "undefined assembler routine: ~S" routine))
+ (sb!vm:fixup-code-object code-object (read-arg 4) value kind))
+ code-object))
+
+(define-fop (fop-code-object-fixup 149)
+ (let ((kind (pop-stack))
+ (code-object (pop-stack)))
+ ;; Note: We don't have to worry about GC moving the code-object after
+ ;; the GET-LISP-OBJ-ADDRESS and before that value is deposited, because
+ ;; we can only use code-object fixups when code-objects don't move.
+ (sb!vm:fixup-code-object code-object (read-arg 4)
+ (get-lisp-obj-address code-object) kind)
+ code-object))
--- /dev/null
+;;;; Now that all the cross-compiler DEFMACRO machinery has been set up, we
+;;;; can feed the stored DEF!MACRO argument lists to it.
+;;;;
+;;;; KLUDGE: There's no real reason for this to be in its own file, except
+;;;; perhaps the parallelism with FORCE-DELAYED-DEF!STRUCTS (which does have a
+;;;; good reason).
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!IMPL")
+
+(file-comment
+ "$Header$")
+
+#+sb-xc-host (force-delayed-def!macros)
--- /dev/null
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB-IMPL")
+
+(file-comment
+ "$Header$")
+
+(macrolet ((force-delayed-def!methods ()
+ `(progn
+ ,@(mapcar (lambda (args)
+ `(progn
+ #+sb-show
+ (format t
+ "~&/about to do ~S~%"
+ '(defmethod ,@args))
+ (defmethod ,@args)
+ #+sb-show
+ (format t
+ "~&/done with DEFMETHOD ~S~%"
+ ',(first args))))
+ *delayed-def!method-args*)
+ (defmacro def!method (&rest args) `(defmethod ,@args))
+ ;; We're no longer needed, ordinary DEFMETHOD is enough now.
+ (makunbound '*delayed-def!method-args*))))
+ (force-delayed-def!methods))
--- /dev/null
+;;;; Once all the cross-compiler DEFSTRUCT machinery has been set up,
+;;;; we can feed the stored DEF!STRUCT argument lists to it. (This
+;;;; goes in its own source file, instead of in the same file as the
+;;;; DEFSTRUCT machinery, because it's tidier and more maintainable
+;;;; than adding EVAL-WHEN :COMPILE wrappers to anything that it might
+;;;; need.)
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!KERNEL")
+
+(file-comment
+ "$Header$")
+
+#+sb-xc-host (force-delayed-def!structs)
--- /dev/null
+;;;; support for dynamically loading foreign object files
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB-SYS")
+
+(file-comment
+ "$Header$")
+
+;;; not needed until we implement full-blown LOAD-FOREIGN
+#|
+(defun pick-temporary-file-name (&optional
+ ;; KLUDGE: There are various security
+ ;; nastyisms associated with easily
+ ;; guessable temporary file names,
+ ;; and we haven't done anything to
+ ;; work around them here. -- pointed
+ ;; out by Dan Barlow on sbcl-devel
+ ;; 20000702
+ (base "/tmp/sbcl-tmp-~D~C"))
+ (let ((code (char-code #\A)))
+ (loop
+ (let ((name (format nil base (sb-unix:unix-getpid) (code-char code))))
+ (multiple-value-bind (fd errno)
+ (sb-unix:unix-open name
+ (logior sb-unix:o_wronly
+ sb-unix:o_creat
+ sb-unix:o_excl)
+ #o666)
+ (cond ((not (null fd))
+ (sb-unix:unix-close fd)
+ (return name))
+ ((not (= errno sb-unix:eexist))
+ (error "could not create temporary file ~S: ~A"
+ name
+ (sb-unix:get-unix-error-msg errno)))
+ ;; KLUDGE: depends on ASCII character ordering -- WHN 20000128
+ ((= code (char-code #\Z))
+ (setf code (char-code #\a)))
+ ((= code (char-code #\z))
+ (return nil))
+ (t
+ (incf code))))))))
+|#
+
+;;; On any OS where we don't support foreign object file loading, any
+;;; query of a foreign symbol value is answered with "no definition
+;;; known", i.e. NIL.
+;;;
+;;; (On any OS which *does* support foreign object file loading, this
+;;; placeholder implementation is overwritten by a subsequent real
+;;; implementation.)
+(defun get-dynamic-foreign-symbol-address (symbol)
+ (declare (type simple-string symbol) (ignore symbol))
+ nil)
+
+;;; Linux implementation of GET-DYNAMIC-FOREIGN-SYMBOL-ADDRESS
+;;; and functions (e.g. LOAD-FOREIGN) which affect it
+#+linux
+(progn
+
+;;; flags for dlopen()
+(defconstant rtld-lazy 1) ; lazy function call binding?
+(defconstant rtld-now 2) ; immediate function call binding?
+(defconstant rtld-global #x100) ; symbols of loaded obj file
+ ; (and its dependencies) made
+ ; visible (as though the
+ ; obj file were linked directly
+ ; into the program)?
+
+;;; a list of tables returned from dlopen(3) (or possibly some
+;;; bogus value temporarily during initialization)
+(defvar *tables-from-dlopen* nil)
+;;; Dynamically loaded stuff isn't there upon restoring from a save.
+;;; Clearing the variable this way was originally done primarily for
+;;; Irix, which resolves tzname at runtime, resulting in
+;;; *TABLES-FROM-DLOPEN* being set in the saved core image, resulting
+;;; in havoc upon restart; but it seems harmless and tidy for other
+;;; OSes too.
+;;;
+;;; Of course, it can be inconvenient that dynamically loaded stuff
+;;; goes away when we save and restore. However,
+;;; (1) trying to avoid it by system programming here could open a
+;;; huge can of worms, since e.g. now we would need to worry about
+;;; libraries possibly being in different locations (file locations
+;;; or memory locations) at restore time than at save time; and
+;;; (2) by the time the application programmer is so deep into the
+;;; the use of hard core extension features as to be doing
+;;; dynamic loading of foreign files and saving/restoring cores,
+;;; he probably has the sophistication to write his own after-save
+;;; code to reload the libraries without much difficulty.
+(push (lambda () (setq *tables-from-dlopen* nil))
+ sb-int:*after-save-initializations*)
+
+;;; not needed until we implement full-blown LOAD-FOREIGN
+#|
+(defvar *dso-linker* "/usr/bin/ld")
+(defvar *dso-linker-options* '("-G" "-o"))
+|#
+
+(sb-alien:def-alien-routine dlopen system-area-pointer
+ (file sb-c-call:c-string) (mode sb-c-call:int))
+(sb-alien:def-alien-routine dlsym system-area-pointer
+ (lib system-area-pointer)
+ (name sb-c-call:c-string))
+(sb-alien:def-alien-routine dlerror sb-c-call:c-string)
+
+;;; Ensure that we've opened our own binary so we can resolve global
+;;; variables in the Lisp image that come from libraries. This used to
+;;; happen only in GET-DYNAMIC-FOREIGN-SYMBOL-ADDRESS, and only if no
+;;; libraries were dlopen()ed already, but that didn't work if
+;;; something was dlopen()ed before any problem global vars were used.
+;;; So now we do this in any function that can add to the
+;;; *TABLES-FROM-DLOPEN*, as well as in
+;;; GET-DYNAMIC-FOREIGN-SYMBOL-ADDRESS.
+(defun ensure-lisp-table-opened ()
+ (unless *tables-from-dlopen*
+ ;; Prevent recursive call if dlopen() isn't defined.
+ (setf *tables-from-dlopen* (int-sap 0))
+ (setf *tables-from-dlopen* (list (dlopen nil rtld-lazy)))
+ (when (zerop (sb-sys:sap-int (first *tables-from-dlopen*)))
+ (error "can't open global symbol table: ~S" (dlerror)))))
+
+(defun load-1-foreign (file)
+ "a primitive way to load a foreign object file. (LOAD-FOREIGN is
+ probably preferred, but as of SBCL 0.6.7 is not implemented..)
+
+ To use LOAD-1-FOREIGN, at the Unix command line do this:
+ echo 'int summish(int x, int y) { return 1 + x + y; }' > /tmp/ffi-test.c
+ make /tmp/ffi-test.o # i.e. cc -c -o /tmp/ffi-test.o /tmp/ffi-test.c
+ ld -shared -o /tmp/ffi-test.so /tmp/ffi-test.o
+ then in SBCL do this:
+ (LOAD-1-FOREIGN \"/tmp/ffi-test.so\")
+ (DEF-ALIEN-ROUTINE SUMMISH INT (X INT) (Y INT))
+ Now running (SUMMISH 10 20) should return 31.
+"
+ (ensure-lisp-table-opened)
+ ;; Note: We use RTLD-GLOBAL so that it can find all the symbols
+ ;; previously loaded. We use RTLD-NOW so that dlopen() will fail if
+ ;; not all symbols are defined.
+ (let ((sap (dlopen file (logior rtld-now rtld-global))))
+ (if (zerop (sap-int sap))
+ (error "can't open object ~S: ~S" file (dlerror))
+ (pushnew sap *tables-from-dlopen* :test #'sap=)))
+ (values))
+
+(defun get-dynamic-foreign-symbol-address (symbol)
+ (ensure-lisp-table-opened)
+ ;; Find the symbol in any of the loaded object files. Search in
+ ;; reverse order of loading, so that later loadings take precedence.
+ ;;
+ ;; FIXME: The way that we use PUSHNEW SAP in LOAD-1-FOREIGN means
+ ;; that the list isn't guaranteed to be in reverse order of loading,
+ ;; at least not if a file is loaded more than once. Is this the
+ ;; right thing? (In what cases does it matter?)
+ (dolist (table *tables-from-dlopen*)
+ ;; KLUDGE: We implicitly exclude the possibility that the variable
+ ;; could actually be NULL, but the man page for dlsym(3)
+ ;; recommends doing a more careful test. -- WHN 20000825
+ (let ((possible-result (sap-int (dlsym table symbol))))
+ (unless (zerop possible-result)
+ (return possible-result)))))
+
+;;; code partially ported from CMU CL to SBCL, but needs RUN-PROGRAM
+#|
+(defun load-foreign (files &key
+ (libraries '("-lc"))
+ (base-file nil)
+ ;; Note: Since SBCL has no *ENVIRONMENT-LIST*
+ ;; variable, if this code is ever restored,
+ ;; the default should be taken from the alien
+ ;; "environ" variable.
+ ,, ; do it!
+ (env sb-ext:*environment-list*))
+ #+sb-doc
+ "LOAD-FOREIGN loads a list of C object files into a running Lisp. The FILES
+ argument should be a single file or a list of files. The files may be
+ specified as namestrings or as pathnames. The libraries argument should be a
+ list of library files as would be specified to ld. They will be searched in
+ the order given. The default is just \"-lc\", i.e., the C library. The
+ base-file argument is used to specify a file to use as the starting place for
+ defined symbols. The default is the C start up code for Lisp. The ENV
+ argument is the Unix environment variable definitions for the invocation of
+ the linker. The default is the environment passed to Lisp."
+ ;; Note: dlopen() remembers the name of an object, when dlopen()ing
+ ;; the same name twice, the old object is reused.
+ (declare (ignore base-file))
+ (let ((output-file (pick-temporary-file-name
+ (concatenate 'string "/tmp/~D~C" (string (gensym)))))
+ (error-output (make-string-output-stream)))
+
+ (/show "running" *dso-linker*)
+ (force-output)
+ (unwind-protect
+ (let ((proc (sb-ext:run-program
+ *dso-linker*
+ (append *dso-linker-options*
+ (list output-file)
+ (append (mapcar #'(lambda (name)
+ (unix-namestring name nil))
+ (if (atom files)
+ (list files)
+ files))
+ libraries))
+ :env env
+ :input nil
+ :output error-output
+ :error :output)))
+ (unless proc
+ (error "could not run ~A" *dso-linker*))
+ (unless (zerop (sb-ext:process-exit-code proc))
+ (sb-sys:serve-all-events 0)
+ (error "~A failed:~%~A" *dso-linker*
+ (get-output-stream-string error-output)))
+ (load-1-foreign output-file))
+ #-sb-show (sb-unix:unix-unlink output-file)
+ #+sb-show (/show "not unlinking" output-file)))) ; so we can look at it
+|#
+
+) ; PROGN
--- /dev/null
+;;; time printing routines built upon the Common Lisp FORMAT function
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!EXT")
+
+(file-comment
+ "$Header$")
+
+(defconstant abbrev-weekday-table
+ '#("Mon" "Tue" "Wed" "Thu" "Fri" "Sat" "Sun"))
+
+(defconstant long-weekday-table
+ '#("Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday"
+ "Sunday"))
+
+(defconstant abbrev-month-table
+ '#("Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug" "Sep" "Oct" "Nov"
+ "Dec"))
+
+(defconstant long-month-table
+ '#("January" "February" "March" "April" "May" "June" "July" "August"
+ "September" "October" "November" "December"))
+
+;;; The timezone-table is incomplete but workable.
+
+(defconstant timezone-table
+ '#("GMT" "" "" "" "" "EST" "CST" "MST" "PST"))
+
+(defconstant daylight-table
+ '#(nil nil nil nil nil "EDT" "CDT" "MDT" "PDT"))
+
+;;; Valid-Destination-P ensures the destination stream is okay
+;;; for the Format function.
+
+(defun valid-destination-p (destination)
+ (or (not destination)
+ (eq destination 't)
+ (streamp destination)
+ (and (stringp destination)
+ (array-has-fill-pointer-p destination))))
+
+;;; Format-Universal-Time - External.
+
+;;; CMU CL made the default style :SHORT here. I've changed that to :LONG, on
+;;; the theory that since the 8/7/1999 style is hard to decode unambiguously,
+;;; you should have to ask for it explicitly. (I prefer YYYYMMDD myself, since
+;;; it sorts properly.:-) -- WHN 19990831
+;;;
+;;; FIXME: On the CMU CL mailing list 30 Jan 2000, Pierre Mai suggested
+;;; OTOH it probably wouldn't be a major problem to change compile-file to
+;;; use for example :long, so that the output would be Month DD, YYYY, or
+;;; even better to extend format-universal-time with a flag to output ISO
+;;; 8601 formats (like e.g. :iso-8601 and :iso-8601-short) and migrate
+;;; slowly towards ISO dates in the user code...
+;;; The :ISO-8601 and :ISO-8601-SHORT options sound sensible to me. Maybe
+;;; someone will do them for CMU CL and we can steal them here.
+(defun format-universal-time (destination universal-time
+ &key
+ (timezone nil)
+ (style :long)
+ (date-first t)
+ (print-seconds t)
+ (print-meridian t)
+ (print-timezone t)
+ (print-weekday t))
+ #!+sb-doc
+ "Format-Universal-Time formats a string containing the time and date
+ given by universal-time in a common manner. The destination is any
+ destination which can be accepted by the Format function. The
+ timezone keyword is an integer specifying hours west of Greenwich.
+ The style keyword can be :SHORT (numeric date), :LONG (months and
+ weekdays expressed as words), :ABBREVIATED (like :long but words are
+ abbreviated), or :GOVERNMENT (of the form \"XX Month XXXX XX:XX:XX\")
+ The keyword argument DATE-FIRST, if nil, will print the time first instead
+ of the date (the default). The PRINT- keywords, if nil, inhibit
+ the printing of the obvious part of the time/date."
+ (unless (valid-destination-p destination)
+ (error "~A: Not a valid format destination." destination))
+ (unless (integerp universal-time)
+ (error "~A: Universal-Time should be an integer." universal-time))
+ (when timezone
+ (unless (and (rationalp timezone) (<= -24 timezone 24))
+ (error "~A: Timezone should be a rational between -24 and 24." timezone))
+ (unless (zerop (rem timezone 1/3600))
+ (error "~A: Timezone is not a second (1/3600) multiple." timezone)))
+
+ (multiple-value-bind (secs mins hours day month year dow dst tz)
+ (if timezone
+ (decode-universal-time universal-time timezone)
+ (decode-universal-time universal-time))
+ (declare (fixnum secs mins hours day month year dow))
+ (let ((time-string "~2,'0D:~2,'0D")
+ (date-string
+ (case style
+ (:short "~D/~D/~D") ;; MM/DD/Y
+ ((:abbreviated :long) "~A ~D, ~D") ;; Month DD, Y
+ (:government "~2,'0D ~:@(~A~) ~D") ;; DD MON Y
+ (t
+ (error "~A: Unrecognized :style keyword value." style))))
+ (time-args
+ (list mins (max (mod hours 12) (1+ (mod (1- hours) 12)))))
+ (date-args (case style
+ (:short
+ (list month day year))
+ (:abbreviated
+ (list (svref abbrev-month-table (1- month)) day year))
+ (:long
+ (list (svref long-month-table (1- month)) day year))
+ (:government
+ (list day (svref abbrev-month-table (1- month))
+ year)))))
+ (declare (simple-string time-string date-string))
+ (when print-weekday
+ (push (case style
+ ((:short :long) (svref long-weekday-table dow))
+ (:abbreviated (svref abbrev-weekday-table dow))
+ (:government (svref abbrev-weekday-table dow)))
+ date-args)
+ (setq date-string
+ (concatenate 'simple-string "~A, " date-string)))
+ (when (or print-seconds (eq style :government))
+ (push secs time-args)
+ (setq time-string
+ (concatenate 'simple-string time-string ":~2,'0D")))
+ (when print-meridian
+ (push (signum (floor hours 12)) time-args)
+ (setq time-string
+ (concatenate 'simple-string time-string " ~[AM~;PM~]")))
+ (apply #'format destination
+ (if date-first
+ (concatenate 'simple-string date-string " " time-string
+ (if print-timezone " ~A"))
+ (concatenate 'simple-string time-string " " date-string
+ (if print-timezone " ~A")))
+ (if date-first
+ (nconc date-args (nreverse time-args)
+ (if print-timezone
+ (list (timezone-name dst tz))))
+ (nconc (nreverse time-args) date-args
+ (if print-timezone
+ (list (timezone-name dst tz)))))))))
+
+(defun timezone-name (dst tz)
+ (if (and (integerp tz)
+ (or (and dst (= tz 0))
+ (<= 5 tz 8)))
+ (svref (if dst daylight-table timezone-table) tz)
+ (multiple-value-bind (rest seconds) (truncate (* tz 60 60) 60)
+ (multiple-value-bind (hours minutes) (truncate rest 60)
+ (format nil "[~C~D~@[~*:~2,'0D~@[~*:~2,'0D~]~]]"
+ (if (minusp tz) #\- #\+)
+ (abs hours)
+ (not (and (zerop minutes) (zerop seconds)))
+ (abs minutes)
+ (not (zerop seconds))
+ (abs seconds))))))
+
+;;; Format-Decoded-Time - External.
+(defun format-decoded-time (destination seconds minutes hours
+ day month year
+ &key (timezone nil)
+ (style :short)
+ (date-first t)
+ (print-seconds t)
+ (print-meridian t)
+ (print-timezone t)
+ (print-weekday t))
+ #!+sb-doc
+ "Format-Decoded-Time formats a string containing decoded-time
+ expressed in a humanly-readable manner. The destination is any
+ destination which can be accepted by the Format function. The
+ timezone keyword is an integer specifying hours west of Greenwich.
+ The style keyword can be :short (numeric date), :long (months and
+ weekdays expressed as words), or :abbreviated (like :long but words are
+ abbreviated). The keyword date-first, if nil, will cause the time
+ to be printed first instead of the date (the default). The print-
+ keywords, if nil, inhibit the printing of certain semi-obvious
+ parts of the string."
+ (unless (valid-destination-p destination)
+ (error "~A: Not a valid format destination." destination))
+ (unless (and (integerp seconds) (<= 0 seconds 59))
+ (error "~A: Seconds should be an integer between 0 and 59." seconds))
+ (unless (and (integerp minutes) (<= 0 minutes 59))
+ (error "~A: Minutes should be an integer between 0 and 59." minutes))
+ (unless (and (integerp hours) (<= 0 hours 23))
+ (error "~A: Hours should be an integer between 0 and 23." hours))
+ (unless (and (integerp day) (<= 1 day 31))
+ (error "~A: Day should be an integer between 1 and 31." day))
+ (unless (and (integerp month) (<= 1 month 12))
+ (error "~A: Month should be an integer between 1 and 12." month))
+ (unless (and (integerp year) (plusp year))
+ (error "~A: Hours should be an non-negative integer." year))
+ (when timezone
+ (unless (and (integerp timezone) (<= 0 timezone 32))
+ (error "~A: Timezone should be an integer between 0 and 32."
+ timezone)))
+ (format-universal-time destination
+ (encode-universal-time seconds minutes hours day month year)
+ :timezone timezone :style style :date-first date-first
+ :print-seconds print-seconds :print-meridian print-meridian
+ :print-timezone print-timezone :print-weekday print-weekday))
--- /dev/null
+;;;; garbage collection and allocation-related code
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!KERNEL")
+
+(file-comment
+ "$Header$")
+\f
+;;;; DYNAMIC-USAGE and friends
+
+(declaim (special *read-only-space-free-pointer*
+ *static-space-free-pointer*))
+
+(eval-when (:compile-toplevel :execute)
+ (sb!xc:defmacro def-c-var-frob (lisp-fun c-var-name)
+ `(progn
+ #!-sb-fluid (declaim (inline ,lisp-fun))
+ (defun ,lisp-fun ()
+ (sb!alien:extern-alien ,c-var-name (sb!alien:unsigned 32))))))
+
+(def-c-var-frob read-only-space-start "read_only_space")
+(def-c-var-frob static-space-start "static_space")
+(def-c-var-frob dynamic-0-space-start "dynamic_0_space")
+(def-c-var-frob dynamic-1-space-start "dynamic_1_space")
+(def-c-var-frob control-stack-start "control_stack")
+#!+x86 (def-c-var-frob control-stack-end "control_stack_end")
+(def-c-var-frob binding-stack-start "binding_stack")
+(def-c-var-frob current-dynamic-space-start "current_dynamic_space")
+
+#!-sb-fluid (declaim (inline dynamic-usage))
+#!-(or cgc gencgc)
+(defun dynamic-usage ()
+ (the (unsigned-byte 32)
+ (- (sb!sys:sap-int (sb!c::dynamic-space-free-pointer))
+ (current-dynamic-space-start))))
+#!+(or cgc gencgc)
+(def-c-var-frob dynamic-usage "bytes_allocated")
+
+(defun static-space-usage ()
+ (- (* sb!impl::*static-space-free-pointer* sb!vm:word-bytes)
+ (static-space-start)))
+
+(defun read-only-space-usage ()
+ (- (* sb!impl::*read-only-space-free-pointer* sb!vm:word-bytes)
+ (read-only-space-start)))
+
+(defun control-stack-usage ()
+ #!-x86 (- (sb!sys:sap-int (sb!c::control-stack-pointer-sap))
+ (control-stack-start))
+ #!+x86 (- (control-stack-end)
+ (sb!sys:sap-int (sb!c::control-stack-pointer-sap))))
+
+(defun binding-stack-usage ()
+ (- (sb!sys:sap-int (sb!c::binding-stack-pointer-sap)) (binding-stack-start)))
+
+(defun current-dynamic-space ()
+ (let ((start (current-dynamic-space-start)))
+ (cond ((= start (dynamic-0-space-start))
+ 0)
+ ((= start (dynamic-1-space-start))
+ 1)
+ (t
+ (error "Oh no! The current dynamic space is missing!")))))
+\f
+;;;; ROOM
+
+(defun room-minimal-info ()
+ (format t "Dynamic Space Usage: ~10:D bytes.~%" (dynamic-usage))
+ (format t "Read-Only Space Usage: ~10:D bytes.~%" (read-only-space-usage))
+ (format t "Static Space Usage: ~10:D bytes.~%" (static-space-usage))
+ (format t "Control Stack Usage: ~10:D bytes.~%" (control-stack-usage))
+ (format t "Binding Stack Usage: ~10:D bytes.~%" (binding-stack-usage))
+ (format t "The current dynamic space is ~D.~%" (current-dynamic-space))
+ (format t "Garbage collection is currently ~:[enabled~;DISABLED~].~%"
+ *gc-inhibit*))
+
+(defun room-intermediate-info ()
+ (room-minimal-info)
+ (sb!vm:memory-usage :count-spaces '(:dynamic)
+ :print-spaces t
+ :cutoff 0.05s0
+ :print-summary nil))
+
+(defun room-maximal-info ()
+ (room-minimal-info)
+ (sb!vm:memory-usage :count-spaces '(:static :dynamic))
+ (sb!vm:instance-usage :dynamic :top-n 10)
+ (sb!vm:instance-usage :static :top-n 10))
+
+(defun room (&optional (verbosity :default))
+ #!+sb-doc
+ "Prints to *STANDARD-OUTPUT* information about the state of internal
+ storage and its management. The optional argument controls the
+ verbosity of ROOM. If it is T, ROOM prints out a maximal amount of
+ information. If it is NIL, ROOM prints out a minimal amount of
+ information. If it is :DEFAULT or it is not supplied, ROOM prints out
+ an intermediate amount of information. See also VM:MEMORY-USAGE and
+ VM:INSTANCE-USAGE for finer report control."
+ (fresh-line)
+ (ecase verbosity
+ ((t)
+ (room-maximal-info))
+ ((nil)
+ (room-minimal-info))
+ (:default
+ (room-intermediate-info)))
+ (values))
+\f
+;;;; GET-BYTES-CONSED
+
+;;; internal state
+(defvar *last-bytes-in-use* nil)
+(defvar *total-bytes-consed* 0)
+(declaim (type (or index null) *last-bytes-in-use*))
+(declaim (type integer *total-bytes-consed*))
+
+(declaim (ftype (function () unsigned-byte) get-bytes-consed))
+(defun get-bytes-consed ()
+ #!+sb-doc
+ "Returns the number of bytes consed since the first time this function
+ was called. The first time it is called, it returns zero."
+ (declare (optimize (speed 3) (safety 0)))
+ (cond ((null *last-bytes-in-use*)
+ (setq *last-bytes-in-use* (dynamic-usage))
+ (setq *total-bytes-consed* 0))
+ (t
+ (let ((bytes (dynamic-usage)))
+ (incf *total-bytes-consed*
+ (the index (- bytes *last-bytes-in-use*)))
+ (setq *last-bytes-in-use* bytes))))
+ *total-bytes-consed*)
+\f
+;;;; variables and constants
+
+;;; the default value of *BYTES-CONSED-BETWEEN-GCS* and *GC-TRIGGER*
+(defconstant default-bytes-consed-between-gcs 2000000)
+
+;;; This variable is the user-settable variable that specifies the
+;;; minimum amount of dynamic space which must be consed before a GC
+;;; will be triggered.
+;;;
+;;; Unlike CMU CL, we don't export this variable. (There's no need to, since
+;;; the BYTES-CONSED-BETWEEN-GCS function is SETFable.)
+(defvar *bytes-consed-between-gcs* default-bytes-consed-between-gcs
+ #!+sb-doc
+ "This number specifies the minimum number of bytes of dynamic space
+ that must be consed before the next GC will occur.")
+(declaim (type index *bytes-consed-between-gcs*))
+
+;;;; GC hooks
+
+;;; These variables are a list of functions which are run before and
+;;; after garbage collection occurs.
+(defvar *before-gc-hooks* nil ; actually initialized in cold init
+ #!+sb-doc
+ "A list of functions that are called before garbage collection occurs.
+ The functions should take no arguments.")
+(defvar *after-gc-hooks* nil ; actually initialized in cold init
+ #!+sb-doc
+ "A list of functions that are called after garbage collection occurs.
+ The functions should take no arguments.")
+
+;;; This hook is invoked whenever SUB-GC intends to GC (unless the GC
+;;; was explicitly forced by calling SB!EXT:GC). If the hook function
+;;; returns NIL then the GC procedes; otherwise, the GC is inhibited and
+;;; *GC-INHIBIT* and *NEED-TO-COLLECT-GARBAGE* are left bound to T.
+;;; Presumably someone will call GC-ON later to collect the garbage.
+(defvar *gc-inhibit-hook* nil
+ #!+sb-doc
+ "Should be bound to a function or NIL. If it is a function, this
+ function should take one argument, the current amount of dynamic
+ usage. The function should return NIL if garbage collection should
+ continue and non-NIL if it should be inhibited. Use with caution.")
+
+(defvar *gc-verbose* nil ; (actually initialized in cold init)
+ #!+sb-doc
+ "Should low-level GC functions produce verbose diagnostic output?")
+
+(defvar *gc-notify-stream* nil ; (actually initialized in cold init)
+ #!+sb-doc
+ "When non-NIL, this must be a STREAM; and the functions bound to
+ *GC-NOTIFY-BEFORE* and *GC-NOTIFY-AFTER* are called with the
+ STREAM value before and after a garbage collection occurs
+ respectively.")
+
+(defvar *gc-run-time* 0
+ #!+sb-doc
+ "The total CPU time spent doing garbage collection (as reported by
+ GET-INTERNAL-RUN-TIME.)")
+
+(declaim (type index *gc-run-time*))
+
+;;; Internal trigger. When the dynamic usage increases beyond this
+;;; amount, the system notes that a garbage collection needs to occur by
+;;; setting *NEED-TO-COLLECT-GARBAGE* to T. It starts out as NIL meaning
+;;; nobody has figured out what it should be yet.
+(defvar *gc-trigger* nil)
+
+(declaim (type (or index null) *gc-trigger*))
+
+;;; On the RT, we store the GC trigger in a ``static'' symbol instead of
+;;; letting magic C code handle it. It gets initialized by the startup
+;;; code. The X86 port defines this here because it uses the `ibmrt'
+;;; feature in the C code for allocation and binding stack access and
+;;; a lot of stuff wants this INTERNAL_GC_TRIGGER available as well.
+#!+(or ibmrt x86)
+(defvar sb!vm::*internal-gc-trigger*)
+
+;;;; The following specials are used to control when garbage collection
+;;;; occurs.
+
+;;; When non-NIL, inhibits garbage collection.
+(defvar *gc-inhibit*) ; initialized in cold init
+
+;;; This flag is used to prevent recursive entry into the garbage
+;;; collector.
+(defvar *already-maybe-gcing*) ; initialized in cold init
+
+;;; When T, indicates that the dynamic usage has exceeded the value
+;;; *GC-TRIGGER*.
+(defvar *need-to-collect-garbage* nil) ; initialized in cold init
+\f
+(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.~%"
+ bytes-in-use)
+ (finish-output notify-stream))
+(defparameter *gc-notify-before* #'default-gc-notify-before
+ #!+sb-doc
+ "This function bound to this variable is invoked before GC'ing (unless
+ *GC-NOTIFY-STREAM* is NIL) with the value of *GC-NOTIFY-STREAM* and
+ current amount of dynamic usage (in bytes). It should notify the
+ user that the system is going to GC.")
+
+(defun default-gc-notify-after (notify-stream
+ bytes-retained
+ bytes-freed
+ new-trigger)
+ (declare (type stream notify-stream))
+ (format notify-stream
+ "~&; GC has finished with ~:D bytes in use (~:D bytes freed).~%"
+ bytes-retained
+ bytes-freed)
+ (format notify-stream
+ "~&; The new GC trigger is ~:D bytes.~%"
+ new-trigger)
+ (finish-output notify-stream))
+(defparameter *gc-notify-after* #'default-gc-notify-after
+ #!+sb-doc
+ "The function bound to this variable is invoked after GC'ing (unless
+ *GC-VERBOSE* is NIL) with the value of *GC-NOTIFY-STREAM*,
+ the amount of dynamic usage (in bytes) now free, the number of
+ bytes freed by the GC, and the new GC trigger threshold. The function
+ should notify the user that the system has finished GC'ing.")
+\f
+;;;; internal GC
+
+(sb!alien:def-alien-routine collect-garbage sb!c-call:int
+ #!+gencgc (last-gen sb!c-call:int))
+
+#!-ibmrt
+(sb!alien:def-alien-routine set-auto-gc-trigger sb!c-call:void
+ (dynamic-usage sb!c-call:unsigned-long))
+
+#!+ibmrt
+(defun set-auto-gc-trigger (bytes)
+ (let ((words (ash (+ (current-dynamic-space-start) bytes) -2)))
+ (unless (and (fixnump words) (plusp words))
+ (clear-auto-gc-trigger)
+ (warn "attempt to set GC trigger to something bogus: ~S" bytes))
+ (setf %rt::*internal-gc-trigger* words)))
+
+#!-ibmrt
+(sb!alien:def-alien-routine clear-auto-gc-trigger sb!c-call:void)
+
+#!+ibmrt
+(defun clear-auto-gc-trigger ()
+ (setf %rt::*internal-gc-trigger* -1))
+
+;;; This variable contains the function that does the real GC. This is
+;;; for low-level GC experimentation. Do not touch it if you do not
+;;; know what you are doing.
+(defvar *internal-gc* #'collect-garbage)
+\f
+;;;; SUB-GC
+
+;;; Used to carefully invoke hooks.
+(eval-when (:compile-toplevel :execute)
+ (sb!xc:defmacro carefully-funcall (function &rest args)
+ `(handler-case (funcall ,function ,@args)
+ (error (cond)
+ (warn "(FUNCALL ~S~{ ~S~}) lost:~%~A" ',function ',args cond)
+ nil))))
+
+;;; SUB-GC decides when and if to do a garbage collection. The
+;;; VERBOSE-P flag controls whether or not the notify functions are
+;;; called. The FORCE-P flags controls if a GC should occur even if
+;;; the dynamic usage is not greater than *GC-TRIGGER*.
+;;;
+;;; For GENCGC all generations < GEN will be GC'ed.
+;;;
+;;; FIXME: The VERBOSE-P stuff is no longer used.
+(defun sub-gc (&key (verbose-p *gc-verbose*) force-p #!+gencgc (gen 0))
+ (/show0 "entering SUB-GC")
+ (unless *already-maybe-gcing*
+ (/show0 "not *ALREADY-MAYBE-GCING*")
+ (let* ((*already-maybe-gcing* t)
+ (start-time (get-internal-run-time))
+ (pre-gc-dyn-usage (dynamic-usage)))
+ (unless (integerp (symbol-value '*bytes-consed-between-gcs*))
+ ;; The noise w/ symbol-value above is to keep the compiler
+ ;; from optimizing the test away because of the type declaim
+ ;; for *bytes-consed-between-gcs*.
+ ;;
+ ;; FIXME: I'm inclined either to get rid of the DECLAIM or to
+ ;; trust it, instead of doing this weird hack. It's not
+ ;; particularly trustable, since (SETF
+ ;; *BYTES-CONSED-BETWEEN-GCS* 'SEVEN) works. But it's also not
+ ;; very nice to have the type of the variable specified in two
+ ;; places which can (and in CMU CL 2.4.8 did, INTEGER vs.
+ ;; INDEX) drift apart. So perhaps we should just add a note to
+ ;; the variable documentation for *BYTES-CONSED-BETWEEN-GCS*
+ ;; that it must be an INDEX, and remove the DECLAIM. Or we
+ ;; could make a SETFable (BYTES-CONSED-BETWEEN-GCS) function
+ ;; and enforce the typing that way. And in fact the SETFable
+ ;; function already exists, so all we need do is make the
+ ;; variable private, and then we can trust the DECLAIM.
+ (warn "The value of *BYTES-CONSED-BETWEEN-GCS*, ~S, is not an ~
+ integer. Resetting it to ~D."
+ *bytes-consed-between-gcs*
+ default-bytes-consed-between-gcs)
+ (setf *bytes-consed-between-gcs* default-bytes-consed-between-gcs))
+ (when (and *gc-trigger* (> pre-gc-dyn-usage *gc-trigger*))
+ (/show0 "setting *NEED-TO-COLLECT-GARBAGE* to T")
+ (setf *need-to-collect-garbage* t))
+ (when (or force-p
+ (and *need-to-collect-garbage* (not *gc-inhibit*)))
+ (/show0 "Evidently we ought to collect garbage..")
+ (when (and (not force-p)
+ *gc-inhibit-hook*
+ (carefully-funcall *gc-inhibit-hook* pre-gc-dyn-usage))
+ (/show0 "..but we're inhibited.")
+ (setf *gc-inhibit* t)
+ (return-from sub-gc nil))
+ ;; KLUDGE: Wow, we really mask interrupts all the time we're
+ ;; collecting garbage? That seems like a long time.. -- WHN 19991129
+ (without-interrupts
+ ;; FIXME: We probably shouldn't do this evil thing to
+ ;; *STANDARD-OUTPUT* in a binding which is wrapped around
+ ;; calls to user-settable GC hook functions.
+ (let ((*standard-output* *terminal-io*))
+ (when *gc-notify-stream*
+ (/show0 "doing the *GC-NOTIFY-BEFORE* thing")
+ (if (streamp *gc-notify-stream*)
+ (carefully-funcall *gc-notify-before*
+ *gc-notify-stream*
+ pre-gc-dyn-usage)
+ (warn
+ "*GC-NOTIFY-STREAM* is set, but not a STREAM -- ignored.")))
+ (dolist (hook *before-gc-hooks*)
+ (/show0 "doing a hook from *BEFORE-GC-HOOKS*")
+ (carefully-funcall hook))
+ (when *gc-trigger*
+ (clear-auto-gc-trigger))
+ (/show0 "FUNCALLing *INTERNAL-GC*, one way or another")
+ #!-gencgc (funcall *internal-gc*)
+ ;; FIXME: This EQ test is pretty gross. Among its other
+ ;; nastinesses, it looks as though it could break if we
+ ;; recompile COLLECT-GARBAGE.
+ #!+gencgc (if (eq *internal-gc* #'collect-garbage)
+ (funcall *internal-gc* gen)
+ (funcall *internal-gc*))
+ (/show0 "back from FUNCALL to *INTERNAL-GC*")
+ (let* ((post-gc-dyn-usage (dynamic-usage))
+ (bytes-freed (- pre-gc-dyn-usage post-gc-dyn-usage)))
+ (when *last-bytes-in-use*
+ (incf *total-bytes-consed*
+ (- pre-gc-dyn-usage *last-bytes-in-use*))
+ (setq *last-bytes-in-use* post-gc-dyn-usage))
+ (setf *need-to-collect-garbage* nil)
+ (let ((new-gc-trigger (+ post-gc-dyn-usage
+ *bytes-consed-between-gcs*)))
+ (setf *gc-trigger* new-gc-trigger))
+ (set-auto-gc-trigger *gc-trigger*)
+ (dolist (hook *after-gc-hooks*)
+ (/show0 "doing a hook from *AFTER-GC--HOOKS*")
+ ;; FIXME: This hook should be called with the
+ ;; same kind of information as *GC-NOTIFY-AFTER*.
+ ;; In particular, it would be nice for the
+ ;; hook function to be able to adjust *GC-TRIGGER*
+ ;; intelligently to e.g. 108% of total memory usage.
+ (carefully-funcall hook))
+ (when *gc-notify-stream*
+ (/show0 "doing the *GC-NOTIFY-AFTER* thing")
+ (if (streamp *gc-notify-stream*)
+ (carefully-funcall *gc-notify-after*
+ *gc-notify-stream*
+ post-gc-dyn-usage
+ bytes-freed
+ *gc-trigger*)
+ (warn
+ "*GC-NOTIFY-STREAM* is set, but not a stream -- ignored.")))))
+ (/show0 "scrubbing control stack")
+ (scrub-control-stack)))
+ (/show0 "updating *GC-RUN-TIME*")
+ (incf *gc-run-time* (- (get-internal-run-time)
+ start-time))))
+ ;; FIXME: should probably return (VALUES), here and in RETURN-FROM
+ (/show "returning from tail of SUB-GC")
+ nil)
+
+;;; This routine is called by the allocation miscops to decide whether
+;;; a GC should occur. The argument, OBJECT, is the newly allocated
+;;; object which must be returned to the caller.
+(defun maybe-gc (&optional object)
+ (sub-gc)
+ object)
+
+;;; This is the user-advertised garbage collection function.
+;;;
+;;; KLUDGE: GC shouldn't have different parameters depending on what
+;;; garbage collector we use. -- WHN 19991020
+#!-gencgc
+(defun gc (&optional (verbose-p *gc-verbose*))
+ #!+sb-doc
+ "Initiates a garbage collection. VERBOSE-P controls
+ whether or not GC statistics are printed."
+ (sub-gc :verbose-p verbose-p :force-p t))
+#!+gencgc
+(defun gc (&key (verbose *gc-verbose*) (gen 0) (full nil))
+ #!+sb-doc
+ "Initiates a garbage collection. VERBOSE controls whether or not GC
+ statistics are printed. GEN controls the number of generations to garbage
+ collect."
+ ;; FIXME: The bare 6 here (corresponding to a bare 6 in
+ ;; the gencgc.c sources) is nasty.
+ (sub-gc :verbose-p verbose :force-p t :gen (if full 6 gen)))
+\f
+;;;; auxiliary functions
+
+(defun bytes-consed-between-gcs ()
+ #!+sb-doc
+ "Return the amount of memory that will be allocated before the next garbage
+ collection is initiated. This can be set with SETF."
+ *bytes-consed-between-gcs*)
+(defun (setf bytes-consed-between-gcs) (val)
+ ;; FIXME: Shouldn't this (and the DECLAIM for the underlying variable)
+ ;; be for a strictly positive number type, e.g.
+ ;; (AND (INTEGER 1) FIXNUM)?
+ (declare (type index val))
+ (let ((old *bytes-consed-between-gcs*))
+ (setf *bytes-consed-between-gcs* val)
+ (when *gc-trigger*
+ (setf *gc-trigger* (+ *gc-trigger* (- val old)))
+ (cond ((<= (dynamic-usage) *gc-trigger*)
+ (clear-auto-gc-trigger)
+ (set-auto-gc-trigger *gc-trigger*))
+ (t
+ (sb!sys:scrub-control-stack)
+ (sub-gc)))))
+ val)
+
+(defun gc-on ()
+ #!+sb-doc
+ "Enables the garbage collector."
+ (setq *gc-inhibit* nil)
+ (when *need-to-collect-garbage*
+ (sub-gc))
+ nil)
+
+(defun gc-off ()
+ #!+sb-doc
+ "Disables the garbage collector."
+ (setq *gc-inhibit* t)
+ nil)
+\f
+;;;; initialization stuff
+
+(defun gc-cold-init-or-reinit ()
+ (when *gc-trigger*
+ (if (< *gc-trigger* (dynamic-usage))
+ (sub-gc)
+ (set-auto-gc-trigger *gc-trigger*))))
--- /dev/null
+;;;; This file contains special proclamations for variables that are
+;;;; referenced in the code sources before they are defined. There are
+;;;; also function proclamations to make some common functions be
+;;;; known, avoiding work in recording the calls that are done before
+;;;; the definition.
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!IMPL")
+
+(file-comment
+ "$Header$")
+
+;;; FIXME: The COMMON-LISP specials here are already handled in
+;;; cl-specials.lisp.
+(declaim (special *keyword-package* *cl-package* *package* *query-io*
+ *terminal-io* *error-output* *trace-output* *debug-io*
+ *standard-input* *standard-output*
+ *evalhook* *applyhook*
+ original-lisp-environment
+ *read-default-float-format*
+ *read-suppress* *readtable* *print-base* *print-radix*
+ *print-length* *print-level* *print-pretty* *print-escape*
+ *print-case* *print-circle* *print-gensym* *print-array*
+ *standard-readtable*
+ sb!debug:*in-the-debugger*
+ sb!debug:*stack-top-hint*
+ sb!conditions::*handler-clusters*
+ sb!conditions::*restart-clusters*
+ *gc-inhibit* *need-to-collect-garbage*
+ *software-interrupt-vector* *load-verbose*
+ *load-print-stuff* *in-compilation-unit*
+ *aborted-compilation-unit-count* *char-name-alist*
+ *default-pathname-defaults* *beep-function*
+ *gc-notify-before* *gc-notify-after*
+ *posix-argv*))
+
+(declaim (ftype (function * *)
+ find-keyword keyword-test assert-error
+ assert-prompt check-type-error case-body-error print-object
+ describe-object sb!pcl::check-wrapper-validity))
+
+;;; Gray streams functions not defined until after PCL is loaded.
+(declaim (ftype (function * *)
+ stream-advance-to-column stream-clear-input
+ stream-clear-output stream-finish-output stream-force-output
+ stream-fresh-line stream-line-column stream-line-length
+ stream-listen stream-peek-char stream-read-byte
+ stream-read-char stream-read-char-no-hang stream-read-line
+ stream-start-line-p stream-terpri stream-unread-char
+ stream-write-byte stream-write-char stream-write-string))
--- /dev/null
+;;;; the needed-on-the-cross-compilation-host part of HASH-TABLE
+;;;; implementation
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!IMPL")
+
+(file-comment
+ "$Header$")
+
+;;; an internal tag for marking empty slots
+;;;
+;;; CMU CL 18b used :EMPTY for this purpose, which was somewhat nasty
+;;; since it's easily accessible to the user, so that e.g.
+;;; (DEFVAR *HT* (MAKE-HASH-TABLE))
+;;; (SETF (GETHASH :EMPTY *HT*) :EMPTY)
+;;; (MAPHASH (LAMBDA (K V) (FORMAT T "~&~S ~S~%" K V)))
+;;; gives no output -- oops!
+;;;
+;;; Note that as of version 0.6.6 there's a dependence in the gencgc.c
+;;; code on this value being a symbol. (This is only one of many nasty
+;;; dependencies between that code and this, alas.)
+(defconstant +empty-ht-slot+ '%empty-ht-slot%)
+;;; KLUDGE: Using a private symbol still leaves us vulnerable to users
+;;; getting nonconforming behavior by messing around with
+;;; DO-ALL-SYMBOLS. That seems like a fairly obscure problem, so for
+;;; now we just don't worry about it. If for some reason it becomes
+;;; worrisome and the magic value needs replacement:
+;;; * The replacement value needs to be LOADable with EQL preserved,
+;;; so that macroexpansion for WITH-HASH-TABLE-ITERATOR will work
+;;; when compiled into a file and loaded back into SBCL.
+;;; (Thus, just uninterning %EMPTY-HT-SLOT% doesn't work.)
+;;; * The replacement value needs to be acceptable to the
+;;; low-level gencgc.lisp hash table scavenging code.
+;;; * The change will break binary compatibility, since comparisons
+;;; against the value used at the time of compilation are wired
+;;; into FASL files.
+;;; -- WHN 20000622
+
+;;; HASH-TABLE is implemented as a STRUCTURE-OBJECT.
+(sb!xc:defstruct (hash-table (:constructor %make-hash-table))
+ ;; The type of hash table this is. Only used for printing and as part of
+ ;; the exported interface.
+ (test (required-argument) :type symbol :read-only t)
+ ;; The function used to compare two keys. Returns T if they are the same
+ ;; and NIL if not.
+ (test-fun (required-argument) :type function :read-only t)
+ ;; The function used to compute the hashing of a key. Returns two values:
+ ;; the index hashing and T if that might change with the next GC.
+ (hash-fun (required-argument) :type function :read-only t)
+ ;; How much to grow the hash table by when it fills up. If an index, then
+ ;; add that amount. If a floating point number, then multiple it by that.
+ (rehash-size (required-argument) :type (or index (single-float (1.0)))
+ :read-only t)
+ ;; How full the hash table has to get before we rehash.
+ (rehash-threshold (required-argument) :type (single-float (0.0) 1.0)
+ :read-only t)
+ ;; The number of entries before a rehash, just the one less than the
+ ;; size of the next-vector, hash-vector, and half the size of the
+ ;; kv-vector.
+ (rehash-trigger (required-argument) :type index)
+ ;; The current number of entries in the table.
+ (number-entries 0 :type index)
+ ;; The Key-Value pair vector.
+ (table (required-argument) :type simple-vector)
+ ;; True if this is a weak hash table, meaning that key->value mappings will
+ ;; disappear if there are no other references to the key. Note: this only
+ ;; matters if the hash function indicates that the hashing is EQ based.
+ (weak-p nil :type (member t nil))
+ ;; Index into the next-vector, chaining together buckets that need
+ ;; to be rehashed because their hashing is EQ based and the key has
+ ;; been moved by the garbage collector.
+ (needing-rehash 0 :type index)
+ ;; Index into the Next vector chaining together free slots in the KV
+ ;; vector.
+ (next-free-kv 0 :type index)
+ ;; The index vector. This may be larger than the hash size to help
+ ;; reduce collisions.
+ (index-vector (required-argument)
+ :type (simple-array (unsigned-byte 32) (*)))
+ ;; This table parallels the KV vector, and is used to chain together
+ ;; the hash buckets, the free list, and the values needing rehash, a
+ ;; slot will only ever be in one of these lists.
+ (next-vector (required-argument) :type (simple-array (unsigned-byte 32) (*)))
+ ;; This table parallels the KV table, and can be used to store the
+ ;; hash associated with the key, saving recalculation. Could be
+ ;; useful for EQL, and EQUAL hash tables. This table is not needed
+ ;; for EQ hash tables, and when present the value of #x8000000
+ ;; represents EQ-based hashing on the respective Key.
+ (hash-vector nil :type (or null (simple-array (unsigned-byte 32) (*)))))
+\f
+(defmacro-mundanely with-hash-table-iterator ((function hash-table) &body body)
+ #!+sb-doc
+ "WITH-HASH-TABLE-ITERATOR ((function hash-table) &body body)
+ provides a method of manually looping over the elements of a hash-table.
+ FUNCTION is bound to a generator-macro that, within the scope of the
+ invocation, returns one or three values. The first value tells whether
+ any objects remain in the hash table. When the first value is non-NIL,
+ the second and third values are the key and the value of the next object."
+ (let ((n-function (gensym "WITH-HASH-TABLE-ITERATOR-")))
+ `(let ((,n-function
+ (let* ((table ,hash-table)
+ (length (length (hash-table-next-vector table)))
+ (index 1))
+ (declare (type (mod #.(floor most-positive-fixnum 2)) index))
+ (labels
+ ((,function ()
+ ;; (We grab the table again on each iteration just in
+ ;; case it was rehashed by a PUTHASH.)
+ (let ((kv-vector (hash-table-table table)))
+ (do ()
+ ((>= index length) (values nil))
+ (let ((key (aref kv-vector (* 2 index)))
+ (value (aref kv-vector (1+ (* 2 index)))))
+ (incf index)
+ (unless (and (eq key '#.+empty-ht-slot+)
+ (eq value '#.+empty-ht-slot+))
+ (return (values t key value))))))))
+ #',function))))
+ (macrolet ((,function () '(funcall ,n-function)))
+ ,@body))))
--- /dev/null
+;;;; the part of the Alien implementation which is needed at
+;;;; cross-compilation time
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!ALIEN")
+
+(file-comment
+ "$Header$")
+\f
+;;;; utility functions
+
+(defun align-offset (offset alignment)
+ (let ((extra (rem offset alignment)))
+ (if (zerop extra) offset (+ offset (- alignment extra)))))
+
+(defun guess-alignment (bits)
+ (cond ((null bits) nil)
+ #!-x86 ((> bits 32) 64)
+ ((> bits 16) 32)
+ ((> bits 8) 16)
+ ((> bits 1) 8)
+ (t 1)))
+\f
+;;;; ALIEN-TYPE-INFO stuff
+
+(eval-when (:compile-toplevel :execute :load-toplevel)
+
+(defstruct alien-type-class
+ (name nil :type symbol)
+ (include nil :type (or null alien-type-class))
+ (unparse nil :type (or null function))
+ (type= nil :type (or null function))
+ (lisp-rep nil :type (or null function))
+ (alien-rep nil :type (or null function))
+ (extract-gen nil :type (or null function))
+ (deposit-gen nil :type (or null function))
+ (naturalize-gen nil :type (or null function))
+ (deport-gen nil :type (or null function))
+ ;; Cast?
+ (arg-tn nil :type (or null function))
+ (result-tn nil :type (or null function))
+ (subtypep nil :type (or null function)))
+(def!method print-object ((type-class alien-type-class) stream)
+ (print-unreadable-object (type-class stream :type t)
+ (prin1 (alien-type-class-name type-class) stream)))
+
+(defun alien-type-class-or-lose (name)
+ (or (gethash name *alien-type-classes*)
+ (error "no alien type class ~S" name)))
+
+(defun create-alien-type-class-if-necessary (name include)
+ (let ((old (gethash name *alien-type-classes*))
+ (include (and include (alien-type-class-or-lose include))))
+ (if old
+ (setf (alien-type-class-include old) include)
+ (setf (gethash name *alien-type-classes*)
+ (make-alien-type-class :name name :include include)))))
+
+(defconstant method-slot-alist
+ '((:unparse . alien-type-class-unparse)
+ (:type= . alien-type-class-type=)
+ (:subtypep . alien-type-class-subtypep)
+ (:lisp-rep . alien-type-class-lisp-rep)
+ (:alien-rep . alien-type-class-alien-rep)
+ (:extract-gen . alien-type-class-extract-gen)
+ (:deposit-gen . alien-type-class-deposit-gen)
+ (:naturalize-gen . alien-type-class-naturalize-gen)
+ (:deport-gen . alien-type-class-deport-gen)
+ ;; cast?
+ (:arg-tn . alien-type-class-arg-tn)
+ (:result-tn . alien-type-class-result-tn)))
+
+(defun method-slot (method)
+ (cdr (or (assoc method method-slot-alist)
+ (error "no method ~S" method))))
+
+) ; EVAL-WHEN
+
+;;; We define a keyword "BOA" constructor so that we can reference the slot
+;;; names in init forms.
+(def!macro def-alien-type-class ((name &key include include-args) &rest slots)
+ (let ((defstruct-name
+ (intern (concatenate 'string "ALIEN-" (symbol-name name) "-TYPE"))))
+ (multiple-value-bind (include include-defstruct overrides)
+ (etypecase include
+ (null
+ (values nil 'alien-type nil))
+ (symbol
+ (values
+ include
+ (intern (concatenate 'string
+ "ALIEN-" (symbol-name include) "-TYPE"))
+ nil))
+ (list
+ (values
+ (car include)
+ (intern (concatenate 'string
+ "ALIEN-" (symbol-name (car include)) "-TYPE"))
+ (cdr include))))
+ `(progn
+ (eval-when (:compile-toplevel :load-toplevel :execute)
+ (create-alien-type-class-if-necessary ',name ',(or include 'root)))
+ (def!struct (,defstruct-name
+ (:include ,include-defstruct
+ (:class ',name)
+ ,@overrides)
+ (:constructor
+ ,(intern (concatenate 'string "MAKE-"
+ (string defstruct-name)))
+ (&key class bits alignment
+ ,@(mapcar #'(lambda (x)
+ (if (atom x) x (car x)))
+ slots)
+ ,@include-args)))
+ ,@slots)))))
+
+(def!macro def-alien-type-method ((class method) lambda-list &rest body)
+ (let ((defun-name (intern (concatenate 'string
+ (symbol-name class)
+ "-"
+ (symbol-name method)
+ "-METHOD"))))
+ `(progn
+ (defun ,defun-name ,lambda-list
+ ,@body)
+ (setf (,(method-slot method) (alien-type-class-or-lose ',class))
+ #',defun-name))))
+
+(def!macro invoke-alien-type-method (method type &rest args)
+ (let ((slot (method-slot method)))
+ (once-only ((type type))
+ `(funcall (do ((class (alien-type-class-or-lose (alien-type-class ,type))
+ (alien-type-class-include class)))
+ ((null class)
+ (error "method ~S not defined for ~S"
+ ',method (alien-type-class ,type)))
+ (let ((fn (,slot class)))
+ (when fn
+ (return fn))))
+ ,type ,@args))))
+\f
+;;;; type parsing and unparsing
+
+;;; CMU CL used COMPILER-LET to bind *AUXILIARY-TYPE-DEFINITIONS*, and
+;;; COMPILER-LET is no longer supported by ANSI or SBCL. Instead, we
+;;; follow the suggestion in CLTL2 of using SYMBOL-MACROLET to achieve
+;;; a similar effect.
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defun auxiliary-type-definitions (env)
+ (multiple-value-bind (result expanded-p)
+ (sb!xc:macroexpand '&auxiliary-type-definitions& env)
+ (if expanded-p
+ result
+ ;; This is like having the global symbol-macro definition be
+ ;; NIL, but global symbol-macros make me vaguely queasy, so
+ ;; I do it this way instead.
+ nil))))
+
+;;; Process stuff in a new scope.
+(def!macro with-auxiliary-alien-types (env &body body)
+ ``(symbol-macrolet ((&auxiliary-type-definitions&
+ ,(append *new-auxiliary-types*
+ (auxiliary-type-definitions ,env))))
+ ,(let ((*new-auxiliary-types* nil))
+ ,@body)))
+
+;;; FIXME: Now that *NEW-AUXILIARY-TYPES* is born initialized to NIL,
+;;; we no longer need to make a distinction between this and
+;;; %PARSE-ALIEN-TYPE.
+(defun parse-alien-type (type env)
+ (declare (type sb!kernel:lexenv env))
+ #!+sb-doc
+ "Parse the list structure TYPE as an alien type specifier and return
+ the resultant ALIEN-TYPE structure."
+ (%parse-alien-type type env))
+
+(defun %parse-alien-type (type env)
+ (declare (type sb!kernel:lexenv env))
+ (if (consp type)
+ (let ((translator (info :alien-type :translator (car type))))
+ (unless translator
+ (error "unknown alien type: ~S" type))
+ (funcall translator type env))
+ (case (info :alien-type :kind type)
+ (:primitive
+ (let ((translator (info :alien-type :translator type)))
+ (unless translator
+ (error "no translator for primitive alien type ~S" type))
+ (funcall translator (list type) env)))
+ (:defined
+ (or (info :alien-type :definition type)
+ (error "no definition for alien type ~S" type)))
+ (:unknown
+ (error "unknown alien type: ~S" type)))))
+
+(defun auxiliary-alien-type (kind name env)
+ (declare (type sb!kernel:lexenv env))
+ (flet ((aux-defn-matches (x)
+ (and (eq (first x) kind) (eq (second x) name))))
+ (let ((in-auxiliaries
+ (or (find-if #'aux-defn-matches *new-auxiliary-types*)
+ (find-if #'aux-defn-matches (auxiliary-type-definitions env)))))
+ (if in-auxiliaries
+ (values (third in-auxiliaries) t)
+ (ecase kind
+ (:struct
+ (info :alien-type :struct name))
+ (:union
+ (info :alien-type :union name))
+ (:enum
+ (info :alien-type :enum name)))))))
+
+(defun (setf auxiliary-alien-type) (new-value kind name env)
+ (declare (type sb!kernel:lexenv env))
+ (flet ((aux-defn-matches (x)
+ (and (eq (first x) kind) (eq (second x) name))))
+ (when (find-if #'aux-defn-matches *new-auxiliary-types*)
+ (error "attempt to multiply define ~A ~S" kind name))
+ (when (find-if #'aux-defn-matches (auxiliary-type-definitions env))
+ (error "attempt to shadow definition of ~A ~S" kind name)))
+ (push (list kind name new-value) *new-auxiliary-types*)
+ new-value)
+
+(defun verify-local-auxiliaries-okay ()
+ (dolist (info *new-auxiliary-types*)
+ (destructuring-bind (kind name defn) info
+ (declare (ignore defn))
+ (when (ecase kind
+ (:struct
+ (info :alien-type :struct name))
+ (:union
+ (info :alien-type :union name))
+ (:enum
+ (info :alien-type :enum name)))
+ (error "attempt to shadow definition of ~A ~S" kind name)))))
+
+(defun unparse-alien-type (type)
+ #!+sb-doc
+ "Convert the alien-type structure TYPE back into a list specification of
+ the type."
+ (declare (type alien-type type))
+ (let ((*record-types-already-unparsed* nil))
+ (%unparse-alien-type type)))
+
+;;; Does all the work of UNPARSE-ALIEN-TYPE. It's separate because we
+;;; need to recurse inside the binding of
+;;; *RECORD-TYPES-ALREADY-UNPARSED*.
+(defun %unparse-alien-type (type)
+ (invoke-alien-type-method :unparse type))
+\f
+;;;; alien type defining stuff
+
+(def!macro def-alien-type-translator (name lambda-list &body body)
+ (let ((whole (gensym "WHOLE"))
+ (env (gensym "ENV"))
+ (defun-name (symbolicate "ALIEN-" name "-TYPE-TRANSLATOR")))
+ (multiple-value-bind (body decls docs)
+ (sb!kernel:parse-defmacro lambda-list whole body name
+ 'def-alien-type-translator
+ :environment env)
+ `(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defun ,defun-name (,whole ,env)
+ (declare (ignorable ,env))
+ ,@decls
+ (block ,name
+ ,body))
+ (%def-alien-type-translator ',name #',defun-name ,docs)))))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defun %def-alien-type-translator (name translator docs)
+ (declare (ignore docs))
+ (setf (info :alien-type :kind name) :primitive)
+ (setf (info :alien-type :translator name) translator)
+ (clear-info :alien-type :definition name)
+ #+nil
+ (setf (fdocumentation name 'alien-type) docs)
+ name))
+
+(def!macro def-alien-type (name type &environment env)
+ #!+sb-doc
+ "Define the alien type NAME to be equivalent to TYPE. Name may be NIL for
+ STRUCT and UNION types, in which case the name is taken from the type
+ specifier."
+ (with-auxiliary-alien-types env
+ (let ((alien-type (parse-alien-type type env)))
+ `(eval-when (:compile-toplevel :load-toplevel :execute)
+ ,@(when *new-auxiliary-types*
+ `((%def-auxiliary-alien-types ',*new-auxiliary-types*)))
+ ,@(when name
+ `((%def-alien-type ',name ',alien-type)))))))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defun %def-auxiliary-alien-types (types)
+ (dolist (info types)
+ (destructuring-bind (kind name defn) info
+ (macrolet ((frob (kind)
+ `(let ((old (info :alien-type ,kind name)))
+ (unless (or (null old) (alien-type-= old defn))
+ (warn
+ "redefining ~A ~S to be:~% ~S,~%was:~% ~S"
+ kind name defn old))
+ (setf (info :alien-type ,kind name) defn))))
+ (ecase kind
+ (:struct (frob :struct))
+ (:union (frob :union))
+ (:enum (frob :enum)))))))
+ (defun %def-alien-type (name new)
+ (ecase (info :alien-type :kind name)
+ (:primitive
+ (error "~S is a built-in alien type." name))
+ (:defined
+ (let ((old (info :alien-type :definition name)))
+ (unless (or (null old) (alien-type-= new old))
+ (warn "redefining ~S to be:~% ~S,~%was~% ~S"
+ name
+ (unparse-alien-type new)
+ (unparse-alien-type old)))))
+ (:unknown))
+ (setf (info :alien-type :definition name) new)
+ (setf (info :alien-type :kind name) :defined)
+ name))
+\f
+;;;; the root alien type
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (create-alien-type-class-if-necessary 'root nil))
+
+(def!struct (alien-type
+ (:make-load-form-fun sb!kernel:just-dump-it-normally)
+ (:constructor make-alien-type (&key class bits alignment)))
+ (class 'root :type symbol)
+ (bits nil :type (or null unsigned-byte))
+ (alignment (guess-alignment bits) :type (or null unsigned-byte)))
+(def!method print-object ((type alien-type) stream)
+ (print-unreadable-object (type stream :type t)
+ (prin1 (unparse-alien-type type) stream)))
+\f
+;;;; the SAP type
+
+(def-alien-type-class (system-area-pointer))
+
+(def-alien-type-translator system-area-pointer ()
+ (make-alien-system-area-pointer-type
+ :bits #!-alpha sb!vm:word-bits #!+alpha 64))
+
+(def-alien-type-method (system-area-pointer :unparse) (type)
+ (declare (ignore type))
+ 'system-area-pointer)
+
+(def-alien-type-method (system-area-pointer :lisp-rep) (type)
+ (declare (ignore type))
+ 'system-area-pointer)
+
+(def-alien-type-method (system-area-pointer :alien-rep) (type)
+ (declare (ignore type))
+ 'system-area-pointer)
+
+(def-alien-type-method (system-area-pointer :naturalize-gen) (type alien)
+ (declare (ignore type))
+ alien)
+
+(def-alien-type-method (system-area-pointer :deport-gen) (type object)
+ (declare (ignore type))
+ (/noshow "doing alien type method SYSTEM-AREA-POINTER :DEPORT-GEN" object)
+ object)
+
+(def-alien-type-method (system-area-pointer :extract-gen) (type sap offset)
+ (declare (ignore type))
+ `(sap-ref-sap ,sap (/ ,offset sb!vm:byte-bits)))
+\f
+;;;; the ALIEN-VALUE type
+
+(def-alien-type-class (alien-value :include system-area-pointer))
+
+(def-alien-type-method (alien-value :lisp-rep) (type)
+ (declare (ignore type))
+ nil)
+
+(def-alien-type-method (alien-value :naturalize-gen) (type alien)
+ `(%sap-alien ,alien ',type))
+
+(def-alien-type-method (alien-value :deport-gen) (type value)
+ (declare (ignore type))
+ (/noshow "doing alien type method ALIEN-VALUE :DEPORT-GEN" value)
+ `(alien-sap ,value))
+\f
+;;; HEAP-ALIEN-INFO -- defstruct.
+;;;
+;;; Information describing a heap-allocated alien.
+(def!struct (heap-alien-info
+ (:make-load-form-fun sb!kernel:just-dump-it-normally))
+ ;; The type of this alien.
+ (type (required-argument) :type alien-type)
+ ;; The form to evaluate to produce the SAP pointing to where in the heap
+ ;; it is.
+ (sap-form (required-argument)))
+(def!method print-object ((info heap-alien-info) stream)
+ (print-unreadable-object (info stream :type t)
+ (funcall (formatter "~S ~S")
+ stream
+ (heap-alien-info-sap-form info)
+ (unparse-alien-type (heap-alien-info-type info)))))
+\f
+;;;; Interfaces to the different methods
+
+(defun alien-type-= (type1 type2)
+ #!+sb-doc
+ "Return T iff TYPE1 and TYPE2 describe equivalent alien types."
+ (or (eq type1 type2)
+ (and (eq (alien-type-class type1)
+ (alien-type-class type2))
+ (invoke-alien-type-method :type= type1 type2))))
+
+(defun alien-subtype-p (type1 type2)
+ #!+sb-doc
+ "Return T iff the alien type TYPE1 is a subtype of TYPE2. Currently, the
+ only supported subtype relationships are is that any pointer type is a
+ subtype of (* t), and any array type first dimension will match
+ (array <eltype> nil ...). Otherwise, the two types have to be
+ ALIEN-TYPE-=."
+ (or (eq type1 type2)
+ (invoke-alien-type-method :subtypep type1 type2)))
+
+(defun compute-naturalize-lambda (type)
+ `(lambda (alien ignore)
+ (declare (ignore ignore))
+ ,(invoke-alien-type-method :naturalize-gen type 'alien)))
+
+(defun compute-deport-lambda (type)
+ (declare (type alien-type type))
+ (/noshow "entering COMPUTE-DEPORT-LAMBDA" type)
+ (multiple-value-bind (form value-type)
+ (invoke-alien-type-method :deport-gen type 'value)
+ `(lambda (value ignore)
+ (declare (type ,(or value-type
+ (compute-lisp-rep-type type)
+ `(alien ,type))
+ value)
+ (ignore ignore))
+ ,form)))
+
+(defun compute-extract-lambda (type)
+ `(lambda (sap offset ignore)
+ (declare (type system-area-pointer sap)
+ (type unsigned-byte offset)
+ (ignore ignore))
+ (naturalize ,(invoke-alien-type-method :extract-gen type 'sap 'offset)
+ ',type)))
+
+(defun compute-deposit-lambda (type)
+ (declare (type alien-type type))
+ `(lambda (sap offset ignore value)
+ (declare (type system-area-pointer sap)
+ (type unsigned-byte offset)
+ (ignore ignore))
+ (let ((value (deport value ',type)))
+ ,(invoke-alien-type-method :deposit-gen type 'sap 'offset 'value)
+ ;; Note: the reason we don't just return the pre-deported value
+ ;; is because that would inhibit any (deport (naturalize ...))
+ ;; optimizations that might have otherwise happen. Re-naturalizing
+ ;; the value might cause extra consing, but is flushable, so probably
+ ;; results in better code.
+ (naturalize value ',type))))
+
+(defun compute-lisp-rep-type (type)
+ (invoke-alien-type-method :lisp-rep type))
+
+(defun compute-alien-rep-type (type)
+ (invoke-alien-type-method :alien-rep type))
+\f
+;;;; default methods
+
+(def-alien-type-method (root :unparse) (type)
+ `(<unknown-alien-type> ,(type-of type)))
+
+(def-alien-type-method (root :type=) (type1 type2)
+ (declare (ignore type1 type2))
+ t)
+
+(def-alien-type-method (root :subtypep) (type1 type2)
+ (alien-type-= type1 type2))
+
+(def-alien-type-method (root :lisp-rep) (type)
+ (declare (ignore type))
+ nil)
+
+(def-alien-type-method (root :alien-rep) (type)
+ (declare (ignore type))
+ '*)
+
+(def-alien-type-method (root :naturalize-gen) (type alien)
+ (declare (ignore alien))
+ (error "cannot represent ~S typed aliens" type))
+
+(def-alien-type-method (root :deport-gen) (type object)
+ (declare (ignore object))
+ (error "cannot represent ~S typed aliens" type))
+
+(def-alien-type-method (root :extract-gen) (type sap offset)
+ (declare (ignore sap offset))
+ (error "cannot represent ~S typed aliens" type))
+
+(def-alien-type-method (root :deposit-gen) (type sap offset value)
+ `(setf ,(invoke-alien-type-method :extract-gen type sap offset) ,value))
+
+(def-alien-type-method (root :arg-tn) (type state)
+ (declare (ignore state))
+ (error "Aliens of type ~S cannot be passed as arguments to CALL-OUT."
+ (unparse-alien-type type)))
+
+(def-alien-type-method (root :result-tn) (type state)
+ (declare (ignore state))
+ (error "Aliens of type ~S cannot be returned from CALL-OUT."
+ (unparse-alien-type type)))
+\f
+;;;; the INTEGER type
+
+(def-alien-type-class (integer)
+ (signed t :type (member t nil)))
+
+(def-alien-type-translator signed (&optional (bits sb!vm:word-bits))
+ (make-alien-integer-type :bits bits))
+
+(def-alien-type-translator integer (&optional (bits sb!vm:word-bits))
+ (make-alien-integer-type :bits bits))
+
+(def-alien-type-translator unsigned (&optional (bits sb!vm:word-bits))
+ (make-alien-integer-type :bits bits :signed nil))
+
+(def-alien-type-method (integer :unparse) (type)
+ (list (if (alien-integer-type-signed type) 'signed 'unsigned)
+ (alien-integer-type-bits type)))
+
+(def-alien-type-method (integer :type=) (type1 type2)
+ (and (eq (alien-integer-type-signed type1)
+ (alien-integer-type-signed type2))
+ (= (alien-integer-type-bits type1)
+ (alien-integer-type-bits type2))))
+
+(def-alien-type-method (integer :lisp-rep) (type)
+ (list (if (alien-integer-type-signed type) 'signed-byte 'unsigned-byte)
+ (alien-integer-type-bits type)))
+
+(def-alien-type-method (integer :alien-rep) (type)
+ (list (if (alien-integer-type-signed type) 'signed-byte 'unsigned-byte)
+ (alien-integer-type-bits type)))
+
+(def-alien-type-method (integer :naturalize-gen) (type alien)
+ (declare (ignore type))
+ alien)
+
+(def-alien-type-method (integer :deport-gen) (type value)
+ (declare (ignore type))
+ value)
+
+(def-alien-type-method (integer :extract-gen) (type sap offset)
+ (declare (type alien-integer-type type))
+ (let ((ref-fun
+ (if (alien-integer-type-signed type)
+ (case (alien-integer-type-bits type)
+ (8 'signed-sap-ref-8)
+ (16 'signed-sap-ref-16)
+ (32 'signed-sap-ref-32)
+ #!+alpha (64 'signed-sap-ref-64))
+ (case (alien-integer-type-bits type)
+ (8 'sap-ref-8)
+ (16 'sap-ref-16)
+ (32 'sap-ref-32)
+ #!+alpha (64 'sap-ref-64)))))
+ (if ref-fun
+ `(,ref-fun ,sap (/ ,offset sb!vm:byte-bits))
+ (error "cannot extract ~D bit integers"
+ (alien-integer-type-bits type)))))
+\f
+;;;; the BOOLEAN type
+
+(def-alien-type-class (boolean :include integer :include-args (signed)))
+
+;;; FIXME: Check to make sure that we aren't attaching user-readable
+;;; stuff to CL:BOOLEAN in any way which impairs ANSI compliance.
+(def-alien-type-translator boolean (&optional (bits sb!vm:word-bits))
+ (make-alien-boolean-type :bits bits :signed nil))
+
+(def-alien-type-method (boolean :unparse) (type)
+ `(boolean ,(alien-boolean-type-bits type)))
+
+(def-alien-type-method (boolean :lisp-rep) (type)
+ (declare (ignore type))
+ `(member t nil))
+
+(def-alien-type-method (boolean :naturalize-gen) (type alien)
+ (declare (ignore type))
+ `(not (zerop ,alien)))
+
+(def-alien-type-method (boolean :deport-gen) (type value)
+ (declare (ignore type))
+ `(if ,value 1 0))
+\f
+;;;; the ENUM type
+
+(def-alien-type-class (enum :include (integer (:bits 32))
+ :include-args (signed))
+ name ; name of this enum (if any)
+ from ; alist from keywords to integers.
+ to ; alist or vector from integers to keywords.
+ kind ; Kind of from mapping, :vector or :alist.
+ offset) ; Offset to add to value for :vector from mapping.
+
+(def-alien-type-translator enum (&whole type
+ name
+ &rest mappings
+ &environment env)
+ (cond (mappings
+ (let ((result (parse-enum name mappings)))
+ (when name
+ (multiple-value-bind (old old-p)
+ (auxiliary-alien-type :enum name env)
+ (when old-p
+ (unless (alien-type-= result old)
+ (warn "redefining alien enum ~S" name))))
+ (setf (auxiliary-alien-type :enum name env) result))
+ result))
+ (name
+ (multiple-value-bind (result found)
+ (auxiliary-alien-type :enum name env)
+ (unless found
+ (error "unknown enum type: ~S" name))
+ result))
+ (t
+ (error "empty enum type: ~S" type))))
+
+(defun parse-enum (name elements)
+ (when (null elements)
+ (error "An enumeration must contain at least one element."))
+ (let ((min nil)
+ (max nil)
+ (from-alist ())
+ (prev -1))
+ (declare (list from-alist))
+ (dolist (el elements)
+ (multiple-value-bind (sym val)
+ (if (listp el)
+ (values (first el) (second el))
+ (values el (1+ prev)))
+ (setf prev val)
+ (unless (keywordp sym)
+ (error "The enumeration element ~S is not a keyword." sym))
+ (unless (integerp val)
+ (error "The element value ~S is not an integer." val))
+ (unless (and max (> max val)) (setq max val))
+ (unless (and min (< min val)) (setq min val))
+ (when (rassoc val from-alist)
+ (error "The element value ~S is used more than once." val))
+ (when (assoc sym from-alist :test #'eq)
+ (error "The enumeration element ~S is used more than once." sym))
+ (push (cons sym val) from-alist)))
+ (let* ((signed (minusp min))
+ (min-bits (if signed
+ (1+ (max (integer-length min)
+ (integer-length max)))
+ (integer-length max))))
+ (when (> min-bits 32)
+ (error "can't represent enums needing more than 32 bits"))
+ (setf from-alist (sort from-alist #'< :key #'cdr))
+ (cond
+ ;; If range is at least 20% dense, use vector mapping. Crossover
+ ;; point solely on basis of space would be 25%. Vector mapping
+ ;; is always faster, so give the benefit of the doubt.
+ ((< 0.2 (/ (float (length from-alist)) (float (- max min))))
+ ;; If offset is small and ignorable, ignore it to save time.
+ (when (< 0 min 10) (setq min 0))
+ (let ((to (make-array (1+ (- max min)))))
+ (dolist (el from-alist)
+ (setf (svref to (- (cdr el) min)) (car el)))
+ (make-alien-enum-type :name name :signed signed
+ :from from-alist :to to :kind
+ :vector :offset (- min))))
+ (t
+ (make-alien-enum-type :name name :signed signed
+ :from from-alist
+ :to (mapcar #'(lambda (x) (cons (cdr x) (car x)))
+ from-alist)
+ :kind :alist))))))
+
+(def-alien-type-method (enum :unparse) (type)
+ `(enum ,(alien-enum-type-name type)
+ ,@(let ((prev -1))
+ (mapcar #'(lambda (mapping)
+ (let ((sym (car mapping))
+ (value (cdr mapping)))
+ (prog1
+ (if (= (1+ prev) value)
+ sym
+ `(,sym ,value))
+ (setf prev value))))
+ (alien-enum-type-from type)))))
+
+(def-alien-type-method (enum :type=) (type1 type2)
+ (and (eq (alien-enum-type-name type1)
+ (alien-enum-type-name type2))
+ (equal (alien-enum-type-from type1)
+ (alien-enum-type-from type2))))
+
+(def-alien-type-method (enum :lisp-rep) (type)
+ `(member ,@(mapcar #'car (alien-enum-type-from type))))
+
+(def-alien-type-method (enum :naturalize-gen) (type alien)
+ (ecase (alien-enum-type-kind type)
+ (:vector
+ `(svref ',(alien-enum-type-to type)
+ (+ ,alien ,(alien-enum-type-offset type))))
+ (:alist
+ `(ecase ,alien
+ ,@(mapcar #'(lambda (mapping)
+ `(,(car mapping) ,(cdr mapping)))
+ (alien-enum-type-to type))))))
+
+(def-alien-type-method (enum :deport-gen) (type value)
+ `(ecase ,value
+ ,@(mapcar #'(lambda (mapping)
+ `(,(car mapping) ,(cdr mapping)))
+ (alien-enum-type-from type))))
+\f
+;;;; the FLOAT types
+
+(def-alien-type-class (float)
+ (type (required-argument) :type symbol))
+
+(def-alien-type-method (float :unparse) (type)
+ (alien-float-type-type type))
+
+(def-alien-type-method (float :lisp-rep) (type)
+ (alien-float-type-type type))
+
+(def-alien-type-method (float :alien-rep) (type)
+ (alien-float-type-type type))
+
+(def-alien-type-method (float :naturalize-gen) (type alien)
+ (declare (ignore type))
+ alien)
+
+(def-alien-type-method (float :deport-gen) (type value)
+ (declare (ignore type))
+ value)
+
+(def-alien-type-class (single-float :include (float (:bits 32))
+ :include-args (type)))
+
+(def-alien-type-translator single-float ()
+ (make-alien-single-float-type :type 'single-float))
+
+(def-alien-type-method (single-float :extract-gen) (type sap offset)
+ (declare (ignore type))
+ `(sap-ref-single ,sap (/ ,offset sb!vm:byte-bits)))
+
+(def-alien-type-class (double-float :include (float (:bits 64))
+ :include-args (type)))
+
+(def-alien-type-translator double-float ()
+ (make-alien-double-float-type :type 'double-float))
+
+(def-alien-type-method (double-float :extract-gen) (type sap offset)
+ (declare (ignore type))
+ `(sap-ref-double ,sap (/ ,offset sb!vm:byte-bits)))
+
+#!+long-float
+(def-alien-type-class (long-float :include (float (:bits #!+x86 96 #!+sparc 128))
+ :include-args (type)))
+
+#!+long-float
+(def-alien-type-translator long-float ()
+ (make-alien-long-float-type :type 'long-float))
+
+#!+long-float
+(def-alien-type-method (long-float :extract-gen) (type sap offset)
+ (declare (ignore type))
+ `(sap-ref-long ,sap (/ ,offset sb!vm:byte-bits)))
+\f
+;;;; the POINTER type
+
+(def-alien-type-class (pointer :include (alien-value (:bits
+ #!-alpha sb!vm:word-bits
+ #!+alpha 64)))
+ (to nil :type (or alien-type null)))
+
+(def-alien-type-translator * (to &environment env)
+ (make-alien-pointer-type :to (if (eq to t) nil (parse-alien-type to env))))
+
+(def-alien-type-method (pointer :unparse) (type)
+ (let ((to (alien-pointer-type-to type)))
+ `(* ,(if to
+ (%unparse-alien-type to)
+ t))))
+
+(def-alien-type-method (pointer :type=) (type1 type2)
+ (let ((to1 (alien-pointer-type-to type1))
+ (to2 (alien-pointer-type-to type2)))
+ (if to1
+ (if to2
+ (alien-type-= to1 to2)
+ nil)
+ (null to2))))
+
+(def-alien-type-method (pointer :subtypep) (type1 type2)
+ (and (alien-pointer-type-p type2)
+ (let ((to1 (alien-pointer-type-to type1))
+ (to2 (alien-pointer-type-to type2)))
+ (if to1
+ (if to2
+ (alien-subtype-p to1 to2)
+ t)
+ (null to2)))))
+
+(def-alien-type-method (pointer :deport-gen) (type value)
+ (/noshow "doing alien type method POINTER :DEPORT-GEN" type value)
+ (values
+ ;; FIXME: old version, highlighted a bug in xc optimization
+ `(etypecase ,value
+ (null
+ (int-sap 0))
+ (system-area-pointer
+ ,value)
+ ((alien ,type)
+ (alien-sap ,value)))
+ ;; new version, works around bug in xc optimization
+ #+nil
+ `(etypecase ,value
+ (system-area-pointer
+ ,value)
+ ((alien ,type)
+ (alien-sap ,value))
+ (null
+ (int-sap 0)))
+ `(or null system-area-pointer (alien ,type))))
+\f
+;;;; the MEM-BLOCK type
+
+(def-alien-type-class (mem-block :include alien-value))
+
+(def-alien-type-method (mem-block :extract-gen) (type sap offset)
+ (declare (ignore type))
+ `(sap+ ,sap (/ ,offset sb!vm:byte-bits)))
+
+(def-alien-type-method (mem-block :deposit-gen) (type sap offset value)
+ (let ((bits (alien-mem-block-type-bits type)))
+ (unless bits
+ (error "can't deposit aliens of type ~S (unknown size)" type))
+ `(sb!kernel:system-area-copy ,value 0 ,sap ,offset ',bits)))
+\f
+;;;; the ARRAY type
+
+(def-alien-type-class (array :include mem-block)
+ (element-type (required-argument) :type alien-type)
+ (dimensions (required-argument) :type list))
+
+(def-alien-type-translator array (ele-type &rest dims &environment env)
+ (when dims
+ (unless (typep (first dims) '(or sb!kernel:index null))
+ (error "The first dimension is not a non-negative fixnum or NIL: ~S"
+ (first dims)))
+ (let ((loser (find-if-not #'(lambda (x) (typep x 'sb!kernel:index))
+ (rest dims))))
+ (when loser
+ (error "A dimension is not a non-negative fixnum: ~S" loser))))
+
+ (let ((type (parse-alien-type ele-type env)))
+ (make-alien-array-type
+ :element-type type
+ :dimensions dims
+ :alignment (alien-type-alignment type)
+ :bits (if (and (alien-type-bits type)
+ (every #'integerp dims))
+ (* (align-offset (alien-type-bits type)
+ (alien-type-alignment type))
+ (reduce #'* dims))))))
+
+(def-alien-type-method (array :unparse) (type)
+ `(array ,(%unparse-alien-type (alien-array-type-element-type type))
+ ,@(alien-array-type-dimensions type)))
+
+(def-alien-type-method (array :type=) (type1 type2)
+ (and (equal (alien-array-type-dimensions type1)
+ (alien-array-type-dimensions type2))
+ (alien-type-= (alien-array-type-element-type type1)
+ (alien-array-type-element-type type2))))
+
+(def-alien-type-method (array :subtypep) (type1 type2)
+ (and (alien-array-type-p type2)
+ (let ((dim1 (alien-array-type-dimensions type1))
+ (dim2 (alien-array-type-dimensions type2)))
+ (and (= (length dim1) (length dim2))
+ (or (and dim2
+ (null (car dim2))
+ (equal (cdr dim1) (cdr dim2)))
+ (equal dim1 dim2))
+ (alien-subtype-p (alien-array-type-element-type type1)
+ (alien-array-type-element-type type2))))))
+\f
+;;;; the RECORD type
+
+(def!struct (alien-record-field
+ (:make-load-form-fun sb!kernel:just-dump-it-normally))
+ (name (required-argument) :type symbol)
+ (type (required-argument) :type alien-type)
+ (bits nil :type (or unsigned-byte null))
+ (offset 0 :type unsigned-byte))
+(def!method print-object ((field alien-record-field) stream)
+ (print-unreadable-object (field stream :type t)
+ (format stream
+ "~S ~S~@[:~D~]"
+ (alien-record-field-type field)
+ (alien-record-field-name field)
+ (alien-record-field-bits field))))
+
+(def-alien-type-class (record :include mem-block)
+ (kind :struct :type (member :struct :union))
+ (name nil :type (or symbol null))
+ (fields nil :type list))
+
+(def-alien-type-translator struct (name &rest fields &environment env)
+ (parse-alien-record-type :struct name fields env))
+
+(def-alien-type-translator union (name &rest fields &environment env)
+ (parse-alien-record-type :union name fields env))
+
+(defun parse-alien-record-type (kind name fields env)
+ (declare (type sb!kernel:lexenv env))
+ (cond (fields
+ (let* ((old (and name (auxiliary-alien-type kind name env)))
+ (old-fields (and old (alien-record-type-fields old))))
+ (cond (old-fields
+ ;; KLUDGE: We can't easily compare the new fields
+ ;; against the old fields, since the old fields have
+ ;; already been parsed into an internal
+ ;; representation, so we just punt, assuming that
+ ;; they're consistent. -- WHN 200000505
+ #|
+ (unless (equal fields old-fields)
+ ;; FIXME: Perhaps this should be a warning, and we
+ ;; should overwrite the old definition and proceed?
+ (error "mismatch in fields for ~S~% old ~S~% new ~S"
+ name old-fields fields))
+ |#
+ old)
+ (t
+ (let ((new (make-alien-record-type :name name
+ :kind kind)))
+ (when name
+ (setf (auxiliary-alien-type kind name env) new))
+ (parse-alien-record-fields new fields env)
+ new)))))
+ (name
+ (or (auxiliary-alien-type kind name env)
+ (setf (auxiliary-alien-type kind name env)
+ (make-alien-record-type :name name :kind kind))))
+ (t
+ (make-alien-record-type :kind kind))))
+
+;;; This is used by PARSE-ALIEN-TYPE to parse the fields of struct and
+;;; union types. RESULT holds the record type we are paring the fields
+;;; of, and FIELDS is the list of field specifications.
+(defun parse-alien-record-fields (result fields env)
+ (declare (type alien-record-type result)
+ (type list fields))
+ (let ((total-bits 0)
+ (overall-alignment 1)
+ (parsed-fields nil))
+ (dolist (field fields)
+ (destructuring-bind (var type &optional bits) field
+ (declare (ignore bits))
+ (let* ((field-type (parse-alien-type type env))
+ (bits (alien-type-bits field-type))
+ (alignment (alien-type-alignment field-type))
+ (parsed-field
+ (make-alien-record-field :type field-type
+ :name var)))
+ (push parsed-field parsed-fields)
+ (when (null bits)
+ (error "unknown size: ~S" (unparse-alien-type field-type)))
+ (when (null alignment)
+ (error "unknown alignment: ~S" (unparse-alien-type field-type)))
+ (setf overall-alignment (max overall-alignment alignment))
+ (ecase (alien-record-type-kind result)
+ (:struct
+ (let ((offset (align-offset total-bits alignment)))
+ (setf (alien-record-field-offset parsed-field) offset)
+ (setf total-bits (+ offset bits))))
+ (:union
+ (setf total-bits (max total-bits bits)))))))
+ (let ((new (nreverse parsed-fields)))
+ (setf (alien-record-type-fields result) new))
+ (setf (alien-record-type-alignment result) overall-alignment)
+ (setf (alien-record-type-bits result)
+ (align-offset total-bits overall-alignment))))
+
+(def-alien-type-method (record :unparse) (type)
+ `(,(case (alien-record-type-kind type)
+ (:struct 'struct)
+ (:union 'union)
+ (t '???))
+ ,(alien-record-type-name type)
+ ,@(unless (member type *record-types-already-unparsed* :test #'eq)
+ (push type *record-types-already-unparsed*)
+ (mapcar #'(lambda (field)
+ `(,(alien-record-field-name field)
+ ,(%unparse-alien-type (alien-record-field-type field))
+ ,@(if (alien-record-field-bits field)
+ (list (alien-record-field-bits field)))))
+ (alien-record-type-fields type)))))
+
+;;; Test the record fields. The depth is limiting in case of cyclic
+;;; pointers.
+(defun record-fields-match (fields1 fields2 depth)
+ (declare (type list fields1 fields2)
+ (type (mod 64) depth))
+ (labels ((record-type-= (type1 type2 depth)
+ (and (eq (alien-record-type-name type1)
+ (alien-record-type-name type2))
+ (eq (alien-record-type-kind type1)
+ (alien-record-type-kind type2))
+ (= (length (alien-record-type-fields type1))
+ (length (alien-record-type-fields type2)))
+ (record-fields-match (alien-record-type-fields type1)
+ (alien-record-type-fields type2)
+ (1+ depth))))
+ (pointer-type-= (type1 type2 depth)
+ (let ((to1 (alien-pointer-type-to type1))
+ (to2 (alien-pointer-type-to type2)))
+ (if to1
+ (if to2
+ (type-= to1 to2 (1+ depth))
+ nil)
+ (null to2))))
+ (type-= (type1 type2 depth)
+ (cond ((and (alien-pointer-type-p type1)
+ (alien-pointer-type-p type2))
+ (or (> depth 10)
+ (pointer-type-= type1 type2 depth)))
+ ((and (alien-record-type-p type1)
+ (alien-record-type-p type2))
+ (record-type-= type1 type2 depth))
+ (t
+ (alien-type-= type1 type2)))))
+ (do ((fields1-rem fields1 (rest fields1-rem))
+ (fields2-rem fields2 (rest fields2-rem)))
+ ((or (eq fields1-rem fields2-rem)
+ (endp fields1-rem) (endp fields2-rem))
+ (eq fields1-rem fields2-rem))
+ (let ((field1 (first fields1-rem))
+ (field2 (first fields2-rem)))
+ (declare (type alien-record-field field1 field2))
+ (unless (and (eq (alien-record-field-name field1)
+ (alien-record-field-name field2))
+ (eql (alien-record-field-bits field1)
+ (alien-record-field-bits field2))
+ (eql (alien-record-field-offset field1)
+ (alien-record-field-offset field2))
+ (let ((field1 (alien-record-field-type field1))
+ (field2 (alien-record-field-type field2)))
+ (type-= field1 field2 (1+ depth))))
+ (return nil))))))
+
+(def-alien-type-method (record :type=) (type1 type2)
+ (and (eq (alien-record-type-name type1)
+ (alien-record-type-name type2))
+ (eq (alien-record-type-kind type1)
+ (alien-record-type-kind type2))
+ (= (length (alien-record-type-fields type1))
+ (length (alien-record-type-fields type2)))
+ (record-fields-match (alien-record-type-fields type1)
+ (alien-record-type-fields type2) 0)))
+\f
+;;;; the FUNCTION and VALUES types
+
+(defvar *values-type-okay* nil)
+
+(def-alien-type-class (function :include mem-block)
+ (result-type (required-argument) :type alien-type)
+ (arg-types (required-argument) :type list)
+ (stub nil :type (or null function)))
+
+(def-alien-type-translator function (result-type &rest arg-types
+ &environment env)
+ (make-alien-function-type
+ :result-type (let ((*values-type-okay* t))
+ (parse-alien-type result-type env))
+ :arg-types (mapcar (lambda (arg-type) (parse-alien-type arg-type env))
+ arg-types)))
+
+(def-alien-type-method (function :unparse) (type)
+ `(function ,(%unparse-alien-type (alien-function-type-result-type type))
+ ,@(mapcar #'%unparse-alien-type
+ (alien-function-type-arg-types type))))
+
+(def-alien-type-method (function :type=) (type1 type2)
+ (and (alien-type-= (alien-function-type-result-type type1)
+ (alien-function-type-result-type type2))
+ (= (length (alien-function-type-arg-types type1))
+ (length (alien-function-type-arg-types type2)))
+ (every #'alien-type-=
+ (alien-function-type-arg-types type1)
+ (alien-function-type-arg-types type2))))
+
+(def-alien-type-class (values)
+ (values (required-argument) :type list))
+
+(def-alien-type-translator values (&rest values &environment env)
+ (unless *values-type-okay*
+ (error "cannot use values types here"))
+ (let ((*values-type-okay* nil))
+ (make-alien-values-type
+ :values (mapcar (lambda (alien-type) (parse-alien-type alien-type env))
+ values))))
+
+(def-alien-type-method (values :unparse) (type)
+ `(values ,@(mapcar #'%unparse-alien-type
+ (alien-values-type-values type))))
+
+(def-alien-type-method (values :type=) (type1 type2)
+ (and (= (length (alien-values-type-values type1))
+ (length (alien-values-type-values type2)))
+ (every #'alien-type-=
+ (alien-values-type-values type1)
+ (alien-values-type-values type2))))
+\f
+;;;; a structure definition needed both in the target and in the
+;;;; cross-compilation host
+
+;;; information about local aliens. The WITH-ALIEN macro builds one of
+;;; these structures and LOCAL-ALIEN and friends communicate
+;;; information about how that local alien is represented.
+(def!struct (local-alien-info
+ (:make-load-form-fun sb!kernel:just-dump-it-normally)
+ (:constructor make-local-alien-info
+ (&key type force-to-memory-p)))
+ ;; the type of the local alien
+ (type (required-argument) :type alien-type)
+ ;; T if this local alien must be forced into memory. Using the ADDR macro
+ ;; on a local alien will set this.
+ (force-to-memory-p (or (alien-array-type-p type) (alien-record-type-p type))
+ :type (member t nil)))
+(def!method print-object ((info local-alien-info) stream)
+ (print-unreadable-object (info stream :type t)
+ (format stream
+ "~:[~;(forced to stack) ~]~S"
+ (local-alien-info-force-to-memory-p info)
+ (unparse-alien-type (local-alien-info-type info)))))
+\f
+;;;; the ADDR macro
+
+(sb!kernel: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."
+ (let ((form (sb!xc:macroexpand expr env)))
+ (or (typecase form
+ (cons
+ (case (car form)
+ (slot
+ (cons '%slot-addr (cdr form)))
+ (deref
+ (cons '%deref-addr (cdr form)))
+ (%heap-alien
+ (cons '%heap-alien-addr (cdr form)))
+ (local-alien
+ (let ((info (let ((info-arg (second form)))
+ (and (consp info-arg)
+ (eq (car info-arg) 'quote)
+ (second info-arg)))))
+ (unless (local-alien-info-p info)
+ (error "Something is wrong, LOCAL-ALIEN-INFO not found: ~S"
+ form))
+ (setf (local-alien-info-force-to-memory-p info) t))
+ (cons '%local-alien-addr (cdr form)))))
+ (symbol
+ (let ((kind (info :variable :kind form)))
+ (when (eq kind :alien)
+ `(%heap-alien-addr ',(info :variable :alien-info form))))))
+ (error "~S is not a valid L-value." form))))
--- /dev/null
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!C-CALL")
+
+(sb!int:file-comment
+ "$Header$")
+
+(def-alien-type-class (c-string :include pointer :include-args (to)))
+
+(def-alien-type-translator c-string ()
+ (make-alien-c-string-type :to
+ (parse-alien-type 'char
+ (sb!kernel::make-null-lexenv))))
+
+(def-alien-type-method (c-string :unparse) (type)
+ (declare (ignore type))
+ 'c-string)
+
+(def-alien-type-method (c-string :lisp-rep) (type)
+ (declare (ignore type))
+ '(or simple-base-string null (alien (* char))))
+
+(def-alien-type-method (c-string :naturalize-gen) (type alien)
+ (declare (ignore type))
+ `(if (zerop (sap-int ,alien))
+ nil
+ (%naturalize-c-string ,alien)))
+
+(def-alien-type-method (c-string :deport-gen) (type value)
+ (declare (ignore type))
+ `(etypecase ,value
+ (null (int-sap 0))
+ ((alien (* char)) (alien-sap ,value))
+ (simple-base-string (vector-sap ,value))))
--- /dev/null
+;;;; the INSPECT function
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB-INSPECT")
+
+(file-comment
+ "$Header$")
+
+;;; The inspector views LISP objects as being composed of parts. A
+;;; list, for example, would be divided into its members, and a
+;;; instance into its slots. These parts are stored in a list. The
+;;; first two elements of this list are for bookkeeping. The first
+;;; element is a preamble string that will be displayed before the
+;;; object. The second element is a boolean value that indicates
+;;; whether a label will be printed in front of a value, or just the
+;;; value. Symbols and instances need to display both a slot name and
+;;; a value, while lists, vectors, and atoms need only display a
+;;; value. If the second member of a parts list is t, then the third
+;;; and successive members must be an association list of slot names
+;;; and values. When the second slot is nil, the third and successive
+;;; slots must be the parts of an object.
+
+;;; *INSPECT-OBJECT-STACK* is an assoc list of objects to their parts.
+(defvar *inspect-object-stack* ())
+
+(defparameter *inspect-length* 10)
+
+#-sb-fluid (declaim (inline numbered-parts-p))
+(defun numbered-parts-p (parts)
+ (second parts))
+
+(defconstant parts-offset 2)
+
+(defun nth-parts (parts n)
+ (if (numbered-parts-p parts)
+ (cdr (nth (+ n parts-offset) parts))
+ (nth (+ n parts-offset) parts)))
+
+(defun inspect (object)
+ (unwind-protect
+ (input-loop object (describe-parts object) *standard-output*)
+ (setf *inspect-object-stack* nil)))
+
+;;; When *ILLEGAL-OBJECT-MARKER* occurs in a parts list, it indicates that that
+;;; slot is unbound.
+(defvar *illegal-object-marker* (cons nil nil))
+
+(defun input-loop (object parts s)
+ (tty-display-object parts s)
+ (loop
+ (format s "~&> ")
+ (force-output)
+ (let ((command (read))
+ ;; Use 2 less than length because first 2 elements are bookkeeping.
+ (parts-len-2 (- (length parts) 2)))
+ (typecase command
+ (integer
+ (cond ((< -1 command parts-len-2)
+ (cond ((eq (nth-parts parts command) *illegal-object-marker*)
+ (format s "~%That slot is unbound.~%"))
+ (t
+ (push (cons object parts) *inspect-object-stack*)
+ (setf object (nth-parts parts command))
+ (setf parts (describe-parts object))
+ (tty-display-object parts s))))
+ (t
+ (if (= parts-len-2 0)
+ (format s "~%This object contains nothing to inspect.~%~%")
+ (format s "~%Enter a VALID number (~:[0-~D~;0~]).~%~%"
+ (= parts-len-2 1) (1- parts-len-2))))))
+ (symbol
+ (case (find-symbol (symbol-name command) *keyword-package*)
+ ((:q :e)
+ (return object))
+ (:u
+ (cond (*inspect-object-stack*
+ (setf object (caar *inspect-object-stack*))
+ (setf parts (cdar *inspect-object-stack*))
+ (pop *inspect-object-stack*)
+ (tty-display-object parts s))
+ (t (format s "~%Bottom of Stack.~%"))))
+ (:r
+ (setf parts (describe-parts object))
+ (tty-display-object parts s))
+ (:d
+ (tty-display-object parts s))
+ ((:h :? :help)
+ (show-help s))
+ (t
+ (do-inspect-eval command s))))
+ (t
+ (do-inspect-eval command s))))))
+
+(defun do-inspect-eval (command stream)
+ (let ((result-list (restart-case (multiple-value-list (eval command))
+ (nil () :report "Return to the inspector."
+ (format stream "~%returning to the inspector~%")
+ (return-from do-inspect-eval nil)))))
+ (setf /// // // / / result-list)
+ (setf +++ ++ ++ + + - - command)
+ (setf *** ** ** * * (car /))
+ (format stream "~&~{~S~%~}" /)))
+
+(defun show-help (s)
+ (terpri)
+ (write-line "inspector help:" s)
+ (write-line " R - recompute current object." s)
+ (write-line " D - redisplay current object." s)
+ (write-line " U - Move upward through the object stack." s)
+ (write-line " Q, E - Quit inspector." s)
+ (write-line " ?, H, Help - Show this help." s))
+
+(defun tty-display-object (parts stream)
+ (format stream "~%~A" (car parts))
+ (let ((numbered-parts-p (numbered-parts-p parts))
+ (parts (cddr parts)))
+ (do ((part parts (cdr part))
+ (i 0 (1+ i)))
+ ((endp part) nil)
+ (if numbered-parts-p
+ (format stream "~D. ~A: ~A~%" i (caar part)
+ (if (eq (cdar part) *illegal-object-marker*)
+ "unbound"
+ (cdar part)))
+ (format stream "~D. ~A~%" i (car part))))))
+\f
+;;;; DESCRIBE-PARTS
+
+(defun describe-parts (object)
+ (typecase object
+ (symbol (describe-symbol-parts object))
+ (instance (describe-instance-parts object :structure))
+ (function
+ (if (sb-kernel:funcallable-instance-p object)
+ (describe-instance-parts object :funcallable-instance)
+ (describe-function-parts object)))
+ (vector (describe-vector-parts object))
+ (array (describe-array-parts object))
+ (cons (describe-cons-parts object))
+ (t (describe-atomic-parts object))))
+
+(defun describe-symbol-parts (object)
+ (list (format nil "~S is a symbol.~%" object) t
+ (cons "Value" (if (boundp object)
+ (symbol-value object)
+ *illegal-object-marker*))
+ (cons "Function" (if (fboundp object)
+ (symbol-function object)
+ *illegal-object-marker*))
+ (cons "Plist" (symbol-plist object))
+ (cons "Package" (symbol-package object))))
+
+(defun describe-instance-parts (object kind)
+ (let ((info (layout-info (sb-kernel:layout-of object)))
+ (parts-list ()))
+ (push (format nil "~S is a ~(~A~).~%" object kind) parts-list)
+ (push t parts-list)
+ (when (sb-kernel::defstruct-description-p info)
+ (dolist (dd-slot (dd-slots info) (nreverse parts-list))
+ (push (cons (dsd-%name dd-slot)
+ (funcall (dsd-accessor dd-slot) object))
+ parts-list)))))
+
+(defun describe-function-parts (object)
+ (let* ((type (sb-kernel:get-type object))
+ (object (if (= type sb-vm:closure-header-type)
+ (sb-kernel:%closure-function object)
+ object)))
+ (list (format nil "Function ~S.~@[~%Argument List: ~A~]." object
+ (sb-kernel:%function-arglist object)
+ ;; Defined-from stuff used to be here. Someone took
+ ;; it out. FIXME: We should make it easy to get
+ ;; to DESCRIBE from the inspector.
+ )
+ t)))
+
+(defun describe-vector-parts (object)
+ (list* (format nil "The object is a ~:[~;displaced ~]vector of length ~D.~%"
+ (and (sb-impl::array-header-p object)
+ (sb-impl::%array-displaced-p object))
+ (length object))
+ nil
+ (coerce object 'list)))
+
+(defun describe-cons-parts (object)
+ (list* (format nil "The object is a LIST of length ~D.~%" (length object))
+ nil
+ object))
+
+(defun index-string (index rev-dimensions)
+ (if (null rev-dimensions)
+ "[]"
+ (let ((list nil))
+ (dolist (dim rev-dimensions)
+ (multiple-value-bind (q r) (floor index dim)
+ (setq index q)
+ (push r list)))
+ (format nil "[~D~{,~D~}]" (car list) (cdr list)))))
+
+(defun describe-array-parts (object)
+ (let* ((length (min (array-total-size object) *inspect-length*))
+ (reference-array (make-array length :displaced-to object))
+ (dimensions (array-dimensions object))
+ (parts ()))
+ (push (format nil "The object is ~:[a displaced~;an~] array of ~A.~%~
+ Its dimensions are ~S.~%"
+ (array-element-type object)
+ (and (sb-impl::array-header-p object)
+ (sb-impl::%array-displaced-p object))
+ dimensions)
+ parts)
+ (push t parts)
+ (dotimes (i length (nreverse parts))
+ (push (cons (format nil "~A " (index-string i (reverse dimensions)))
+ (aref reference-array i))
+ parts))))
+
+(defun describe-atomic-parts (object)
+ (list (format nil "The object is an atom.~%") nil object))
--- /dev/null
+;;;; functions and macros to define and deal with internal errors
+;;;; (i.e. problems that can be signaled from assembler code)
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!KERNEL")
+
+(file-comment
+ "$Header$")
+\f
+;;;; internal errors
+
+(defvar *internal-errors*
+ #.(map 'vector #'cdr sb!c:*backend-internal-errors*))
+
+(eval-when (:compile-toplevel :execute)
+
+(sb!xc:defmacro deferr (name args &rest body)
+ (let* ((rest-pos (position '&rest args))
+ (required (if rest-pos (subseq args 0 rest-pos) args))
+ (fp (gensym))
+ (context (gensym))
+ (sc-offsets (gensym))
+ (temp (gensym))
+ (fn-name (symbolicate name "-HANDLER")))
+ `(progn
+ ;; FIXME: Having a separate full DEFUN for each error doesn't
+ ;; seem to add much value, and it takes a lot of space. Perhaps
+ ;; we could make this a big CASE statement instead?
+ (defun ,fn-name (name ,fp ,context ,sc-offsets)
+ ;; FIXME: Perhaps put in OPTIMIZE declaration to make this
+ ;; byte coded.
+ ;;
+ ;; FIXME: It would probably be good to do *STACK-TOP-HINT*
+ ;; tricks to hide this internal error-handling logic from the
+ ;; poor high level user, so his debugger tells him about
+ ;; where his error was detected instead of telling him where
+ ;; he ended up inside the system error-handling logic.
+ (declare (ignorable name ,fp ,context ,sc-offsets))
+ (macrolet ((set-value (var value)
+ (let ((pos (position var ',required)))
+ (unless pos
+ (error "~S isn't one of the required args." var))
+ `(let ((,',temp ,value))
+ (sb!di::sub-set-debug-var-slot
+ ,',fp (nth ,pos ,',sc-offsets)
+ ,',temp ,',context)
+ (setf ,var ,',temp)))))
+ (let (,@(let ((offset -1))
+ (mapcar #'(lambda (var)
+ `(,var (sb!di::sub-access-debug-var-slot
+ ,fp
+ (nth ,(incf offset)
+ ,sc-offsets)
+ ,context)))
+ required))
+ ,@(when rest-pos
+ `((,(nth (1+ rest-pos) args)
+ (mapcar #'(lambda (sc-offset)
+ (sb!di::sub-access-debug-var-slot
+ ,fp
+ sc-offset
+ ,context))
+ (nthcdr ,rest-pos ,sc-offsets))))))
+ ,@body)))
+ (setf (svref *internal-errors* ,(error-number-or-lose name))
+ #',fn-name))))
+
+) ; EVAL-WHEN
+
+(deferr unknown-error (&rest args)
+ (error "unknown error:~{ ~S~})" args))
+
+(deferr object-not-function-error (object)
+ (error 'type-error
+ :function-name name
+ :datum object
+ :expected-type 'function))
+
+(deferr object-not-list-error (object)
+ (error 'type-error
+ :function-name name
+ :datum object
+ :expected-type 'list))
+
+(deferr object-not-bignum-error (object)
+ (error 'type-error
+ :function-name name
+ :datum object
+ :expected-type 'bignum))
+
+(deferr object-not-ratio-error (object)
+ (error 'type-error
+ :function-name name
+ :datum object
+ :expected-type 'ratio))
+
+(deferr object-not-single-float-error (object)
+ (error 'type-error
+ :function-name name
+ :datum object
+ :expected-type 'single-float))
+
+(deferr object-not-double-float-error (object)
+ (error 'type-error
+ :function-name name
+ :datum object
+ :expected-type 'double-float))
+
+#!+long-float
+(deferr object-not-long-float-error (object)
+ (error 'type-error
+ :function-name name
+ :datum object
+ :expected-type 'long-float))
+
+(deferr object-not-simple-string-error (object)
+ (error 'type-error
+ :function-name name
+ :datum object
+ :expected-type 'simple-string))
+
+(deferr object-not-simple-bit-vector-error (object)
+ (error 'type-error
+ :function-name name
+ :datum object
+ :expected-type 'simple-bit-vector))
+
+(deferr object-not-simple-vector-error (object)
+ (error 'type-error
+ :function-name name
+ :datum object
+ :expected-type 'simple-vector))
+
+(deferr object-not-fixnum-error (object)
+ (error 'type-error
+ :function-name name
+ :datum object
+ :expected-type 'fixnum))
+
+(deferr object-not-function-or-symbol-error (object)
+ (error 'type-error
+ :function-name name
+ :datum object
+ :expected-type '(or function symbol)))
+
+(deferr object-not-vector-error (object)
+ (error 'type-error
+ :function-name name
+ :datum object
+ :expected-type 'vector))
+
+(deferr object-not-string-error (object)
+ (error 'type-error
+ :function-name name
+ :datum object
+ :expected-type 'string))
+
+(deferr object-not-bit-vector-error (object)
+ (error 'type-error
+ :function-name name
+ :datum object
+ :expected-type 'bit-vector))
+
+(deferr object-not-array-error (object)
+ (error 'type-error
+ :function-name name
+ :datum object
+ :expected-type 'array))
+
+(deferr object-not-number-error (object)
+ (error 'type-error
+ :function-name name
+ :datum object
+ :expected-type 'number))
+
+(deferr object-not-rational-error (object)
+ (error 'type-error
+ :function-name name
+ :datum object
+ :expected-type 'rational))
+
+(deferr object-not-float-error (object)
+ (error 'type-error
+ :function-name name
+ :datum object
+ :expected-type 'float))
+
+(deferr object-not-real-error (object)
+ (error 'type-error
+ :function-name name
+ :datum object
+ :expected-type 'real))
+
+(deferr object-not-integer-error (object)
+ (error 'type-error
+ :function-name name
+ :datum object
+ :expected-type 'integer))
+
+(deferr object-not-cons-error (object)
+ (error 'type-error
+ :function-name name
+ :datum object
+ :expected-type 'cons))
+
+(deferr object-not-symbol-error (object)
+ (error 'type-error
+ :function-name name
+ :datum object
+ :expected-type 'symbol))
+
+(deferr undefined-symbol-error (fdefn-or-symbol)
+ (error 'undefined-function
+ :function-name name
+ :name (etypecase fdefn-or-symbol
+ (symbol fdefn-or-symbol)
+ (fdefn (fdefn-name fdefn-or-symbol)))))
+
+(deferr object-not-coerceable-to-function-error (object)
+ (error 'type-error
+ :function-name name
+ :datum object
+ :expected-type 'coerceable-to-function))
+
+(deferr invalid-argument-count-error (nargs)
+ (error 'simple-program-error
+ :function-name name
+ :format-control "invalid number of arguments: ~S"
+ :format-arguments (list nargs)))
+
+(deferr bogus-argument-to-values-list-error (list)
+ (error 'type-error
+ :function-name name
+ :format-control "attempt to use VALUES-LIST on a dotted-list:~% ~S"
+ :format-arguments (list list)))
+
+(deferr unbound-symbol-error (symbol)
+ (error 'unbound-variable :function-name name :name symbol))
+
+(deferr object-not-base-char-error (object)
+ (error 'type-error
+ :function-name name
+ :datum object
+ :expected-type 'base-char))
+
+(deferr object-not-sap-error (object)
+ (error 'type-error
+ :function-name name
+ :datum object
+ :expected-type 'system-area-pointer))
+
+(deferr invalid-unwind-error ()
+ (error 'simple-control-error
+ :function-name name
+ :format-control
+ "attempt to RETURN-FROM a block or GO to a tag that no longer exists"))
+
+(deferr unseen-throw-tag-error (tag)
+ (error 'simple-control-error
+ :function-name name
+ :format-control "attempt to THROW to a tag that does not exist: ~S"
+ :format-arguments (list tag)))
+
+(deferr nil-function-returned-error (function)
+ (error 'simple-control-error
+ :function-name name
+ :format-control
+ "A function with declared result type NIL returned:~% ~S"
+ :format-arguments (list function)))
+
+(deferr division-by-zero-error (this that)
+ (error 'division-by-zero
+ :function-name name
+ :operation 'division
+ :operands (list this that)))
+
+(deferr object-not-type-error (object type)
+ (error (if (and (typep object 'instance)
+ (layout-invalid (%instance-layout object)))
+ 'layout-invalid
+ 'type-error)
+ :function-name name
+ :datum object
+ :expected-type type))
+
+(deferr layout-invalid-error (object layout)
+ (error 'layout-invalid
+ :function-name name
+ :datum object
+ :expected-type (layout-class layout)))
+
+(deferr odd-keyword-arguments-error ()
+ (error 'simple-program-error
+ :function-name name
+ :format-control "odd number of keyword arguments"))
+
+(deferr unknown-keyword-argument-error (key)
+ (error 'simple-program-error
+ :function-name name
+ :format-control "unknown keyword: ~S"
+ :format-arguments (list key)))
+
+(deferr invalid-array-index-error (array bound index)
+ (error 'simple-error
+ :function-name name
+ :format-control
+ "invalid array index, ~D for ~S (should have been less than ~D)"
+ :format-arguments (list index array bound)))
+
+(deferr object-not-simple-array-error (object)
+ (error 'type-error
+ :function-name name
+ :datum object
+ :expected-type 'simple-array))
+
+(deferr object-not-signed-byte-32-error (object)
+ (error 'type-error
+ :function-name name
+ :datum object
+ :expected-type '(signed-byte 32)))
+
+(deferr object-not-unsigned-byte-32-error (object)
+ (error 'type-error
+ :function-name name
+ :datum object
+ :expected-type '(unsigned-byte 32)))
+
+(deferr object-not-simple-array-unsigned-byte-2-error (object)
+ (error 'type-error
+ :function-name name
+ :datum object
+ :expected-type '(simple-array (unsigned-byte 2) (*))))
+
+(deferr object-not-simple-array-unsigned-byte-4-error (object)
+ (error 'type-error
+ :function-name name
+ :datum object
+ :expected-type '(simple-array (unsigned-byte 4) (*))))
+
+(deferr object-not-simple-array-unsigned-byte-8-error (object)
+ (error 'type-error
+ :function-name name
+ :datum object
+ :expected-type '(simple-array (unsigned-byte 8) (*))))
+
+(deferr object-not-simple-array-unsigned-byte-16-error (object)
+ (error 'type-error
+ :function-name name
+ :datum object
+ :expected-type '(simple-array (unsigned-byte 16) (*))))
+
+(deferr object-not-simple-array-unsigned-byte-32-error (object)
+ (error 'type-error
+ :function-name name
+ :datum object
+ :expected-type '(simple-array (unsigned-byte 32) (*))))
+
+(deferr object-not-simple-array-signed-byte-8-error (object)
+ (error 'type-error
+ :function-name name
+ :datum object
+ :expected-type '(simple-array (signed-byte 8) (*))))
+
+(deferr object-not-simple-array-signed-byte-16-error (object)
+ (error 'type-error
+ :function-name name
+ :datum object
+ :expected-type '(simple-array (signed-byte 16) (*))))
+
+(deferr object-not-simple-array-signed-byte-30-error (object)
+ (error 'type-error
+ :function-name name
+ :datum object
+ :expected-type '(simple-array (signed-byte 30) (*))))
+
+(deferr object-not-simple-array-signed-byte-32-error (object)
+ (error 'type-error
+ :function-name name
+ :datum object
+ :expected-type '(simple-array (signed-byte 32) (*))))
+
+(deferr object-not-simple-array-single-float-error (object)
+ (error 'type-error
+ :function-name name
+ :datum object
+ :expected-type '(simple-array single-float (*))))
+
+(deferr object-not-simple-array-double-float-error (object)
+ (error 'type-error
+ :function-name name
+ :datum object
+ :expected-type '(simple-array double-float (*))))
+
+(deferr object-not-simple-array-complex-single-float-error (object)
+ (error 'type-error
+ :function-name name
+ :datum object
+ :expected-type '(simple-array (complex single-float) (*))))
+
+(deferr object-not-simple-array-complex-double-float-error (object)
+ (error 'type-error
+ :function-name name
+ :datum object
+ :expected-type '(simple-array (complex double-float) (*))))
+
+#!+long-float
+(deferr object-not-simple-array-complex-long-float-error (object)
+ (error 'type-error
+ :function-name name
+ :datum object
+ :expected-type '(simple-array (complex long-float) (*))))
+
+(deferr object-not-complex-error (object)
+ (error 'type-error
+ :function-name name
+ :datum object
+ :expected-type 'complex))
+
+(deferr object-not-complex-rational-error (object)
+ (error 'type-error
+ :function-name name
+ :datum object
+ :expected-type '(complex rational)))
+
+(deferr object-not-complex-single-float-error (object)
+ (error 'type-error
+ :function-name name
+ :datum object
+ :expected-type '(complex single-float)))
+
+(deferr object-not-complex-double-float-error (object)
+ (error 'type-error
+ :function-name name
+ :datum object
+ :expected-type '(complex double-float)))
+
+#!+long-float
+(deferr object-not-complex-long-float-error (object)
+ (error 'type-error
+ :function-name name
+ :datum object
+ :expected-type '(complex long-float)))
+
+(deferr object-not-weak-pointer-error (object)
+ (error 'type-error
+ :function-name name
+ :datum object
+ :expected-type 'weak-pointer))
+
+(deferr object-not-instance-error (object)
+ (error 'type-error
+ :function-name name
+ :datum object
+ :expected-type 'instance))
+\f
+;;;; fetching errorful function name
+
+;;; This variable is used to prevent infinite recursive lossage when
+;;; we can't find the caller for some reason.
+(defvar *finding-name* nil)
+
+(defun find-caller-name ()
+ (if *finding-name*
+ (values "<error finding caller name -- already finding name>" nil)
+ (handler-case
+ (let* ((*finding-name* t)
+ (frame (sb!di:frame-down (sb!di:frame-down (sb!di:top-frame))))
+ (name (sb!di:debug-function-name
+ (sb!di:frame-debug-function frame))))
+ (sb!di:flush-frames-above frame)
+ (values name frame))
+ (error ()
+ (values "<error finding caller name -- trapped error>" nil))
+ (sb!di:debug-condition ()
+ (values "<error finding caller name -- trapped debug-condition>"
+ nil)))))
+
+(defun find-interrupted-name ()
+ (if *finding-name*
+ (values "<error finding interrupted name -- already finding name>" nil)
+ (handler-case
+ (let ((*finding-name* t))
+ (do ((frame (sb!di:top-frame) (sb!di:frame-down frame)))
+ ((null frame)
+ (values "<error finding interrupted name -- null frame>" nil))
+ (when (and (sb!di::compiled-frame-p frame)
+ (sb!di::compiled-frame-escaped frame))
+ (sb!di:flush-frames-above frame)
+ (return (values (sb!di:debug-function-name
+ (sb!di:frame-debug-function frame))
+ frame)))))
+ (error ()
+ (values "<error finding interrupted name -- trapped error>" nil))
+ (sb!di:debug-condition ()
+ (values "<error finding interrupted name -- trapped debug-condition>"
+ nil)))))
+\f
+;;;; INTERNAL-ERROR signal handler
+
+(defun internal-error (context continuable)
+ (declare (type system-area-pointer context) (ignore continuable))
+ (infinite-error-protect
+ (let ((context (locally
+ (declare (optimize (inhibit-warnings 3)))
+ (sb!alien:sap-alien context (* os-context-t)))))
+ (multiple-value-bind (error-number arguments)
+ (sb!vm:internal-error-arguments context)
+ (multiple-value-bind (name sb!debug:*stack-top-hint*)
+ (find-interrupted-name)
+ (let ((fp (int-sap (sb!vm:context-register context
+ sb!vm::cfp-offset)))
+ (handler (and (< -1 error-number (length *internal-errors*))
+ (svref *internal-errors* error-number))))
+ (cond ((null handler)
+ (error 'simple-error
+ :function-name name
+ :format-control
+ "unknown internal error, ~D? args=~S"
+ :format-arguments
+ (list error-number
+ (mapcar #'(lambda (sc-offset)
+ (sb!di::sub-access-debug-var-slot
+ fp sc-offset context))
+ arguments))))
+ ((not (functionp handler))
+ (error 'simple-error
+ :function-name name
+ :format-control
+ "internal error ~D: ~A; args=~S"
+ :format-arguments
+ (list error-number
+ handler
+ (mapcar #'(lambda (sc-offset)
+ (sb!di::sub-access-debug-var-slot
+ fp sc-offset context))
+ arguments))))
+ (t
+ (funcall handler name fp context arguments)))))))))
--- /dev/null
+;;;; This file contains all the irrational functions. (Actually, most
+;;;; of the work is done by calling out to C.)
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!KERNEL")
+
+(file-comment
+ "$Header$")
+\f
+;;;; miscellaneous constants, utility functions, and macros
+
+(defconstant pi 3.14159265358979323846264338327950288419716939937511L0)
+;(defconstant e 2.71828182845904523536028747135266249775724709369996L0)
+
+;;; Make these INLINE, since the call to C is at least as compact as a Lisp
+;;; call, and saves number consing to boot.
+;;;
+;;; FIXME: This should be (EVAL-WHEN (COMPILE-EVAL) (SB!XC:DEFMACRO ..)),
+;;; I think.
+(defmacro def-math-rtn (name num-args)
+ (let ((function (intern (concatenate 'simple-string
+ "%"
+ (string-upcase name)))))
+ `(progn
+ (proclaim '(inline ,function))
+ (let ((sb!int::*rogue-export* "DEF-MATH-RTN"))
+ (export ',function))
+ (sb!alien:def-alien-routine (,name ,function) double-float
+ ,@(let ((results nil))
+ (dotimes (i num-args (nreverse results))
+ (push (list (intern (format nil "ARG-~D" i))
+ 'double-float)
+ results)))))))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+
+(defun handle-reals (function var)
+ `((((foreach fixnum single-float bignum ratio))
+ (coerce (,function (coerce ,var 'double-float)) 'single-float))
+ ((double-float)
+ (,function ,var))))
+
+) ; EVAL-WHEN
+\f
+;;;; stubs for the Unix math library
+
+;;; Please refer to the Unix man pages for details about these routines.
+
+;;; Trigonometric.
+#!-x86 (def-math-rtn "sin" 1)
+#!-x86 (def-math-rtn "cos" 1)
+#!-x86 (def-math-rtn "tan" 1)
+(def-math-rtn "asin" 1)
+(def-math-rtn "acos" 1)
+#!-x86 (def-math-rtn "atan" 1)
+#!-x86 (def-math-rtn "atan2" 2)
+(def-math-rtn "sinh" 1)
+(def-math-rtn "cosh" 1)
+(def-math-rtn "tanh" 1)
+(def-math-rtn "asinh" 1)
+(def-math-rtn "acosh" 1)
+(def-math-rtn "atanh" 1)
+
+;;; Exponential and Logarithmic.
+#!-x86 (def-math-rtn "exp" 1)
+#!-x86 (def-math-rtn "log" 1)
+#!-x86 (def-math-rtn "log10" 1)
+(def-math-rtn "pow" 2)
+#!-x86 (def-math-rtn "sqrt" 1)
+(def-math-rtn "hypot" 2)
+#!-(or hpux x86) (def-math-rtn "log1p" 1)
+
+#!+x86 ;; These are needed for use by byte-compiled files.
+(progn
+ (defun %sin (x)
+ (declare (double-float x)
+ (values double-float))
+ (%sin x))
+ (defun %sin-quick (x)
+ (declare (double-float x)
+ (values double-float))
+ (%sin-quick x))
+ (defun %cos (x)
+ (declare (double-float x)
+ (values double-float))
+ (%cos x))
+ (defun %cos-quick (x)
+ (declare (double-float x)
+ (values double-float))
+ (%cos-quick x))
+ (defun %tan (x)
+ (declare (double-float x)
+ (values double-float))
+ (%tan x))
+ (defun %tan-quick (x)
+ (declare (double-float x)
+ (values double-float))
+ (%tan-quick x))
+ (defun %atan (x)
+ (declare (double-float x)
+ (values double-float))
+ (%atan x))
+ (defun %atan2 (x y)
+ (declare (double-float x y)
+ (values double-float))
+ (%atan2 x y))
+ (defun %exp (x)
+ (declare (double-float x)
+ (values double-float))
+ (%exp x))
+ (defun %log (x)
+ (declare (double-float x)
+ (values double-float))
+ (%log x))
+ (defun %log10 (x)
+ (declare (double-float x)
+ (values double-float))
+ (%log10 x))
+ #+nil ;; notyet
+ (defun %pow (x y)
+ (declare (type (double-float 0d0) x)
+ (double-float y)
+ (values (double-float 0d0)))
+ (%pow x y))
+ (defun %sqrt (x)
+ (declare (double-float x)
+ (values double-float))
+ (%sqrt x))
+ (defun %scalbn (f ex)
+ (declare (double-float f)
+ (type (signed-byte 32) ex)
+ (values double-float))
+ (%scalbn f ex))
+ (defun %scalb (f ex)
+ (declare (double-float f ex)
+ (values double-float))
+ (%scalb f ex))
+ (defun %logb (x)
+ (declare (double-float x)
+ (values double-float))
+ (%logb x))
+ (defun %log1p (x)
+ (declare (double-float x)
+ (values double-float))
+ (%log1p x))
+ ) ; progn
+\f
+;;;; power functions
+
+(defun exp (number)
+ #!+sb-doc
+ "Return e raised to the power NUMBER."
+ (number-dispatch ((number number))
+ (handle-reals %exp number)
+ ((complex)
+ (* (exp (realpart number))
+ (cis (imagpart number))))))
+
+;;; INTEXP -- Handle the rational base, integer power case.
+
+;;; FIXME: As long as the
+;;; system dies on stack overflow or memory exhaustion, it seems reasonable
+;;; to have this, but its default should be NIL, and when it's NIL,
+;;; anything should be accepted.
+(defparameter *intexp-maximum-exponent* 10000)
+
+;;; This function precisely calculates base raised to an integral power. It
+;;; separates the cases by the sign of power, for efficiency reasons, as powers
+;;; can be calculated more efficiently if power is a positive integer. Values
+;;; of power are calculated as positive integers, and inverted if negative.
+(defun intexp (base power)
+ (when (> (abs power) *intexp-maximum-exponent*)
+ ;; FIXME: should be ordinary error, not CERROR. (Once we set the
+ ;; default for the variable to NIL, the un-continuable error will
+ ;; be less obnoxious.)
+ (cerror "Continue with calculation."
+ "The absolute value of ~S exceeds ~S."
+ power '*intexp-maximum-exponent* base power))
+ (cond ((minusp power)
+ (/ (intexp base (- power))))
+ ((eql base 2)
+ (ash 1 power))
+ (t
+ (do ((nextn (ash power -1) (ash power -1))
+ (total (if (oddp power) base 1)
+ (if (oddp power) (* base total) total)))
+ ((zerop nextn) total)
+ (setq base (* base base))
+ (setq power nextn)))))
+
+;;; If an integer power of a rational, use INTEXP above. Otherwise, do
+;;; floating point stuff. If both args are real, we try %POW right off,
+;;; assuming it will return 0 if the result may be complex. If so, we call
+;;; COMPLEX-POW which directly computes the complex result. We also separate
+;;; the complex-real and real-complex cases from the general complex case.
+(defun expt (base power)
+ #!+sb-doc
+ "Returns BASE raised to the POWER."
+ (if (zerop power)
+ (1+ (* base power))
+ (labels (;; determine if the double float is an integer.
+ ;; 0 - not an integer
+ ;; 1 - an odd int
+ ;; 2 - an even int
+ (isint (ihi lo)
+ (declare (type (unsigned-byte 31) ihi)
+ (type (unsigned-byte 32) lo)
+ (optimize (speed 3) (safety 0)))
+ (let ((isint 0))
+ (declare (type fixnum isint))
+ (cond ((>= ihi #x43400000) ; exponent >= 53
+ (setq isint 2))
+ ((>= ihi #x3ff00000)
+ (let ((k (- (ash ihi -20) #x3ff))) ; exponent
+ (declare (type (mod 53) k))
+ (cond ((> k 20)
+ (let* ((shift (- 52 k))
+ (j (logand (ash lo (- shift))))
+ (j2 (ash j shift)))
+ (declare (type (mod 32) shift)
+ (type (unsigned-byte 32) j j2))
+ (when (= j2 lo)
+ (setq isint (- 2 (logand j 1))))))
+ ((= lo 0)
+ (let* ((shift (- 20 k))
+ (j (ash ihi (- shift)))
+ (j2 (ash j shift)))
+ (declare (type (mod 32) shift)
+ (type (unsigned-byte 31) j j2))
+ (when (= j2 ihi)
+ (setq isint (- 2 (logand j 1))))))))))
+ isint))
+ (real-expt (x y rtype)
+ (let ((x (coerce x 'double-float))
+ (y (coerce y 'double-float)))
+ (declare (double-float x y))
+ (let* ((x-hi (sb!kernel:double-float-high-bits x))
+ (x-lo (sb!kernel:double-float-low-bits x))
+ (x-ihi (logand x-hi #x7fffffff))
+ (y-hi (sb!kernel:double-float-high-bits y))
+ (y-lo (sb!kernel:double-float-low-bits y))
+ (y-ihi (logand y-hi #x7fffffff)))
+ (declare (type (signed-byte 32) x-hi y-hi)
+ (type (unsigned-byte 31) x-ihi y-ihi)
+ (type (unsigned-byte 32) x-lo y-lo))
+ ;; y==zero: x**0 = 1
+ (when (zerop (logior y-ihi y-lo))
+ (return-from real-expt (coerce 1d0 rtype)))
+ ;; +-NaN return x+y
+ (when (or (> x-ihi #x7ff00000)
+ (and (= x-ihi #x7ff00000) (/= x-lo 0))
+ (> y-ihi #x7ff00000)
+ (and (= y-ihi #x7ff00000) (/= y-lo 0)))
+ (return-from real-expt (coerce (+ x y) rtype)))
+ (let ((yisint (if (< x-hi 0) (isint y-ihi y-lo) 0)))
+ (declare (type fixnum yisint))
+ ;; special value of y
+ (when (and (zerop y-lo) (= y-ihi #x7ff00000))
+ ;; y is +-inf
+ (return-from real-expt
+ (cond ((and (= x-ihi #x3ff00000) (zerop x-lo))
+ ;; +-1**inf is NaN
+ (coerce (- y y) rtype))
+ ((>= x-ihi #x3ff00000)
+ ;; (|x|>1)**+-inf = inf,0
+ (if (>= y-hi 0)
+ (coerce y rtype)
+ (coerce 0 rtype)))
+ (t
+ ;; (|x|<1)**-,+inf = inf,0
+ (if (< y-hi 0)
+ (coerce (- y) rtype)
+ (coerce 0 rtype))))))
+
+ (let ((abs-x (abs x)))
+ (declare (double-float abs-x))
+ ;; special value of x
+ (when (and (zerop x-lo)
+ (or (= x-ihi #x7ff00000) (zerop x-ihi)
+ (= x-ihi #x3ff00000)))
+ ;; x is +-0,+-inf,+-1
+ (let ((z (if (< y-hi 0)
+ (/ 1 abs-x) ; z = (1/|x|)
+ abs-x)))
+ (declare (double-float z))
+ (when (< x-hi 0)
+ (cond ((and (= x-ihi #x3ff00000) (zerop yisint))
+ ;; (-1)**non-int
+ (let ((y*pi (* y pi)))
+ (declare (double-float y*pi))
+ (return-from real-expt
+ (complex
+ (coerce (%cos y*pi) rtype)
+ (coerce (%sin y*pi) rtype)))))
+ ((= yisint 1)
+ ;; (x<0)**odd = -(|x|**odd)
+ (setq z (- z)))))
+ (return-from real-expt (coerce z rtype))))
+
+ (if (>= x-hi 0)
+ ;; x>0
+ (coerce (sb!kernel::%pow x y) rtype)
+ ;; x<0
+ (let ((pow (sb!kernel::%pow abs-x y)))
+ (declare (double-float pow))
+ (case yisint
+ (1 ; Odd
+ (coerce (* -1d0 pow) rtype))
+ (2 ; Even
+ (coerce pow rtype))
+ (t ; Non-integer
+ (let ((y*pi (* y pi)))
+ (declare (double-float y*pi))
+ (complex
+ (coerce (* pow (%cos y*pi)) rtype)
+ (coerce (* pow (%sin y*pi)) rtype)))))))))))))
+ (declare (inline real-expt))
+ (number-dispatch ((base number) (power number))
+ (((foreach fixnum (or bignum ratio) (complex rational)) integer)
+ (intexp base power))
+ (((foreach single-float double-float) rational)
+ (real-expt base power '(dispatch-type base)))
+ (((foreach fixnum (or bignum ratio) single-float)
+ (foreach ratio single-float))
+ (real-expt base power 'single-float))
+ (((foreach fixnum (or bignum ratio) single-float double-float)
+ double-float)
+ (real-expt base power 'double-float))
+ ((double-float single-float)
+ (real-expt base power 'double-float))
+ (((foreach (complex rational) (complex float)) rational)
+ (* (expt (abs base) power)
+ (cis (* power (phase base)))))
+ (((foreach fixnum (or bignum ratio) single-float double-float)
+ complex)
+ (if (and (zerop base) (plusp (realpart power)))
+ (* base power)
+ (exp (* power (log base)))))
+ (((foreach (complex float) (complex rational))
+ (foreach complex double-float single-float))
+ (if (and (zerop base) (plusp (realpart power)))
+ (* base power)
+ (exp (* power (log base)))))))))
+
+(defun log (number &optional (base nil base-p))
+ #!+sb-doc
+ "Return the logarithm of NUMBER in the base BASE, which defaults to e."
+ (if base-p
+ (if (zerop base)
+ base ; ANSI spec
+ (/ (log number) (log base)))
+ (number-dispatch ((number number))
+ (((foreach fixnum bignum ratio))
+ (if (minusp number)
+ (complex (log (- number)) (coerce pi 'single-float))
+ (coerce (%log (coerce number 'double-float)) 'single-float)))
+ (((foreach single-float double-float))
+ ;; Is (log -0) -infinity (libm.a) or -infinity + i*pi (Kahan)?
+ ;; Since this doesn't seem to be an implementation issue
+ ;; I (pw) take the Kahan result.
+ (if (< (float-sign number)
+ (coerce 0 '(dispatch-type number)))
+ (complex (log (- number)) (coerce pi '(dispatch-type number)))
+ (coerce (%log (coerce number 'double-float))
+ '(dispatch-type number))))
+ ((complex)
+ (complex-log number)))))
+
+(defun sqrt (number)
+ #!+sb-doc
+ "Return the square root of NUMBER."
+ (number-dispatch ((number number))
+ (((foreach fixnum bignum ratio))
+ (if (minusp number)
+ (complex-sqrt number)
+ (coerce (%sqrt (coerce number 'double-float)) 'single-float)))
+ (((foreach single-float double-float))
+ (if (minusp number)
+ (complex-sqrt number)
+ (coerce (%sqrt (coerce number 'double-float))
+ '(dispatch-type number))))
+ ((complex)
+ (complex-sqrt number))))
+\f
+;;;; trigonometic and related functions
+
+(defun abs (number)
+ #!+sb-doc
+ "Returns the absolute value of the number."
+ (number-dispatch ((number number))
+ (((foreach single-float double-float fixnum rational))
+ (abs number))
+ ((complex)
+ (let ((rx (realpart number))
+ (ix (imagpart number)))
+ (etypecase rx
+ (rational
+ (sqrt (+ (* rx rx) (* ix ix))))
+ (single-float
+ (coerce (%hypot (coerce rx 'double-float)
+ (coerce ix 'double-float))
+ 'single-float))
+ (double-float
+ (%hypot rx ix)))))))
+
+(defun phase (number)
+ #!+sb-doc
+ "Returns the angle part of the polar representation of a complex number.
+ For complex numbers, this is (atan (imagpart number) (realpart number)).
+ For non-complex positive numbers, this is 0. For non-complex negative
+ numbers this is PI."
+ (etypecase number
+ (rational
+ (if (minusp number)
+ (coerce pi 'single-float)
+ 0.0f0))
+ (single-float
+ (if (minusp (float-sign number))
+ (coerce pi 'single-float)
+ 0.0f0))
+ (double-float
+ (if (minusp (float-sign number))
+ (coerce pi 'double-float)
+ 0.0d0))
+ (complex
+ (atan (imagpart number) (realpart number)))))
+
+(defun sin (number)
+ #!+sb-doc
+ "Return the sine of NUMBER."
+ (number-dispatch ((number number))
+ (handle-reals %sin number)
+ ((complex)
+ (let ((x (realpart number))
+ (y (imagpart number)))
+ (complex (* (sin x) (cosh y))
+ (* (cos x) (sinh y)))))))
+
+(defun cos (number)
+ #!+sb-doc
+ "Return the cosine of NUMBER."
+ (number-dispatch ((number number))
+ (handle-reals %cos number)
+ ((complex)
+ (let ((x (realpart number))
+ (y (imagpart number)))
+ (complex (* (cos x) (cosh y))
+ (- (* (sin x) (sinh y))))))))
+
+(defun tan (number)
+ #!+sb-doc
+ "Return the tangent of NUMBER."
+ (number-dispatch ((number number))
+ (handle-reals %tan number)
+ ((complex)
+ (complex-tan number))))
+
+(defun cis (theta)
+ #!+sb-doc
+ "Return cos(Theta) + i sin(Theta), AKA exp(i Theta)."
+ (if (complexp theta)
+ (error "Argument to CIS is complex: ~S" theta)
+ (complex (cos theta) (sin theta))))
+
+(defun asin (number)
+ #!+sb-doc
+ "Return the arc sine of NUMBER."
+ (number-dispatch ((number number))
+ ((rational)
+ (if (or (> number 1) (< number -1))
+ (complex-asin number)
+ (coerce (%asin (coerce number 'double-float)) 'single-float)))
+ (((foreach single-float double-float))
+ (if (or (> number (coerce 1 '(dispatch-type number)))
+ (< number (coerce -1 '(dispatch-type number))))
+ (complex-asin number)
+ (coerce (%asin (coerce number 'double-float))
+ '(dispatch-type number))))
+ ((complex)
+ (complex-asin number))))
+
+(defun acos (number)
+ #!+sb-doc
+ "Return the arc cosine of NUMBER."
+ (number-dispatch ((number number))
+ ((rational)
+ (if (or (> number 1) (< number -1))
+ (complex-acos number)
+ (coerce (%acos (coerce number 'double-float)) 'single-float)))
+ (((foreach single-float double-float))
+ (if (or (> number (coerce 1 '(dispatch-type number)))
+ (< number (coerce -1 '(dispatch-type number))))
+ (complex-acos number)
+ (coerce (%acos (coerce number 'double-float))
+ '(dispatch-type number))))
+ ((complex)
+ (complex-acos number))))
+
+(defun atan (y &optional (x nil xp))
+ #!+sb-doc
+ "Return the arc tangent of Y if X is omitted or Y/X if X is supplied."
+ (if xp
+ (flet ((atan2 (y x)
+ (declare (type double-float y x)
+ (values double-float))
+ (if (zerop x)
+ (if (zerop y)
+ (if (plusp (float-sign x))
+ y
+ (float-sign y pi))
+ (float-sign y (/ pi 2)))
+ (%atan2 y x))))
+ (number-dispatch ((y number) (x number))
+ ((double-float
+ (foreach double-float single-float fixnum bignum ratio))
+ (atan2 y (coerce x 'double-float)))
+ (((foreach single-float fixnum bignum ratio)
+ double-float)
+ (atan2 (coerce y 'double-float) x))
+ (((foreach single-float fixnum bignum ratio)
+ (foreach single-float fixnum bignum ratio))
+ (coerce (atan2 (coerce y 'double-float) (coerce x 'double-float))
+ 'single-float))))
+ (number-dispatch ((y number))
+ (handle-reals %atan y)
+ ((complex)
+ (complex-atan y)))))
+
+;; It seems that everyone has a C version of sinh, cosh, and
+;; tanh. Let's use these for reals because the original
+;; implementations based on the definitions lose big in round-off
+;; 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."
+ (number-dispatch ((number number))
+ (handle-reals %sinh number)
+ ((complex)
+ (let ((x (realpart number))
+ (y (imagpart 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."
+ (number-dispatch ((number number))
+ (handle-reals %cosh number)
+ ((complex)
+ (let ((x (realpart number))
+ (y (imagpart number)))
+ (complex (* (cosh x) (cos y))
+ (* (sinh x) (sin y)))))))
+
+(defun tanh (number)
+ #!+sb-doc
+ "Return the hyperbolic tangent of NUMBER."
+ (number-dispatch ((number number))
+ (handle-reals %tanh number)
+ ((complex)
+ (complex-tanh number))))
+
+(defun asinh (number)
+ #!+sb-doc
+ "Return the hyperbolic arc sine of NUMBER."
+ (number-dispatch ((number number))
+ (handle-reals %asinh number)
+ ((complex)
+ (complex-asinh number))))
+
+(defun acosh (number)
+ #!+sb-doc
+ "Return the hyperbolic arc cosine of NUMBER."
+ (number-dispatch ((number number))
+ ((rational)
+ ;; acosh is complex if number < 1
+ (if (< number 1)
+ (complex-acosh number)
+ (coerce (%acosh (coerce number 'double-float)) 'single-float)))
+ (((foreach single-float double-float))
+ (if (< number (coerce 1 '(dispatch-type number)))
+ (complex-acosh number)
+ (coerce (%acosh (coerce number 'double-float))
+ '(dispatch-type number))))
+ ((complex)
+ (complex-acosh number))))
+
+(defun atanh (number)
+ #!+sb-doc
+ "Return the hyperbolic arc tangent of NUMBER."
+ (number-dispatch ((number number))
+ ((rational)
+ ;; atanh is complex if |number| > 1
+ (if (or (> number 1) (< number -1))
+ (complex-atanh number)
+ (coerce (%atanh (coerce number 'double-float)) 'single-float)))
+ (((foreach single-float double-float))
+ (if (or (> number (coerce 1 '(dispatch-type number)))
+ (< number (coerce -1 '(dispatch-type number))))
+ (complex-atanh number)
+ (coerce (%atanh (coerce number 'double-float))
+ '(dispatch-type number))))
+ ((complex)
+ (complex-atanh number))))
+
+;;; HP-UX does not supply a C version of log1p, so
+;;; use the definition.
+
+#!+hpux
+#!-sb-fluid (declaim (inline %log1p))
+#!+hpux
+(defun %log1p (number)
+ (declare (double-float number)
+ (optimize (speed 3) (safety 0)))
+ (the double-float (log (the (double-float 0d0) (+ number 1d0)))))
+
--- /dev/null
+;;;; miscellaneous kernel-level definitions
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!KERNEL")
+
+(file-comment
+ "$Header$")
+
+(defun get-header-data (x)
+ #!+sb-doc
+ "Return the 24 bits of data in the header of object X, which must be an
+ other-pointer object."
+ (get-header-data x))
+
+(defun set-header-data (x val)
+ #!+sb-doc
+ "Sets the 24 bits of data in the header of object X (which must be an
+ other-pointer object) to VAL."
+ (set-header-data x val))
+
+(defun get-closure-length (x)
+ #!+sb-doc
+ "Returns the length of the closure X. This is one more than the number
+ of variables closed over."
+ (get-closure-length x))
+
+(defun get-lowtag (x)
+ #!+sb-doc
+ "Returns the three-bit lowtag for the object X."
+ (get-lowtag x))
+
+(defun get-type (x)
+ #!+sb-doc
+ "Returns the 8-bit header type for the object X."
+ (get-type x))
+
+(defun vector-sap (x)
+ #!+sb-doc
+ "Return a System-Area-Pointer pointing to the data for the vector X, which
+ must be simple."
+ (declare (type (simple-unboxed-array (*)) x))
+ (vector-sap x))
+
+(defun sb!c::binding-stack-pointer-sap ()
+ #!+sb-doc
+ "Return a System-Area-Pointer pointing to the end of the binding stack."
+ (sb!c::binding-stack-pointer-sap))
+
+(defun sb!c::dynamic-space-free-pointer ()
+ #!+sb-doc
+ "Returns a System-Area-Pointer pointing to the next free work of the current
+ dynamic space."
+ (sb!c::dynamic-space-free-pointer))
+
+(defun sb!c::control-stack-pointer-sap ()
+ #!+sb-doc
+ "Return a System-Area-Pointer pointing to the end of the control stack."
+ (sb!c::control-stack-pointer-sap))
+
+(defun function-subtype (function)
+ #!+sb-doc
+ "Return the header typecode for FUNCTION. Can be set with SETF."
+ (function-subtype function))
+
+(defun (setf function-subtype) (type function)
+ (setf (function-subtype function) type))
+
+(defun %function-arglist (func)
+ #!+sb-doc
+ "Extracts the arglist from the function header FUNC."
+ (%function-arglist func))
+
+(defun %function-name (func)
+ #!+sb-doc
+ "Extracts the name from the function header FUNC."
+ (%function-name func))
+
+(defun %function-type (func)
+ #!+sb-doc
+ "Extracts the type from the function header FUNC."
+ (%function-type func))
+
+(defun %closure-function (closure)
+ #!+sb-doc
+ "Extracts the function from CLOSURE."
+ (%closure-function closure))
+
+(defun sb!c::vector-length (vector)
+ #!+sb-doc
+ "Return the length of VECTOR. There is no reason to use this, 'cause
+ (length (the vector foo)) is the same."
+ (sb!c::vector-length vector))
+
+(defun %closure-index-ref (closure index)
+ #!+sb-doc
+ "Extract the INDEXth slot from CLOSURE."
+ (%closure-index-ref closure index))
+
+(defun allocate-vector (type length words)
+ #!+sb-doc
+ "Allocate a unboxed, simple vector with type code TYPE, length LENGTH, and
+ WORDS words long. Note: it is your responsibility to ensure that the
+ relation between LENGTH and WORDS is correct."
+ (allocate-vector type length words))
+
+(defun make-array-header (type rank)
+ #!+sb-doc
+ "Allocate an array header with type code TYPE and rank RANK."
+ (make-array-header type rank))
+
+(defun code-instructions (code-obj)
+ #!+sb-doc
+ "Return a SAP pointing to the instructions part of CODE-OBJ."
+ (code-instructions code-obj))
+
+(defun code-header-ref (code-obj index)
+ #!+sb-doc
+ "Extract the INDEXth element from the header of CODE-OBJ. Can be set with
+ setf."
+ (code-header-ref code-obj index))
+
+(defun code-header-set (code-obj index new)
+ (code-header-set code-obj index new))
+
+(defun %raw-bits (object offset)
+ (declare (type index offset))
+ (sb!kernel:%raw-bits object offset))
+
+(defun %set-raw-bits (object offset value)
+ (declare (type index offset) (type (unsigned-byte #.sb!vm:word-bits) value))
+ (setf (sb!kernel:%raw-bits object offset) value))
+
+(defun make-single-float (x) (make-single-float x))
+(defun make-double-float (hi lo) (make-double-float hi lo))
+#!+long-float
+(defun make-long-float (exp hi #!+sparc mid lo)
+ (make-long-float exp hi #!+sparc mid lo))
+(defun single-float-bits (x) (single-float-bits x))
+(defun double-float-high-bits (x) (double-float-high-bits x))
+(defun double-float-low-bits (x) (double-float-low-bits x))
+#!+long-float
+(defun long-float-exp-bits (x) (long-float-exp-bits x))
+#!+long-float
+(defun long-float-high-bits (x) (long-float-high-bits x))
+#!+(and long-float sparc)
+(defun long-float-mid-bits (x) (long-float-mid-bits x))
+#!+long-float
+(defun long-float-low-bits (x) (long-float-low-bits x))
--- /dev/null
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!IMPL")
+
+(file-comment
+ "$Header$")
+
+;;; DEF!METHOD = cold DEFMETHOD, a version of DEFMETHOD which, when used
+;;; before real CLOS DEFMETHOD is available, saves up its definition to be
+;;; executed later when CLOS is available
+(defmacro-mundanely def!method (&rest args)
+ `(push ',args *delayed-def!method-args*))
--- /dev/null
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!EXT")
+
+(file-comment
+ "$Header$")
+
+(defun featurep (x)
+ #!+sb-doc
+ "If X is an atom, see whether it is present in *FEATURES*. Also
+ handle arbitrary combinations of atoms using NOT, AND, OR."
+ (if (consp x)
+ (case (car x)
+ ((:not not)
+ (if (cddr x)
+ (error "too many subexpressions in feature expression: ~S" x)
+ (not (featurep (cadr x)))))
+ ((:and and) (every #'featurep (cdr x)))
+ ((:or or) (some #'featurep (cdr x)))
+ (t
+ (error "unknown operator in feature expression: ~S." x)))
+ (not (null (memq x *features*)))))
+
+;;; KLUDGE: This is a wrapper around stale code for working with floating point
+;;; infinities. I believe that I will eventually eliminate floating point
+;;; infinities from the code, since they're a pain to cross-compile, since they
+;;; significantly increase the number of conditions which need to be tested in
+;;; numeric functions, and since the benefits which they provide (which are
+;;; admittedly significant) are unfortunately not portable. I haven't actually
+;;; done the dirty deed yet, though, and until then, I've wrapped various
+;;; infinity-returning forms in this macro. -- WHN 1999
+(defmacro infinite (x)
+ (declare (ignorable x))
+ #!-sb-infinities '(error 'floating-point-overflow)
+ #!+sb-infinities x)
+
+;;; Given a list of keyword substitutions `(,OLD ,NEW), and a
+;;; keyword-argument-list-style list of alternating keywords and arbitrary
+;;; values, return a new keyword-argument-list-style list with all
+;;; substitutions applied to it.
+;;;
+;;; Note: If efficiency mattered, we could do less consing. (But if efficiency
+;;; mattered, why would we be using keyword arguments at all, much less
+;;; renaming keyword arguments?)
+;;;
+;;; KLUDGE: It would probably be good to get rid of this. -- WHN 19991201
+(defun rename-keyword-args (rename-list keyword-args)
+ (declare (type list rename-list keyword-args))
+ ;; Walk through RENAME-LIST modifying RESULT as per each element in
+ ;; RENAME-LIST.
+ (do ((result (copy-list keyword-args))) ; may be modified below
+ ((null rename-list) result)
+ (destructuring-bind (old new) (pop rename-list)
+ (declare (type keyword old new))
+ ;; Walk through RESULT renaming any OLD keyword argument to NEW.
+ (do ((in-result result (cddr in-result)))
+ ((null in-result))
+ (declare (type list in-result))
+ (when (eq (car in-result) old)
+ (setf (car in-result) new))))))
+
+;;; ANSI Common Lisp's READ-SEQUENCE function, unlike most of the
+;;; other ANSI input functions, is defined to communicate end of file
+;;; status with its return value, not by signalling. This is not the
+;;; behavior we usually want. This is a wrapper which give the
+;;; behavior we usually want, causing READ-SEQUENCE to communicate
+;;; end-of-file status by signalling.
+(defun read-sequence-or-die (sequence stream &key start end)
+ ;; implementation using READ-SEQUENCE
+ #-no-ansi-read-sequence
+ (let ((read-end (read-sequence sequence
+ stream
+ :start start
+ :end end)))
+ (unless (= read-end end)
+ (error 'end-of-file :stream stream))
+ (values))
+ ;; workaround for broken READ-SEQUENCE
+ #+no-ansi-read-sequence
+ (progn
+ (assert (<= start end))
+ (let ((etype (stream-element-type stream)))
+ (cond ((equal etype '(unsigned-byte 8))
+ (do ((i start (1+ i)))
+ ((>= i end)
+ (values))
+ (setf (aref sequence i)
+ (read-byte stream))))
+ (t (error "unsupported element type ~S" etype))))))
--- /dev/null
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!FORMAT")
+
+(file-comment
+ "$Header$")
+\f
+(define-condition format-error (error)
+ ((complaint :reader format-error-complaint :initarg :complaint)
+ (arguments :reader format-error-arguments :initarg :arguments :initform nil)
+ (control-string :reader format-error-control-string
+ :initarg :control-string
+ :initform *default-format-error-control-string*)
+ (offset :reader format-error-offset :initarg :offset
+ :initform *default-format-error-offset*)
+ (print-banner :reader format-error-print-banner :initarg :print-banner
+ :initform t))
+ (:report %print-format-error))
+
+(defun %print-format-error (condition stream)
+ (format stream
+ "~:[~;error in format: ~]~
+ ~?~@[~% ~A~% ~V@T^~]"
+ (format-error-print-banner condition)
+ (format-error-complaint condition)
+ (format-error-arguments condition)
+ (format-error-control-string condition)
+ (format-error-offset condition)))
+\f
+(def!struct format-directive
+ (string (required-argument) :type simple-string)
+ (start (required-argument) :type (and unsigned-byte fixnum))
+ (end (required-argument) :type (and unsigned-byte fixnum))
+ (character (required-argument) :type base-char)
+ (colonp nil :type (member t nil))
+ (atsignp nil :type (member t nil))
+ (params nil :type list))
+(def!method print-object ((x format-directive) stream)
+ (print-unreadable-object (x stream)
+ (write-string (format-directive-string x)
+ stream
+ :start (format-directive-start x)
+ :end (format-directive-end x))))
+\f
+;;;; TOKENIZE-CONTROL-STRING
+
+(defun tokenize-control-string (string)
+ (declare (simple-string string))
+ (let ((index 0)
+ (end (length string))
+ (result nil))
+ (loop
+ (let ((next-directive (or (position #\~ string :start index) end)))
+ (when (> next-directive index)
+ (push (subseq string index next-directive) result))
+ (when (= next-directive end)
+ (return))
+ (let ((directive (parse-directive string next-directive)))
+ (push directive result)
+ (setf index (format-directive-end directive)))))
+ (nreverse result)))
+
+(defun parse-directive (string start)
+ (let ((posn (1+ start)) (params nil) (colonp nil) (atsignp nil)
+ (end (length string)))
+ (flet ((get-char ()
+ (if (= posn end)
+ (error 'format-error
+ :complaint "String ended before directive was found."
+ :control-string string
+ :offset start)
+ (schar string posn))))
+ (loop
+ (let ((char (get-char)))
+ (cond ((or (char<= #\0 char #\9) (char= char #\+) (char= char #\-))
+ (multiple-value-bind (param new-posn)
+ (parse-integer string :start posn :junk-allowed t)
+ (push (cons posn param) params)
+ (setf posn new-posn)
+ (case (get-char)
+ (#\,)
+ ((#\: #\@)
+ (decf posn))
+ (t
+ (return)))))
+ ((or (char= char #\v) (char= char #\V))
+ (push (cons posn :arg) params)
+ (incf posn)
+ (case (get-char)
+ (#\,)
+ ((#\: #\@)
+ (decf posn))
+ (t
+ (return))))
+ ((char= char #\#)
+ (push (cons posn :remaining) params)
+ (incf posn)
+ (case (get-char)
+ (#\,)
+ ((#\: #\@)
+ (decf posn))
+ (t
+ (return))))
+ ((char= char #\')
+ (incf posn)
+ (push (cons posn (get-char)) params)
+ (incf posn)
+ (unless (char= (get-char) #\,)
+ (decf posn)))
+ ((char= char #\,)
+ (push (cons posn nil) params))
+ ((char= char #\:)
+ (if colonp
+ (error 'format-error
+ :complaint "too many colons supplied"
+ :control-string string
+ :offset posn)
+ (setf colonp t)))
+ ((char= char #\@)
+ (if atsignp
+ (error 'format-error
+ :complaint "too many #\\@ characters supplied"
+ :control-string string
+ :offset posn)
+ (setf atsignp t)))
+ (t
+ (when (char= (schar string (1- posn)) #\,)
+ (push (cons (1- posn) nil) params))
+ (return))))
+ (incf posn))
+ (let ((char (get-char)))
+ (when (char= char #\/)
+ (let ((closing-slash (position #\/ string :start (1+ posn))))
+ (if closing-slash
+ (setf posn closing-slash)
+ (error 'format-error
+ :complaint "no matching closing slash"
+ :control-string string
+ :offset posn))))
+ (make-format-directive
+ :string string :start start :end (1+ posn)
+ :character (char-upcase char)
+ :colonp colonp :atsignp atsignp
+ :params (nreverse params))))))
+\f
+;;;; FORMATTER stuff
+
+(sb!xc:defmacro formatter (control-string)
+ `#',(%formatter control-string))
+
+(defun %formatter (control-string)
+ (block nil
+ (catch 'need-orig-args
+ (let* ((*simple-args* nil)
+ (*only-simple-args* t)
+ (guts (expand-control-string control-string))
+ (args nil))
+ (dolist (arg *simple-args*)
+ (push `(,(car arg)
+ (error
+ 'format-error
+ :complaint "required argument missing"
+ :control-string ,control-string
+ :offset ,(cdr arg)))
+ args))
+ (return `(lambda (stream &optional ,@args &rest args)
+ ,guts
+ args))))
+ (let ((*orig-args-available* t)
+ (*only-simple-args* nil))
+ `(lambda (stream &rest orig-args)
+ (let ((args orig-args))
+ ,(expand-control-string control-string)
+ args)))))
+
+(defun expand-control-string (string)
+ (let* ((string (etypecase string
+ (simple-string
+ string)
+ (string
+ (coerce string 'simple-string))))
+ (*default-format-error-control-string* string)
+ (directives (tokenize-control-string string)))
+ `(block nil
+ ,@(expand-directive-list directives))))
+
+(defun expand-directive-list (directives)
+ (let ((results nil)
+ (remaining-directives directives))
+ (loop
+ (unless remaining-directives
+ (return))
+ (multiple-value-bind (form new-directives)
+ (expand-directive (car remaining-directives)
+ (cdr remaining-directives))
+ (push form results)
+ (setf remaining-directives new-directives)))
+ (reverse results)))
+
+(defun expand-directive (directive more-directives)
+ (etypecase directive
+ (format-directive
+ (let ((expander
+ (aref *format-directive-expanders*
+ (char-code (format-directive-character directive))))
+ (*default-format-error-offset*
+ (1- (format-directive-end directive))))
+ (if expander
+ (funcall expander directive more-directives)
+ (error 'format-error
+ :complaint "unknown directive"))))
+ (simple-string
+ (values `(write-string ,directive stream)
+ more-directives))))
+
+(defmacro-mundanely expander-next-arg (string offset)
+ `(if args
+ (pop args)
+ (error 'format-error
+ :complaint "no more arguments"
+ :control-string ,string
+ :offset ,offset)))
+
+(defun expand-next-arg (&optional offset)
+ (if (or *orig-args-available* (not *only-simple-args*))
+ `(,*expander-next-arg-macro*
+ ,*default-format-error-control-string*
+ ,(or offset *default-format-error-offset*))
+ (let ((symbol (gensym "FORMAT-ARG-")))
+ (push (cons symbol (or offset *default-format-error-offset*))
+ *simple-args*)
+ symbol)))
+
+(defmacro expand-bind-defaults (specs params &body body)
+ (once-only ((params params))
+ (if specs
+ (collect ((expander-bindings) (runtime-bindings))
+ (dolist (spec specs)
+ (destructuring-bind (var default) spec
+ (let ((symbol (gensym)))
+ (expander-bindings
+ `(,var ',symbol))
+ (runtime-bindings
+ `(list ',symbol
+ (let* ((param-and-offset (pop ,params))
+ (offset (car param-and-offset))
+ (param (cdr param-and-offset)))
+ (case param
+ (:arg `(or ,(expand-next-arg offset)
+ ,,default))
+ (:remaining
+ (setf *only-simple-args* nil)
+ '(length args))
+ ((nil) ,default)
+ (t param))))))))
+ `(let ,(expander-bindings)
+ `(let ,(list ,@(runtime-bindings))
+ ,@(if ,params
+ (error
+ 'format-error
+ :complaint
+ "too many parameters, expected no more than ~D"
+ :arguments (list ,(length specs))
+ :offset (caar ,params)))
+ ,,@body)))
+ `(progn
+ (when ,params
+ (error 'format-error
+ :complaint "too many parameters, expected none"
+ :offset (caar ,params)))
+ ,@body))))
+\f
+;;;; format directive machinery
+
+;;; FIXME: only used in this file, could be SB!XC:DEFMACRO in EVAL-WHEN
+(defmacro def-complex-format-directive (char lambda-list &body body)
+ (let ((defun-name (intern (format nil
+ "~:@(~:C~)-FORMAT-DIRECTIVE-EXPANDER"
+ char)))
+ (directive (gensym))
+ (directives (if lambda-list (car (last lambda-list)) (gensym))))
+ `(progn
+ (defun ,defun-name (,directive ,directives)
+ ,@(if lambda-list
+ `((let ,(mapcar #'(lambda (var)
+ `(,var
+ (,(intern (concatenate
+ 'string
+ "FORMAT-DIRECTIVE-"
+ (symbol-name var))
+ (symbol-package 'foo))
+ ,directive)))
+ (butlast lambda-list))
+ ,@body))
+ `((declare (ignore ,directive ,directives))
+ ,@body)))
+ (%set-format-directive-expander ,char #',defun-name))))
+
+;;; FIXME: only used in this file, could be SB!XC:DEFMACRO in EVAL-WHEN
+(defmacro def-format-directive (char lambda-list &body body)
+ (let ((directives (gensym))
+ (declarations nil)
+ (body-without-decls body))
+ (loop
+ (let ((form (car body-without-decls)))
+ (unless (and (consp form) (eq (car form) 'declare))
+ (return))
+ (push (pop body-without-decls) declarations)))
+ (setf declarations (reverse declarations))
+ `(def-complex-format-directive ,char (,@lambda-list ,directives)
+ ,@declarations
+ (values (progn ,@body-without-decls)
+ ,directives))))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+
+(defun %set-format-directive-expander (char fn)
+ (setf (aref *format-directive-expanders* (char-code (char-upcase char))) fn)
+ char)
+
+(defun %set-format-directive-interpreter (char fn)
+ (setf (aref *format-directive-interpreters*
+ (char-code (char-upcase char)))
+ fn)
+ char)
+
+(defun find-directive (directives kind stop-at-semi)
+ (if directives
+ (let ((next (car directives)))
+ (if (format-directive-p next)
+ (let ((char (format-directive-character next)))
+ (if (or (char= kind char)
+ (and stop-at-semi (char= char #\;)))
+ (car directives)
+ (find-directive
+ (cdr (flet ((after (char)
+ (member (find-directive (cdr directives)
+ char
+ nil)
+ directives)))
+ (case char
+ (#\( (after #\)))
+ (#\< (after #\>))
+ (#\[ (after #\]))
+ (#\{ (after #\}))
+ (t directives))))
+ kind stop-at-semi)))
+ (find-directive (cdr directives) kind stop-at-semi)))))
+
+) ; EVAL-WHEN
+\f
+;;;; format directives for simple output
+
+(def-format-directive #\A (colonp atsignp params)
+ (if params
+ (expand-bind-defaults ((mincol 0) (colinc 1) (minpad 0)
+ (padchar #\space))
+ params
+ `(format-princ stream ,(expand-next-arg) ',colonp ',atsignp
+ ,mincol ,colinc ,minpad ,padchar))
+ `(princ ,(if colonp
+ `(or ,(expand-next-arg) "()")
+ (expand-next-arg))
+ stream)))
+
+(def-format-directive #\S (colonp atsignp params)
+ (cond (params
+ (expand-bind-defaults ((mincol 0) (colinc 1) (minpad 0)
+ (padchar #\space))
+ params
+ `(format-prin1 stream ,(expand-next-arg) ,colonp ,atsignp
+ ,mincol ,colinc ,minpad ,padchar)))
+ (colonp
+ `(let ((arg ,(expand-next-arg)))
+ (if arg
+ (prin1 arg stream)
+ (princ "()" stream))))
+ (t
+ `(prin1 ,(expand-next-arg) stream))))
+
+(def-format-directive #\C (colonp atsignp params)
+ (expand-bind-defaults () params
+ (if colonp
+ `(format-print-named-character ,(expand-next-arg) stream)
+ (if atsignp
+ `(prin1 ,(expand-next-arg) stream)
+ `(write-char ,(expand-next-arg) stream)))))
+
+(def-format-directive #\W (colonp atsignp params)
+ (expand-bind-defaults () params
+ (if (or colonp atsignp)
+ `(let (,@(when colonp
+ '((*print-pretty* t)))
+ ,@(when atsignp
+ '((*print-level* nil)
+ (*print-length* nil))))
+ (output-object ,(expand-next-arg) stream))
+ `(output-object ,(expand-next-arg) stream))))
+\f
+;;;; format directives for integer output
+
+(defun expand-format-integer (base colonp atsignp params)
+ (if (or colonp atsignp params)
+ (expand-bind-defaults
+ ((mincol 0) (padchar #\space) (commachar #\,) (commainterval 3))
+ params
+ `(format-print-integer stream ,(expand-next-arg) ,colonp ,atsignp
+ ,base ,mincol ,padchar ,commachar
+ ,commainterval))
+ `(write ,(expand-next-arg) :stream stream :base ,base :radix nil
+ :escape nil)))
+
+(def-format-directive #\D (colonp atsignp params)
+ (expand-format-integer 10 colonp atsignp params))
+
+(def-format-directive #\B (colonp atsignp params)
+ (expand-format-integer 2 colonp atsignp params))
+
+(def-format-directive #\O (colonp atsignp params)
+ (expand-format-integer 8 colonp atsignp params))
+
+(def-format-directive #\X (colonp atsignp params)
+ (expand-format-integer 16 colonp atsignp params))
+
+(def-format-directive #\R (colonp atsignp params)
+ (if params
+ (expand-bind-defaults
+ ((base 10) (mincol 0) (padchar #\space) (commachar #\,)
+ (commainterval 3))
+ params
+ `(format-print-integer stream ,(expand-next-arg) ,colonp ,atsignp
+ ,base ,mincol
+ ,padchar ,commachar ,commainterval))
+ (if atsignp
+ (if colonp
+ `(format-print-old-roman stream ,(expand-next-arg))
+ `(format-print-roman stream ,(expand-next-arg)))
+ (if colonp
+ `(format-print-ordinal stream ,(expand-next-arg))
+ `(format-print-cardinal stream ,(expand-next-arg))))))
+\f
+;;;; format directive for pluralization
+
+(def-format-directive #\P (colonp atsignp params end)
+ (expand-bind-defaults () params
+ (let ((arg (cond
+ ((not colonp)
+ (expand-next-arg))
+ (*orig-args-available*
+ `(if (eq orig-args args)
+ (error 'format-error
+ :complaint "no previous argument"
+ :offset ,(1- end))
+ (do ((arg-ptr orig-args (cdr arg-ptr)))
+ ((eq (cdr arg-ptr) args)
+ (car arg-ptr)))))
+ (*only-simple-args*
+ (unless *simple-args*
+ (error 'format-error
+ :complaint "no previous argument"))
+ (caar *simple-args*))
+ (t
+ (throw 'need-orig-args nil)))))
+ (if atsignp
+ `(write-string (if (eql ,arg 1) "y" "ies") stream)
+ `(unless (eql ,arg 1) (write-char #\s stream))))))
+\f
+;;;; format directives for floating point output
+
+(def-format-directive #\F (colonp atsignp params)
+ (when colonp
+ (error 'format-error
+ :complaint
+ "The colon modifier cannot be used with this directive."))
+ (expand-bind-defaults ((w nil) (d nil) (k nil) (ovf nil) (pad #\space)) params
+ `(format-fixed stream ,(expand-next-arg) ,w ,d ,k ,ovf ,pad ,atsignp)))
+
+(def-format-directive #\E (colonp atsignp params)
+ (when colonp
+ (error 'format-error
+ :complaint
+ "The colon modifier cannot be used with this directive."))
+ (expand-bind-defaults
+ ((w nil) (d nil) (e nil) (k 1) (ovf nil) (pad #\space) (mark nil))
+ params
+ `(format-exponential stream ,(expand-next-arg) ,w ,d ,e ,k ,ovf ,pad ,mark
+ ,atsignp)))
+
+(def-format-directive #\G (colonp atsignp params)
+ (when colonp
+ (error 'format-error
+ :complaint
+ "The colon modifier cannot be used with this directive."))
+ (expand-bind-defaults
+ ((w nil) (d nil) (e nil) (k nil) (ovf nil) (pad #\space) (mark nil))
+ params
+ `(format-general stream ,(expand-next-arg) ,w ,d ,e ,k ,ovf ,pad ,mark ,atsignp)))
+
+(def-format-directive #\$ (colonp atsignp params)
+ (expand-bind-defaults ((d 2) (n 1) (w 0) (pad #\space)) params
+ `(format-dollars stream ,(expand-next-arg) ,d ,n ,w ,pad ,colonp
+ ,atsignp)))
+\f
+;;;; format directives for line/page breaks etc.
+
+(def-format-directive #\% (colonp atsignp params)
+ (when (or colonp atsignp)
+ (error 'format-error
+ :complaint
+ "The colon and atsign modifiers cannot be used with this directive."
+ ))
+ (if params
+ (expand-bind-defaults ((count 1)) params
+ `(dotimes (i ,count)
+ (terpri stream)))
+ '(terpri stream)))
+
+(def-format-directive #\& (colonp atsignp params)
+ (when (or colonp atsignp)
+ (error 'format-error
+ :complaint
+ "The colon and atsign modifiers cannot be used with this directive."
+ ))
+ (if params
+ (expand-bind-defaults ((count 1)) params
+ `(progn
+ (fresh-line stream)
+ (dotimes (i (1- ,count))
+ (terpri stream))))
+ '(fresh-line stream)))
+
+(def-format-directive #\| (colonp atsignp params)
+ (when (or colonp atsignp)
+ (error 'format-error
+ :complaint
+ "The colon and atsign modifiers cannot be used with this directive."
+ ))
+ (if params
+ (expand-bind-defaults ((count 1)) params
+ `(dotimes (i ,count)
+ (write-char (code-char form-feed-char-code) stream)))
+ '(write-char (code-char form-feed-char-code) stream)))
+
+(def-format-directive #\~ (colonp atsignp params)
+ (when (or colonp atsignp)
+ (error 'format-error
+ :complaint
+ "The colon and atsign modifiers cannot be used with this directive."
+ ))
+ (if params
+ (expand-bind-defaults ((count 1)) params
+ `(dotimes (i ,count)
+ (write-char #\~ stream)))
+ '(write-char #\~ stream)))
+
+(def-complex-format-directive #\newline (colonp atsignp params directives)
+ (when (and colonp atsignp)
+ (error 'format-error
+ :complaint "both colon and atsign modifiers used simultaneously"))
+ (values (expand-bind-defaults () params
+ (if atsignp
+ '(write-char #\newline stream)
+ nil))
+ (if (and (not colonp)
+ directives
+ (simple-string-p (car directives)))
+ (cons (string-left-trim *format-whitespace-chars*
+ (car directives))
+ (cdr directives))
+ directives)))
+\f
+;;;; format directives for tabs and simple pretty printing
+
+(def-format-directive #\T (colonp atsignp params)
+ (if colonp
+ (expand-bind-defaults ((n 1) (m 1)) params
+ `(pprint-tab ,(if atsignp :section-relative :section)
+ ,n ,m stream))
+ (if atsignp
+ (expand-bind-defaults ((colrel 1) (colinc 1)) params
+ `(format-relative-tab stream ,colrel ,colinc))
+ (expand-bind-defaults ((colnum 1) (colinc 1)) params
+ `(format-absolute-tab stream ,colnum ,colinc)))))
+
+(def-format-directive #\_ (colonp atsignp params)
+ (expand-bind-defaults () params
+ `(pprint-newline ,(if colonp
+ (if atsignp
+ :mandatory
+ :fill)
+ (if atsignp
+ :miser
+ :linear))
+ stream)))
+
+(def-format-directive #\I (colonp atsignp params)
+ (when atsignp
+ (error 'format-error
+ :complaint
+ "cannot use the at-sign modifier with this directive"))
+ (expand-bind-defaults ((n 0)) params
+ `(pprint-indent ,(if colonp :current :block) ,n stream)))
+\f
+;;;; format directive for ~*
+
+(def-format-directive #\* (colonp atsignp params end)
+ (if atsignp
+ (if colonp
+ (error 'format-error
+ :complaint
+ "both colon and atsign modifiers used simultaneously")
+ (expand-bind-defaults ((posn 0)) params
+ (unless *orig-args-available*
+ (throw 'need-orig-args nil))
+ `(if (<= 0 ,posn (length orig-args))
+ (setf args (nthcdr ,posn orig-args))
+ (error 'format-error
+ :complaint "Index ~D out of bounds. Should have been ~
+ between 0 and ~D."
+ :arguments (list ,posn (length orig-args))
+ :offset ,(1- end)))))
+ (if colonp
+ (expand-bind-defaults ((n 1)) params
+ (unless *orig-args-available*
+ (throw 'need-orig-args nil))
+ `(do ((cur-posn 0 (1+ cur-posn))
+ (arg-ptr orig-args (cdr arg-ptr)))
+ ((eq arg-ptr args)
+ (let ((new-posn (- cur-posn ,n)))
+ (if (<= 0 new-posn (length orig-args))
+ (setf args (nthcdr new-posn orig-args))
+ (error 'format-error
+ :complaint
+ "Index ~D is out of bounds; should have been ~
+ between 0 and ~D."
+ :arguments
+ (list new-posn (length orig-args))
+ :offset ,(1- end)))))))
+ (if params
+ (expand-bind-defaults ((n 1)) params
+ (setf *only-simple-args* nil)
+ `(dotimes (i ,n)
+ ,(expand-next-arg)))
+ (expand-next-arg)))))
+\f
+;;;; format directive for indirection
+
+(def-format-directive #\? (colonp atsignp params string end)
+ (when colonp
+ (error 'format-error
+ :complaint "cannot use the colon modifier with this directive"))
+ (expand-bind-defaults () params
+ `(handler-bind
+ ((format-error
+ #'(lambda (condition)
+ (error 'format-error
+ :complaint
+ "~A~%while processing indirect format string:"
+ :arguments (list condition)
+ :print-banner nil
+ :control-string ,string
+ :offset ,(1- end)))))
+ ,(if atsignp
+ (if *orig-args-available*
+ `(setf args (%format stream ,(expand-next-arg) orig-args args))
+ (throw 'need-orig-args nil))
+ `(%format stream ,(expand-next-arg) ,(expand-next-arg))))))
+\f
+;;;; format directives for capitalization
+
+(def-complex-format-directive #\( (colonp atsignp params directives)
+ (let ((close (find-directive directives #\) nil)))
+ (unless close
+ (error 'format-error
+ :complaint "no corresponding close parenthesis"))
+ (let* ((posn (position close directives))
+ (before (subseq directives 0 posn))
+ (after (nthcdr (1+ posn) directives)))
+ (values
+ (expand-bind-defaults () params
+ `(let ((stream (make-case-frob-stream stream
+ ,(if colonp
+ (if atsignp
+ :upcase
+ :capitalize)
+ (if atsignp
+ :capitalize-first
+ :downcase)))))
+ ,@(expand-directive-list before)))
+ after))))
+
+(def-complex-format-directive #\) ()
+ (error 'format-error
+ :complaint "no corresponding open parenthesis"))
+\f
+;;;; format directives and support functions for conditionalization
+
+(def-complex-format-directive #\[ (colonp atsignp params directives)
+ (multiple-value-bind (sublists last-semi-with-colon-p remaining)
+ (parse-conditional-directive directives)
+ (values
+ (if atsignp
+ (if colonp
+ (error 'format-error
+ :complaint
+ "both colon and atsign modifiers used simultaneously")
+ (if (cdr sublists)
+ (error 'format-error
+ :complaint
+ "Can only specify one section")
+ (expand-bind-defaults () params
+ (expand-maybe-conditional (car sublists)))))
+ (if colonp
+ (if (= (length sublists) 2)
+ (expand-bind-defaults () params
+ (expand-true-false-conditional (car sublists)
+ (cadr sublists)))
+ (error 'format-error
+ :complaint
+ "must specify exactly two sections"))
+ (expand-bind-defaults ((index (expand-next-arg))) params
+ (setf *only-simple-args* nil)
+ (let ((clauses nil))
+ (when last-semi-with-colon-p
+ (push `(t ,@(expand-directive-list (pop sublists)))
+ clauses))
+ (let ((count (length sublists)))
+ (dolist (sublist sublists)
+ (push `(,(decf count)
+ ,@(expand-directive-list sublist))
+ clauses)))
+ `(case ,index ,@clauses)))))
+ remaining)))
+
+(defun parse-conditional-directive (directives)
+ (let ((sublists nil)
+ (last-semi-with-colon-p nil)
+ (remaining directives))
+ (loop
+ (let ((close-or-semi (find-directive remaining #\] t)))
+ (unless close-or-semi
+ (error 'format-error
+ :complaint "no corresponding close bracket"))
+ (let ((posn (position close-or-semi remaining)))
+ (push (subseq remaining 0 posn) sublists)
+ (setf remaining (nthcdr (1+ posn) remaining))
+ (when (char= (format-directive-character close-or-semi) #\])
+ (return))
+ (setf last-semi-with-colon-p
+ (format-directive-colonp close-or-semi)))))
+ (values sublists last-semi-with-colon-p remaining)))
+
+(defun expand-maybe-conditional (sublist)
+ (flet ((hairy ()
+ `(let ((prev-args args)
+ (arg ,(expand-next-arg)))
+ (when arg
+ (setf args prev-args)
+ ,@(expand-directive-list sublist)))))
+ (if *only-simple-args*
+ (multiple-value-bind (guts new-args)
+ (let ((*simple-args* *simple-args*))
+ (values (expand-directive-list sublist)
+ *simple-args*))
+ (cond ((eq *simple-args* (cdr new-args))
+ (setf *simple-args* new-args)
+ `(when ,(caar new-args)
+ ,@guts))
+ (t
+ (setf *only-simple-args* nil)
+ (hairy))))
+ (hairy))))
+
+(defun expand-true-false-conditional (true false)
+ (let ((arg (expand-next-arg)))
+ (flet ((hairy ()
+ `(if ,arg
+ (progn
+ ,@(expand-directive-list true))
+ (progn
+ ,@(expand-directive-list false)))))
+ (if *only-simple-args*
+ (multiple-value-bind (true-guts true-args true-simple)
+ (let ((*simple-args* *simple-args*)
+ (*only-simple-args* t))
+ (values (expand-directive-list true)
+ *simple-args*
+ *only-simple-args*))
+ (multiple-value-bind (false-guts false-args false-simple)
+ (let ((*simple-args* *simple-args*)
+ (*only-simple-args* t))
+ (values (expand-directive-list false)
+ *simple-args*
+ *only-simple-args*))
+ (if (= (length true-args) (length false-args))
+ `(if ,arg
+ (progn
+ ,@true-guts)
+ ,(do ((false false-args (cdr false))
+ (true true-args (cdr true))
+ (bindings nil (cons `(,(caar false) ,(caar true))
+ bindings)))
+ ((eq true *simple-args*)
+ (setf *simple-args* true-args)
+ (setf *only-simple-args*
+ (and true-simple false-simple))
+ (if bindings
+ `(let ,bindings
+ ,@false-guts)
+ `(progn
+ ,@false-guts)))))
+ (progn
+ (setf *only-simple-args* nil)
+ (hairy)))))
+ (hairy)))))
+
+(def-complex-format-directive #\; ()
+ (error 'format-error
+ :complaint
+ "~~; directive not contained within either ~~[...~~] or ~~<...~~>"))
+
+(def-complex-format-directive #\] ()
+ (error 'format-error
+ :complaint
+ "no corresponding open bracket"))
+\f
+;;;; format directive for up-and-out
+
+(def-format-directive #\^ (colonp atsignp params)
+ (when atsignp
+ (error 'format-error
+ :complaint "cannot use the at-sign modifier with this directive"))
+ (when (and colonp (not *up-up-and-out-allowed*))
+ (error 'format-error
+ :complaint "attempt to use ~~:^ outside a ~~:{...~~} construct"))
+ `(when ,(case (length params)
+ (0 (if colonp
+ '(null outside-args)
+ (progn
+ (setf *only-simple-args* nil)
+ '(null args))))
+ (1 (expand-bind-defaults ((count 0)) params
+ `(zerop ,count)))
+ (2 (expand-bind-defaults ((arg1 0) (arg2 0)) params
+ `(= ,arg1 ,arg2)))
+ (t (expand-bind-defaults ((arg1 0) (arg2 0) (arg3 0)) params
+ `(<= ,arg1 ,arg2 ,arg3))))
+ ,(if colonp
+ '(return-from outside-loop nil)
+ '(return))))
+\f
+;;;; format directives for iteration
+
+(def-complex-format-directive #\{ (colonp atsignp params string end directives)
+ (let ((close (find-directive directives #\} nil)))
+ (unless close
+ (error 'format-error
+ :complaint "no corresponding close brace"))
+ (let* ((closed-with-colon (format-directive-colonp close))
+ (posn (position close directives)))
+ (labels
+ ((compute-insides ()
+ (if (zerop posn)
+ (if *orig-args-available*
+ `((handler-bind
+ ((format-error
+ #'(lambda (condition)
+ (error 'format-error
+ :complaint
+ "~A~%while processing indirect format string:"
+ :arguments (list condition)
+ :print-banner nil
+ :control-string ,string
+ :offset ,(1- end)))))
+ (setf args
+ (%format stream inside-string orig-args args))))
+ (throw 'need-orig-args nil))
+ (let ((*up-up-and-out-allowed* colonp))
+ (expand-directive-list (subseq directives 0 posn)))))
+ (compute-loop-aux (count)
+ (when atsignp
+ (setf *only-simple-args* nil))
+ `(loop
+ ,@(unless closed-with-colon
+ '((when (null args)
+ (return))))
+ ,@(when count
+ `((when (and ,count (minusp (decf ,count)))
+ (return))))
+ ,@(if colonp
+ (let ((*expander-next-arg-macro* 'expander-next-arg)
+ (*only-simple-args* nil)
+ (*orig-args-available* t))
+ `((let* ((orig-args ,(expand-next-arg))
+ (outside-args args)
+ (args orig-args))
+ (declare (ignorable orig-args outside-args args))
+ (block nil
+ ,@(compute-insides)))))
+ (compute-insides))
+ ,@(when closed-with-colon
+ '((when (null args)
+ (return))))))
+ (compute-loop ()
+ (if params
+ (expand-bind-defaults ((count nil)) params
+ (compute-loop-aux count))
+ (compute-loop-aux nil)))
+ (compute-block ()
+ (if colonp
+ `(block outside-loop
+ ,(compute-loop))
+ (compute-loop)))
+ (compute-bindings ()
+ (if atsignp
+ (compute-block)
+ `(let* ((orig-args ,(expand-next-arg))
+ (args orig-args))
+ (declare (ignorable orig-args args))
+ ,(let ((*expander-next-arg-macro* 'expander-next-arg)
+ (*only-simple-args* nil)
+ (*orig-args-available* t))
+ (compute-block))))))
+ (values (if (zerop posn)
+ `(let ((inside-string ,(expand-next-arg)))
+ ,(compute-bindings))
+ (compute-bindings))
+ (nthcdr (1+ posn) directives))))))
+
+(def-complex-format-directive #\} ()
+ (error 'format-error
+ :complaint "no corresponding open brace"))
+\f
+;;;; format directives and support functions for justification
+
+(def-complex-format-directive #\< (colonp atsignp params string end directives)
+ (multiple-value-bind (segments first-semi close remaining)
+ (parse-format-justification directives)
+ (values
+ (if (format-directive-colonp close)
+ (multiple-value-bind (prefix per-line-p insides suffix)
+ (parse-format-logical-block segments colonp first-semi
+ close params string end)
+ (expand-format-logical-block prefix per-line-p insides
+ suffix atsignp))
+ (expand-format-justification segments colonp atsignp
+ first-semi params))
+ remaining)))
+
+(def-complex-format-directive #\> ()
+ (error 'format-error
+ :complaint "no corresponding open bracket"))
+
+(defun parse-format-logical-block
+ (segments colonp first-semi close params string end)
+ (when params
+ (error 'format-error
+ :complaint "No parameters can be supplied with ~~<...~~:>."
+ :offset (caar params)))
+ (multiple-value-bind (prefix insides suffix)
+ (multiple-value-bind (prefix-default suffix-default)
+ (if colonp (values "(" ")") (values nil ""))
+ (flet ((extract-string (list prefix-p)
+ (let ((directive (find-if #'format-directive-p list)))
+ (if directive
+ (error 'format-error
+ :complaint
+ "cannot include format directives inside the ~
+ ~:[suffix~;prefix~] segment of ~~<...~~:>"
+ :arguments (list prefix-p)
+ :offset (1- (format-directive-end directive)))
+ (apply #'concatenate 'string list)))))
+ (case (length segments)
+ (0 (values prefix-default nil suffix-default))
+ (1 (values prefix-default (car segments) suffix-default))
+ (2 (values (extract-string (car segments) t)
+ (cadr segments) suffix-default))
+ (3 (values (extract-string (car segments) t)
+ (cadr segments)
+ (extract-string (caddr segments) nil)))
+ (t
+ (error 'format-error
+ :complaint "too many segments for ~~<...~~:>")))))
+ (when (format-directive-atsignp close)
+ (setf insides
+ (add-fill-style-newlines insides
+ string
+ (if first-semi
+ (format-directive-end first-semi)
+ end))))
+ (values prefix
+ (and first-semi (format-directive-atsignp first-semi))
+ insides
+ suffix)))
+
+(defun add-fill-style-newlines (list string offset)
+ (if list
+ (let ((directive (car list)))
+ (if (simple-string-p directive)
+ (nconc (add-fill-style-newlines-aux directive string offset)
+ (add-fill-style-newlines (cdr list)
+ string
+ (+ offset (length directive))))
+ (cons directive
+ (add-fill-style-newlines (cdr list)
+ string
+ (format-directive-end directive)))))
+ nil))
+
+(defun add-fill-style-newlines-aux (literal string offset)
+ (let ((end (length literal))
+ (posn 0))
+ (collect ((results))
+ (loop
+ (let ((blank (position #\space literal :start posn)))
+ (when (null blank)
+ (results (subseq literal posn))
+ (return))
+ (let ((non-blank (or (position #\space literal :start blank
+ :test #'char/=)
+ end)))
+ (results (subseq literal posn non-blank))
+ (results (make-format-directive
+ :string string :character #\_
+ :start (+ offset non-blank) :end (+ offset non-blank)
+ :colonp t :atsignp nil :params nil))
+ (setf posn non-blank))
+ (when (= posn end)
+ (return))))
+ (results))))
+
+(defun parse-format-justification (directives)
+ (let ((first-semi nil)
+ (close nil)
+ (remaining directives))
+ (collect ((segments))
+ (loop
+ (let ((close-or-semi (find-directive remaining #\> t)))
+ (unless close-or-semi
+ (error 'format-error
+ :complaint "no corresponding close bracket"))
+ (let ((posn (position close-or-semi remaining)))
+ (segments (subseq remaining 0 posn))
+ (setf remaining (nthcdr (1+ posn) remaining)))
+ (when (char= (format-directive-character close-or-semi)
+ #\>)
+ (setf close close-or-semi)
+ (return))
+ (unless first-semi
+ (setf first-semi close-or-semi))))
+ (values (segments) first-semi close remaining))))
+
+(sb!xc:defmacro expander-pprint-next-arg (string offset)
+ `(progn
+ (when (null args)
+ (error 'format-error
+ :complaint "no more arguments"
+ :control-string ,string
+ :offset ,offset))
+ (pprint-pop)
+ (pop args)))
+
+(defun expand-format-logical-block (prefix per-line-p insides suffix atsignp)
+ `(let ((arg ,(if atsignp 'args (expand-next-arg))))
+ ,@(when atsignp
+ (setf *only-simple-args* nil)
+ '((setf args nil)))
+ (pprint-logical-block
+ (stream arg
+ ,(if per-line-p :per-line-prefix :prefix) ,prefix
+ :suffix ,suffix)
+ (let ((args arg)
+ ,@(unless atsignp
+ `((orig-args arg))))
+ (declare (ignorable args ,@(unless atsignp '(orig-args))))
+ (block nil
+ ,@(let ((*expander-next-arg-macro* 'expander-pprint-next-arg)
+ (*only-simple-args* nil)
+ (*orig-args-available* t))
+ (expand-directive-list insides)))))))
+
+(defun expand-format-justification (segments colonp atsignp first-semi params)
+ (let ((newline-segment-p
+ (and first-semi
+ (format-directive-colonp first-semi))))
+ (expand-bind-defaults
+ ((mincol 0) (colinc 1) (minpad 0) (padchar #\space))
+ params
+ `(let ((segments nil)
+ ,@(when newline-segment-p
+ '((newline-segment nil)
+ (extra-space 0)
+ (line-len 72))))
+ (block nil
+ ,@(when newline-segment-p
+ `((setf newline-segment
+ (with-output-to-string (stream)
+ ,@(expand-directive-list (pop segments))))
+ ,(expand-bind-defaults
+ ((extra 0)
+ (line-len '(or (sb!impl::line-length stream) 72)))
+ (format-directive-params first-semi)
+ `(setf extra-space ,extra line-len ,line-len))))
+ ,@(mapcar #'(lambda (segment)
+ `(push (with-output-to-string (stream)
+ ,@(expand-directive-list segment))
+ segments))
+ segments))
+ (format-justification stream
+ ,@(if newline-segment-p
+ '(newline-segment extra-space line-len)
+ '(nil 0 0))
+ segments ,colonp ,atsignp
+ ,mincol ,colinc ,minpad ,padchar)))))
+\f
+;;;; format directive and support function for user-defined method
+
+(def-format-directive #\/ (string start end colonp atsignp params)
+ (let ((symbol (extract-user-function-name string start end)))
+ (collect ((param-names) (bindings))
+ (dolist (param-and-offset params)
+ (let ((param (cdr param-and-offset)))
+ (let ((param-name (gensym)))
+ (param-names param-name)
+ (bindings `(,param-name
+ ,(case param
+ (:arg (expand-next-arg))
+ (:remaining '(length args))
+ (t param)))))))
+ `(let ,(bindings)
+ (,symbol stream ,(expand-next-arg) ,colonp ,atsignp
+ ,@(param-names))))))
+
+(defun extract-user-function-name (string start end)
+ (let ((slash (position #\/ string :start start :end (1- end)
+ :from-end t)))
+ (unless slash
+ (error 'format-error
+ :complaint "malformed ~~/ directive"))
+ (let* ((name (string-upcase (let ((foo string))
+ ;; Hack alert: This is to keep the compiler
+ ;; quiet about deleting code inside the
+ ;; subseq expansion.
+ (subseq foo (1+ slash) (1- end)))))
+ (first-colon (position #\: name))
+ (last-colon (if first-colon (position #\: name :from-end t)))
+ (package-name (if last-colon
+ (subseq name 0 first-colon)
+ "COMMON-LISP-USER"))
+ (package (find-package package-name)))
+ (unless package
+ ;; FIXME: should be PACKAGE-ERROR? Could we just use
+ ;; FIND-UNDELETED-PACKAGE-OR-LOSE?
+ (error 'format-error
+ :complaint "no package named ~S"
+ :arguments (list package-name)))
+ (intern (if first-colon
+ (subseq name (1+ first-colon))
+ name)
+ package))))
--- /dev/null
+;;;; SETF-related stuff which requires COLLECT, separated into this
+;;;; separate file to deal with boot order problems (since COLLECT
+;;;; requires other SETF-related stuff)
+;;;;
+;;;; FIXME: Now that we don't do bogobootstrapping, these boot order
+;;;; problems may no longer exist, so perhaps we could merge back with
+;;;; other SETF logic.
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!IMPL")
+
+(file-comment
+ "$Header$")
+
+(defmacro-mundanely psetf (&rest args &environment env)
+ #!+sb-doc
+ "This is to SETF as PSETQ is to SETQ. Args are alternating place
+ expressions and values to go into those places. All of the subforms and
+ values are determined, left to right, and only then are the locations
+ updated. Returns NIL."
+ (declare (type sb!c::lexenv env))
+ (collect ((let*-bindings) (mv-bindings) (setters))
+ (do ((a args (cddr a)))
+ ((endp a))
+ (if (endp (cdr a))
+ (error "Odd number of args to PSETF."))
+ (multiple-value-bind (dummies vals newval setter getter)
+ (sb!xc:get-setf-expansion (car a) env)
+ (declare (ignore getter))
+ (let*-bindings (mapcar #'list dummies vals))
+ (mv-bindings (list newval (cadr a)))
+ (setters setter)))
+ (labels ((thunk (let*-bindings mv-bindings)
+ (if let*-bindings
+ `(let* ,(car let*-bindings)
+ (multiple-value-bind ,@(car mv-bindings)
+ ,(thunk (cdr let*-bindings) (cdr mv-bindings))))
+ `(progn ,@(setters) nil))))
+ (thunk (let*-bindings) (mv-bindings)))))
+
+;;; FIXME: Compiling this definition of ROTATEF apparently blows away the
+;;; definition in the cross-compiler itself, so that after that, any
+;;; ROTATEF operations can no longer be compiled, because
+;;; GET-SETF-EXPANSION is called instead of SB!XC:GET-SETF-EXPANSION.
+(defmacro-mundanely rotatef (&rest args &environment env)
+ #!+sb-doc
+ "Takes any number of SETF-style place expressions. Evaluates all of the
+ expressions in turn, then assigns to each place the value of the form to
+ its right. The rightmost form gets the value of the leftmost.
+ Returns NIL."
+ (declare (type sb!c::lexenv env))
+ (when args
+ (collect ((let*-bindings) (mv-bindings) (setters) (getters))
+ (dolist (arg args)
+ (multiple-value-bind (temps subforms store-vars setter getter)
+ (sb!xc:get-setf-expansion arg env)
+ (loop
+ for temp in temps
+ for subform in subforms
+ do (let*-bindings `(,temp ,subform)))
+ (mv-bindings store-vars)
+ (setters setter)
+ (getters getter)))
+ (setters nil)
+ (getters (car (getters)))
+ (labels ((thunk (mv-bindings getters)
+ (if mv-bindings
+ `((multiple-value-bind ,(car mv-bindings) ,(car getters)
+ ,@(thunk (cdr mv-bindings) (cdr getters))))
+ (setters))))
+ `(let* ,(let*-bindings)
+ ,@(thunk (mv-bindings) (cdr (getters))))))))
+
+(sb!xc:define-setf-expander values (&rest places &environment env)
+ (declare (type sb!c::lexenv env))
+ (collect ((setters) (getters))
+ (let ((all-dummies '())
+ (all-vals '())
+ (newvals '()))
+ (dolist (place places)
+ (multiple-value-bind (dummies vals newval setter getter)
+ (sb!xc:get-setf-expansion place env)
+ (setq all-dummies (append all-dummies dummies)
+ all-vals (append all-vals vals)
+ newvals (append newvals newval))
+ (setters setter)
+ (getters getter)))
+ (values all-dummies all-vals newvals
+ `(values ,@(setters)) `(values ,@(getters))))))
--- /dev/null
+;;;; stuff originally from CMU CL's error.lisp which can or should
+;;;; come late (mostly related to the CONDITION class itself)
+;;;;
+;;;; FIXME: should perhaps be called condition.lisp, or moved into
+;;;; classes.lisp
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!CONDITIONS")
+
+(sb!int:file-comment
+ "$Header$")
+\f
+;;;; the CONDITION class
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+
+(def!struct (condition-class (:include slot-class)
+ (:constructor bare-make-condition-class))
+ ;; List of CONDITION-SLOT structures for the direct slots of this class.
+ (slots nil :type list)
+ ;; List of CONDITION-SLOT structures for all of the effective class slots of
+ ;; this class.
+ (class-slots nil :type list)
+ ;; Report function or NIL.
+ (report nil :type (or function null))
+ ;; List of alternating initargs and initforms.
+ (default-initargs () :type list)
+ ;; CPL as a list of class objects, with all non-condition classes removed.
+ (cpl () :type list)
+ ;; A list of all the effective instance allocation slots of this class that
+ ;; have a non-constant initform or default-initarg. Values for these slots
+ ;; must be computed in the dynamic environment of MAKE-CONDITION.
+ (hairy-slots nil :type list))
+
+(defun make-condition-class (&rest rest)
+ (apply #'bare-make-condition-class
+ (rename-keyword-args '((:name :%name)) rest)))
+
+) ; EVAL-WHEN
+
+(defstruct (condition
+ (:constructor make-condition-object (actual-initargs))
+ (:alternate-metaclass instance
+ condition-class
+ make-condition-class)
+ (:copier nil))
+
+ (function-name nil)
+ ;; Actual initargs supplied to MAKE-CONDITION.
+ (actual-initargs (required-argument) :type list)
+ ;; Plist mapping slot names to any values that were assigned or defaulted
+ ;; after creation.
+ (assigned-slots () :type list))
+
+(defstruct condition-slot
+ (name (required-argument) :type symbol)
+ ;; List of all applicable initargs.
+ (initargs (required-argument) :type list)
+ ;; Names of reader and writer functions.
+ (readers (required-argument) :type list)
+ (writers (required-argument) :type list)
+ ;; True if :INITFORM was specified.
+ (initform-p (required-argument) :type (member t nil))
+ ;; If a function, call it with no args. Otherwise, the actual value.
+ (initform (required-argument) :type t)
+ ;; Allocation of this slot. Nil only until defaulted.
+ (allocation nil :type (member :instance :class nil))
+ ;; If :class allocation, a cons whose car holds the value.
+ (cell nil :type (or cons null)))
+
+(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
+ ;; the appropriate initialization value for the CPL slot of a CONDITION,
+ ;; calculated by looking at the INHERITS information in the LAYOUT
+ ;; of the CONDITION
+ (defun condition-class-cpl-from-layout (condition)
+ (declare (type condition condition))
+ (let* ((class (sb!xc:find-class condition))
+ (layout (class-layout class))
+ (superset (map 'list #'identity (layout-inherits layout))))
+ (delete-if (lambda (superclass)
+ (not (typep superclass 'condition-class)))
+ superset))))
+
+;;; KLUDGE: It's not clear to me why CONDITION-CLASS has itself listed in its
+;;; CPL, while other classes derived from CONDITION-CLASS don't have themselves
+;;; listed in their CPLs. This behavior is inherited from CMU CL, and didn't
+;;; seem to be explained there, and I haven't figured out whether it's right.
+;;; -- WHN 19990612
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (let ((condition-class (locally
+ ;; KLUDGE: There's a FIND-CLASS DEFTRANSFORM for
+ ;; constant class names which creates fast but
+ ;; non-cold-loadable, non-compact code. In this
+ ;; context, we'd rather have compact, cold-loadable
+ ;; code. -- WHN 19990928
+ (declare (notinline sb!xc:find-class))
+ (sb!xc:find-class 'condition))))
+ (setf (condition-class-cpl condition-class)
+ (list condition-class))))
+
+(setf (condition-class-report (locally
+ ;; KLUDGE: There's a FIND-CLASS DEFTRANSFORM
+ ;; for constant class names which creates fast
+ ;; but non-cold-loadable, non-compact code. In
+ ;; this context, we'd rather have compact,
+ ;; cold-loadable code. -- WHN 19990928
+ (declare (notinline sb!xc:find-class))
+ (find-class 'condition)))
+ #'(lambda (cond stream)
+ (format stream "Condition ~S was signalled." (type-of cond))))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+
+(defun find-condition-layout (name parent-types)
+ (let* ((cpl (remove-duplicates
+ (reverse
+ (reduce #'append
+ (mapcar #'(lambda (x)
+ (condition-class-cpl
+ (sb!xc:find-class x)))
+ parent-types)))))
+ (cond-layout (info :type :compiler-layout 'condition))
+ (olayout (info :type :compiler-layout name))
+ (new-inherits
+ (concatenate 'simple-vector
+ (layout-inherits cond-layout)
+ (mapcar #'class-layout cpl))))
+ (if (and olayout
+ (not (mismatch (layout-inherits olayout) new-inherits)))
+ olayout
+ (make-layout :class (make-undefined-class name)
+ :inherits new-inherits
+ :depthoid -1
+ :length (layout-length cond-layout)))))
+
+) ; EVAL-WHEN
+
+;;; FIXME: ANSI's definition of DEFINE-CONDITION says
+;;; Condition reporting is mediated through the print-object method for
+;;; the condition type in question, with *print-escape* always being nil.
+;;; Specifying (:report report-name) in the definition of a condition
+;;; type C is equivalent to:
+;;; (defmethod print-object ((x c) stream)
+;;; (if *print-escape* (call-next-method) (report-name x stream)))
+;;; The current code doesn't seem to quite match that.
+(def!method print-object ((x condition) stream)
+ (if *print-escape*
+ (print-unreadable-object (x stream :type t :identity t))
+ ;; KLUDGE: A comment from CMU CL here said
+ ;; 7/13/98 BUG? CPL is not sorted and results here depend on order of
+ ;; superclasses in define-condition call!
+ (dolist (class (condition-class-cpl (sb!xc:class-of x))
+ (error "no REPORT? shouldn't happen!"))
+ (let ((report (condition-class-report class)))
+ (when report
+ (return (funcall report x stream)))))))
+\f
+;;;; slots of CONDITION objects
+
+(defvar *empty-slot* '(empty))
+
+(defun find-slot-default (class slot)
+ (let ((initargs (condition-slot-initargs slot))
+ (cpl (condition-class-cpl class)))
+ (dolist (class cpl)
+ (let ((default-initargs (condition-class-default-initargs class)))
+ (dolist (initarg initargs)
+ (let ((val (getf default-initargs initarg *empty-slot*)))
+ (unless (eq val *empty-slot*)
+ (return-from find-slot-default
+ (if (functionp val)
+ (funcall val)
+ val)))))))
+
+ (if (condition-slot-initform-p slot)
+ (let ((initform (condition-slot-initform slot)))
+ (if (functionp initform)
+ (funcall initform)
+ initform))
+ (error "unbound condition slot: ~S" (condition-slot-name slot)))))
+
+(defun find-slot (classes name)
+ (dolist (sclass classes nil)
+ (dolist (slot (condition-class-slots sclass))
+ (when (eq (condition-slot-name slot) name)
+ (return-from find-slot slot)))))
+
+(defun condition-writer-function (condition new-value name)
+ (dolist (cslot (condition-class-class-slots
+ (layout-class (%instance-layout condition)))
+ (setf (getf (condition-assigned-slots condition) name)
+ new-value))
+ (when (eq (condition-slot-name cslot) name)
+ (return (setf (car (condition-slot-cell cslot)) new-value)))))
+
+(defun condition-reader-function (condition name)
+ (let ((class (layout-class (%instance-layout condition))))
+ (dolist (cslot (condition-class-class-slots class))
+ (when (eq (condition-slot-name cslot) name)
+ (return-from condition-reader-function
+ (car (condition-slot-cell cslot)))))
+
+ (let ((val (getf (condition-assigned-slots condition) name
+ *empty-slot*)))
+ (if (eq val *empty-slot*)
+ (let ((actual-initargs (condition-actual-initargs condition))
+ (slot (find-slot (condition-class-cpl class) name)))
+ (dolist (initarg (condition-slot-initargs slot))
+ (let ((val (getf actual-initargs initarg *empty-slot*)))
+ (unless (eq val *empty-slot*)
+ (return-from condition-reader-function
+ (setf (getf (condition-assigned-slots condition)
+ name)
+ val)))))
+ (setf (getf (condition-assigned-slots condition) name)
+ (find-slot-default class slot)))
+ val))))
+\f
+;;;; MAKE-CONDITION
+
+(defun make-condition (thing &rest args)
+ #!+sb-doc
+ "Make an instance of a condition object using the specified initargs."
+ ;; Note: ANSI specifies no exceptional situations in this function.
+ ;; signalling simple-type-error would not be wrong.
+ (let* ((thing (if (symbolp thing)
+ (sb!xc:find-class thing)
+ thing))
+ (class (typecase thing
+ (condition-class thing)
+ (class
+ (error 'simple-type-error
+ :datum thing
+ :expected-type 'condition-class
+ :format-control "~S is not a condition class."
+ :format-arguments (list thing)))
+ (t
+ (error 'simple-type-error
+ :datum thing
+ :expected-type 'condition-class
+ :format-control "bad thing for class arg:~% ~S"
+ :format-arguments (list thing)))))
+ (res (make-condition-object args)))
+ (setf (%instance-layout res) (class-layout class))
+ ;; Set any class slots with initargs present in this call.
+ (dolist (cslot (condition-class-class-slots class))
+ (dolist (initarg (condition-slot-initargs cslot))
+ (let ((val (getf args initarg *empty-slot*)))
+ (unless (eq val *empty-slot*)
+ (setf (car (condition-slot-cell cslot)) val)))))
+ ;; Default any slots with non-constant defaults now.
+ (dolist (hslot (condition-class-hairy-slots class))
+ (when (dolist (initarg (condition-slot-initargs hslot) t)
+ (unless (eq (getf args initarg *empty-slot*) *empty-slot*)
+ (return nil)))
+ (setf (getf (condition-assigned-slots res) (condition-slot-name hslot))
+ (find-slot-default class hslot))))
+
+ res))
+\f
+;;;; DEFINE-CONDITION
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+(defun %compiler-define-condition (name direct-supers layout)
+ (multiple-value-bind (class old-layout)
+ (insured-find-class name #'condition-class-p #'make-condition-class)
+ (setf (layout-class layout) class)
+ (setf (class-direct-superclasses class)
+ (mapcar #'sb!xc:find-class direct-supers))
+ (cond ((not old-layout)
+ (register-layout layout))
+ ((not *type-system-initialized*)
+ (setf (layout-class old-layout) class)
+ (setq layout old-layout)
+ (unless (eq (class-layout class) layout)
+ (register-layout layout)))
+ ((redefine-layout-warning "current"
+ old-layout
+ "new"
+ (layout-length layout)
+ (layout-inherits layout)
+ (layout-depthoid layout))
+ (register-layout layout :invalidate t))
+ ((not (class-layout class))
+ (register-layout layout)))
+
+ (setf (layout-info layout)
+ (locally
+ ;; KLUDGE: There's a FIND-CLASS DEFTRANSFORM for constant class
+ ;; names which creates fast but non-cold-loadable, non-compact
+ ;; code. In this context, we'd rather have compact, cold-loadable
+ ;; code. -- WHN 19990928
+ (declare (notinline sb!xc:find-class))
+ (layout-info (class-layout (sb!xc:find-class 'condition)))))
+
+ (setf (sb!xc:find-class name) class)
+
+ ;; Initialize CPL slot from layout.
+ (collect ((cpl))
+ (cpl class)
+ (let ((inherits (layout-inherits layout)))
+ (do ((i (1- (length inherits)) (1- i)))
+ ((minusp i))
+ (let ((super (sb!xc:find-class
+ (sb!xc:class-name
+ (layout-class (svref inherits i))))))
+ (when (typep super 'condition-class)
+ (cpl super)))))
+ (setf (condition-class-cpl class) (cpl))))
+
+ (values))
+
+) ; EVAL-WHEN
+
+;;; Compute the effective slots of class, copying inherited slots and
+;;; side-effecting direct slots.
+(defun compute-effective-slots (class)
+ (collect ((res (copy-list (condition-class-slots class))))
+ (dolist (sclass (condition-class-cpl class))
+ (dolist (sslot (condition-class-slots sclass))
+ (let ((found (find (condition-slot-name sslot) (res)
+ :test #'eq)))
+ (cond (found
+ (setf (condition-slot-initargs found)
+ (union (condition-slot-initargs found)
+ (condition-slot-initargs sslot)))
+ (unless (condition-slot-initform-p found)
+ (setf (condition-slot-initform-p found)
+ (condition-slot-initform-p sslot))
+ (setf (condition-slot-initform found)
+ (condition-slot-initform sslot)))
+ (unless (condition-slot-allocation found)
+ (setf (condition-slot-allocation found)
+ (condition-slot-allocation sslot))))
+ (t
+ (res (copy-structure sslot)))))))
+ (res)))
+
+(defun %define-condition (name slots documentation report default-initargs)
+ (let ((class (sb!xc:find-class name)))
+ (setf (condition-class-slots class) slots)
+ (setf (condition-class-report class) report)
+ (setf (condition-class-default-initargs class) default-initargs)
+ (setf (fdocumentation name 'type) documentation)
+
+ (dolist (slot slots)
+
+ ;; Set up reader and writer functions.
+ (let ((name (condition-slot-name slot)))
+ (dolist (reader (condition-slot-readers slot))
+ (setf (fdefinition reader)
+ #'(lambda (condition)
+ (condition-reader-function condition name))))
+ (dolist (writer (condition-slot-writers slot))
+ (setf (fdefinition writer)
+ #'(lambda (new-value condition)
+ (condition-writer-function condition new-value name))))))
+
+ ;; Compute effective slots and set up the class and hairy slots (subsets of
+ ;; the effective slots.)
+ (let ((eslots (compute-effective-slots class))
+ (e-def-initargs
+ (reduce #'append
+ (mapcar #'condition-class-default-initargs
+ (condition-class-cpl class)))))
+ (dolist (slot eslots)
+ (ecase (condition-slot-allocation slot)
+ (:class
+ (unless (condition-slot-cell slot)
+ (setf (condition-slot-cell slot)
+ (list (if (condition-slot-initform-p slot)
+ (let ((initform (condition-slot-initform slot)))
+ (if (functionp initform)
+ (funcall initform)
+ initform))
+ *empty-slot*))))
+ (push slot (condition-class-class-slots class)))
+ ((:instance nil)
+ (setf (condition-slot-allocation slot) :instance)
+ (when (or (functionp (condition-slot-initform slot))
+ (dolist (initarg (condition-slot-initargs slot) nil)
+ (when (functionp (getf e-def-initargs initarg))
+ (return t))))
+ (push slot (condition-class-hairy-slots class))))))))
+ name)
+
+(defmacro define-condition (name (&rest parent-types) (&rest slot-specs)
+ &body options)
+ #!+sb-doc
+ "DEFINE-CONDITION Name (Parent-Type*) (Slot-Spec*) Option*
+ Define NAME as a condition type. This new type inherits slots and its
+ report function from the specified PARENT-TYPEs. A slot spec is a list of:
+ (slot-name :reader <rname> :initarg <iname> {Option Value}*
+
+ The DEFINE-CLASS slot options :ALLOCATION, :INITFORM, [slot] :DOCUMENTATION
+ and :TYPE and the overall options :DEFAULT-INITARGS and
+ [type] :DOCUMENTATION are also allowed.
+
+ The :REPORT option is peculiar to DEFINE-CONDITION. Its argument is either
+ a string or a two-argument lambda or function name. If a function, the
+ function is called with the condition and stream to report the condition.
+ If a string, the string is printed.
+
+ Condition types are classes, but (as allowed by ANSI and not as described in
+ CLtL2) are neither STANDARD-OBJECTs nor STRUCTURE-OBJECTs. WITH-SLOTS and
+ SLOT-VALUE may not be used on condition objects."
+ (let* ((parent-types (or parent-types '(condition)))
+ (layout (find-condition-layout name parent-types))
+ (documentation nil)
+ (report nil)
+ (default-initargs ()))
+ (collect ((slots)
+ (all-readers nil append)
+ (all-writers nil append))
+ (dolist (spec slot-specs)
+ (when (keywordp spec)
+ (warn "Keyword slot name indicates probable syntax error:~% ~S"
+ spec))
+ (let* ((spec (if (consp spec) spec (list spec)))
+ (slot-name (first spec))
+ (allocation :instance)
+ (initform-p nil)
+ initform)
+ (collect ((initargs)
+ (readers)
+ (writers))
+ (do ((options (rest spec) (cddr options)))
+ ((null options))
+ (unless (and (consp options) (consp (cdr options)))
+ (error "malformed condition slot spec:~% ~S." spec))
+ (let ((arg (second options)))
+ (case (first options)
+ (:reader (readers arg))
+ (:writer (writers arg))
+ (:accessor
+ (readers arg)
+ (writers `(setf ,arg)))
+ (:initform
+ (when initform-p
+ (error "more than one :INITFORM in ~S" spec))
+ (setq initform-p t)
+ (setq initform arg))
+ (:initarg (initargs arg))
+ (:allocation
+ (setq allocation arg))
+ (:type)
+ (t
+ (error "unknown slot option:~% ~S" (first options))))))
+
+ (all-readers (readers))
+ (all-writers (writers))
+ (slots `(make-condition-slot
+ :name ',slot-name
+ :initargs ',(initargs)
+ :readers ',(readers)
+ :writers ',(writers)
+ :initform-p ',initform-p
+ :initform
+ ,(if (constantp initform)
+ `',(eval initform)
+ `#'(lambda () ,initform)))))))
+
+ (dolist (option options)
+ (unless (consp option)
+ (error "bad option:~% ~S" option))
+ (case (first option)
+ (:documentation (setq documentation (second option)))
+ (:report
+ (let ((arg (second option)))
+ (setq report
+ (if (stringp arg)
+ `#'(lambda (condition stream)
+ (declare (ignore condition))
+ (write-string ,arg stream))
+ `#'(lambda (condition stream)
+ (funcall #',arg condition stream))))))
+ (:default-initargs
+ (do ((initargs (rest option) (cddr initargs)))
+ ((endp initargs))
+ (let ((val (second initargs)))
+ (setq default-initargs
+ (list* `',(first initargs)
+ (if (constantp val)
+ `',(eval val)
+ `#'(lambda () ,val))
+ default-initargs)))))
+ (t
+ (error "unknown option: ~S" (first option)))))
+
+ (when (all-writers)
+ (warn "Condition slot setters probably not allowed in ANSI CL:~% ~S"
+ (all-writers)))
+
+ `(progn
+ (eval-when (:compile-toplevel :load-toplevel :execute)
+ (%compiler-define-condition ',name ',parent-types ',layout))
+
+ (declaim (ftype (function (t) t) ,@(all-readers)))
+ (declaim (ftype (function (t t) t) ,@(all-writers)))
+
+ (%define-condition ',name
+ (list ,@(slots))
+ ,documentation
+ ,report
+ (list ,@default-initargs))))))
+\f
+;;;; various CONDITIONs specified by ANSI
+
+(define-condition serious-condition (condition)())
+
+(define-condition error (serious-condition) ())
+
+(define-condition warning (condition) ())
+(define-condition style-warning (warning) ())
+
+(defun simple-condition-printer (condition stream)
+ ;; FIXME: Why use APPLY instead of an ordinary form? To stop the optimizer
+ ;; from doing something?
+ (apply #'format stream (simple-condition-format-control condition)
+ (simple-condition-format-arguments condition)))
+
+(define-condition simple-condition ()
+ ((format-control :reader simple-condition-format-control
+ :initarg :format-control)
+ (format-arguments :reader simple-condition-format-arguments
+ :initarg :format-arguments
+ :initform '()))
+ (:report simple-condition-printer))
+
+(define-condition simple-warning (simple-condition warning) ())
+
+(defun print-simple-error (condition stream)
+ (format stream
+ "~&~@<error in function ~S: ~3I~:_~?~:>"
+ (condition-function-name condition)
+ (simple-condition-format-control condition)
+ (simple-condition-format-arguments condition)))
+
+(define-condition simple-error (simple-condition error) ()
+ ;; This is the condition type used by ERROR and CERROR when
+ ;; a format-control string is supplied as the first argument.
+ (:report print-simple-error))
+
+(define-condition storage-condition (serious-condition) ())
+
+;;; FIXME: Should we really be reporting CONDITION-FUNCTION-NAME data on an
+;;; ad hoc basis, for some conditions and not others? Why not standardize
+;;; it somehow? perhaps by making the debugger report it?
+
+(define-condition type-error (error)
+ ((datum :reader type-error-datum :initarg :datum)
+ (expected-type :reader type-error-expected-type :initarg :expected-type))
+ (:report
+ (lambda (condition stream)
+ (format stream
+ "~@<TYPE-ERROR in ~S: ~3I~:_~S is not of type ~S~:>."
+ (condition-function-name condition)
+ (type-error-datum condition)
+ (type-error-expected-type condition)))))
+
+(define-condition program-error (error) ())
+(define-condition parse-error (error) ())
+(define-condition control-error (error) ())
+(define-condition stream-error (error)
+ ((stream :reader stream-error-stream :initarg :stream)))
+
+(define-condition end-of-file (stream-error) ()
+ (:report
+ (lambda (condition stream)
+ (format stream
+ "END-OF-FILE on ~S"
+ (stream-error-stream condition)))))
+
+(define-condition file-error (error)
+ ((pathname :reader file-error-pathname :initarg :pathname))
+ (:report
+ (lambda (condition stream)
+ (format stream
+ "~&~@<FILE-ERROR in function ~S: ~3i~:_~?~:>"
+ (condition-function-name condition)
+ (serious-condition-format-control condition)
+ (serious-condition-format-arguments condition)))))
+
+(define-condition package-error (error)
+ ((package :reader package-error-package :initarg :package)))
+
+(define-condition cell-error (error)
+ ((name :reader cell-error-name :initarg :name)))
+
+(define-condition unbound-variable (cell-error) ()
+ (:report
+ (lambda (condition stream)
+ (format stream
+ "error in ~S: The variable ~S is unbound."
+ (condition-function-name condition)
+ (cell-error-name condition)))))
+
+(define-condition undefined-function (cell-error) ()
+ (:report
+ (lambda (condition stream)
+ (format stream
+ "error in ~S: The function ~S is undefined."
+ (condition-function-name condition)
+ (cell-error-name condition)))))
+
+(define-condition arithmetic-error (error)
+ ((operation :reader arithmetic-error-operation
+ :initarg :operation
+ :initform nil)
+ (operands :reader arithmetic-error-operands
+ :initarg :operands))
+ (:report (lambda (condition stream)
+ (format stream
+ "arithmetic error ~S signalled"
+ (type-of condition))
+ (when (arithmetic-error-operation condition)
+ (format stream
+ "~%Operation was ~S, operands ~S."
+ (arithmetic-error-operation condition)
+ (arithmetic-error-operands condition))))))
+
+(define-condition division-by-zero (arithmetic-error) ())
+(define-condition floating-point-overflow (arithmetic-error) ())
+(define-condition floating-point-underflow (arithmetic-error) ())
+(define-condition floating-point-inexact (arithmetic-error) ())
+(define-condition floating-point-invalid-operation (arithmetic-error) ())
+
+(define-condition print-not-readable (error)
+ ((object :reader print-not-readable-object :initarg :object))
+ (:report
+ (lambda (condition stream)
+ (let ((obj (print-not-readable-object condition))
+ (*print-array* nil))
+ (format stream "~S cannot be printed readably." obj)))))
+
+(define-condition reader-error (parse-error stream-error)
+ ((format-control
+ :reader reader-error-format-control
+ :initarg :format-control)
+ (format-arguments
+ :reader reader-error-format-arguments
+ :initarg :format-arguments
+ :initform '()))
+ (:report
+ (lambda (condition stream)
+ (let ((error-stream (stream-error-stream condition)))
+ (format stream "READER-ERROR ~@[at ~D ~]on ~S:~%~?"
+ (file-position error-stream) error-stream
+ (reader-error-format-control condition)
+ (reader-error-format-arguments condition))))))
+\f
+;;;; various other (not specified by ANSI) CONDITIONs
+;;;;
+;;;; These might logically belong in other files; they're here, after
+;;;; setup of CONDITION machinery, only because that makes it easier to
+;;;; get cold init to work.
+
+;;; KLUDGE: a condition for floating point errors when we can't or
+;;; won't figure out what type they are. (In FreeBSD and OpenBSD we
+;;; don't know how, at least as of sbcl-0.6.7; in Linux we probably
+;;; know how but the old code was broken by the conversion to POSIX
+;;; signal handling and hasn't been fixed as of sbcl-0.6.7.)
+;;;
+;;; FIXME: Perhaps this should also be a base class for all
+;;; floating point exceptions?
+(define-condition floating-point-exception (arithmetic-error)
+ ((flags :initarg :traps
+ :reader floating-point-exception-traps))
+ (:report (lambda (condition stream)
+ (format stream
+ "An arithmetic error ~S was signalled.~%"
+ (type-of condition))
+ (let ((traps (floating-point-exception-traps condition)))
+ (if traps
+ (format stream
+ "Trapping conditions are: ~%~{ ~S~^~}~%"
+ traps)
+ (write-line
+ "No traps are enabled? How can this be?"
+ stream))))))
+
+(define-condition index-too-large-error (type-error)
+ ()
+ (:report
+ (lambda (condition stream)
+ (format stream
+ "error in ~S: ~S: index too large"
+ (condition-function-name condition)
+ (type-error-datum condition)))))
+
+(define-condition io-timeout (stream-error)
+ ((direction :reader io-timeout-direction :initarg :direction))
+ (:report
+ (lambda (condition stream)
+ (declare (type stream stream))
+ (format stream
+ "IO-TIMEOUT ~(~A~)ing ~S"
+ (io-timeout-direction condition)
+ (stream-error-stream condition)))))
+
+(define-condition namestring-parse-error (parse-error)
+ ((complaint :reader namestring-parse-error-complaint :initarg :complaint)
+ (arguments :reader namestring-parse-error-arguments :initarg :arguments
+ :initform nil)
+ (namestring :reader namestring-parse-error-namestring :initarg :namestring)
+ (offset :reader namestring-parse-error-offset :initarg :offset))
+ (:report %print-namestring-parse-error))
+
+(define-condition simple-package-error (simple-condition package-error) ())
+
+(define-condition reader-package-error (reader-error) ())
+
+(define-condition reader-eof-error (end-of-file)
+ ((context :reader reader-eof-error-context :initarg :context))
+ (:report
+ (lambda (condition stream)
+ (format stream
+ "unexpected EOF on ~S ~A"
+ (stream-error-stream condition)
+ (reader-eof-error-context condition)))))
+\f
+;;;; restart definitions
+
+(define-condition abort-failure (control-error) ()
+ (:report
+ "An ABORT restart was found that failed to transfer control dynamically."))
+
+(defun abort (&optional condition)
+ #!+sb-doc
+ "Transfer control to a restart named ABORT, signalling a CONTROL-ERROR if
+ none exists."
+ (invoke-restart (find-restart 'abort condition))
+ ;; ABORT signals an error in case there was a restart named abort that did
+ ;; not transfer control dynamically. This could happen with RESTART-BIND.
+ (error 'abort-failure))
+
+(defun muffle-warning (&optional condition)
+ #!+sb-doc
+ "Transfer control to a restart named MUFFLE-WARNING, signalling a
+ CONTROL-ERROR if none exists."
+ (invoke-restart (find-restart 'muffle-warning condition)))
+
+(macrolet ((define-nil-returning-restart (name args doc)
+ #!-sb-doc (declare (ignore doc))
+ `(defun ,name (,@args &optional condition)
+ #!+sb-doc ,doc
+ ;; FIXME: Perhaps this shared logic should be pulled out into
+ ;; FLET MAYBE-INVOKE-RESTART? See whether it shrinks code..
+ (when (find-restart ',name condition)
+ (invoke-restart ',name ,@args)))))
+ (define-nil-returning-restart continue ()
+ "Transfer control to a restart named CONTINUE, or return NIL if none exists.")
+ (define-nil-returning-restart store-value (value)
+ "Transfer control and VALUE to a restart named STORE-VALUE, or return NIL if
+ none exists.")
+ (define-nil-returning-restart use-value (value)
+ "Transfer control and VALUE to a restart named USE-VALUE, or return NIL if
+ none exists."))
--- /dev/null
+;;;; This file contains the definition of non-CLASS types (e.g.
+;;;; subtypes of interesting BUILT-IN-CLASSes) and the interfaces to
+;;;; the type system. Common Lisp type specifiers are parsed into a
+;;;; somewhat canonical internal type representation that supports
+;;;; type union, intersection, etc. (Except that ALIEN types have
+;;;; moved out..)
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!KERNEL")
+
+(file-comment
+ "$Header$")
+
+(!begin-collecting-cold-init-forms)
+
+;;; ### Remaining incorrectnesses:
+;;;
+;;; TYPE-UNION (and the OR type) doesn't properly canonicalize an
+;;; exhaustive partition or coalesce contiguous ranges of numeric
+;;; types.
+;;;
+;;; There are all sorts of nasty problems with open bounds on FLOAT
+;;; types (and probably FLOAT types in general.)
+;;;
+;;; RATIO and BIGNUM are not recognized as numeric types.
+
+;;; FIXME: It seems to me that this should be set to NIL by default,
+;;; and perhaps not even optionally set to T.
+(defvar *use-implementation-types* t
+ #!+sb-doc
+ "*USE-IMPLEMENTATION-TYPES* is a semi-public flag which determines how
+ restrictive we are in determining type membership. If two types are the
+ same in the implementation, then we will consider them them the same when
+ this switch is on. When it is off, we try to be as restrictive as the
+ language allows, allowing us to detect more errors. Currently, this only
+ affects array types.")
+
+(!cold-init-forms (setq *use-implementation-types* t))
+
+;;; These functions are used as method for types which need a complex
+;;; subtypep method to handle some superclasses, but cover a subtree
+;;; of the type graph (i.e. there is no simple way for any other type
+;;; class to be a subtype.) There are always still complex ways,
+;;; namely UNION and MEMBER types, so we must give TYPE1's method a
+;;; chance to run, instead of immediately returning NIL, T.
+(defun delegate-complex-subtypep-arg2 (type1 type2)
+ (let ((subtypep-arg1
+ (type-class-complex-subtypep-arg1
+ (type-class-info type1))))
+ (if subtypep-arg1
+ (funcall subtypep-arg1 type1 type2)
+ (values nil t))))
+(defun delegate-complex-intersection (type1 type2)
+ (let ((method (type-class-complex-intersection (type-class-info type1))))
+ (if (and method (not (eq method #'delegate-complex-intersection)))
+ (funcall method type2 type1)
+ (vanilla-intersection type1 type2))))
+
+;;; This is used by DEFINE-SUPERCLASSES to define the SUBTYPE-ARG1
+;;; method. INFO is a list of conses (SUPERCLASS-CLASS .
+;;; {GUARD-TYPE-SPECIFIER | NIL}). This will never be called with a
+;;; hairy type as TYPE2, since the hairy type TYPE2 method gets first
+;;; crack.
+;;;
+;;; FIXME: Declare this as INLINE, since it's only used in one place.
+(defun has-superclasses-complex-subtypep-arg1 (type1 type2 info)
+ (values
+ (and (sb!xc:typep type2 'sb!xc:class)
+ (dolist (x info nil)
+ (when (or (not (cdr x))
+ (csubtypep type1 (specifier-type (cdr x))))
+ (return
+ (or (eq type2 (car x))
+ (let ((inherits (layout-inherits (class-layout (car x)))))
+ (dotimes (i (length inherits) nil)
+ (when (eq type2 (layout-class (svref inherits i)))
+ (return t)))))))))
+ t))
+
+;;; This function takes a list of specs, each of the form
+;;; (SUPERCLASS-NAME &OPTIONAL GUARD).
+;;; Consider one spec (with no guard): any instance of the named
+;;; TYPE-CLASS is also a subtype of the named superclass and of any of
+;;; its superclasses. If there are multiple specs, then some will have
+;;; guards. We choose the first spec whose guard is a supertype of
+;;; TYPE1 and use its superclass. In effect, a sequence of guards
+;;; G0, G1, G2
+;;; is actually
+;;; G0,(and G1 (not G0)), (and G2 (not (or G0 G1))).
+;;;
+;;; WHEN controls when the forms are executed.
+(defmacro define-superclasses (type-class-name specs when)
+ (let ((type-class (gensym "TYPE-CLASS-"))
+ (info (gensym "INFO")))
+ `(,when
+ (let ((,type-class (type-class-or-lose ',type-class-name))
+ (,info (mapcar (lambda (spec)
+ (destructuring-bind
+ (super &optional guard)
+ spec
+ (cons (sb!xc:find-class super) guard)))
+ ',specs)))
+ (setf (type-class-complex-subtypep-arg1 ,type-class)
+ (lambda (type1 type2)
+ (has-superclasses-complex-subtypep-arg1 type1 type2 ,info)))
+ (setf (type-class-complex-subtypep-arg2 ,type-class)
+ #'delegate-complex-subtypep-arg2)
+ (setf (type-class-complex-intersection ,type-class)
+ #'delegate-complex-intersection)))))
+\f
+;;;; FUNCTION and VALUES types
+;;;;
+;;;; Pretty much all of the general type operations are illegal on
+;;;; VALUES types, since we can't discriminate using them, do
+;;;; SUBTYPEP, etc. FUNCTION types are acceptable to the normal type
+;;;; operations, but are generally considered to be equivalent to
+;;;; FUNCTION. These really aren't true types in any type theoretic
+;;;; sense, but we still parse them into CTYPE structures for two
+;;;; reasons:
+
+;;;; -- Parsing and unparsing work the same way, and indeed we can't
+;;;; tell whether a type is a function or values type without
+;;;; parsing it.
+;;;; -- Many of the places that can be annotated with real types can
+;;;; also be annotated with function or values types.
+
+;;; the description of a keyword argument
+(defstruct (key-info #-sb-xc-host (:pure t))
+ ;; the keyword
+ (name (required-argument) :type keyword)
+ ;; the type of the argument value
+ (type (required-argument) :type ctype))
+
+(define-type-method (values :simple-subtypep :complex-subtypep-arg1)
+ (type1 type2)
+ (declare (ignore type2))
+ (error "Subtypep is illegal on this type:~% ~S" (type-specifier type1)))
+
+(define-type-method (values :complex-subtypep-arg2)
+ (type1 type2)
+ (declare (ignore type1))
+ (error "Subtypep is illegal on this type:~% ~S" (type-specifier type2)))
+
+(define-type-method (values :unparse) (type)
+ (cons 'values (unparse-args-types type)))
+
+;;; Return true if LIST1 and LIST2 have the same elements in the same
+;;; positions according to TYPE=. We return NIL, NIL if there is an
+;;; uncertain comparison.
+(defun type=-list (list1 list2)
+ (declare (list list1 list2))
+ (do ((types1 list1 (cdr types1))
+ (types2 list2 (cdr types2)))
+ ((or (null types1) (null types2))
+ (if (or types1 types2)
+ (values nil t)
+ (values t t)))
+ (multiple-value-bind (val win)
+ (type= (first types1) (first types2))
+ (unless win
+ (return (values nil nil)))
+ (unless val
+ (return (values nil t))))))
+
+(define-type-method (values :simple-=) (type1 type2)
+ (let ((rest1 (args-type-rest type1))
+ (rest2 (args-type-rest type2)))
+ (cond ((or (args-type-keyp type1) (args-type-keyp type2)
+ (args-type-allowp type1) (args-type-allowp type2))
+ (values nil nil))
+ ((and rest1 rest2 (type/= rest1 rest2))
+ (type= rest1 rest2))
+ ((or rest1 rest2)
+ (values nil t))
+ (t
+ (multiple-value-bind (req-val req-win)
+ (type=-list (values-type-required type1)
+ (values-type-required type2))
+ (multiple-value-bind (opt-val opt-win)
+ (type=-list (values-type-optional type1)
+ (values-type-optional type2))
+ (values (and req-val opt-val) (and req-win opt-win))))))))
+
+(define-type-class function)
+
+;;; a flag that we can bind to cause complex function types to be
+;;; unparsed as FUNCTION. This is useful when we want a type that we
+;;; can pass to TYPEP.
+(defvar *unparse-function-type-simplify*)
+(!cold-init-forms (setq *unparse-function-type-simplify* nil))
+
+(define-type-method (function :unparse) (type)
+ (if *unparse-function-type-simplify*
+ 'function
+ (list 'function
+ (if (function-type-wild-args type)
+ '*
+ (unparse-args-types type))
+ (type-specifier
+ (function-type-returns type)))))
+
+;;; Since all function types are equivalent to FUNCTION, they are all
+;;; subtypes of each other.
+(define-type-method (function :simple-subtypep) (type1 type2)
+ (declare (ignore type1 type2))
+ (values t t))
+
+(define-superclasses function ((function)) !cold-init-forms)
+
+;;; The union or intersection of two FUNCTION types is FUNCTION.
+(define-type-method (function :simple-union) (type1 type2)
+ (declare (ignore type1 type2))
+ (specifier-type 'function))
+(define-type-method (function :simple-intersection) (type1 type2)
+ (declare (ignore type1 type2))
+ (values (specifier-type 'function) t))
+
+;;; ### Not very real, but good enough for redefining transforms
+;;; according to type:
+(define-type-method (function :simple-=) (type1 type2)
+ (values (equalp type1 type2) t))
+
+(define-type-class constant :inherits values)
+
+(define-type-method (constant :unparse) (type)
+ `(constant-argument ,(type-specifier (constant-type-type type))))
+
+(define-type-method (constant :simple-=) (type1 type2)
+ (type= (constant-type-type type1) (constant-type-type type2)))
+
+(def-type-translator constant-argument (type)
+ (make-constant-type :type (specifier-type type)))
+
+;;; Given a LAMBDA-LIST-like values type specification and an ARGS-TYPE
+;;; structure, fill in the slots in the structure accordingly. This is
+;;; used for both FUNCTION and VALUES types.
+(declaim (ftype (function (list args-type) (values)) parse-args-types))
+(defun parse-args-types (lambda-list result)
+ (multiple-value-bind (required optional restp rest keyp keys allowp aux)
+ (parse-lambda-list lambda-list)
+ (when aux
+ (error "&Aux in a FUNCTION or VALUES type: ~S." lambda-list))
+ (setf (args-type-required result) (mapcar #'specifier-type required))
+ (setf (args-type-optional result) (mapcar #'specifier-type optional))
+ (setf (args-type-rest result) (if restp (specifier-type rest) nil))
+ (setf (args-type-keyp result) keyp)
+ (collect ((key-info))
+ (dolist (key keys)
+ (unless (proper-list-of-length-p key 2)
+ (error "Keyword type description is not a two-list: ~S." key))
+ (let ((kwd (first key)))
+ (when (find kwd (key-info) :key #'key-info-name)
+ (error "Repeated keyword ~S in lambda list: ~S." kwd lambda-list))
+ (key-info (make-key-info :name kwd
+ :type (specifier-type (second key))))))
+ (setf (args-type-keywords result) (key-info)))
+ (setf (args-type-allowp result) allowp)
+ (values)))
+
+;;; Return the lambda-list-like type specification corresponding
+;;; to an ARGS-TYPE.
+(declaim (ftype (function (args-type) list) unparse-args-types))
+(defun unparse-args-types (type)
+ (collect ((result))
+
+ (dolist (arg (args-type-required type))
+ (result (type-specifier arg)))
+
+ (when (args-type-optional type)
+ (result '&optional)
+ (dolist (arg (args-type-optional type))
+ (result (type-specifier arg))))
+
+ (when (args-type-rest type)
+ (result '&rest)
+ (result (type-specifier (args-type-rest type))))
+
+ (when (args-type-keyp type)
+ (result '&key)
+ (dolist (key (args-type-keywords type))
+ (result (list (key-info-name key)
+ (type-specifier (key-info-type key))))))
+
+ (when (args-type-allowp type)
+ (result '&allow-other-keys))
+
+ (result)))
+
+(def-type-translator function (&optional (args '*) (result '*))
+ (let ((res (make-function-type
+ :returns (values-specifier-type result))))
+ (if (eq args '*)
+ (setf (function-type-wild-args res) t)
+ (parse-args-types args res))
+ res))
+
+(def-type-translator values (&rest values)
+ (let ((res (make-values-type)))
+ (parse-args-types values res)
+ res))
+\f
+;;;; VALUES types interfaces
+;;;;
+;;;; We provide a few special operations that can be meaningfully used
+;;;; on VALUES types (as well as on any other type).
+
+;;; Return the type of the first value indicated by Type. This is used
+;;; by people who don't want to have to deal with values types.
+#!-sb-fluid (declaim (freeze-type values-type) (inline single-value-type))
+(defun single-value-type (type)
+ (declare (type ctype type))
+ (cond ((values-type-p type)
+ (or (car (args-type-required type))
+ (car (args-type-optional type))
+ (args-type-rest type)
+ *universal-type*))
+ ((eq type *wild-type*)
+ *universal-type*)
+ (t
+ type)))
+
+;;; Return the minmum number of arguments that a function can be
+;;; called with, and the maximum number or NIL. If not a function
+;;; type, return NIL, NIL.
+(defun function-type-nargs (type)
+ (declare (type ctype type))
+ (if (function-type-p type)
+ (let ((fixed (length (args-type-required type))))
+ (if (or (args-type-rest type)
+ (args-type-keyp type)
+ (args-type-allowp type))
+ (values fixed nil)
+ (values fixed (+ fixed (length (args-type-optional type))))))
+ (values nil nil)))
+
+;;; Determine if Type corresponds to a definite number of values. The
+;;; first value is a list of the types for each value, and the second
+;;; value is the number of values. If the number of values is not
+;;; fixed, then return NIL and :Unknown.
+(defun values-types (type)
+ (declare (type ctype type))
+ (cond ((eq type *wild-type*)
+ (values nil :unknown))
+ ((not (values-type-p type))
+ (values (list type) 1))
+ ((or (args-type-optional type)
+ (args-type-rest type)
+ (args-type-keyp type)
+ (args-type-allowp type))
+ (values nil :unknown))
+ (t
+ (let ((req (args-type-required type)))
+ (values (mapcar #'single-value-type req) (length req))))))
+
+;;; Return two values:
+;;; 1. A list of all the positional (fixed and optional) types.
+;;; 2. The &REST type (if any). If keywords allowed, *UNIVERSAL-TYPE*.
+;;; If no keywords or rest, *EMPTY-TYPE*.
+(defun values-type-types (type)
+ (declare (type values-type type))
+ (values (append (args-type-required type)
+ (args-type-optional type))
+ (cond ((args-type-keyp type) *universal-type*)
+ ((args-type-rest type))
+ (t
+ *empty-type*))))
+
+;;; Return a list of OPERATION applied to the types in TYPES1 and
+;;; TYPES2, padding with REST2 as needed. TYPES1 must not be shorter
+;;; than TYPES2. The second value is T if OPERATION always returned a
+;;; true second value.
+(defun fixed-values-op (types1 types2 rest2 operation)
+ (declare (list types1 types2) (type ctype rest2) (type function operation))
+ (let ((exact t))
+ (values (mapcar #'(lambda (t1 t2)
+ (multiple-value-bind (res win)
+ (funcall operation t1 t2)
+ (unless win
+ (setq exact nil))
+ res))
+ types1
+ (append types2
+ (make-list (- (length types1) (length types2))
+ :initial-element rest2)))
+ exact)))
+
+;;; If Type isn't a values type, then make it into one:
+;;; <type> ==> (values type &rest t)
+(defun coerce-to-values (type)
+ (declare (type ctype type))
+ (if (values-type-p type)
+ type
+ (make-values-type :required (list type) :rest *universal-type*)))
+
+;;; Do the specified OPERATION on TYPE1 and TYPE2, which may be any
+;;; type, including VALUES types. With VALUES types such as:
+;;; (VALUES a0 a1)
+;;; (VALUES b0 b1)
+;;; we compute the more useful result
+;;; (VALUES (<operation> a0 b0) (<operation> a1 b1))
+;;; rather than the precise result
+;;; (<operation> (values a0 a1) (values b0 b1))
+;;; This has the virtue of always keeping the VALUES type specifier
+;;; outermost, and retains all of the information that is really
+;;; useful for static type analysis. We want to know what is always
+;;; true of each value independently. It is worthless to know that IF
+;;; the first value is B0 then the second will be B1.
+;;;
+;;; If the VALUES count signatures differ, then we produce a result with
+;;; the required VALUE count chosen by NREQ when applied to the number
+;;; of required values in TYPE1 and TYPE2. Any &KEY values become
+;;; &REST T (anyone who uses keyword values deserves to lose.)
+;;;
+;;; The second value is true if the result is definitely empty or if
+;;; OPERATION returned true as its second value each time we called
+;;; it. Since we approximate the intersection of VALUES types, the
+;;; second value being true doesn't mean the result is exact.
+(defun args-type-op (type1 type2 operation nreq)
+ (declare (type ctype type1 type2) (type function operation nreq))
+ (if (or (values-type-p type1) (values-type-p type2))
+ (let ((type1 (coerce-to-values type1))
+ (type2 (coerce-to-values type2)))
+ (multiple-value-bind (types1 rest1) (values-type-types type1)
+ (multiple-value-bind (types2 rest2) (values-type-types type2)
+ (multiple-value-bind (rest rest-exact)
+ (funcall operation rest1 rest2)
+ (multiple-value-bind (res res-exact)
+ (if (< (length types1) (length types2))
+ (fixed-values-op types2 types1 rest1 operation)
+ (fixed-values-op types1 types2 rest2 operation))
+ (let* ((req (funcall nreq
+ (length (args-type-required type1))
+ (length (args-type-required type2))))
+ (required (subseq res 0 req))
+ (opt (subseq res req))
+ (opt-last (position rest opt :test-not #'type=
+ :from-end t)))
+ (if (find *empty-type* required :test #'type=)
+ (values *empty-type* t)
+ (values (make-values-type
+ :required required
+ :optional (if opt-last
+ (subseq opt 0 (1+ opt-last))
+ ())
+ :rest (if (eq rest *empty-type*) nil rest))
+ (and rest-exact res-exact)))))))))
+ (funcall operation type1 type2)))
+
+;;; Do a union or intersection operation on types that might be values
+;;; types. The result is optimized for utility rather than exactness,
+;;; but it is guaranteed that it will be no smaller (more restrictive)
+;;; than the precise result.
+;;;
+;;; The return convention seems to be analogous to
+;;; TYPES-INTERSECT. -- WHN 19990910.
+(defun-cached (values-type-union :hash-function type-cache-hash
+ :hash-bits 8
+ :default nil
+ :init-wrapper !cold-init-forms)
+ ((type1 eq) (type2 eq))
+ (declare (type ctype type1 type2))
+ (cond ((or (eq type1 *wild-type*) (eq type2 *wild-type*)) *wild-type*)
+ ((eq type1 *empty-type*) type2)
+ ((eq type2 *empty-type*) type1)
+ (t
+ (values (args-type-op type1 type2 #'type-union #'min)))))
+(defun-cached (values-type-intersection :hash-function type-cache-hash
+ :hash-bits 8
+ :values 2
+ :default (values nil :empty)
+ :init-wrapper !cold-init-forms)
+ ((type1 eq) (type2 eq))
+ (declare (type ctype type1 type2))
+ (cond ((eq type1 *wild-type*) (values type2 t))
+ ((eq type2 *wild-type*) (values type1 t))
+ (t
+ (args-type-op type1 type2 #'type-intersection #'max))))
+
+;;; This is like TYPES-INTERSECT, except that it sort of works on
+;;; VALUES types. Note that due to the semantics of
+;;; VALUES-TYPE-INTERSECTION, this might return (VALUES T T) when
+;;; there isn't really any intersection (?).
+;;;
+;;; The return convention seems to be analogous to
+;;; TYPES-INTERSECT. -- WHN 19990910.
+(defun values-types-intersect (type1 type2)
+ (cond ((or (eq type1 *empty-type*) (eq type2 *empty-type*))
+ (values 't t))
+ ((or (values-type-p type1) (values-type-p type2))
+ (multiple-value-bind (res win) (values-type-intersection type1 type2)
+ (values (not (eq res *empty-type*))
+ win)))
+ (t
+ (types-intersect type1 type2))))
+
+;;; a SUBTYPEP-like operation that can be used on any types, including
+;;; VALUES types
+(defun-cached (values-subtypep :hash-function type-cache-hash
+ :hash-bits 8
+ :values 2
+ :default (values nil :empty)
+ :init-wrapper !cold-init-forms)
+ ((type1 eq) (type2 eq))
+ (declare (type ctype type1 type2))
+ (cond ((eq type2 *wild-type*) (values t t))
+ ((eq type1 *wild-type*)
+ (values (eq type2 *universal-type*) t))
+ ((not (values-types-intersect type1 type2))
+ (values nil t))
+ (t
+ (if (or (values-type-p type1) (values-type-p type2))
+ (let ((type1 (coerce-to-values type1))
+ (type2 (coerce-to-values type2)))
+ (multiple-value-bind (types1 rest1) (values-type-types type1)
+ (multiple-value-bind (types2 rest2) (values-type-types type2)
+ (cond ((< (length (values-type-required type1))
+ (length (values-type-required type2)))
+ (values nil t))
+ ((< (length types1) (length types2))
+ (values nil nil))
+ ((or (values-type-keyp type1)
+ (values-type-keyp type2))
+ (values nil nil))
+ (t
+ (do ((t1 types1 (rest t1))
+ (t2 types2 (rest t2)))
+ ((null t2)
+ (csubtypep rest1 rest2))
+ (multiple-value-bind (res win-p)
+ (csubtypep (first t1) (first t2))
+ (unless win-p
+ (return (values nil nil)))
+ (unless res
+ (return (values nil t))))))))))
+ (csubtypep type1 type2)))))
+\f
+;;;; type method interfaces
+
+;;; like SUBTYPEP, only works on CTYPE structures
+(defun-cached (csubtypep :hash-function type-cache-hash
+ :hash-bits 8
+ :values 2
+ :default (values nil :empty)
+ :init-wrapper !cold-init-forms)
+ ((type1 eq) (type2 eq))
+ (declare (type ctype type1 type2))
+ (cond ((or (eq type1 type2)
+ (eq type1 *empty-type*)
+ (eq type2 *wild-type*))
+ (values t t))
+ ((or (eq type1 *wild-type*)
+ (eq type2 *empty-type*))
+ (values nil t))
+ (t
+ (invoke-type-method :simple-subtypep :complex-subtypep-arg2
+ type1 type2
+ :complex-arg1 :complex-subtypep-arg1))))
+
+;;; Just parse the type specifiers and call CSUBTYPE.
+(defun sb!xc:subtypep (type1 type2)
+ #!+sb-doc
+ "Return two values indicating the relationship between type1 and type2.
+ If values are T and T, type1 definitely is a subtype of type2.
+ If values are NIL and T, type1 definitely is not a subtype of type2.
+ If values are NIL and NIL, it couldn't be determined."
+ (csubtypep (specifier-type type1) (specifier-type type2)))
+
+;;; If two types are definitely equivalent, return true. The second
+;;; value indicates whether the first value is definitely correct.
+;;; This should only fail in the presence of HAIRY types.
+(defun-cached (type= :hash-function type-cache-hash
+ :hash-bits 8
+ :values 2
+ :default (values nil :empty)
+ :init-wrapper !cold-init-forms)
+ ((type1 eq) (type2 eq))
+ (declare (type ctype type1 type2))
+ (if (eq type1 type2)
+ (values t t)
+ (invoke-type-method :simple-= :complex-= type1 type2)))
+
+;;; Not exactly the negation of TYPE=, since when the relationship is
+;;; uncertain, we still return NIL, NIL. This is useful in cases where
+;;; the conservative assumption is =.
+(defun type/= (type1 type2)
+ (declare (type ctype type1 type2))
+ (multiple-value-bind (res win) (type= type1 type2)
+ (if win
+ (values (not res) t)
+ (values nil nil))))
+
+;;; Find a type which includes both types. Any inexactness is
+;;; represented by the fuzzy element types; we return a single value
+;;; that is precise to the best of our knowledge. This result is
+;;; simplified into the canonical form, thus is not a UNION type
+;;; unless there is no other way to represent the result.
+(defun-cached (type-union :hash-function type-cache-hash
+ :hash-bits 8
+ :init-wrapper !cold-init-forms)
+ ((type1 eq) (type2 eq))
+ (declare (type ctype type1 type2))
+ (if (eq type1 type2)
+ type1
+ (let ((res (invoke-type-method :simple-union :complex-union
+ type1 type2
+ :default :vanilla)))
+ (cond ((eq res :vanilla)
+ (or (vanilla-union type1 type2)
+ (make-union-type (list type1 type2))))
+ (res)
+ (t
+ (make-union-type (list type1 type2)))))))
+
+;;; Return as restrictive a type as we can discover that is no more
+;;; restrictive than the intersection of Type1 and Type2. The second
+;;; value is true if the result is exact. At worst, we randomly return
+;;; one of the arguments as the first value (trying not to return a
+;;; hairy type).
+(defun-cached (type-intersection :hash-function type-cache-hash
+ :hash-bits 8
+ :values 2
+ :default (values nil :empty)
+ :init-wrapper !cold-init-forms)
+ ((type1 eq) (type2 eq))
+ (declare (type ctype type1 type2))
+ (if (eq type1 type2)
+ (values type1 t)
+ (invoke-type-method :simple-intersection :complex-intersection
+ type1 type2
+ :default (values *empty-type* t))))
+
+;;; The first value is true unless the types don't intersect. The
+;;; second value is true if the first value is definitely correct. NIL
+;;; is considered to intersect with any type. If T is a subtype of
+;;; either type, then we also return T, T. This way we consider hairy
+;;; types to intersect with T.
+(defun types-intersect (type1 type2)
+ (declare (type ctype type1 type2))
+ (if (or (eq type1 *empty-type*) (eq type2 *empty-type*))
+ (values t t)
+ (multiple-value-bind (val winp) (type-intersection type1 type2)
+ (cond ((not winp)
+ (if (or (csubtypep *universal-type* type1)
+ (csubtypep *universal-type* type2))
+ (values t t)
+ (values t nil)))
+ ((eq val *empty-type*) (values nil t))
+ (t (values t t))))))
+
+;;; Return a Common Lisp type specifier corresponding to the TYPE
+;;; object.
+(defun type-specifier (type)
+ (declare (type ctype type))
+ (funcall (type-class-unparse (type-class-info type)) type))
+
+;;; (VALUES-SPECIFIER-TYPE and SPECIFIER-TYPE moved from here to
+;;; early-type.lisp by WHN ca. 19990201.)
+
+;;; Take a list of type specifiers, compute the translation and define
+;;; it as a builtin type.
+(declaim (ftype (function (list) (values)) precompute-types))
+(defun precompute-types (specs)
+ (dolist (spec specs)
+ (let ((res (specifier-type spec)))
+ (unless (unknown-type-p res)
+ (setf (info :type :builtin spec) res)
+ (setf (info :type :kind spec) :primitive))))
+ (values))
+\f
+;;;; built-in types
+
+(define-type-class named)
+
+(defvar *wild-type*)
+(defvar *empty-type*)
+(defvar *universal-type*)
+
+(!cold-init-forms
+ (macrolet ((frob (name var)
+ `(progn
+ (setq ,var (make-named-type :name ',name))
+ (setf (info :type :kind ',name) :primitive)
+ (setf (info :type :builtin ',name) ,var))))
+ ;; KLUDGE: In ANSI, * isn't really the name of a type, it's just a
+ ;; special symbol which can be stuck in some places where an
+ ;; ordinary type can go, e.g. (ARRAY * 1) instead of (ARRAY T 1).
+ ;; At some point, in order to become more standard, we should
+ ;; convert all the classic CMU CL legacy *s and *WILD-TYPE*s into
+ ;; Ts and *UNIVERSAL-TYPE*s.
+ (frob * *wild-type*)
+ (frob nil *empty-type*)
+ (frob t *universal-type*)))
+
+(define-type-method (named :simple-=) (type1 type2)
+ (values (eq type1 type2) t))
+
+(define-type-method (named :simple-subtypep) (type1 type2)
+ (values (or (eq type1 *empty-type*) (eq type2 *wild-type*)) t))
+
+(define-type-method (named :complex-subtypep-arg1) (type1 type2)
+ (assert (not (hairy-type-p type2)))
+ (values (eq type1 *empty-type*) t))
+
+(define-type-method (named :complex-subtypep-arg2) (type1 type2)
+ (if (hairy-type-p type1)
+ (values nil nil)
+ (values (not (eq type2 *empty-type*)) t)))
+
+(define-type-method (named :complex-intersection) (type1 type2)
+ (vanilla-intersection type1 type2))
+
+(define-type-method (named :unparse) (x)
+ (named-type-name x))
+\f
+;;;; hairy and unknown types
+
+(define-type-method (hairy :unparse) (x) (hairy-type-specifier x))
+
+(define-type-method (hairy :simple-subtypep) (type1 type2)
+ (let ((hairy-spec1 (hairy-type-specifier type1))
+ (hairy-spec2 (hairy-type-specifier type2)))
+ (cond ((and (consp hairy-spec1) (eq (car hairy-spec1) 'not)
+ (consp hairy-spec2) (eq (car hairy-spec2) 'not))
+ (csubtypep (specifier-type (cadr hairy-spec2))
+ (specifier-type (cadr hairy-spec1))))
+ ((equal hairy-spec1 hairy-spec2)
+ (values t t))
+ (t
+ (values nil nil)))))
+
+(define-type-method (hairy :complex-subtypep-arg2) (type1 type2)
+ (let ((hairy-spec (hairy-type-specifier type2)))
+ (cond ((and (consp hairy-spec) (eq (car hairy-spec) 'not))
+ (multiple-value-bind (val win)
+ (type-intersection type1 (specifier-type (cadr hairy-spec)))
+ (if win
+ (values (eq val *empty-type*) t)
+ (values nil nil))))
+ (t
+ (values nil nil)))))
+
+(define-type-method (hairy :complex-subtypep-arg1 :complex-=) (type1 type2)
+ (declare (ignore type1 type2))
+ (values nil nil))
+
+(define-type-method (hairy :simple-intersection :complex-intersection)
+ (type1 type2)
+ (declare (ignore type2))
+ (values type1 nil))
+
+(define-type-method (hairy :complex-union) (type1 type2)
+ (make-union-type (list type1 type2)))
+
+(define-type-method (hairy :simple-=) (type1 type2)
+ (if (equal (hairy-type-specifier type1)
+ (hairy-type-specifier type2))
+ (values t t)
+ (values nil nil)))
+
+(def-type-translator not (&whole whole type)
+ (declare (ignore type))
+ (make-hairy-type :specifier whole))
+
+(def-type-translator satisfies (&whole whole fun)
+ (declare (ignore fun))
+ (make-hairy-type :specifier whole))
+\f
+;;;; numeric types
+
+;;; A list of all the float formats, in order of decreasing precision.
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defconstant float-formats
+ '(long-float double-float single-float short-float)))
+
+;;; The type of a float format.
+(deftype float-format () `(member ,@float-formats))
+
+#!+negative-zero-is-not-zero
+(defun make-numeric-type (&key class format (complexp :real) low high
+ enumerable)
+ (flet ((canonicalise-low-bound (x)
+ ;; Canonicalise a low bound of (-0.0) to 0.0.
+ (if (and (consp x) (floatp (car x)) (zerop (car x))
+ (minusp (float-sign (car x))))
+ (float 0.0 (car x))
+ x))
+ (canonicalise-high-bound (x)
+ ;; Canonicalise a high bound of (+0.0) to -0.0.
+ (if (and (consp x) (floatp (car x)) (zerop (car x))
+ (plusp (float-sign (car x))))
+ (float -0.0 (car x))
+ x)))
+ (%make-numeric-type :class class
+ :format format
+ :complexp complexp
+ :low (canonicalise-low-bound low)
+ :high (canonicalise-high-bound high)
+ :enumerable enumerable)))
+
+(define-type-class number)
+
+(define-type-method (number :simple-=) (type1 type2)
+ (values
+ (and (eq (numeric-type-class type1) (numeric-type-class type2))
+ (eq (numeric-type-format type1) (numeric-type-format type2))
+ (eq (numeric-type-complexp type1) (numeric-type-complexp type2))
+ (equal (numeric-type-low type1) (numeric-type-low type2))
+ (equal (numeric-type-high type1) (numeric-type-high type2)))
+ t))
+
+(define-type-method (number :unparse) (type)
+ (let* ((complexp (numeric-type-complexp type))
+ (low (numeric-type-low type))
+ (high (numeric-type-high type))
+ (base (case (numeric-type-class type)
+ (integer 'integer)
+ (rational 'rational)
+ (float (or (numeric-type-format type) 'float))
+ (t 'real))))
+ (let ((base+bounds
+ (cond ((and (eq base 'integer) high low)
+ (let ((high-count (logcount high))
+ (high-length (integer-length high)))
+ (cond ((= low 0)
+ (cond ((= high 0) '(integer 0 0))
+ ((= high 1) 'bit)
+ ((and (= high-count high-length)
+ (plusp high-length))
+ `(unsigned-byte ,high-length))
+ (t
+ `(mod ,(1+ high)))))
+ ((and (= low sb!vm:*target-most-negative-fixnum*)
+ (= high sb!vm:*target-most-positive-fixnum*))
+ 'fixnum)
+ ((and (= low (lognot high))
+ (= high-count high-length)
+ (> high-count 0))
+ `(signed-byte ,(1+ high-length)))
+ (t
+ `(integer ,low ,high)))))
+ (high `(,base ,(or low '*) ,high))
+ (low
+ (if (and (eq base 'integer) (= low 0))
+ 'unsigned-byte
+ `(,base ,low)))
+ (t base))))
+ (ecase complexp
+ (:real
+ base+bounds)
+ (:complex
+ (if (eq base+bounds 'real)
+ 'complex
+ `(complex ,base+bounds)))
+ ((nil)
+ (assert (eq base+bounds 'real))
+ 'number)))))
+
+;;; Return true if X is "less than or equal" to Y, taking open bounds
+;;; into consideration. CLOSED is the predicate used to test the bound
+;;; on a closed interval (e.g. <=), and OPEN is the predicate used on
+;;; open bounds (e.g. <). Y is considered to be the outside bound, in
+;;; the sense that if it is infinite (NIL), then the test succeeds,
+;;; whereas if X is infinite, then the test fails (unless Y is also
+;;; infinite).
+;;;
+;;; This is for comparing bounds of the same kind, e.g. upper and
+;;; upper. Use NUMERIC-BOUND-TEST* for different kinds of bounds.
+#!-negative-zero-is-not-zero
+(defmacro numeric-bound-test (x y closed open)
+ `(cond ((not ,y) t)
+ ((not ,x) nil)
+ ((consp ,x)
+ (if (consp ,y)
+ (,closed (car ,x) (car ,y))
+ (,closed (car ,x) ,y)))
+ (t
+ (if (consp ,y)
+ (,open ,x (car ,y))
+ (,closed ,x ,y)))))
+
+#!+negative-zero-is-not-zero
+(defmacro numeric-bound-test-zero (op x y)
+ `(if (and (zerop ,x) (zerop ,y) (floatp ,x) (floatp ,y))
+ (,op (float-sign ,x) (float-sign ,y))
+ (,op ,x ,y)))
+
+#!+negative-zero-is-not-zero
+(defmacro numeric-bound-test (x y closed open)
+ `(cond ((not ,y) t)
+ ((not ,x) nil)
+ ((consp ,x)
+ (if (consp ,y)
+ (numeric-bound-test-zero ,closed (car ,x) (car ,y))
+ (numeric-bound-test-zero ,closed (car ,x) ,y)))
+ (t
+ (if (consp ,y)
+ (numeric-bound-test-zero ,open ,x (car ,y))
+ (numeric-bound-test-zero ,closed ,x ,y)))))
+
+;;; This is used to compare upper and lower bounds. This is different
+;;; from the same-bound case:
+;;; -- Since X = NIL is -infinity, whereas y = NIL is +infinity, we
+;;; return true if *either* arg is NIL.
+;;; -- an open inner bound is "greater" and also squeezes the interval,
+;;; causing us to use the OPEN test for those cases as well.
+#!-negative-zero-is-not-zero
+(defmacro numeric-bound-test* (x y closed open)
+ `(cond ((not ,y) t)
+ ((not ,x) t)
+ ((consp ,x)
+ (if (consp ,y)
+ (,open (car ,x) (car ,y))
+ (,open (car ,x) ,y)))
+ (t
+ (if (consp ,y)
+ (,open ,x (car ,y))
+ (,closed ,x ,y)))))
+
+#!+negative-zero-is-not-zero
+(defmacro numeric-bound-test* (x y closed open)
+ `(cond ((not ,y) t)
+ ((not ,x) t)
+ ((consp ,x)
+ (if (consp ,y)
+ (numeric-bound-test-zero ,open (car ,x) (car ,y))
+ (numeric-bound-test-zero ,open (car ,x) ,y)))
+ (t
+ (if (consp ,y)
+ (numeric-bound-test-zero ,open ,x (car ,y))
+ (numeric-bound-test-zero ,closed ,x ,y)))))
+
+;;; Return whichever of the numeric bounds X and Y is "maximal"
+;;; according to the predicates CLOSED (e.g. >=) and OPEN (e.g. >).
+;;; This is only meaningful for maximizing like bounds, i.e. upper and
+;;; upper. If MAX-P is true, then we return NIL if X or Y is NIL,
+;;; otherwise we return the other arg.
+(defmacro numeric-bound-max (x y closed open max-p)
+ (once-only ((n-x x)
+ (n-y y))
+ `(cond ((not ,n-x) ,(if max-p nil n-y))
+ ((not ,n-y) ,(if max-p nil n-x))
+ ((consp ,n-x)
+ (if (consp ,n-y)
+ (if (,closed (car ,n-x) (car ,n-y)) ,n-x ,n-y)
+ (if (,open (car ,n-x) ,n-y) ,n-x ,n-y)))
+ (t
+ (if (consp ,n-y)
+ (if (,open (car ,n-y) ,n-x) ,n-y ,n-x)
+ (if (,closed ,n-y ,n-x) ,n-y ,n-x))))))
+
+(define-type-method (number :simple-subtypep) (type1 type2)
+ (let ((class1 (numeric-type-class type1))
+ (class2 (numeric-type-class type2))
+ (complexp2 (numeric-type-complexp type2))
+ (format2 (numeric-type-format type2))
+ (low1 (numeric-type-low type1))
+ (high1 (numeric-type-high type1))
+ (low2 (numeric-type-low type2))
+ (high2 (numeric-type-high type2)))
+ ;; If one is complex and the other isn't, they are disjoint.
+ (cond ((not (or (eq (numeric-type-complexp type1) complexp2)
+ (null complexp2)))
+ (values nil t))
+ ;; If the classes are specified and different, the types are
+ ;; disjoint unless type2 is rational and type1 is integer.
+ ((not (or (eq class1 class2)
+ (null class2)
+ (and (eq class1 'integer)
+ (eq class2 'rational))))
+ (values nil t))
+ ;; If the float formats are specified and different, the types
+ ;; are disjoint.
+ ((not (or (eq (numeric-type-format type1) format2)
+ (null format2)))
+ (values nil t))
+ ;; Check the bounds.
+ ((and (numeric-bound-test low1 low2 >= >)
+ (numeric-bound-test high1 high2 <= <))
+ (values t t))
+ (t
+ (values nil t)))))
+
+(define-superclasses number ((generic-number)) !cold-init-forms)
+
+;;; If the high bound of LOW is adjacent to the low bound of HIGH,
+;;; then return true, otherwise NIL.
+(defun numeric-types-adjacent (low high)
+ (let ((low-bound (numeric-type-high low))
+ (high-bound (numeric-type-low high)))
+ (cond ((not (and low-bound high-bound)) nil)
+ ((and (consp low-bound) (consp high-bound)) nil)
+ ((consp low-bound)
+ #!-negative-zero-is-not-zero
+ (let ((low-value (car low-bound)))
+ (or (eql low-value high-bound)
+ (and (eql low-value -0f0) (eql high-bound 0f0))
+ (and (eql low-value 0f0) (eql high-bound -0f0))
+ (and (eql low-value -0d0) (eql high-bound 0d0))
+ (and (eql low-value 0d0) (eql high-bound -0d0))))
+ #!+negative-zero-is-not-zero
+ (eql (car low-bound) high-bound))
+ ((consp high-bound)
+ #!-negative-zero-is-not-zero
+ (let ((high-value (car high-bound)))
+ (or (eql high-value low-bound)
+ (and (eql high-value -0f0) (eql low-bound 0f0))
+ (and (eql high-value 0f0) (eql low-bound -0f0))
+ (and (eql high-value -0d0) (eql low-bound 0d0))
+ (and (eql high-value 0d0) (eql low-bound -0d0))))
+ #!+negative-zero-is-not-zero
+ (eql (car high-bound) low-bound))
+ #!+negative-zero-is-not-zero
+ ((or (and (eql low-bound -0f0) (eql high-bound 0f0))
+ (and (eql low-bound -0d0) (eql high-bound 0d0))))
+ ((and (eq (numeric-type-class low) 'integer)
+ (eq (numeric-type-class high) 'integer))
+ (eql (1+ low-bound) high-bound))
+ (t
+ nil))))
+
+;;; Return a numeric type that is a supertype for both TYPE1 and TYPE2.
+;;;
+;;; ### Note: we give up early, so keep from dropping lots of information on
+;;; the floor by returning overly general types.
+(define-type-method (number :simple-union) (type1 type2)
+ (declare (type numeric-type type1 type2))
+ (cond ((csubtypep type1 type2) type2)
+ ((csubtypep type2 type1) type1)
+ (t
+ (let ((class1 (numeric-type-class type1))
+ (format1 (numeric-type-format type1))
+ (complexp1 (numeric-type-complexp type1))
+ (class2 (numeric-type-class type2))
+ (format2 (numeric-type-format type2))
+ (complexp2 (numeric-type-complexp type2)))
+ (when (and (eq class1 class2)
+ (eq format1 format2)
+ (eq complexp1 complexp2)
+ (or (numeric-types-intersect type1 type2)
+ (numeric-types-adjacent type1 type2)
+ (numeric-types-adjacent type2 type1)))
+ (make-numeric-type
+ :class class1
+ :format format1
+ :complexp complexp1
+ :low (numeric-bound-max (numeric-type-low type1)
+ (numeric-type-low type2)
+ <= < t)
+ :high (numeric-bound-max (numeric-type-high type1)
+ (numeric-type-high type2)
+ >= > t)))))))
+
+(!cold-init-forms
+ (setf (info :type :kind 'number) :primitive)
+ (setf (info :type :builtin 'number)
+ (make-numeric-type :complexp nil)))
+
+(def-type-translator complex (&optional (spec '*))
+ (if (eq spec '*)
+ (make-numeric-type :complexp :complex)
+ (let ((type (specifier-type spec)))
+ (unless (numeric-type-p type)
+ (error "Component type for Complex is not numeric: ~S." spec))
+ (when (eq (numeric-type-complexp type) :complex)
+ (error "Component type for Complex is complex: ~S." spec))
+ (let ((res (copy-numeric-type type)))
+ (setf (numeric-type-complexp res) :complex)
+ res))))
+
+;;; If X is *, return NIL, otherwise return the bound, which must be a
+;;; member of TYPE or a one-element list of a member of TYPE.
+#!-sb-fluid (declaim (inline canonicalized-bound))
+(defun canonicalized-bound (bound type)
+ (cond ((eq bound '*) nil)
+ ((or (sb!xc:typep bound type)
+ (and (consp bound)
+ (sb!xc:typep (car bound) type)
+ (null (cdr bound))))
+ bound)
+ (t
+ (error "Bound is not ~S, a ~S or a list of a ~S: ~S"
+ '*
+ type
+ type
+ bound))))
+
+(def-type-translator integer (&optional (low '*) (high '*))
+ (let* ((l (canonicalized-bound low 'integer))
+ (lb (if (consp l) (1+ (car l)) l))
+ (h (canonicalized-bound high 'integer))
+ (hb (if (consp h) (1- (car h)) h)))
+ (when (and hb lb (< hb lb))
+ (error "Lower bound ~S is greater than upper bound ~S." l h))
+ (make-numeric-type :class 'integer
+ :complexp :real
+ :enumerable (not (null (and l h)))
+ :low lb
+ :high hb)))
+
+(defmacro def-bounded-type (type class format)
+ `(def-type-translator ,type (&optional (low '*) (high '*))
+ (let ((lb (canonicalized-bound low ',type))
+ (hb (canonicalized-bound high ',type)))
+ (unless (numeric-bound-test* lb hb <= <)
+ (error "Lower bound ~S is not less than upper bound ~S." low high))
+ (make-numeric-type :class ',class :format ',format :low lb :high hb))))
+
+(def-bounded-type rational rational nil)
+(def-bounded-type float float nil)
+(def-bounded-type real nil nil)
+
+(defmacro define-float-format (f)
+ `(def-bounded-type ,f float ,f))
+
+(define-float-format short-float)
+(define-float-format single-float)
+(define-float-format double-float)
+(define-float-format long-float)
+
+(defun numeric-types-intersect (type1 type2)
+ (declare (type numeric-type type1 type2))
+ (let* ((class1 (numeric-type-class type1))
+ (class2 (numeric-type-class type2))
+ (complexp1 (numeric-type-complexp type1))
+ (complexp2 (numeric-type-complexp type2))
+ (format1 (numeric-type-format type1))
+ (format2 (numeric-type-format type2))
+ (low1 (numeric-type-low type1))
+ (high1 (numeric-type-high type1))
+ (low2 (numeric-type-low type2))
+ (high2 (numeric-type-high type2)))
+ ;; If one is complex and the other isn't, then they are disjoint.
+ (cond ((not (or (eq complexp1 complexp2)
+ (null complexp1) (null complexp2)))
+ nil)
+ ;; If either type is a float, then the other must either be
+ ;; specified to be a float or unspecified. Otherwise, they
+ ;; are disjoint.
+ ((and (eq class1 'float)
+ (not (member class2 '(float nil)))) nil)
+ ((and (eq class2 'float)
+ (not (member class1 '(float nil)))) nil)
+ ;; If the float formats are specified and different, the
+ ;; types are disjoint.
+ ((not (or (eq format1 format2) (null format1) (null format2)))
+ nil)
+ (t
+ ;; Check the bounds. This is a bit odd because we must
+ ;; always have the outer bound of the interval as the
+ ;; second arg.
+ (if (numeric-bound-test high1 high2 <= <)
+ (or (and (numeric-bound-test low1 low2 >= >)
+ (numeric-bound-test* low1 high2 <= <))
+ (and (numeric-bound-test low2 low1 >= >)
+ (numeric-bound-test* low2 high1 <= <)))
+ (or (and (numeric-bound-test* low2 high1 <= <)
+ (numeric-bound-test low2 low1 >= >))
+ (and (numeric-bound-test high2 high1 <= <)
+ (numeric-bound-test* high2 low1 >= >))))))))
+
+;;; Take the numeric bound X and convert it into something that can be
+;;; used as a bound in a numeric type with the specified CLASS and
+;;; FORMAT. If UP-P is true, then we round up as needed, otherwise we
+;;; round down. UP-P true implies that X is a lower bound, i.e. (N) > N.
+;;;
+;;; This is used by NUMERIC-TYPE-INTERSECTION to mash the bound into
+;;; the appropriate type number. X may only be a float when CLASS is
+;;; FLOAT.
+;;;
+;;; ### Note: it is possible for the coercion to a float to overflow
+;;; or underflow. This happens when the bound doesn't fit in the
+;;; specified format. In this case, we should really return the
+;;; appropriate {Most | Least}-{Positive | Negative}-XXX-Float float
+;;; of desired format. But these conditions aren't currently signalled
+;;; in any useful way.
+;;;
+;;; Also, when converting an open rational bound into a float we
+;;; should probably convert it to a closed bound of the closest float
+;;; in the specified format. KLUDGE: In general, open float bounds are
+;;; screwed up. -- (comment from original CMU CL)
+(defun round-numeric-bound (x class format up-p)
+ (if x
+ (let ((cx (if (consp x) (car x) x)))
+ (ecase class
+ ((nil rational) x)
+ (integer
+ (if (and (consp x) (integerp cx))
+ (if up-p (1+ cx) (1- cx))
+ (if up-p (ceiling cx) (floor cx))))
+ (float
+ (let ((res (if format (coerce cx format) (float cx))))
+ (if (consp x) (list res) res)))))
+ nil))
+
+;;; Handle the case of TYPE-INTERSECTION on two numeric types. We use
+;;; TYPES-INTERSECT to throw out the case of types with no
+;;; intersection. If an attribute in TYPE1 is unspecified, then we use
+;;; TYPE2's attribute, which must be at least as restrictive. If the
+;;; types intersect, then the only attributes that can be specified
+;;; and different are the class and the bounds.
+;;;
+;;; When the class differs, we use the more restrictive class. The
+;;; only interesting case is RATIONAL/INTEGER, since RATIONAL includes
+;;; INTEGER.
+;;;
+;;; We make the result lower (upper) bound the maximum (minimum) of
+;;; the argument lower (upper) bounds. We convert the bounds into the
+;;; appropriate numeric type before maximizing. This avoids possible
+;;; confusion due to mixed-type comparisons (but I think the result is
+;;; the same).
+(define-type-method (number :simple-intersection) (type1 type2)
+ (declare (type numeric-type type1 type2))
+ (if (numeric-types-intersect type1 type2)
+ (let* ((class1 (numeric-type-class type1))
+ (class2 (numeric-type-class type2))
+ (class (ecase class1
+ ((nil) class2)
+ ((integer float) class1)
+ (rational (if (eq class2 'integer)
+ 'integer
+ 'rational))))
+ (format (or (numeric-type-format type1)
+ (numeric-type-format type2))))
+ (values
+ (make-numeric-type
+ :class class
+ :format format
+ :complexp (or (numeric-type-complexp type1)
+ (numeric-type-complexp type2))
+ :low (numeric-bound-max
+ (round-numeric-bound (numeric-type-low type1)
+ class format t)
+ (round-numeric-bound (numeric-type-low type2)
+ class format t)
+ > >= nil)
+ :high (numeric-bound-max
+ (round-numeric-bound (numeric-type-high type1)
+ class format nil)
+ (round-numeric-bound (numeric-type-high type2)
+ class format nil)
+ < <= nil))
+ t))
+ (values *empty-type* t)))
+
+;;; Given two float formats, return the one with more precision. If
+;;; either one is null, return NIL.
+(defun float-format-max (f1 f2)
+ (when (and f1 f2)
+ (dolist (f float-formats (error "Bad float format: ~S." f1))
+ (when (or (eq f f1) (eq f f2))
+ (return f)))))
+
+;;; Return the result of an operation on Type1 and Type2 according to
+;;; the rules of numeric contagion. This is always NUMBER, some float
+;;; format (possibly complex) or RATIONAL. Due to rational
+;;; canonicalization, there isn't much we can do here with integers or
+;;; rational complex numbers.
+;;;
+;;; If either argument is not a Numeric-Type, then return NUMBER. This
+;;; is useful mainly for allowing types that are technically numbers,
+;;; but not a Numeric-Type.
+(defun numeric-contagion (type1 type2)
+ (if (and (numeric-type-p type1) (numeric-type-p type2))
+ (let ((class1 (numeric-type-class type1))
+ (class2 (numeric-type-class type2))
+ (format1 (numeric-type-format type1))
+ (format2 (numeric-type-format type2))
+ (complexp1 (numeric-type-complexp type1))
+ (complexp2 (numeric-type-complexp type2)))
+ (cond ((or (null complexp1)
+ (null complexp2))
+ (specifier-type 'number))
+ ((eq class1 'float)
+ (make-numeric-type
+ :class 'float
+ :format (ecase class2
+ (float (float-format-max format1 format2))
+ ((integer rational) format1)
+ ((nil)
+ ;; A double-float with any real number is a
+ ;; double-float.
+ #!-long-float
+ (if (eq format1 'double-float)
+ 'double-float
+ nil)
+ ;; A long-float with any real number is a
+ ;; long-float.
+ #!+long-float
+ (if (eq format1 'long-float)
+ 'long-float
+ nil)))
+ :complexp (if (or (eq complexp1 :complex)
+ (eq complexp2 :complex))
+ :complex
+ :real)))
+ ((eq class2 'float) (numeric-contagion type2 type1))
+ ((and (eq complexp1 :real) (eq complexp2 :real))
+ (make-numeric-type
+ :class (and class1 class2 'rational)
+ :complexp :real))
+ (t
+ (specifier-type 'number))))
+ (specifier-type 'number)))
+\f
+;;;; array types
+
+(define-type-class array)
+
+;;; What this does depends on the setting of the
+;;; *USE-IMPLEMENTATION-TYPES* switch. If true, return the specialized
+;;; element type, otherwise return the original element type.
+(defun specialized-element-type-maybe (type)
+ (declare (type array-type type))
+ (if *use-implementation-types*
+ (array-type-specialized-element-type type)
+ (array-type-element-type type)))
+
+(define-type-method (array :simple-=) (type1 type2)
+ (values (and (equal (array-type-dimensions type1)
+ (array-type-dimensions type2))
+ (eq (array-type-complexp type1)
+ (array-type-complexp type2))
+ (type= (specialized-element-type-maybe type1)
+ (specialized-element-type-maybe type2)))
+ t))
+
+(define-type-method (array :unparse) (type)
+ (let ((dims (array-type-dimensions type))
+ (eltype (type-specifier (array-type-element-type type)))
+ (complexp (array-type-complexp type)))
+ (cond ((eq dims '*)
+ (if (eq eltype '*)
+ (if complexp 'array 'simple-array)
+ (if complexp `(array ,eltype) `(simple-array ,eltype))))
+ ((= (length dims) 1)
+ (if complexp
+ (if (eq (car dims) '*)
+ (case eltype
+ (bit 'bit-vector)
+ (base-char 'base-string)
+ (character 'string)
+ (* 'vector)
+ (t `(vector ,eltype)))
+ (case eltype
+ (bit `(bit-vector ,(car dims)))
+ (base-char `(base-string ,(car dims)))
+ (character `(string ,(car dims)))
+ (t `(vector ,eltype ,(car dims)))))
+ (if (eq (car dims) '*)
+ (case eltype
+ (bit 'simple-bit-vector)
+ (base-char 'simple-base-string)
+ (character 'simple-string)
+ ((t) 'simple-vector)
+ (t `(simple-array ,eltype (*))))
+ (case eltype
+ (bit `(simple-bit-vector ,(car dims)))
+ (base-char `(simple-base-string ,(car dims)))
+ (character `(simple-string ,(car dims)))
+ ((t) `(simple-vector ,(car dims)))
+ (t `(simple-array ,eltype ,dims))))))
+ (t
+ (if complexp
+ `(array ,eltype ,dims)
+ `(simple-array ,eltype ,dims))))))
+
+(define-type-method (array :simple-subtypep) (type1 type2)
+ (let ((dims1 (array-type-dimensions type1))
+ (dims2 (array-type-dimensions type2))
+ (complexp2 (array-type-complexp type2)))
+ ;; See whether dimensions are compatible.
+ (cond ((not (or (eq dims2 '*)
+ (and (not (eq dims1 '*))
+ ;; (sbcl-0.6.4 has trouble figuring out that
+ ;; DIMS1 and DIMS2 must be lists at this
+ ;; point, and knowing that is important to
+ ;; compiling EVERY efficiently.)
+ (= (length (the list dims1))
+ (length (the list dims2)))
+ (every (lambda (x y)
+ (or (eq y '*) (eql x y)))
+ (the list dims1)
+ (the list dims2)))))
+ (values nil t))
+ ;; See whether complexpness is compatible.
+ ((not (or (eq complexp2 :maybe)
+ (eq (array-type-complexp type1) complexp2)))
+ (values nil t))
+ ;; If the TYPE2 eltype is wild, we win. Otherwise, the types
+ ;; must be identical.
+ ((or (eq (array-type-element-type type2) *wild-type*)
+ (type= (specialized-element-type-maybe type1)
+ (specialized-element-type-maybe type2)))
+ (values t t))
+ (t
+ (values nil t)))))
+
+(define-superclasses array
+ ((string string)
+ (vector vector)
+ (array))
+ !cold-init-forms)
+
+(defun array-types-intersect (type1 type2)
+ (declare (type array-type type1 type2))
+ (let ((dims1 (array-type-dimensions type1))
+ (dims2 (array-type-dimensions type2))
+ (complexp1 (array-type-complexp type1))
+ (complexp2 (array-type-complexp type2)))
+ ;; See whether dimensions are compatible.
+ (cond ((not (or (eq dims1 '*) (eq dims2 '*)
+ (and (= (length dims1) (length dims2))
+ (every #'(lambda (x y)
+ (or (eq x '*) (eq y '*) (= x y)))
+ dims1 dims2))))
+ (values nil t))
+ ;; See whether complexpness is compatible.
+ ((not (or (eq complexp1 :maybe)
+ (eq complexp2 :maybe)
+ (eq complexp1 complexp2)))
+ (values nil t))
+ ;; If either element type is wild, then they intersect.
+ ;; Otherwise, the types must be identical.
+ ((or (eq (array-type-element-type type1) *wild-type*)
+ (eq (array-type-element-type type2) *wild-type*)
+ (type= (specialized-element-type-maybe type1)
+ (specialized-element-type-maybe type2)))
+
+ (values t t))
+ (t
+ (values nil t)))))
+
+(define-type-method (array :simple-intersection) (type1 type2)
+ (declare (type array-type type1 type2))
+ (if (array-types-intersect type1 type2)
+ (let ((dims1 (array-type-dimensions type1))
+ (dims2 (array-type-dimensions type2))
+ (complexp1 (array-type-complexp type1))
+ (complexp2 (array-type-complexp type2))
+ (eltype1 (array-type-element-type type1))
+ (eltype2 (array-type-element-type type2)))
+ (values
+ (specialize-array-type
+ (make-array-type
+ :dimensions (cond ((eq dims1 '*) dims2)
+ ((eq dims2 '*) dims1)
+ (t
+ (mapcar (lambda (x y) (if (eq x '*) y x))
+ dims1 dims2)))
+ :complexp (if (eq complexp1 :maybe) complexp2 complexp1)
+ :element-type (if (eq eltype1 *wild-type*) eltype2 eltype1)))
+ t))
+ (values *empty-type* t)))
+
+;;; Check a supplied dimension list to determine whether it is legal,
+;;; and return it in canonical form (as either '* or a list).
+(defun canonical-array-dimensions (dims)
+ (typecase dims
+ ((member *) dims)
+ (integer
+ (when (minusp dims)
+ (error "Arrays can't have a negative number of dimensions: ~S" dims))
+ (when (>= dims sb!xc:array-rank-limit)
+ (error "array type with too many dimensions: ~S" dims))
+ (make-list dims :initial-element '*))
+ (list
+ (when (>= (length dims) sb!xc:array-rank-limit)
+ (error "array type with too many dimensions: ~S" dims))
+ (dolist (dim dims)
+ (unless (eq dim '*)
+ (unless (and (integerp dim)
+ (>= dim 0)
+ (< dim sb!xc:array-dimension-limit))
+ (error "bad dimension in array type: ~S" dim))))
+ dims)
+ (t
+ (error "Array dimensions is not a list, integer or *:~% ~S" dims))))
+\f
+;;;; MEMBER types
+
+(define-type-class member)
+
+(define-type-method (member :unparse) (type)
+ (let ((members (member-type-members type)))
+ (if (equal members '(nil))
+ 'null
+ `(member ,@members))))
+
+(define-type-method (member :simple-subtypep) (type1 type2)
+ (values (subsetp (member-type-members type1) (member-type-members type2))
+ t))
+
+(define-type-method (member :complex-subtypep-arg1) (type1 type2)
+ (block PUNT
+ (values (every-type-op ctypep type2 (member-type-members type1)
+ :list-first t)
+ t)))
+
+;;; We punt if the odd type is enumerable and intersects with the
+;;; MEMBER type. If not enumerable, then it is definitely not a
+;;; subtype of the MEMBER type.
+(define-type-method (member :complex-subtypep-arg2) (type1 type2)
+ (cond ((not (type-enumerable type1)) (values nil t))
+ ((types-intersect type1 type2) (values nil nil))
+ (t
+ (values nil t))))
+
+(define-type-method (member :simple-intersection) (type1 type2)
+ (let ((mem1 (member-type-members type1))
+ (mem2 (member-type-members type2)))
+ (values (cond ((subsetp mem1 mem2) type1)
+ ((subsetp mem2 mem1) type2)
+ (t
+ (let ((res (intersection mem1 mem2)))
+ (if res
+ (make-member-type :members res)
+ *empty-type*))))
+ t)))
+
+(define-type-method (member :complex-intersection) (type1 type2)
+ (block PUNT
+ (collect ((members))
+ (let ((mem2 (member-type-members type2)))
+ (dolist (member mem2)
+ (multiple-value-bind (val win) (ctypep member type1)
+ (unless win
+ (return-from PUNT (values type2 nil)))
+ (when val (members member))))
+
+ (values (cond ((subsetp mem2 (members)) type2)
+ ((null (members)) *empty-type*)
+ (t
+ (make-member-type :members (members))))
+ t)))))
+
+;;; We don't need a :COMPLEX-UNION, since the only interesting case is a union
+;;; type, and the member/union interaction is handled by the union type
+;;; method.
+(define-type-method (member :simple-union) (type1 type2)
+ (let ((mem1 (member-type-members type1))
+ (mem2 (member-type-members type2)))
+ (cond ((subsetp mem1 mem2) type2)
+ ((subsetp mem2 mem1) type1)
+ (t
+ (make-member-type :members (union mem1 mem2))))))
+
+(define-type-method (member :simple-=) (type1 type2)
+ (let ((mem1 (member-type-members type1))
+ (mem2 (member-type-members type2)))
+ (values (and (subsetp mem1 mem2) (subsetp mem2 mem1))
+ t)))
+
+(define-type-method (member :complex-=) (type1 type2)
+ (if (type-enumerable type1)
+ (multiple-value-bind (val win) (csubtypep type2 type1)
+ (if (or val (not win))
+ (values nil nil)
+ (values nil t)))
+ (values nil t)))
+
+(def-type-translator member (&rest members)
+ (if members
+ (make-member-type :members (remove-duplicates members))
+ *empty-type*))
+\f
+;;;; union types
+
+;;; Make a union type from the specifier types, setting ENUMERABLE in
+;;; the result if all are enumerable.
+(defun make-union-type (types)
+ (declare (list types))
+ (%make-union-type (every #'type-enumerable types) types))
+
+(define-type-class union)
+
+;;; If LIST, then return that, otherwise the OR of the component types.
+(define-type-method (union :unparse) (type)
+ (declare (type ctype type))
+ (if (type= type (specifier-type 'list))
+ 'list
+ `(or ,@(mapcar #'type-specifier (union-type-types type)))))
+
+;;; Two union types are equal if every type in one is equal to some
+;;; type in the other.
+(define-type-method (union :simple-=) (type1 type2)
+ (block PUNT
+ (let ((types1 (union-type-types type1))
+ (types2 (union-type-types type2)))
+ (values (and (dolist (type1 types1 t)
+ (unless (any-type-op type= type1 types2)
+ (return nil)))
+ (dolist (type2 types2 t)
+ (unless (any-type-op type= type2 types1)
+ (return nil))))
+ t))))
+
+;;; Similarly, a union type is a subtype of another if every element
+;;; of TYPE1 is a subtype of some element of TYPE2.
+(define-type-method (union :simple-subtypep) (type1 type2)
+ (block PUNT
+ (let ((types2 (union-type-types type2)))
+ (values (dolist (type1 (union-type-types type1) t)
+ (unless (any-type-op csubtypep type1 types2)
+ (return nil)))
+ t))))
+
+(define-type-method (union :complex-subtypep-arg1) (type1 type2)
+ (block PUNT
+ (values (every-type-op csubtypep type2 (union-type-types type1)
+ :list-first t)
+ t)))
+
+(define-type-method (union :complex-subtypep-arg2) (type1 type2)
+ (block PUNT
+ (values (any-type-op csubtypep type1 (union-type-types type2)) t)))
+
+(define-type-method (union :complex-union) (type1 type2)
+ (let* ((class1 (type-class-info type1)))
+ (collect ((res))
+ (let ((this-type type1))
+ (dolist (type (union-type-types type2)
+ (if (res)
+ (make-union-type (cons this-type (res)))
+ this-type))
+ (cond ((eq (type-class-info type) class1)
+ (let ((union (funcall (type-class-simple-union class1)
+ this-type type)))
+ (if union
+ (setq this-type union)
+ (res type))))
+ ((csubtypep type this-type))
+ ((csubtypep type1 type) (return type2))
+ (t
+ (res type))))))))
+
+;;; For the union of union types, we let the :COMPLEX-UNION method do
+;;; the work.
+(define-type-method (union :simple-union) (type1 type2)
+ (let ((res type1))
+ (dolist (t2 (union-type-types type2) res)
+ (setq res (type-union res t2)))))
+
+(define-type-method (union :simple-intersection :complex-intersection)
+ (type1 type2)
+ (let ((res *empty-type*)
+ (win t))
+ (dolist (type (union-type-types type2) (values res win))
+ (multiple-value-bind (int w) (type-intersection type1 type)
+ (setq res (type-union res int))
+ (unless w (setq win nil))))))
+
+(def-type-translator or (&rest types)
+ (reduce #'type-union
+ (mapcar #'specifier-type types)
+ :initial-value *empty-type*))
+
+;;; We don't actually have intersection types, since the result of
+;;; reasonable type intersections is always describable as a union of
+;;; simple types. If something is too hairy to fit this mold, then we
+;;; make a hairy type.
+(def-type-translator and (&whole spec &rest types)
+ (let ((res *wild-type*))
+ (dolist (type types res)
+ (let ((ctype (specifier-type type)))
+ (multiple-value-bind (int win) (type-intersection res ctype)
+ (unless win
+ (return (make-hairy-type :specifier spec)))
+ (setq res int))))))
+\f
+;;; Return the type that describes all objects that are in X but not
+;;; in Y. If we can't determine this type, then return NIL.
+;;;
+;;; For now, we only are clever dealing with union and member types.
+;;; If either type is not a union type, then we pretend that it is a
+;;; union of just one type. What we do is remove from X all the types
+;;; that are a subtype any type in Y. If any type in X intersects with
+;;; a type in Y but is not a subtype, then we give up.
+;;;
+;;; We must also special-case any member type that appears in the
+;;; union. We remove from X's members all objects that are TYPEP to Y.
+;;; If Y has any members, we must be careful that none of those
+;;; members are CTYPEP to any of Y's non-member types. We give up in
+;;; this case, since to compute that difference we would have to break
+;;; the type from X into some collection of types that represents the
+;;; type without that particular element. This seems too hairy to be
+;;; worthwhile, given its low utility.
+(defun type-difference (x y)
+ (let ((x-types (if (union-type-p x) (union-type-types x) (list x)))
+ (y-types (if (union-type-p y) (union-type-types y) (list y))))
+ (collect ((res))
+ (dolist (x-type x-types)
+ (if (member-type-p x-type)
+ (collect ((members))
+ (dolist (mem (member-type-members x-type))
+ (multiple-value-bind (val win) (ctypep mem y)
+ (unless win (return-from type-difference nil))
+ (unless val
+ (members mem))))
+ (when (members)
+ (res (make-member-type :members (members)))))
+ (dolist (y-type y-types (res x-type))
+ (multiple-value-bind (val win) (csubtypep x-type y-type)
+ (unless win (return-from type-difference nil))
+ (when val (return))
+ (when (types-intersect x-type y-type)
+ (return-from type-difference nil))))))
+
+ (let ((y-mem (find-if #'member-type-p y-types)))
+ (when y-mem
+ (let ((members (member-type-members y-mem)))
+ (dolist (x-type x-types)
+ (unless (member-type-p x-type)
+ (dolist (member members)
+ (multiple-value-bind (val win) (ctypep member x-type)
+ (when (or (not win) val)
+ (return-from type-difference nil)))))))))
+
+ (cond ((null (res)) *empty-type*)
+ ((null (rest (res))) (first (res)))
+ (t
+ (make-union-type (res)))))))
+\f
+(def-type-translator array (&optional (element-type '*)
+ (dimensions '*))
+ (specialize-array-type
+ (make-array-type :dimensions (canonical-array-dimensions dimensions)
+ :element-type (specifier-type element-type))))
+
+(def-type-translator simple-array (&optional (element-type '*)
+ (dimensions '*))
+ (specialize-array-type
+ (make-array-type :dimensions (canonical-array-dimensions dimensions)
+ :element-type (specifier-type element-type)
+ :complexp nil)))
+\f
+(!defun-from-collected-cold-init-forms !late-type-cold-init)
--- /dev/null
+;;;; OS interface functions for CMU CL under Linux
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!SYS")
+
+(file-comment
+ "$Header$")
+
+;;; Check that target machine features are set up consistently with this file.
+#!-linux (error "missing :LINUX feature")
+
+(defun software-type ()
+ #!+sb-doc
+ "Return a string describing the supporting software."
+ (values "Linux"))
+
+(defun software-version ()
+ #!+sb-doc
+ "Return a string describing version of the supporting software, or NIL
+ if not available."
+ ;; The old CMU CL code is NILed out here. If we wanted to do this, we should
+ ;; probably either use "/bin/uname -r", but since in any case we don't have
+ ;; RUN-PROGRAM working right now (sbcl-0.6.4), for now we just punt,
+ ;; returning NIL.
+ #+nil
+ (string-trim '(#\newline)
+ (with-output-to-string (stream)
+ (run-program "/usr/cs/etc/version" ; Site dependent???
+ nil :output stream)))
+ nil)
+
+;;; OS-COLD-INIT-OR-REINIT initializes our operating-system interface.
+;;; It sets the values of the global port variables to what they
+;;; should be and calls the functions that set up the argument blocks
+;;; for the server interfaces.
+(defun os-cold-init-or-reinit () ; KLUDGE: don't know what to do here
+ #!+sparc ;; Can't use #x20000000 thru #xDFFFFFFF, but mach tries to let us.
+ (sb!sys:allocate-system-memory-at (sb!sys:int-sap #x20000000) #xc0000000))
+
+;;; Return system time, user time and number of page faults.
+(defun get-system-info ()
+ (multiple-value-bind
+ (err? utime stime maxrss ixrss idrss isrss minflt majflt)
+ (sb!unix:unix-getrusage sb!unix:rusage_self)
+ (declare (ignore maxrss ixrss idrss isrss minflt))
+ (unless err? ; FIXME: nonmnemonic (reversed) name for ERR?
+ (error "Unix system call getrusage failed: ~A."
+ (sb!unix:get-unix-error-msg utime)))
+
+ (values utime stime majflt)))
+
+;;; Return the system page size.
+(defun get-page-size ()
+ ;; probably should call getpagesize()
+ ;; FIXME: Or we could just get rid of this, since the uses of it look
+ ;; disposable.
+ 4096)
--- /dev/null
+;;;; the STREAM structure
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!IMPL")
+
+(file-comment
+ "$Header$")
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defconstant in-buffer-length 512 "the size of a stream in-buffer"))
+
+(deftype in-buffer-type ()
+ `(simple-array (unsigned-byte 8) (,in-buffer-length)))
+
+(defstruct (lisp-stream (:constructor nil))
+ ;; Buffered input.
+ (in-buffer nil :type (or in-buffer-type null))
+ (in-index in-buffer-length :type index) ; index into IN-BUFFER
+ (in #'ill-in :type function) ; READ-CHAR function
+ (bin #'ill-bin :type function) ; byte input function
+ (n-bin #'ill-bin :type function) ; n-byte input function
+ (out #'ill-out :type function) ; WRITE-CHAR function
+ (bout #'ill-bout :type function) ; byte output function
+ (sout #'ill-out :type function) ; string output function
+ (misc #'do-nothing :type function)) ; less-used methods
+(def!method print-object ((x lisp-stream) stream)
+ (print-unreadable-object (x stream :type t :identity t)))
--- /dev/null
+;;;; functions to implement lists
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!IMPL")
+
+(file-comment
+ "$Header$")
+
+;;;; KLUDGE: comment from CMU CL, what does it mean?
+;;;; NSUBLIS, things at the beginning broken.
+;;;; -- WHN 20000127
+
+(declaim (maybe-inline
+ tree-equal list-length nth %setnth nthcdr last make-list append
+ copy-list copy-alist copy-tree revappend nconc nreconc butlast
+ nbutlast ldiff member member-if member-if-not tailp adjoin union
+ nunion intersection nintersection set-difference nset-difference
+ set-exclusive-or nset-exclusive-or subsetp acons pairlis assoc
+ assoc-if assoc-if-not rassoc rassoc-if rassoc-if-not subst subst-if
+ subst-if-not nsubst nsubst-if nsubst-if-not sublis nsublis))
+
+;;; These functions perform basic list operations:
+(defun car (list) #!+sb-doc "Returns the 1st object in a list." (car list))
+(defun cdr (list)
+ #!+sb-doc "Returns all but the first object in a list."
+ (cdr list))
+(defun cadr (list) #!+sb-doc "Returns the 2nd object in a list." (cadr list))
+(defun cdar (list) #!+sb-doc "Returns the cdr of the 1st sublist." (cdar list))
+(defun caar (list) #!+sb-doc "Returns the car of the 1st sublist." (caar list))
+(defun cddr (list)
+ #!+sb-doc "Returns all but the 1st two objects of a list."
+ (cddr list))
+(defun caddr (list)
+ #!+sb-doc "Returns the 1st object in the cddr of a list."
+ (caddr list))
+(defun caadr (list)
+ #!+sb-doc "Returns the 1st object in the cadr of a list."
+ (caadr list))
+(defun caaar (list)
+ #!+sb-doc "Returns the 1st object in the caar of a list."
+ (caaar list))
+(defun cdaar (list)
+ #!+sb-doc "Returns the cdr of the caar of a list."
+ (cdaar list))
+(defun cddar (list)
+ #!+sb-doc "Returns the cdr of the cdar of a list."
+ (cddar list))
+(defun cdddr (list)
+ #!+sb-doc "Returns the cdr of the cddr of a list."
+ (cdddr list))
+(defun cadar (list)
+ #!+sb-doc "Returns the car of the cdar of a list."
+ (cadar list))
+(defun cdadr (list)
+ #!+sb-doc "Returns the cdr of the cadr of a list."
+ (cdadr list))
+(defun caaaar (list)
+ #!+sb-doc "Returns the car of the caaar of a list."
+ (caaaar list))
+(defun caaadr (list)
+ #!+sb-doc "Returns the car of the caadr of a list."
+ (caaadr list))
+(defun caaddr (list)
+ #!+sb-doc "Returns the car of the caddr of a list."
+ (caaddr list))
+(defun cadddr (list)
+ #!+sb-doc "Returns the car of the cdddr of a list."
+ (cadddr list))
+(defun cddddr (list)
+ #!+sb-doc "Returns the cdr of the cdddr of a list."
+ (cddddr list))
+(defun cdaaar (list)
+ #!+sb-doc "Returns the cdr of the caaar of a list."
+ (cdaaar list))
+(defun cddaar (list)
+ #!+sb-doc "Returns the cdr of the cdaar of a list."
+ (cddaar list))
+(defun cdddar (list)
+ #!+sb-doc "Returns the cdr of the cddar of a list."
+ (cdddar list))
+(defun caadar (list)
+ #!+sb-doc "Returns the car of the cadar of a list."
+ (caadar list))
+(defun cadaar (list)
+ #!+sb-doc "Returns the car of the cdaar of a list."
+ (cadaar list))
+(defun cadadr (list)
+ #!+sb-doc "Returns the car of the cdadr of a list."
+ (cadadr list))
+(defun caddar (list)
+ #!+sb-doc "Returns the car of the cddar of a list."
+ (caddar list))
+(defun cdaadr (list)
+ #!+sb-doc "Returns the cdr of the caadr of a list."
+ (cdaadr list))
+(defun cdadar (list)
+ #!+sb-doc "Returns the cdr of the cadar of a list."
+ (cdadar list))
+(defun cdaddr (list)
+ #!+sb-doc "Returns the cdr of the caddr of a list."
+ (cdaddr list))
+(defun cddadr (list)
+ #!+sb-doc "Returns the cdr of the cdadr of a list."
+ (cddadr list))
+(defun cons (se1 se2)
+ #!+sb-doc "Returns a list with se1 as the car and se2 as the cdr."
+ (cons se1 se2))
+\f
+(declaim (maybe-inline tree-equal-test tree-equal-test-not))
+
+(defun tree-equal-test-not (x y test-not)
+ (cond ((consp x)
+ (and (consp y)
+ (tree-equal-test-not (car x) (car y) test-not)
+ (tree-equal-test-not (cdr x) (cdr y) test-not)))
+ ((consp y) nil)
+ ((not (funcall test-not x y)) t)
+ (t ())))
+
+(defun tree-equal-test (x y test)
+ (cond ((consp x)
+ (and (consp y)
+ (tree-equal-test (car x) (car y) test)
+ (tree-equal-test (cdr x) (cdr y) test)))
+ ((consp y) nil)
+ ((funcall test x y) t)
+ (t ())))
+
+(defun tree-equal (x y &key (test #'eql) test-not)
+ #!+sb-doc
+ "Returns T if X and Y are isomorphic trees with identical leaves."
+ (if test-not
+ (tree-equal-test-not x y test-not)
+ (tree-equal-test x y test)))
+
+(defun endp (object)
+ #!+sb-doc
+ "The recommended way to test for the end of a list. True if Object is nil,
+ false if Object is a cons, and an error for any other types of arguments."
+ (endp object))
+
+(defun list-length (list)
+ #!+sb-doc
+ "Returns the length of the given List, or Nil if the List is circular."
+ (do ((n 0 (+ n 2))
+ (y list (cddr y))
+ (z list (cdr z)))
+ (())
+ (declare (fixnum n) (list y z))
+ (when (endp y) (return n))
+ (when (endp (cdr y)) (return (+ n 1)))
+ (when (and (eq y z) (> n 0)) (return nil))))
+
+(defun nth (n list)
+ #!+sb-doc
+ "Returns the nth object in a list where the car is the zero-th element."
+ (car (nthcdr n list)))
+
+(defun first (list)
+ #!+sb-doc
+ "Returns the 1st object in a list or NIL if the list is empty."
+ (car list))
+(defun second (list)
+ "Returns the 2nd object in a list or NIL if there is no 2nd object."
+ (cadr list))
+(defun third (list)
+ #!+sb-doc
+ "Returns the 3rd object in a list or NIL if there is no 3rd object."
+ (caddr list))
+(defun fourth (list)
+ #!+sb-doc
+ "Returns the 4th object in a list or NIL if there is no 4th object."
+ (cadddr list))
+(defun fifth (list)
+ #!+sb-doc
+ "Returns the 5th object in a list or NIL if there is no 5th object."
+ (car (cddddr list)))
+(defun sixth (list)
+ #!+sb-doc
+ "Returns the 6th object in a list or NIL if there is no 6th object."
+ (cadr (cddddr list)))
+(defun seventh (list)
+ #!+sb-doc
+ "Returns the 7th object in a list or NIL if there is no 7th object."
+ (caddr (cddddr list)))
+(defun eighth (list)
+ #!+sb-doc
+ "Returns the 8th object in a list or NIL if there is no 8th object."
+ (cadddr (cddddr list)))
+(defun ninth (list)
+ #!+sb-doc
+ "Returns the 9th object in a list or NIL if there is no 9th object."
+ (car (cddddr (cddddr list))))
+(defun tenth (list)
+ #!+sb-doc
+ "Returns the 10th object in a list or NIL if there is no 10th object."
+ (cadr (cddddr (cddddr list))))
+(defun rest (list)
+ #!+sb-doc
+ "Means the same as the cdr of a list."
+ (cdr list))
+
+(defun nthcdr (n list)
+ (declare (type index n))
+ #!+sb-doc
+ "Performs the cdr function n times on a list."
+ (do ((i n (1- i))
+ (result list (cdr result)))
+ ((not (plusp i)) result)
+ (declare (type index i))))
+
+(defun last (list &optional (n 1))
+ #!+sb-doc
+ "Returns the last N conses (not the last element!) of a list."
+ (declare (type index n))
+ (do ((checked-list list (cdr checked-list))
+ (returned-list list)
+ (index 0 (1+ index)))
+ ((atom checked-list) returned-list)
+ (declare (type index index))
+ (if (>= index n)
+ (pop returned-list))))
+
+(defun list (&rest args)
+ #!+sb-doc
+ "Returns constructs and returns a list of its arguments."
+ args)
+
+;;; List* is done the same as list, except that the last cons is made a
+;;; dotted pair
+
+(defun list* (arg &rest others)
+ #!+sb-doc
+ "Returns a list of the arguments with last cons a dotted pair"
+ (cond ((atom others) arg)
+ ((atom (cdr others)) (cons arg (car others)))
+ (t (do ((x others (cdr x)))
+ ((null (cddr x)) (rplacd x (cadr x))))
+ (cons arg others))))
+
+(defun make-list (size &key initial-element)
+ #!+sb-doc
+ "Constructs a list with size elements each set to value"
+ (declare (type index size))
+ (do ((count size (1- count))
+ (result '() (cons initial-element result)))
+ ((zerop count) result)
+ (declare (type index count))))
+\f
+;;; The outer loop finds the first non-null list and the result is started.
+;;; The remaining lists in the arguments are tacked to the end of the result
+;;; using splice which cdr's down the end of the new list
+
+(defun append (&rest lists)
+ #!+sb-doc
+ "Construct a new list by concatenating the list arguments"
+ (do ((top lists (cdr top))) ;;Cdr to first non-null list.
+ ((atom top) '())
+ (cond ((null (car top))) ; Nil -> Keep looping
+ ((not (consp (car top))) ; Non cons
+ (if (cdr top)
+ (error "~S is not a list." (car top))
+ (return (car top))))
+ (t ; Start appending
+ (return
+ (if (atom (cdr top))
+ (car top) ;;Special case.
+ (let* ((result (cons (caar top) '()))
+ (splice result))
+ (do ((x (cdar top) (cdr x))) ;;Copy first list
+ ((atom x))
+ (setq splice
+ (cdr (rplacd splice (cons (car x) ()) ))) )
+ (do ((y (cdr top) (cdr y))) ;;Copy rest of lists.
+ ((atom (cdr y))
+ (setq splice (rplacd splice (car y)))
+ result)
+ (if (listp (car y))
+ (do ((x (car y) (cdr x))) ;;Inner copy loop.
+ ((atom x))
+ (setq
+ splice
+ (cdr (rplacd splice (cons (car x) ())))))
+ (error "~S is not a list." (car y)))))))))))
+\f
+;;; list copying functions
+
+;;; The list is copied correctly even if the list is not terminated by ()
+;;; The new list is built by cdr'ing splice which is always at the tail
+;;; of the new list
+
+(defun copy-list (list)
+ #!+sb-doc
+ "Returns a new list EQUAL but not EQ to list"
+ (if (atom list)
+ list
+ (let ((result (list (car list))))
+ (do ((x (cdr list) (cdr x))
+ (splice result
+ (cdr (rplacd splice (cons (car x) '() ))) ))
+ ((atom x)
+ (unless (null x)
+ (rplacd splice x))))
+ result)))
+
+(defun copy-alist (alist)
+ #!+sb-doc
+ "Returns a new association list equal to alist, constructed in space"
+ (if (atom alist)
+ alist
+ (let ((result
+ (cons (if (atom (car alist))
+ (car alist)
+ (cons (caar alist) (cdar alist)) )
+ nil)))
+ (do ((x (cdr alist) (cdr x))
+ (splice result
+ (cdr (rplacd splice
+ (cons
+ (if (atom (car x))
+ (car x)
+ (cons (caar x) (cdar x)))
+ nil)))))
+ ;; Non-null terminated alist done here.
+ ((atom x)
+ (unless (null x)
+ (rplacd splice x))))
+ result)))
+
+(defun copy-tree (object)
+ #!+sb-doc
+ "Recursively copy trees of conses."
+ (if (consp object)
+ (cons (copy-tree (car object)) (copy-tree (cdr object)))
+ object))
+\f
+;;; more commonly-used list functions
+
+(defun revappend (x y)
+ #!+sb-doc
+ "Returns (append (reverse x) y)"
+ (do ((top x (cdr top))
+ (result y (cons (car top) result)))
+ ((endp top) result)))
+
+;;; NCONC finds the first non-null list, so it can make splice point to a cons.
+;;; After finding the first cons element, it holds it in a result variable
+;;; while running down successive elements tacking them together. While
+;;; tacking lists together, if we encounter a null list, we set the previous
+;;; list's last cdr to nil just in case it wasn't already nil, and it could
+;;; have been dotted while the null list was the last argument to NCONC. The
+;;; manipulation of splice (that is starting it out on a first cons, setting
+;;; LAST of splice, and setting splice to ele) inherently handles (nconc x x),
+;;; and it avoids running down the last argument to NCONC which allows the last
+;;; argument to be circular.
+(defun nconc (&rest lists)
+ #!+sb-doc
+ "Concatenates the lists given as arguments (by changing them)"
+ (do ((top lists (cdr top)))
+ ((null top) nil)
+ (let ((top-of-top (car top)))
+ (typecase top-of-top
+ (cons
+ (let* ((result top-of-top)
+ (splice result))
+ (do ((elements (cdr top) (cdr elements)))
+ ((endp elements))
+ (let ((ele (car elements)))
+ (typecase ele
+ (cons (rplacd (last splice) ele)
+ (setf splice ele))
+ (null (rplacd (last splice) nil))
+ (atom (if (cdr elements)
+ (error "Argument is not a list -- ~S." ele)
+ (rplacd (last splice) ele)))
+ (t (error "Argument is not a list -- ~S." ele)))))
+ (return result)))
+ (null)
+ (atom
+ (if (cdr top)
+ (error "Argument is not a list -- ~S." top-of-top)
+ (return top-of-top)))
+ (t (error "Argument is not a list -- ~S." top-of-top))))))
+
+(defun nreconc (x y)
+ #!+sb-doc
+ "Returns (nconc (nreverse x) y)"
+ (do ((1st (cdr x) (if (atom 1st) 1st (cdr 1st)))
+ (2nd x 1st) ;2nd follows first down the list.
+ (3rd y 2nd)) ;3rd follows 2nd down the list.
+ ((atom 2nd) 3rd)
+ (rplacd 2nd 3rd)))
+\f
+(defun butlast (list &optional (n 1))
+ #!+sb-doc
+ "Return a new list the same as LIST without the last N conses.
+ List must not be circular."
+ (declare (list list) (type index n))
+ (let ((length (do ((list list (cdr list))
+ (i 0 (1+ i)))
+ ((atom list) (1- i)))))
+ (declare (type index length))
+ (unless (< length n)
+ (do* ((top (cdr list) (cdr top))
+ (result (list (car list)))
+ (splice result)
+ (count length (1- count)))
+ ((= count n) result)
+ (declare (type index count))
+ (setq splice (cdr (rplacd splice (list (car top)))))))))
+
+(defun nbutlast (list &optional (n 1))
+ #!+sb-doc
+ "Modifies List to remove the last N conses. List must not be circular."
+ (declare (list list) (type index n))
+ (let ((length (do ((list list (cdr list))
+ (i 0 (1+ i)))
+ ((atom list) (1- i)))))
+ (declare (type index length))
+ (unless (< length n)
+ (do ((1st (cdr list) (cdr 1st))
+ (2nd list 1st)
+ (count length (1- count)))
+ ((= count n)
+ (rplacd 2nd ())
+ list)
+ (declare (type index count))))))
+
+(defun ldiff (list object)
+ "Returns a new list, whose elements are those of List that appear before
+ Object. If Object is not a tail of List, a copy of List is returned.
+ List must be a proper list or a dotted list."
+ (do* ((list list (cdr list))
+ (result (list ()))
+ (splice result))
+ ((atom list)
+ (if (eql list object)
+ (cdr result)
+ (progn (rplacd splice list) (cdr result))))
+ (if (eql list object)
+ (return (cdr result))
+ (setq splice (cdr (rplacd splice (list (car list))))))))
+\f
+;;; Functions to alter list structure
+
+(defun rplaca (x y)
+ #!+sb-doc
+ "Changes the car of x to y and returns the new x."
+ (rplaca x y))
+
+(defun rplacd (x y)
+ #!+sb-doc
+ "Changes the cdr of x to y and returns the new x."
+ (rplacd x y))
+
+;;; The following are for use by SETF.
+
+(defun %rplaca (x val) (rplaca x val) val)
+
+(defun %rplacd (x val) (rplacd x val) val)
+
+(defun %setnth (n list newval)
+ (declare (type index n))
+ #!+sb-doc
+ "Sets the Nth element of List (zero based) to Newval."
+ (do ((count n (1- count))
+ (list list (cdr list)))
+ ((endp list)
+ (error "~S is too large an index for SETF of NTH." n))
+ (declare (fixnum count))
+ (when (<= count 0)
+ (rplaca list newval)
+ (return newval))))
+\f
+;;;; :KEY arg optimization to save funcall of IDENTITY
+
+;;; APPLY-KEY saves us a function call sometimes.
+;;; This is not wrapped in an (EVAL-WHEN (COMPILE EVAL) ..)
+;;; because this is used in seq.lisp and sort.lisp.
+(defmacro apply-key (key element)
+ `(if ,key
+ (funcall ,key ,element)
+ ,element))
+
+(defun identity (thing)
+ #!+sb-doc
+ "Returns what was passed to it."
+ thing)
+
+(defun complement (function)
+ #!+sb-doc
+ "Builds a new function that returns T whenever FUNCTION returns NIL and
+ NIL whenever FUNCTION returns T."
+ #'(lambda (&optional (arg0 nil arg0-p) (arg1 nil arg1-p) (arg2 nil arg2-p)
+ &rest more-args)
+ (not (cond (more-args (apply function arg0 arg1 arg2 more-args))
+ (arg2-p (funcall function arg0 arg1 arg2))
+ (arg1-p (funcall function arg0 arg1))
+ (arg0-p (funcall function arg0))
+ (t (funcall function))))))
+
+(defun constantly (value &optional (val1 nil val1-p) (val2 nil val2-p)
+ &rest more-values)
+ #!+sb-doc
+ "Builds a function that always returns VALUE, and posisbly MORE-VALUES."
+ (cond (more-values
+ (let ((list (list* value val1 val2 more-values)))
+ #'(lambda ()
+ (declare (optimize-interface (speed 3) (safety 0)))
+ (values-list list))))
+ (val2-p
+ #'(lambda ()
+ (declare (optimize-interface (speed 3) (safety 0)))
+ (values value val1 val2)))
+ (val1-p
+ #'(lambda ()
+ (declare (optimize-interface (speed 3) (safety 0)))
+ (values value val1)))
+ (t
+ #'(lambda ()
+ (declare (optimize-interface (speed 3) (safety 0)))
+ value))))
+\f
+;;;; macros for (&key (key #'identity) (test #'eql testp) (test-not nil notp)).
+
+;;; Use these with the following keyword args:
+(defmacro with-set-keys (funcall)
+ `(cond ((and testp notp) (error "Test and test-not both supplied."))
+ (notp ,(append funcall '(:key key :test-not test-not)))
+ (t ,(append funcall '(:key key :test test)))))
+
+(defmacro satisfies-the-test (item elt)
+ (let ((key-tmp (gensym)))
+ `(let ((,key-tmp (apply-key key ,elt)))
+ (cond (testp (funcall test ,item ,key-tmp))
+ (notp (not (funcall test-not ,item ,key-tmp)))
+ (t (funcall test ,item ,key-tmp))))))
+\f
+;;;; substitution of expressions
+
+(defun subst (new old tree &key key (test #'eql testp) (test-not nil notp))
+ #!+sb-doc
+ "Substitutes new for subtrees matching old."
+ (labels ((s (subtree)
+ (cond ((satisfies-the-test old subtree) new)
+ ((atom subtree) subtree)
+ (t (let ((car (s (car subtree)))
+ (cdr (s (cdr subtree))))
+ (if (and (eq car (car subtree))
+ (eq cdr (cdr subtree)))
+ subtree
+ (cons car cdr)))))))
+ (s tree)))
+
+(defun subst-if (new test tree &key key)
+ #!+sb-doc
+ "Substitutes new for subtrees for which test is true."
+ (labels ((s (subtree)
+ (cond ((funcall test (apply-key key subtree)) new)
+ ((atom subtree) subtree)
+ (t (let ((car (s (car subtree)))
+ (cdr (s (cdr subtree))))
+ (if (and (eq car (car subtree))
+ (eq cdr (cdr subtree)))
+ subtree
+ (cons car cdr)))))))
+ (s tree)))
+
+(defun subst-if-not (new test tree &key key)
+ #!+sb-doc
+ "Substitutes new for subtrees for which test is false."
+ (labels ((s (subtree)
+ (cond ((not (funcall test (apply-key key subtree))) new)
+ ((atom subtree) subtree)
+ (t (let ((car (s (car subtree)))
+ (cdr (s (cdr subtree))))
+ (if (and (eq car (car subtree))
+ (eq cdr (cdr subtree)))
+ subtree
+ (cons car cdr)))))))
+ (s tree)))
+
+(defun nsubst (new old tree &key key (test #'eql testp) (test-not nil notp))
+ #!+sb-doc
+ "Substitutes new for subtrees matching old."
+ (labels ((s (subtree)
+ (cond ((satisfies-the-test old subtree) new)
+ ((atom subtree) subtree)
+ (t (do* ((last nil subtree)
+ (subtree subtree (Cdr subtree)))
+ ((atom subtree)
+ (if (satisfies-the-test old subtree)
+ (setf (cdr last) new)))
+ (if (satisfies-the-test old subtree)
+ (return (setf (cdr last) new))
+ (setf (car subtree) (s (car subtree)))))
+ subtree))))
+ (s tree)))
+
+(defun nsubst-if (new test tree &key key)
+ #!+sb-doc
+ "Substitutes new for subtrees of tree for which test is true."
+ (labels ((s (subtree)
+ (cond ((funcall test (apply-key key subtree)) new)
+ ((atom subtree) subtree)
+ (t (do* ((last nil subtree)
+ (subtree subtree (Cdr subtree)))
+ ((atom subtree)
+ (if (funcall test (apply-key key subtree))
+ (setf (cdr last) new)))
+ (if (funcall test (apply-key key subtree))
+ (return (setf (cdr last) new))
+ (setf (car subtree) (s (car subtree)))))
+ subtree))))
+ (s tree)))
+
+(defun nsubst-if-not (new test tree &key key)
+ #!+sb-doc
+ "Substitutes new for subtrees of tree for which test is false."
+ (labels ((s (subtree)
+ (cond ((not (funcall test (apply-key key subtree))) new)
+ ((atom subtree) subtree)
+ (t (do* ((last nil subtree)
+ (subtree subtree (Cdr subtree)))
+ ((atom subtree)
+ (if (not (funcall test (apply-key key subtree)))
+ (setf (cdr last) new)))
+ (if (not (funcall test (apply-key key subtree)))
+ (return (setf (cdr last) new))
+ (setf (car subtree) (s (car subtree)))))
+ subtree))))
+ (s tree)))
+\f
+(defun sublis (alist tree &key key (test #'eql) (test-not nil notp))
+ #!+sb-doc
+ "Substitutes from alist into tree nondestructively."
+ (declare (inline assoc))
+ (labels ((s (subtree)
+ (let* ((key-val (apply-key key subtree))
+ (assoc (if notp
+ (assoc key-val alist :test-not test-not)
+ (assoc key-val alist :test test))))
+ (cond (assoc (cdr assoc))
+ ((atom subtree) subtree)
+ (t (let ((car (s (car subtree)))
+ (cdr (s (cdr subtree))))
+ (if (and (eq car (car subtreE))
+ (eq cdr (cdr subtree)))
+ subtree
+ (cons car cdr))))))))
+ (s tree)))
+
+;;; These are in run-time env (i.e. not wrapped in EVAL-WHEN (COMPILE EVAL))
+;;; because they can be referenced in inline expansions.
+(defmacro nsublis-macro ()
+ (let ((key-tmp (gensym)))
+ `(let ((,key-tmp (apply-key key subtree)))
+ (if notp
+ (assoc ,key-tmp alist :test-not test-not)
+ (assoc ,key-tmp alist :test test)))))
+
+(defun nsublis (alist tree &key key (test #'eql) (test-not nil notp))
+ #!+sb-doc
+ "Substitutes new for subtrees matching old."
+ (declare (inline assoc))
+ (let (temp)
+ (labels ((s (subtree)
+ (cond ((Setq temp (nsublis-macro))
+ (cdr temp))
+ ((atom subtree) subtree)
+ (t (do* ((last nil subtree)
+ (subtree subtree (Cdr subtree)))
+ ((atom subtree)
+ (if (setq temp (nsublis-macro))
+ (setf (cdr last) (cdr temp))))
+ (if (setq temp (nsublis-macro))
+ (return (setf (Cdr last) (Cdr temp)))
+ (setf (car subtree) (s (car subtree)))))
+ subtree))))
+ (s tree))))
+\f
+;;;; functions for using lists as sets
+
+(defun member (item list &key key (test #'eql testp) (test-not nil notp))
+ #!+sb-doc
+ "Returns tail of list beginning with first element satisfying EQLity,
+ :test, or :test-not with a given item."
+ (do ((list list (cdr list)))
+ ((null list) nil)
+ (let ((car (car list)))
+ (if (satisfies-the-test item car)
+ (return list)))))
+
+(defun member-if (test list &key key)
+ #!+sb-doc
+ "Returns tail of list beginning with first element satisfying test(element)"
+ (do ((list list (Cdr list)))
+ ((endp list) nil)
+ (if (funcall test (apply-key key (car list)))
+ (return list))))
+
+(defun member-if-not (test list &key key)
+ #!+sb-doc
+ "Returns tail of list beginning with first element not satisfying test(el)"
+ (do ((list list (cdr list)))
+ ((endp list) ())
+ (if (not (funcall test (apply-key key (car list))))
+ (return list))))
+
+(defun tailp (object list)
+ #!+sb-doc
+ "Returns true if Object is the same as some tail of List, otherwise
+ returns false. List must be a proper list or a dotted list."
+ (do ((list list (cdr list)))
+ ((atom list) (eql list object))
+ (if (eql object list)
+ (return t))))
+
+(defun adjoin (item list &key key (test #'eql) (test-not nil notp))
+ #!+sb-doc
+ "Add item to list unless it is already a member"
+ (declare (inline member))
+ (if (let ((key-val (apply-key key item)))
+ (if notp
+ (member key-val list :test-not test-not :key key)
+ (member key-val list :test test :key key)))
+ list
+ (cons item list)))
+
+;;; This function assumes list2 is the result, adding to it from list1 as
+;;; necessary. List2 must initialize the result value, so the call to MEMBER
+;;; will apply the test to the elements from list1 and list2 in the correct
+;;; order.
+(defun union (list1 list2 &key key (test #'eql testp) (test-not nil notp))
+ #!+sb-doc
+ "Returns the union of list1 and list2."
+ (declare (inline member))
+ (when (and testp notp) (error "Test and test-not both supplied."))
+ (let ((res list2))
+ (dolist (elt list1)
+ (unless (with-set-keys (member (apply-key key elt) list2))
+ (push elt res)))
+ res))
+
+;;; Destination and source are setf-able and many-evaluable. Sets the source
+;;; to the cdr, and "conses" the 1st elt of source to destination.
+;;;
+;;; FIXME: needs a more mnemonic name
+(defmacro steve-splice (source destination)
+ `(let ((temp ,source))
+ (setf ,source (cdr ,source)
+ (cdr temp) ,destination
+ ,destination temp)))
+
+(defun nunion (list1 list2 &key key (test #'eql testp) (test-not nil notp))
+ #!+sb-doc
+ "Destructively returns the union list1 and list2."
+ (declare (inline member))
+ (if (and testp notp)
+ (error "Test and test-not both supplied."))
+ (let ((res list2)
+ (list1 list1))
+ (do ()
+ ((endp list1))
+ (if (not (with-set-keys (member (apply-key key (car list1)) list2)))
+ (steve-splice list1 res)
+ (setf list1 (cdr list1))))
+ res))
+
+(defun intersection (list1 list2 &key key
+ (test #'eql testp) (test-not nil notp))
+ #!+sb-doc
+ "Returns the intersection of list1 and list2."
+ (declare (inline member))
+ (if (and testp notp)
+ (error "Test and test-not both supplied."))
+ (let ((res nil))
+ (dolist (elt list1)
+ (if (with-set-keys (member (apply-key key elt) list2))
+ (push elt res)))
+ res))
+
+(defun nintersection (list1 list2 &key key
+ (test #'eql testp) (test-not nil notp))
+ #!+sb-doc
+ "Destructively returns the intersection of list1 and list2."
+ (declare (inline member))
+ (if (and testp notp)
+ (error "Test and test-not both supplied."))
+ (let ((res nil)
+ (list1 list1))
+ (do () ((endp list1))
+ (if (with-set-keys (member (apply-key key (car list1)) list2))
+ (steve-splice list1 res)
+ (setq list1 (Cdr list1))))
+ res))
+
+(defun set-difference (list1 list2 &key key
+ (test #'eql testp) (test-not nil notp))
+ #!+sb-doc
+ "Returns the elements of list1 which are not in list2."
+ (declare (inline member))
+ (if (and testp notp)
+ (error "Test and test-not both supplied."))
+ (if (null list2)
+ list1
+ (let ((res nil))
+ (dolist (elt list1)
+ (if (not (with-set-keys (member (apply-key key elt) list2)))
+ (push elt res)))
+ res)))
+
+(defun nset-difference (list1 list2 &key key
+ (test #'eql testp) (test-not nil notp))
+ #!+sb-doc
+ "Destructively returns the elements of list1 which are not in list2."
+ (declare (inline member))
+ (if (and testp notp)
+ (error "Test and test-not both supplied."))
+ (let ((res nil)
+ (list1 list1))
+ (do () ((endp list1))
+ (if (not (with-set-keys (member (apply-key key (car list1)) list2)))
+ (steve-splice list1 res)
+ (setq list1 (cdr list1))))
+ res))
+
+(defun set-exclusive-or (list1 list2 &key key
+ (test #'eql testp) (test-not nil notp))
+ #!+sb-doc
+ "Returns new list of elements appearing exactly once in list1 and list2."
+ (declare (inline member))
+ (let ((result nil))
+ (dolist (elt list1)
+ (unless (with-set-keys (member (apply-key key elt) list2))
+ (setq result (cons elt result))))
+ (dolist (elt list2)
+ (unless (with-set-keys (member (apply-key key elt) list1))
+ (setq result (cons elt result))))
+ result))
+
+;;; The outer loop examines list1 while the inner loop examines list2. If an
+;;; element is found in list2 "equal" to the element in list1, both are
+;;; spliced out. When the end of list1 is reached, what is left of list2 is
+;;; tacked onto what is left of list1. The splicing operation ensures that
+;;; the correct operation is performed depending on whether splice is at the
+;;; top of the list or not
+
+(defun nset-exclusive-or (list1 list2 &key (test #'eql) (test-not nil notp)
+ key)
+ #!+sb-doc
+ "Destructively return a list with elements which appear but once in list1
+ and list2."
+ (do ((list1 list1)
+ (list2 list2)
+ (x list1 (cdr x))
+ (splicex ()))
+ ((endp x)
+ (if (null splicex)
+ (setq list1 list2)
+ (rplacd splicex list2))
+ list1)
+ (do ((y list2 (cdr y))
+ (splicey ()))
+ ((endp y) (setq splicex x))
+ (cond ((let ((key-val-x (apply-key key (car x)))
+ (key-val-y (apply-key key (Car y))))
+ (if notp
+ (not (funcall test-not key-val-x key-val-y))
+ (funcall test key-val-x key-val-y)))
+ (if (null splicex)
+ (setq list1 (cdr x))
+ (rplacd splicex (cdr x)))
+ (if (null splicey)
+ (setq list2 (cdr y))
+ (rplacd splicey (cdr y)))
+ (return ())) ; assume lists are really sets
+ (t (setq splicey y))))))
+
+(defun subsetp (list1 list2 &key key (test #'eql testp) (test-not nil notp))
+ #!+sb-doc
+ "Returns T if every element in list1 is also in list2."
+ (declare (inline member))
+ (dolist (elt list1)
+ (unless (with-set-keys (member (apply-key key elt) list2))
+ (return-from subsetp nil)))
+ T)
+\f
+;;; functions that operate on association lists
+
+(defun acons (key datum alist)
+ #!+sb-doc
+ "Construct a new alist by adding the pair (key . datum) to alist"
+ (cons (cons key datum) alist))
+
+(defun pairlis (keys data &optional (alist '()))
+ #!+sb-doc
+ "Construct an association list from keys and data (adding to alist)"
+ (do ((x keys (cdr x))
+ (y data (cdr y)))
+ ((and (endp x) (endp y)) alist)
+ (if (or (endp x) (endp y))
+ (error "The lists of keys and data are of unequal length."))
+ (setq alist (acons (car x) (car y) alist))))
+
+;;; This is in the run-time environment (i.e. not wrapped in
+;;; EVAL-WHEN (COMPILE EVAL)) because these guys can be inline
+;;; expanded.
+(defmacro assoc-guts (test-guy)
+ `(do ((alist alist (cdr alist)))
+ ((endp alist))
+ ;; FIXME: would be clearer as (WHEN (AND ..) ..)
+ (if (car alist)
+ (if ,test-guy (return (car alist))))))
+
+(defun assoc (item alist &key key test test-not)
+ #!+sb-doc
+ "Returns the cons in ALIST whose car is equal (by a given test or EQL) to
+ the ITEM."
+ ;; FIXME: Shouldn't there be a check for existence of both TEST and TEST-NOT?
+ (cond (test
+ (if key
+ (assoc-guts (funcall test item (funcall key (caar alist))))
+ (assoc-guts (funcall test item (caar alist)))))
+ (test-not
+ (if key
+ (assoc-guts (not (funcall test-not item
+ (funcall key (caar alist)))))
+ (assoc-guts (not (funcall test-not item (caar alist))))))
+ (t
+ (if key
+ (assoc-guts (eql item (funcall key (caar alist))))
+ (assoc-guts (eql item (caar alist)))))))
+
+(defun assoc-if (predicate alist &key key)
+ #!+sb-doc
+ "Returns the first cons in alist whose car satisfies the Predicate. If
+ key is supplied, apply it to the car of each cons before testing."
+ (if key
+ (assoc-guts (funcall predicate (funcall key (caar alist))))
+ (assoc-guts (funcall predicate (caar alist)))))
+
+(defun assoc-if-not (predicate alist &key key)
+ #!+sb-doc
+ "Returns the first cons in alist whose car does not satisfiy the Predicate.
+ If key is supplied, apply it to the car of each cons before testing."
+ (if key
+ (assoc-guts (not (funcall predicate (funcall key (caar alist)))))
+ (assoc-guts (not (funcall predicate (caar alist))))))
+
+(defun rassoc (item alist &key key test test-not)
+ (declare (list alist))
+ #!+sb-doc
+ "Returns the cons in alist whose cdr is equal (by a given test or EQL) to
+ the Item."
+ (cond (test
+ (if key
+ (assoc-guts (funcall test item (funcall key (cdar alist))))
+ (assoc-guts (funcall test item (cdar alist)))))
+ (test-not
+ (if key
+ (assoc-guts (not (funcall test-not item
+ (funcall key (cdar alist)))))
+ (assoc-guts (not (funcall test-not item (cdar alist))))))
+ (t
+ (if key
+ (assoc-guts (eql item (funcall key (cdar alist))))
+ (assoc-guts (eql item (cdar alist)))))))
+
+(defun rassoc-if (predicate alist &key key)
+ #!+sb-doc
+ "Returns the first cons in alist whose cdr satisfies the Predicate. If key
+ is supplied, apply it to the cdr of each cons before testing."
+ (if key
+ (assoc-guts (funcall predicate (funcall key (cdar alist))))
+ (assoc-guts (funcall predicate (cdar alist)))))
+
+(defun rassoc-if-not (predicate alist &key key)
+ #!+sb-doc
+ "Returns the first cons in alist whose cdr does not satisfy the Predicate.
+ If key is supplied, apply it to the cdr of each cons before testing."
+ (if key
+ (assoc-guts (not (funcall predicate (funcall key (cdar alist)))))
+ (assoc-guts (not (funcall predicate (cdar alist))))))
+\f
+;;;; mapping functions
+
+(defun map1 (function original-arglists accumulate take-car)
+ #!+sb-doc
+ "This function is called by mapc, mapcar, mapcan, mapl, maplist, and mapcon.
+ It Maps function over the arglists in the appropriate way. It is done when any
+ of the arglists runs out. Until then, it CDRs down the arglists calling the
+ function and accumulating results as desired."
+
+ (let* ((arglists (copy-list original-arglists))
+ (ret-list (list nil))
+ (temp ret-list))
+ (do ((res nil)
+ (args '() '()))
+ ((dolist (x arglists nil) (if (null x) (return t)))
+ (if accumulate
+ (cdr ret-list)
+ (car original-arglists)))
+ (do ((l arglists (cdr l)))
+ ((null l))
+ (push (if take-car (caar l) (car l)) args)
+ (setf (car l) (cdar l)))
+ (setq res (apply function (nreverse args)))
+ (case accumulate
+ (:nconc (setq temp (last (nconc temp res))))
+ (:list (rplacd temp (list res))
+ (setq temp (cdr temp)))))))
+
+(defun mapc (function list &rest more-lists)
+ #!+sb-doc
+ "Applies fn to successive elements of lists, returns its second argument."
+ (map1 function (cons list more-lists) nil t))
+
+(defun mapcar (function list &rest more-lists)
+ #!+sb-doc
+ "Applies fn to successive elements of list, returns list of results."
+ (map1 function (cons list more-lists) :list t))
+
+(defun mapcan (function list &rest more-lists)
+ #!+sb-doc
+ "Applies fn to successive elements of list, returns NCONC of results."
+ (map1 function (cons list more-lists) :nconc t))
+
+(defun mapl (function list &rest more-lists)
+ #!+sb-doc
+ "Applies fn to successive CDRs of list, returns ()."
+ (map1 function (cons list more-lists) nil nil))
+
+(defun maplist (function list &rest more-lists)
+ #!+sb-doc
+ "Applies fn to successive CDRs of list, returns list of results."
+ (map1 function (cons list more-lists) :list nil))
+
+(defun mapcon (function list &rest more-lists)
+ #!+sb-doc
+ "Applies fn to successive CDRs of lists, returns NCONC of results."
+ (map1 function (cons list more-lists) :nconc nil))
--- /dev/null
+;;;; parts of the loader which make sense in the cross-compilation
+;;;; host (and which are useful in the host, because they're used by
+;;;; GENESIS)
+;;;;
+;;;; based on the CMU CL load.lisp code, written by Skef Wholey and
+;;;; Rob Maclachlan
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!IMPL")
+
+(file-comment
+ "$Header$")
+\f
+;;;; variables
+
+;;; FIXME: It's awkward having LOAD stuff in SB!IMPL and dump stuff in
+;;; SB!C. Among other things, it makes it hard to figure out where
+;;; *FASL-HEADER-STRING-START-STRING* and
+;;; *FASL-HEADER-STRING-STOP-CHAR-CODE* should go. Perhaps we should
+;;; make a package called SB-DUMP or SB-LD which includes all
+;;; knowledge of both loading and dumping.
+
+;;; This value is used to identify fasl files. Even though this is not
+;;; declared as a constant (because ANSI Common Lisp has no facility
+;;; for declaring values which are constant under EQUAL but not EQL),
+;;; obviously you shouldn't mess with it lightly. If you do set a new
+;;; value for some reason, keep these things in mind:
+;;; * To avoid confusion with the similar but incompatible CMU CL
+;;; fasl file format, the value should not be "FASL FILE", which
+;;; is what CMU CL used for the same purpose.
+;;; * Since its presence at the head of a file is used by LOAD to
+;;; decide whether a file is to be fasloaded or sloloaded, the value
+;;; should be something which can't legally appear at the head of a
+;;; Lisp source file.
+;;; * The value should not contain any line-terminating characters,
+;;; because they're hard to express portably and because the LOAD
+;;; code might reasonably use READ-LINE to get the value to compare
+;;; against.
+(defparameter sb!c:*fasl-header-string-start-string* "# FASL"
+ #!+sb-doc
+ "a string which appears at the start of a fasl file header")
+
+(defparameter sb!c:*fasl-header-string-stop-char-code* 255
+ #!+sb-doc
+ "the code for a character which terminates a fasl file header")
+
+(defvar *load-depth* 0
+ #!+sb-doc
+ "the current number of recursive loads")
+(declaim (type index *load-depth*))
+
+;;; the FASL file we're reading from
+(defvar *fasl-file*)
+(declaim (type lisp-stream fasl-file))
+
+(defvar *load-print* nil
+ #!+sb-doc
+ "the default for the :PRINT argument to LOAD")
+(defvar *load-verbose* nil
+ ;; Note that CMU CL's default for this was T, and ANSI says it's
+ ;; implementation-dependent. We choose NIL on the theory that it's
+ ;; a nicer default behavior for Unix programs.
+ #!+sb-doc
+ "the default for the :VERBOSE argument to LOAD")
+\f
+;;;; miscellaneous load utilities
+
+;;; Output the current number of semicolons after a fresh-line.
+;;; FIXME: non-mnemonic name
+(defun load-fresh-line ()
+ (fresh-line)
+ (let ((semicolons ";;;;;;;;;;;;;;;;"))
+ (do ((count *load-depth* (- count (length semicolons))))
+ ((< count (length semicolons))
+ (write-string semicolons *standard-output* :end count))
+ (declare (fixnum count))
+ (write-string semicolons))
+ (write-char #\space)))
+
+;;; If VERBOSE, output (to *STANDARD-OUTPUT*) a message about how we're
+;;; loading from STREAM-WE-ARE-LOADING-FROM.
+;;; FIXME: non-mnemonic name
+(defun do-load-verbose (stream-we-are-loading-from verbose)
+ (when verbose
+ (load-fresh-line)
+ (let ((name #-sb-xc-host (file-name stream-we-are-loading-from)
+ #+sb-xc-host nil))
+ (if name
+ (format t "loading ~S~%" name)
+ (format t "loading stuff from ~S~%" stream-we-are-loading-from)))))
+\f
+;;;; utilities for reading from fasl files
+
+#!-sb-fluid (declaim (inline read-byte))
+
+;;; Expands into code to read an N-byte unsigned integer using
+;;; fast-read-byte.
+(defmacro fast-read-u-integer (n)
+ (declare (optimize (speed 0)))
+ (do ((res '(fast-read-byte)
+ `(logior (fast-read-byte)
+ (ash ,res 8)))
+ (cnt 1 (1+ cnt)))
+ ((>= cnt n) res)))
+
+;;; Like Fast-Read-U-Integer, but the size may be determined at run time.
+(defmacro fast-read-variable-u-integer (n)
+ (let ((n-pos (gensym))
+ (n-res (gensym))
+ (n-cnt (gensym)))
+ `(do ((,n-pos 8 (+ ,n-pos 8))
+ (,n-cnt (1- ,n) (1- ,n-cnt))
+ (,n-res
+ (fast-read-byte)
+ (dpb (fast-read-byte) (byte 8 ,n-pos) ,n-res)))
+ ((zerop ,n-cnt) ,n-res)
+ (declare (type index ,n-pos ,n-cnt)))))
+
+;;; Read a signed integer.
+(defmacro fast-read-s-integer (n)
+ (declare (optimize (speed 0)))
+ (let ((n-last (gensym)))
+ (do ((res `(let ((,n-last (fast-read-byte)))
+ (if (zerop (logand ,n-last #x80))
+ ,n-last
+ (logior ,n-last #x-100)))
+ `(logior (fast-read-byte)
+ (ash (the (signed-byte ,(* cnt 8)) ,res) 8)))
+ (cnt 1 (1+ cnt)))
+ ((>= cnt n) res))))
+
+;;; Read an N-byte unsigned integer from the *FASL-FILE*
+(defmacro read-arg (n)
+ (declare (optimize (speed 0)))
+ (if (= n 1)
+ `(the (unsigned-byte 8) (read-byte *fasl-file*))
+ `(prepare-for-fast-read-byte *fasl-file*
+ (prog1
+ (fast-read-u-integer ,n)
+ (done-with-fast-read-byte)))))
+;;; FIXME: This deserves a more descriptive name, and should probably
+;;; be implemented as an ordinary function, not a macro.
+;;;
+;;; (for the names: There seem to be only two cases, so it could be
+;;; named READ-U-INTEGER-8 and READ-U-INTEGER-32 or something.)
+\f
+;;;; the fop table
+
+;;; The table is implemented as a simple-vector indexed by the table
+;;; offset. We may need to have several, since LOAD can be called
+;;; recursively.
+
+(defvar *free-fop-tables* (list (make-array 1000))
+ #!+sb-doc
+ "List of free fop tables for the fasloader.")
+
+;;; the current fop table
+(defvar *current-fop-table*)
+(declaim (simple-vector *current-fop-table*))
+
+;;; the length of the current fop table
+(defvar *current-fop-table-size*)
+(declaim (type index *current-fop-table-size*))
+
+;;; the index in the fop-table of the next entry to be used
+(defvar *current-fop-table-index*)
+(declaim (type index *current-fop-table-index*))
+
+(defun grow-fop-table ()
+ (let* ((new-size (* *current-fop-table-size* 2))
+ (new-table (make-array new-size)))
+ (declare (fixnum new-size) (simple-vector new-table))
+ (replace new-table (the simple-vector *current-fop-table*))
+ (setq *current-fop-table* new-table)
+ (setq *current-fop-table-size* new-size)))
+
+(defmacro push-fop-table (thing)
+ (let ((n-index (gensym)))
+ `(let ((,n-index *current-fop-table-index*))
+ (declare (fixnum ,n-index))
+ (when (= ,n-index (the fixnum *current-fop-table-size*))
+ (grow-fop-table))
+ (setq *current-fop-table-index* (1+ ,n-index))
+ (setf (svref *current-fop-table* ,n-index) ,thing))))
+\f
+;;;; the fop stack
+
+;;; (This is in a simple-vector, but it grows down, since it is
+;;; somewhat cheaper to test for overflow that way.)
+(defvar *fop-stack* (make-array 100)
+ #!+sb-doc
+ "The fop stack (we only need one!).")
+(declaim (simple-vector *fop-stack*))
+
+;;; the index of the most recently pushed item on the fop-stack
+(defvar *fop-stack-pointer* 100)
+
+;;; the current index into the fop stack when we last recursively
+;;; entered LOAD
+(defvar *fop-stack-pointer-on-entry*)
+(declaim (type index *fop-stack-pointer* *fop-stack-pointer-on-entry*))
+
+(defun grow-fop-stack ()
+ (let* ((size (length (the simple-vector *fop-stack*)))
+ (new-size (* size 2))
+ (new-stack (make-array new-size)))
+ (declare (fixnum size new-size) (simple-vector new-stack))
+ (replace new-stack (the simple-vector *fop-stack*) :start1 size)
+ (incf *fop-stack-pointer-on-entry* size)
+ (setq *fop-stack-pointer* size)
+ (setq *fop-stack* new-stack)))
+
+;;; Cache information about the fop-stack in local variables. Define a
+;;; local macro to pop from the stack. Push the result of evaluation
+;;; if specified.
+(defmacro with-fop-stack (pushp &body forms)
+ (check-type pushp (member nil t :nope))
+ (let ((n-stack (gensym))
+ (n-index (gensym))
+ (n-res (gensym)))
+ `(let ((,n-stack *fop-stack*)
+ (,n-index *fop-stack-pointer*))
+ (declare (simple-vector ,n-stack) (type index ,n-index))
+ (macrolet ((pop-stack ()
+ `(prog1
+ (svref ,',n-stack ,',n-index)
+ (incf ,',n-index)))
+ (call-with-popped-things (fun n)
+ (let ((n-start (gensym)))
+ `(let ((,n-start (+ ,',n-index ,n)))
+ (declare (type index ,n-start))
+ (setq ,',n-index ,n-start)
+ (,fun ,@(make-list n :initial-element
+ `(svref ,',n-stack
+ (decf ,n-start))))))))
+ ,(if pushp
+ `(let ((,n-res (progn ,@forms)))
+ (when (zerop ,n-index)
+ (grow-fop-stack)
+ (setq ,n-index *fop-stack-pointer*
+ ,n-stack *fop-stack*))
+ (decf ,n-index)
+ (setq *fop-stack-pointer* ,n-index)
+ (setf (svref ,n-stack ,n-index) ,n-res))
+ `(prog1
+ (progn ,@forms)
+ (setq *fop-stack-pointer* ,n-index)))))))
+\f
+;;;; FASLOAD
+;;;;
+;;;; Note: FASLOAD is used not only by LOAD, but also (after suitable
+;;;; modification of the fop table) in genesis. Therefore, it's needed
+;;;; not only in the target Lisp, but also in the cross-compilation
+;;;; host.
+
+;;; a helper function for LOAD-FASL-GROUP
+;;;
+;;; Return true if we successfully read a FASL header from the stream,
+;;; or NIL if EOF was hit before anything was read. Signal an error if
+;;; we encounter garbage.
+(defun check-fasl-header (stream)
+
+ (let ((byte (read-byte stream nil)))
+ (when byte
+
+ ;; Read the string part of the fasl header, or die.
+ (let* ((fhsss sb!c:*fasl-header-string-start-string*)
+ (fhsss-length (length fhsss)))
+ (unless (= byte (char-code (schar fhsss 0)))
+ (error "illegal fasl file header"))
+ (do ((byte (read-byte stream) (read-byte stream))
+ (count 1 (1+ count)))
+ ((= byte sb!c:*fasl-header-string-stop-char-code*)
+ t)
+ (declare (fixnum byte count))
+ (when (and (< count fhsss-length)
+ (not (eql byte (char-code (schar fhsss count)))))
+ (error "illegal fasl file header"))))
+
+ ;; Read and validate implementation and version, or die.
+ (let* ((implementation-length (read-arg 4))
+ (implementation-string (make-string implementation-length))
+ (ignore (read-string-as-bytes stream implementation-string))
+ (implementation (keywordicate implementation-string))
+ ;; FIXME: The logic above to read a keyword from the fasl file
+ ;; could probably be shared with the read-a-keyword fop.
+ (version (read-arg 4)))
+ (declare (ignore ignore))
+ (flet ((check-version (impl vers)
+ (when (string= impl implementation)
+ (unless (= version vers)
+ (error "~S was compiled for fasl file format version ~S, ~
+ but we need version ~S."
+ stream
+ version
+ vers))
+ t)))
+ (or (check-version #.sb!c:*backend-fasl-file-implementation*
+ #.sb!c:*backend-fasl-file-version*)
+ (check-version #.(sb!c:backend-byte-fasl-file-implementation)
+ sb!c:byte-fasl-file-version)
+ (error "~S was compiled for implementation ~A, but this is a ~A."
+ stream
+ implementation
+ sb!c:*backend-fasl-file-implementation*)))))))
+
+;; Setting this variable gives you a trace of fops as they are loaded and
+;; executed.
+#!+sb-show
+(defvar *show-fops-p* nil)
+
+;;; a helper function for FASLOAD
+;;;
+;;; Return true if we successfully load a group from the stream, or NIL if EOF
+;;; was encountered while trying to read from the stream. Dispatch to the right
+;;; function for each fop. Special-case FOP-BYTE-PUSH since it is real common.
+(defun load-fasl-group (stream)
+ (when (check-fasl-header stream)
+ (catch 'fasl-group-end
+ (let ((*current-fop-table-index* 0))
+ (loop
+ (let ((byte (read-byte stream)))
+
+ ;; Do some debugging output.
+ #!+sb-show
+ (when *show-fops-p*
+ (let ((ptr *fop-stack-pointer*)
+ (stack *fop-stack*))
+ (fresh-line *trace-output*)
+ ;; The FOP operations are stack based, so it's sorta
+ ;; logical to display the operand before the operator.
+ ;; ("reverse Polish notation")
+ (unless (= ptr (length stack))
+ (write-char #\space *trace-output*)
+ (prin1 (svref stack ptr) *trace-output*)
+ (terpri *trace-output*))
+ ;; Display the operator.
+ (format *trace-output*
+ "~&~S (#X~X at ~D) (~S)~%"
+ (svref *fop-names* byte)
+ byte
+ (1- (file-position stream))
+ (svref *fop-functions* byte))))
+
+ ;; Actually execute the fop.
+ (if (eql byte 3)
+ ;; FIXME: This is the special case for FOP-BYTE-PUSH.
+ ;; Benchmark to see whether it's really worth special
+ ;; casing it. If it is, at least express the test in
+ ;; terms of a symbolic name for the FOP-BYTE-PUSH code,
+ ;; not a bare '3' (!). Failing that, remove the special
+ ;; case (and the comment at the head of this function
+ ;; which mentions it).
+ (let ((index *fop-stack-pointer*))
+ (declare (type index index))
+ (when (zerop index)
+ (grow-fop-stack)
+ (setq index *fop-stack-pointer*))
+ (decf index)
+ (setq *fop-stack-pointer* index)
+ (setf (svref *fop-stack* index)
+ (svref *current-fop-table* (read-byte stream))))
+ (funcall (the function (svref *fop-functions* byte))))))))))
+
+(defun fasload (stream verbose print)
+ ;; KLUDGE: ANSI says it's good to do something with the :PRINT
+ ;; argument to LOAD when we're fasloading a file, but currently we
+ ;; 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))
+ (when (zerop (file-length stream))
+ (error "attempt to load an empty FASL file:~% ~S" (namestring stream)))
+ (do-load-verbose stream verbose)
+ (let* ((*fasl-file* stream)
+ (*current-fop-table* (or (pop *free-fop-tables*) (make-array 1000)))
+ (*current-fop-table-size* (length *current-fop-table*))
+ (*fop-stack-pointer-on-entry* *fop-stack-pointer*))
+ (unwind-protect
+ ;; FIXME: This should probably become
+ ;; (LOOP WHILE (LOAD-FASL-GROUP-STREAM))
+ ;; but as a LOOP newbie I don't want to do that until I can
+ ;; test it.
+ (do ((loaded-group (load-fasl-group stream) (load-fasl-group stream)))
+ ((not loaded-group)))
+ (setq *fop-stack-pointer* *fop-stack-pointer-on-entry*)
+ (push *current-fop-table* *free-fop-tables*)
+ ;; NIL out the stack and table, so that we don't hold onto garbage.
+ ;;
+ ;; FIXME: Couldn't we just get rid of the free fop table pool so
+ ;; that some of this NILing out would go away?
+ (fill *fop-stack* nil :end *fop-stack-pointer-on-entry*)
+ (fill *current-fop-table* nil)))
+ t)
+\f
+;;;; stuff for debugging/tuning by collecting statistics on FOPs (?)
+
+#|
+(defvar *fop-counts* (make-array 256 :initial-element 0))
+(defvar *fop-times* (make-array 256 :initial-element 0))
+(defvar *print-fops* nil)
+
+(defun clear-counts ()
+ (fill (the simple-vector *fop-counts*) 0)
+ (fill (the simple-vector *fop-times*) 0)
+ t)
+
+(defun analyze-counts ()
+ (let ((counts ())
+ (total-count 0)
+ (times ())
+ (total-time 0))
+ (macrolet ((breakdown (lvar tvar vec)
+ `(progn
+ (dotimes (i 255)
+ (declare (fixnum i))
+ (let ((n (svref ,vec i)))
+ (push (cons (svref *fop-names* i) n) ,lvar)
+ (incf ,tvar n)))
+ (setq ,lvar (subseq (sort ,lvar #'(lambda (x y)
+ (> (cdr x) (cdr y))))
+ 0 10)))))
+
+ (breakdown counts total-count *fop-counts*)
+ (breakdown times total-time *fop-times*)
+ (format t "Total fop count is ~D~%" total-count)
+ (dolist (c counts)
+ (format t "~30S: ~4D~%" (car c) (cdr c)))
+ (format t "~%Total fop time is ~D~%" (/ (float total-time) 60.0))
+ (dolist (m times)
+ (format t "~30S: ~6,2F~%" (car m) (/ (float (cdr m)) 60.0))))))
+|#
+
--- /dev/null
+;;;; the LOOP iteration macro
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+
+;;;; This code was modified by William Harold Newman beginning
+;;;; 19981106, originally to conform to the new SBCL bootstrap package
+;;;; system and then subsequently to address other cross-compiling
+;;;; bootstrap issues. Whether or not it then supported all the
+;;;; environments implied by the reader conditionals in the source
+;;;; code (e.g. #!+CLOE-RUNTIME) before that modification, it sure
+;;;; doesn't now: it might be appropriate for CMU-CL-derived systems
+;;;; in general but only claims to be appropriate for the particular
+;;;; branch I was working on.
+
+;;;; This software is derived from software originally released by the
+;;;; Massachusetts Institute of Technology and Symbolics, Inc. Copyright and
+;;;; release statements follow. Later modifications to the software are in
+;;;; the public domain and are provided with absolutely no warranty. See the
+;;;; COPYING and CREDITS files for more information.
+
+;;;; Portions of LOOP are Copyright (c) 1986 by the Massachusetts Institute
+;;;; of Technology. All Rights Reserved.
+;;;;
+;;;; Permission to use, copy, modify and distribute this software and its
+;;;; documentation for any purpose and without fee is hereby granted,
+;;;; provided that the M.I.T. copyright notice appear in all copies and that
+;;;; both that copyright notice and this permission notice appear in
+;;;; supporting documentation. The names "M.I.T." and "Massachusetts
+;;;; Institute of Technology" may not be used in advertising or publicity
+;;;; pertaining to distribution of the software without specific, written
+;;;; prior permission. Notice must be given in supporting documentation that
+;;;; copying distribution is by permission of M.I.T. M.I.T. makes no
+;;;; representations about the suitability of this software for any purpose.
+;;;; It is provided "as is" without express or implied warranty.
+;;;;
+;;;; Massachusetts Institute of Technology
+;;;; 77 Massachusetts Avenue
+;;;; Cambridge, Massachusetts 02139
+;;;; United States of America
+;;;; +1-617-253-1000
+
+;;;; Portions of LOOP are Copyright (c) 1989, 1990, 1991, 1992 by Symbolics,
+;;;; Inc. All Rights Reserved.
+;;;;
+;;;; Permission to use, copy, modify and distribute this software and its
+;;;; documentation for any purpose and without fee is hereby granted,
+;;;; provided that the Symbolics copyright notice appear in all copies and
+;;;; that both that copyright notice and this permission notice appear in
+;;;; supporting documentation. The name "Symbolics" may not be used in
+;;;; advertising or publicity pertaining to distribution of the software
+;;;; without specific, written prior permission. Notice must be given in
+;;;; supporting documentation that copying distribution is by permission of
+;;;; Symbolics. Symbolics makes no representations about the suitability of
+;;;; this software for any purpose. It is provided "as is" without express
+;;;; or implied warranty.
+;;;;
+;;;; Symbolics, CLOE Runtime, and Minima are trademarks, and CLOE, Genera,
+;;;; and Zetalisp are registered trademarks of Symbolics, Inc.
+;;;;
+;;;; Symbolics, Inc.
+;;;; 8 New England Executive Park, East
+;;;; Burlington, Massachusetts 01803
+;;;; United States of America
+;;;; +1-617-221-1000
+
+(in-package "SB!LOOP")
+
+(sb!int:file-comment
+ "$Header$")
+
+;;;; The design of this LOOP is intended to permit, using mostly the same
+;;;; kernel of code, up to three different "loop" macros:
+;;;;
+;;;; (1) The unextended, unextensible ANSI standard LOOP;
+;;;;
+;;;; (2) A clean "superset" extension of the ANSI LOOP which provides
+;;;; functionality similar to that of the old LOOP, but "in the style of"
+;;;; the ANSI LOOP. For instance, user-definable iteration paths, with a
+;;;; somewhat cleaned-up interface.
+;;;;
+;;;; (3) Extensions provided in another file which can make this LOOP
+;;;; kernel behave largely compatibly with the Genera-vintage LOOP macro,
+;;;; with only a small addition of code (instead of two whole, separate,
+;;;; LOOP macros).
+;;;;
+;;;; Each of the above three LOOP variations can coexist in the same LISP
+;;;; environment.
+;;;;
+;;;; KLUDGE: In SBCL, we only really use variant (1), and any generality
+;;;; for the other variants is wasted. -- WHN 20000121
+
+;;;; FIXME: the STEP-FUNCTION stuff in the code seems to've been
+;;;; intended to support code which was conditionalized with
+;;;; LOOP-PREFER-POP (not true on CMU CL) and which has since been
+;;;; removed. Thus, STEP-FUNCTION stuff could probably be removed too.
+\f
+;;;; miscellaneous environment things
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defvar *loop-real-data-type* 'real))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defvar *loop-gentemp* nil)
+ (defun loop-gentemp (&optional (pref 'loopvar-))
+ (if *loop-gentemp*
+ (gentemp (string pref))
+ (gensym))))
+
+;;; @@@@ The following form takes a list of variables and a form which
+;;; presumably references those variables, and wraps it somehow so that the
+;;; compiler does not consider those variables have been referenced. The intent
+;;; of this is that iteration variables can be flagged as unused by the
+;;; compiler, e.g. I in (loop for i from 1 to 10 do (print t)), since we will
+;;; tell it when a usage of it is "invisible" or "not to be considered".
+;;;
+;;; We implicitly assume that a setq does not count as a reference. That is,
+;;; the kind of form generated for the above loop construct to step I,
+;;; simplified, is
+;;; `(SETQ I ,(HIDE-VARIABLE-REFERENCES '(I) '(1+ I))).
+;;;
+;;; FIXME: This is a no-op except for Genera, now obsolete, so it
+;;; can be removed.
+(defun hide-variable-references (variable-list form)
+ (declare (ignore variable-list))
+ form)
+
+;;; @@@@ The following function takes a flag, a variable, and a form which
+;;; presumably references that variable, and wraps it somehow so that the
+;;; compiler does not consider that variable to have been referenced. The
+;;; intent of this is that iteration variables can be flagged as unused by the
+;;; compiler, e.g. I in (loop for i from 1 to 10 do (print t)), since we will
+;;; tell it when a usage of it is "invisible" or "not to be considered".
+;;;
+;;; We implicitly assume that a setq does not count as a reference. That is,
+;;; the kind of form generated for the above loop construct to step I,
+;;; simplified, is
+;;; `(SETQ I ,(HIDE-VARIABLE-REFERENCES T 'I '(1+ I))).
+;;;
+;;; Certain cases require that the "invisibility" of the reference be
+;;; conditional upon something. This occurs in cases of "named" variables (the
+;;; USING clause). For instance, we want IDX in (LOOP FOR E BEING THE
+;;; VECTOR-ELEMENTS OF V USING (INDEX IDX) ...) to be "invisible" when it is
+;;; stepped, so that the user gets informed if IDX is not referenced. However,
+;;; if no USING clause is present, we definitely do not want to be informed
+;;; that some gensym or other is not used.
+;;;
+;;; It is easier for the caller to do this conditionally by passing a flag
+;;; (which happens to be the second value of NAMED-VARIABLE, q.v.) to this
+;;; function than for all callers to contain the conditional invisibility
+;;; construction.
+;;;
+;;; FIXME: This is a no-op except for Genera, now obsolete, so it
+;;; can be removed.
+(defun hide-variable-reference (really-hide variable form)
+ (declare (ignore really-hide variable))
+ form)
+\f
+;;;; list collection macrology
+
+(sb!kernel: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
+ (&environment env (head-var tail-var &optional user-head-var) form)
+ (setq form (sb!xc:macroexpand form env))
+ (flet ((cdr-wrap (form n)
+ (declare (fixnum n))
+ (do () ((<= n 4) (setq form `(,(case n
+ (1 'cdr)
+ (2 'cddr)
+ (3 'cdddr)
+ (4 'cddddr))
+ ,form)))
+ (setq form `(cddddr ,form) n (- n 4)))))
+ (let ((tail-form form) (ncdrs nil))
+ ;; Determine whether the form being constructed is a list of known
+ ;; length.
+ (when (consp form)
+ (cond ((eq (car form) 'list)
+ (setq ncdrs (1- (length (cdr form)))))
+ ((member (car form) '(list* cons))
+ (when (and (cddr form) (member (car (last form)) '(nil 'nil)))
+ (setq ncdrs (- (length (cdr form)) 2))))))
+ (let ((answer
+ (cond ((null ncdrs)
+ `(when (setf (cdr ,tail-var) ,tail-form)
+ (setq ,tail-var (last (cdr ,tail-var)))))
+ ((< ncdrs 0) (return-from loop-collect-rplacd nil))
+ ((= ncdrs 0)
+ ;; @@@@ Here we have a choice of two idioms:
+ ;; (RPLACD TAIL (SETQ TAIL TAIL-FORM))
+ ;; (SETQ TAIL (SETF (CDR TAIL) TAIL-FORM)).
+ ;; Genera and most others I have seen do better with the
+ ;; former.
+ `(rplacd ,tail-var (setq ,tail-var ,tail-form)))
+ (t `(setq ,tail-var ,(cdr-wrap `(setf (cdr ,tail-var)
+ ,tail-form)
+ ncdrs))))))
+ ;; If not using locatives or something similar to update the
+ ;; user's head variable, we've got to set it... It's harmless
+ ;; to repeatedly set it unconditionally, and probably faster
+ ;; than checking.
+ (when user-head-var
+ (setq answer
+ `(progn ,answer
+ (setq ,user-head-var (cdr ,head-var)))))
+ answer))))
+
+(sb!kernel:defmacro-mundanely loop-collect-answer (head-var
+ &optional user-head-var)
+ (or user-head-var
+ `(cdr ,head-var)))
+\f
+;;;; maximization technology
+
+#|
+The basic idea of all this minimax randomness here is that we have to
+have constructed all uses of maximize and minimize to a particular
+"destination" before we can decide how to code them. The goal is to not
+have to have any kinds of flags, by knowing both that (1) the type is
+something which we can provide an initial minimum or maximum value for
+and (2) know that a MAXIMIZE and MINIMIZE are not being combined.
+
+SO, we have a datastructure which we annotate with all sorts of things,
+incrementally updating it as we generate loop body code, and then use
+a wrapper and internal macros to do the coding when the loop has been
+constructed.
+|#
+
+(defstruct (loop-minimax
+ (:constructor make-loop-minimax-internal)
+ (:copier nil)
+ (:predicate nil))
+ answer-variable
+ type
+ temp-variable
+ flag-variable
+ operations
+ infinity-data)
+
+(defvar *loop-minimax-type-infinities-alist*
+ ;; Note: In the portable loop.lisp, this had various
+ ;; conditional-on-*FEATURES* cases to support machines which had true
+ ;; floating infinity. Now that we're limited to CMU CL, this is irrelevant.
+ ;; FIXME: Or is it? What if we ever support infinity? Perhaps we should
+ ;; put in something conditional on SB-INFINITY or something?
+ '((fixnum most-positive-fixnum most-negative-fixnum)))
+
+(defun make-loop-minimax (answer-variable type)
+ (let ((infinity-data (cdr (assoc type
+ *loop-minimax-type-infinities-alist*
+ :test #'subtypep))))
+ (make-loop-minimax-internal
+ :answer-variable answer-variable
+ :type type
+ :temp-variable (loop-gentemp 'loop-maxmin-temp-)
+ :flag-variable (and (not infinity-data)
+ (loop-gentemp 'loop-maxmin-flag-))
+ :operations nil
+ :infinity-data infinity-data)))
+
+(defun loop-note-minimax-operation (operation minimax)
+ (pushnew (the symbol operation) (loop-minimax-operations minimax))
+ (when (and (cdr (loop-minimax-operations minimax))
+ (not (loop-minimax-flag-variable minimax)))
+ (setf (loop-minimax-flag-variable minimax)
+ (loop-gentemp 'loop-maxmin-flag-)))
+ operation)
+
+(sb!kernel: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))
+ (answer-var (loop-minimax-answer-variable lm))
+ (temp-var (loop-minimax-temp-variable lm))
+ (flag-var (loop-minimax-flag-variable lm))
+ (type (loop-minimax-type lm)))
+ (if flag-var
+ `(let ((,answer-var ,init) (,temp-var ,init) (,flag-var nil))
+ (declare (type ,type ,answer-var ,temp-var))
+ ,@body)
+ `(let ((,answer-var ,(if (eq which 'min)
+ (first infinity-data)
+ (second infinity-data)))
+ (,temp-var ,init))
+ (declare (type ,type ,answer-var ,temp-var))
+ ,@body))))
+
+(sb!kernel: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))
+ (test
+ (hide-variable-reference
+ t (loop-minimax-answer-variable lm)
+ `(,(ecase operation
+ (min '<)
+ (max '>))
+ ,temp-var ,answer-var))))
+ `(progn
+ (setq ,temp-var ,form)
+ (when ,(if flag-var `(or (not ,flag-var) ,test) test)
+ (setq ,@(and flag-var `(,flag-var t))
+ ,answer-var ,temp-var)))))
+\f
+;;;; LOOP keyword tables
+
+#|
+LOOP keyword tables are hash tables string keys and a test of EQUAL.
+
+The actual descriptive/dispatch structure used by LOOP is called a "loop
+universe" contains a few tables and parameterizations. The basic idea is
+that we can provide a non-extensible ANSI-compatible loop environment,
+an extensible ANSI-superset loop environment, and (for such environments
+as CLOE) one which is "sufficiently close" to the old Genera-vintage
+LOOP for use by old user programs without requiring all of the old LOOP
+code to be loaded.
+|#
+
+;;;; token hackery
+
+;;; Compare two "tokens". The first is the frob out of *LOOP-SOURCE-CODE*,
+;;; the second a symbol to check against.
+(defun loop-tequal (x1 x2)
+ (and (symbolp x1) (string= x1 x2)))
+
+(defun loop-tassoc (kwd alist)
+ (and (symbolp kwd) (assoc kwd alist :test #'string=)))
+
+(defun loop-tmember (kwd list)
+ (and (symbolp kwd) (member kwd list :test #'string=)))
+
+(defun loop-lookup-keyword (loop-token table)
+ (and (symbolp loop-token)
+ (values (gethash (symbol-name loop-token) table))))
+
+(sb!kernel:defmacro-mundanely loop-store-table-data (symbol table datum)
+ `(setf (gethash (symbol-name ,symbol) ,table) ,datum))
+
+(defstruct (loop-universe
+ (:copier nil)
+ (:predicate nil))
+ keywords ; hash table, value = (fn-name . extra-data)
+ iteration-keywords ; hash table, value = (fn-name . extra-data)
+ for-keywords ; hash table, value = (fn-name . extra-data)
+ path-keywords ; hash table, value = (fn-name . extra-data)
+ type-symbols ; hash table of type SYMBOLS, test EQ,
+ ; value = CL type specifier
+ type-keywords ; hash table of type STRINGS, test EQUAL,
+ ; value = CL type spec
+ ansi ; NIL, T, or :EXTENDED
+ implicit-for-required) ; see loop-hack-iteration
+(sb!int:def!method print-object ((u loop-universe) stream)
+ (let ((string (case (loop-universe-ansi u)
+ ((nil) "Non-ANSI")
+ ((t) "ANSI")
+ (:extended "Extended-ANSI")
+ (t (loop-universe-ansi u)))))
+ (print-unreadable-object (u stream :type t)
+ (write-string string stream))))
+
+;;; This is the "current" loop context in use when we are expanding a
+;;; loop. It gets bound on each invocation of LOOP.
+(defvar *loop-universe*)
+
+(defun make-standard-loop-universe (&key keywords for-keywords
+ iteration-keywords path-keywords
+ type-keywords type-symbols ansi)
+ (check-type ansi (member nil t :extended))
+ (flet ((maketable (entries)
+ (let* ((size (length entries))
+ (ht (make-hash-table :size (if (< size 10) 10 size)
+ :test 'equal)))
+ (dolist (x entries)
+ (setf (gethash (symbol-name (car x)) ht) (cadr x)))
+ ht)))
+ (make-loop-universe
+ :keywords (maketable keywords)
+ :for-keywords (maketable for-keywords)
+ :iteration-keywords (maketable iteration-keywords)
+ :path-keywords (maketable path-keywords)
+ :ansi ansi
+ :implicit-for-required (not (null ansi))
+ :type-keywords (maketable type-keywords)
+ :type-symbols (let* ((size (length type-symbols))
+ (ht (make-hash-table :size (if (< size 10) 10 size)
+ :test 'eq)))
+ (dolist (x type-symbols)
+ (if (atom x)
+ (setf (gethash x ht) x)
+ (setf (gethash (car x) ht) (cadr x))))
+ ht))))
+\f
+;;;; SETQ hackery
+
+(defvar *loop-destructuring-hooks*
+ nil
+ #!+sb-doc
+ "If not NIL, this must be a list of two things:
+a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring.")
+
+(defun loop-make-psetq (frobs)
+ (and frobs
+ (loop-make-desetq
+ (list (car frobs)
+ (if (null (cddr frobs)) (cadr frobs)
+ `(prog1 ,(cadr frobs)
+ ,(loop-make-psetq (cddr frobs))))))))
+
+(defun loop-make-desetq (var-val-pairs)
+ (if (null var-val-pairs)
+ nil
+ (cons (if *loop-destructuring-hooks*
+ (cadr *loop-destructuring-hooks*)
+ 'loop-really-desetq)
+ var-val-pairs)))
+
+(defvar *loop-desetq-temporary*
+ (make-symbol "LOOP-DESETQ-TEMP"))
+
+(sb!kernel: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
+ ;; recurse if the list element is itself a list
+ (do ((tail var)) ((not (consp tail)) tail)
+ (when (find-non-null (pop tail)) (return t))))
+ (loop-desetq-internal (var val &optional temp)
+ ;; returns a list of actions to be performed
+ (typecase var
+ (null
+ (when (consp val)
+ ;; don't lose possible side-effects
+ (if (eq (car val) 'prog1)
+ ;; these can come from psetq or desetq below.
+ ;; throw away the value, keep the side-effects.
+ ;;Special case is for handling an expanded POP.
+ (mapcan #'(lambda (x)
+ (and (consp x)
+ (or (not (eq (car x) 'car))
+ (not (symbolp (cadr x)))
+ (not (symbolp (setq x (sb!xc:macroexpand x env)))))
+ (cons x nil)))
+ (cdr val))
+ `(,val))))
+ (cons
+ (let* ((car (car var))
+ (cdr (cdr var))
+ (car-non-null (find-non-null car))
+ (cdr-non-null (find-non-null cdr)))
+ (when (or car-non-null cdr-non-null)
+ (if cdr-non-null
+ (let* ((temp-p temp)
+ (temp (or temp *loop-desetq-temporary*))
+ (body `(,@(loop-desetq-internal car
+ `(car ,temp))
+ (setq ,temp (cdr ,temp))
+ ,@(loop-desetq-internal cdr
+ temp
+ temp))))
+ (if temp-p
+ `(,@(unless (eq temp val)
+ `((setq ,temp ,val)))
+ ,@body)
+ `((let ((,temp ,val))
+ ,@body))))
+ ;; no cdring to do
+ (loop-desetq-internal car `(car ,val) temp)))))
+ (otherwise
+ (unless (eq var val)
+ `((setq ,var ,val)))))))
+ (do ((actions))
+ ((null var-val-pairs)
+ (if (null (cdr actions)) (car actions) `(progn ,@(nreverse actions))))
+ (setq actions (revappend
+ (loop-desetq-internal (pop var-val-pairs)
+ (pop var-val-pairs))
+ actions)))))
+\f
+;;;; LOOP-local variables
+
+;;;This is the "current" pointer into the LOOP source code.
+(defvar *loop-source-code*)
+
+;;;This is the pointer to the original, for things like NAMED that
+;;;insist on being in a particular position
+(defvar *loop-original-source-code*)
+
+;;;This is *loop-source-code* as of the "last" clause. It is used
+;;;primarily for generating error messages (see loop-error, loop-warn).
+(defvar *loop-source-context*)
+
+;;;List of names for the LOOP, supplied by the NAMED clause.
+(defvar *loop-names*)
+
+;;;The macroexpansion environment given to the macro.
+(defvar *loop-macro-environment*)
+
+;;;This holds variable names specified with the USING clause.
+;;; See LOOP-NAMED-VARIABLE.
+(defvar *loop-named-variables*)
+
+;;; LETlist-like list being accumulated for one group of parallel bindings.
+(defvar *loop-variables*)
+
+;;;List of declarations being accumulated in parallel with
+;;;*loop-variables*.
+(defvar *loop-declarations*)
+
+;;;Used by LOOP for destructuring binding, if it is doing that itself.
+;;; See loop-make-variable.
+(defvar *loop-desetq-crocks*)
+
+;;; List of wrapping forms, innermost first, which go immediately inside
+;;; the current set of parallel bindings being accumulated in
+;;; *loop-variables*. The wrappers are appended onto a body. E.g.,
+;;; this list could conceivably has as its value ((with-open-file (g0001
+;;; g0002 ...))), with g0002 being one of the bindings in
+;;; *loop-variables* (this is why the wrappers go inside of the variable
+;;; bindings).
+(defvar *loop-wrappers*)
+
+;;;This accumulates lists of previous values of *loop-variables* and the
+;;;other lists above, for each new nesting of bindings. See
+;;;loop-bind-block.
+(defvar *loop-bind-stack*)
+
+;;;This is a LOOP-global variable for the (obsolete) NODECLARE clause
+;;;which inhibits LOOP from actually outputting a type declaration for
+;;;an iteration (or any) variable.
+(defvar *loop-nodeclare*)
+
+;;;This is simply a list of LOOP iteration variables, used for checking
+;;;for duplications.
+(defvar *loop-iteration-variables*)
+
+;;;List of prologue forms of the loop, accumulated in reverse order.
+(defvar *loop-prologue*)
+
+(defvar *loop-before-loop*)
+(defvar *loop-body*)
+(defvar *loop-after-body*)
+
+;;;This is T if we have emitted any body code, so that iteration driving
+;;;clauses can be disallowed. This is not strictly the same as
+;;;checking *loop-body*, because we permit some clauses such as RETURN
+;;;to not be considered "real" body (so as to permit the user to "code"
+;;;an abnormal return value "in loop").
+(defvar *loop-emitted-body*)
+
+;;;List of epilogue forms (supplied by FINALLY generally), accumulated
+;;; in reverse order.
+(defvar *loop-epilogue*)
+
+;;;List of epilogue forms which are supplied after the above "user"
+;;;epilogue. "normal" termination return values are provide by putting
+;;;the return form in here. Normally this is done using
+;;;loop-emit-final-value, q.v.
+(defvar *loop-after-epilogue*)
+
+;;;The "culprit" responsible for supplying a final value from the loop.
+;;;This is so loop-emit-final-value can moan about multiple return
+;;;values being supplied.
+(defvar *loop-final-value-culprit*)
+
+;;;If not NIL, we are in some branch of a conditional. Some clauses may
+;;;be disallowed.
+(defvar *loop-inside-conditional*)
+
+;;;If not NIL, this is a temporary bound around the loop for holding the
+;;;temporary value for "it" in things like "when (f) collect it". It
+;;;may be used as a supertemporary by some other things.
+(defvar *loop-when-it-variable*)
+
+;;;Sometimes we decide we need to fold together parts of the loop, but
+;;;some part of the generated iteration code is different for the first
+;;;and remaining iterations. This variable will be the temporary which
+;;;is the flag used in the loop to tell whether we are in the first or
+;;;remaining iterations.
+(defvar *loop-never-stepped-variable*)
+
+;;;List of all the value-accumulation descriptor structures in the loop.
+;;; See loop-get-collection-info.
+(defvar *loop-collection-cruft*) ; for multiple COLLECTs (etc)
+\f
+;;;; code analysis stuff
+
+(defun loop-constant-fold-if-possible (form &optional expected-type)
+ (let ((new-form form) (constantp nil) (constant-value nil))
+ (when (setq constantp (constantp new-form))
+ (setq constant-value (eval new-form)))
+ (when (and constantp expected-type)
+ (unless (typep constant-value expected-type)
+ (loop-warn "The form ~S evaluated to ~S, which was not of the anticipated type ~S."
+ form constant-value expected-type)
+ (setq constantp nil constant-value nil)))
+ (values new-form constantp constant-value)))
+
+(defun loop-constantp (form)
+ (constantp form))
+\f
+;;;; LOOP iteration optimization
+
+(defvar *loop-duplicate-code*
+ nil)
+
+(defvar *loop-iteration-flag-variable*
+ (make-symbol "LOOP-NOT-FIRST-TIME"))
+
+(defun loop-code-duplication-threshold (env)
+ (declare (ignore env))
+ (let (;; If we could read optimization declaration information (as with
+ ;; the DECLARATION-INFORMATION function (present in CLTL2, removed
+ ;; from ANSI standard) we could set these values flexibly. Without
+ ;; DECLARATION-INFORMATION, we have to set them to constants.
+ (speed 1)
+ (space 1))
+ (+ 40 (* (- speed space) 10))))
+
+(sb!kernel:defmacro-mundanely loop-body (&environment env
+ prologue
+ before-loop
+ main-body
+ after-loop
+ epilogue
+ &aux rbefore rafter flagvar)
+ (unless (= (length before-loop) (length after-loop))
+ (error "LOOP-BODY called with non-synched before- and after-loop lists"))
+ ;;All our work is done from these copies, working backwards from the end:
+ (setq rbefore (reverse before-loop) rafter (reverse after-loop))
+ (labels ((psimp (l)
+ (let ((ans nil))
+ (dolist (x l)
+ (when x
+ (push x ans)
+ (when (and (consp x)
+ (member (car x) '(go return return-from)))
+ (return nil))))
+ (nreverse ans)))
+ (pify (l) (if (null (cdr l)) (car l) `(progn ,@l)))
+ (makebody ()
+ (let ((form `(tagbody
+ ,@(psimp (append prologue (nreverse rbefore)))
+ next-loop
+ ,@(psimp (append main-body
+ (nreconc rafter
+ `((go next-loop)))))
+ end-loop
+ ,@(psimp epilogue))))
+ (if flagvar `(let ((,flagvar nil)) ,form) form))))
+ (when (or *loop-duplicate-code* (not rbefore))
+ (return-from loop-body (makebody)))
+ ;; This outer loop iterates once for each not-first-time flag test
+ ;; generated plus once more for the forms that don't need a flag test
+ (do ((threshold (loop-code-duplication-threshold env))) (nil)
+ (declare (fixnum threshold))
+ ;; Go backwards from the ends of before-loop and after-loop merging all
+ ;; the equivalent forms into the body.
+ (do () ((or (null rbefore) (not (equal (car rbefore) (car rafter)))))
+ (push (pop rbefore) main-body)
+ (pop rafter))
+ (unless rbefore (return (makebody)))
+ ;; The first forms in rbefore & rafter (which are the chronologically
+ ;; last forms in the list) differ, therefore they cannot be moved
+ ;; into the main body. If everything that chronologically precedes
+ ;; them either differs or is equal but is okay to duplicate, we can
+ ;; just put all of rbefore in the prologue and all of rafter after
+ ;; the body. Otherwise, there is something that is not okay to
+ ;; duplicate, so it and everything chronologically after it in
+ ;; rbefore and rafter must go into the body, with a flag test to
+ ;; distinguish the first time around the loop from later times.
+ ;; What chronologically precedes the non-duplicatable form will
+ ;; be handled the next time around the outer loop.
+ (do ((bb rbefore (cdr bb))
+ (aa rafter (cdr aa))
+ (lastdiff nil)
+ (count 0)
+ (inc nil))
+ ((null bb) (return-from loop-body (makebody))) ; Did it.
+ (cond ((not (equal (car bb) (car aa))) (setq lastdiff bb count 0))
+ ((or (not (setq inc (estimate-code-size (car bb) env)))
+ (> (incf count inc) threshold))
+ ;; Ok, we have found a non-duplicatable piece of code.
+ ;; Everything chronologically after it must be in the central
+ ;; body. Everything chronologically at and after lastdiff goes
+ ;; into the central body under a flag test.
+ (let ((then nil) (else nil))
+ (do () (nil)
+ (push (pop rbefore) else)
+ (push (pop rafter) then)
+ (when (eq rbefore (cdr lastdiff)) (return)))
+ (unless flagvar
+ (push `(setq ,(setq flagvar *loop-iteration-flag-variable*)
+ t)
+ else))
+ (push `(if ,flagvar ,(pify (psimp then)) ,(pify (psimp else)))
+ main-body))
+ ;; Everything chronologically before lastdiff until the
+ ;; non-duplicatable form (car bb) is the same in rbefore and
+ ;; rafter so just copy it into the body
+ (do () (nil)
+ (pop rafter)
+ (push (pop rbefore) main-body)
+ (when (eq rbefore (cdr bb)) (return)))
+ (return)))))))
+\f
+(defun duplicatable-code-p (expr env)
+ (if (null expr) 0
+ (let ((ans (estimate-code-size expr env)))
+ (declare (fixnum ans))
+ ;; @@@@ Use (DECLARATION-INFORMATION 'OPTIMIZE ENV) here to get an
+ ;; alist of optimize quantities back to help quantify how much code we
+ ;; are willing to duplicate.
+ ans)))
+
+(defvar *special-code-sizes*
+ '((return 0) (progn 0)
+ (null 1) (not 1) (eq 1) (car 1) (cdr 1)
+ (when 1) (unless 1) (if 1)
+ (caar 2) (cadr 2) (cdar 2) (cddr 2)
+ (caaar 3) (caadr 3) (cadar 3) (caddr 3)
+ (cdaar 3) (cdadr 3) (cddar 3) (cdddr 3)
+ (caaaar 4) (caaadr 4) (caadar 4) (caaddr 4)
+ (cadaar 4) (cadadr 4) (caddar 4) (cadddr 4)
+ (cdaaar 4) (cdaadr 4) (cdadar 4) (cdaddr 4)
+ (cddaar 4) (cddadr 4) (cdddar 4) (cddddr 4)))
+
+(defvar *estimate-code-size-punt*
+ '(block
+ do do* dolist
+ flet
+ labels lambda let let* locally
+ macrolet multiple-value-bind
+ prog prog*
+ symbol-macrolet
+ tagbody
+ unwind-protect
+ with-open-file))
+
+(defun destructuring-size (x)
+ (do ((x x (cdr x)) (n 0 (+ (destructuring-size (car x)) n)))
+ ((atom x) (+ n (if (null x) 0 1)))))
+
+(defun estimate-code-size (x env)
+ (catch 'estimate-code-size
+ (estimate-code-size-1 x env)))
+
+(defun estimate-code-size-1 (x env)
+ (flet ((list-size (l)
+ (let ((n 0))
+ (declare (fixnum n))
+ (dolist (x l n) (incf n (estimate-code-size-1 x env))))))
+ ;;@@@@ ???? (declare (function list-size (list) fixnum))
+ (cond ((constantp x) 1)
+ ((symbolp x) (multiple-value-bind (new-form expanded-p)
+ (sb!xc:macroexpand-1 x env)
+ (if expanded-p
+ (estimate-code-size-1 new-form env)
+ 1)))
+ ((atom x) 1) ;; ??? self-evaluating???
+ ((symbolp (car x))
+ (let ((fn (car x)) (tem nil) (n 0))
+ (declare (symbol fn) (fixnum n))
+ (macrolet ((f (overhead &optional (args nil args-p))
+ `(the fixnum (+ (the fixnum ,overhead)
+ (the fixnum
+ (list-size ,(if args-p
+ args
+ '(cdr x))))))))
+ (cond ((setq tem (get fn 'estimate-code-size))
+ (typecase tem
+ (fixnum (f tem))
+ (t (funcall tem x env))))
+ ((setq tem (assoc fn *special-code-sizes*))
+ (f (second tem)))
+ ((eq fn 'cond)
+ (dolist (clause (cdr x) n)
+ (incf n (list-size clause)) (incf n)))
+ ((eq fn 'desetq)
+ (do ((l (cdr x) (cdr l))) ((null l) n)
+ (setq n (+ n
+ (destructuring-size (car l))
+ (estimate-code-size-1 (cadr l) env)))))
+ ((member fn '(setq psetq))
+ (do ((l (cdr x) (cdr l))) ((null l) n)
+ (setq n (+ n (estimate-code-size-1 (cadr l) env) 1))))
+ ((eq fn 'go) 1)
+ ((eq fn 'function)
+ ;; This skirts the issue of implementationally-defined
+ ;; lambda macros by recognizing CL function names and
+ ;; nothing else.
+ (if (or (symbolp (cadr x))
+ (and (consp (cadr x)) (eq (caadr x) 'setf)))
+ 1
+ (throw 'duplicatable-code-p nil)))
+ ((eq fn 'multiple-value-setq)
+ (f (length (second x)) (cddr x)))
+ ((eq fn 'return-from)
+ (1+ (estimate-code-size-1 (third x) env)))
+ ((or (special-operator-p fn)
+ (member fn *estimate-code-size-punt*))
+ (throw 'estimate-code-size nil))
+ (t (multiple-value-bind (new-form expanded-p)
+ (sb!xc:macroexpand-1 x env)
+ (if expanded-p
+ (estimate-code-size-1 new-form env)
+ (f 3))))))))
+ (t (throw 'estimate-code-size nil)))))
+\f
+;;;; loop errors
+
+(defun loop-context ()
+ (do ((l *loop-source-context* (cdr l)) (new nil (cons (car l) new)))
+ ((eq l (cdr *loop-source-code*)) (nreverse new))))
+
+(defun loop-error (format-string &rest format-args)
+ (error "~?~%current LOOP context:~{ ~S~}."
+ format-string
+ format-args
+ (loop-context)))
+
+(defun loop-warn (format-string &rest format-args)
+ (warn "~?~%current LOOP context:~{ ~S~}."
+ format-string
+ format-args
+ (loop-context)))
+
+(defun loop-check-data-type (specified-type required-type
+ &optional (default-type required-type))
+ (if (null specified-type)
+ default-type
+ (multiple-value-bind (a b) (subtypep specified-type required-type)
+ (cond ((not b)
+ (loop-warn "LOOP couldn't verify that ~S is a subtype of the required type ~S."
+ specified-type required-type))
+ ((not a)
+ (loop-error "The specified data type ~S is not a subtype of ~S."
+ specified-type required-type)))
+ specified-type)))
+\f
+(defun loop-translate (*loop-source-code*
+ *loop-macro-environment*
+ *loop-universe*)
+ (let ((*loop-original-source-code* *loop-source-code*)
+ (*loop-source-context* nil)
+ (*loop-iteration-variables* nil)
+ (*loop-variables* nil)
+ (*loop-nodeclare* nil)
+ (*loop-named-variables* nil)
+ (*loop-declarations* nil)
+ (*loop-desetq-crocks* nil)
+ (*loop-bind-stack* nil)
+ (*loop-prologue* nil)
+ (*loop-wrappers* nil)
+ (*loop-before-loop* nil)
+ (*loop-body* nil)
+ (*loop-emitted-body* nil)
+ (*loop-after-body* nil)
+ (*loop-epilogue* nil)
+ (*loop-after-epilogue* nil)
+ (*loop-final-value-culprit* nil)
+ (*loop-inside-conditional* nil)
+ (*loop-when-it-variable* nil)
+ (*loop-never-stepped-variable* nil)
+ (*loop-names* nil)
+ (*loop-collection-cruft* nil))
+ (loop-iteration-driver)
+ (loop-bind-block)
+ (let ((answer `(loop-body
+ ,(nreverse *loop-prologue*)
+ ,(nreverse *loop-before-loop*)
+ ,(nreverse *loop-body*)
+ ,(nreverse *loop-after-body*)
+ ,(nreconc *loop-epilogue*
+ (nreverse *loop-after-epilogue*)))))
+ (do () (nil)
+ (setq answer `(block ,(pop *loop-names*) ,answer))
+ (unless *loop-names* (return nil)))
+ (dolist (entry *loop-bind-stack*)
+ (let ((vars (first entry))
+ (dcls (second entry))
+ (crocks (third entry))
+ (wrappers (fourth entry)))
+ (dolist (w wrappers)
+ (setq answer (append w (list answer))))
+ (when (or vars dcls crocks)
+ (let ((forms (list answer)))
+ ;;(when crocks (push crocks forms))
+ (when dcls (push `(declare ,@dcls) forms))
+ (setq answer `(,(cond ((not vars) 'locally)
+ (*loop-destructuring-hooks*
+ (first *loop-destructuring-hooks*))
+ (t
+ 'let))
+ ,vars
+ ,@(if crocks
+ `((destructuring-bind ,@crocks
+ ,@forms))
+ forms)))))))
+ answer)))
+
+(defun loop-iteration-driver ()
+ (do () ((null *loop-source-code*))
+ (let ((keyword (car *loop-source-code*)) (tem nil))
+ (cond ((not (symbolp keyword))
+ (loop-error "~S found where LOOP keyword expected" keyword))
+ (t (setq *loop-source-context* *loop-source-code*)
+ (loop-pop-source)
+ (cond ((setq tem
+ (loop-lookup-keyword keyword
+ (loop-universe-keywords
+ *loop-universe*)))
+ ;; It's a "miscellaneous" toplevel LOOP keyword (do,
+ ;; collect, named, etc.)
+ (apply (symbol-function (first tem)) (rest tem)))
+ ((setq tem
+ (loop-lookup-keyword keyword
+ (loop-universe-iteration-keywords *loop-universe*)))
+ (loop-hack-iteration tem))
+ ((loop-tmember keyword '(and else))
+ ;; Alternative is to ignore it, ie let it go around to
+ ;; the next keyword...
+ (loop-error "secondary clause misplaced at top level in LOOP macro: ~S ~S ~S ..."
+ keyword
+ (car *loop-source-code*)
+ (cadr *loop-source-code*)))
+ (t (loop-error "unknown LOOP keyword: ~S" keyword))))))))
+\f
+(defun loop-pop-source ()
+ (if *loop-source-code*
+ (pop *loop-source-code*)
+ (loop-error "LOOP source code ran out when another token was expected.")))
+
+(defun loop-get-progn ()
+ (do ((forms (list (loop-pop-source)) (cons (loop-pop-source) forms))
+ (nextform (car *loop-source-code*) (car *loop-source-code*)))
+ ((atom nextform)
+ (if (null (cdr forms)) (car forms) (cons 'progn (nreverse forms))))))
+
+(defun loop-get-form ()
+ (if *loop-source-code*
+ (loop-pop-source)
+ (loop-error "LOOP code ran out where a form was expected.")))
+
+(defun loop-construct-return (form)
+ `(return-from ,(car *loop-names*) ,form))
+
+(defun loop-pseudo-body (form)
+ (cond ((or *loop-emitted-body* *loop-inside-conditional*)
+ (push form *loop-body*))
+ (t (push form *loop-before-loop*) (push form *loop-after-body*))))
+
+(defun loop-emit-body (form)
+ (setq *loop-emitted-body* t)
+ (loop-pseudo-body form))
+
+(defun loop-emit-final-value (form)
+ (push (loop-construct-return form) *loop-after-epilogue*)
+ (when *loop-final-value-culprit*
+ (loop-warn "The LOOP clause is providing a value for the iteration,~@
+ however one was already established by a ~S clause."
+ *loop-final-value-culprit*))
+ (setq *loop-final-value-culprit* (car *loop-source-context*)))
+
+(defun loop-disallow-conditional (&optional kwd)
+ (when *loop-inside-conditional*
+ (loop-error "~:[This LOOP~;The LOOP ~:*~S~] clause is not permitted inside a conditional." kwd)))
+\f
+;;;; loop types
+
+(defun loop-typed-init (data-type)
+ (when (and data-type (subtypep data-type 'number))
+ (if (or (subtypep data-type 'float) (subtypep data-type '(complex float)))
+ (coerce 0 data-type)
+ 0)))
+
+(defun loop-optional-type (&optional variable)
+ ;; No variable specified implies that no destructuring is permissible.
+ (and *loop-source-code* ; Don't get confused by NILs..
+ (let ((z (car *loop-source-code*)))
+ (cond ((loop-tequal z 'of-type)
+ ;; This is the syntactically unambigous form in that the form
+ ;; of the type specifier does not matter. Also, it is assumed
+ ;; that the type specifier is unambiguously, and without need
+ ;; of translation, a common lisp type specifier or pattern
+ ;; (matching the variable) thereof.
+ (loop-pop-source)
+ (loop-pop-source))
+
+ ((symbolp z)
+ ;; This is the (sort of) "old" syntax, even though we didn't
+ ;; used to support all of these type symbols.
+ (let ((type-spec (or (gethash z
+ (loop-universe-type-symbols
+ *loop-universe*))
+ (gethash (symbol-name z)
+ (loop-universe-type-keywords
+ *loop-universe*)))))
+ (when type-spec
+ (loop-pop-source)
+ type-spec)))
+ (t
+ ;; This is our sort-of old syntax. But this is only valid for
+ ;; when we are destructuring, so we will be compulsive (should
+ ;; we really be?) and require that we in fact be doing variable
+ ;; destructuring here. We must translate the old keyword
+ ;; pattern typespec into a fully-specified pattern of real type
+ ;; specifiers here.
+ (if (consp variable)
+ (unless (consp z)
+ (loop-error
+ "~S found where a LOOP keyword, LOOP type keyword, or LOOP type pattern expected"
+ z))
+ (loop-error "~S found where a LOOP keyword or LOOP type keyword expected" z))
+ (loop-pop-source)
+ (labels ((translate (k v)
+ (cond ((null k) nil)
+ ((atom k)
+ (replicate
+ (or (gethash k
+ (loop-universe-type-symbols
+ *loop-universe*))
+ (gethash (symbol-name k)
+ (loop-universe-type-keywords
+ *loop-universe*))
+ (loop-error
+ "The destructuring type pattern ~S contains the unrecognized type keyword ~S."
+ z k))
+ v))
+ ((atom v)
+ (loop-error
+ "The destructuring type pattern ~S doesn't match the variable pattern ~S."
+ z variable))
+ (t (cons (translate (car k) (car v))
+ (translate (cdr k) (cdr v))))))
+ (replicate (typ v)
+ (if (atom v)
+ typ
+ (cons (replicate typ (car v))
+ (replicate typ (cdr v))))))
+ (translate z variable)))))))
+\f
+;;;; loop variables
+
+(defun loop-bind-block ()
+ (when (or *loop-variables* *loop-declarations* *loop-wrappers*)
+ (push (list (nreverse *loop-variables*)
+ *loop-declarations*
+ *loop-desetq-crocks*
+ *loop-wrappers*)
+ *loop-bind-stack*)
+ (setq *loop-variables* nil
+ *loop-declarations* nil
+ *loop-desetq-crocks* nil
+ *loop-wrappers* nil)))
+
+(defun loop-make-variable (name initialization dtype
+ &optional iteration-variable-p)
+ (cond ((null name)
+ (cond ((not (null initialization))
+ (push (list (setq name (loop-gentemp 'loop-ignore-))
+ initialization)
+ *loop-variables*)
+ (push `(ignore ,name) *loop-declarations*))))
+ ((atom name)
+ (cond (iteration-variable-p
+ (if (member name *loop-iteration-variables*)
+ (loop-error "duplicated LOOP iteration variable ~S" name)
+ (push name *loop-iteration-variables*)))
+ ((assoc name *loop-variables*)
+ (loop-error "duplicated variable ~S in LOOP parallel binding"
+ name)))
+ (unless (symbolp name)
+ (loop-error "bad variable ~S somewhere in LOOP" name))
+ (loop-declare-variable name dtype)
+ ;; We use ASSOC on this list to check for duplications (above),
+ ;; so don't optimize out this list:
+ (push (list name (or initialization (loop-typed-init dtype)))
+ *loop-variables*))
+ (initialization
+ (cond (*loop-destructuring-hooks*
+ (loop-declare-variable name dtype)
+ (push (list name initialization) *loop-variables*))
+ (t (let ((newvar (loop-gentemp 'loop-destructure-)))
+ (push (list newvar initialization) *loop-variables*)
+ ;; *LOOP-DESETQ-CROCKS* gathered in reverse order.
+ (setq *loop-desetq-crocks*
+ (list* name newvar *loop-desetq-crocks*))
+ ;; FIXME: We can delete this, right?
+ #+ignore
+ (loop-make-variable name
+ nil
+ dtype
+ iteration-variable-p)))))
+ (t (let ((tcar nil) (tcdr nil))
+ (if (atom dtype) (setq tcar (setq tcdr dtype))
+ (setq tcar (car dtype) tcdr (cdr dtype)))
+ (loop-make-variable (car name) nil tcar iteration-variable-p)
+ (loop-make-variable (cdr name) nil tcdr iteration-variable-p))))
+ name)
+
+(defun loop-make-iteration-variable (name initialization dtype)
+ (loop-make-variable name initialization dtype t))
+
+(defun loop-declare-variable (name dtype)
+ (cond ((or (null name) (null dtype) (eq dtype t)) nil)
+ ((symbolp name)
+ (unless (or (eq dtype t) (member (the symbol name) *loop-nodeclare*))
+ (let ((dtype (let ((init (loop-typed-init dtype)))
+ (if (typep init dtype)
+ dtype
+ `(or (member ,init) ,dtype)))))
+ (push `(type ,dtype ,name) *loop-declarations*))))
+ ((consp name)
+ (cond ((consp dtype)
+ (loop-declare-variable (car name) (car dtype))
+ (loop-declare-variable (cdr name) (cdr dtype)))
+ (t (loop-declare-variable (car name) dtype)
+ (loop-declare-variable (cdr name) dtype))))
+ (t (error "invalid LOOP variable passed in: ~S" name))))
+
+(defun loop-maybe-bind-form (form data-type)
+ (if (loop-constantp form)
+ form
+ (loop-make-variable (loop-gentemp 'loop-bind-) form data-type)))
+\f
+(defun loop-do-if (for negatep)
+ (let ((form (loop-get-form)) (*loop-inside-conditional* t) (it-p nil))
+ (flet ((get-clause (for)
+ (do ((body nil)) (nil)
+ (let ((key (car *loop-source-code*)) (*loop-body* nil) data)
+ (cond ((not (symbolp key))
+ (loop-error
+ "~S found where keyword expected getting LOOP clause after ~S"
+ key for))
+ (t (setq *loop-source-context* *loop-source-code*)
+ (loop-pop-source)
+ (when (loop-tequal (car *loop-source-code*) 'it)
+ (setq *loop-source-code*
+ (cons (or it-p
+ (setq it-p
+ (loop-when-it-variable)))
+ (cdr *loop-source-code*))))
+ (cond ((or (not (setq data (loop-lookup-keyword
+ key (loop-universe-keywords *loop-universe*))))
+ (progn (apply (symbol-function (car data))
+ (cdr data))
+ (null *loop-body*)))
+ (loop-error
+ "~S does not introduce a LOOP clause that can follow ~S."
+ key for))
+ (t (setq body (nreconc *loop-body* body)))))))
+ (if (loop-tequal (car *loop-source-code*) :and)
+ (loop-pop-source)
+ (return (if (cdr body)
+ `(progn ,@(nreverse body))
+ (car body)))))))
+ (let ((then (get-clause for))
+ (else (when (loop-tequal (car *loop-source-code*) :else)
+ (loop-pop-source)
+ (list (get-clause :else)))))
+ (when (loop-tequal (car *loop-source-code*) :end)
+ (loop-pop-source))
+ (when it-p (setq form `(setq ,it-p ,form)))
+ (loop-pseudo-body
+ `(if ,(if negatep `(not ,form) form)
+ ,then
+ ,@else))))))
+
+(defun loop-do-initially ()
+ (loop-disallow-conditional :initially)
+ (push (loop-get-progn) *loop-prologue*))
+
+(defun loop-do-finally ()
+ (loop-disallow-conditional :finally)
+ (push (loop-get-progn) *loop-epilogue*))
+
+(defun loop-do-do ()
+ (loop-emit-body (loop-get-progn)))
+
+(defun loop-do-named ()
+ (let ((name (loop-pop-source)))
+ (unless (symbolp name)
+ (loop-error "~S is an invalid name for your LOOP" name))
+ (when (or *loop-before-loop* *loop-body* *loop-after-epilogue* *loop-inside-conditional*)
+ (loop-error "The NAMED ~S clause occurs too late." name))
+ (when *loop-names*
+ (loop-error "You may only use one NAMED clause in your loop: NAMED ~S ... NAMED ~S."
+ (car *loop-names*) name))
+ (setq *loop-names* (list name nil))))
+
+(defun loop-do-return ()
+ (loop-pseudo-body (loop-construct-return (loop-get-form))))
+\f
+;;;; value accumulation: LIST
+
+(defstruct (loop-collector
+ (:copier nil)
+ (:predicate nil))
+ name
+ class
+ (history nil)
+ (tempvars nil)
+ dtype
+ (data nil)) ;collector-specific data
+
+(defun loop-get-collection-info (collector class default-type)
+ (let ((form (loop-get-form))
+ (dtype (and (not (loop-universe-ansi *loop-universe*)) (loop-optional-type)))
+ (name (when (loop-tequal (car *loop-source-code*) 'into)
+ (loop-pop-source)
+ (loop-pop-source))))
+ (when (not (symbolp name))
+ (loop-error "The value accumulation recipient name, ~S, is not a symbol." name))
+ (unless dtype
+ (setq dtype (or (loop-optional-type) default-type)))
+ (let ((cruft (find (the symbol name) *loop-collection-cruft*
+ :key #'loop-collector-name)))
+ (cond ((not cruft)
+ (push (setq cruft (make-loop-collector
+ :name name :class class
+ :history (list collector) :dtype dtype))
+ *loop-collection-cruft*))
+ (t (unless (eq (loop-collector-class cruft) class)
+ (loop-error
+ "incompatible kinds of LOOP value accumulation specified for collecting~@
+ ~:[as the value of the LOOP~;~:*INTO ~S~]: ~S and ~S"
+ name (car (loop-collector-history cruft)) collector))
+ (unless (equal dtype (loop-collector-dtype cruft))
+ (loop-warn
+ "unequal datatypes specified in different LOOP value accumulations~@
+ into ~S: ~S and ~S"
+ name dtype (loop-collector-dtype cruft))
+ (when (eq (loop-collector-dtype cruft) t)
+ (setf (loop-collector-dtype cruft) dtype)))
+ (push collector (loop-collector-history cruft))))
+ (values cruft form))))
+
+(defun loop-list-collection (specifically) ; NCONC, LIST, or APPEND
+ (multiple-value-bind (lc form)
+ (loop-get-collection-info specifically 'list 'list)
+ (let ((tempvars (loop-collector-tempvars lc)))
+ (unless tempvars
+ (setf (loop-collector-tempvars lc)
+ (setq tempvars (list* (loop-gentemp 'loop-list-head-)
+ (loop-gentemp 'loop-list-tail-)
+ (and (loop-collector-name lc)
+ (list (loop-collector-name lc))))))
+ (push `(with-loop-list-collection-head ,tempvars) *loop-wrappers*)
+ (unless (loop-collector-name lc)
+ (loop-emit-final-value `(loop-collect-answer ,(car tempvars)
+ ,@(cddr tempvars)))))
+ (ecase specifically
+ (list (setq form `(list ,form)))
+ (nconc nil)
+ (append (unless (and (consp form) (eq (car form) 'list))
+ (setq form `(copy-list ,form)))))
+ (loop-emit-body `(loop-collect-rplacd ,tempvars ,form)))))
+\f
+;;;; value accumulation: MAX, MIN, SUM, COUNT
+
+(defun loop-sum-collection (specifically required-type default-type);SUM, COUNT
+ (multiple-value-bind (lc form)
+ (loop-get-collection-info specifically 'sum default-type)
+ (loop-check-data-type (loop-collector-dtype lc) required-type)
+ (let ((tempvars (loop-collector-tempvars lc)))
+ (unless tempvars
+ (setf (loop-collector-tempvars lc)
+ (setq tempvars (list (loop-make-variable
+ (or (loop-collector-name lc)
+ (loop-gentemp 'loop-sum-))
+ nil (loop-collector-dtype lc)))))
+ (unless (loop-collector-name lc)
+ (loop-emit-final-value (car (loop-collector-tempvars lc)))))
+ (loop-emit-body
+ (if (eq specifically 'count)
+ `(when ,form
+ (setq ,(car tempvars)
+ ,(hide-variable-reference t
+ (car tempvars)
+ `(1+ ,(car tempvars)))))
+ `(setq ,(car tempvars)
+ (+ ,(hide-variable-reference t
+ (car tempvars)
+ (car tempvars))
+ ,form)))))))
+
+(defun loop-maxmin-collection (specifically)
+ (multiple-value-bind (lc form)
+ (loop-get-collection-info specifically 'maxmin *loop-real-data-type*)
+ (loop-check-data-type (loop-collector-dtype lc) *loop-real-data-type*)
+ (let ((data (loop-collector-data lc)))
+ (unless data
+ (setf (loop-collector-data lc)
+ (setq data (make-loop-minimax
+ (or (loop-collector-name lc)
+ (loop-gentemp 'loop-maxmin-))
+ (loop-collector-dtype lc))))
+ (unless (loop-collector-name lc)
+ (loop-emit-final-value (loop-minimax-answer-variable data))))
+ (loop-note-minimax-operation specifically data)
+ (push `(with-minimax-value ,data) *loop-wrappers*)
+ (loop-emit-body `(loop-accumulate-minimax-value ,data
+ ,specifically
+ ,form)))))
+\f
+;;;; value accumulation: aggregate booleans
+
+;;; ALWAYS and NEVER
+;;;
+;;; Under ANSI these are not permitted to appear under conditionalization.
+(defun loop-do-always (restrictive negate)
+ (let ((form (loop-get-form)))
+ (when restrictive (loop-disallow-conditional))
+ (loop-emit-body `(,(if negate 'when 'unless) ,form
+ ,(loop-construct-return nil)))
+ (loop-emit-final-value t)))
+
+;;; THEREIS
+;;;
+;;; Under ANSI this is not permitted to appear under conditionalization.
+(defun loop-do-thereis (restrictive)
+ (when restrictive (loop-disallow-conditional))
+ (loop-emit-body `(when (setq ,(loop-when-it-variable) ,(loop-get-form))
+ ,(loop-construct-return *loop-when-it-variable*))))
+\f
+(defun loop-do-while (negate kwd &aux (form (loop-get-form)))
+ (loop-disallow-conditional kwd)
+ (loop-pseudo-body `(,(if negate 'when 'unless) ,form (go end-loop))))
+
+(defun loop-do-with ()
+ (loop-disallow-conditional :with)
+ (do ((var) (val) (dtype)) (nil)
+ (setq var (loop-pop-source)
+ dtype (loop-optional-type var)
+ val (cond ((loop-tequal (car *loop-source-code*) :=)
+ (loop-pop-source)
+ (loop-get-form))
+ (t nil)))
+ (loop-make-variable var val dtype)
+ (if (loop-tequal (car *loop-source-code*) :and)
+ (loop-pop-source)
+ (return (loop-bind-block)))))
+\f
+;;;; the iteration driver
+
+(defun loop-hack-iteration (entry)
+ (flet ((make-endtest (list-of-forms)
+ (cond ((null list-of-forms) nil)
+ ((member t list-of-forms) '(go end-loop))
+ (t `(when ,(if (null (cdr (setq list-of-forms
+ (nreverse list-of-forms))))
+ (car list-of-forms)
+ (cons 'or list-of-forms))
+ (go end-loop))))))
+ (do ((pre-step-tests nil)
+ (steps nil)
+ (post-step-tests nil)
+ (pseudo-steps nil)
+ (pre-loop-pre-step-tests nil)
+ (pre-loop-steps nil)
+ (pre-loop-post-step-tests nil)
+ (pre-loop-pseudo-steps nil)
+ (tem) (data))
+ (nil)
+ ;; Note that we collect endtests in reverse order, but steps in correct
+ ;; order. MAKE-ENDTEST does the nreverse for us.
+ (setq tem (setq data
+ (apply (symbol-function (first entry)) (rest entry))))
+ (and (car tem) (push (car tem) pre-step-tests))
+ (setq steps (nconc steps (copy-list (car (setq tem (cdr tem))))))
+ (and (car (setq tem (cdr tem))) (push (car tem) post-step-tests))
+ (setq pseudo-steps
+ (nconc pseudo-steps (copy-list (car (setq tem (cdr tem))))))
+ (setq tem (cdr tem))
+ (when *loop-emitted-body*
+ (loop-error "iteration in LOOP follows body code"))
+ (unless tem (setq tem data))
+ (when (car tem) (push (car tem) pre-loop-pre-step-tests))
+ ;; FIXME: This (SETF FOO (NCONC FOO BAR)) idiom appears often enough
+ ;; that it might be worth making it into an NCONCF macro.
+ (setq pre-loop-steps
+ (nconc pre-loop-steps (copy-list (car (setq tem (cdr tem))))))
+ (when (car (setq tem (cdr tem)))
+ (push (car tem) pre-loop-post-step-tests))
+ (setq pre-loop-pseudo-steps
+ (nconc pre-loop-pseudo-steps (copy-list (cadr tem))))
+ (unless (loop-tequal (car *loop-source-code*) :and)
+ (setq *loop-before-loop*
+ (list* (loop-make-desetq pre-loop-pseudo-steps)
+ (make-endtest pre-loop-post-step-tests)
+ (loop-make-psetq pre-loop-steps)
+ (make-endtest pre-loop-pre-step-tests)
+ *loop-before-loop*))
+ (setq *loop-after-body*
+ (list* (loop-make-desetq pseudo-steps)
+ (make-endtest post-step-tests)
+ (loop-make-psetq steps)
+ (make-endtest pre-step-tests)
+ *loop-after-body*))
+ (loop-bind-block)
+ (return nil))
+ (loop-pop-source) ; Flush the "AND".
+ (when (and (not (loop-universe-implicit-for-required *loop-universe*))
+ (setq tem
+ (loop-lookup-keyword
+ (car *loop-source-code*)
+ (loop-universe-iteration-keywords *loop-universe*))))
+ ;; The latest ANSI clarification is that the FOR/AS after the AND must
+ ;; NOT be supplied.
+ (loop-pop-source)
+ (setq entry tem)))))
+\f
+;;;; main iteration drivers
+
+;;; FOR variable keyword ..args..
+(defun loop-do-for ()
+ (let* ((var (loop-pop-source))
+ (data-type (loop-optional-type var))
+ (keyword (loop-pop-source))
+ (first-arg nil)
+ (tem nil))
+ (setq first-arg (loop-get-form))
+ (unless (and (symbolp keyword)
+ (setq tem (loop-lookup-keyword
+ keyword
+ (loop-universe-for-keywords *loop-universe*))))
+ (loop-error "~S is an unknown keyword in FOR or AS clause in LOOP."
+ keyword))
+ (apply (car tem) var first-arg data-type (cdr tem))))
+
+(defun loop-do-repeat ()
+ (let ((form (loop-get-form))
+ (type (loop-check-data-type (loop-optional-type)
+ *loop-real-data-type*)))
+ (when (and (consp form) (eq (car form) 'the) (subtypep (second form) type))
+ (setq type (second form)))
+ (multiple-value-bind (number constantp value)
+ (loop-constant-fold-if-possible form type)
+ (cond ((and constantp (<= value 1)) `(t () () () ,(<= value 0) () () ()))
+ (t (let ((var (loop-make-variable (loop-gentemp 'loop-repeat-)
+ number
+ type)))
+ (if constantp
+ `((not (plusp (setq ,var (1- ,var))))
+ () () () () () () ())
+ `((minusp (setq ,var (1- ,var)))
+ () () ()))))))))
+
+(defun loop-when-it-variable ()
+ (or *loop-when-it-variable*
+ (setq *loop-when-it-variable*
+ (loop-make-variable (loop-gentemp 'loop-it-) nil nil))))
+\f
+;;;; various FOR/AS subdispatches
+
+;;; ANSI "FOR x = y [THEN z]" is sort of like the old Genera one when the THEN
+;;; is omitted (other than being more stringent in its placement), and like the
+;;; old "FOR x FIRST y THEN z" when the THEN is present. I.e., the first
+;;; initialization occurs in the loop body (first-step), not in the variable
+;;; binding phase.
+(defun loop-ansi-for-equals (var val data-type)
+ (loop-make-iteration-variable var nil data-type)
+ (cond ((loop-tequal (car *loop-source-code*) :then)
+ ;; Then we are the same as "FOR x FIRST y THEN z".
+ (loop-pop-source)
+ `(() (,var ,(loop-get-form)) () ()
+ () (,var ,val) () ()))
+ (t ;; We are the same as "FOR x = y".
+ `(() (,var ,val) () ()))))
+
+(defun loop-for-across (var val data-type)
+ (loop-make-iteration-variable var nil data-type)
+ (let ((vector-var (loop-gentemp 'loop-across-vector-))
+ (index-var (loop-gentemp 'loop-across-index-)))
+ (multiple-value-bind (vector-form constantp vector-value)
+ (loop-constant-fold-if-possible val 'vector)
+ (loop-make-variable
+ vector-var vector-form
+ (if (and (consp vector-form) (eq (car vector-form) 'the))
+ (cadr vector-form)
+ 'vector))
+ (loop-make-variable index-var 0 'fixnum)
+ (let* ((length 0)
+ (length-form (cond ((not constantp)
+ (let ((v (loop-gentemp 'loop-across-limit-)))
+ (push `(setq ,v (length ,vector-var))
+ *loop-prologue*)
+ (loop-make-variable v 0 'fixnum)))
+ (t (setq length (length vector-value)))))
+ (first-test `(>= ,index-var ,length-form))
+ (other-test first-test)
+ (step `(,var (aref ,vector-var ,index-var)))
+ (pstep `(,index-var (1+ ,index-var))))
+ (declare (fixnum length))
+ (when constantp
+ (setq first-test (= length 0))
+ (when (<= length 1)
+ (setq other-test t)))
+ `(,other-test ,step () ,pstep
+ ,@(and (not (eq first-test other-test))
+ `(,first-test ,step () ,pstep)))))))
+\f
+;;;; list iteration
+
+(defun loop-list-step (listvar)
+ ;; We are not equipped to analyze whether 'FOO is the same as #'FOO here in
+ ;; any sensible fashion, so let's give an obnoxious warning whenever 'FOO is
+ ;; used as the stepping function.
+ ;;
+ ;; While a Discerning Compiler may deal intelligently with
+ ;; (FUNCALL 'FOO ...), not recognizing FOO may defeat some LOOP
+ ;; optimizations.
+ (let ((stepper (cond ((loop-tequal (car *loop-source-code*) :by)
+ (loop-pop-source)
+ (loop-get-form))
+ (t '(function cdr)))))
+ (cond ((and (consp stepper) (eq (car stepper) 'quote))
+ (loop-warn "Use of QUOTE around stepping function in LOOP will be left verbatim.")
+ `(funcall ,stepper ,listvar))
+ ((and (consp stepper) (eq (car stepper) 'function))
+ (list (cadr stepper) listvar))
+ (t
+ `(funcall ,(loop-make-variable (loop-gentemp 'loop-fn-)
+ stepper
+ 'function)
+ ,listvar)))))
+
+(defun loop-for-on (var val data-type)
+ (multiple-value-bind (list constantp list-value)
+ (loop-constant-fold-if-possible val)
+ (let ((listvar var))
+ (cond ((and var (symbolp var))
+ (loop-make-iteration-variable var list data-type))
+ (t (loop-make-variable (setq listvar (loop-gentemp)) list 'list)
+ (loop-make-iteration-variable var nil data-type)))
+ (let ((list-step (loop-list-step listvar)))
+ (let* ((first-endtest
+ (hide-variable-reference
+ (eq var listvar)
+ listvar
+ ;; the following should use `atom' instead of `endp', per
+ ;; [bug2428]
+ `(atom ,listvar)))
+ (other-endtest first-endtest))
+ (when (and constantp (listp list-value))
+ (setq first-endtest (null list-value)))
+ (cond ((eq var listvar)
+ ;; Contour of the loop is different because we use the user's
+ ;; variable...
+ `(() (,listvar ,(hide-variable-reference t listvar list-step))
+ ,other-endtest () () () ,first-endtest ()))
+ (t (let ((step `(,var ,listvar))
+ (pseudo `(,listvar ,list-step)))
+ `(,other-endtest ,step () ,pseudo
+ ,@(and (not (eq first-endtest other-endtest))
+ `(,first-endtest ,step () ,pseudo)))))))))))
+
+(defun loop-for-in (var val data-type)
+ (multiple-value-bind (list constantp list-value)
+ (loop-constant-fold-if-possible val)
+ (let ((listvar (loop-gentemp 'loop-list-)))
+ (loop-make-iteration-variable var nil data-type)
+ (loop-make-variable listvar list 'list)
+ (let ((list-step (loop-list-step listvar)))
+ (let* ((first-endtest `(endp ,listvar))
+ (other-endtest first-endtest)
+ (step `(,var (car ,listvar)))
+ (pseudo-step `(,listvar ,list-step)))
+ (when (and constantp (listp list-value))
+ (setq first-endtest (null list-value)))
+ `(,other-endtest ,step () ,pseudo-step
+ ,@(and (not (eq first-endtest other-endtest))
+ `(,first-endtest ,step () ,pseudo-step))))))))
+\f
+;;;; iteration paths
+
+(defstruct (loop-path
+ (:copier nil)
+ (:predicate nil))
+ names
+ preposition-groups
+ inclusive-permitted
+ function
+ user-data)
+
+(defun add-loop-path (names function universe
+ &key preposition-groups inclusive-permitted user-data)
+ (unless (listp names) (setq names (list names)))
+ (check-type universe loop-universe)
+ (let ((ht (loop-universe-path-keywords universe))
+ (lp (make-loop-path
+ :names (mapcar #'symbol-name names)
+ :function function
+ :user-data user-data
+ :preposition-groups (mapcar (lambda (x)
+ (if (listp x) x (list x)))
+ preposition-groups)
+ :inclusive-permitted inclusive-permitted)))
+ (dolist (name names)
+ (setf (gethash (symbol-name name) ht) lp))
+ lp))
+\f
+;;; Note: path functions are allowed to use loop-make-variable, hack
+;;; the prologue, etc.
+(defun loop-for-being (var val data-type)
+ ;; FOR var BEING each/the pathname prep-phrases using-stuff... each/the =
+ ;; EACH or THE. Not clear if it is optional, so I guess we'll warn.
+ (let ((path nil)
+ (data nil)
+ (inclusive nil)
+ (stuff nil)
+ (initial-prepositions nil))
+ (cond ((loop-tmember val '(:each :the)) (setq path (loop-pop-source)))
+ ((loop-tequal (car *loop-source-code*) :and)
+ (loop-pop-source)
+ (setq inclusive t)
+ (unless (loop-tmember (car *loop-source-code*)
+ '(:its :each :his :her))
+ (loop-error "~S was found where ITS or EACH expected in LOOP iteration path syntax."
+ (car *loop-source-code*)))
+ (loop-pop-source)
+ (setq path (loop-pop-source))
+ (setq initial-prepositions `((:in ,val))))
+ (t (loop-error "unrecognizable LOOP iteration path syntax: missing EACH or THE?")))
+ (cond ((not (symbolp path))
+ (loop-error
+ "~S was found where a LOOP iteration path name was expected."
+ path))
+ ((not (setq data (loop-lookup-keyword path (loop-universe-path-keywords *loop-universe*))))
+ (loop-error "~S is not the name of a LOOP iteration path." path))
+ ((and inclusive (not (loop-path-inclusive-permitted data)))
+ (loop-error "\"Inclusive\" iteration is not possible with the ~S LOOP iteration path." path)))
+ (let ((fun (loop-path-function data))
+ (preps (nconc initial-prepositions
+ (loop-collect-prepositional-phrases
+ (loop-path-preposition-groups data)
+ t)))
+ (user-data (loop-path-user-data data)))
+ (when (symbolp fun) (setq fun (symbol-function fun)))
+ (setq stuff (if inclusive
+ (apply fun var data-type preps :inclusive t user-data)
+ (apply fun var data-type preps user-data))))
+ (when *loop-named-variables*
+ (loop-error "Unused USING variables: ~S." *loop-named-variables*))
+ ;; STUFF is now (bindings prologue-forms . stuff-to-pass-back). Protect the
+ ;; system from the user and the user from himself.
+ (unless (member (length stuff) '(6 10))
+ (loop-error "Value passed back by LOOP iteration path function for path ~S has invalid length."
+ path))
+ (do ((l (car stuff) (cdr l)) (x)) ((null l))
+ (if (atom (setq x (car l)))
+ (loop-make-iteration-variable x nil nil)
+ (loop-make-iteration-variable (car x) (cadr x) (caddr x))))
+ (setq *loop-prologue* (nconc (reverse (cadr stuff)) *loop-prologue*))
+ (cddr stuff)))
+\f
+(defun named-variable (name)
+ (let ((tem (loop-tassoc name *loop-named-variables*)))
+ (declare (list tem))
+ (cond ((null tem) (values (loop-gentemp) nil))
+ (t (setq *loop-named-variables* (delete tem *loop-named-variables*))
+ (values (cdr tem) t)))))
+
+(defun loop-collect-prepositional-phrases (preposition-groups
+ &optional
+ USING-allowed
+ initial-phrases)
+ (flet ((in-group-p (x group) (car (loop-tmember x group))))
+ (do ((token nil)
+ (prepositional-phrases initial-phrases)
+ (this-group nil nil)
+ (this-prep nil nil)
+ (disallowed-prepositions
+ (mapcan #'(lambda (x)
+ (copy-list
+ (find (car x) preposition-groups :test #'in-group-p)))
+ initial-phrases))
+ (used-prepositions (mapcar #'car initial-phrases)))
+ ((null *loop-source-code*) (nreverse prepositional-phrases))
+ (declare (symbol this-prep))
+ (setq token (car *loop-source-code*))
+ (dolist (group preposition-groups)
+ (when (setq this-prep (in-group-p token group))
+ (return (setq this-group group))))
+ (cond (this-group
+ (when (member this-prep disallowed-prepositions)
+ (loop-error
+ (if (member this-prep used-prepositions)
+ "A ~S prepositional phrase occurs multiply for some LOOP clause."
+ "Preposition ~S was used when some other preposition has subsumed it.")
+ token))
+ (setq used-prepositions (if (listp this-group)
+ (append this-group used-prepositions)
+ (cons this-group used-prepositions)))
+ (loop-pop-source)
+ (push (list this-prep (loop-get-form)) prepositional-phrases))
+ ((and USING-allowed (loop-tequal token 'using))
+ (loop-pop-source)
+ (do ((z (loop-pop-source) (loop-pop-source)) (tem)) (nil)
+ (when (or (atom z)
+ (atom (cdr z))
+ (not (null (cddr z)))
+ (not (symbolp (car z)))
+ (and (cadr z) (not (symbolp (cadr z)))))
+ (loop-error "~S bad variable pair in path USING phrase" z))
+ (when (cadr z)
+ (if (setq tem (loop-tassoc (car z) *loop-named-variables*))
+ (loop-error
+ "The variable substitution for ~S occurs twice in a USING phrase,~@
+ with ~S and ~S."
+ (car z) (cadr z) (cadr tem))
+ (push (cons (car z) (cadr z)) *loop-named-variables*)))
+ (when (or (null *loop-source-code*)
+ (symbolp (car *loop-source-code*)))
+ (return nil))))
+ (t (return (nreverse prepositional-phrases)))))))
+\f
+;;;; master sequencer function
+
+(defun loop-sequencer (indexv indexv-type indexv-user-specified-p
+ variable variable-type
+ sequence-variable sequence-type
+ step-hack default-top
+ prep-phrases)
+ (let ((endform nil) ; Form (constant or variable) with limit value
+ (sequencep nil) ; T if sequence arg has been provided
+ (testfn nil) ; endtest function
+ (test nil) ; endtest form
+ (stepby (1+ (or (loop-typed-init indexv-type) 0))) ; our increment
+ (stepby-constantp t)
+ (step nil) ; step form
+ (dir nil) ; direction of stepping: NIL, :UP, :DOWN
+ (inclusive-iteration nil) ; T if include last index
+ (start-given nil) ; T when prep phrase has specified start
+ (start-value nil)
+ (start-constantp nil)
+ (limit-given nil) ; T when prep phrase has specified end
+ (limit-constantp nil)
+ (limit-value nil)
+ )
+ (when variable (loop-make-iteration-variable variable nil variable-type))
+ (do ((l prep-phrases (cdr l)) (prep) (form) (odir)) ((null l))
+ (setq prep (caar l) form (cadar l))
+ (case prep
+ ((:of :in)
+ (setq sequencep t)
+ (loop-make-variable sequence-variable form sequence-type))
+ ((:from :downfrom :upfrom)
+ (setq start-given t)
+ (cond ((eq prep :downfrom) (setq dir ':down))
+ ((eq prep :upfrom) (setq dir ':up)))
+ (multiple-value-setq (form start-constantp start-value)
+ (loop-constant-fold-if-possible form indexv-type))
+ (loop-make-iteration-variable indexv form indexv-type))
+ ((:upto :to :downto :above :below)
+ (cond ((loop-tequal prep :upto) (setq inclusive-iteration
+ (setq dir ':up)))
+ ((loop-tequal prep :to) (setq inclusive-iteration t))
+ ((loop-tequal prep :downto) (setq inclusive-iteration
+ (setq dir ':down)))
+ ((loop-tequal prep :above) (setq dir ':down))
+ ((loop-tequal prep :below) (setq dir ':up)))
+ (setq limit-given t)
+ (multiple-value-setq (form limit-constantp limit-value)
+ (loop-constant-fold-if-possible form indexv-type))
+ (setq endform (if limit-constantp
+ `',limit-value
+ (loop-make-variable
+ (loop-gentemp 'loop-limit-) form indexv-type))))
+ (:by
+ (multiple-value-setq (form stepby-constantp stepby)
+ (loop-constant-fold-if-possible form indexv-type))
+ (unless stepby-constantp
+ (loop-make-variable (setq stepby (loop-gentemp 'loop-step-by-))
+ form
+ indexv-type)))
+ (t (loop-error
+ "~S invalid preposition in sequencing or sequence path;~@
+ maybe invalid prepositions were specified in iteration path descriptor?"
+ prep)))
+ (when (and odir dir (not (eq dir odir)))
+ (loop-error "conflicting stepping directions in LOOP sequencing path"))
+ (setq odir dir))
+ (when (and sequence-variable (not sequencep))
+ (loop-error "missing OF or IN phrase in sequence path"))
+ ;; Now fill in the defaults.
+ (unless start-given
+ (loop-make-iteration-variable
+ indexv
+ (setq start-constantp t
+ start-value (or (loop-typed-init indexv-type) 0))
+ indexv-type))
+ (cond ((member dir '(nil :up))
+ (when (or limit-given default-top)
+ (unless limit-given
+ (loop-make-variable (setq endform
+ (loop-gentemp 'loop-seq-limit-))
+ nil indexv-type)
+ (push `(setq ,endform ,default-top) *loop-prologue*))
+ (setq testfn (if inclusive-iteration '> '>=)))
+ (setq step (if (eql stepby 1) `(1+ ,indexv) `(+ ,indexv ,stepby))))
+ (t (unless start-given
+ (unless default-top
+ (loop-error "don't know where to start stepping"))
+ (push `(setq ,indexv (1- ,default-top)) *loop-prologue*))
+ (when (and default-top (not endform))
+ (setq endform (loop-typed-init indexv-type)
+ inclusive-iteration t))
+ (when endform (setq testfn (if inclusive-iteration '< '<=)))
+ (setq step
+ (if (eql stepby 1) `(1- ,indexv) `(- ,indexv ,stepby)))))
+ (when testfn
+ (setq test
+ (hide-variable-reference t indexv `(,testfn ,indexv ,endform))))
+ (when step-hack
+ (setq step-hack
+ `(,variable ,(hide-variable-reference indexv-user-specified-p
+ indexv
+ step-hack))))
+ (let ((first-test test) (remaining-tests test))
+ (when (and stepby-constantp start-constantp limit-constantp)
+ (when (setq first-test
+ (funcall (symbol-function testfn)
+ start-value
+ limit-value))
+ (setq remaining-tests t)))
+ `(() (,indexv ,(hide-variable-reference t indexv step))
+ ,remaining-tests ,step-hack () () ,first-test ,step-hack))))
+\f
+;;;; interfaces to the master sequencer
+
+(defun loop-for-arithmetic (var val data-type kwd)
+ (loop-sequencer
+ var (loop-check-data-type data-type *loop-real-data-type*) t
+ nil nil nil nil nil nil
+ (loop-collect-prepositional-phrases
+ '((:from :upfrom :downfrom) (:to :upto :downto :above :below) (:by))
+ nil (list (list kwd val)))))
+
+(defun loop-sequence-elements-path (variable data-type prep-phrases
+ &key
+ fetch-function
+ size-function
+ sequence-type
+ element-type)
+ (multiple-value-bind (indexv indexv-user-specified-p) (named-variable 'index)
+ (let ((sequencev (named-variable 'sequence)))
+ (list* nil nil ; dummy bindings and prologue
+ (loop-sequencer
+ indexv 'fixnum indexv-user-specified-p
+ variable (or data-type element-type)
+ sequencev sequence-type
+ `(,fetch-function ,sequencev ,indexv)
+ `(,size-function ,sequencev)
+ prep-phrases)))))
+\f
+;;;; builtin LOOP iteration paths
+
+#||
+(loop for v being the hash-values of ht do (print v))
+(loop for k being the hash-keys of ht do (print k))
+(loop for v being the hash-values of ht using (hash-key k) do (print (list k v)))
+(loop for k being the hash-keys of ht using (hash-value v) do (print (list k v)))
+||#
+
+(defun loop-hash-table-iteration-path (variable data-type prep-phrases
+ &key which)
+ (check-type which (member hash-key hash-value))
+ (cond ((or (cdr prep-phrases) (not (member (caar prep-phrases) '(:in :of))))
+ (loop-error "Too many prepositions!"))
+ ((null prep-phrases)
+ (loop-error "missing OF or IN in ~S iteration path")))
+ (let ((ht-var (loop-gentemp 'loop-hashtab-))
+ (next-fn (loop-gentemp 'loop-hashtab-next-))
+ (dummy-predicate-var nil)
+ (post-steps nil))
+ (multiple-value-bind (other-var other-p)
+ (named-variable (if (eq which 'hash-key) 'hash-value 'hash-key))
+ ;; @@@@ named-variable returns a second value of T if the name was
+ ;; actually specified, so clever code can throw away the gensym'ed up
+ ;; variable if it isn't really needed. The following is for those
+ ;; implementations in which we cannot put dummy NILs into
+ ;; multiple-value-setq variable lists.
+ (setq other-p t
+ dummy-predicate-var (loop-when-it-variable))
+ (let ((key-var nil)
+ (val-var nil)
+ (bindings `((,variable nil ,data-type)
+ (,ht-var ,(cadar prep-phrases))
+ ,@(and other-p other-var `((,other-var nil))))))
+ (if (eq which 'hash-key)
+ (setq key-var variable val-var (and other-p other-var))
+ (setq key-var (and other-p other-var) val-var variable))
+ (push `(with-hash-table-iterator (,next-fn ,ht-var)) *loop-wrappers*)
+ (when (consp key-var)
+ (setq post-steps
+ `(,key-var ,(setq key-var (loop-gentemp 'loop-hash-key-temp-))
+ ,@post-steps))
+ (push `(,key-var nil) bindings))
+ (when (consp val-var)
+ (setq post-steps
+ `(,val-var ,(setq val-var (loop-gentemp 'loop-hash-val-temp-))
+ ,@post-steps))
+ (push `(,val-var nil) bindings))
+ `(,bindings ;bindings
+ () ;prologue
+ () ;pre-test
+ () ;parallel steps
+ (not (multiple-value-setq (,dummy-predicate-var ,key-var ,val-var)
+ (,next-fn))) ;post-test
+ ,post-steps)))))
+
+(defun loop-package-symbols-iteration-path (variable data-type prep-phrases
+ &key symbol-types)
+ (cond ((or (cdr prep-phrases) (not (member (caar prep-phrases) '(:in :of))))
+ (loop-error "Too many prepositions!"))
+ ((null prep-phrases)
+ (loop-error "missing OF or IN in ~S iteration path")))
+ (unless (symbolp variable)
+ (loop-error "Destructuring is not valid for package symbol iteration."))
+ (let ((pkg-var (loop-gentemp 'loop-pkgsym-))
+ (next-fn (loop-gentemp 'loop-pkgsym-next-)))
+ (push `(with-package-iterator (,next-fn ,pkg-var ,@symbol-types))
+ *loop-wrappers*)
+ `(((,variable nil ,data-type) (,pkg-var ,(cadar prep-phrases)))
+ ()
+ ()
+ ()
+ (not (multiple-value-setq (,(loop-when-it-variable)
+ ,variable)
+ (,next-fn)))
+ ())))
+\f
+;;;; ANSI LOOP
+
+(defun make-ansi-loop-universe (extended-p)
+ (let ((w (make-standard-loop-universe
+ :keywords `((named (loop-do-named))
+ (initially (loop-do-initially))
+ (finally (loop-do-finally))
+ (do (loop-do-do))
+ (doing (loop-do-do))
+ (return (loop-do-return))
+ (collect (loop-list-collection list))
+ (collecting (loop-list-collection list))
+ (append (loop-list-collection append))
+ (appending (loop-list-collection append))
+ (nconc (loop-list-collection nconc))
+ (nconcing (loop-list-collection nconc))
+ (count (loop-sum-collection count
+ ,*loop-real-data-type*
+ fixnum))
+ (counting (loop-sum-collection count
+ ,*loop-real-data-type*
+ fixnum))
+ (sum (loop-sum-collection sum number number))
+ (summing (loop-sum-collection sum number number))
+ (maximize (loop-maxmin-collection max))
+ (minimize (loop-maxmin-collection min))
+ (maximizing (loop-maxmin-collection max))
+ (minimizing (loop-maxmin-collection min))
+ (always (loop-do-always t nil)) ; Normal, do always
+ (never (loop-do-always t t)) ; Negate test on always.
+ (thereis (loop-do-thereis t))
+ (while (loop-do-while nil :while)) ; Normal, do while
+ (until (loop-do-while t :until)) ;Negate test on while
+ (when (loop-do-if when nil)) ; Normal, do when
+ (if (loop-do-if if nil)) ; synonymous
+ (unless (loop-do-if unless t)) ; Negate test on when
+ (with (loop-do-with)))
+ :for-keywords '((= (loop-ansi-for-equals))
+ (across (loop-for-across))
+ (in (loop-for-in))
+ (on (loop-for-on))
+ (from (loop-for-arithmetic :from))
+ (downfrom (loop-for-arithmetic :downfrom))
+ (upfrom (loop-for-arithmetic :upfrom))
+ (below (loop-for-arithmetic :below))
+ (to (loop-for-arithmetic :to))
+ (upto (loop-for-arithmetic :upto))
+ (being (loop-for-being)))
+ :iteration-keywords '((for (loop-do-for))
+ (as (loop-do-for))
+ (repeat (loop-do-repeat)))
+ :type-symbols '(array atom bignum bit bit-vector character
+ compiled-function complex cons double-float
+ fixnum float function hash-table integer
+ keyword list long-float nil null number
+ package pathname random-state ratio rational
+ readtable sequence short-float simple-array
+ simple-bit-vector simple-string simple-vector
+ single-float standard-char stream string
+ base-char symbol t vector)
+ :type-keywords nil
+ :ansi (if extended-p :extended t))))
+ (add-loop-path '(hash-key hash-keys) 'loop-hash-table-iteration-path w
+ :preposition-groups '((:of :in))
+ :inclusive-permitted nil
+ :user-data '(:which hash-key))
+ (add-loop-path '(hash-value hash-values) 'loop-hash-table-iteration-path w
+ :preposition-groups '((:of :in))
+ :inclusive-permitted nil
+ :user-data '(:which hash-value))
+ (add-loop-path '(symbol symbols) 'loop-package-symbols-iteration-path w
+ :preposition-groups '((:of :in))
+ :inclusive-permitted nil
+ :user-data '(:symbol-types (:internal
+ :external
+ :inherited)))
+ (add-loop-path '(external-symbol external-symbols)
+ 'loop-package-symbols-iteration-path w
+ :preposition-groups '((:of :in))
+ :inclusive-permitted nil
+ :user-data '(:symbol-types (:external)))
+ (add-loop-path '(present-symbol present-symbols)
+ 'loop-package-symbols-iteration-path w
+ :preposition-groups '((:of :in))
+ :inclusive-permitted nil
+ :user-data '(:symbol-types (:internal)))
+ w))
+
+(defparameter *loop-ansi-universe*
+ (make-ansi-loop-universe nil))
+
+(defun loop-standard-expansion (keywords-and-forms environment universe)
+ (if (and keywords-and-forms (symbolp (car keywords-and-forms)))
+ (loop-translate keywords-and-forms environment universe)
+ (let ((tag (gensym)))
+ `(block nil (tagbody ,tag (progn ,@keywords-and-forms) (go ,tag))))))
+
+(sb!kernel: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-doc
+ "Causes 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."
+ '(go end-loop))
--- /dev/null
+;;;; MACROEXPAND and friends
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!IMPL")
+
+(file-comment
+ "$Header$")
+\f
+;;;; syntactic environment access
+
+(defun sb!xc:special-operator-p (symbol)
+ #!+sb-doc
+ "If the symbol globally names a special form, returns T, otherwise NIL."
+ (declare (symbol symbol))
+ (eq (info :function :kind symbol) :special-form))
+
+(defvar sb!xc:*macroexpand-hook* 'funcall
+ #!+sb-doc
+ "The value of this variable must be a designator for a function that can
+ take three arguments, a macro expander function, the macro form to be
+ expanded, and the lexical environment to expand in. The function should
+ return the expanded form. This function is called by MACROEXPAND-1
+ whenever a runtime expansion is needed. Initially this is set to
+ FUNCALL.")
+
+(declaim (ftype (function (t &optional (or null sb!c::lexenv))) sb!xc:macroexpand-1))
+(defun sb!xc:macroexpand-1 (form &optional env)
+ #!+sb-doc
+ "If form is a macro (or symbol macro), expands it once. Returns two values,
+ the expanded form and a T-or-NIL flag indicating whether the form was, in
+ fact, a macro. Env is the lexical environment to expand in, which defaults
+ to the null environment."
+ (cond ((and (consp form) (symbolp (car form)))
+ (let ((def (sb!xc:macro-function (car form) env)))
+ (if def
+ (values (funcall sb!xc:*macroexpand-hook*
+ def
+ form
+ ;; As far as I can tell, it's not clear from
+ ;; the ANSI spec whether a MACRO-FUNCTION
+ ;; function needs to be prepared to handle
+ ;; NIL as a lexical environment. CMU CL
+ ;; passed NIL through to the MACRO-FUNCTION
+ ;; function, but I prefer SBCL "be conservative
+ ;; in what it sends and liberal in what it
+ ;; accepts" by doing the defaulting itself.
+ ;; -- WHN 19991128
+ (or env (make-null-lexenv)))
+ t)
+ (values form nil))))
+ ((symbolp form)
+ (let* ((venv (when env (sb!c::lexenv-variables env)))
+ (local-def (cdr (assoc form venv))))
+ (if (and (consp local-def)
+ (eq (car local-def) 'macro))
+ (values (cdr local-def) t)
+ (values form nil))))
+ (t
+ (values form nil))))
+
+(declaim (ftype (function (t &optional (or null sb!c::lexenv))) sb!xc:macroexpand))
+(defun sb!xc:macroexpand (form &optional env)
+ #!+sb-doc
+ "Repetitively call MACROEXPAND-1 until the form can no longer be expanded.
+ Returns the final resultant form, and T if it was expanded. ENV is the
+ lexical environment to expand in, or NIL (the default) for the null
+ environment."
+ (labels ((frob (form expanded)
+ (multiple-value-bind (new-form newly-expanded-p)
+ (sb!xc:macroexpand-1 form env)
+ (if newly-expanded-p
+ (frob new-form t)
+ (values new-form expanded)))))
+ (frob form nil)))
--- /dev/null
+;;;; lots of basic macros for the target SBCL
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!IMPL")
+
+(file-comment
+ "$Header$")
+\f
+;;;; ASSERT and CHECK-TYPE
+
+;;; ASSERT is written this way, to call ASSERT-ERROR, because of how
+;;; closures are compiled. RESTART-CASE has forms with closures that
+;;; the compiler causes to be generated at the top of any function
+;;; using RESTART-CASE, regardless of whether they are needed. Thus if
+;;; we just wrapped a RESTART-CASE around the call to ERROR, we'd have
+;;; to do a significant amount of work at runtime allocating and
+;;; deallocating the closures regardless of whether they were ever
+;;; needed.
+;;;
+;;; ASSERT-ERROR isn't defined until a later file because it uses the
+;;; macro RESTART-CASE, which isn't defined until a later file.
+(defmacro-mundanely assert (test-form &optional places datum &rest arguments)
+ #!+sb-doc
+ "Signals an error if the value of test-form is nil. Continuing from this
+ error using the CONTINUE restart will allow the user to alter the value of
+ some locations known to SETF, starting over with test-form. Returns nil."
+ `(do () (,test-form)
+ (assert-error ',test-form ',places ,datum ,@arguments)
+ ,@(mapcar #'(lambda (place)
+ `(setf ,place (assert-prompt ',place ,place)))
+ places)))
+
+(defun assert-prompt (name value)
+ (cond ((y-or-n-p "The old value of ~S is ~S.~
+ ~%Do you want to supply a new value? "
+ name value)
+ (format *query-io* "~&Type a form to be evaluated:~%")
+ (flet ((read-it () (eval (read *query-io*))))
+ (if (symbolp name) ;help user debug lexical variables
+ (progv (list name) (list value) (read-it))
+ (read-it))))
+ (t value)))
+
+;;; CHECK-TYPE is written this way, to call CHECK-TYPE-ERROR, because
+;;; of how closures are compiled. RESTART-CASE has forms with closures
+;;; that the compiler causes to be generated at the top of any
+;;; function using RESTART-CASE, regardless of whether they are
+;;; needed. Because it would be nice if CHECK-TYPE were cheap to use,
+;;; and some things (e.g., READ-CHAR) can't afford this excessive
+;;; consing, we bend backwards a little.
+;;;
+;;; FIXME: In reality, this restart cruft is needed hardly anywhere in
+;;; the system. Write NEED and NEED-TYPE to replace ASSERT and
+;;; CHECK-TYPE inside the system.
+;;;
+;;; CHECK-TYPE-ERROR isn't defined until a later file because it uses
+;;; the macro RESTART-CASE, which isn't defined until a later file.
+(defmacro-mundanely check-type (place type &optional type-string)
+ #!+sb-doc
+ "Signals a restartable error of type TYPE-ERROR if the value of PLACE is
+ not of the specified type. If an error is signalled and the restart is
+ used to return, the
+ return if the
+ STORE-VALUE is invoked. It will store into PLACE and start over."
+ (let ((place-value (gensym)))
+ `(do ((,place-value ,place))
+ ((typep ,place-value ',type))
+ (setf ,place
+ (check-type-error ',place ,place-value ',type ,type-string)))))
+
+#!+high-security-support
+(defmacro-mundanely check-type-var (place type-var &optional type-string)
+ #!+sb-doc
+ "Signals an error of type type-error if the contents of place are not of the
+ specified type to which the type-var evaluates. If an error is signaled,
+ this can only return if STORE-VALUE is invoked. It will store into place
+ and start over."
+ (let ((place-value (gensym))
+ (type-value (gensym)))
+ `(do ((,place-value ,place)
+ (,type-value ,type-var))
+ ((typep ,place-value ,type-value))
+ (setf ,place
+ (check-type-error ',place ,place-value ,type-value ,type-string)))))
+\f
+;;;; DEFCONSTANT
+
+(defmacro-mundanely defconstant (var val &optional doc)
+ #!+sb-doc
+ "For defining global constants at top level. The DEFCONSTANT says that the
+ value is constant and may be compiled into code. If the variable already has
+ a value, and this is not equal to the init, an error is signalled. The third
+ argument is an optional documentation string for the variable."
+ `(sb!c::%defconstant ',var ,val ',doc))
+
+;;; These are like the other %MUMBLEs except that we currently
+;;; actually do something interesting at load time, namely checking
+;;; whether the constant is being redefined.
+(defun sb!c::%defconstant (name value doc)
+ (sb!c::%%defconstant name value doc))
+#+sb-xc-host (sb!xc:proclaim '(ftype function sb!c::%%defconstant)) ; to avoid
+ ; undefined function warnings
+(defun sb!c::%%defconstant (name value doc)
+ (when doc
+ (setf (fdocumentation name 'variable) doc))
+ (when (boundp name)
+ (unless (equalp (symbol-value name) value)
+ (cerror "Go ahead and change the value."
+ "The constant ~S is being redefined."
+ name)))
+ (setf (symbol-value name) value)
+ (setf (info :variable :kind name) :constant)
+ (clear-info :variable :constant-value name)
+ name)
+\f
+;;;; DEFINE-COMPILER-MACRO
+
+;;; FIXME: The logic here for handling compiler macros named (SETF
+;;; FOO) was added after the fork from SBCL, is not well tested, and
+;;; may conflict with subtleties of the ANSI standard. E.g. section
+;;; "3.2.2.1 Compiler Macros" says that creating a lexical binding for
+;;; a function name shadows a compiler macro, and it's not clear that
+;;; that works with this version. It should be tested.
+(defmacro-mundanely define-compiler-macro (name lambda-list &body body)
+ #!+sb-doc
+ "Define a compiler-macro for NAME."
+ (let ((whole (gensym "WHOLE-"))
+ (environment (gensym "ENV-")))
+ (multiple-value-bind (body local-decs doc)
+ (parse-defmacro lambda-list whole body name 'define-compiler-macro
+ :environment environment)
+ (let ((def `(lambda (,whole ,environment)
+ ,@local-decs
+ (block ,(function-name-block-name name)
+ ,body))))
+ `(sb!c::%define-compiler-macro ',name #',def ',lambda-list ,doc)))))
+(defun sb!c::%define-compiler-macro (name definition lambda-list doc)
+ ;; FIXME: Why does this have to be an interpreted function? Shouldn't
+ ;; it get compiled?
+ (assert (sb!eval:interpreted-function-p definition))
+ (setf (sb!eval:interpreted-function-name definition)
+ (format nil "DEFINE-COMPILER-MACRO ~S" name))
+ (setf (sb!eval:interpreted-function-arglist definition) lambda-list)
+ (sb!c::%%define-compiler-macro name definition doc))
+(defun sb!c::%%define-compiler-macro (name definition doc)
+ (setf (sb!xc:compiler-macro-function name) definition)
+ ;; FIXME: Add support for (SETF FDOCUMENTATION) when object is a list
+ ;; and type is COMPILER-MACRO. (Until then, we have to discard any
+ ;; compiler macro documentation for (SETF FOO).)
+ (unless (listp name)
+ (setf (fdocumentation name 'compiler-macro) doc))
+ name)
+\f
+;;;; CASE, TYPECASE, and friends
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+
+;;; CASE-BODY (interface)
+;;;
+;;; CASE-BODY returns code for all the standard "case" macros. Name is
+;;; the macro name, and keyform is the thing to case on. Multi-p
+;;; indicates whether a branch may fire off a list of keys; otherwise,
+;;; a key that is a list is interpreted in some way as a single key.
+;;; When multi-p, test is applied to the value of keyform and each key
+;;; for a given branch; otherwise, test is applied to the value of
+;;; keyform and the entire first element, instead of each part, of the
+;;; case branch. When errorp, no t or otherwise branch is permitted,
+;;; and an ERROR form is generated. When proceedp, it is an error to
+;;; omit errorp, and the ERROR form generated is executed within a
+;;; RESTART-CASE allowing keyform to be set and retested.
+(defun case-body (name keyform cases multi-p test errorp proceedp needcasesp)
+ (unless (or cases (not needcasesp))
+ (warn "no clauses in ~S" name))
+ (let ((keyform-value (gensym))
+ (clauses ())
+ (keys ()))
+ (dolist (case cases)
+ (cond ((atom case)
+ (error "~S -- Bad clause in ~S." case name))
+ ((memq (car case) '(t otherwise))
+ (if errorp
+ (error 'simple-program-error
+ :format-control "No default clause is allowed in ~S: ~S"
+ :format-arguments (list name case))
+ (push `(t nil ,@(rest case)) clauses)))
+ ((and multi-p (listp (first case)))
+ (setf keys (append (first case) keys))
+ (push `((or ,@(mapcar #'(lambda (key)
+ `(,test ,keyform-value ',key))
+ (first case)))
+ nil ,@(rest case))
+ clauses))
+ (t
+ (push (first case) keys)
+ (push `((,test ,keyform-value
+ ',(first case)) nil ,@(rest case)) clauses))))
+ (case-body-aux name keyform keyform-value clauses keys errorp proceedp
+ `(,(if multi-p 'member 'or) ,@keys))))
+
+;;; CASE-BODY-AUX provides the expansion once CASE-BODY has groveled
+;;; all the cases. Note: it is not necessary that the resulting code
+;;; signal case-failure conditions, but that's what KMP's prototype
+;;; code did. We call CASE-BODY-ERROR, because of how closures are
+;;; compiled. RESTART-CASE has forms with closures that the compiler
+;;; causes to be generated at the top of any function using the case
+;;; macros, regardless of whether they are needed.
+;;;
+;;; The CASE-BODY-ERROR function is defined later, when the
+;;; RESTART-CASE macro has been defined.
+(defun case-body-aux (name keyform keyform-value clauses keys
+ errorp proceedp expected-type)
+ (if proceedp
+ (let ((block (gensym))
+ (again (gensym)))
+ `(let ((,keyform-value ,keyform))
+ (block ,block
+ (tagbody
+ ,again
+ (return-from
+ ,block
+ (cond ,@(nreverse clauses)
+ (t
+ (setf ,keyform-value
+ (setf ,keyform
+ (case-body-error
+ ',name ',keyform ,keyform-value
+ ',expected-type ',keys)))
+ (go ,again))))))))
+ `(let ((,keyform-value ,keyform))
+ (declare (ignorable ,keyform-value)) ; e.g. (CASE KEY (T))
+ (cond
+ ,@(nreverse clauses)
+ ,@(if errorp
+ `((t (error 'sb!conditions::case-failure
+ :name ',name
+ :datum ,keyform-value
+ :expected-type ',expected-type
+ :possibilities ',keys))))))))
+) ; EVAL-WHEN
+
+(defmacro-mundanely case (keyform &body cases)
+ #!+sb-doc
+ "CASE Keyform {({(Key*) | Key} Form*)}*
+ Evaluates the Forms in the first clause with a Key EQL to the value of
+ Keyform. If a singleton key is T then the clause is a default clause."
+ (case-body 'case keyform cases t 'eql nil nil nil))
+
+(defmacro-mundanely ccase (keyform &body cases)
+ #!+sb-doc
+ "CCASE Keyform {({(Key*) | Key} Form*)}*
+ Evaluates the Forms in the first clause with a Key EQL to the value of
+ Keyform. If none of the keys matches then a correctable error is
+ signalled."
+ (case-body 'ccase keyform cases t 'eql t t t))
+
+(defmacro-mundanely ecase (keyform &body cases)
+ #!+sb-doc
+ "ECASE Keyform {({(Key*) | Key} Form*)}*
+ Evaluates the Forms in the first clause with a Key EQL to the value of
+ Keyform. If none of the keys matches then an error is signalled."
+ (case-body 'ecase keyform cases t 'eql t nil t))
+
+(defmacro-mundanely typecase (keyform &body cases)
+ #!+sb-doc
+ "TYPECASE Keyform {(Type Form*)}*
+ Evaluates the Forms in the first clause for which TYPEP of Keyform and Type
+ is true."
+ (case-body 'typecase keyform cases nil 'typep nil nil nil))
+
+(defmacro-mundanely ctypecase (keyform &body cases)
+ #!+sb-doc
+ "CTYPECASE Keyform {(Type Form*)}*
+ Evaluates the Forms in the first clause for which TYPEP of Keyform and Type
+ is true. If no form is satisfied then a correctable error is signalled."
+ (case-body 'ctypecase keyform cases nil 'typep t t t))
+
+(defmacro-mundanely etypecase (keyform &body cases)
+ #!+sb-doc
+ "ETYPECASE Keyform {(Type Form*)}*
+ Evaluates the Forms in the first clause for which TYPEP of Keyform and Type
+ is true. If no form is satisfied then an error is signalled."
+ (case-body 'etypecase keyform cases nil 'typep t nil t))
+\f
+;;;; WITH-FOO i/o-related macros
+
+(defmacro-mundanely with-open-stream ((var stream) &body forms-decls)
+ (multiple-value-bind (forms decls) (parse-body forms-decls nil)
+ (let ((abortp (gensym)))
+ `(let ((,var ,stream)
+ (,abortp t))
+ ,@decls
+ (unwind-protect
+ (multiple-value-prog1
+ (progn ,@forms)
+ (setq ,abortp nil))
+ (when ,var
+ (close ,var :abort ,abortp)))))))
+
+(defmacro-mundanely with-open-file ((stream filespec &rest options)
+ &body body)
+ `(with-open-stream (,stream (open ,filespec ,@options))
+ ,@body))
+
+(defmacro-mundanely with-input-from-string ((var string &key index start end)
+ &body forms-decls)
+ (multiple-value-bind (forms decls) (parse-body forms-decls nil)
+ ;; The ONCE-ONLY inhibits compiler note for unreachable code when
+ ;; END is true.
+ (once-only ((string string))
+ `(let ((,var
+ ,(cond ((null end)
+ `(make-string-input-stream ,string ,(or start 0)))
+ ((symbolp end)
+ `(if ,end
+ (make-string-input-stream ,string
+ ,(or start 0)
+ ,end)
+ (make-string-input-stream ,string
+ ,(or start 0))))
+ (t
+ `(make-string-input-stream ,string
+ ,(or start 0)
+ ,end)))))
+ ,@decls
+ (unwind-protect
+ (progn ,@forms)
+ (close ,var)
+ ,@(when index
+ `((setf ,index (string-input-stream-current ,var)))))))))
+
+(defmacro-mundanely with-output-to-string ((var &optional string)
+ &body forms-decls)
+ (multiple-value-bind (forms decls) (parse-body forms-decls nil)
+ (if string
+ `(let ((,var (make-fill-pointer-output-stream ,string)))
+ ,@decls
+ (unwind-protect
+ (progn ,@forms)
+ (close ,var)))
+ `(let ((,var (make-string-output-stream)))
+ ,@decls
+ (unwind-protect
+ (progn ,@forms)
+ (close ,var))
+ (get-output-stream-string ,var)))))
+\f
+;;;; miscellaneous macros
+
+(defmacro-mundanely nth-value (n form)
+ #!+sb-doc
+ "Evaluates FORM and returns the Nth value (zero based). This involves no
+ consing when N is a trivial constant integer."
+ (if (integerp n)
+ (let ((dummy-list nil)
+ (keeper (gensym "KEEPER-")))
+ ;; We build DUMMY-LIST, a list of variables to bind to useless
+ ;; values, then we explicitly IGNORE those bindings and return
+ ;; KEEPER, the only thing we're really interested in right now.
+ (dotimes (i n)
+ (push (gensym "IGNORE-") dummy-list))
+ `(multiple-value-bind (,@dummy-list ,keeper) ,form
+ (declare (ignore ,@dummy-list))
+ ,keeper))
+ (once-only ((n n))
+ `(case (the fixnum ,n)
+ (0 (nth-value 0 ,form))
+ (1 (nth-value 1 ,form))
+ (2 (nth-value 2 ,form))
+ (t (nth (the fixnum ,n) (multiple-value-list ,form)))))))
+
+(defmacro-mundanely declaim (&rest specs)
+ #!+sb-doc
+ "DECLAIM Declaration*
+ Do a declaration or declarations for the global environment."
+ #-sb-xc-host
+ `(eval-when (:compile-toplevel :load-toplevel :execute)
+ ,@(mapcar #'(lambda (x)
+ `(sb!xc:proclaim ',x))
+ specs))
+ ;; KLUDGE: The definition above doesn't work in the cross-compiler,
+ ;; because UNCROSS translates SB!XC:PROCLAIM into CL:PROCLAIM before
+ ;; the form gets executed. Instead, we have to explicitly do the
+ ;; proclamation at macroexpansion time. -- WHN ca. 19990810
+ ;;
+ ;; FIXME: Maybe we don't need this special treatment any more now
+ ;; that we're using DEFMACRO-MUNDANELY instead of DEFMACRO?
+ #+sb-xc-host (progn
+ (mapcar #'sb!xc:proclaim specs)
+ `(progn
+ ,@(mapcar #'(lambda (x)
+ `(sb!xc:proclaim ',x))
+ specs))))
+
+(defmacro-mundanely print-unreadable-object ((object stream
+ &key type identity)
+ &body body)
+ `(%print-unreadable-object ,object ,stream ,type ,identity
+ ,(if body
+ `#'(lambda () ,@body)
+ nil)))
--- /dev/null
+;;;; string hacking functions that are stubs for things that might
+;;;; be microcoded someday
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!IMPL")
+
+(file-comment
+ "$Header$")
+
+;(defun %sp-byte-blt (src-string src-start dst-string dst-start dst-end)
+; "Moves bytes from Src-String into Dst-String between Dst-Start (inclusive)
+;and Dst-End (exclusive) (Dst-Start - Dst-End bytes are moved). Overlap of the
+;strings does not affect the result. This would be done on the Vax
+;with MOVC3. The arguments do not need to be strings: 8-bit U-Vectors
+;are also acceptable."
+; (%primitive byte-blt src-string src-start dst-string dst-start dst-end))
+
+(defun %sp-string-compare (string1 start1 end1 string2 start2 end2)
+ (declare (simple-string string1 string2))
+ (declare (fixnum start1 end1 start2 end2))
+ #!+sb-doc
+ "Compares the substrings specified by String1 and String2 and returns
+NIL if the strings are String=, or the lowest index of String1 in
+which the two differ. If one string is longer than the other and the
+shorter is a prefix of the longer, the length of the shorter + start1 is
+returned. This would be done on the Vax with CMPC3. The arguments must
+be simple strings."
+ (let ((len1 (- end1 start1))
+ (len2 (- end2 start2)))
+ (declare (fixnum len1 len2))
+ (cond
+ ((= len1 len2)
+ (do ((index1 start1 (1+ index1))
+ (index2 start2 (1+ index2)))
+ ((= index1 end1) nil)
+ (declare (fixnum index1 index2))
+ (if (char/= (schar string1 index1) (schar string2 index2))
+ (return index1))))
+ ((> len1 len2)
+ (do ((index1 start1 (1+ index1))
+ (index2 start2 (1+ index2)))
+ ((= index2 end2) index1)
+ (declare (fixnum index1 index2))
+ (if (char/= (schar string1 index1) (schar string2 index2))
+ (return index1))))
+ (t
+ (do ((index1 start1 (1+ index1))
+ (index2 start2 (1+ index2)))
+ ((= index1 end1) index1)
+ (declare (fixnum index1 index2))
+ (if (char/= (schar string1 index1) (schar string2 index2))
+ (return index1)))))))
+
+(defun %sp-reverse-string-compare (string1 start1 end1 string2 start2 end2)
+ (declare (simple-string string1 string2))
+ (declare (fixnum start1 end1 start2 end2))
+ #!+sb-doc
+ "like %SP-STRING-COMPARE, only backwards"
+ (let ((len1 (- end1 start1))
+ (len2 (- end2 start2)))
+ (declare (fixnum len1 len2))
+ (cond
+ ((= len1 len2)
+ (do ((index1 (1- end1) (1- index1))
+ (index2 (1- end2) (1- index2)))
+ ((< index1 start1) nil)
+ (declare (fixnum index1 index2))
+ (if (char/= (schar string1 index1) (schar string2 index2))
+ (return index1))))
+ ((> len1 len2)
+ (do ((index1 (1- end1) (1- index1))
+ (index2 (1- end2) (1- index2)))
+ ((< index2 start2) index1)
+ (declare (fixnum index1 index2))
+ (if (char/= (schar string1 index1) (schar string2 index2))
+ (return index1))))
+ (t
+ (do ((index1 (1- end1) (1- index1))
+ (index2 (1- end2) (1- index2)))
+ ((< index1 start1) index1)
+ (declare (fixnum index1 index2))
+ (if (char/= (schar string1 index1) (schar string2 index2))
+ (return index1)))))))
+
+(defmacro maybe-sap-maybe-string ((var) &body body)
+ `(etypecase ,var
+ (system-area-pointer
+ (macrolet ((byte-ref (index)
+ `(sap-ref-8 ,',var ,index))
+ (char-ref (index)
+ `(code-char (byte-ref ,index))))
+ ,@body))
+ (simple-string
+ (macrolet ((char-ref (index)
+ `(schar ,',var ,index))
+ (byte-ref (index)
+ `(char-code (char-ref ,index))))
+ ,@body))))
+
+(defun %sp-find-character-with-attribute (string start end table mask)
+ (declare (type (simple-array (unsigned-byte 8) (256)) table)
+ (type (or simple-string system-area-pointer) string)
+ (fixnum start end mask))
+ #!+sb-doc
+ "%SP-Find-Character-With-Attribute String, Start, End, Table, Mask
+ The codes of the characters of String from Start to End are used as indices
+ into the Table, which is a U-Vector of 8-bit bytes. When the number picked
+ up from the table bitwise ANDed with Mask is non-zero, the current
+ index into the String is returned. The corresponds to SCANC on the Vax."
+ (maybe-sap-maybe-string (string)
+ (do ((index start (1+ index)))
+ ((>= index end) nil)
+ (declare (fixnum index))
+ (unless (zerop (logand (aref table (byte-ref index)) mask))
+ (return index)))))
+
+(defun %sp-reverse-find-character-with-attribute (string start end table mask)
+ #!+sb-doc
+ "Like %SP-Find-Character-With-Attribute, only sdrawkcaB."
+ (declare (type (or simple-string system-area-pointer) string)
+ (fixnum start end mask)
+ (type (array (unsigned-byte 8) (256)) table))
+ (maybe-sap-maybe-string (string)
+ (do ((index (1- end) (1- index)))
+ ((< index start) nil)
+ (declare (fixnum index))
+ (unless (zerop (logand (aref table (byte-ref index)) mask))
+ (return index)))))
+
+(defun %sp-find-character (string start end character)
+ #!+sb-doc
+ "%SP-Find-Character String, Start, End, Character
+ Searches String for the Character from Start to End. If the character is
+ found, the corresponding index into String is returned, otherwise NIL is
+ returned."
+ (declare (fixnum start end)
+ (type (or simple-string system-area-pointer) string)
+ (base-char character))
+ (maybe-sap-maybe-string (string)
+ (do ((index start (1+ index)))
+ ((>= index end) nil)
+ (declare (fixnum index))
+ (when (char= (char-ref index) character)
+ (return index)))))
+
+(defun %sp-reverse-find-character (string start end character)
+ (declare (type (or simple-string system-area-pointer) string)
+ (fixnum start end)
+ (base-char character))
+ #!+sb-doc
+ "%SP-Reverse-Find-Character String, Start, End, Character
+ Searches String for Character from End to Start. If the character is
+ found, the corresponding index into String is returned, otherwise NIL is
+ returned."
+ (maybe-sap-maybe-string (string)
+ (do ((index (1- end) (1- index))
+ (terminus (1- start)))
+ ((= index terminus) nil)
+ (declare (fixnum terminus index))
+ (if (char= (char-ref index) character)
+ (return index)))))
+
+(defun %sp-skip-character (string start end character)
+ (declare (type (or simple-string system-area-pointer) string)
+ (fixnum start end)
+ (base-char character))
+ #!+sb-doc
+ "%SP-Skip-Character String, Start, End, Character
+ Returns the index of the first character between Start and End which
+ is not Char= to Character, or NIL if there is no such character."
+ (maybe-sap-maybe-string (string)
+ (do ((index start (1+ index)))
+ ((= index end) nil)
+ (declare (fixnum index))
+ (if (char/= (char-ref index) character)
+ (return index)))))
+
+(defun %sp-reverse-skip-character (string start end character)
+ (declare (type (or simple-string system-area-pointer) string)
+ (fixnum start end)
+ (base-char character))
+ #!+sb-doc
+ "%SP-Skip-Character String, Start, End, Character
+ Returns the index of the last character between Start and End which
+ is not Char= to Character, or NIL if there is no such character."
+ (maybe-sap-maybe-string (string)
+ (do ((index (1- end) (1- index))
+ (terminus (1- start)))
+ ((= index terminus) nil)
+ (declare (fixnum terminus index))
+ (if (char/= (char-ref index) character)
+ (return index)))))
+
+(defun %sp-string-search (string1 start1 end1 string2 start2 end2)
+ #!+sb-doc
+ "%SP-String-Search String1, Start1, End1, String2, Start2, End2
+ Searches for the substring of String1 specified in String2.
+ Returns an index into String2 or NIL if the substring wasn't
+ found."
+ (declare (simple-string string1 string2))
+ (do ((index2 start2 (1+ index2)))
+ ((= index2 end2) nil)
+ (declare (fixnum index2))
+ (when (do ((index1 start1 (1+ index1))
+ (index2 index2 (1+ index2)))
+ ((= index1 end1) t)
+ (declare (fixnum index1 index2))
+ (when (= index2 end2)
+ (return-from %sp-string-search nil))
+ (when (char/= (char string1 index1) (char string2 index2))
+ (return nil)))
+ (return index2))))
--- /dev/null
+;;;; that part of misc.lisp functionality which is used on the
+;;;; cross-compilation host Lisp as well as the target Lisp
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!IMPL")
+
+(file-comment
+ "$Header$")
+
+(defun sb!xc:lisp-implementation-type ()
+ "SBCL")
+
+(defun sb!xc:lisp-implementation-version ()
+ #.(sb-cold:read-from-file "version.lisp-expr"))
--- /dev/null
+;;;; REQUIRE, PROVIDE, and friends
+;;;;
+;;;; Note that this module file is based on the old system, and is being
+;;;; spliced into the current sources to reflect the last minute deprecated
+;;;; addition of modules to the X3J13 ANSI standard.
+;;;;
+;;;; FIXME: This implementation has cruft not required by the ANSI
+;;;; spec, notably DEFMODULE. We should probably minimize it, since
+;;;; it's deprecated anyway.
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!IMPL")
+
+(file-comment
+ "$Header$")
+\f
+;;;; exported specials
+
+(defvar *modules* ()
+ #!+sb-doc
+ "This is a list of module names that have been loaded into Lisp so far.
+ It is used by PROVIDE and REQUIRE.")
+
+;;;; DEFMODULE
+;;;; FIXME: Remove this.
+
+(defvar *module-file-translations* (make-hash-table :test 'equal))
+(defmacro defmodule (name &rest files)
+ #!+sb-doc
+ "Defines a module by registering the files that need to be loaded when
+ the module is required. If name is a symbol, its print name is used
+ after downcasing it."
+ `(%define-module ,name ',files))
+
+(defun %define-module (name files)
+ (setf (gethash (module-name-string name) *module-file-translations*)
+ files))
+
+(defun module-files (name)
+ (gethash name *module-file-translations*))
+\f
+;;;; PROVIDE and REQUIRE
+
+(defun provide (module-name)
+ #!+sb-doc
+ "Adds a new module name to *MODULES* indicating that it has been loaded.
+ Module-name may be either a case-sensitive string or a symbol; if it is
+ a symbol, its print name is downcased and used."
+ (pushnew (module-name-string module-name) *modules* :test #'string=)
+ t)
+
+(defun require (module-name &optional pathname)
+ #!+sb-doc
+ "Loads a module when it has not been already. PATHNAME, if supplied,
+ is a single pathname or list of pathnames to be loaded if the module
+ needs to be. If PATHNAME is not supplied, then a list of files are
+ looked for that were registered by a DEFMODULE form. If the module
+ has not been defined, then a file will be loaded whose name is formed
+ by merging \"modules:\" and MODULE-NAME (downcased if it is a symbol).
+ This merged name will be probed with both a .lisp extension and any
+ architecture-specific FASL extensions, and LOAD will be called on it
+ if it is found."
+ ;; KLUDGE: Does this really match the doc string any more? (Did it ever
+ ;; match the doc string? Arguably this isn't a high priority question
+ ;; since REQUIRE is deprecated anyway and I've not been very motivated
+ ;; to maintain CMU CL extensions like DEFMODULE.. -- WHN 19990804
+ (setf module-name
+ (module-name-string module-name))
+ (unless (member module-name *modules* :test #'string=)
+ (if pathname
+ (unless (listp pathname) (setf pathname (list pathname)))
+ (let ((files (module-files module-name)))
+ (if files
+ (setf pathname files)
+ (setf pathname (list (merge-pathnames "modules:" module-name))))))
+ (dolist (ele pathname t)
+ (load ele))))
+\f
+;;;; miscellany
+
+(defun module-name-string (name)
+ (typecase name
+ (string name)
+ (symbol (string-downcase (symbol-name name)))
+ (t (error 'simple-type-error
+ :datum name
+ :expected-type '(or string symbol)
+ :format-control "Module name must be a string or symbol -- ~S."
+ :format-arguments (list name)))))
--- /dev/null
+;;;; stack-group and multi-process support for CMU CL x86
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!MP")
+
+(file-comment
+ "$Header$")
+\f
+;;;; Handle the binding stack.
+
+;;; Undo all the bindings in the bind stack, restoring the global
+;;; values.
+(defun unbind-binding-stack ()
+ (declare (optimize (speed 3) (safety 0)))
+ (let* ((binding-stack-pointer (sb!kernel:binding-stack-pointer-sap))
+ (binding-stack
+ (sb!sys:int-sap (sb!alien:extern-alien "binding_stack"
+ sb!alien:unsigned)))
+ (size (sb!sys:sap- binding-stack-pointer binding-stack)))
+ (declare (type (unsigned-byte 29) size))
+ (do ((binding size))
+ ((zerop binding))
+ (declare (type (unsigned-byte 29) binding))
+ (decf binding 8)
+ (let* ((value
+ (sb!kernel:make-lisp-obj
+ (sb!sys:sap-int (sb!sys:sap-ref-sap binding-stack binding))))
+ (symbol
+ (sb!kernel:make-lisp-obj
+ (sb!sys:sap-int (sb!sys:sap-ref-sap binding-stack
+ (+ binding 4))))))
+ (cond ((symbolp symbol)
+ (let ((symbol-value (sb!c::%primitive sb!c:fast-symbol-value
+ symbol)))
+ #+nil
+ (format t "undoing: ~S ~S <-> ~S~%" symbol value symbol-value)
+ (sb!kernel:%set-symbol-value symbol value)
+ (setf (sb!sys:sap-ref-sap binding-stack binding)
+ (sb!sys:int-sap (sb!kernel:get-lisp-obj-address
+ symbol-value)))))
+ (t
+ #+nil
+ (format t "ignoring undoing: ~S ~S~%" symbol value)))))))
+
+;;; Re-apply the bindings in a binding stack after an
+;;; unbind-binding-stack.
+(defun rebind-binding-stack ()
+ (declare (optimize (speed 3) (safety 0)))
+ (let* ((binding-stack-pointer (sb!kernel:binding-stack-pointer-sap))
+ (binding-stack
+ (sb!sys:int-sap (sb!alien:extern-alien "binding_stack"
+ sb!alien:unsigned)))
+ (size (sb!sys:sap- binding-stack-pointer binding-stack)))
+ (declare (type (unsigned-byte 29) size))
+ (do ((binding 0 (+ 8 binding)))
+ ((= binding size))
+ (declare (type (unsigned-byte 29) binding))
+ (let* ((value
+ (sb!kernel:make-lisp-obj
+ (sb!sys:sap-int (sb!sys:sap-ref-sap binding-stack binding))))
+ (symbol
+ (sb!kernel:make-lisp-obj
+ (sb!sys:sap-int (sb!sys:sap-ref-sap binding-stack
+ (+ binding 4))))))
+ (cond ((symbolp symbol)
+ (let ((symbol-value (sb!c::%primitive sb!c:fast-symbol-value
+ symbol)))
+ #+nil
+ (format t "rebinding: ~S ~S <-> ~S~%"
+ symbol value symbol-value)
+ (sb!kernel:%set-symbol-value symbol value)
+ (setf (sb!sys:sap-ref-sap binding-stack binding)
+ (sb!sys:int-sap (sb!kernel:get-lisp-obj-address
+ symbol-value)))))
+ (t
+ #+nil
+ (format t "ignoring rebinding: ~S ~S~%" symbol value)))))))
+
+(defun save-binding-stack (binding-save-stack)
+ (declare (type (simple-array t (*)) binding-save-stack)
+ (optimize (speed 3) (safety 0)))
+ (let* ((binding-stack-pointer (sb!kernel:binding-stack-pointer-sap))
+ (binding-stack
+ (sb!sys:int-sap (sb!alien:extern-alien "binding_stack"
+ sb!alien:unsigned)))
+ (size (sb!sys:sap- binding-stack-pointer binding-stack))
+ (vector-size (truncate size 4)))
+ (declare (type (unsigned-byte 29) size))
+ ;; Grow binding-save-stack if necessary.
+ (when (< (length binding-save-stack) vector-size)
+ (setq binding-save-stack
+ (adjust-array binding-save-stack vector-size :element-type t)))
+ ;; Save the stack.
+ (do ((binding 0 (+ 4 binding))
+ (index 0 (1+ index)))
+ ((= binding size))
+ (declare (type (unsigned-byte 29) binding index))
+ (setf (aref binding-save-stack index)
+ (sb!kernel:make-lisp-obj
+ (sb!sys:sap-int (sb!sys:sap-ref-sap binding-stack binding)))))
+ (values binding-save-stack vector-size)))
+
+(defun restore-binding-stack (new-binding-stack size)
+ (declare (type (simple-array t (*)) new-binding-stack)
+ (type (unsigned-byte 29) size)
+ (optimize (speed 3) (safety 0)))
+ (let* ((binding-stack-size (* size 4))
+ (binding-stack (sb!alien:extern-alien "binding_stack"
+ sb!alien:unsigned)))
+ (declare (type (unsigned-byte 32) binding-stack-size binding-stack))
+ (setf (sb!kernel:binding-stack-pointer-sap)
+ (sb!sys:int-sap (+ binding-stack binding-stack-size)))
+ (do ((binding 0 (+ 4 binding))
+ (index 0 (1+ index)))
+ ((= binding binding-stack-size))
+ (declare (type (unsigned-byte 29) binding index))
+ (setf (sb!sys:sap-ref-sap (sb!sys:int-sap binding-stack) binding)
+ (sb!sys:int-sap (sb!kernel:get-lisp-obj-address
+ (aref new-binding-stack index))))))
+ (values))
+\f
+;;;; alien stack
+
+;;; The Top of the Alien-stack.
+(declaim (type (unsigned-byte 32) *alien-stack-top*))
+(defvar *alien-stack-top* 0)
+
+;;; Save the alien-stack.
+(defun save-alien-stack (save-stack)
+ (declare (type (simple-array (unsigned-byte 32) (*)) save-stack)
+ (optimize (speed 3) (safety 0)))
+ (let* ((alien-stack (sb!kernel:get-lisp-obj-address sb!vm::*alien-stack*))
+ (size (- *alien-stack-top* alien-stack))
+ (vector-size (ceiling size 4)))
+ (declare (type (unsigned-byte 32) alien-stack)
+ (type (unsigned-byte 29) size))
+ #+nil
+ (format t "alien-stack ~X; size ~X~%" alien-stack size)
+ ;; Grow save-stack if necessary.
+ (when (< (length save-stack) vector-size)
+ (setq save-stack
+ (adjust-array save-stack vector-size
+ :element-type '(unsigned-byte 32))))
+ ;; Save the stack.
+ (do ((index 0 (1+ index)))
+ ((>= index vector-size))
+ (declare (type (unsigned-byte 29) index))
+ (setf (aref save-stack index)
+ (sb!sys:sap-ref-32 (sb!sys:int-sap *alien-stack-top*)
+ (* 4 (- (1+ index))))))
+ (values save-stack vector-size alien-stack)))
+
+(defun restore-alien-stack (save-stack size alien-stack)
+ (declare (type (simple-array (unsigned-byte 32) (*)) save-stack)
+ (type (unsigned-byte 29) size)
+ (type (unsigned-byte 32) alien-stack)
+ (optimize (speed 3) (safety 0)))
+ (setf sb!vm::*alien-stack* (sb!kernel:make-lisp-obj alien-stack))
+ (do ((index 0 (1+ index)))
+ ((>= index size))
+ (declare (type (unsigned-byte 29) index))
+ (setf (sb!sys:sap-ref-32 (sb!sys:int-sap *alien-stack-top*)
+ (* 4 (- (1+ index))))
+ (aref save-stack index)))
+ (values))
+\f
+;;;; interrupt contexts
+
+;;; Save the interrupt contexts.
+(defun save-interrupt-contexts (save-vector)
+ (declare (type (simple-array (unsigned-byte 32) (*)) save-vector)
+ (optimize (speed 3) (safety 0)))
+ (let* ((size sb!impl::*free-interrupt-context-index*))
+ (declare (type (unsigned-byte 29) size))
+ ;; Grow save-stack if necessary.
+ (when (< (length save-vector) size)
+ (setq save-vector
+ (adjust-array save-vector size :element-type '(unsigned-byte 32))))
+ (sb!alien:with-alien
+ ((lisp-interrupt-contexts (array sb!alien:unsigned nil) :extern))
+ (dotimes (index size)
+ (setf (aref save-vector index)
+ (sb!alien:deref lisp-interrupt-contexts index))))
+ save-vector))
+
+;;; Restore the interrupt contexts.
+(defun restore-interrupt-contexts (save-vector)
+ (declare (type (simple-array (unsigned-byte 32) (*)) save-vector)
+ (optimize (speed 3) (safety 0)))
+ (let* ((size sb!impl::*free-interrupt-context-index*))
+ (declare (type (unsigned-byte 29) size))
+ (sb!alien:with-alien
+ ((lisp-interrupt-contexts (array sb!alien:unsigned nil) :extern))
+ (dotimes (index size)
+ (setf (sb!alien:deref lisp-interrupt-contexts index)
+ (aref save-vector index)))))
+ (values))
+\f
+;;; The control stacks need special handling on the X86 as they
+;;; contain conservative roots. When placed in the *control-stacks*
+;;; vector they will be scavenged for conservative roots by the
+;;; garbage collector.
+(declaim (type (simple-array (or null (simple-array (unsigned-byte 32) (*)))
+ (*)) sb!vm::*control-stacks*))
+(defvar sb!vm::*control-stacks*
+ (make-array 0 :element-type '(or null (unsigned-byte 32))
+ :initial-element nil))
+
+;;; Stack-group structure.
+(defstruct (stack-group
+ (:constructor %make-stack-group)
+ (:print-object
+ (lambda (stack-group stream)
+ (declare (type stack-group stack-group)
+ (stream stream))
+ (print-unreadable-object (stack-group stream :identity t)
+ (format stream "stack-group ~A, ~A"
+ (stack-group-name stack-group)
+ (stack-group-state stack-group))))))
+ ;; Must have a name.
+ (name "Anonymous" :type simple-base-string)
+ ;; State: :active or :inactive.
+ (state :inactive :type (member :active :inactive))
+ ;; The control stack; an index into *control-stacks*.
+ (control-stack-id nil :type (or sb!kernel:index null))
+ ;; Binding stack.
+ (binding-stack nil :type (or (simple-array t (*)) null))
+ ;; Twice the number of bindings.
+ (binding-stack-size 0 :type (unsigned-byte 29))
+ ;; Current catch block, on the control stack.
+ (current-catch-block 0 :type fixnum)
+ ;; Unwind protect block, on the control stack.
+ (current-unwind-protect-block 0 :type fixnum)
+ ;; Alien stack
+ (alien-stack nil :type (or (simple-array (unsigned-byte 32) (*)) null))
+ (alien-stack-size 0 :type (unsigned-byte 29))
+ (alien-stack-pointer 0 :type (unsigned-byte 32))
+ ;; Eval-stack
+ (eval-stack nil :type (or (simple-array t (*)) null))
+ (eval-stack-top 0 :type fixnum)
+ ;; Interrupt contexts
+ (interrupt-contexts nil :type (or (simple-array (unsigned-byte 32) (*))
+ null))
+ ;; Resumer
+ (resumer nil :type (or stack-group null)))
+
+;;; The current stack group.
+(declaim (type (or stack-group null) *current-stack-group*))
+(defvar *current-stack-group* nil)
+
+(declaim (type (or stack-group null) *initial-stack-group*))
+(defvar *initial-stack-group* nil)
+
+;;; Setup the initial stack group.
+(defun init-stack-groups ()
+ ;; Grab the top of the alien-stack; it's currently stored at the top
+ ;; of the control stack.
+ (setf *alien-stack-top*
+ (sb!sys:sap-ref-32
+ (sb!sys:int-sap (sb!alien:extern-alien "control_stack_end"
+ sb!alien:unsigned))
+ -4))
+ ;; Initialise the *control-stacks* vector.
+ (setq sb!vm::*control-stacks*
+ (make-array 10 :element-type '(or null (unsigned-byte 32))
+ :initial-element nil))
+ ;; Setup a control-stack for the initial stack-group.
+ (setf (aref sb!vm::*control-stacks* 0)
+ (make-array 0
+ :element-type '(unsigned-byte 32)
+ :initial-element 0))
+ ;; Make and return the initial stack group.
+ (setf *current-stack-group*
+ (%make-stack-group
+ :name "initial"
+ :state :active
+ :control-stack-id 0
+ :binding-stack #()
+ :alien-stack (make-array 0 :element-type '(unsigned-byte 32))
+ :interrupt-contexts (make-array 0 :element-type '(unsigned-byte 32))
+ :eval-stack #()))
+ (setf *initial-stack-group* *current-stack-group*))
+
+;;; Inactivate the stack group, cleaning its slot and freeing the
+;;; control stack.
+(defun inactivate-stack-group (stack-group)
+ (declare (type stack-group stack-group))
+ (setf (stack-group-state stack-group) :inactive)
+ (let ((cs-id (stack-group-control-stack-id stack-group)))
+ (when (and cs-id (aref sb!vm::*control-stacks* cs-id))
+ (setf (aref sb!vm::*control-stacks* cs-id) nil)))
+ (setf (stack-group-control-stack-id stack-group) nil)
+ (setf (stack-group-binding-stack stack-group) nil)
+ (setf (stack-group-binding-stack-size stack-group) 0)
+ (setf (stack-group-current-catch-block stack-group) 0)
+ (setf (stack-group-current-unwind-protect-block stack-group) 0)
+ (setf (stack-group-alien-stack stack-group) nil)
+ (setf (stack-group-alien-stack-size stack-group) 0)
+ (setf (stack-group-alien-stack-pointer stack-group) 0)
+ (setf (stack-group-eval-stack stack-group) nil)
+ (setf (stack-group-eval-stack-top stack-group) 0)
+ (setf (stack-group-resumer stack-group) nil))
+
+;;; Scrub the binding and eval stack of the give stack-group.
+(defun scrub-stack-group-stacks (stack-group)
+ (declare (type stack-group stack-group)
+ (optimize (speed 3) (safety 0)))
+ ;; Binding stack.
+ (let ((binding-save-stack (stack-group-binding-stack stack-group)))
+ (when binding-save-stack
+ (let ((size
+ ;; The stored binding stack for the current stack group
+ ;; can be completely scrubbed.
+ (if (eq stack-group *current-stack-group*)
+ 0
+ (stack-group-binding-stack-size stack-group)))
+ (len (length binding-save-stack)))
+ ;; Scrub the remainder of the binding stack.
+ (do ((index size (+ index 1)))
+ ((>= index len))
+ (declare (type (unsigned-byte 29) index))
+ (setf (aref binding-save-stack index) 0)))))
+ ;; If this is the current stack group then update the stored
+ ;; eval-stack and eval-stack-top before scrubbing.
+ (when (eq stack-group *current-stack-group*)
+ ;; Updare the stored vector, flushing an old vector if a new one
+ ;; has been allocated.
+ (setf (stack-group-eval-stack stack-group) sb!impl::*eval-stack*)
+ ;; Ensure that the stack-top is valid.
+ (setf (stack-group-eval-stack-top stack-group) sb!impl::*eval-stack-top*))
+ ;; Scrub the eval stack.
+ (let ((eval-stack (stack-group-eval-stack stack-group)))
+ (when eval-stack
+ (let ((eval-stack-top (stack-group-eval-stack-top stack-group))
+ (len (length eval-stack)))
+ (do ((i eval-stack-top (1+ i)))
+ ((= i len))
+ (declare (type sb!kernel:index i))
+ (setf (svref eval-stack i) nil))))))
+
+;;; Generate the initial bindings for a newly created stack-group.
+;;; This function may be redefined to return a vector with other bindings
+;;; but *interrupts-enabled* and *gc-inhibit* must be the last two.
+(defun initial-binding-stack ()
+ (vector
+ (find-package "COMMON-LISP-USER") '*package*
+ ;; Other bindings may be added here.
+ nil 'sb!unix::*interrupts-enabled*
+ t 'sb!impl::*gc-inhibit*))
+
+;;; Fork a new stack-group from the *current-stack-group*. Execution
+;;; continues with the *current-stack-group* returning the new stack
+;;; group. Control may be transfer to the child by stack-group-resume
+;;; and it executes the initial-function.
+(defun make-stack-group (name initial-function &optional
+ (resumer *current-stack-group*)
+ (inherit t))
+ (declare (type simple-base-string name)
+ (type function initial-function)
+ (type stack-group resumer))
+ (flet ((allocate-control-stack ()
+ (let* (;; Allocate a new control-stack ID.
+ (control-stack-id (position nil sb!vm::*control-stacks*))
+ ;; Find the required stack size.
+ (control-stack-end
+ (sb!alien:extern-alien "control_stack_end"
+ sb!alien:unsigned))
+ (control-stack-pointer (sb!kernel:control-stack-pointer-sap))
+ (control-stack-size
+ (- control-stack-end
+ (sb!sys:sap-int control-stack-pointer)))
+ ;; Saved control stack needs three extra words. The
+ ;; stack pointer will be stored in the first
+ ;; element, and the frame pointer and return address
+ ;; push onto the bottom of the stack.
+ (control-stack
+ (make-array (+ (ceiling control-stack-size 4) 3)
+ :element-type '(unsigned-byte 32)
+ :initial-element 0)))
+ (declare (type (unsigned-byte 29) control-stack-size))
+ (unless control-stack-id
+ ;; Need to extend the *control-stacks* vector.
+ (setq control-stack-id (length sb!vm::*control-stacks*))
+ (setq sb!vm::*control-stacks*
+ (adjust-array sb!vm::*control-stacks*
+ (* 2 (length sb!vm::*control-stacks*))
+ :element-type '(or null (unsigned-byte 32))
+ :initial-element nil)))
+ (setf (aref sb!vm::*control-stacks* control-stack-id)
+ control-stack)
+ (values control-stack control-stack-id)))
+ ;; Allocate a stack group inheriting stacks and bindings from
+ ;; the current stack group.
+ (allocate-child-stack-group (control-stack-id)
+ ;; Save the interrupt-contexts while the size is still
+ ;; bound.
+ (let ((interrupt-contexts
+ (save-interrupt-contexts
+ (make-array 0 :element-type '(unsigned-byte 32)))))
+ ;; Save the binding stack. Note that
+ ;; *interrutps-enabled* could be briefly set during the
+ ;; unbinding and re-binding process so signals are
+ ;; blocked.
+ (let ((old-sigs (sb!unix:unix-sigblock
+ (sb!unix:sigmask :sigint :sigalrm))))
+ (declare (type (unsigned-byte 32) old-sigs))
+ (unbind-binding-stack)
+ (multiple-value-bind (binding-stack binding-stack-size)
+ (save-binding-stack #())
+ (rebind-binding-stack)
+ (sb!unix:unix-sigsetmask old-sigs)
+ ;; Save the Alien stack.
+ (multiple-value-bind
+ (alien-stack alien-stack-size alien-stack-pointer)
+ (save-alien-stack
+ (make-array 0 :element-type '(unsigned-byte 32)))
+ ;; Allocate a stack-group structure.
+ (%make-stack-group
+ :name name
+ :state :active
+ :control-stack-id control-stack-id
+ ;; Save the Eval stack.
+ :eval-stack (copy-seq (the simple-vector
+ sb!kernel:*eval-stack*))
+ :eval-stack-top sb!kernel:*eval-stack-top*
+ ;; Misc stacks.
+ :current-catch-block sb!impl::*current-catch-block*
+ :current-unwind-protect-block
+ sb!impl::*current-unwind-protect-block*
+ ;; Alien stack.
+ :alien-stack alien-stack
+ :alien-stack-size alien-stack-size
+ :alien-stack-pointer alien-stack-pointer
+ ;; Interrupt contexts
+ :interrupt-contexts interrupt-contexts
+ ;; Binding stack.
+ :binding-stack binding-stack
+ :binding-stack-size binding-stack-size
+ ;; Resumer
+ :resumer resumer))))))
+ ;; Allocate a new stack group with fresh stacks and bindings.
+ (allocate-new-stack-group (control-stack-id)
+ (let ((binding-stack (initial-binding-stack)))
+ ;; Allocate a stack-group structure.
+ (%make-stack-group
+ :name name
+ :state :active
+ :control-stack-id control-stack-id
+ ;; Eval stack. Needs at least one element be because
+ ;; push doubles the size when full.
+ :eval-stack (make-array 32)
+ :eval-stack-top 0
+ ;; Misc stacks.
+ :current-catch-block 0
+ :current-unwind-protect-block 0
+ ;; Alien stack.
+ :alien-stack (make-array 0 :element-type '(unsigned-byte 32))
+ :alien-stack-size 0
+ :alien-stack-pointer *alien-stack-top*
+ ;; Interrupt contexts
+ :interrupt-contexts (make-array 0 :element-type
+ '(unsigned-byte 32))
+ ;; Binding stack - some initial bindings.
+ :binding-stack binding-stack
+ :binding-stack-size (length binding-stack)
+ ;; Resumer
+ :resumer resumer))))
+ (let ((child-stack-group nil))
+ (let ((sb!unix::*interrupts-enabled* nil)
+ (sb!impl::*gc-inhibit* t))
+ (multiple-value-bind (control-stack control-stack-id)
+ (allocate-control-stack)
+ (setq child-stack-group
+ (if inherit
+ (allocate-child-stack-group control-stack-id)
+ (allocate-new-stack-group control-stack-id)))
+ ;; Fork the control-stack.
+ (if (sb!vm:control-stack-fork control-stack inherit)
+ ;; Current-stack-group returns the child-stack-group.
+ child-stack-group
+ ;; Child starts.
+ (unwind-protect
+ (progn
+ (setq *current-stack-group* child-stack-group)
+ (assert (eq *current-stack-group*
+ (process-stack-group *current-process*)))
+ ;; Enable interrupts and GC.
+ (setf sb!unix::*interrupts-enabled* t)
+ (setf sb!impl::*gc-inhibit* nil)
+ (when sb!unix::*interrupt-pending*
+ (sb!unix::do-pending-interrupt))
+ (when sb!impl::*need-to-collect-garbage*
+ (sb!impl::maybe-gc))
+ (funcall initial-function))
+ (let ((resumer (stack-group-resumer child-stack-group)))
+ ;; Disable interrupts and GC.
+ (setf sb!unix::*interrupts-enabled* nil)
+ (setf sb!impl::*gc-inhibit* t)
+ (inactivate-stack-group child-stack-group)
+ ;; Verify the resumer.
+ (unless (and resumer
+ (eq (stack-group-state resumer) :active))
+ (format t "*resuming stack-group ~S instead of ~S~%"
+ *initial-stack-group* resumer)
+ (setq resumer *initial-stack-group*))
+ ;; Restore the resumer state.
+ (setq *current-stack-group* resumer)
+ ;; Eval-stack
+ (setf sb!kernel:*eval-stack*
+ (stack-group-eval-stack resumer))
+ (setf sb!kernel:*eval-stack-top*
+ (stack-group-eval-stack-top resumer))
+ ;; The binding stack. Note that
+ ;; *interrutps-enabled* could be briefly set during
+ ;; the unbinding and re-binding process so signals
+ ;; are blocked.
+ (let ((old-sigs (sb!unix:unix-sigblock
+ (sb!unix:sigmask :sigint :sigalrm))))
+ (declare (type (unsigned-byte 32) old-sigs))
+ (unbind-binding-stack)
+ (restore-binding-stack
+ (stack-group-binding-stack resumer)
+ (stack-group-binding-stack-size resumer))
+ (rebind-binding-stack)
+ (sb!unix:unix-sigsetmask old-sigs))
+ ;; Misc stacks.
+ (setf sb!impl::*current-catch-block*
+ (stack-group-current-catch-block resumer))
+ (setf sb!impl::*current-unwind-protect-block*
+ (stack-group-current-unwind-protect-block resumer))
+ ;; The Alien stack
+ (restore-alien-stack
+ (stack-group-alien-stack resumer)
+ (stack-group-alien-stack-size resumer)
+ (stack-group-alien-stack-pointer resumer))
+ ;; Interrupt-contexts.
+ (restore-interrupt-contexts
+ (stack-group-interrupt-contexts resumer))
+ (let ((new-control-stack
+ (aref sb!vm::*control-stacks*
+ (stack-group-control-stack-id resumer))))
+ (declare (type (simple-array (unsigned-byte 32) (*))
+ new-control-stack))
+ (sb!vm:control-stack-return new-control-stack)))))))
+ (when (and sb!unix::*interrupts-enabled* sb!unix::*interrupt-pending*)
+ (sb!unix::do-pending-interrupt))
+ (when (and sb!impl::*need-to-collect-garbage*
+ (not sb!impl::*gc-inhibit*))
+ (sb!impl::maybe-gc))
+ child-stack-group)))
+
+;;; Transfer control to the given stack-group, resuming its execution,
+;;; and saving the *current-stack-group*.
+(defun stack-group-resume (new-stack-group)
+ (declare (type stack-group new-stack-group)
+ (optimize (speed 3)))
+ (assert (and (eq (stack-group-state new-stack-group) :active)
+ (not (eq new-stack-group *current-stack-group*))))
+ (assert (eq new-stack-group (process-stack-group *current-process*)))
+ (let ((sb!unix::*interrupts-enabled* nil)
+ (sb!impl::*gc-inhibit* t))
+ (let* (;; Save the current stack-group on its stack.
+ (stack-group *current-stack-group*)
+ ;; Find the required stack size.
+ (control-stack-end
+ (sb!alien:extern-alien "control_stack_end" sb!alien:unsigned))
+ (control-stack-pointer (sb!kernel:control-stack-pointer-sap))
+ (control-stack-size (- control-stack-end
+ (sb!sys:sap-int control-stack-pointer)))
+ ;; Stack-save array needs three extra elements. The stack
+ ;; pointer will be stored in the first, and the frame
+ ;; pointer and return address push onto the bottom of the
+ ;; stack.
+ (save-stack-size (+ (ceiling control-stack-size 4) 3))
+ ;; the save-stack vector
+ (control-stack (aref sb!vm::*control-stacks*
+ (stack-group-control-stack-id stack-group))))
+ (declare (type (unsigned-byte 29) control-stack-size save-stack-size)
+ (type (simple-array (unsigned-byte 32) (*)) control-stack))
+ ;; Increase the save-stack size if necessary.
+ (when (> save-stack-size (length control-stack))
+ (setf control-stack (adjust-array control-stack save-stack-size
+ :element-type '(unsigned-byte 32)
+ :initial-element 0))
+ (setf (aref sb!vm::*control-stacks*
+ (stack-group-control-stack-id stack-group))
+ control-stack))
+
+ ;; eval-stack
+ (setf (stack-group-eval-stack stack-group) sb!kernel:*eval-stack*)
+ (setf (stack-group-eval-stack-top stack-group)
+ sb!kernel:*eval-stack-top*)
+ (setf sb!kernel:*eval-stack* (stack-group-eval-stack new-stack-group))
+ (setf sb!kernel:*eval-stack-top*
+ (stack-group-eval-stack-top new-stack-group))
+
+ ;; misc stacks
+ (setf (stack-group-current-catch-block stack-group)
+ sb!impl::*current-catch-block*)
+ (setf (stack-group-current-unwind-protect-block stack-group)
+ sb!impl::*current-unwind-protect-block*)
+ (setf sb!impl::*current-catch-block*
+ (stack-group-current-catch-block new-stack-group))
+ (setf sb!impl::*current-unwind-protect-block*
+ (stack-group-current-unwind-protect-block new-stack-group))
+
+ ;; Save the interrupt-contexts.
+ (setf (stack-group-interrupt-contexts stack-group)
+ (save-interrupt-contexts
+ (stack-group-interrupt-contexts stack-group)))
+
+ ;; the binding stack. Note that *interrutps-enabled* could be
+ ;; briefly set during the unbinding and re-binding process so
+ ;; signals are blocked.
+ (let ((old-sigs (sb!unix:unix-sigblock (sb!unix:sigmask :sigint
+ :sigalrm))))
+ (declare (type (unsigned-byte 32) old-sigs))
+ (unbind-binding-stack)
+ (multiple-value-bind (stack size)
+ (save-binding-stack (stack-group-binding-stack stack-group))
+ (setf (stack-group-binding-stack stack-group) stack)
+ (setf (stack-group-binding-stack-size stack-group) size))
+ (restore-binding-stack (stack-group-binding-stack new-stack-group)
+ (stack-group-binding-stack-size
+ new-stack-group))
+ (rebind-binding-stack)
+ (sb!unix:unix-sigsetmask old-sigs))
+
+ ;; Restore the interrupt-contexts.
+ (restore-interrupt-contexts
+ (stack-group-interrupt-contexts new-stack-group))
+
+ ;; The Alien stack
+ (multiple-value-bind (save-stack size alien-stack)
+ (save-alien-stack (stack-group-alien-stack stack-group))
+ (setf (stack-group-alien-stack stack-group) save-stack)
+ (setf (stack-group-alien-stack-size stack-group) size)
+ (setf (stack-group-alien-stack-pointer stack-group) alien-stack))
+ (restore-alien-stack (stack-group-alien-stack new-stack-group)
+ (stack-group-alien-stack-size new-stack-group)
+ (stack-group-alien-stack-pointer new-stack-group))
+ (let ((new-control-stack
+ (aref sb!vm::*control-stacks*
+ (stack-group-control-stack-id new-stack-group))))
+ (declare (type (simple-array (unsigned-byte 32) (*))
+ new-control-stack))
+ (sb!vm:control-stack-resume control-stack new-control-stack))
+ ;; Thread returns.
+ (setq *current-stack-group* stack-group)))
+ (assert (eq *current-stack-group* (process-stack-group *current-process*)))
+ (when (and sb!unix::*interrupts-enabled* sb!unix::*interrupt-pending*)
+ (sb!unix::do-pending-interrupt))
+ (when (and sb!impl::*need-to-collect-garbage*
+ (not sb!impl::*gc-inhibit*))
+ (sb!impl::maybe-gc))
+ (values))
+\f
+;;;; DOUBLE-FLOAT timing functions for use by the scheduler
+
+;;; These timer functions use double-floats for accuracy. In most
+;;; cases consing is avoided.
+
+#!-sb-fluid (declaim (inline get-real-time))
+(defun get-real-time ()
+ #!+sb-doc
+ "Return the real time in seconds."
+ (declare (optimize (speed 3) (safety 0)))
+ (multiple-value-bind (ignore seconds useconds) (sb!unix:unix-gettimeofday)
+ (declare (ignore ignore)
+ (type (unsigned-byte 32) seconds useconds))
+ (+ (coerce seconds 'double-float)
+ (* (coerce useconds 'double-float) 1d-6))))
+
+#!-sb-fluid (declaim (inline get-run-time))
+(defun get-run-time ()
+ #!+sb-doc
+ "Return the run time in seconds"
+ (declare (optimize (speed 3) (safety 0)))
+ (multiple-value-bind (ignore utime-sec utime-usec stime-sec stime-usec)
+ (sb!unix:unix-fast-getrusage sb!unix:rusage_self)
+ (declare (ignore ignore)
+ (type (unsigned-byte 31) utime-sec stime-sec)
+ ;; (Classic CMU CL had these (MOD 1000000) instead, but
+ ;; at least in Linux 2.2.12, the type doesn't seem to be
+ ;; documented anywhere and the observed behavior is to
+ ;; sometimes return 1000000 exactly.)
+ (type (integer 0 1000000) utime-usec stime-usec))
+ (+ (coerce utime-sec 'double-float) (coerce stime-sec 'double-float)
+ (* (+ (coerce utime-usec 'double-float)
+ (coerce stime-usec 'double-float))
+ 1d-6))))
+\f
+;;;; Multi-process support. The interface is based roughly on the
+;;;; CLIM-SYS spec. and support needed for cl-http.
+
+(defvar *multi-processing* t)
+
+(defstruct (process
+ (:constructor %make-process)
+ (:predicate processp)
+ (:print-object
+ (lambda (process stream)
+ (print-unreadable-object (process stream :identity t :type t)
+ (write-string (process-name process) stream)))))
+ (name "Anonymous" :type simple-base-string)
+ (state :killed :type (member :killed :active :inactive))
+ (%whostate nil :type (or null simple-base-string))
+ (initial-function nil :type (or null function))
+ (initial-args nil :type list)
+ (wait-function nil :type (or null function))
+ ;; The real time after which the wait will timeout.
+ (wait-timeout nil :type (or null double-float))
+ (wait-return-value nil :type t)
+ (interrupts '() :type list)
+ (stack-group nil :type (or null stack-group))
+ ;; The real and run times when the current process was last
+ ;; scheduled or yielded.
+ (scheduled-real-time (get-real-time) :type double-float)
+ (scheduled-run-time (get-run-time) :type double-float)
+ ;; Accrued real and run times in seconds.
+ (%real-time 0d0 :type double-float)
+ (%run-time 0d0 :type double-float))
+
+(defun process-whostate (process)
+ #!+sb-doc
+ "Return the process state which is either Run, Killed, or a wait reason."
+ (cond ((eq (process-state process) :killed)
+ "Killed")
+ ((process-wait-function process)
+ (or (process-%whostate process) "Run"))
+ (t
+ "Run")))
+
+#!-sb-fluid (declaim (inline process-active-p))
+(defun process-active-p (process)
+ (eq (process-state process) :active))
+
+#!-sb-fluid (declaim (inline process-alive-p))
+(defun process-alive-p (process)
+ (let ((state (process-state process)))
+ (or (eq state :active) (eq state :inactive))))
+
+(declaim (type (or null process) *current-process*))
+(defvar *current-process* nil)
+
+#!-sb-fluid (declaim (inline current-process))
+(defun current-process ()
+ #!+sb-doc
+ "Returns the current process."
+ *current-process*)
+
+(declaim (list *all-processes*))
+(defvar *all-processes* nil
+ #!+sb-doc
+ "A list of all alive processes.")
+
+#!-sb-fluid (declaim (inline all-processes))
+(defun all-processes ()
+ #!+sb-doc
+ "Return a list of all the live processes."
+ *all-processes*)
+
+(declaim (type (or null process) *intial-process*))
+(defvar *initial-process* nil)
+
+;;; Disable scheduling while the body is executed. Scheduling is
+;;; typically inhibited when process state is being modified.
+(defvar *inhibit-scheduling* t)
+(defmacro without-scheduling (&body body)
+ #!+sb-doc
+ "Execute the body the scheduling disabled."
+ `(let ((inhibit *inhibit-scheduling*))
+ (unwind-protect
+ (progn
+ (setf *inhibit-scheduling* t)
+ ,@body)
+ (setf *inhibit-scheduling* inhibit))))
+
+(defmacro atomic-incf (reference &optional (delta 1))
+ #!+sb-doc
+ "Increments the reference by delta in a single atomic operation"
+ `(without-scheduling
+ (incf ,reference ,delta)))
+
+(defmacro atomic-decf (reference &optional (delta 1))
+ #!+sb-doc
+ "Decrements the reference by delta in a single atomic operation"
+ `(without-scheduling
+ (decf ,reference ,delta)))
+
+(defmacro atomic-push (obj place)
+ #!+sb-doc
+ "Atomically push object onto place."
+ `(without-scheduling
+ (push ,obj ,place)))
+
+(defmacro atomic-pop (place)
+ #!+sb-doc
+ "Atomically pop place."
+ `(without-scheduling
+ (pop ,place)))
+
+;;; If a process other than the initial process throws to the
+;;; %END-OF-THE-WORLD then *QUITTING-LISP* is set to the exit value,
+;;; after which further process creation blocks. If the initial
+;;; process is running the idle loop then it will perform the exit
+;;; when it runs.
+(defvar *quitting-lisp* nil)
+
+;;; Update the processes times for the current and new process before
+;;; a process switch.
+(defun update-process-timers (current-process new-process)
+ (declare (type process current-process new-process)
+ (optimize (speed 3) (safety 0)))
+ (let ((real-time (get-real-time)))
+ (incf (process-%real-time current-process)
+ (- real-time (process-scheduled-real-time current-process)))
+ (setf (process-scheduled-real-time current-process) real-time)
+ (setf (process-scheduled-real-time new-process) real-time))
+ (let ((run-time (get-run-time)))
+ (incf (process-%run-time current-process)
+ (- run-time (process-scheduled-run-time current-process)))
+ (setf (process-scheduled-run-time current-process) run-time)
+ (setf (process-scheduled-run-time new-process) run-time))
+ (values))
+
+(defun make-process (function &key (name "Anonymous"))
+ #!+sb-doc
+ "Make a process which will run function when it starts up. The process
+ may be given an optional name which defaults to Anonymous. The new
+ process has a fresh set of special bindings, with *PACKAGE* set to be
+ the COMMON-LISP-USER package."
+ (declare (type (or null function) function))
+ (cond (*quitting-lisp*
+ ;; No more processes if about to quit lisp.
+ (process-wait "Quitting Lisp" #'(lambda () nil)))
+ ((null function)
+ ;; If function is nil then create a dead process; can be
+ ;; restarted with process-preset.
+ (%make-process :initial-function nil :name name :state :killed))
+ (t
+ ;; Create a stack-group.
+ (let ((process
+ (%make-process
+ :name name
+ :state :active
+ :initial-function function
+ :stack-group
+ (make-stack-group
+ name
+ #'(lambda ()
+ (unwind-protect
+ (catch '%end-of-the-process
+ ;; Catch throws to the %END-OF-THE-WORLD.
+ (setf *quitting-lisp*
+ (catch 'sb!impl::%end-of-the-world
+ (with-simple-restart
+ (destroy "Destroy the process")
+ (setf *inhibit-scheduling* nil)
+ (funcall function))
+ ;; Normal exit.
+ (throw '%end-of-the-process nil))))
+ (setf *inhibit-scheduling* t)
+ ;; About to return to the resumer's
+ ;; stack-group, which in this case is the
+ ;; initial process's stack-group.
+ (setf (process-state *current-process*) :killed)
+ (setf *all-processes*
+ (delete *current-process* *all-processes*))
+ (setf (process-%whostate *current-process*) nil)
+ (setf (process-wait-function *current-process*) nil)
+ (setf (process-wait-timeout *current-process*) nil)
+ (setf (process-wait-return-value *current-process*)
+ nil)
+ (setf (process-interrupts *current-process*) nil)
+ (update-process-timers *current-process*
+ *initial-process*)
+ (setf *current-process* *initial-process*)))
+ *initial-stack-group* nil))))
+ (atomic-push process *all-processes*)
+ process))))
+
+(defun process-interrupt (process function)
+ #!+sb-doc
+ "Interrupt process and cause it to evaluate function."
+ ;; Place the interrupt function at the end of process's interrupts
+ ;; queue, to be called the next time the process is scheduled.
+ (without-scheduling
+ (setf (process-interrupts process)
+ (append (list function) (process-interrupts process))))
+ (process-yield))
+
+(defun destroy-process (process)
+ #!+sb-doc
+ "Destroy a process. The process is sent a interrupt which throws to
+ the end of the process allowing it to unwind gracefully."
+ (declare (type process process))
+ (assert (not (eq process *current-process*)))
+ (without-scheduling
+ (unless (eq (process-state process) :killed)
+ ;; Place a throw to end-of-the-world at the start of process's
+ ;; interrupts queue, to be called the next time the process is
+ ;; scheduled.
+ (push #'(lambda ()
+ (throw '%end-of-the-process nil))
+ (process-interrupts process))
+ ;; Ensure that the process is active so that it can accept this
+ ;; interrupt.
+ (setf (process-state process) :active)))
+ ;; Should we wait until it's dead?
+ (process-yield))
+
+(defun restart-process (process)
+ #!+sb-doc
+ "Restart process by unwinding it to its initial state and calling its
+ initial function."
+ (destroy-process process)
+ (process-wait "Waiting for process to die"
+ #'(lambda ()
+ (eq (process-state process) :killed)))
+ ;; No more processes if about to quit lisp.
+ (when *quitting-lisp*
+ (process-wait "Quitting Lisp" #'(lambda () nil)))
+ ;; Create a new stack-group.
+ (without-scheduling
+ (setf (process-stack-group process)
+ (make-stack-group
+ (process-name process)
+ #'(lambda ()
+ (unwind-protect
+ (catch '%end-of-the-process
+ ;; Catch throws to the %END-OF-THE-WORLD.
+ (setf *quitting-lisp*
+ (catch 'sb!impl::%end-of-the-world
+ (with-simple-restart
+ (destroy "Destroy the process")
+ (setf *inhibit-scheduling* nil)
+ (apply (process-initial-function process)
+ (process-initial-args process)))
+ ;; Normal exit.
+ (throw '%end-of-the-process nil))))
+ (setf *inhibit-scheduling* t)
+ ;; About to return to the resumer's stack-group, which
+ ;; in this case is the initial process's stack-group.
+ (setf (process-state *current-process*) :killed)
+ (setf *all-processes*
+ (delete *current-process* *all-processes*))
+ (setf (process-%whostate *current-process*) nil)
+ (setf (process-wait-function *current-process*) nil)
+ (setf (process-wait-timeout *current-process*) nil)
+ (setf (process-wait-return-value *current-process*) nil)
+ (setf (process-interrupts *current-process*) nil)
+ (update-process-timers *current-process* *initial-process*)
+ (setf *current-process* *initial-process*)))
+ *initial-stack-group* nil))
+ (setf (process-%whostate process) nil)
+ (setf (process-wait-function process) nil)
+ (setf (process-wait-timeout process) nil)
+ (setf (process-wait-return-value process) nil)
+ (setf (process-interrupts process) nil)
+ (setf (process-state process) :active)
+ (push process *all-processes*))
+ process)
+
+(defun process-preset (process function &rest args)
+ #!+sb-doc
+ "Restart process, unwinding it to its initial state and calls
+ function with args."
+ (setf (process-initial-function process) function)
+ (setf (process-initial-args process) args)
+ (restart-process process))
+
+(defun disable-process (process)
+ #!+sb-doc
+ "Disable process from being runnable until enabled."
+ (without-scheduling
+ (assert (not (eq (process-state process) :killed)))
+ (setf (process-state process) :inactive)))
+
+(defun enable-process (process)
+ #!+sb-doc
+ "Allow process to become runnable again after it has been disabled."
+ (without-scheduling
+ (assert (not (eq (process-state process) :killed)))
+ (setf (process-state process) :active)))
+
+(defun process-wait (whostate predicate)
+ #!+sb-doc
+ "Causes the process to wait until predicate returns True. Processes
+ can only call process-wait when scheduling is enabled, and the predicate
+ can not call process-wait. Since the predicate may be evaluated may
+ times by the scheduler it should be relative fast native compiled code.
+ The single True predicate value is returned."
+ (assert (not *inhibit-scheduling*))
+ (assert (not (process-wait-function *current-process*)))
+ ;; Don't need the disable scheduling here because the scheduler
+ ;; doesn't mess with the whostate or timeout until the function is
+ ;; setup, unless the process is interrupted in which case the
+ ;; scheduler restores the state when execution resumers here.
+ (setf (process-%whostate *current-process*) whostate)
+ (setf (process-wait-timeout *current-process*) nil)
+ (setf (process-wait-function *current-process*) predicate)
+ (process-yield)
+ (process-wait-return-value *current-process*))
+
+(defun process-wait-with-timeout (whostate timeout predicate)
+ (declare (type (or fixnum float) timeout))
+ #!+sb-doc
+ "Causes the process to wait until predicate returns True, or the
+ number of seconds specified by timeout has elapsed. The timeout may
+ be a fixnum or a float in seconds. The single True predicate value is
+ returned, or NIL if the timeout was reached."
+ (assert (not *inhibit-scheduling*))
+ (assert (not (process-wait-function *current-process*)))
+ ;; Don't need the disable scheduling here because the scheduler
+ ;; doesn't mess with the whostate or timeout until the function is
+ ;; setup, unless the process is interrupted in which case the
+ ;; scheduler restores the state when execution resumers here.
+ (setf (process-%whostate *current-process*) whostate)
+ (let ((timeout (etypecase timeout
+ (fixnum
+ (coerce timeout 'double-float))
+ (single-float
+ (coerce timeout 'double-float))
+ (double-float
+ (coerce timeout 'double-float)))))
+ (declare (double-float timeout))
+ (setf (process-wait-timeout *current-process*)
+ (+ timeout (get-real-time)))
+ (setf (process-wait-function *current-process*) predicate))
+ (process-yield)
+ (process-wait-return-value *current-process*))
+
+;;; The remaining processes in the scheduling queue for this cycle,
+;;; the remainder of *all-processes*. The *current-process* is the
+;;; first element of this list.
+(defvar *remaining-processes* nil)
+
+;;; The idle process will only run when there are no other runnable
+;;; processes.
+(defvar *idle-process* nil)
+
+;;; Decide when to allow the idle process to run.
+(defun run-idle-process-p ()
+ ;; Check whether there are any other runnable processes.
+ (dolist (process *all-processes* t)
+ (when (and (not (eq process *idle-process*))
+ (process-active-p process)
+ (not (process-wait-function process)))
+ (return nil))))
+
+(defun shutdown-multi-processing ()
+ #!+sb-doc
+ "Try to gracefully destroy all the processes giving them some
+ chance to unwind, before shutting down multi-processing. This is
+ currently necessary before a purify and is performed before a save-lisp.
+ Multi-processing can be restarted by calling init-multi-processing."
+ (assert (eq *current-process* *initial-process*) ()
+ "Only the *initial-process* can shutdown multi-processing")
+
+ (let ((destroyed-processes nil))
+ (do ((cnt 0 (1+ cnt)))
+ ((> cnt 10))
+ (declare (type sb!kernel:index cnt))
+ (dolist (process *all-processes*)
+ (when (and (not (eq process *current-process*))
+ (process-active-p process)
+ (not (member process destroyed-processes)))
+ (destroy-process process)
+ (push process destroyed-processes)))
+ (unless (rest *all-processes*)
+ (return))
+ (format t "destroyed ~D process~:P; remaining ~D~%"
+ (length destroyed-processes) (length *all-processes*))
+ (process-yield)))
+
+ (start-sigalrm-yield 0 0) ; Off with the interrupts.
+ ;; Reset the multi-processing state.
+ (setf *inhibit-scheduling* t)
+ (setf *initial-process* nil)
+ (setf *idle-process* nil)
+ (setf *current-process* nil)
+ (setf *all-processes* nil)
+ (setf *remaining-processes* nil)
+ ;; Clean up the stack groups.
+ (setf sb!vm::*control-stacks*
+ (make-array 0 :element-type '(or null (unsigned-byte 32))
+ :initial-element nil))
+ (setf *current-stack-group* nil)
+ (setf *initial-stack-group* nil))
+
+;;; A useful idle process loop, waiting on events using the select
+;;; based event server, which is assumed to be setup to call
+;;; process-yielding periodically.
+(declaim (double-float *idle-loop-timeout*))
+(defvar *idle-loop-timeout* 0.1d0)
+(defun idle-process-loop ()
+ #!+sb-doc
+ "An idle loop to be run by the initial process. The select based event
+ server is called with a timeout calculated from the minimum of the
+ *idle-loop-timeout* and the time to the next process wait timeout.
+ To avoid this delay when there are runnable processes the *idle-process*
+ should be setup to the *initial-process*. If one of the processes quits
+ by throwing to %end-of-the-world then *quitting-lisp* will have been
+ set to the exit value which is noted by the idle loop which tries to
+ exit gracefully destroying all the processes and giving them a chance
+ to unwind."
+ (declare (optimize (speed 3)))
+ (assert (eq *current-process* *initial-process*) ()
+ "Only the *initial-process* is intended to run the idle loop")
+ ;; Ensure the *idle-process* is setup.
+ (unless *idle-process*
+ (setf *idle-process* *current-process*))
+ ;; Adjust the process name.
+ (setf (process-name *current-process*) "Idle Loop")
+ (do ()
+ (*quitting-lisp*)
+ ;; Calculate the wait period.
+ (let ((real-time (get-real-time))
+ (timeout *idle-loop-timeout*))
+ (declare (double-float timeout))
+ (dolist (process *all-processes*)
+ (when (process-active-p process)
+ (let ((wait-timeout (process-wait-timeout process)))
+ (when wait-timeout
+ (let ((delta (- wait-timeout real-time)))
+ (when (< delta timeout)
+ (sb!vm::double-float-reg-bias timeout)
+ (setf timeout delta)))))))
+ (when (> timeout 1d-5)
+ (sb!sys:serve-all-events timeout))
+ (process-yield)))
+ (shutdown-multi-processing)
+ (throw 'sb!impl::%end-of-the-world *quitting-lisp*))
+
+;;; the scheduler
+(defun process-yield ()
+ (declare (optimize (speed 3)))
+ #!+sb-doc
+ "Allow other processes to run."
+ (unless *inhibit-scheduling*
+ ;; Catch any FP exceptions before entering the scheduler.
+ (sb!kernel:float-wait)
+ ;; Inhibit recursive entry of the scheduler.
+ (setf *inhibit-scheduling* t)
+ (assert (eq (first *remaining-processes*) *current-process*))
+ (assert (eq *current-stack-group* (process-stack-group *current-process*)))
+ (loop
+ ;; Rotate the queue.
+ (setf *remaining-processes*
+ (or (rest *remaining-processes*) *all-processes*))
+
+ (let ((next (first *remaining-processes*)))
+ ;; Shouldn't see any :killed porcesses here.
+ (assert (process-alive-p next))
+
+ (cond
+ ;; New process at the head of the queue?
+ ((eq next *current-process*))
+ ;; Ignore inactive processes.
+ ((not (process-active-p next)))
+ ;; If the next process has pending interrupts then return to
+ ;; it to execute these.
+ ((process-interrupts next)
+ (update-process-timers *current-process* next)
+ (setf *current-process* next)
+ (stack-group-resume (process-stack-group next)))
+ (t
+ ;; If not waiting then return.
+ (let ((wait-fn (process-wait-function next)))
+ (cond
+ ((null wait-fn)
+ ;; Skip the idle process if there are other runnable
+ ;; processes.
+ (when (or (not (eq next *idle-process*))
+ (run-idle-process-p))
+ (update-process-timers *current-process* next)
+ (setf *current-process* next)
+ (stack-group-resume (process-stack-group next))))
+ (t
+ ;; Check the wait function in the current context
+ ;; saving a stack-group switch; although
+ ;; *current-process* is setup.
+ (let ((current-process *current-process*))
+ (setf *current-process* next)
+ ;; Predicate true?
+ (let ((wait-return-value (funcall wait-fn)))
+ (cond (wait-return-value
+ ;; Flush the wait.
+ (setf (process-wait-return-value next)
+ wait-return-value)
+ (setf (process-wait-timeout next) nil)
+ (setf (process-wait-function next) nil)
+ (setf (process-%whostate next) nil)
+ (update-process-timers current-process next)
+ (stack-group-resume (process-stack-group next)))
+ (t
+ ;; Timeout?
+ (let ((timeout (process-wait-timeout next)))
+ (when (and timeout (> (get-real-time) timeout))
+ ;; Flush the wait.
+ (setf (process-wait-return-value next) nil)
+ (setf (process-wait-timeout next) nil)
+ (setf (process-wait-function next) nil)
+ (setf (process-%whostate next) nil)
+ (update-process-timers current-process next)
+ (stack-group-resume
+ (process-stack-group next)))))))
+ ;; Restore the *current-process*.
+ (setf *current-process* current-process))))))))
+
+ ;; May have just returned, or have cycled the queue.
+ (let ((next (first *remaining-processes*)))
+ ;; Tolerate :killed processes on the *remaining-processes* list
+ ;; saving their deletion from this list when killed; will be
+ ;; corrected when it cycles back to *all-processes*.
+ (when (and (process-active-p next)
+ ;; Current process at the head of the queue?
+ (eq next *current-process*))
+ ;; Run any pending interrupts.
+ (let ((interrupt (pop (process-interrupts next))))
+ (declare (type (or null function) interrupt))
+ (cond (interrupt
+ ;; Save and reset any wait reasons so that the
+ ;; interrupt can wait. The return-value is also
+ ;; saved and restored in case a process is
+ ;; interrupted before it is read.
+ (let ((wait-function (process-wait-function next))
+ (wait-timeout (process-wait-timeout next))
+ (whostate (process-%whostate next))
+ (wait-return-value (process-wait-return-value next)))
+ (setf (process-wait-function next) nil)
+ (setf (process-wait-timeout next) nil)
+ (setf (process-%whostate next) nil)
+ (setf (process-wait-return-value next) nil)
+ ;; Allow recursive scheduling during the interrupt
+ ;; processing. Only one interrupt is processed on
+ ;; each scheduler queue cycle. The process doesn't
+ ;; return until there are no interrupts.
+ (setf *inhibit-scheduling* nil)
+ (funcall interrupt)
+ (setf *inhibit-scheduling* t)
+ ;; Restore any wait reasons.
+ (setf (process-wait-function next) wait-function)
+ (setf (process-wait-timeout next) wait-timeout)
+ (setf (process-%whostate next) whostate)
+ (setf (process-wait-return-value next) wait-return-value)))
+ (t
+ ;; Check the wait function.
+ (let ((wait-fn (process-wait-function next)))
+ (cond
+ ((null wait-fn)
+ (when (or (not (eq next *idle-process*))
+ (run-idle-process-p))
+ (return)))
+ (t
+ ;; Predicate true?
+ (let ((return-value (funcall wait-fn)))
+ (when return-value
+ ;; Flush the wait.
+ (setf (process-wait-return-value next) return-value)
+ (setf (process-wait-timeout next) nil)
+ (setf (process-wait-function next) nil)
+ (setf (process-%whostate next) nil)
+ (return)))
+ ;; Timeout?
+ (let ((timeout (process-wait-timeout next)))
+ (when (and timeout (> (get-real-time) timeout))
+ ;; Flush the wait.
+ (setf (process-wait-return-value next) nil)
+ (setf (process-wait-timeout next) nil)
+ (setf (process-wait-function next) nil)
+ (setf (process-%whostate next) nil)
+ (return))))))))))))
+ (setf *inhibit-scheduling* nil)))
+
+;;; Return the real time in seconds accrued while the process was scheduled.
+(defun process-real-time (process)
+ #!+sb-doc
+ "Return the accrued real time elapsed while the given process was
+ scheduled. The returned time is a double-float in seconds."
+ (declare (type process process))
+ (if (eq process *current-process*)
+ (without-scheduling
+ (let ((real-time (get-real-time)))
+ (+ (process-%real-time process)
+ (- real-time (process-scheduled-real-time process)))))
+ (process-%real-time process)))
+
+;;; The run time in seconds accrued while the process was scheduled.
+(defun process-run-time (process)
+ #!+sb-doc
+ "Return the accrued run time elapsed for the given process. The returned
+ time is a double-float in seconds."
+ (declare (type process process))
+ (if (eq process *current-process*)
+ (without-scheduling
+ (let ((run-time (get-run-time)))
+ (+ (process-%run-time process)
+ (- run-time (process-scheduled-run-time process)))))
+ (process-%run-time process)))
+
+;;; Return the real time in seconds elapsed since the process was last
+;;; de-scheduled.
+(defun process-idle-time (process)
+ #!+sb-doc
+ "Return the real time elapsed since the given process was last
+ descheduled. The returned time is a double-float in seconds."
+ (declare (type process process))
+ (if (eq process *current-process*)
+ 0
+ (without-scheduling
+ (let ((real-time (get-real-time)))
+ (- real-time (process-scheduled-real-time process))))))
+
+;;; Start a regular interrupt to switch processes. This may not be a
+;;; good idea yet as the SBCL code is not too interrupt safe.
+(defun start-sigalrm-yield (&optional (sec 0) (usec 500000))
+ #!+sb-doc
+ "Start a regular SIGALRM interrupt which calls process-yield. An optional
+ time in seconds and micro seconds may be provided. Note that SBCL code
+ base is not too interrupt safe so this may cause problems."
+ (declare (fixnum sec usec))
+ ;; Disable the gencgc pointer filter to improve interrupt safety.
+ #!+(and gencgc nil)
+ (setf (sb!alien:extern-alien "enable_pointer_filter" sb!alien:unsigned) 0)
+ (flet ((sigalrm-handler (signal info context)
+ (declare (ignore signal info context))
+ (cond ((<= sb!impl::*free-interrupt-context-index* 1)
+ #+nil (format t ".~%")
+ (process-yield))
+ (t
+ #+nil (format t "-~%")))))
+ (sb!sys:enable-interrupt :sigalrm #'sigalrm-handler))
+ (sb!unix:unix-setitimer :real sec usec 0 1)
+ (values))
+
+;;; Startup multi-processing, initializing the initial process. This
+;;; must be called before use of the other multi-process functions.
+(defun init-multi-processing ()
+ (unless *initial-process*
+ (init-stack-groups)
+ (setf *initial-process*
+ (%make-process
+ :name "initial"
+ :state :active
+ :stack-group *initial-stack-group*))
+ (setf *current-process* *initial-process*)
+ (setf *all-processes* (list *initial-process*))
+ (setf *remaining-processes* *all-processes*)
+ #+nil (start-sigalrm-yield)
+ (setf *inhibit-scheduling* nil)))
+
+(pushnew 'init-multi-processing sb!int:*after-save-initializations*)
+
+;;; Scrub the stored stacks of all the processes.
+(defun scrub-all-processes-stacks ()
+ (sb!sys:without-interrupts
+ (dolist (process *all-processes*)
+ (let ((stack-group (process-stack-group process)))
+ (when stack-group
+ (scrub-stack-group-stacks stack-group))))))
+(pushnew 'scrub-all-processes-stacks sb!ext:*before-gc-hooks*)
+
+;;; Wait until FD is usable for DIRECTION.
+(defun process-wait-until-fd-usable (fd direction &optional timeout)
+ #!+sb-doc
+ "Wait until FD is usable for DIRECTION and return True. DIRECTION should be
+ either :INPUT or :OUTPUT. TIMEOUT, if supplied, is the number of seconds to
+ wait before giving up and returning NIL."
+ (declare (type sb!kernel:index fd)
+ (type (or real null) timeout)
+ (optimize (speed 3)))
+ (if (or (eq *current-process* *initial-process*)
+ ;; Can't call process-wait if the scheduling is inhibited.
+ *inhibit-scheduling*)
+ ;; The initial-process calls the event server to block.
+ (sb!sys:wait-until-fd-usable fd direction timeout)
+ ;; Other processes use process-wait.
+ (flet ((fd-usable-for-input ()
+ (declare (optimize (speed 3) (safety 1)))
+ (not (eql (sb!alien:with-alien ((read-fds
+ (sb!alien:struct sb!unix:fd-set)))
+ (sb!unix:fd-zero read-fds)
+ (sb!unix:fd-set fd read-fds)
+ (sb!unix:unix-fast-select
+ (1+ fd) (sb!alien:addr read-fds) nil nil 0 0))
+ 0)))
+ (fd-usable-for-output ()
+ (declare (optimize (speed 3) (safety 1)))
+ (not (eql (sb!alien:with-alien ((write-fds
+ (sb!alien:struct sb!unix:fd-set)))
+ (sb!unix:fd-zero write-fds)
+ (sb!unix:fd-set fd write-fds)
+ (sb!unix:unix-fast-select
+ (1+ fd) nil (sb!alien:addr write-fds) nil 0 0))
+ 0))))
+
+ (ecase direction
+ (:input
+ (unless (fd-usable-for-input)
+ ;; Wait until input possible.
+ (sb!sys:with-fd-handler (fd :input
+ #'(lambda (fd)
+ (declare (ignore fd)
+ (optimize (speed 3)
+ (safety 0)))
+ (sb!mp:process-yield)))
+ (if timeout
+ (sb!mp:process-wait-with-timeout "Input Wait"
+ timeout
+ #'fd-usable-for-input)
+ (sb!mp:process-wait "Input Wait" #'fd-usable-for-input)))))
+ (:output
+ (unless (fd-usable-for-output)
+ ;; Wait until output possible.
+ (sb!sys:with-fd-handler (fd :output
+ #'(lambda (fd)
+ (declare (ignore fd)
+ (optimize (speed 3)
+ (safety 0)))
+ (sb!mp:process-yield)))
+ (if timeout
+ (sb!mp:process-wait-with-timeout "Output Wait"
+ timeout
+ #'fd-usable-for-output)
+ (sb!mp:process-wait "Output Wait"
+ #'fd-usable-for-output)))))))))
+
+;;; Redefine the sleep function to call process-wait-with-timeout,
+;;; rather than blocking.
+(defun sleep (n)
+ #!+sb-doc
+ "This function causes execution to be suspended for N seconds. N may
+ be any non-negative, non-complex number."
+ (when (or (not (realp n))
+ (minusp n))
+ (error "Invalid argument to SLEEP: ~S.~%~
+ Must be a non-negative, non-complex number."
+ n))
+ (cond ((or (eq *current-process* *initial-process*)
+ ;; Can't call process-wait if the scheduling is inhibited.
+ *inhibit-scheduling*)
+ ;; The initial-process may block.
+ (multiple-value-bind (sec usec)
+ (if (integerp n)
+ (values n 0)
+ (multiple-value-bind (sec frac) (truncate n)
+ (values sec (truncate frac 1e-6))))
+ (sb!unix:unix-select 0 0 0 0 sec usec))
+ nil)
+ (t
+ (process-wait-with-timeout "Sleep" n (constantly nil)))))
+
+(defun show-processes (&optional verbose)
+ #!+sb-doc
+ "Show the all the processes, their whostate, and state. If the optional
+ verbose argument is true then the run, real, and idle times are also
+ shown."
+ (fresh-line)
+ (dolist (process *all-processes*)
+ (when (eq process *current-process*)
+ (format t "* "))
+ (format t "~S ~S ~A~%" process (process-whostate process)
+ (process-state process))
+ (when verbose
+ (format t "~4TRun time: ~,3f; Real time: ~,3f; Idle time: ~,3f~%"
+ (process-run-time process)
+ (process-real-time process)
+ (process-idle-time process)))))
+
+(defun top-level ()
+ #!+sb-doc
+ "Top-level READ-EVAL-PRINT loop for processes."
+ (let ((* nil) (** nil) (*** nil)
+ (- nil) (+ nil) (++ nil) (+++ nil)
+ (/// nil) (// nil) (/ nil)
+ (magic-eof-cookie (cons :eof nil)))
+ (loop
+ (with-simple-restart (abort "Return to Top-Level.")
+ (catch 'sb!impl::top-level-catcher
+ (sb!unix:unix-sigsetmask 0)
+ (let ((sb!impl::*in-top-level-catcher* t))
+ (loop
+ (sb!sys:scrub-control-stack)
+ (fresh-line)
+ (princ (if (functionp sb!int:*prompt*)
+ (funcall sb!int:*prompt*)
+ sb!int:*prompt*))
+ (force-output)
+ (let ((form (read *standard-input* nil magic-eof-cookie)))
+ (cond ((not (eq form magic-eof-cookie))
+ (let ((results
+ (multiple-value-list
+ (sb!int:interactive-eval form))))
+ (dolist (result results)
+ (fresh-line)
+ (prin1 result))))
+ (t
+ (throw '%end-of-the-process nil)))))))))))
+
+(defun startup-idle-and-top-level-loops ()
+ #!+sb-doc
+ "Enter the idle loop, starting a new process to run the top level loop.
+ The awaking of sleeping processes is timed better with the idle loop process
+ running, and starting a new process for the top level loop supports a
+ simultaneous interactive session. Such an initialization will likely be the
+ default when there is better MP debug support etc."
+ (assert (eq *current-process* *initial-process*) ()
+ "Only the *initial-process* is intended to run the idle loop")
+ (init-multi-processing) ; Initialise in case MP had been shutdown.
+ ;; Start a new Top Level loop.
+ (make-process #'top-level :name "top level loop")
+ ;; Enter the idle loop.
+ (idle-process-loop))
+\f
+;;;; simple locking
+
+(defstruct (lock (:constructor make-lock (&optional name)))
+ (name nil :type (or null simple-base-string))
+ (process nil :type (or null process)))
+(def!method print-object ((lock lock) stream)
+ (print-unreadable-object (lock stream :identity t)
+ (write-string "Lock" stream)
+ (let ((name (lock-name lock)))
+ (when name
+ (format stream " ~A" name)))
+ (let ((process (lock-process lock)))
+ (cond (process
+ (format stream ", held by ~S" process))
+ (t
+ (write-string ", free" stream))))))
+
+;;; Wait for the lock to be free and acquire it for the *current-process*.
+(defun lock-wait (lock whostate)
+ (declare (type lock lock))
+ (process-wait whostate
+ #'(lambda ()
+ (declare (optimize (speed 3)))
+ #!-mp-i486
+ (unless (lock-process lock)
+ (setf (lock-process lock) *current-process*))
+ #!+mp-i486
+ (null (sb!kernel:%instance-set-conditional
+ lock 2 nil *current-process*)))))
+
+;;; Wait with a timeout for the lock to be free and acquire it for the
+;;; *current-process*.
+(defun lock-wait-with-timeout (lock whostate timeout)
+ (declare (type lock lock))
+ (process-wait-with-timeout
+ whostate timeout
+ #'(lambda ()
+ (declare (optimize (speed 3)))
+ #!-mp-i486
+ (unless (lock-process lock)
+ (setf (lock-process lock) *current-process*))
+ #!+mp-i486
+ (null (sb!kernel:%instance-set-conditional
+ lock 2 nil *current-process*)))))
+
+;;; Atomically seize a lock if it's free.
+#!-mp-i486
+(defun seize-lock (lock)
+ (declare (type lock lock)
+ (optimize (speed 3)))
+ (sb!sys:without-interrupts
+ (unless (lock-process lock)
+ (setf (lock-process lock) *current-process*))))
+
+(defmacro with-lock-held ((lock &optional (whostate "Lock Wait") &key timeout)
+ &body body)
+
+ #!+sb-doc
+ "Execute the body with the lock held. If the lock is held by another
+ process then the current process waits until the lock is released or a
+ optional timeout is reached - recursive locks are allowed. The
+ optional wait timeout is a time in seconds acceptable to
+ process-wait-with-timeout. The results of the body are return upon
+ success and NIL is return if the timeout is reached."
+ (let ((have-lock (gensym)))
+ `(let ((,have-lock (eq (lock-process ,lock) *current-process*)))
+ (unwind-protect
+ ,(if timeout
+ `(when (cond (,have-lock)
+ #!+mp-i486 ((null (sb!kernel:%instance-set-conditional
+ ,lock 2 nil *current-process*)))
+ #!-mp-i486 ((seize-lock ,lock))
+ ((null ,timeout)
+ (lock-wait ,lock ,whostate))
+ ((lock-wait-with-timeout
+ ,lock ,whostate ,timeout)))
+ ,@body)
+ `(progn
+ (unless (or ,have-lock
+ #!+mp-i486 (null (sb!kernel:%instance-set-conditional
+ ,lock 2 nil *current-process*))
+ #!-mp-i486 (seize-lock ,lock))
+ (lock-wait ,lock ,whostate))
+ ,@body))
+ (unless ,have-lock
+ #!+mp-i486 (sb!kernel:%instance-set-conditional
+ ,lock 2 *current-process* nil)
+ #!-mp-i486 (when (eq (lock-process ,lock) *current-process*)
+ (setf (lock-process ,lock) nil)))))))
--- /dev/null
+;;;; a tracing facility based on breakpoints
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB-DEBUG")
+
+(file-comment
+ "$Header$")
+
+;;; FIXME: Why, oh why, doesn't the SB-DEBUG package use the SB-DI package?
+;;; That would let us get rid of a whole lot of stupid prefixes..
+
+(defvar *trace-values* nil
+ #+sb-doc
+ "This is bound to the returned values when evaluating :BREAK-AFTER and
+ :PRINT-AFTER forms.")
+
+(defvar *trace-indentation-step* 2
+ #+sb-doc
+ "the increase in trace indentation at each call level")
+
+(defvar *max-trace-indentation* 40
+ #+sb-doc
+ "If the trace indentation exceeds this value, then indentation restarts at
+ 0.")
+
+(defvar *trace-encapsulate-default* :default
+ #+sb-doc
+ "the default value for the :ENCAPSULATE option to TRACE")
+\f
+;;;; internal state
+
+;;; a hash table that maps each traced function to the TRACE-INFO. The entry
+;;; for a closure is the shared function-entry object.
+(defvar *traced-functions* (make-hash-table :test 'eq))
+
+;;; A TRACE-INFO object represents all the information we need to trace a
+;;; given function.
+(def!struct (trace-info
+ (:make-load-form-fun sb-kernel:just-dump-it-normally)
+ (:print-object (lambda (x stream)
+ (print-unreadable-object (x stream :type t)
+ (prin1 (trace-info-what x) stream)))))
+ ;; the original representation of the thing traced
+ (what nil :type (or function cons symbol))
+ ;; Is WHAT a function name whose definition we should track?
+ (named nil)
+ ;; Is tracing to be done by encapsulation rather than breakpoints?
+ ;; T implies NAMED.
+ (encapsulated *trace-encapsulate-default*)
+ ;; Has this trace been untraced?
+ (untraced nil)
+ ;; breakpoints we set up to trigger tracing
+ (start-breakpoint nil :type (or sb-di:breakpoint null))
+ (end-breakpoint nil :type (or sb-di:breakpoint null))
+ ;; the list of function names for WHEREIN, or NIL if unspecified
+ (wherein nil :type list)
+
+ ;; The following slots represent the forms that we are supposed to evaluate
+ ;; on each iteration. Each form is represented by a cons (Form . Function),
+ ;; where the Function is the cached result of coercing Form to a function.
+ ;; Forms which use the current environment are converted with
+ ;; PREPROCESS-FOR-EVAL, which gives us a one-arg function.
+ ;; Null environment forms also have one-arg functions, but the argument is
+ ;; ignored. NIL means unspecified (the default.)
+
+ ;; current environment forms
+ (condition nil)
+ (break nil)
+ ;; List of current environment forms
+ (print () :type list)
+ ;; null environment forms
+ (condition-after nil)
+ (break-after nil)
+ ;; list of null environment forms
+ (print-after () :type list))
+
+;;; This is a list of conses (function-end-cookie .
+;;; condition-satisfied), which we use to note distinct dynamic
+;;; entries into functions. When we enter a traced function, we add a
+;;; entry to this list holding the new end-cookie and whether the
+;;; trace condition was satisfied. We must save the trace condition so
+;;; that the after breakpoint knows whether to print. The length of
+;;; this list tells us the indentation to use for printing TRACE
+;;; messages.
+;;;
+;;; This list also helps us synchronize the TRACE facility dynamically
+;;; for detecting non-local flow of control. Whenever execution hits a
+;;; :function-end breakpoint used for TRACE'ing, we look for the
+;;; function-end-cookie at the top of *traced-entries*. If it is not
+;;; there, we discard any entries that come before our cookie.
+;;;
+;;; When we trace using encapsulation, we bind this variable and add
+;;; (NIL . CONDITION-SATISFIED), so a NIL "cookie" marks an
+;;; encapsulated tracing.
+(defvar *traced-entries* ())
+(declaim (list *traced-entries*))
+
+;;; This variable is used to discourage infinite recursions when some trace
+;;; action invokes a function that is itself traced. In this case, we quietly
+;;; ignore the inner tracing.
+(defvar *in-trace* nil)
+\f
+;;;; utilities
+
+;;; Given a function name, a function or a macro name, return the raw
+;;; definition and some information. "Raw" means that if the result is a
+;;; closure, we strip off the closure and return the bare code. The second
+;;; value is T if the argument was a function name. The third value is one of
+;;; :COMPILED, :COMPILED-CLOSURE, :INTERPRETED, :INTERPRETED-CLOSURE and
+;;; :FUNCALLABLE-INSTANCE.
+(defun trace-fdefinition (x)
+ (multiple-value-bind (res named-p)
+ (typecase x
+ (symbol
+ (cond ((special-operator-p x)
+ (error "can't trace special form ~S" x))
+ ((macro-function x))
+ (t
+ (values (fdefinition x) t))))
+ (function x)
+ (t (values (fdefinition x) t)))
+ (if (sb-eval:interpreted-function-p res)
+ (values res named-p (if (sb-eval:interpreted-function-closure res)
+ :interpreted-closure :interpreted))
+ (case (sb-kernel:get-type res)
+ (#.sb-vm:closure-header-type
+ (values (sb-kernel:%closure-function res)
+ named-p
+ :compiled-closure))
+ (#.sb-vm:funcallable-instance-header-type
+ (values res named-p :funcallable-instance))
+ (t (values res named-p :compiled))))))
+
+;;; When a function name is redefined, and we were tracing that name, then
+;;; untrace the old definition and trace the new one.
+(defun trace-redefined-update (fname new-value)
+ (when (fboundp fname)
+ (let* ((fun (trace-fdefinition fname))
+ (info (gethash fun *traced-functions*)))
+ (when (and info (trace-info-named info))
+ (untrace-1 fname)
+ (trace-1 fname info new-value)))))
+(push #'trace-redefined-update sb-int:*setf-fdefinition-hook*)
+
+;;; Annotate some forms to evaluate with pre-converted functions. Each form
+;;; is really a cons (exp . function). Loc is the code location to use for
+;;; the lexical environment. If Loc is NIL, evaluate in the null environment.
+;;; If Form is NIL, just return NIL.
+(defun coerce-form (form loc)
+ (when form
+ (let ((exp (car form)))
+ (if (sb-di:code-location-p loc)
+ (let ((fun (sb-di:preprocess-for-eval exp loc)))
+ (cons exp
+ #'(lambda (frame)
+ (let ((*current-frame* frame))
+ (funcall fun frame)))))
+ (let* ((bod (ecase loc
+ ((nil) exp)
+ (:encapsulated
+ `(flet ((sb-debug:arg (n)
+ (declare (special argument-list))
+ (elt argument-list n)))
+ (declare (ignorable #'sb-debug:arg))
+ ,exp))))
+ (fun (coerce `(lambda () ,bod) 'function)))
+ (cons exp
+ #'(lambda (frame)
+ (declare (ignore frame))
+ (let ((*current-frame* nil))
+ (funcall fun)))))))))
+(defun coerce-form-list (forms loc)
+ (mapcar #'(lambda (x) (coerce-form x loc)) forms))
+
+;;; Print indentation according to the number of trace entries.
+;;; Entries whose condition was false don't count.
+(defun print-trace-indentation ()
+ (let ((depth 0))
+ (dolist (entry *traced-entries*)
+ (when (cdr entry) (incf depth)))
+ (format t
+ "~@V,0T~D: "
+ (+ (mod (* depth *trace-indentation-step*)
+ (- *max-trace-indentation* *trace-indentation-step*))
+ *trace-indentation-step*)
+ depth)))
+
+;;; Return true if one of the Names appears on the stack below Frame.
+(defun trace-wherein-p (frame names)
+ (do ((frame (sb-di:frame-down frame) (sb-di:frame-down frame)))
+ ((not frame) nil)
+ (when (member (sb-di:debug-function-name (sb-di:frame-debug-function
+ frame))
+ names
+ :test #'equal)
+ (return t))))
+
+;;; Handle print and print-after options.
+(defun trace-print (frame forms)
+ (dolist (ele forms)
+ (fresh-line)
+ (print-trace-indentation)
+ (format t "~S = ~S" (car ele) (funcall (cdr ele) frame))))
+
+;;; Test a break option, and break if true.
+(defun trace-maybe-break (info break where frame)
+ (when (and break (funcall (cdr break) frame))
+ (sb-di:flush-frames-above frame)
+ (let ((*stack-top-hint* frame))
+ (break "breaking ~A traced call to ~S:"
+ where
+ (trace-info-what info)))))
+
+;;; This function discards any invalid cookies on our simulated stack.
+;;; Encapsulated entries are always valid, since we bind *traced-entries* in
+;;; the encapsulation.
+(defun discard-invalid-entries (frame)
+ (loop
+ (when (or (null *traced-entries*)
+ (let ((cookie (caar *traced-entries*)))
+ (or (not cookie)
+ (sb-di:function-end-cookie-valid-p frame cookie))))
+ (return))
+ (pop *traced-entries*)))
+\f
+;;;; hook functions
+
+;;; Return a closure that can be used for a function start breakpoint hook
+;;; function and a closure that can be used as the FUNCTION-END-COOKIE
+;;; function. The first communicates the sense of the Condition to the second
+;;; via a closure variable.
+(defun trace-start-breakpoint-fun (info)
+ (let (conditionp)
+ (values
+ #'(lambda (frame bpt)
+ (declare (ignore bpt))
+ (discard-invalid-entries frame)
+ (let ((condition (trace-info-condition info))
+ (wherein (trace-info-wherein info)))
+ (setq conditionp
+ (and (not *in-trace*)
+ (or (not condition)
+ (funcall (cdr condition) frame))
+ (or (not wherein)
+ (trace-wherein-p frame wherein)))))
+
+ (when conditionp
+ (let ((sb-kernel:*current-level* 0)
+ (*standard-output* *trace-output*)
+ (*in-trace* t))
+ (fresh-line)
+ (print-trace-indentation)
+ (if (trace-info-encapsulated info)
+ (locally (declare (special basic-definition argument-list))
+ (prin1 `(,(trace-info-what info) ,@argument-list)))
+ (print-frame-call frame))
+ (terpri)
+ (trace-print frame (trace-info-print info)))
+ (trace-maybe-break info (trace-info-break info) "before" frame)))
+
+ #'(lambda (frame cookie)
+ (declare (ignore frame))
+ (push (cons cookie conditionp) *traced-entries*)))))
+
+;;; This prints a representation of the return values delivered.
+;;; First, this checks to see that cookie is at the top of
+;;; *traced-entries*; if it is not, then we need to adjust this list
+;;; to determine the correct indentation for output. We then check to
+;;; see whether the function is still traced and that the condition
+;;; succeeded before printing anything.
+(defun trace-end-breakpoint-fun (info)
+ #'(lambda (frame bpt *trace-values* cookie)
+ (declare (ignore bpt))
+ (unless (eq cookie (caar *traced-entries*))
+ (setf *traced-entries*
+ (member cookie *traced-entries* :key #'car)))
+
+ (let ((entry (pop *traced-entries*)))
+ (when (and (not (trace-info-untraced info))
+ (or (cdr entry)
+ (let ((cond (trace-info-condition-after info)))
+ (and cond (funcall (cdr cond) frame)))))
+ (let ((sb-kernel:*current-level* 0)
+ (*standard-output* *trace-output*)
+ (*in-trace* t))
+ (fresh-line)
+ (pprint-logical-block (*standard-output* nil)
+ (print-trace-indentation)
+ (pprint-indent :current 2)
+ (format t "~S returned" (trace-info-what info))
+ (dolist (v *trace-values*)
+ (write-char #\space)
+ (pprint-newline :linear)
+ (prin1 v)))
+ (terpri)
+ (trace-print frame (trace-info-print-after info)))
+ (trace-maybe-break info
+ (trace-info-break-after info)
+ "after"
+ frame)))))
+\f
+;;; This function is called by the trace encapsulation. It calls the
+;;; breakpoint hook functions with NIL for the breakpoint and cookie, which
+;;; we have cleverly contrived to work for our hook functions.
+(defun trace-call (info)
+ (multiple-value-bind (start cookie) (trace-start-breakpoint-fun info)
+ (let ((frame (sb-di:frame-down (sb-di:top-frame))))
+ (funcall start frame nil)
+ (let ((*traced-entries* *traced-entries*))
+ (declare (special basic-definition argument-list))
+ (funcall cookie frame nil)
+ (let ((vals
+ (multiple-value-list
+ (apply basic-definition argument-list))))
+ (funcall (trace-end-breakpoint-fun info) frame nil vals nil)
+ (values-list vals))))))
+\f
+;;; Trace one function according to the specified options. We copy the
+;;; trace info (it was a quoted constant), fill in the functions, and then
+;;; install the breakpoints or encapsulation.
+;;;
+;;; If non-null, Definition is the new definition of a function that we are
+;;; automatically retracing.
+(defun trace-1 (function-or-name info &optional definition)
+ (multiple-value-bind (fun named kind)
+ (if definition
+ (values definition t
+ (nth-value 2 (trace-fdefinition definition)))
+ (trace-fdefinition function-or-name))
+ (when (gethash fun *traced-functions*)
+ ;; FIXME: should be STYLE-WARNING
+ (warn "Function ~S is already TRACE'd, retracing it." function-or-name)
+ (untrace-1 fun))
+
+ (let* ((debug-fun (sb-di:function-debug-function fun))
+ (encapsulated
+ (if (eq (trace-info-encapsulated info) :default)
+ (ecase kind
+ (:compiled nil)
+ (:compiled-closure
+ (unless (functionp function-or-name)
+ (warn "Tracing shared code for ~S:~% ~S"
+ function-or-name
+ fun))
+ nil)
+ ((:interpreted :interpreted-closure :funcallable-instance)
+ t))
+ (trace-info-encapsulated info)))
+ (loc (if encapsulated
+ :encapsulated
+ (sb-di:debug-function-start-location debug-fun)))
+ (info (make-trace-info
+ :what function-or-name
+ :named named
+ :encapsulated encapsulated
+ :wherein (trace-info-wherein info)
+ :condition (coerce-form (trace-info-condition info) loc)
+ :break (coerce-form (trace-info-break info) loc)
+ :print (coerce-form-list (trace-info-print info) loc)
+ :break-after (coerce-form (trace-info-break-after info) nil)
+ :condition-after
+ (coerce-form (trace-info-condition-after info) nil)
+ :print-after
+ (coerce-form-list (trace-info-print-after info) nil))))
+
+ (dolist (wherein (trace-info-wherein info))
+ (unless (or (stringp wherein)
+ (fboundp wherein))
+ (warn ":WHEREIN name ~S is not a defined global function."
+ wherein)))
+
+ (cond
+ (encapsulated
+ (unless named
+ (error "can't use encapsulation to trace anonymous function ~S"
+ fun))
+ (sb-int:encapsulate function-or-name 'trace `(trace-call ',info)))
+ (t
+ (multiple-value-bind (start-fun cookie-fun)
+ (trace-start-breakpoint-fun info)
+ (let ((start (sb-di:make-breakpoint start-fun debug-fun
+ :kind :function-start))
+ (end (sb-di:make-breakpoint
+ (trace-end-breakpoint-fun info)
+ debug-fun :kind :function-end
+ :function-end-cookie cookie-fun)))
+ (setf (trace-info-start-breakpoint info) start)
+ (setf (trace-info-end-breakpoint info) end)
+ ;; The next two forms must be in the order in which they appear,
+ ;; since the start breakpoint must run before the function-end
+ ;; breakpoint's start helper (which calls the cookie function.)
+ ;; One reason is that cookie function requires that the CONDITIONP
+ ;; shared closure variable be initialized.
+ (sb-di:activate-breakpoint start)
+ (sb-di:activate-breakpoint end)))))
+
+ (setf (gethash fun *traced-functions*) info)))
+
+ function-or-name)
+\f
+;;;; the TRACE macro
+
+;;; Parse leading trace options off of SPECS, modifying INFO accordingly. The
+;;; remaining portion of the list is returned when we encounter a plausible
+;;; function name.
+(defun parse-trace-options (specs info)
+ (let ((current specs))
+ (loop
+ (when (endp current) (return))
+ (let ((option (first current))
+ (value (cons (second current) nil)))
+ (case option
+ (:report (error "stub: The :REPORT option is not yet implemented."))
+ (:condition (setf (trace-info-condition info) value))
+ (:condition-after
+ (setf (trace-info-condition info) (cons nil nil))
+ (setf (trace-info-condition-after info) value))
+ (:condition-all
+ (setf (trace-info-condition info) value)
+ (setf (trace-info-condition-after info) value))
+ (:wherein
+ (setf (trace-info-wherein info)
+ (if (listp (car value)) (car value) value)))
+ (:encapsulate
+ (setf (trace-info-encapsulated info) (car value)))
+ (:break (setf (trace-info-break info) value))
+ (:break-after (setf (trace-info-break-after info) value))
+ (:break-all
+ (setf (trace-info-break info) value)
+ (setf (trace-info-break-after info) value))
+ (:print
+ (setf (trace-info-print info)
+ (append (trace-info-print info) (list value))))
+ (:print-after
+ (setf (trace-info-print-after info)
+ (append (trace-info-print-after info) (list value))))
+ (:print-all
+ (setf (trace-info-print info)
+ (append (trace-info-print info) (list value)))
+ (setf (trace-info-print-after info)
+ (append (trace-info-print-after info) (list value))))
+ (t (return)))
+ (pop current)
+ (unless current
+ (error "missing argument to ~S TRACE option" option))
+ (pop current)))
+ current))
+
+;;; Compute the expansion of TRACE in the non-trivial case (arguments
+;;; specified.) If there are no :FUNCTION specs, then don't use a LET. This
+;;; allows TRACE to be used without the full interpreter.
+(defun expand-trace (specs)
+ (collect ((binds)
+ (forms))
+ (let* ((global-options (make-trace-info))
+ (current (parse-trace-options specs global-options)))
+ (loop
+ (when (endp current) (return))
+ (let ((name (pop current))
+ (options (copy-trace-info global-options)))
+ (cond
+ ((eq name :function)
+ (let ((temp (gensym)))
+ (binds `(,temp ,(pop current)))
+ (forms `(trace-1 ,temp ',options))))
+ ((and (keywordp name)
+ (not (or (fboundp name) (macro-function name))))
+ (error "unknown TRACE option: ~S" name))
+ (t
+ (forms `(trace-1 ',name ',options))))
+ (setq current (parse-trace-options current options)))))
+
+ (if (binds)
+ `(let ,(binds) (list ,@(forms)))
+ `(list ,@(forms)))))
+
+(defun %list-traced-functions ()
+ (loop for x being each hash-value in *traced-functions*
+ collect (trace-info-what x)))
+
+(defmacro trace (&rest specs)
+ #+sb-doc
+ "TRACE {Option Global-Value}* {Name {Option Value}*}*
+ TRACE is a debugging tool that provides information when specified functions
+ are called. In its simplest form:
+ (trace Name-1 Name-2 ...)
+ (The Names are not evaluated.)
+
+ Options allow modification of the default behavior. Each option is a pair
+ of an option keyword and a value form. Global options are specified before
+ the first name, and affect all functions traced by a given use of TRACE.
+ Options may also be interspersed with function names, in which case they
+ act as local options, only affecting tracing of the immediately preceding
+ function name. Local options override global options.
+
+ By default, TRACE causes a printout on *TRACE-OUTPUT* each time that
+ one of the named functions is entered or returns. (This is the
+ basic, ANSI Common Lisp behavior of TRACE.) As an SBCL extension, the
+ :REPORT SB-EXT:PROFILE option can be used to instead cause information
+ to be silently recorded to be inspected later using the SB-EXT:PROFILE
+ function.
+
+ The following options are defined:
+
+ :REPORT Report-Type
+ If Report-Type is TRACE (the default) then information is reported
+ by printing immediately. If Report-Type is SB-EXT:PROFILE, information
+ is recorded for later summary by calls to SB-EXT:PROFILE. If
+ Report-Type is NIL, then the only effect of the trace is to execute
+ other options (e.g. PRINT or BREAK).
+
+ :CONDITION Form
+ :CONDITION-AFTER Form
+ :CONDITION-ALL Form
+ If :CONDITION is specified, then TRACE does nothing unless Form
+ evaluates to true at the time of the call. :CONDITION-AFTER is
+ similar, but suppresses the initial printout, and is tested when the
+ function returns. :CONDITION-ALL tries both before and after.
+
+ :BREAK Form
+ :BREAK-AFTER Form
+ :BREAK-ALL Form
+ If specified, and Form evaluates to true, then the debugger is invoked
+ at the start of the function, at the end of the function, or both,
+ according to the respective option.
+
+ :PRINT Form
+ :PRINT-AFTER Form
+ :PRINT-ALL Form
+ In addition to the usual printout, the result of evaluating Form is
+ printed at the start of the function, at the end of the function, or
+ both, according to the respective option. Multiple print options cause
+ multiple values to be printed.
+
+ :WHEREIN Names
+ If specified, Names is a function name or list of names. TRACE does
+ nothing unless a call to one of those functions encloses the call to
+ this function (i.e. it would appear in a backtrace.) Anonymous
+ functions have string names like \"DEFUN FOO\".
+
+ :ENCAPSULATE {:DEFAULT | T | NIL}
+ If T, the tracing is done via encapsulation (redefining the function
+ name) rather than by modifying the function. :DEFAULT is the default,
+ and means to use encapsulation for interpreted functions and funcallable
+ instances, breakpoints otherwise. When encapsulation is used, forms are
+ *not* evaluated in the function's lexical environment, but SB-DEBUG:ARG
+ can still be used.
+
+ :FUNCTION Function-Form
+ This is a not really an option, but rather another way of specifying
+ what function to trace. The Function-Form is evaluated immediately,
+ and the resulting function is traced.
+
+ :CONDITION, :BREAK and :PRINT forms are evaluated in the lexical environment
+ of the called function; SB-DEBUG:VAR and SB-DEBUG:ARG can be used. The
+ -AFTER and -ALL forms are evaluated in the null environment."
+ (if specs
+ (expand-trace specs)
+ '(%list-traced-functions)))
+\f
+;;;; untracing
+
+;;; Untrace one function.
+(defun untrace-1 (function-or-name)
+ (let* ((fun (trace-fdefinition function-or-name))
+ (info (gethash fun *traced-functions*)))
+ (cond
+ ((not info)
+ (warn "Function is not TRACEd: ~S" function-or-name))
+ (t
+ (cond
+ ((trace-info-encapsulated info)
+ (sb-int:unencapsulate (trace-info-what info) 'trace))
+ (t
+ (sb-di:delete-breakpoint (trace-info-start-breakpoint info))
+ (sb-di:delete-breakpoint (trace-info-end-breakpoint info))))
+ (setf (trace-info-untraced info) t)
+ (remhash fun *traced-functions*)))))
+
+;;; Untrace all traced functions.
+(defun untrace-all ()
+ (dolist (fun (%list-traced-functions))
+ (untrace-1 fun))
+ t)
+
+(defmacro untrace (&rest specs)
+ #+sb-doc
+ "Remove tracing from the specified functions. With no args, untrace all
+ functions."
+ (if specs
+ (collect ((res))
+ (let ((current specs))
+ (loop
+ (unless current (return))
+ (let ((name (pop current)))
+ (res (if (eq name :function)
+ `(untrace-1 ,(pop current))
+ `(untrace-1 ',name)))))
+ `(progn ,@(res) t)))
+ '(untrace-all)))
--- /dev/null
+;;;; numeric things needed within the cross-compiler
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!KERNEL")
+
+(file-comment
+ "$Header$")
+
+;;; FIXME: This probably belongs in SB-INT instead of SB-KERNEL.
+;;; And couldn't it be limited to FIXNUM arguments?
+(defun positive-primep (x)
+ #!+sb-doc
+ "Returns T iff X is a positive prime integer."
+ (declare (integer x))
+ (if (<= x 5)
+ (and (>= x 2) (/= x 4))
+ (and (not (evenp x))
+ (not (zerop (rem x 3)))
+ (do ((q 6)
+ (r 1)
+ (inc 2 (logxor inc 6)) ;; 2,4,2,4...
+ (d 5 (+ d inc)))
+ ((or (= r 0) (> d q)) (/= r 0))
+ (declare (fixnum inc))
+ (multiple-value-setq (q r) (truncate x d))))))
--- /dev/null
+;;;; that part of the CMU CL package.lisp file which can run on the
+;;;; cross-compilation host
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!IMPL")
+
+(file-comment
+ "$Header$")
+\f
+;;;; the PACKAGE-HASHTABLE structure
+
+;;; comment from CMU CL:
+;;; Packages are implemented using a special kind of hashtable. It is
+;;; an open hashtable with a parallel 8-bit I-vector of hash-codes. The
+;;; primary purpose of the hash for each entry is to reduce paging by
+;;; allowing collisions and misses to be detected without paging in the
+;;; symbol and pname for an entry. If the hash for an entry doesn't
+;;; match that for the symbol that we are looking for, then we can
+;;; go on without touching the symbol, pname, or even hastable vector.
+;;; It turns out that, contrary to my expectations, paging is a very
+;;; important consideration the design of the package representation.
+;;; Using a similar scheme without the entry hash, the fasloader was
+;;; spending more than half its time paging in INTERN.
+;;; The hash code also indicates the status of an entry. If it zero,
+;;; the entry is unused. If it is one, then it is deleted.
+;;; Double-hashing is used for collision resolution.
+
+(sb!xc:deftype hash-vector () '(simple-array (unsigned-byte 8) (*)))
+
+(sb!xc:defstruct (package-hashtable (:constructor %make-package-hashtable ())
+ (:copier nil))
+ ;; The g-vector of symbols.
+ ;; FIXME: could just be type SIMPLE-VECTOR, with REQUIRED-ARGUMENT
+ (table nil :type (or simple-vector null))
+ ;; The i-vector of pname hash values.
+ ;; FIXME: could just be type HASH-VECTOR, with REQUIRED-ARGUMENT
+ (hash nil :type (or hash-vector null))
+ ;; The total number of entries allowed before resizing.
+ ;;
+ ;; FIXME: CAPACITY would be a more descriptive name. (This is
+ ;; related to but not quite the same as HASH-TABLE-SIZE, so calling
+ ;; it SIZE seems somewhat misleading.)
+ (size 0 :type index)
+ ;; The remaining number of entries that can be made before we have to rehash.
+ (free 0 :type index)
+ ;; The number of deleted entries.
+ (deleted 0 :type index))
+\f
+;;;; the PACKAGE structure
+
+;;; KLUDGE: We use DEF!STRUCT to define this not because we need to
+;;; manipulate target package objects on the cross-compilation host,
+;;; but only because its MAKE-LOAD-FORM function needs to be hooked
+;;; into the pre-CLOS DEF!STRUCT MAKE-LOAD-FORM system. The DEF!STRUCT
+;;; side-effect of defining a new PACKAGE type on the
+;;; cross-compilation host is just a nuisance, and in order to avoid
+;;; breaking the cross-compilation host, we need to work around it
+;;; around by putting the new PACKAGE type (and the PACKAGEP predicate
+;;; too..) into SB!XC. -- WHN 20000309
+(def!struct (sb!xc:package
+ (:constructor internal-make-package)
+ (:make-load-form-fun (lambda (p)
+ (values `(find-undeleted-package-or-lose
+ ',(package-name p))
+ nil)))
+ (:predicate sb!xc:packagep))
+ #!+sb-doc
+ "the standard structure for the description of a package"
+ ;; the name of the package, or NIL for a deleted package
+ (%name nil :type (or simple-string null))
+ ;; nickname strings
+ (%nicknames () :type list)
+ ;; packages used by this package
+ (%use-list () :type list)
+ ;; a list of all the hashtables for inherited symbols. This is
+ ;; derived from %USE-LIST, but maintained separately from %USE-LIST
+ ;; for some reason. (Perhaps the reason is that when FIND-SYMBOL*
+ ;; hits an inherited symbol, it pulls it to the head of the list.)
+ ;;
+ ;; FIXME: This needs a more-descriptive name
+ ;; (USED-PACKAGE-HASH-TABLES?). It also needs an explanation of why
+ ;; the last entry is NIL. Perhaps it should even just go away and
+ ;; let us do indirection on the fly through %USE-LIST. (If so,
+ ;; benchmark to make sure that performance doesn't get stomped..)
+ ;; (If benchmark performance is important, this should prob'ly
+ ;; become a vector instead of a list.)
+ (tables (list nil) :type list)
+ ;; packages that use this package
+ (%used-by-list () :type list)
+ ;; PACKAGE-HASHTABLEs of internal & external symbols
+ (internal-symbols (required-argument) :type package-hashtable)
+ (external-symbols (required-argument) :type package-hashtable)
+ ;; shadowing symbols
+ (%shadowing-symbols () :type list)
+ ;; documentation string for this package
+ (doc-string nil :type (or simple-string null)))
+\f
+;;;; iteration macros
+
+(defmacro-mundanely do-symbols ((var &optional
+ (package '*package*)
+ result-form)
+ &body body-decls)
+ #!+sb-doc
+ "DO-SYMBOLS (VAR [PACKAGE [RESULT-FORM]]) {DECLARATION}* {TAG | FORM}*
+ Executes the FORMs at least once for each symbol accessible in the given
+ PACKAGE with VAR bound to the current symbol."
+ (multiple-value-bind (body decls) body-decls
+ (let ((flet-name (gensym "DO-SYMBOLS-")))
+ `(block nil
+ (flet ((,flet-name (,var)
+ ,@decls
+ (tagbody ,@body)))
+ (let* ((package (find-undeleted-package-or-lose ,package))
+ (shadows (package-%shadowing-symbols package)))
+ (flet ((iterate-over-hash-table (table ignore)
+ (let ((hash-vec (package-hashtable-hash table))
+ (sym-vec (package-hashtable-table table)))
+ (declare (type (simple-array (unsigned-byte 8) (*))
+ hash-vec)
+ (type simple-vector sym-vec))
+ (dotimes (i (length sym-vec))
+ (when (>= (aref hash-vec i) 2)
+ (let ((sym (aref sym-vec i)))
+ (declare (inline member))
+ (unless (member sym ignore :test #'string=)
+ (,flet-name sym))))))))
+ (iterate-over-hash-table (package-internal-symbols package) nil)
+ (iterate-over-hash-table (package-external-symbols package) nil)
+ (dolist (use (package-%use-list package))
+ (iterate-over-hash-table (package-external-symbols use)
+ shadows)))))
+ (let ((,var nil))
+ (declare (ignorable ,var))
+ ,@decls
+ ,result-form)))))
+
+(defmacro-mundanely do-external-symbols ((var &optional
+ (package '*package*)
+ result-form)
+ &body body-decls)
+ #!+sb-doc
+ "DO-EXTERNAL-SYMBOLS (VAR [PACKAGE [RESULT-FORM]]) {DECL}* {TAG | FORM}*
+ Executes the FORMs once for each external symbol in the given PACKAGE with
+ VAR bound to the current symbol."
+ (multiple-value-bind (body decls) (parse-body body-decls nil)
+ (let ((flet-name (gensym "DO-SYMBOLS-")))
+ `(block nil
+ (flet ((,flet-name (,var)
+ ,@decls
+ (tagbody ,@body)))
+ (let* ((package (find-undeleted-package-or-lose ,package))
+ (table (package-external-symbols package))
+ (hash-vec (package-hashtable-hash table))
+ (sym-vec (package-hashtable-table table)))
+ (declare (type (simple-array (unsigned-byte 8) (*))
+ hash-vec)
+ (type simple-vector sym-vec))
+ (dotimes (i (length sym-vec))
+ (when (>= (aref hash-vec i) 2)
+ (,flet-name (aref sym-vec i))))))
+ (let ((,var nil))
+ (declare (ignorable ,var))
+ ,@decls
+ ,result-form)))))
+
+(defmacro-mundanely do-all-symbols ((var &optional
+ result-form)
+ &body body-decls)
+ #!+sb-doc
+ "DO-ALL-SYMBOLS (VAR [RESULT-FORM]) {DECLARATION}* {TAG | FORM}*
+ Executes the FORMs once for each symbol in every package with VAR bound
+ to the current symbol."
+ (multiple-value-bind (body decls) (parse-body body-decls nil)
+ (let ((flet-name (gensym "DO-SYMBOLS-")))
+ `(block nil
+ (flet ((,flet-name (,var)
+ ,@decls
+ (tagbody ,@body)))
+ (dolist (package (list-all-packages))
+ (flet ((iterate-over-hash-table (table)
+ (let ((hash-vec (package-hashtable-hash table))
+ (sym-vec (package-hashtable-table table)))
+ (declare (type (simple-array (unsigned-byte 8) (*))
+ hash-vec)
+ (type simple-vector sym-vec))
+ (dotimes (i (length sym-vec))
+ (when (>= (aref hash-vec i) 2)
+ (,flet-name (aref sym-vec i)))))))
+ (iterate-over-hash-table (package-internal-symbols package))
+ (iterate-over-hash-table (package-external-symbols package)))))
+ (let ((,var nil))
+ (declare (ignorable ,var))
+ ,@decls
+ ,result-form)))))
+\f
+;;;; WITH-PACKAGE-ITERATOR
+
+(defmacro-mundanely with-package-iterator ((mname package-list
+ &rest symbol-types)
+ &body body)
+ #!+sb-doc
+ "Within the lexical scope of the body forms, MNAME is defined via macrolet
+ such that successive invocations of (MNAME) will return the symbols,
+ one by one, from the packages in PACKAGE-LIST. SYMBOL-TYPES may be
+ any of :INHERITED :EXTERNAL :INTERNAL."
+ (let* ((packages (gensym))
+ (these-packages (gensym))
+ (ordered-types (let ((res nil))
+ (dolist (kind '(:inherited :external :internal)
+ res)
+ (when (member kind symbol-types)
+ (push kind res))))) ; Order SYMBOL-TYPES.
+ (counter (gensym))
+ (kind (gensym))
+ (hash-vector (gensym))
+ (vector (gensym))
+ (package-use-list (gensym))
+ (init-macro (gensym))
+ (end-test-macro (gensym))
+ (real-symbol-p (gensym))
+ (inherited-symbol-p (gensym))
+ (BLOCK (gensym)))
+ `(let* ((,these-packages ,package-list)
+ (,packages `,(mapcar #'(lambda (package)
+ (if (packagep package)
+ package
+ (find-package package)))
+ (if (consp ,these-packages)
+ ,these-packages
+ (list ,these-packages))))
+ (,counter nil)
+ (,kind (car ,packages))
+ (,hash-vector nil)
+ (,vector nil)
+ (,package-use-list nil))
+ ,(if (member :inherited ordered-types)
+ `(setf ,package-use-list (package-%use-list (car ,packages)))
+ `(declare (ignore ,package-use-list)))
+ (macrolet ((,init-macro (next-kind)
+ (let ((symbols (gensym)))
+ `(progn
+ (setf ,',kind ,next-kind)
+ (setf ,',counter nil)
+ ,(case next-kind
+ (:internal
+ `(let ((,symbols (package-internal-symbols
+ (car ,',packages))))
+ (when ,symbols
+ (setf ,',vector (package-hashtable-table ,symbols))
+ (setf ,',hash-vector (package-hashtable-hash ,symbols)))))
+ (:external
+ `(let ((,symbols (package-external-symbols
+ (car ,',packages))))
+ (when ,symbols
+ (setf ,',vector (package-hashtable-table ,symbols))
+ (setf ,',hash-vector
+ (package-hashtable-hash ,symbols)))))
+ (:inherited
+ `(let ((,symbols (and ,',package-use-list
+ (package-external-symbols
+ (car ,',package-use-list)))))
+ (when ,symbols
+ (setf ,',vector (package-hashtable-table ,symbols))
+ (setf ,',hash-vector
+ (package-hashtable-hash ,symbols)))))))))
+ (,end-test-macro (this-kind)
+ `,(let ((next-kind (cadr (member this-kind
+ ',ordered-types))))
+ (if next-kind
+ `(,',init-macro ,next-kind)
+ `(if (endp (setf ,',packages (cdr ,',packages)))
+ (return-from ,',BLOCK)
+ (,',init-macro ,(car ',ordered-types)))))))
+ (when ,packages
+ ,(when (null symbol-types)
+ (error 'program-error
+ :format-control
+ "Must supply at least one of :internal, :external, or ~
+ :inherited."))
+ ,(dolist (symbol symbol-types)
+ (unless (member symbol '(:internal :external :inherited))
+ (error 'program-error
+ :format-control
+ "~S is not one of :internal, :external, or :inherited."
+ :format-argument symbol)))
+ (,init-macro ,(car ordered-types))
+ (flet ((,real-symbol-p (number)
+ (> number 1)))
+ (macrolet ((,mname ()
+ `(block ,',BLOCK
+ (loop
+ (case ,',kind
+ ,@(when (member :internal ',ordered-types)
+ `((:internal
+ (setf ,',counter
+ (position-if #',',real-symbol-p ,',hash-vector
+ :start (if ,',counter
+ (1+ ,',counter)
+ 0)))
+ (if ,',counter
+ (return-from ,',BLOCK
+ (values t (svref ,',vector ,',counter)
+ ,',kind (car ,',packages)))
+ (,',end-test-macro :internal)))))
+ ,@(when (member :external ',ordered-types)
+ `((:external
+ (setf ,',counter
+ (position-if #',',real-symbol-p ,',hash-vector
+ :start (if ,',counter
+ (1+ ,',counter)
+ 0)))
+ (if ,',counter
+ (return-from ,',BLOCK
+ (values t (svref ,',vector ,',counter)
+ ,',kind (car ,',packages)))
+ (,',end-test-macro :external)))))
+ ,@(when (member :inherited ',ordered-types)
+ `((:inherited
+ (flet ((,',inherited-symbol-p (number)
+ (when (,',real-symbol-p number)
+ (let* ((p (position
+ number ,',hash-vector
+ :start (if ,',counter
+ (1+ ,',counter)
+ 0)))
+ (s (svref ,',vector p)))
+ (eql (nth-value
+ 1 (find-symbol
+ (symbol-name s)
+ (car ,',packages)))
+ :inherited)))))
+ (setf ,',counter
+ (position-if #',',inherited-symbol-p
+ ,',hash-vector
+ :start (if ,',counter
+ (1+ ,',counter)
+ 0))))
+ (cond (,',counter
+ (return-from
+ ,',BLOCK
+ (values t (svref ,',vector ,',counter)
+ ,',kind (car ,',packages))
+ ))
+ (t
+ (setf ,',package-use-list
+ (cdr ,',package-use-list))
+ (cond ((endp ,',package-use-list)
+ (setf ,',packages (cdr ,',packages))
+ (when (endp ,',packages)
+ (return-from ,',BLOCK))
+ (setf ,',package-use-list
+ (package-%use-list
+ (car ,',packages)))
+ (,',init-macro ,(car
+ ',ordered-types)))
+ (t (,',init-macro :inherited)
+ (setf ,',counter nil)))))))))))))
+ ,@body)))))))
--- /dev/null
+;;;; functions used to parse function/macro bodies
+;;;;
+;;;; FIXME: In an early attempt to bootstrap SBCL, this file
+;;;; was loaded before fundamental things like DEFUN and AND and OR
+;;;; were defined, and it still bears scars from the attempt to
+;;;; make that work. (TAGBODY, forsooth..) It should be cleaned up.
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!INT")
+
+(file-comment
+ "$Header$")
+
+(/show0 "entering parse-body.lisp")
+
+;;; Given a sequence of declarations (and possibly a documentation
+;;; string) followed by other forms (as occurs in the bodies of DEFUN,
+;;; DEFMACRO, etc.) return (VALUES FORMS DECLS DOC), where DECLS holds
+;;; declarations, DOC holds a doc string (or NIL if none), and FORMS
+;;; holds the other forms.
+;;;
+;;; If DOC-STRING-ALLOWED is NIL, then no forms will be treated as
+;;; documentation strings.
+(defun sb!sys:parse-body (body &optional (doc-string-allowed t))
+ (let ((reversed-decls nil)
+ (forms body)
+ (doc nil))
+ ;; Since we don't have macros like AND, OR, and NOT yet, it's
+ ;; hard to express these tests clearly. Giving them names
+ ;; seems to help a little bit.
+ (flet ((doc-string-p (x remaining-forms)
+ (if (stringp x)
+ (if doc-string-allowed
+ ;; ANSI 3.4.11 explicitly requires that a doc
+ ;; string be followed by another form (either an
+ ;; ordinary form or a declaration). Hence:
+ (if remaining-forms
+ (if doc
+ ;; ANSI 3.4.11 says that the consequences of
+ ;; duplicate doc strings are unspecified.
+ ;; That's probably not something the
+ ;; programmer intends. We raise an error so
+ ;; that this won't pass unnoticed.
+ (error "duplicate doc string ~S" x)
+ t)))))
+ (declaration-p (x)
+ (if (consp x)
+ (eq (car x) 'declare))))
+ (tagbody
+ :again
+ (if forms
+ (let ((form1 (first forms)))
+ ;; Note: The (IF (IF ..) ..) stuff is because we don't
+ ;; have the macro AND yet.:-|
+ (if (doc-string-p form1 (rest forms))
+ (setq doc form1)
+ (if (declaration-p form1)
+ (setq reversed-decls
+ (cons form1 reversed-decls))
+ (go :done)))
+ (setq forms (rest forms))
+ (go :again)))
+ :done)
+ (values forms
+ (nreverse reversed-decls)
+ doc))))
+
+(/show0 "leaving parse-body.lisp")
--- /dev/null
+;;;; error-handling machinery for PARSE-DEFMACRO, separated from PARSE-DEFMACRO
+;;;; code itself because the happy path can be handled earlier in the bootstrap
+;;;; sequence than DEFINE-CONDITION can be, and because some of the error
+;;;; handling depends on SBCL extensions, while PARSE-DEFMACRO needs to run in
+;;;; the cross-compiler on the host Common Lisp
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!KERNEL")
+
+(file-comment
+ "$Header$")
+
+;;; We save space in macro definitions by calling this function.
+(defun do-arg-count-error (error-kind name arg lambda-list minimum maximum)
+ (multiple-value-bind (fname sb!debug:*stack-top-hint*) (find-caller-name)
+ (error 'defmacro-ll-arg-count-error
+ :kind error-kind
+ :function-name fname
+ :name name
+ :argument arg
+ :lambda-list lambda-list
+ :minimum minimum :maximum maximum)))
+
+(define-condition defmacro-lambda-list-bind-error (error)
+ ((kind :reader defmacro-lambda-list-bind-error-kind
+ :initarg :kind)
+ (name :reader defmacro-lambda-list-bind-error-name
+ :initarg :name
+ :initform nil)))
+
+(defun print-defmacro-ll-bind-error-intro (condition stream)
+ (if (null (defmacro-lambda-list-bind-error-name condition))
+ (format stream
+ "error while parsing arguments to ~A in ~S:~%"
+ (defmacro-lambda-list-bind-error-kind condition)
+ (condition-function-name condition))
+ (format stream
+ "error while parsing arguments to ~A ~S:~%"
+ (defmacro-lambda-list-bind-error-kind condition)
+ (defmacro-lambda-list-bind-error-name condition))))
+
+(define-condition defmacro-bogus-sublist-error
+ (defmacro-lambda-list-bind-error)
+ ((object :reader defmacro-bogus-sublist-error-object :initarg :object)
+ (lambda-list :reader defmacro-bogus-sublist-error-lambda-list
+ :initarg :lambda-list))
+ (:report
+ (lambda (condition stream)
+ (print-defmacro-ll-bind-error-intro condition stream)
+ (format stream
+ "bogus sublist:~% ~S~%to satisfy lambda-list:~% ~:S~%"
+ (defmacro-bogus-sublist-error-object condition)
+ (defmacro-bogus-sublist-error-lambda-list condition)))))
+
+(define-condition defmacro-ll-arg-count-error (defmacro-lambda-list-bind-error)
+ ((argument :reader defmacro-ll-arg-count-error-argument :initarg :argument)
+ (lambda-list :reader defmacro-ll-arg-count-error-lambda-list
+ :initarg :lambda-list)
+ (minimum :reader defmacro-ll-arg-count-error-minimum :initarg :minimum)
+ (maximum :reader defmacro-ll-arg-count-error-maximum :initarg :maximum))
+ (:report
+ (lambda (condition stream)
+ (print-defmacro-ll-bind-error-intro condition stream)
+ (format stream
+ "invalid number of elements in:~% ~:S~%~
+ to satisfy lambda-list:~% ~:S~%"
+ (defmacro-ll-arg-count-error-argument condition)
+ (defmacro-ll-arg-count-error-lambda-list condition))
+ (cond ((null (defmacro-ll-arg-count-error-maximum condition))
+ (format stream "at least ~D expected"
+ (defmacro-ll-arg-count-error-minimum condition)))
+ ((= (defmacro-ll-arg-count-error-minimum condition)
+ (defmacro-ll-arg-count-error-maximum condition))
+ (format stream "exactly ~D expected"
+ (defmacro-ll-arg-count-error-minimum condition)))
+ (t
+ (format stream "between ~D and ~D expected"
+ (defmacro-ll-arg-count-error-minimum condition)
+ (defmacro-ll-arg-count-error-maximum condition))))
+ (format stream ", but ~D found"
+ (length (defmacro-ll-arg-count-error-argument condition))))))
+
+(define-condition defmacro-ll-broken-key-list-error
+ (defmacro-lambda-list-bind-error)
+ ((problem :reader defmacro-ll-broken-key-list-error-problem
+ :initarg :problem)
+ (info :reader defmacro-ll-broken-key-list-error-info :initarg :info))
+ (:report (lambda (condition stream)
+ (print-defmacro-ll-bind-error-intro condition stream)
+ (format stream
+ (ecase
+ (defmacro-ll-broken-key-list-error-problem condition)
+ (:dotted-list
+ "dotted keyword/value list: ~S")
+ (:odd-length
+ "odd number of elements in keyword/value list: ~S")
+ (:duplicate
+ "duplicate keyword: ~S")
+ (:unknown-keyword
+ "~{unknown keyword: ~S; expected one of ~{~S~^, ~}~}"))
+ (defmacro-ll-broken-key-list-error-info condition)))))
--- /dev/null
+;;;; the PARSE-DEFMACRO function and related code
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!KERNEL")
+
+(file-comment
+ "$Header$")
+
+;;; variables for accumulating the results of parsing a DEFMACRO. (Declarations
+;;; in DEFMACRO are the reason this isn't as easy as it sounds.)
+(defvar *arg-tests* nil) ; tests that do argument counting at expansion time
+(declaim (type list *arg-tests*))
+(defvar *system-lets* nil) ; LET bindings done to allow lambda-list parsing
+(declaim (type list *system-lets*))
+(defvar *user-lets* nil) ; LET bindings that the user has explicitly supplied
+(declaim (type list *user-lets*))
+
+;; the default default for unsupplied optional and keyword args
+(defvar *default-default* nil)
+
+;;; temps that we introduce and might not reference
+(defvar *ignorable-vars*)
+(declaim (type list *ignorable-vars*))
+
+;;; Return, as multiple-values, a body, possibly a declare form to put where
+;;; this code is inserted, the documentation for the parsed body, and bounds
+;;; on the number of arguments.
+(defun parse-defmacro (lambda-list arg-list-name body name error-kind
+ &key
+ (anonymousp nil)
+ (doc-string-allowed t)
+ ((:environment env-arg-name))
+ ((:default-default *default-default*))
+ (error-fun 'error))
+ (multiple-value-bind (forms declarations documentation)
+ (parse-body body doc-string-allowed)
+ (let ((*arg-tests* ())
+ (*user-lets* ())
+ (*system-lets* ())
+ (*ignorable-vars* ()))
+ (multiple-value-bind (env-arg-used minimum maximum)
+ (parse-defmacro-lambda-list lambda-list arg-list-name name
+ error-kind error-fun (not anonymousp)
+ nil env-arg-name)
+ (values `(let* ,(nreverse *system-lets*)
+ ,@(when *ignorable-vars*
+ `((declare (ignorable ,@*ignorable-vars*))))
+ ,@*arg-tests*
+ (let* ,(nreverse *user-lets*)
+ ,@declarations
+ ,@forms))
+ `(,@(when (and env-arg-name (not env-arg-used))
+ `((declare (ignore ,env-arg-name)))))
+ documentation
+ minimum
+ maximum)))))
+
+;;; partial reverse-engineered documentation:
+;;; TOP-LEVEL is true for calls through PARSE-DEFMACRO from DEFSETF and
+;;; DESTRUCTURING-BIND, false otherwise.
+;;; -- WHN 19990620
+(defun parse-defmacro-lambda-list (possibly-dotted-lambda-list
+ arg-list-name
+ name
+ error-kind
+ error-fun
+ &optional
+ top-level
+ env-illegal
+ env-arg-name)
+ (let* (;; PATH is a sort of pointer into the part of the lambda list we're
+ ;; considering at this point in the code. PATH-0 is the root of the
+ ;; lambda list, which is the initial value of PATH.
+ (path-0 (if top-level
+ `(cdr ,arg-list-name)
+ arg-list-name))
+ (path path-0) ; (will change below)
+ (now-processing :required)
+ (maximum 0)
+ (minimum 0)
+ (keys ())
+ ;; ANSI specifies that dotted lists are "treated exactly as if the
+ ;; parameter name that ends the list had appeared preceded by &rest."
+ ;; We force this behavior by transforming dotted lists into ordinary
+ ;; lists with explicit &REST elements.
+ (lambda-list (do ((in-pdll possibly-dotted-lambda-list (cdr in-pdll))
+ (reversed-result nil))
+ ((atom in-pdll)
+ (nreverse (if in-pdll
+ (list* in-pdll '&rest reversed-result)
+ reversed-result)))
+ (push (car in-pdll) reversed-result)))
+ rest-name restp allow-other-keys-p env-arg-used)
+ (when (member '&whole (rest lambda-list))
+ (error "&WHOLE may only appear first in ~S lambda-list." error-kind))
+ (do ((rest-of-args lambda-list (cdr rest-of-args)))
+ ((null rest-of-args))
+ (let ((var (car rest-of-args)))
+ (cond ((eq var '&whole)
+ (cond ((and (cdr rest-of-args) (symbolp (cadr rest-of-args)))
+ (setq rest-of-args (cdr rest-of-args))
+ (push-let-binding (car rest-of-args) arg-list-name nil))
+ (t
+ (defmacro-error "&WHOLE" error-kind name))))
+ ((eq var '&environment)
+ (cond (env-illegal
+ (error "&ENVIRONMENT is not valid with ~S." error-kind))
+ ((not top-level)
+ (error "&ENVIRONMENT is only valid at top level of ~
+ lambda-list.")))
+ (cond ((and (cdr rest-of-args) (symbolp (cadr rest-of-args)))
+ (setq rest-of-args (cdr rest-of-args))
+ (push-let-binding (car rest-of-args) env-arg-name nil)
+ (setq env-arg-used t))
+ (t
+ (defmacro-error "&ENVIRONMENT" error-kind name))))
+ ((or (eq var '&rest)
+ (eq var '&body))
+ (cond ((and (cdr rest-of-args) (symbolp (cadr rest-of-args)))
+ (setq rest-of-args (cdr rest-of-args))
+ (setq restp t)
+ (push-let-binding (car rest-of-args) path nil))
+ (t
+ (defmacro-error (symbol-name var) error-kind name))))
+ ((eq var '&optional)
+ (setq now-processing :optionals))
+ ((eq var '&key)
+ (setq now-processing :keywords)
+ (setq rest-name (gensym "KEYWORDS-"))
+ (push rest-name *ignorable-vars*)
+ (setq restp t)
+ (push-let-binding rest-name path t))
+ ((eq var '&allow-other-keys)
+ (setq allow-other-keys-p t))
+ ((eq var '&aux)
+ (setq now-processing :auxs))
+ ((listp var)
+ (cond ; (since it's too early to use CASE)
+ ((eq now-processing :required)
+ (let ((sub-list-name (gensym "SUBLIST-")))
+ (push-sub-list-binding sub-list-name `(car ,path) var
+ name error-kind error-fun)
+ (parse-defmacro-lambda-list var sub-list-name name
+ error-kind error-fun))
+ (setq path `(cdr ,path)
+ minimum (1+ minimum)
+ maximum (1+ maximum)))
+ ((eq now-processing :optionals)
+ (when (> (length var) 3)
+ (cerror "Ignore extra noise."
+ "more than variable, initform, and suppliedp ~
+ in &optional binding: ~S"
+ var))
+ (push-optional-binding (car var) (cadr var) (caddr var)
+ `(not (null ,path)) `(car ,path)
+ name error-kind error-fun)
+ (setq path `(cdr ,path)
+ maximum (1+ maximum)))
+ ((eq now-processing :keywords)
+ (let* ((keyword-given (consp (car var)))
+ (variable (if keyword-given
+ (cadar var)
+ (car var)))
+ (keyword (if keyword-given
+ (caar var)
+ (keywordicate variable)))
+ (supplied-p (caddr var)))
+ (push-optional-binding variable (cadr var) supplied-p
+ `(keyword-supplied-p ',keyword
+ ,rest-name)
+ `(lookup-keyword ',keyword
+ ,rest-name)
+ name error-kind error-fun)
+ (push keyword keys)))
+ ((eq now-processing :auxs)
+ (push-let-binding (car var) (cadr var) nil))))
+ ((symbolp var)
+ (cond ; (too early in bootstrapping to use CASE)
+ ;; FIXME: ^ This "too early in bootstrapping" is no
+ ;; longer an issue in current SBCL bootstrapping.
+ ((eq now-processing :required)
+ (push-let-binding var `(car ,path) nil)
+ (setq minimum (1+ minimum)
+ maximum (1+ maximum)
+ path `(cdr ,path)))
+ ((eq now-processing :optionals)
+ (push-let-binding var `(car ,path) nil `(not (null ,path)))
+ (setq path `(cdr ,path)
+ maximum (1+ maximum)))
+ ((eq now-processing :keywords)
+ (let ((key (keywordicate var)))
+ (push-let-binding var
+ `(lookup-keyword ,key ,rest-name)
+ nil)
+ (push key keys)))
+ ((eq now-processing :auxs)
+ (push-let-binding var nil nil))))
+ (t
+ (error "non-symbol in lambda-list: ~S" var)))))
+ (push `(unless ,(if restp
+ ;; (If RESTP, then the argument list might be
+ ;; dotted, in which case ordinary LENGTH won't
+ ;; work.)
+ `(list-of-length-at-least-p ,path-0 ,minimum)
+ `(proper-list-of-length-p ,path-0 ,minimum ,maximum))
+ ,(if (eq error-fun 'error)
+ `(do-arg-count-error ',error-kind ',name ,path-0
+ ',lambda-list ,minimum
+ ,(unless restp maximum))
+ `(,error-fun 'defmacro-ll-arg-count-error
+ :kind ',error-kind
+ ,@(when name `(:name ',name))
+ :argument ,path-0
+ :lambda-list ',lambda-list
+ :minimum ,minimum
+ ,@(unless restp
+ `(:maximum ,maximum)))))
+ *arg-tests*)
+ (when keys
+ (let ((problem (gensym "KEY-PROBLEM-"))
+ (info (gensym "INFO-")))
+ (push `(multiple-value-bind (,problem ,info)
+ (verify-keywords ,rest-name
+ ',keys
+ ',allow-other-keys-p)
+ (when ,problem
+ (,error-fun
+ 'defmacro-ll-broken-key-list-error
+ :kind ',error-kind
+ ,@(when name `(:name ',name))
+ :problem ,problem
+ :info ,info)))
+ *arg-tests*)))
+ (values env-arg-used minimum (if (null restp) maximum nil))))
+
+(defun push-sub-list-binding (variable path object name error-kind error-fun)
+ (let ((var (gensym "TEMP-")))
+ (push `(,variable
+ (let ((,var ,path))
+ (if (listp ,var)
+ ,var
+ (,error-fun 'defmacro-bogus-sublist-error
+ :kind ',error-kind
+ ,@(when name `(:name ',name))
+ :object ,var
+ :lambda-list ',object))))
+ *system-lets*)))
+
+(defun push-let-binding (variable path systemp &optional condition
+ (init-form *default-default*))
+ (let ((let-form (if condition
+ `(,variable (if ,condition ,path ,init-form))
+ `(,variable ,path))))
+ (if systemp
+ (push let-form *system-lets*)
+ (push let-form *user-lets*))))
+
+(defun push-optional-binding (value-var init-form supplied-var condition path
+ name error-kind error-fun)
+ (unless supplied-var
+ (setq supplied-var (gensym "SUPPLIEDP-")))
+ (push-let-binding supplied-var condition t)
+ (cond ((consp value-var)
+ (let ((whole-thing (gensym "OPTIONAL-SUBLIST-")))
+ (push-sub-list-binding whole-thing
+ `(if ,supplied-var ,path ,init-form)
+ value-var name error-kind error-fun)
+ (parse-defmacro-lambda-list value-var whole-thing name
+ error-kind error-fun)))
+ ((symbolp value-var)
+ (push-let-binding value-var path nil supplied-var init-form))
+ (t
+ (error "Illegal optional variable name: ~S" value-var))))
+
+(defun defmacro-error (problem kind name)
+ (error "Illegal or ill-formed ~A argument in ~A~@[ ~S~]."
+ problem kind name))
+
+;;; Determine whether KEY-LIST is a valid list of keyword/value pairs. Do not
+;;; signal the error directly, 'cause we don't know how it should be signaled.
+(defun verify-keywords (key-list valid-keys allow-other-keys)
+ (do ((already-processed nil)
+ (unknown-keyword nil)
+ (remaining key-list (cddr remaining)))
+ ((null remaining)
+ (if (and unknown-keyword
+ (not allow-other-keys)
+ (not (lookup-keyword :allow-other-keys key-list)))
+ (values :unknown-keyword (list unknown-keyword valid-keys))
+ (values nil nil)))
+ (cond ((not (and (consp remaining) (listp (cdr remaining))))
+ (return (values :dotted-list key-list)))
+ ((null (cdr remaining))
+ (return (values :odd-length key-list)))
+ ((member (car remaining) already-processed)
+ (return (values :duplicate (car remaining))))
+ ((or (eq (car remaining) :allow-other-keys)
+ (member (car remaining) valid-keys))
+ (push (car remaining) already-processed))
+ (t
+ (setq unknown-keyword (car remaining))))))
+
+(defun lookup-keyword (keyword key-list)
+ (do ((remaining key-list (cddr remaining)))
+ ((endp remaining))
+ (when (eq keyword (car remaining))
+ (return (cadr remaining)))))
+
+(defun keyword-supplied-p (keyword key-list)
+ (do ((remaining key-list (cddr remaining)))
+ ((endp remaining))
+ (when (eq keyword (car remaining))
+ (return t))))
--- /dev/null
+;;;; the known-to-the-cross-compiler part of PATHNAME logic
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!IMPL")
+
+(file-comment
+ "$Header$")
+\f
+;;;; data types used by pathnames
+
+;;; The HOST structure holds the functions that both parse the
+;;; pathname information into structure slot entries, and after
+;;; translation the inverse (unparse) functions.
+(sb!xc:defstruct (host (:constructor nil))
+ (parse (required-argument) :type function)
+ (unparse (required-argument) :type function)
+ (unparse-host (required-argument) :type function)
+ (unparse-directory (required-argument) :type function)
+ (unparse-file (required-argument) :type function)
+ (unparse-enough (required-argument) :type function)
+ (customary-case (required-argument) :type (member :upper :lower)))
+
+(sb!xc:defstruct (logical-host
+ (:include host
+ (:parse #'parse-logical-namestring)
+ (:unparse #'unparse-logical-namestring)
+ (:unparse-host
+ (lambda (x)
+ (logical-host-name (%pathname-host x))))
+ (:unparse-directory #'unparse-logical-directory)
+ (:unparse-file #'unparse-unix-file)
+ (:unparse-enough #'identity)
+ (:customary-case :upper)))
+ (name "" :type simple-base-string)
+ (translations nil :type list)
+ (canon-transls nil :type list))
+
+;;; A PATTERN is a list of entries and wildcards used for pattern
+;;; matches of translations.
+(sb!xc:defstruct (pattern (:constructor make-pattern (pieces)))
+ (pieces nil :type list))
+\f
+;;;; PATHNAME structures
+
+;;; the various magic tokens that are allowed to appear in pretty much
+;;; all pathname components
+(sb!xc:deftype component-tokens () ; FIXME: rename to PATHNAME-COMPONENT-TOKENS
+ '(member nil :unspecific :wild))
+
+(sb!xc:defstruct (pathname (:conc-name %pathname-)
+ (:constructor %make-pathname (host
+ device
+ directory
+ name
+ type
+ version))
+ (:predicate pathnamep))
+ ;; the host (at present either a UNIX or logical host)
+ (host nil :type (or host null))
+ ;; the name of a logical or physical device holding files
+ (device nil :type (or simple-string component-tokens))
+ ;; a list of strings that are the component subdirectory components
+ (directory nil :type list)
+ ;; the filename
+ (name nil :type (or simple-string pattern component-tokens))
+ ;; the type extension of the file
+ (type nil :type (or simple-string pattern component-tokens))
+ ;; the version number of the file, a positive integer (not supported
+ ;; on standard Unix filesystems)
+ (version nil :type (or integer component-tokens (member :newest))))
+
+;;; Logical pathnames have the following format:
+;;;
+;;; logical-namestring ::=
+;;; [host ":"] [";"] {directory ";"}* [name] ["." type ["." version]]
+;;;
+;;; host ::= word
+;;; directory ::= word | wildcard-word | **
+;;; name ::= word | wildcard-word
+;;; type ::= word | wildcard-word
+;;; version ::= pos-int | newest | NEWEST | *
+;;; word ::= {uppercase-letter | digit | -}+
+;;; wildcard-word ::= [word] '* {word '*}* [word]
+;;; pos-int ::= integer > 0
+;;;
+;;; Physical pathnames include all these slots and a device slot.
+
+;;; Logical pathnames are a subclass of pathname. Their class
+;;; relations are mimicked using structures for efficency.
+(sb!xc:defstruct (logical-pathname (:conc-name %logical-pathname-)
+ (:include pathname)
+ (:constructor %make-logical-pathname
+ (host
+ device
+ directory
+ name
+ type
+ version))))
+\f
+(defmacro-mundanely enumerate-search-list ((var pathname &optional result)
+ &body body)
+ #!+sb-doc
+ "Execute BODY with VAR bound to each successive possible expansion for
+ PATHNAME and then return RESULT. Note: if PATHNAME does not contain a
+ search-list, then BODY is executed exactly once. Everything is wrapped
+ in a block named NIL, so RETURN can be used to terminate early. Note:
+ VAR is *not* bound inside of RESULT."
+ (let ((body-name (gensym)))
+ `(block nil
+ (flet ((,body-name (,var)
+ ,@body))
+ (%enumerate-search-list ,pathname #',body-name)
+ ,result))))
+
--- /dev/null
+;;;; pretty-printing of backquote expansions
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!IMPL")
+
+(file-comment
+ "$Header$")
+
+(defun backq-unparse-expr (form splicing)
+ (ecase splicing
+ ((nil)
+ `(backq-comma ,form))
+ ((t)
+ `((backq-comma-at ,form)))
+ (:nconc
+ `((backq-comma-dot ,form)))
+ ))
+
+(defun backq-unparse (form &optional splicing)
+ #!+sb-doc
+ "Given a lisp form containing the magic functions BACKQ-LIST, BACKQ-LIST*,
+ BACKQ-APPEND, etc. produced by the backquote reader macro, will return a
+ corresponding backquote input form. In this form, `,' `,@' and `,.' are
+ represented by lists whose cars are BACKQ-COMMA, BACKQ-COMMA-AT, and
+ BACKQ-COMMA-DOT respectively, and whose cadrs are the form after the comma.
+ SPLICING indicates whether a comma-escape return should be modified for
+ splicing with other forms: a value of T or :NCONC meaning that an extra
+ level of parentheses should be added."
+ (cond
+ ((atom form)
+ (backq-unparse-expr form splicing))
+ ((not (null (cdr (last form))))
+ ;; FIXME: Shouldn't this be an ERROR?
+ "### illegal dotted backquote form ###")
+ (t
+ (case (car form)
+ (backq-list
+ (mapcar #'backq-unparse (cdr form)))
+ (backq-list*
+ (do ((tail (cdr form) (cdr tail))
+ (accum nil))
+ ((null (cdr tail))
+ (nconc (nreverse accum)
+ (backq-unparse (car tail) t)))
+ (push (backq-unparse (car tail)) accum)))
+ (backq-append
+ (mapcan #'(lambda (el) (backq-unparse el t))
+ (cdr form)))
+ (backq-nconc
+ (mapcan #'(lambda (el) (backq-unparse el :nconc))
+ (cdr form)))
+ (backq-cons
+ (cons (backq-unparse (cadr form) nil)
+ (backq-unparse (caddr form) t)))
+ (backq-vector
+ (coerce (backq-unparse (cadr form)) 'vector))
+ (quote
+ (cadr form))
+ (t
+ (backq-unparse-expr form splicing))))))
+
+(defun pprint-backquote (stream form &rest noise)
+ (declare (ignore noise))
+ (write-char #\` stream)
+ (write (backq-unparse form) :stream stream))
+
+(defun pprint-backq-comma (stream form &rest noise)
+ (declare (ignore noise))
+ (ecase (car form)
+ (backq-comma
+ (write-char #\, stream))
+ (backq-comma-at
+ (princ ",@" stream))
+ (backq-comma-dot
+ (princ ",." stream)))
+ (write (cadr form) :stream stream))
+
+;;; This is called by !PPRINT-COLD-INIT, fairly late, because
+;;; SET-PPRINT-DISPATCH doesn't work until the compiler works.
+;;;
+;;; FIXME: It might be cleaner to just make these toplevel forms and
+;;; enforce the delay by putting this file late in the build sequence.
+(defun !backq-pp-cold-init ()
+ (set-pprint-dispatch '(cons (eql backq-list)) #'pprint-backquote)
+ (set-pprint-dispatch '(cons (eql backq-list*)) #'pprint-backquote)
+ (set-pprint-dispatch '(cons (eql backq-append)) #'pprint-backquote)
+ (set-pprint-dispatch '(cons (eql backq-nconc)) #'pprint-backquote)
+ (set-pprint-dispatch '(cons (eql backq-cons)) #'pprint-backquote)
+ (set-pprint-dispatch '(cons (eql backq-vector)) #'pprint-backquote)
+
+ (set-pprint-dispatch '(cons (eql backq-comma)) #'pprint-backq-comma)
+ (set-pprint-dispatch '(cons (eql backq-comma-at)) #'pprint-backq-comma)
+ (set-pprint-dispatch '(cons (eql backq-comma-dot)) #'pprint-backq-comma))
--- /dev/null
+;;;; Common Lisp pretty printer
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!PRETTY")
+
+(file-comment
+ "$Header$")
+\f
+;;;; pretty streams
+
+;;; There are three different units for measuring character positions:
+;;; COLUMN - offset (if characters) from the start of the current line.
+;;; INDEX - index into the output buffer.
+;;; POSN - some position in the stream of characters cycling through
+;;; the output buffer.
+(deftype column ()
+ '(and fixnum unsigned-byte))
+;;; The INDEX type is picked up from the kernel package.
+(deftype posn ()
+ 'fixnum)
+
+(defconstant initial-buffer-size 128)
+
+(defconstant default-line-length 80)
+
+(defstruct (pretty-stream (:include sb!sys:lisp-stream
+ (:out #'pretty-out)
+ (:sout #'pretty-sout)
+ (:misc #'pretty-misc))
+ (:constructor make-pretty-stream (target)))
+ ;; Where the output is going to finally go.
+ (target (required-argument) :type stream)
+ ;; Line length we should format to. Cached here so we don't have to keep
+ ;; extracting it from the target stream.
+ (line-length (or *print-right-margin*
+ (sb!impl::line-length target)
+ default-line-length)
+ :type column)
+ ;; A simple string holding all the text that has been output but not yet
+ ;; printed.
+ (buffer (make-string initial-buffer-size) :type simple-string)
+ ;; The index into BUFFER where more text should be put.
+ (buffer-fill-pointer 0 :type index)
+ ;; Whenever we output stuff from the buffer, we shift the remaining noise
+ ;; over. This makes it difficult to keep references to locations in
+ ;; the buffer. Therefore, we have to keep track of the total amount of
+ ;; stuff that has been shifted out of the buffer.
+ (buffer-offset 0 :type posn)
+ ;; The column the first character in the buffer will appear in. Normally
+ ;; zero, but if we end up with a very long line with no breaks in it we
+ ;; might have to output part of it. Then this will no longer be zero.
+ (buffer-start-column (or (sb!impl::charpos target) 0) :type column)
+ ;; The line number we are currently on. Used for *print-lines* abrevs and
+ ;; to tell when sections have been split across multiple lines.
+ (line-number 0 :type index)
+ ;; Stack of logical blocks in effect at the buffer start.
+ (blocks (list (make-logical-block)) :type list)
+ ;; Buffer holding the per-line prefix active at the buffer start.
+ ;; Indentation is included in this. The length of this is stored
+ ;; in the logical block stack.
+ (prefix (make-string initial-buffer-size) :type simple-string)
+ ;; Buffer holding the total remaining suffix active at the buffer start.
+ ;; The characters are right-justified in the buffer to make it easier
+ ;; to output the buffer. The length is stored in the logical block
+ ;; stack.
+ (suffix (make-string initial-buffer-size) :type simple-string)
+ ;; Queue of pending operations. When empty, HEAD=TAIL=NIL. Otherwise,
+ ;; TAIL holds the first (oldest) cons and HEAD holds the last (newest)
+ ;; cons. Adding things to the queue is basically (setf (cdr head) (list
+ ;; new)) and removing them is basically (pop tail) [except that care must
+ ;; be taken to handle the empty queue case correctly.]
+ (queue-tail nil :type list)
+ (queue-head nil :type list)
+ ;; Block-start queue entries in effect at the queue head.
+ (pending-blocks nil :type list))
+(def!method print-object ((pstream pretty-stream) stream)
+ ;; FIXME: CMU CL had #+NIL'ed out this code and done a hand-written
+ ;; FORMAT hack instead. Make sure that this code actually works instead
+ ;; of falling into infinite regress or something.
+ (print-unreadable-object (pstream stream :type t :identity t)))
+
+#!-sb-fluid (declaim (inline index-posn posn-index posn-column))
+(defun index-posn (index stream)
+ (declare (type index index) (type pretty-stream stream)
+ (values posn))
+ (+ index (pretty-stream-buffer-offset stream)))
+(defun posn-index (posn stream)
+ (declare (type posn posn) (type pretty-stream stream)
+ (values index))
+ (- posn (pretty-stream-buffer-offset stream)))
+(defun posn-column (posn stream)
+ (declare (type posn posn) (type pretty-stream stream)
+ (values posn))
+ (index-column (posn-index posn stream) stream))
+\f
+;;;; stream interface routines
+
+(defun pretty-out (stream char)
+ (declare (type pretty-stream stream)
+ (type base-char char))
+ (cond ((char= char #\newline)
+ (enqueue-newline stream :literal))
+ (t
+ (ensure-space-in-buffer stream 1)
+ (let ((fill-pointer (pretty-stream-buffer-fill-pointer stream)))
+ (setf (schar (pretty-stream-buffer stream) fill-pointer) char)
+ (setf (pretty-stream-buffer-fill-pointer stream)
+ (1+ fill-pointer))))))
+
+(defun pretty-sout (stream string start end)
+ (declare (type pretty-stream stream)
+ (type simple-string string)
+ (type index start)
+ (type (or index null) end))
+ (let ((end (or end (length string))))
+ (unless (= start end)
+ (let ((newline (position #\newline string :start start :end end)))
+ (cond
+ (newline
+ (pretty-sout stream string start newline)
+ (enqueue-newline stream :literal)
+ (pretty-sout stream string (1+ newline) end))
+ (t
+ (let ((chars (- end start)))
+ (loop
+ (let* ((available (ensure-space-in-buffer stream chars))
+ (count (min available chars))
+ (fill-pointer (pretty-stream-buffer-fill-pointer stream))
+ (new-fill-ptr (+ fill-pointer count)))
+ (replace (pretty-stream-buffer stream)
+ string
+ :start1 fill-pointer :end1 new-fill-ptr
+ :start2 start)
+ (setf (pretty-stream-buffer-fill-pointer stream) new-fill-ptr)
+ (decf chars count)
+ (when (zerop count)
+ (return))
+ (incf start count))))))))))
+
+(defun pretty-misc (stream op &optional arg1 arg2)
+ (declare (ignore stream op arg1 arg2)))
+\f
+;;;; logical blocks
+
+(defstruct logical-block
+ ;; The column this logical block started in.
+ (start-column 0 :type column)
+ ;; The column the current section started in.
+ (section-column 0 :type column)
+ ;; The length of the per-line prefix. We can't move the indentation
+ ;; left of this.
+ (per-line-prefix-end 0 :type index)
+ ;; The overall length of the prefix, including any indentation.
+ (prefix-length 0 :type index)
+ ;; The overall length of the suffix.
+ (suffix-length 0 :type index)
+ ;; The line number
+ (section-start-line 0 :type index))
+
+(defun really-start-logical-block (stream column prefix suffix)
+ (let* ((blocks (pretty-stream-blocks stream))
+ (prev-block (car blocks))
+ (per-line-end (logical-block-per-line-prefix-end prev-block))
+ (prefix-length (logical-block-prefix-length prev-block))
+ (suffix-length (logical-block-suffix-length prev-block))
+ (block (make-logical-block
+ :start-column column
+ :section-column column
+ :per-line-prefix-end per-line-end
+ :prefix-length prefix-length
+ :suffix-length suffix-length
+ :section-start-line (pretty-stream-line-number stream))))
+ (setf (pretty-stream-blocks stream) (cons block blocks))
+ (set-indentation stream column)
+ (when prefix
+ (setf (logical-block-per-line-prefix-end block) column)
+ (replace (pretty-stream-prefix stream) prefix
+ :start1 (- column (length prefix)) :end1 column))
+ (when suffix
+ (let* ((total-suffix (pretty-stream-suffix stream))
+ (total-suffix-len (length total-suffix))
+ (additional (length suffix))
+ (new-suffix-len (+ suffix-length additional)))
+ (when (> new-suffix-len total-suffix-len)
+ (let ((new-total-suffix-len
+ (max (* total-suffix-len 2)
+ (+ suffix-length
+ (floor (* additional 5) 4)))))
+ (setf total-suffix
+ (replace (make-string new-total-suffix-len) total-suffix
+ :start1 (- new-total-suffix-len suffix-length)
+ :start2 (- total-suffix-len suffix-length)))
+ (setf total-suffix-len new-total-suffix-len)
+ (setf (pretty-stream-suffix stream) total-suffix)))
+ (replace total-suffix suffix
+ :start1 (- total-suffix-len new-suffix-len)
+ :end1 (- total-suffix-len suffix-length))
+ (setf (logical-block-suffix-length block) new-suffix-len))))
+ nil)
+
+(defun set-indentation (stream column)
+ (let* ((prefix (pretty-stream-prefix stream))
+ (prefix-len (length prefix))
+ (block (car (pretty-stream-blocks stream)))
+ (current (logical-block-prefix-length block))
+ (minimum (logical-block-per-line-prefix-end block))
+ (column (max minimum column)))
+ (when (> column prefix-len)
+ (setf prefix
+ (replace (make-string (max (* prefix-len 2)
+ (+ prefix-len
+ (floor (* (- column prefix-len) 5)
+ 4))))
+ prefix
+ :end1 current))
+ (setf (pretty-stream-prefix stream) prefix))
+ (when (> column current)
+ (fill prefix #\space :start current :end column))
+ (setf (logical-block-prefix-length block) column)))
+
+(defun really-end-logical-block (stream)
+ (let* ((old (pop (pretty-stream-blocks stream)))
+ (old-indent (logical-block-prefix-length old))
+ (new (car (pretty-stream-blocks stream)))
+ (new-indent (logical-block-prefix-length new)))
+ (when (> new-indent old-indent)
+ (fill (pretty-stream-prefix stream) #\space
+ :start old-indent :end new-indent)))
+ nil)
+\f
+;;;; the pending operation queue
+
+(defstruct (queued-op (:constructor nil))
+ (posn 0 :type posn))
+
+(defmacro enqueue (stream type &rest args)
+ (let ((constructor (intern (concatenate 'string
+ "MAKE-"
+ (symbol-name type)))))
+ (once-only ((stream stream)
+ (entry `(,constructor :posn
+ (index-posn
+ (pretty-stream-buffer-fill-pointer
+ ,stream)
+ ,stream)
+ ,@args))
+ (op `(list ,entry))
+ (head `(pretty-stream-queue-head ,stream)))
+ `(progn
+ (if ,head
+ (setf (cdr ,head) ,op)
+ (setf (pretty-stream-queue-tail ,stream) ,op))
+ (setf (pretty-stream-queue-head ,stream) ,op)
+ ,entry))))
+
+(defstruct (section-start (:include queued-op)
+ (:constructor nil))
+ (depth 0 :type index)
+ (section-end nil :type (or null newline block-end)))
+
+(defstruct (newline
+ (:include section-start))
+ (kind (required-argument)
+ :type (member :linear :fill :miser :literal :mandatory)))
+
+(defun enqueue-newline (stream kind)
+ (let* ((depth (length (pretty-stream-pending-blocks stream)))
+ (newline (enqueue stream newline :kind kind :depth depth)))
+ (dolist (entry (pretty-stream-queue-tail stream))
+ (when (and (not (eq newline entry))
+ (section-start-p entry)
+ (null (section-start-section-end entry))
+ (<= depth (section-start-depth entry)))
+ (setf (section-start-section-end entry) newline))))
+ (maybe-output stream (or (eq kind :literal) (eq kind :mandatory))))
+
+(defstruct (indentation
+ (:include queued-op))
+ (kind (required-argument) :type (member :block :current))
+ (amount 0 :type fixnum))
+
+(defun enqueue-indent (stream kind amount)
+ (enqueue stream indentation :kind kind :amount amount))
+
+(defstruct (block-start
+ (:include section-start))
+ (block-end nil :type (or null block-end))
+ (prefix nil :type (or null simple-string))
+ (suffix nil :type (or null simple-string)))
+
+(defun start-logical-block (stream prefix per-line-p suffix)
+ ;; (In the PPRINT-LOGICAL-BLOCK form which calls us,
+ ;; :PREFIX and :PER-LINE-PREFIX have hairy defaulting behavior,
+ ;; and might end up being NIL.)
+ (declare (type (or null string prefix)))
+ ;; (But the defaulting behavior of PPRINT-LOGICAL-BLOCK :SUFFIX is
+ ;; trivial, so it should always be a string.)
+ (declare (type string suffix))
+ (when prefix
+ (pretty-sout stream prefix 0 (length prefix)))
+ (let* ((pending-blocks (pretty-stream-pending-blocks stream))
+ (start (enqueue stream block-start
+ :prefix (and per-line-p prefix)
+ :suffix suffix
+ :depth (length pending-blocks))))
+ (setf (pretty-stream-pending-blocks stream)
+ (cons start pending-blocks))))
+
+(defstruct (block-end
+ (:include queued-op))
+ (suffix nil :type (or null simple-string)))
+
+(defun end-logical-block (stream)
+ (let* ((start (pop (pretty-stream-pending-blocks stream)))
+ (suffix (block-start-suffix start))
+ (end (enqueue stream block-end :suffix suffix)))
+ (when suffix
+ (pretty-sout stream suffix 0 (length suffix)))
+ (setf (block-start-block-end start) end)))
+
+(defstruct (tab
+ (:include queued-op))
+ (sectionp nil :type (member t nil))
+ (relativep nil :type (member t nil))
+ (colnum 0 :type column)
+ (colinc 0 :type column))
+
+(defun enqueue-tab (stream kind colnum colinc)
+ (multiple-value-bind (sectionp relativep)
+ (ecase kind
+ (:line (values nil nil))
+ (:line-relative (values nil t))
+ (:section (values t nil))
+ (:section-relative (values t t)))
+ (enqueue stream tab :sectionp sectionp :relativep relativep
+ :colnum colnum :colinc colinc)))
+\f
+;;;; tab support
+
+(defun compute-tab-size (tab section-start column)
+ (let ((origin (if (tab-sectionp tab) section-start 0))
+ (colnum (tab-colnum tab))
+ (colinc (tab-colinc tab)))
+ (cond ((tab-relativep tab)
+ (unless (<= colinc 1)
+ (let ((newposn (+ column colnum)))
+ (let ((rem (rem newposn colinc)))
+ (unless (zerop rem)
+ (incf colnum (- colinc rem))))))
+ colnum)
+ ((<= column (+ colnum origin))
+ (- (+ colnum origin) column))
+ (t
+ (- colinc
+ (rem (- column origin) colinc))))))
+
+(defun index-column (index stream)
+ (let ((column (pretty-stream-buffer-start-column stream))
+ (section-start (logical-block-section-column
+ (first (pretty-stream-blocks stream))))
+ (end-posn (index-posn index stream)))
+ (dolist (op (pretty-stream-queue-tail stream))
+ (when (>= (queued-op-posn op) end-posn)
+ (return))
+ (typecase op
+ (tab
+ (incf column
+ (compute-tab-size op
+ section-start
+ (+ column
+ (posn-index (tab-posn op)
+ stream)))))
+ ((or newline block-start)
+ (setf section-start
+ (+ column (posn-index (queued-op-posn op)
+ stream))))))
+ (+ column index)))
+
+(defun expand-tabs (stream through)
+ (let ((insertions nil)
+ (additional 0)
+ (column (pretty-stream-buffer-start-column stream))
+ (section-start (logical-block-section-column
+ (first (pretty-stream-blocks stream)))))
+ (dolist (op (pretty-stream-queue-tail stream))
+ (typecase op
+ (tab
+ (let* ((index (posn-index (tab-posn op) stream))
+ (tabsize (compute-tab-size op
+ section-start
+ (+ column index))))
+ (unless (zerop tabsize)
+ (push (cons index tabsize) insertions)
+ (incf additional tabsize)
+ (incf column tabsize))))
+ ((or newline block-start)
+ (setf section-start
+ (+ column (posn-index (queued-op-posn op) stream)))))
+ (when (eq op through)
+ (return)))
+ (when insertions
+ (let* ((fill-ptr (pretty-stream-buffer-fill-pointer stream))
+ (new-fill-ptr (+ fill-ptr additional))
+ (buffer (pretty-stream-buffer stream))
+ (new-buffer buffer)
+ (length (length buffer))
+ (end fill-ptr))
+ (when (> new-fill-ptr length)
+ (let ((new-length (max (* length 2)
+ (+ fill-ptr
+ (floor (* additional 5) 4)))))
+ (setf new-buffer (make-string new-length))
+ (setf (pretty-stream-buffer stream) new-buffer)))
+ (setf (pretty-stream-buffer-fill-pointer stream) new-fill-ptr)
+ (decf (pretty-stream-buffer-offset stream) additional)
+ (dolist (insertion insertions)
+ (let* ((srcpos (car insertion))
+ (amount (cdr insertion))
+ (dstpos (+ srcpos additional)))
+ (replace new-buffer buffer :start1 dstpos :start2 srcpos :end2 end)
+ (fill new-buffer #\space :start (- dstpos amount) :end dstpos)
+ (decf additional amount)
+ (setf end srcpos)))
+ (unless (eq new-buffer buffer)
+ (replace new-buffer buffer :end1 end :end2 end))))))
+\f
+;;;; stuff to do the actual outputting
+
+(defun ensure-space-in-buffer (stream want)
+ (declare (type pretty-stream stream)
+ (type index want))
+ (let* ((buffer (pretty-stream-buffer stream))
+ (length (length buffer))
+ (fill-ptr (pretty-stream-buffer-fill-pointer stream))
+ (available (- length fill-ptr)))
+ (cond ((plusp available)
+ available)
+ ((> fill-ptr (pretty-stream-line-length stream))
+ (unless (maybe-output stream nil)
+ (output-partial-line stream))
+ (ensure-space-in-buffer stream want))
+ (t
+ (let* ((new-length (max (* length 2)
+ (+ length
+ (floor (* want 5) 4))))
+ (new-buffer (make-string new-length)))
+ (setf (pretty-stream-buffer stream) new-buffer)
+ (replace new-buffer buffer :end1 fill-ptr)
+ (- new-length fill-ptr))))))
+
+(defun maybe-output (stream force-newlines-p)
+ (declare (type pretty-stream stream))
+ (let ((tail (pretty-stream-queue-tail stream))
+ (output-anything nil))
+ (loop
+ (unless tail
+ (setf (pretty-stream-queue-head stream) nil)
+ (return))
+ (let ((next (pop tail)))
+ (etypecase next
+ (newline
+ (when (ecase (newline-kind next)
+ ((:literal :mandatory :linear) t)
+ (:miser (misering-p stream))
+ (:fill
+ (or (misering-p stream)
+ (> (pretty-stream-line-number stream)
+ (logical-block-section-start-line
+ (first (pretty-stream-blocks stream))))
+ (ecase (fits-on-line-p stream
+ (newline-section-end next)
+ force-newlines-p)
+ ((t) nil)
+ ((nil) t)
+ (:dont-know
+ (return))))))
+ (setf output-anything t)
+ (output-line stream next)))
+ (indentation
+ (unless (misering-p stream)
+ (set-indentation stream
+ (+ (ecase (indentation-kind next)
+ (:block
+ (logical-block-start-column
+ (car (pretty-stream-blocks stream))))
+ (:current
+ (posn-column
+ (indentation-posn next)
+ stream)))
+ (indentation-amount next)))))
+ (block-start
+ (ecase (fits-on-line-p stream (block-start-section-end next)
+ force-newlines-p)
+ ((t)
+ ;; Just nuke the whole logical block and make it look like one
+ ;; nice long literal.
+ (let ((end (block-start-block-end next)))
+ (expand-tabs stream end)
+ (setf tail (cdr (member end tail)))))
+ ((nil)
+ (really-start-logical-block
+ stream
+ (posn-column (block-start-posn next) stream)
+ (block-start-prefix next)
+ (block-start-suffix next)))
+ (:dont-know
+ (return))))
+ (block-end
+ (really-end-logical-block stream))
+ (tab
+ (expand-tabs stream next))))
+ (setf (pretty-stream-queue-tail stream) tail))
+ output-anything))
+
+(defun misering-p (stream)
+ (declare (type pretty-stream stream))
+ (and *print-miser-width*
+ (<= (- (pretty-stream-line-length stream)
+ (logical-block-start-column (car (pretty-stream-blocks stream))))
+ *print-miser-width*)))
+
+(defun fits-on-line-p (stream until force-newlines-p)
+ (let ((available (pretty-stream-line-length stream)))
+ (when (and (not *print-readably*) *print-lines*
+ (= *print-lines* (pretty-stream-line-number stream)))
+ (decf available 3) ; for the `` ..''
+ (decf available (logical-block-suffix-length
+ (car (pretty-stream-blocks stream)))))
+ (cond (until
+ (<= (posn-column (queued-op-posn until) stream) available))
+ (force-newlines-p nil)
+ ((> (index-column (pretty-stream-buffer-fill-pointer stream) stream)
+ available)
+ nil)
+ (t
+ :dont-know))))
+
+(defun output-line (stream until)
+ (declare (type pretty-stream stream)
+ (type newline until))
+ (let* ((target (pretty-stream-target stream))
+ (buffer (pretty-stream-buffer stream))
+ (kind (newline-kind until))
+ (literal-p (eq kind :literal))
+ (amount-to-consume (posn-index (newline-posn until) stream))
+ (amount-to-print
+ (if literal-p
+ amount-to-consume
+ (let ((last-non-blank
+ (position #\space buffer :end amount-to-consume
+ :from-end t :test #'char/=)))
+ (if last-non-blank
+ (1+ last-non-blank)
+ 0)))))
+ (write-string buffer target :end amount-to-print)
+ (let ((line-number (pretty-stream-line-number stream)))
+ (incf line-number)
+ (when (and (not *print-readably*)
+ *print-lines* (>= line-number *print-lines*))
+ (write-string " .." target)
+ (let ((suffix-length (logical-block-suffix-length
+ (car (pretty-stream-blocks stream)))))
+ (unless (zerop suffix-length)
+ (let* ((suffix (pretty-stream-suffix stream))
+ (len (length suffix)))
+ (write-string suffix target
+ :start (- len suffix-length)
+ :end len))))
+ (throw 'line-limit-abbreviation-happened t))
+ (setf (pretty-stream-line-number stream) line-number)
+ (write-char #\newline target)
+ (setf (pretty-stream-buffer-start-column stream) 0)
+ (let* ((fill-ptr (pretty-stream-buffer-fill-pointer stream))
+ (block (first (pretty-stream-blocks stream)))
+ (prefix-len
+ (if literal-p
+ (logical-block-per-line-prefix-end block)
+ (logical-block-prefix-length block)))
+ (shift (- amount-to-consume prefix-len))
+ (new-fill-ptr (- fill-ptr shift))
+ (new-buffer buffer)
+ (buffer-length (length buffer)))
+ (when (> new-fill-ptr buffer-length)
+ (setf new-buffer
+ (make-string (max (* buffer-length 2)
+ (+ buffer-length
+ (floor (* (- new-fill-ptr buffer-length)
+ 5)
+ 4)))))
+ (setf (pretty-stream-buffer stream) new-buffer))
+ (replace new-buffer buffer
+ :start1 prefix-len :start2 amount-to-consume :end2 fill-ptr)
+ (replace new-buffer (pretty-stream-prefix stream)
+ :end1 prefix-len)
+ (setf (pretty-stream-buffer-fill-pointer stream) new-fill-ptr)
+ (incf (pretty-stream-buffer-offset stream) shift)
+ (unless literal-p
+ (setf (logical-block-section-column block) prefix-len)
+ (setf (logical-block-section-start-line block) line-number))))))
+
+(defun output-partial-line (stream)
+ (let* ((fill-ptr (pretty-stream-buffer-fill-pointer stream))
+ (tail (pretty-stream-queue-tail stream))
+ (count
+ (if tail
+ (posn-index (queued-op-posn (car tail)) stream)
+ fill-ptr))
+ (new-fill-ptr (- fill-ptr count))
+ (buffer (pretty-stream-buffer stream)))
+ (when (zerop count)
+ (error "Output-partial-line called when nothing can be output."))
+ (write-string buffer (pretty-stream-target stream)
+ :start 0 :end count)
+ (incf (pretty-stream-buffer-start-column stream) count)
+ (replace buffer buffer :end1 new-fill-ptr :start2 count :end2 fill-ptr)
+ (setf (pretty-stream-buffer-fill-pointer stream) new-fill-ptr)
+ (incf (pretty-stream-buffer-offset stream) count)))
+
+(defun force-pretty-output (stream)
+ (maybe-output stream nil)
+ (expand-tabs stream nil)
+ (write-string (pretty-stream-buffer stream)
+ (pretty-stream-target stream)
+ :end (pretty-stream-buffer-fill-pointer stream)))
+\f
+;;;; user interface to the pretty printer
+
+(defun pprint-newline (kind &optional stream)
+ #!+sb-doc
+ "Output a conditional newline to STREAM (which defaults to
+ *STANDARD-OUTPUT*) if it is a pretty-printing stream, and do
+ nothing if not. KIND can be one of:
+ :LINEAR - A line break is inserted if and only if the immediatly
+ containing section cannot be printed on one line.
+ :MISER - Same as LINEAR, but only if ``miser-style'' is in effect.
+ (See *PRINT-MISER-WIDTH*.)
+ :FILL - A line break is inserted if and only if either:
+ (a) the following section cannot be printed on the end of the
+ current line,
+ (b) the preceding section was not printed on a single line, or
+ (c) the immediately containing section cannot be printed on one
+ line and miser-style is in effect.
+ :MANDATORY - A line break is always inserted.
+ When a line break is inserted by any type of conditional newline, any
+ blanks that immediately precede the conditional newline are ommitted
+ from the output and indentation is introduced at the beginning of the
+ next line. (See PPRINT-INDENT.)"
+ (declare (type (member :linear :miser :fill :mandatory) kind)
+ (type (or stream (member t nil)) stream)
+ (values null))
+ (let ((stream (case stream
+ ((t) *terminal-io*)
+ ((nil) *standard-output*)
+ (t stream))))
+ (when (pretty-stream-p stream)
+ (enqueue-newline stream kind)))
+ nil)
+
+(defun pprint-indent (relative-to n &optional stream)
+ #!+sb-doc
+ "Specify the indentation to use in the current logical block if STREAM
+ (which defaults to *STANDARD-OUTPUT*) is it is a pretty-printing stream
+ and do nothing if not. (See PPRINT-LOGICAL-BLOCK.) N is the indention
+ to use (in ems, the width of an ``m'') and RELATIVE-TO can be either:
+ :BLOCK - Indent relative to the column the current logical block
+ started on.
+ :CURRENT - Indent relative to the current column.
+ The new indention value does not take effect until the following line
+ break."
+ (declare (type (member :block :current) relative-to)
+ (type integer n)
+ (type (or stream (member t nil)) stream)
+ (values null))
+ (let ((stream (case stream
+ ((t) *terminal-io*)
+ ((nil) *standard-output*)
+ (t stream))))
+ (when (pretty-stream-p stream)
+ (enqueue-indent stream relative-to n)))
+ nil)
+
+(defun pprint-tab (kind colnum colinc &optional stream)
+ #!+sb-doc
+ "If STREAM (which defaults to *STANDARD-OUTPUT*) is a pretty-printing
+ stream, perform tabbing based on KIND, otherwise do nothing. KIND can
+ be one of:
+ :LINE - Tab to column COLNUM. If already past COLNUM tab to the next
+ multiple of COLINC.
+ :SECTION - Same as :LINE, but count from the start of the current
+ section, not the start of the line.
+ :LINE-RELATIVE - Output COLNUM spaces, then tab to the next multiple of
+ COLINC.
+ :SECTION-RELATIVE - Same as :LINE-RELATIVE, but count from the start
+ of the current section, not the start of the line."
+ (declare (type (member :line :section :line-relative :section-relative) kind)
+ (type unsigned-byte colnum colinc)
+ (type (or stream (member t nil)) stream)
+ (values null))
+ (let ((stream (case stream
+ ((t) *terminal-io*)
+ ((nil) *standard-output*)
+ (t stream))))
+ (when (pretty-stream-p stream)
+ (enqueue-tab stream kind colnum colinc)))
+ nil)
+
+(defun pprint-fill (stream list &optional (colon? t) atsign?)
+ #!+sb-doc
+ "Output LIST to STREAM putting :FILL conditional newlines between each
+ element. If COLON? is NIL (defaults to T), then no parens are printed
+ around the output. ATSIGN? is ignored (but allowed so that PPRINT-FILL
+ can be used with the ~/.../ format directive."
+ (declare (ignore atsign?))
+ (pprint-logical-block (stream list
+ :prefix (if colon? "(" "")
+ :suffix (if colon? ")" ""))
+ (pprint-exit-if-list-exhausted)
+ (loop
+ (output-object (pprint-pop) stream)
+ (pprint-exit-if-list-exhausted)
+ (write-char #\space stream)
+ (pprint-newline :fill stream))))
+
+(defun pprint-linear (stream list &optional (colon? t) atsign?)
+ #!+sb-doc
+ "Output LIST to STREAM putting :LINEAR conditional newlines between each
+ element. If COLON? is NIL (defaults to T), then no parens are printed
+ around the output. ATSIGN? is ignored (but allowed so that PPRINT-LINEAR
+ can be used with the ~/.../ format directive."
+ (declare (ignore atsign?))
+ (pprint-logical-block (stream list
+ :prefix (if colon? "(" "")
+ :suffix (if colon? ")" ""))
+ (pprint-exit-if-list-exhausted)
+ (loop
+ (output-object (pprint-pop) stream)
+ (pprint-exit-if-list-exhausted)
+ (write-char #\space stream)
+ (pprint-newline :linear stream))))
+
+(defun pprint-tabular (stream list &optional (colon? t) atsign? tabsize)
+ #!+sb-doc
+ "Output LIST to STREAM tabbing to the next column that is an even multiple
+ of TABSIZE (which defaults to 16) between each element. :FILL style
+ conditional newlines are also output between each element. If COLON? is
+ NIL (defaults to T), then no parens are printed around the output.
+ ATSIGN? is ignored (but allowed so that PPRINT-TABULAR can be used with
+ the ~/.../ format directive."
+ (declare (ignore atsign?))
+ (pprint-logical-block (stream list
+ :prefix (if colon? "(" "")
+ :suffix (if colon? ")" ""))
+ (pprint-exit-if-list-exhausted)
+ (loop
+ (output-object (pprint-pop) stream)
+ (pprint-exit-if-list-exhausted)
+ (write-char #\space stream)
+ (pprint-tab :section-relative 0 (or tabsize 16) stream)
+ (pprint-newline :fill stream))))
+\f
+;;;; pprint-dispatch tables
+
+(defvar *initial-pprint-dispatch*)
+(defvar *building-initial-table* nil)
+
+(defstruct pprint-dispatch-entry
+ ;; The type specifier for this entry.
+ (type (required-argument) :type t)
+ ;; A function to test to see whether an object is of this time. Pretty must
+ ;; just (lambda (obj) (typep object type)) except that we handle the
+ ;; CONS type specially so that (cons (member foo)) works. We don't
+ ;; bother computing this for entries in the CONS hash table, because
+ ;; we don't need it.
+ (test-fn nil :type (or function null))
+ ;; The priority for this guy.
+ (priority 0 :type real)
+ ;; T iff one of the original entries.
+ (initial-p *building-initial-table* :type (member t nil))
+ ;; And the associated function.
+ (function (required-argument) :type function))
+(def!method print-object ((entry pprint-dispatch-entry) stream)
+ (print-unreadable-object (entry stream :type t)
+ (format stream "type=~S, priority=~S~@[ [initial]~]"
+ (pprint-dispatch-entry-type entry)
+ (pprint-dispatch-entry-priority entry)
+ (pprint-dispatch-entry-initial-p entry))))
+
+(defstruct pprint-dispatch-table
+ ;; A list of all the entries (except for CONS entries below) in highest
+ ;; to lowest priority.
+ (entries nil :type list)
+ ;; A hash table mapping things to entries for type specifiers of the
+ ;; form (CONS (MEMBER <thing>)). If the type specifier is of this form,
+ ;; we put it in this hash table instead of the regular entries table.
+ (cons-entries (make-hash-table :test 'eql)))
+(def!method print-object ((table pprint-dispatch-table) stream)
+ (print-unreadable-object (table stream :type t :identity t)))
+
+(defun cons-type-specifier-p (spec)
+ (and (consp spec)
+ (eq (car spec) 'cons)
+ (cdr spec)
+ (null (cddr spec))
+ (let ((car (cadr spec)))
+ (and (consp car)
+ (let ((carcar (car car)))
+ (or (eq carcar 'member)
+ (eq carcar 'eql)))
+ (cdr car)
+ (null (cddr car))))))
+
+(defun entry< (e1 e2)
+ (declare (type pprint-dispatch-entry e1 e2))
+ (if (pprint-dispatch-entry-initial-p e1)
+ (if (pprint-dispatch-entry-initial-p e2)
+ (< (pprint-dispatch-entry-priority e1)
+ (pprint-dispatch-entry-priority e2))
+ t)
+ (if (pprint-dispatch-entry-initial-p e2)
+ nil
+ (< (pprint-dispatch-entry-priority e1)
+ (pprint-dispatch-entry-priority e2)))))
+
+(macrolet ((frob (x)
+ `(cons ',x #'(lambda (object) ,x))))
+ (defvar *precompiled-pprint-dispatch-funs*
+ (list (frob (typep object 'array))
+ (frob (and (consp object)
+ (and (typep (car object) 'symbol)
+ (typep (car object) '(satisfies fboundp)))))
+ (frob (typep object 'cons)))))
+
+(defun compute-test-fn (type)
+ (let ((was-cons nil))
+ (labels ((compute-test-expr (type object)
+ (if (listp type)
+ (case (car type)
+ (cons
+ (setq was-cons t)
+ (destructuring-bind
+ (&optional (car nil car-p) (cdr nil cdr-p))
+ (cdr type)
+ `(and (consp ,object)
+ ,@(when car-p
+ `(,(compute-test-expr
+ car `(car ,object))))
+ ,@(when cdr-p
+ `(,(compute-test-expr
+ cdr `(cdr ,object)))))))
+ (not
+ (destructuring-bind (type) (cdr type)
+ `(not ,(compute-test-expr type object))))
+ (and
+ `(and ,@(mapcar #'(lambda (type)
+ (compute-test-expr type object))
+ (cdr type))))
+ (or
+ `(or ,@(mapcar #'(lambda (type)
+ (compute-test-expr type object))
+ (cdr type))))
+ (t
+ `(typep ,object ',type)))
+ `(typep ,object ',type))))
+ (let ((expr (compute-test-expr type 'object)))
+ (cond ((cdr (assoc expr *precompiled-pprint-dispatch-funs*
+ :test #'equal)))
+ ((fboundp 'compile)
+ (compile nil `(lambda (object) ,expr)))
+ (was-cons
+ (warn "CONS PPRINT dispatch ignored w/o compiler loaded:~% ~S"
+ type)
+ #'(lambda (object) (declare (ignore object)) nil))
+ (t
+ (let ((ttype (sb!kernel:specifier-type type)))
+ #'(lambda (object) (sb!kernel:%typep object ttype)))))))))
+
+(defun copy-pprint-dispatch (&optional (table *print-pprint-dispatch*))
+ (declare (type (or pprint-dispatch-table null) table))
+ (let* ((orig (or table *initial-pprint-dispatch*))
+ (new (make-pprint-dispatch-table
+ :entries (copy-list (pprint-dispatch-table-entries orig))))
+ (new-cons-entries (pprint-dispatch-table-cons-entries new)))
+ (maphash #'(lambda (key value)
+ (setf (gethash key new-cons-entries) value))
+ (pprint-dispatch-table-cons-entries orig))
+ new))
+
+(defun pprint-dispatch (object &optional (table *print-pprint-dispatch*))
+ (declare (type (or pprint-dispatch-table null) table))
+ (let* ((table (or table *initial-pprint-dispatch*))
+ (cons-entry
+ (and (consp object)
+ (gethash (car object)
+ (pprint-dispatch-table-cons-entries table))))
+ (entry
+ (dolist (entry (pprint-dispatch-table-entries table) cons-entry)
+ (when (and cons-entry
+ (entry< entry cons-entry))
+ (return cons-entry))
+ (when (funcall (pprint-dispatch-entry-test-fn entry) object)
+ (return entry)))))
+ (if entry
+ (values (pprint-dispatch-entry-function entry) t)
+ (values #'(lambda (stream object)
+ (output-ugly-object object stream))
+ nil))))
+
+(defun set-pprint-dispatch (type function &optional
+ (priority 0) (table *print-pprint-dispatch*))
+ (declare (type (or null function) function)
+ (type real priority)
+ (type pprint-dispatch-table table))
+ (if function
+ (if (cons-type-specifier-p type)
+ (setf (gethash (second (second type))
+ (pprint-dispatch-table-cons-entries table))
+ (make-pprint-dispatch-entry :type type :priority priority
+ :function function))
+ (let ((list (delete type (pprint-dispatch-table-entries table)
+ :key #'pprint-dispatch-entry-type
+ :test #'equal))
+ (entry (make-pprint-dispatch-entry
+ :type type :test-fn (compute-test-fn type)
+ :priority priority :function function)))
+ (do ((prev nil next)
+ (next list (cdr next)))
+ ((null next)
+ (if prev
+ (setf (cdr prev) (list entry))
+ (setf list (list entry))))
+ (when (entry< (car next) entry)
+ (if prev
+ (setf (cdr prev) (cons entry next))
+ (setf list (cons entry next)))
+ (return)))
+ (setf (pprint-dispatch-table-entries table) list)))
+ (if (cons-type-specifier-p type)
+ (remhash (second (second type))
+ (pprint-dispatch-table-cons-entries table))
+ (setf (pprint-dispatch-table-entries table)
+ (delete type (pprint-dispatch-table-entries table)
+ :key #'pprint-dispatch-entry-type
+ :test #'equal))))
+ nil)
+\f
+;;;; standard pretty-printing routines
+
+(defun pprint-array (stream array)
+ (cond ((or (and (null *print-array*) (null *print-readably*))
+ (stringp array)
+ (bit-vector-p array))
+ (output-ugly-object array stream))
+ ((and *print-readably* (not (eq (array-element-type array) 't)))
+ (let ((*print-readably* nil))
+ (error 'print-not-readable :object array)))
+ ((vectorp array)
+ (pprint-vector stream array))
+ (t
+ (pprint-multi-dim-array stream array))))
+
+(defun pprint-vector (stream vector)
+ (pprint-logical-block (stream nil :prefix "#(" :suffix ")")
+ (dotimes (i (length vector))
+ (unless (zerop i)
+ (format stream " ~:_"))
+ (pprint-pop)
+ (output-object (aref vector i) stream))))
+
+(defun pprint-multi-dim-array (stream array)
+ (funcall (formatter "#~DA") stream (array-rank array))
+ (with-array-data ((data array) (start) (end))
+ (declare (ignore end))
+ (labels ((output-guts (stream index dimensions)
+ (if (null dimensions)
+ (output-object (aref data index) stream)
+ (pprint-logical-block
+ (stream nil :prefix "(" :suffix ")")
+ (let ((dim (car dimensions)))
+ (unless (zerop dim)
+ (let* ((dims (cdr dimensions))
+ (index index)
+ (step (reduce #'* dims))
+ (count 0))
+ (loop
+ (pprint-pop)
+ (output-guts stream index dims)
+ (when (= (incf count) dim)
+ (return))
+ (write-char #\space stream)
+ (pprint-newline (if dims :linear :fill)
+ stream)
+ (incf index step)))))))))
+ (output-guts stream start (array-dimensions array)))))
+
+(defun pprint-lambda-list (stream lambda-list &rest noise)
+ (declare (ignore noise))
+ (pprint-logical-block (stream lambda-list :prefix "(" :suffix ")")
+ (let ((state :required)
+ (first t))
+ (loop
+ (pprint-exit-if-list-exhausted)
+ (unless first
+ (write-char #\space stream))
+ (let ((arg (pprint-pop)))
+ (unless first
+ (case arg
+ (&optional
+ (setf state :optional)
+ (pprint-newline :linear stream))
+ ((&rest &body)
+ (setf state :required)
+ (pprint-newline :linear stream))
+ (&key
+ (setf state :key)
+ (pprint-newline :linear stream))
+ (&aux
+ (setf state :optional)
+ (pprint-newline :linear stream))
+ (t
+ (pprint-newline :fill stream))))
+ (ecase state
+ (:required
+ (pprint-lambda-list stream arg))
+ ((:optional :key)
+ (pprint-logical-block
+ (stream arg :prefix "(" :suffix ")")
+ (pprint-exit-if-list-exhausted)
+ (if (eq state :key)
+ (pprint-logical-block
+ (stream (pprint-pop) :prefix "(" :suffix ")")
+ (pprint-exit-if-list-exhausted)
+ (output-object (pprint-pop) stream)
+ (pprint-exit-if-list-exhausted)
+ (write-char #\space stream)
+ (pprint-newline :fill stream)
+ (pprint-lambda-list stream (pprint-pop))
+ (loop
+ (pprint-exit-if-list-exhausted)
+ (write-char #\space stream)
+ (pprint-newline :fill stream)
+ (output-object (pprint-pop) stream)))
+ (pprint-lambda-list stream (pprint-pop)))
+ (loop
+ (pprint-exit-if-list-exhausted)
+ (write-char #\space stream)
+ (pprint-newline :linear stream)
+ (output-object (pprint-pop) stream))))))
+ (setf first nil)))))
+
+(defun pprint-lambda (stream list &rest noise)
+ (declare (ignore noise))
+ (funcall (formatter
+ ;; KLUDGE: This format string, and other format strings which also
+ ;; refer to SB!PRETTY, rely on the current SBCL not-quite-ANSI
+ ;; behavior of FORMATTER in order to make code which survives the
+ ;; transition when SB!PRETTY is renamed to SB-PRETTY after cold
+ ;; init. (ANSI says that the FORMATTER functions should be
+ ;; equivalent to the format string, but the SBCL FORMATTER
+ ;; functions contain references to package objects, not package
+ ;; names, so they keep right on going if the packages are renamed.)
+ ;; If our FORMATTER behavior is ever made more compliant, the code
+ ;; here will have to change. -- WHN 19991207
+ "~:<~^~W~^~3I ~:_~/SB!PRETTY:PPRINT-LAMBDA-LIST/~1I~@{ ~_~W~}~:>")
+ stream
+ list))
+
+(defun pprint-block (stream list &rest noise)
+ (declare (ignore noise))
+ (funcall (formatter "~:<~^~W~^~3I ~:_~W~1I~@{ ~_~W~}~:>") stream list))
+
+(defun pprint-flet (stream list &rest noise)
+ (declare (ignore noise))
+ (funcall (formatter
+ "~:<~^~W~^ ~@_~:<~@{~:<~^~W~^~3I ~:_~/SB!PRETTY:PPRINT-LAMBDA-LIST/~1I~:@_~@{~W~^ ~_~}~:>~^ ~_~}~:>~1I~@:_~@{~W~^ ~_~}~:>")
+ stream
+ list))
+
+(defun pprint-let (stream list &rest noise)
+ (declare (ignore noise))
+ (funcall (formatter "~:<~^~W~^ ~@_~:<~@{~:<~^~W~@{ ~_~W~}~:>~^ ~_~}~:>~1I~:@_~@{~W~^ ~_~}~:>")
+ stream
+ list))
+
+(defun pprint-progn (stream list &rest noise)
+ (declare (ignore noise))
+ (funcall (formatter "~:<~^~W~@{ ~_~W~}~:>") stream list))
+
+(defun pprint-progv (stream list &rest noise)
+ (declare (ignore noise))
+ (funcall (formatter "~:<~^~W~^~3I ~_~W~^ ~_~W~^~1I~@{ ~_~W~}~:>")
+ stream list))
+
+(defun pprint-quote (stream list &rest noise)
+ (declare (ignore noise))
+ (if (and (consp list)
+ (consp (cdr list))
+ (null (cddr list)))
+ (case (car list)
+ (function
+ (write-string "#'" stream)
+ (output-object (cadr list) stream))
+ (quote
+ (write-char #\' stream)
+ (output-object (cadr list) stream))
+ (t
+ (pprint-fill stream list)))
+ (pprint-fill stream list)))
+
+(defun pprint-setq (stream list &rest noise)
+ (declare (ignore noise))
+ (pprint-logical-block (stream list :prefix "(" :suffix ")")
+ (pprint-exit-if-list-exhausted)
+ (output-object (pprint-pop) stream)
+ (pprint-exit-if-list-exhausted)
+ (write-char #\space stream)
+ (pprint-newline :miser stream)
+ (if (and (consp (cdr list)) (consp (cddr list)))
+ (loop
+ (pprint-indent :current 2 stream)
+ (output-object (pprint-pop) stream)
+ (pprint-exit-if-list-exhausted)
+ (write-char #\space stream)
+ (pprint-newline :linear stream)
+ (pprint-indent :current -2 stream)
+ (output-object (pprint-pop) stream)
+ (pprint-exit-if-list-exhausted)
+ (write-char #\space stream)
+ (pprint-newline :linear stream))
+ (progn
+ (pprint-indent :current 0 stream)
+ (output-object (pprint-pop) stream)
+ (pprint-exit-if-list-exhausted)
+ (write-char #\space stream)
+ (pprint-newline :linear stream)
+ (output-object (pprint-pop) stream)))))
+
+;;; FIXME: could become SB!XC:DEFMACRO wrapped in EVAL-WHEN (COMPILE EVAL)
+(defmacro pprint-tagbody-guts (stream)
+ `(loop
+ (pprint-exit-if-list-exhausted)
+ (write-char #\space ,stream)
+ (let ((form-or-tag (pprint-pop)))
+ (pprint-indent :block
+ (if (atom form-or-tag) 0 1)
+ ,stream)
+ (pprint-newline :linear ,stream)
+ (output-object form-or-tag ,stream))))
+
+(defun pprint-tagbody (stream list &rest noise)
+ (declare (ignore noise))
+ (pprint-logical-block (stream list :prefix "(" :suffix ")")
+ (pprint-exit-if-list-exhausted)
+ (output-object (pprint-pop) stream)
+ (pprint-tagbody-guts stream)))
+
+(defun pprint-case (stream list &rest noise)
+ (declare (ignore noise))
+ (funcall (formatter
+ "~:<~^~W~^ ~3I~:_~W~1I~@{ ~_~:<~^~:/SB!PRETTY:PPRINT-FILL/~^~@{ ~_~W~}~:>~}~:>")
+ stream
+ list))
+
+(defun pprint-defun (stream list &rest noise)
+ (declare (ignore noise))
+ (funcall (formatter
+ "~:<~^~W~^ ~@_~:I~W~^ ~:_~/SB!PRETTY:PPRINT-LAMBDA-LIST/~1I~@{ ~_~W~}~:>")
+ stream
+ list))
+
+(defun pprint-destructuring-bind (stream list &rest noise)
+ (declare (ignore noise))
+ (funcall (formatter
+ "~:<~^~W~^~3I ~_~:/SB!PRETTY:PPRINT-LAMBDA-LIST/~^ ~_~W~^~1I~@{ ~_~W~}~:>")
+ stream list))
+
+(defun pprint-do (stream list &rest noise)
+ (declare (ignore noise))
+ (pprint-logical-block (stream list :prefix "(" :suffix ")")
+ (pprint-exit-if-list-exhausted)
+ (output-object (pprint-pop) stream)
+ (pprint-exit-if-list-exhausted)
+ (write-char #\space stream)
+ (pprint-indent :current 0 stream)
+ (funcall (formatter "~:<~@{~:<~^~W~^ ~@_~:I~W~@{ ~_~W~}~:>~^~:@_~}~:>")
+ stream
+ (pprint-pop))
+ (pprint-exit-if-list-exhausted)
+ (write-char #\space stream)
+ (pprint-newline :linear stream)
+ (pprint-linear stream (pprint-pop))
+ (pprint-tagbody-guts stream)))
+
+(defun pprint-dolist (stream list &rest noise)
+ (declare (ignore noise))
+ (pprint-logical-block (stream list :prefix "(" :suffix ")")
+ (pprint-exit-if-list-exhausted)
+ (output-object (pprint-pop) stream)
+ (pprint-exit-if-list-exhausted)
+ (pprint-indent :block 3 stream)
+ (write-char #\space stream)
+ (pprint-newline :fill stream)
+ (funcall (formatter "~:<~^~W~^ ~:_~:I~W~@{ ~_~W~}~:>")
+ stream
+ (pprint-pop))
+ (pprint-tagbody-guts stream)))
+
+(defun pprint-typecase (stream list &rest noise)
+ (declare (ignore noise))
+ (funcall (formatter
+ "~:<~^~W~^ ~3I~:_~W~1I~@{ ~_~:<~^~W~^~@{ ~_~W~}~:>~}~:>")
+ stream
+ list))
+
+(defun pprint-prog (stream list &rest noise)
+ (declare (ignore noise))
+ (pprint-logical-block (stream list :prefix "(" :suffix ")")
+ (pprint-exit-if-list-exhausted)
+ (output-object (pprint-pop) stream)
+ (pprint-exit-if-list-exhausted)
+ (write-char #\space stream)
+ (pprint-newline :miser stream)
+ (pprint-fill stream (pprint-pop))
+ (pprint-tagbody-guts stream)))
+
+(defun pprint-function-call (stream list &rest noise)
+ (declare (ignore noise))
+ (funcall (formatter "~:<~^~W~^ ~:_~:I~@{~W~^ ~_~}~:>")
+ stream
+ list))
+\f
+;;;; the interface seen by regular (ugly) printer and initialization routines
+
+;;; OUTPUT-PRETTY-OBJECT is called by OUTPUT-OBJECT when *PRINT-PRETTY* is
+;;; bound to T.
+(defun output-pretty-object (object stream)
+ (with-pretty-stream (stream)
+ (funcall (pprint-dispatch object) stream object)))
+
+(defun !pprint-cold-init ()
+ (/show0 "entering !PPRINT-COLD-INIT")
+ (setf *initial-pprint-dispatch* (make-pprint-dispatch-table))
+ (let ((*print-pprint-dispatch* *initial-pprint-dispatch*)
+ (*building-initial-table* t))
+ ;; printers for regular types
+ (/show0 "doing SET-PPRINT-DISPATCH for regular types")
+ (set-pprint-dispatch 'array #'pprint-array)
+ (set-pprint-dispatch '(cons (and symbol (satisfies fboundp)))
+ #'pprint-function-call -1)
+ (set-pprint-dispatch 'cons #'pprint-fill -2)
+ ;; cons cells with interesting things for the car
+ (/show0 "doing SET-PPRINT-DISPATCH for CONS with interesting CAR")
+
+ (dolist (magic-form '((lambda pprint-lambda)
+
+ ;; special forms
+ (block pprint-block)
+ (catch pprint-block)
+ (eval-when pprint-block)
+ (flet pprint-flet)
+ (function pprint-quote)
+ (labels pprint-flet)
+ (let pprint-let)
+ (let* pprint-let)
+ (locally pprint-progn)
+ (macrolet pprint-flet)
+ (multiple-value-call pprint-block)
+ (multiple-value-prog1 pprint-block)
+ (progn pprint-progn)
+ (progv pprint-progv)
+ (quote pprint-quote)
+ (return-from pprint-block)
+ (setq pprint-setq)
+ (symbol-macrolet pprint-let)
+ (tagbody pprint-tagbody)
+ (throw pprint-block)
+ (unwind-protect pprint-block)
+
+ ;; macros
+ (case pprint-case)
+ (ccase pprint-case)
+ (ctypecase pprint-typecase)
+ (defconstant pprint-block)
+ (define-modify-macro pprint-defun)
+ (define-setf-expander pprint-defun)
+ (defmacro pprint-defun)
+ (defparameter pprint-block)
+ (defsetf pprint-defun)
+ (defstruct pprint-block)
+ (deftype pprint-defun)
+ (defun pprint-defun)
+ (defvar pprint-block)
+ (destructuring-bind pprint-destructuring-bind)
+ (do pprint-do)
+ (do* pprint-do)
+ (do-all-symbols pprint-dolist)
+ (do-external-symbols pprint-dolist)
+ (do-symbols pprint-dolist)
+ (dolist pprint-dolist)
+ (dotimes pprint-dolist)
+ (ecase pprint-case)
+ (etypecase pprint-typecase)
+ #+nil (handler-bind ...)
+ #+nil (handler-case ...)
+ #+nil (loop ...)
+ (multiple-value-bind pprint-progv)
+ (multiple-value-setq pprint-block)
+ (pprint-logical-block pprint-block)
+ (print-unreadable-object pprint-block)
+ (prog pprint-prog)
+ (prog* pprint-prog)
+ (prog1 pprint-block)
+ (prog2 pprint-progv)
+ (psetf pprint-setq)
+ (psetq pprint-setq)
+ #+nil (restart-bind ...)
+ #+nil (restart-case ...)
+ (setf pprint-setq)
+ (step pprint-progn)
+ (time pprint-progn)
+ (typecase pprint-typecase)
+ (unless pprint-block)
+ (when pprint-block)
+ (with-compilation-unit pprint-block)
+ #+nil (with-condition-restarts ...)
+ (with-hash-table-iterator pprint-block)
+ (with-input-from-string pprint-block)
+ (with-open-file pprint-block)
+ (with-open-stream pprint-block)
+ (with-output-to-string pprint-block)
+ (with-package-iterator pprint-block)
+ (with-simple-restart pprint-block)
+ (with-standard-io-syntax pprint-progn)))
+
+ (set-pprint-dispatch `(cons (eql ,(first magic-form)))
+ (symbol-function (second magic-form))))
+
+ ;; other pretty-print init forms
+ (/show0 "about to call !BACKQ-PP-COLD-INIT")
+ (sb!impl::!backq-pp-cold-init)
+ (/show0 "leaving !PPRINT-COLD-INIT"))
+
+ (setf *print-pprint-dispatch* (copy-pprint-dispatch nil))
+ (setf *pretty-printer* #'output-pretty-object)
+ (setf *print-pretty* t))
--- /dev/null
+;;;; predicate functions (EQUAL and friends, and type predicates)
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!IMPL")
+
+(file-comment
+ "$Header$")
+\f
+;;;; miscellaneous non-primitive predicates
+
+#!-sb-fluid (declaim (inline streamp))
+(defun streamp (stream)
+ (typep stream 'stream))
+
+;;; Is X a (VECTOR T)?
+(defun vector-t-p (x)
+ (or (simple-vector-p x)
+ (and (complex-vector-p x)
+ (simple-vector-p (%array-data-vector x)))))
+\f
+;;;; primitive predicates. These must be supported directly by the
+;;;; compiler.
+
+(defun not (object)
+ #!+sb-doc
+ "Return T if X is NIL, otherwise return NIL."
+ (not object))
+
+;;; All the primitive type predicates share a parallel form..
+(macrolet
+ ((frob ()
+ `(progn
+ ,@(mapcar (lambda (pred)
+ (let* ((name (symbol-name pred))
+ (stem (string-right-trim name "P-"))
+ (article (if (find (schar name 0) "AEIOU")
+ "an"
+ "a")))
+ `(defun ,pred (object)
+ ,(format nil
+ "Return T if OBJECT is ~A ~A, ~
+ and NIL otherwise."
+ article
+ stem)
+ (,pred object))))
+ '(array-header-p
+ arrayp
+ atom
+ base-char-p
+ bignump
+ bit-vector-p
+ characterp
+ code-component-p
+ consp
+ compiled-function-p
+ complexp
+ complex-double-float-p
+ complex-float-p
+ #!+long-float complex-long-float-p
+ complex-rational-p
+ complex-single-float-p
+ ;; (COMPLEX-VECTOR-P is not included here since
+ ;; it's awkward to express the type it tests for
+ ;; in the Common Lisp type system, and since
+ ;; it's only used in the implementation of a few
+ ;; specialized things.)
+ double-float-p
+ fdefn-p
+ fixnump
+ floatp
+ functionp
+ integerp
+ listp
+ long-float-p
+ lra-p
+ null
+ numberp
+ rationalp
+ ratiop
+ realp
+ short-float-p
+ sb!kernel:simple-array-p
+ simple-bit-vector-p
+ simple-string-p
+ simple-vector-p
+ single-float-p
+ stringp
+ %instancep
+ symbolp
+ system-area-pointer-p
+ weak-pointer-p
+ vectorp
+ unsigned-byte-32-p
+ signed-byte-32-p
+ simple-array-unsigned-byte-2-p
+ simple-array-unsigned-byte-4-p
+ simple-array-unsigned-byte-8-p
+ simple-array-unsigned-byte-16-p
+ simple-array-unsigned-byte-32-p
+ simple-array-signed-byte-8-p
+ simple-array-signed-byte-16-p
+ simple-array-signed-byte-30-p
+ simple-array-signed-byte-32-p
+ simple-array-single-float-p
+ simple-array-double-float-p
+ #!+long-float simple-array-long-float-p
+ simple-array-complex-single-float-p
+ simple-array-complex-double-float-p
+ #!+long-float simple-array-complex-long-float-p
+ )))))
+ (frob))
+\f
+;;; Return the specifier for the type of object. This is not simply
+;;; (TYPE-SPECIFIER (CTYPE-OF OBJECT)) because CTYPE-OF has different
+;;; goals than TYPE-OF. In particular, speed is more important than
+;;; precision, and it is not permitted to return member types.
+(defun type-of (object)
+ #!+sb-doc
+ "Return the type of OBJECT."
+ (if (typep object '(or function array complex))
+ (type-specifier (ctype-of object))
+ (let* ((class (layout-class (layout-of object)))
+ (name (class-name class)))
+ (if (typep object 'instance)
+ (case name
+ (sb!alien-internals:alien-value
+ `(sb!alien:alien
+ ,(sb!alien-internals:unparse-alien-type
+ (sb!alien-internals:alien-value-type object))))
+ (t
+ (class-proper-name class)))
+ name))))
+\f
+;;; FIXME: This belongs somewhere else, perhaps in code/array.lisp.
+(defun upgraded-array-element-type (spec)
+ #!+sb-doc
+ "Return the element type that will actually be used to implement an array
+ with the specifier :ELEMENT-TYPE Spec."
+ (type-specifier
+ (array-type-specialized-element-type
+ (specifier-type `(array ,spec)))))
+\f
+;;;; equality predicates
+
+;;; This is real simple, 'cause the compiler takes care of it.
+(defun eq (obj1 obj2)
+ #!+sb-doc
+ "Return T if OBJ1 and OBJ2 are the same object, otherwise NIL."
+ (eq obj1 obj2))
+
+(defun equal (x y)
+ #!+sb-doc
+ "Returns T if X and Y are EQL or if they are structured components
+ whose elements are EQUAL. Strings and bit-vectors are EQUAL if they
+ are the same length and have identical components. Other arrays must be
+ EQ to be EQUAL."
+ (cond ((eql x y) t)
+ ((consp x)
+ (and (consp y)
+ (equal (car x) (car y))
+ (equal (cdr x) (cdr y))))
+ ((stringp x)
+ (and (stringp y) (string= x y)))
+ ((pathnamep x)
+ (and (pathnamep y) (pathname= x y)))
+ ((bit-vector-p x)
+ (and (bit-vector-p y)
+ (= (the fixnum (length x))
+ (the fixnum (length y)))
+ (do ((i 0 (1+ i))
+ (length (length x)))
+ ((= i length) t)
+ (declare (fixnum i))
+ (or (= (the fixnum (bit x i))
+ (the fixnum (bit y i)))
+ (return nil)))))
+ (t nil)))
+
+;;; EQUALP comparison of HASH-TABLE values
+(defun hash-table-equalp (x y)
+ (declare (type hash-table x y))
+ (or (eq x y)
+ (and (hash-table-p y)
+ (eql (hash-table-count x) (hash-table-count y))
+ (eql (hash-table-test x) (hash-table-test y))
+ (block comparison-of-entries
+ (maphash (lambda (key x-value)
+ (multiple-value-bind (y-value y-value-p)
+ (gethash key y)
+ (unless (and y-value-p (equalp x-value y-value))
+ (return-from comparison-of-entries nil))))
+ x)
+ t))))
+
+(defun equalp (x y)
+ #+nil ; KLUDGE: If doc string, should be accurate: Talk about structures
+ ; and HASH-TABLEs.
+ "Just like EQUAL, but more liberal in several respects.
+ Numbers may be of different types, as long as the values are identical
+ after coercion. Characters may differ in alphabetic case. Vectors and
+ arrays must have identical dimensions and EQUALP elements, but may differ
+ in their type restriction."
+ (cond ((eq x y) t)
+ ((characterp x) (and (characterp y) (char-equal x y)))
+ ((numberp x) (and (numberp y) (= x y)))
+ ((consp x)
+ (and (consp y)
+ (equalp (car x) (car y))
+ (equalp (cdr x) (cdr y))))
+ ((pathnamep x)
+ (and (pathnamep y) (pathname= x y)))
+ ((hash-table-p x)
+ (and (hash-table-p y)
+ (hash-table-equalp x y)))
+ ((typep x 'instance)
+ (let* ((layout-x (%instance-layout x))
+ (len (layout-length layout-x)))
+ (and (typep y 'instance)
+ (eq layout-x (%instance-layout y))
+ (structure-class-p (layout-class layout-x))
+ (do ((i 1 (1+ i)))
+ ((= i len) t)
+ (declare (fixnum i))
+ (let ((x-el (%instance-ref x i))
+ (y-el (%instance-ref y i)))
+ (unless (or (eq x-el y-el)
+ (equalp x-el y-el))
+ (return nil)))))))
+ ((vectorp x)
+ (let ((length (length x)))
+ (and (vectorp y)
+ (= length (length y))
+ (dotimes (i length t)
+ (let ((x-el (aref x i))
+ (y-el (aref y i)))
+ (unless (or (eq x-el y-el)
+ (equalp x-el y-el))
+ (return nil)))))))
+ ((arrayp x)
+ (and (arrayp y)
+ (= (array-rank x) (array-rank y))
+ (dotimes (axis (array-rank x) t)
+ (unless (= (array-dimension x axis)
+ (array-dimension y axis))
+ (return nil)))
+ (dotimes (index (array-total-size x) t)
+ (let ((x-el (row-major-aref x index))
+ (y-el (row-major-aref y index)))
+ (unless (or (eq x-el y-el)
+ (equalp x-el y-el))
+ (return nil))))))
+ (t nil)))
+#!+sb-test
+(let ((test-cases '((0.0 -0.0 t)
+ (0.0 1.0 nil)
+ (#c(1 0) #c(1.0 0) t)
+ (#c(1.1 0) #c(11/10 0) nil) ; due to roundoff error
+ ("Hello" "hello" t)
+ ("Hello" #(#\h #\E #\l #\l #\o) t)
+ ("Hello" "goodbye" nil))))
+ (dolist (test-case test-cases)
+ (destructuring-bind (x y expected-result) test-case
+ (let* ((result (equalp x y))
+ (bresult (if result 1 0))
+ (expected-bresult (if expected-result 1 0)))
+ (unless (= bresult expected-bresult)
+ (error "failed test (EQUALP ~S ~S)" x y))))))
--- /dev/null
+;;;; the printer
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!IMPL")
+
+(file-comment
+ "$Header$")
+\f
+;;;; exported printer control variables
+
+;;; FIXME: Many of these have nontrivial types, e.g. *PRINT-LEVEL*,
+;;; *PRINT-LENGTH*, and *PRINT-LINES* are (OR NULL UNSIGNED-BYTE).
+
+(defvar *print-readably* nil
+ #!+sb-doc
+ "If true, all objects will printed readably. If readable printing is
+ impossible, an error will be signalled. This overrides the value of
+ *PRINT-ESCAPE*.")
+(defvar *print-escape* T
+ #!+sb-doc
+ "Flag which indicates that slashification is on. See the manual")
+(defvar *print-pretty* nil ; (set later when pretty-printer is initialized)
+ #!+sb-doc
+ "Flag which indicates that pretty printing is to be used")
+(defvar *print-base* 10.
+ #!+sb-doc
+ "The output base for integers and rationals.")
+(defvar *print-radix* nil
+ #!+sb-doc
+ "This flag requests to verify base when printing rationals.")
+(defvar *print-level* nil
+ #!+sb-doc
+ "How many levels deep to print. Unlimited if null.")
+(defvar *print-length* nil
+ #!+sb-doc
+ "How many elements to print on each level. Unlimited if null.")
+(defvar *print-circle* nil
+ #!+sb-doc
+ "Whether to worry about circular list structures. See the manual.")
+(defvar *print-case* :upcase
+ #!+sb-doc
+ "What kind of case the printer should use by default")
+(defvar *print-array* t
+ #!+sb-doc
+ "Whether the array should print its guts out")
+(defvar *print-gensym* t
+ #!+sb-doc
+ "If true, symbols with no home package are printed with a #: prefix.
+ If false, no prefix is printed.")
+(defvar *print-lines* nil
+ #!+sb-doc
+ "The maximum number of lines to print. If NIL, unlimited.")
+(defvar *print-right-margin* nil
+ #!+sb-doc
+ "The position of the right margin in ems. If NIL, try to determine this
+ from the stream in use.")
+(defvar *print-miser-width* nil
+ #!+sb-doc
+ "If the remaining space between the current column and the right margin
+ is less than this, then print using ``miser-style'' output. Miser
+ style conditional newlines are turned on, and all indentations are
+ turned off. If NIL, never use miser mode.")
+(defvar *print-pprint-dispatch* nil
+ #!+sb-doc
+ "The pprint-dispatch-table that controls how to pretty print objects. See
+ COPY-PPRINT-DISPATH, PPRINT-DISPATCH, and SET-PPRINT-DISPATCH.")
+
+(defmacro with-standard-io-syntax (&body body)
+ #!+sb-doc
+ "Bind the reader and printer control variables to values that enable READ
+ to reliably read the results of PRINT. These values are:
+ *PACKAGE* the COMMON-LISP-USER package
+ *PRINT-ARRAY* T
+ *PRINT-BASE* 10
+ *PRINT-CASE* :UPCASE
+ *PRINT-CIRCLE* NIL
+ *PRINT-ESCAPE* T
+ *PRINT-GENSYM* T
+ *PRINT-LENGTH* NIL
+ *PRINT-LEVEL* NIL
+ *PRINT-LINES* NIL
+ *PRINT-MISER-WIDTH* NIL
+ *PRINT-PRETTY* NIL
+ *PRINT-RADIX* NIL
+ *PRINT-READABLY* T
+ *PRINT-RIGHT-MARGIN* NIL
+ *READ-BASE* 10
+ *READ-DEFAULT-FLOAT-FORMAT* SINGLE-FLOAT
+ *READ-EVAL* T
+ *READ-SUPPRESS* NIL
+ *READTABLE* the standard readtable."
+ `(%with-standard-io-syntax #'(lambda () ,@body)))
+
+(defun %with-standard-io-syntax (function)
+ (let ((*package* (find-package "COMMON-LISP-USER"))
+ (*print-array* t)
+ (*print-base* 10)
+ (*print-case* :upcase)
+ (*print-circle* nil)
+ (*print-escape* t)
+ (*print-gensym* t)
+ (*print-length* nil)
+ (*print-level* nil)
+ (*print-lines* nil)
+ (*print-miser-width* nil)
+ (*print-pretty* nil)
+ (*print-radix* nil)
+ (*print-readably* t)
+ (*print-right-margin* nil)
+ (*read-base* 10)
+ (*read-default-float-format* 'single-float)
+ (*read-eval* t)
+ (*read-suppress* nil)
+ ;; FIXME: It doesn't seem like a good idea to expose our
+ ;; disaster-recovery *STANDARD-READTABLE* here. Perhaps we
+ ;; should do a COPY-READTABLE? The consing would be unfortunate,
+ ;; though.
+ (*readtable* *standard-readtable*))
+ (funcall function)))
+\f
+;;;; routines to print objects
+
+(defun write (object &key
+ ((:stream stream) *standard-output*)
+ ((:escape *print-escape*) *print-escape*)
+ ((:radix *print-radix*) *print-radix*)
+ ((:base *print-base*) *print-base*)
+ ((:circle *print-circle*) *print-circle*)
+ ((:pretty *print-pretty*) *print-pretty*)
+ ((:level *print-level*) *print-level*)
+ ((:length *print-length*) *print-length*)
+ ((:case *print-case*) *print-case*)
+ ((:array *print-array*) *print-array*)
+ ((:gensym *print-gensym*) *print-gensym*)
+ ((:readably *print-readably*) *print-readably*)
+ ((:right-margin *print-right-margin*)
+ *print-right-margin*)
+ ((:miser-width *print-miser-width*)
+ *print-miser-width*)
+ ((:lines *print-lines*) *print-lines*)
+ ((:pprint-dispatch *print-pprint-dispatch*)
+ *print-pprint-dispatch*))
+ #!+sb-doc
+ "Outputs OBJECT to the specified stream, defaulting to *STANDARD-OUTPUT*"
+ (output-object object (out-synonym-of stream))
+ object)
+
+(defun prin1 (object &optional stream)
+ #!+sb-doc
+ "Outputs a mostly READable printed representation of OBJECT on the specified
+ STREAM."
+ (let ((*print-escape* T))
+ (output-object object (out-synonym-of stream)))
+ object)
+
+(defun princ (object &optional stream)
+ #!+sb-doc
+ "Outputs an aesthetic but not necessarily READable printed representation
+ of OBJECT on the specified STREAM."
+ (let ((*print-escape* NIL)
+ (*print-readably* NIL))
+ (output-object object (out-synonym-of stream)))
+ object)
+
+(defun print (object &optional stream)
+ #!+sb-doc
+ "Outputs a terpri, the mostly READable printed represenation of OBJECT, and
+ space to the specified STREAM."
+ (let ((stream (out-synonym-of stream)))
+ (terpri stream)
+ (prin1 object stream)
+ (write-char #\space stream)
+ object))
+
+(defun pprint (object &optional stream)
+ #!+sb-doc
+ "Prettily outputs OBJECT preceded by a newline."
+ (let ((*print-pretty* t)
+ (*print-escape* t)
+ (stream (out-synonym-of stream)))
+ (terpri stream)
+ (output-object object stream))
+ (values))
+
+(defun write-to-string
+ (object &key
+ ((:escape *print-escape*) *print-escape*)
+ ((:radix *print-radix*) *print-radix*)
+ ((:base *print-base*) *print-base*)
+ ((:circle *print-circle*) *print-circle*)
+ ((:pretty *print-pretty*) *print-pretty*)
+ ((:level *print-level*) *print-level*)
+ ((:length *print-length*) *print-length*)
+ ((:case *print-case*) *print-case*)
+ ((:array *print-array*) *print-array*)
+ ((:gensym *print-gensym*) *print-gensym*)
+ ((:readably *print-readably*) *print-readably*)
+ ((:right-margin *print-right-margin*) *print-right-margin*)
+ ((:miser-width *print-miser-width*) *print-miser-width*)
+ ((:lines *print-lines*) *print-lines*)
+ ((:pprint-dispatch *print-pprint-dispatch*)
+ *print-pprint-dispatch*))
+ #!+sb-doc
+ "Returns the printed representation of OBJECT as a string."
+ (stringify-object object))
+
+(defun prin1-to-string (object)
+ #!+sb-doc
+ "Returns the printed representation of OBJECT as a string with
+ slashification on."
+ (stringify-object object t))
+
+(defun princ-to-string (object)
+ #!+sb-doc
+ "Returns the printed representation of OBJECT as a string with
+ slashification off."
+ (stringify-object object nil))
+
+;;; This produces the printed representation of an object as a string. The
+;;; few ...-TO-STRING functions above call this.
+(defvar *string-output-streams* ())
+(defun stringify-object (object &optional (*print-escape* *print-escape*))
+ (let ((stream (if *string-output-streams*
+ (pop *string-output-streams*)
+ (make-string-output-stream))))
+ (setup-printer-state)
+ (output-object object stream)
+ (prog1
+ (get-output-stream-string stream)
+ (push stream *string-output-streams*))))
+\f
+;;;; support for the PRINT-UNREADABLE-OBJECT macro
+
+(defun %print-unreadable-object (object stream type identity body)
+ (when *print-readably*
+ (error 'print-not-readable :object object))
+ (write-string "#<" stream)
+ (when type
+ (write (type-of object) :stream stream :circle nil
+ :level nil :length nil)
+ (write-char #\space stream))
+ (when body
+ (funcall body))
+ (when identity
+ (unless (and type (null body))
+ (write-char #\space stream))
+ (write-char #\{ stream)
+ (write (get-lisp-obj-address object) :stream stream
+ :radix nil :base 16)
+ (write-char #\} stream))
+ (write-char #\> stream)
+ nil)
+\f
+;;;; WHITESPACE-CHAR-P
+
+;;; This is used in other files, but is defined in this one for some reason.
+
+(defun whitespace-char-p (char)
+ #!+sb-doc
+ "Determines whether or not the character is considered whitespace."
+ (or (char= char #\space)
+ (char= char (code-char tab-char-code))
+ (char= char (code-char return-char-code))
+ (char= char #\linefeed)))
+\f
+;;;; circularity detection stuff
+
+;;; When *PRINT-CIRCLE* is T, this gets bound to a hash table that (eventually)
+;;; ends up with entries for every object printed. When we are initially
+;;; looking for circularities, we enter a T when we find an object for the
+;;; first time, and a 0 when we encounter an object a second time around.
+;;; When we are actually printing, the 0 entries get changed to the actual
+;;; marker value when they are first printed.
+(defvar *circularity-hash-table* nil)
+
+;;; When NIL, we are just looking for circularities. After we have found them
+;;; all, this gets bound to 0. Then whenever we need a new marker, it is
+;;; incremented.
+(defvar *circularity-counter* nil)
+
+(defun check-for-circularity (object &optional assign)
+ #!+sb-doc
+ "Check to see whether OBJECT is a circular reference, and return something
+ non-NIL if it is. If ASSIGN is T, then the number to use in the #n= and
+ #n# noise is assigned at this time. Note: CHECK-FOR-CIRCULARITY must
+ be called *EXACTLY* once with ASSIGN T, or the circularity detection noise
+ will get confused about when to use #n= and when to use #n#. If this
+ returns non-NIL when ASSIGN is T, then you must call HANDLE-CIRCULARITY
+ on it. If you are not using this inside a WITH-CIRCULARITY-DETECTION,
+ then you have to be prepared to handle a return value of :INITIATE which
+ means it needs to initiate the circularity detection noise. See the
+ source for info on how to do that."
+ (cond ((null *print-circle*)
+ ;; Don't bother, nobody cares.
+ nil)
+ ((null *circularity-hash-table*)
+ :initiate)
+ ((null *circularity-counter*)
+ (ecase (gethash object *circularity-hash-table*)
+ ((nil)
+ ;; First encounter.
+ (setf (gethash object *circularity-hash-table*) t)
+ ;; We need to keep looking.
+ nil)
+ ((t)
+ ;; Second encounter.
+ (setf (gethash object *circularity-hash-table*) 0)
+ ;; It's a circular reference.
+ t)
+ (0
+ ;; It's a circular reference.
+ t)))
+ (t
+ (let ((value (gethash object *circularity-hash-table*)))
+ (case value
+ ((nil t)
+ ;; If NIL, we found an object that wasn't there the first time
+ ;; around. If T, exactly one occurance of this object appears.
+ ;; Either way, just print the thing without any special
+ ;; processing. Note: you might argue that finding a new object
+ ;; means that something is broken, but this can happen. If
+ ;; someone uses the ~@<...~:> format directive, it conses a
+ ;; new list each time though format (i.e. the &REST list), so
+ ;; we will have different cdrs.
+ nil)
+ (0
+ (if assign
+ (let ((value (incf *circularity-counter*)))
+ ;; First occurance of this object. Set the counter.
+ (setf (gethash object *circularity-hash-table*) value)
+ value)
+ t))
+ (t
+ ;; Second or later occurance.
+ (- value)))))))
+
+(defun handle-circularity (marker stream)
+ #!+sb-doc
+ "Handle the results of CHECK-FOR-CIRCULARITY. If this returns T then
+ you should go ahead and print the object. If it returns NIL, then
+ you should blow it off."
+ (case marker
+ (:initiate
+ ;; Someone forgot to initiate circularity detection.
+ (let ((*print-circle* nil))
+ (error "trying to use CHECK-FOR-CIRCULARITY when ~
+ circularity checking isn't initiated")))
+ ((t)
+ ;; It's a second (or later) reference to the object while we are
+ ;; just looking. So don't bother groveling it again.
+ nil)
+ (t
+ (write-char #\# stream)
+ (let ((*print-base* 10) (*print-radix* nil))
+ (cond ((minusp marker)
+ (output-integer (- marker) stream)
+ (write-char #\# stream)
+ nil)
+ (t
+ (output-integer marker stream)
+ (write-char #\= stream)
+ t))))))
+\f
+;;;; OUTPUT-OBJECT -- the main entry point
+
+(defvar *pretty-printer* nil
+ #!+sb-doc
+ "The current pretty printer. Should be either a function that takes two
+ arguments (the object and the stream) or NIL to indicate that there is
+ no pretty printer installed.")
+
+(defun output-object (object stream)
+ #!+sb-doc
+ "Output OBJECT to STREAM observing all printer control variables."
+ (labels ((print-it (stream)
+ (if *print-pretty*
+ (if *pretty-printer*
+ (funcall *pretty-printer* object stream)
+ (let ((*print-pretty* nil))
+ (output-ugly-object object stream)))
+ (output-ugly-object object stream)))
+ (check-it (stream)
+ (let ((marker (check-for-circularity object t)))
+ (case marker
+ (:initiate
+ (let ((*circularity-hash-table*
+ (make-hash-table :test 'eq)))
+ (check-it (make-broadcast-stream))
+ (let ((*circularity-counter* 0))
+ (check-it stream))))
+ ((nil)
+ (print-it stream))
+ (t
+ (when (handle-circularity marker stream)
+ (print-it stream)))))))
+ (cond ((or (not *print-circle*)
+ (numberp object)
+ (characterp object)
+ (and (symbolp object) (symbol-package object) t))
+ ;; If it a number, character, or interned symbol, we do not want
+ ;; to check for circularity/sharing.
+ (print-it stream))
+ ((or *circularity-hash-table*
+ (consp object)
+ (typep object 'instance)
+ (typep object '(array t *)))
+ ;; If we have already started circularity detection, this object
+ ;; might be a sharded reference. If we have not, then if it is
+ ;; a cons, a instance, or an array of element type t it might
+ ;; contain a circular reference to itself or multiple shared
+ ;; references.
+ (check-it stream))
+ (t
+ (print-it stream)))))
+
+(defun output-ugly-object (object stream)
+ #!+sb-doc
+ "Output OBJECT to STREAM observing all printer control variables except
+ for *PRINT-PRETTY*. Note: if *PRINT-PRETTY* is non-NIL, then the pretty
+ printer will be used for any components of OBJECT, just not for OBJECT
+ itself."
+ (typecase object
+ ;; KLUDGE: The TYPECASE approach here is non-ANSI; the ANSI definition of
+ ;; PRINT-OBJECT says it provides printing and we're supposed to provide
+ ;; PRINT-OBJECT methods covering all classes. We deviate from this
+ ;; by using PRINT-OBJECT only when we print instance values. However,
+ ;; ANSI makes it hard to tell that we're deviating from this:
+ ;; (1) ANSI specifies that the user isn't supposed to call PRINT-OBJECT
+ ;; directly.
+ ;; (2) ANSI (section 11.1.2.1.2) says it's undefined to define
+ ;; a method on an external symbol in the CL package which is
+ ;; applicable to arg lists containing only direct instances of
+ ;; standardized classes.
+ ;; Thus, in order for the user to detect our sleaziness, he has to do
+ ;; something relatively obscure like
+ ;; (1) actually use tools like FIND-METHOD to look for PRINT-OBJECT
+ ;; methods, or
+ ;; (2) define a PRINT-OBJECT method which is specialized on the stream
+ ;; value (e.g. a Gray stream object).
+ ;; As long as no one comes up with a non-obscure way of detecting this
+ ;; sleaziness, fixing this nonconformity will probably have a low
+ ;; priority. -- WHN 20000121
+ (fixnum
+ (output-integer object stream))
+ (list
+ (if (null object)
+ (output-symbol object stream)
+ (output-list object stream)))
+ (instance
+ (print-object object stream))
+ (function
+ (unless (and (funcallable-instance-p object)
+ (printed-as-funcallable-standard-class object stream))
+ (output-function object stream)))
+ (symbol
+ (output-symbol object stream))
+ (number
+ (etypecase object
+ (integer
+ (output-integer object stream))
+ (float
+ (output-float object stream))
+ (ratio
+ (output-ratio object stream))
+ (ratio
+ (output-ratio object stream))
+ (complex
+ (output-complex object stream))))
+ (character
+ (output-character object stream))
+ (vector
+ (output-vector object stream))
+ (array
+ (output-array object stream))
+ (system-area-pointer
+ (output-sap object stream))
+ (weak-pointer
+ (output-weak-pointer object stream))
+ (lra
+ (output-lra object stream))
+ (code-component
+ (output-code-component object stream))
+ (fdefn
+ (output-fdefn object stream))
+ (t
+ (output-random object stream))))
+\f
+;;;; symbols
+
+;;; Values of *PRINT-CASE* and (READTABLE-CASE *READTABLE*) the last time the
+;;; printer was called.
+(defvar *previous-case* nil)
+(defvar *previous-readtable-case* nil)
+
+;;; This variable contains the current definition of one of three symbol
+;;; printers. SETUP-PRINTER-STATE sets this variable.
+(defvar *internal-symbol-output-function* nil)
+
+;;; This function sets the internal global symbol
+;;; *INTERNAL-SYMBOL-OUTPUT-FUNCTION* to the right function depending
+;;; on the value of *PRINT-CASE*. See the manual for details. The
+;;; print buffer stream is also reset.
+(defun setup-printer-state ()
+ (unless (and (eq *print-case* *previous-case*)
+ (eq (readtable-case *readtable*) *previous-readtable-case*))
+ (setq *previous-case* *print-case*)
+ (setq *previous-readtable-case* (readtable-case *readtable*))
+ (unless (member *print-case* '(:upcase :downcase :capitalize))
+ (setq *print-case* :upcase)
+ (error "invalid *PRINT-CASE* value: ~S" *previous-case*))
+ (unless (member *previous-readtable-case*
+ '(:upcase :downcase :invert :preserve))
+ (setf (readtable-case *readtable*) :upcase)
+ (error "invalid READTABLE-CASE value: ~S" *previous-readtable-case*))
+
+ (setq *internal-symbol-output-function*
+ (case *previous-readtable-case*
+ (:upcase
+ (case *print-case*
+ (:upcase #'output-preserve-symbol)
+ (:downcase #'output-lowercase-symbol)
+ (:capitalize #'output-capitalize-symbol)))
+ (:downcase
+ (case *print-case*
+ (:upcase #'output-uppercase-symbol)
+ (:downcase #'output-preserve-symbol)
+ (:capitalize #'output-capitalize-symbol)))
+ (:preserve #'output-preserve-symbol)
+ (:invert #'output-invert-symbol)))))
+
+;;; Output PNAME (a symbol-name or package-name) surrounded with |'s,
+;;; and with any embedded |'s or \'s escaped.
+(defun output-quoted-symbol-name (pname stream)
+ (write-char #\| stream)
+ (dotimes (index (length pname))
+ (let ((char (schar pname index)))
+ (when (or (char= char #\\) (char= char #\|))
+ (write-char #\\ stream))
+ (write-char char stream)))
+ (write-char #\| stream))
+
+(defun output-symbol (object stream)
+ (if (or *print-escape* *print-readably*)
+ (let ((package (symbol-package object))
+ (name (symbol-name object)))
+ (cond
+ ;; The ANSI spec "22.1.3.3.1 Package Prefixes for Symbols"
+ ;; requires that keywords be printed with preceding colons
+ ;; always, regardless of the value of *PACKAGE*.
+ ((eq package *keyword-package*)
+ (write-char #\: stream))
+ ;; Otherwise, if the symbol's home package is the current
+ ;; one, then a prefix is never necessary.
+ ((eq package *package*))
+ ;; Uninterned symbols print with a leading #:.
+ ((null package)
+ (when (or *print-gensym* *print-readably*)
+ (write-string "#:" stream)))
+ (t
+ (multiple-value-bind (symbol accessible) (find-symbol name *package*)
+ ;; If we can find the symbol by looking it up, it need not
+ ;; be qualified. This can happen if the symbol has been
+ ;; inherited from a package other than its home package.
+ (unless (and accessible (eq symbol object))
+ (output-symbol-name (package-name package) stream)
+ (multiple-value-bind (symbol externalp)
+ (find-external-symbol name package)
+ (declare (ignore symbol))
+ (if externalp
+ (write-char #\: stream)
+ (write-string "::" stream)))))))
+ (output-symbol-name name stream))
+ (output-symbol-name (symbol-name object) stream nil)))
+
+;;; Output the string NAME as if it were a symbol name. In other words,
+;;; diddle its case according to *PRINT-CASE* and READTABLE-CASE.
+(defun output-symbol-name (name stream &optional (maybe-quote t))
+ (declare (type simple-base-string name))
+ (setup-printer-state)
+ (if (and maybe-quote (symbol-quotep name))
+ (output-quoted-symbol-name name stream)
+ (funcall *internal-symbol-output-function* name stream)))
+\f
+;;;; escaping symbols
+
+;;; When we print symbols we have to figure out if they need to be
+;;; printed with escape characters. This isn't a whole lot easier than
+;;; reading symbols in the first place.
+;;;
+;;; For each character, the value of the corresponding element is a
+;;; fixnum with bits set corresponding to attributes that the
+;;; character has. At characters have at least one bit set, so we can
+;;; search for any character with a positive test.
+(defvar *character-attributes*
+ (make-array char-code-limit :element-type '(unsigned-byte 16)
+ :initial-element 0))
+(declaim (type (simple-array (unsigned-byte 16) (#.char-code-limit))
+ *character-attributes*))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+
+;;; Constants which are a bit-mask for each interesting character attribute.
+(defconstant other-attribute (ash 1 0)) ; Anything else legal.
+(defconstant number-attribute (ash 1 1)) ; A numeric digit.
+(defconstant uppercase-attribute (ash 1 2)) ; An uppercase letter.
+(defconstant lowercase-attribute (ash 1 3)) ; A lowercase letter.
+(defconstant sign-attribute (ash 1 4)) ; +-
+(defconstant extension-attribute (ash 1 5)) ; ^_
+(defconstant dot-attribute (ash 1 6)) ; .
+(defconstant slash-attribute (ash 1 7)) ; /
+(defconstant funny-attribute (ash 1 8)) ; Anything illegal.
+
+;;; LETTER-ATTRIBUTE is a local of SYMBOL-QUOTEP. It matches letters that
+;;; don't need to be escaped (according to READTABLE-CASE.)
+(defconstant attribute-names
+ `((number . number-attribute) (lowercase . lowercase-attribute)
+ (uppercase . uppercase-attribute) (letter . letter-attribute)
+ (sign . sign-attribute) (extension . extension-attribute)
+ (dot . dot-attribute) (slash . slash-attribute)
+ (other . other-attribute) (funny . funny-attribute)))
+
+) ; EVAL-WHEN
+
+(flet ((set-bit (char bit)
+ (let ((code (char-code char)))
+ (setf (aref *character-attributes* code)
+ (logior bit (aref *character-attributes* code))))))
+
+ (dolist (char '(#\! #\@ #\$ #\% #\& #\* #\= #\~ #\[ #\] #\{ #\}
+ #\? #\< #\>))
+ (set-bit char other-attribute))
+
+ (dotimes (i 10)
+ (set-bit (digit-char i) number-attribute))
+
+ (do ((code (char-code #\A) (1+ code))
+ (end (char-code #\Z)))
+ ((> code end))
+ (declare (fixnum code end))
+ (set-bit (code-char code) uppercase-attribute)
+ (set-bit (char-downcase (code-char code)) lowercase-attribute))
+
+ (set-bit #\- sign-attribute)
+ (set-bit #\+ sign-attribute)
+ (set-bit #\^ extension-attribute)
+ (set-bit #\_ extension-attribute)
+ (set-bit #\. dot-attribute)
+ (set-bit #\/ slash-attribute)
+
+ ;; Mark anything not explicitly allowed as funny.
+ (dotimes (i char-code-limit)
+ (when (zerop (aref *character-attributes* i))
+ (setf (aref *character-attributes* i) funny-attribute))))
+
+;;; For each character, the value of the corresponding element is the lowest
+;;; base in which that character is a digit.
+(defvar *digit-bases*
+ (make-array char-code-limit
+ :element-type '(unsigned-byte 8)
+ :initial-element 36))
+(declaim (type (simple-array (unsigned-byte 8) (#.char-code-limit))
+ *digit-bases*))
+
+(dotimes (i 36)
+ (let ((char (digit-char i 36)))
+ (setf (aref *digit-bases* (char-code char)) i)))
+
+;;; A FSM-like thingie that determines whether a symbol is a potential
+;;; number or has evil characters in it.
+(defun symbol-quotep (name)
+ (declare (simple-string name))
+ (macrolet ((advance (tag &optional (at-end t))
+ `(progn
+ (when (= index len)
+ ,(if at-end '(go TEST-SIGN) '(return nil)))
+ (setq current (schar name index)
+ code (char-code current)
+ bits (aref attributes code))
+ (incf index)
+ (go ,tag)))
+ (test (&rest attributes)
+ `(not (zerop
+ (the fixnum
+ (logand
+ (logior ,@(mapcar
+ #'(lambda (x)
+ (or (cdr (assoc x attribute-names))
+ (error "Blast!")))
+ attributes))
+ bits)))))
+ (digitp ()
+ `(< (the fixnum (aref bases code)) base)))
+
+ (prog ((len (length name))
+ (attributes *character-attributes*)
+ (bases *digit-bases*)
+ (base *print-base*)
+ (letter-attribute
+ (case (readtable-case *readtable*)
+ (:upcase uppercase-attribute)
+ (:downcase lowercase-attribute)
+ (t (logior lowercase-attribute uppercase-attribute))))
+ (index 0)
+ (bits 0)
+ (code 0)
+ current)
+ (declare (fixnum len base index bits code))
+ (advance START t)
+
+ TEST-SIGN ; At end, see whether it is a sign...
+ (return (not (test sign)))
+
+ OTHER ; Not potential number, see whether funny chars...
+ (let ((mask (logxor (logior lowercase-attribute uppercase-attribute
+ funny-attribute)
+ letter-attribute)))
+ (do ((i (1- index) (1+ i)))
+ ((= i len) (return-from symbol-quotep nil))
+ (unless (zerop (logand (aref attributes (char-code (schar name i)))
+ mask))
+ (return-from symbol-quotep t))))
+
+ START
+ (when (digitp)
+ (if (test letter)
+ (advance LAST-DIGIT-ALPHA)
+ (advance DIGIT)))
+ (when (test letter number other slash) (advance OTHER nil))
+ (when (char= current #\.) (advance DOT-FOUND))
+ (when (test sign extension) (advance START-STUFF nil))
+ (return t)
+
+ DOT-FOUND ; Leading dots...
+ (when (test letter) (advance START-DOT-MARKER nil))
+ (when (digitp) (advance DOT-DIGIT))
+ (when (test number other) (advance OTHER nil))
+ (when (test extension slash sign) (advance START-DOT-STUFF nil))
+ (when (char= current #\.) (advance DOT-FOUND))
+ (return t)
+
+ START-STUFF ; Leading stuff before any dot or digit.
+ (when (digitp)
+ (if (test letter)
+ (advance LAST-DIGIT-ALPHA)
+ (advance DIGIT)))
+ (when (test number other) (advance OTHER nil))
+ (when (test letter) (advance START-MARKER nil))
+ (when (char= current #\.) (advance START-DOT-STUFF nil))
+ (when (test sign extension slash) (advance START-STUFF nil))
+ (return t)
+
+ START-MARKER ; Number marker in leading stuff...
+ (when (test letter) (advance OTHER nil))
+ (go START-STUFF)
+
+ START-DOT-STUFF ; Leading stuff containing dot w/o digit...
+ (when (test letter) (advance START-DOT-STUFF nil))
+ (when (digitp) (advance DOT-DIGIT))
+ (when (test sign extension dot slash) (advance START-DOT-STUFF nil))
+ (when (test number other) (advance OTHER nil))
+ (return t)
+
+ START-DOT-MARKER ; Number marker in leading stuff w/ dot..
+ ;; Leading stuff containing dot w/o digit followed by letter...
+ (when (test letter) (advance OTHER nil))
+ (go START-DOT-STUFF)
+
+ DOT-DIGIT ; In a thing with dots...
+ (when (test letter) (advance DOT-MARKER))
+ (when (digitp) (advance DOT-DIGIT))
+ (when (test number other) (advance OTHER nil))
+ (when (test sign extension dot slash) (advance DOT-DIGIT))
+ (return t)
+
+ DOT-MARKER ; Number maker in number with dot...
+ (when (test letter) (advance OTHER nil))
+ (go DOT-DIGIT)
+
+ LAST-DIGIT-ALPHA ; Previous char is a letter digit...
+ (when (or (digitp) (test sign slash))
+ (advance ALPHA-DIGIT))
+ (when (test letter number other dot) (advance OTHER nil))
+ (return t)
+
+ ALPHA-DIGIT ; Seen a digit which is a letter...
+ (when (or (digitp) (test sign slash))
+ (if (test letter)
+ (advance LAST-DIGIT-ALPHA)
+ (advance ALPHA-DIGIT)))
+ (when (test letter) (advance ALPHA-MARKER))
+ (when (test number other dot) (advance OTHER nil))
+ (return t)
+
+ ALPHA-MARKER ; Number marker in number with alpha digit...
+ (when (test letter) (advance OTHER nil))
+ (go ALPHA-DIGIT)
+
+ DIGIT ; Seen only real numeric digits...
+ (when (digitp)
+ (if (test letter)
+ (advance ALPHA-DIGIT)
+ (advance DIGIT)))
+ (when (test number other) (advance OTHER nil))
+ (when (test letter) (advance MARKER))
+ (when (test extension slash sign) (advance DIGIT))
+ (when (char= current #\.) (advance DOT-DIGIT))
+ (return t)
+
+ MARKER ; Number marker in a numeric number...
+ (when (test letter) (advance OTHER nil))
+ (go DIGIT))))
+\f
+;;;; *INTERNAL-SYMBOL-OUTPUT-FUNCTION*
+;;;;
+;;;; Case hackery. These functions are stored in
+;;;; *INTERNAL-SYMBOL-OUTPUT-FUNCTION* according to the values of *PRINT-CASE*
+;;;; and READTABLE-CASE.
+
+;; Called when:
+;; READTABLE-CASE *PRINT-CASE*
+;; :UPCASE :UPCASE
+;; :DOWNCASE :DOWNCASE
+;; :PRESERVE any
+(defun output-preserve-symbol (pname stream)
+ (declare (simple-string pname))
+ (write-string pname stream))
+
+;; Called when:
+;; READTABLE-CASE *PRINT-CASE*
+;; :UPCASE :DOWNCASE
+(defun output-lowercase-symbol (pname stream)
+ (declare (simple-string pname))
+ (dotimes (index (length pname))
+ (let ((char (schar pname index)))
+ (write-char (char-downcase char) stream))))
+
+;; Called when:
+;; READTABLE-CASE *PRINT-CASE*
+;; :DOWNCASE :UPCASE
+(defun output-uppercase-symbol (pname stream)
+ (declare (simple-string pname))
+ (dotimes (index (length pname))
+ (let ((char (schar pname index)))
+ (write-char (char-upcase char) stream))))
+
+;; Called when:
+;; READTABLE-CASE *PRINT-CASE*
+;; :UPCASE :CAPITALIZE
+;; :DOWNCASE :CAPITALIZE
+(defun output-capitalize-symbol (pname stream)
+ (declare (simple-string pname))
+ (let ((prev-not-alpha t)
+ (up (eq (readtable-case *readtable*) :upcase)))
+ (dotimes (i (length pname))
+ (let ((char (char pname i)))
+ (write-char (if up
+ (if (or prev-not-alpha (lower-case-p char))
+ char
+ (char-downcase char))
+ (if prev-not-alpha
+ (char-upcase char)
+ char))
+ stream)
+ (setq prev-not-alpha (not (alpha-char-p char)))))))
+
+;; Called when:
+;; READTABLE-CASE *PRINT-CASE*
+;; :INVERT any
+(defun output-invert-symbol (pname stream)
+ (declare (simple-string pname))
+ (let ((all-upper t)
+ (all-lower t))
+ (dotimes (i (length pname))
+ (let ((ch (schar pname i)))
+ (when (both-case-p ch)
+ (if (upper-case-p ch)
+ (setq all-lower nil)
+ (setq all-upper nil)))))
+ (cond (all-upper (output-lowercase-symbol pname stream))
+ (all-lower (output-uppercase-symbol pname stream))
+ (t
+ (write-string pname stream)))))
+
+#|
+(defun test1 ()
+ (let ((*readtable* (copy-readtable nil)))
+ (format t "READTABLE-CASE Input Symbol-name~@
+ ----------------------------------~%")
+ (dolist (readtable-case '(:upcase :downcase :preserve :invert))
+ (setf (readtable-case *readtable*) readtable-case)
+ (dolist (input '("ZEBRA" "Zebra" "zebra"))
+ (format t "~&:~A~16T~A~24T~A"
+ (string-upcase readtable-case)
+ input
+ (symbol-name (read-from-string input)))))))
+
+(defun test2 ()
+ (let ((*readtable* (copy-readtable nil)))
+ (format t "READTABLE-CASE *PRINT-CASE* Symbol-name Output Princ~@
+ --------------------------------------------------------~%")
+ (dolist (readtable-case '(:upcase :downcase :preserve :invert))
+ (setf (readtable-case *readtable*) readtable-case)
+ (dolist (*print-case* '(:upcase :downcase :capitalize))
+ (dolist (symbol '(|ZEBRA| |Zebra| |zebra|))
+ (format t "~&:~A~15T:~A~29T~A~42T~A~50T~A"
+ (string-upcase readtable-case)
+ (string-upcase *print-case*)
+ (symbol-name symbol)
+ (prin1-to-string symbol)
+ (princ-to-string symbol)))))))
+|#
+\f
+;;;; recursive objects
+
+(defun output-list (list stream)
+ (descend-into (stream)
+ (write-char #\( stream)
+ (let ((length 0)
+ (list list))
+ (loop
+ (punt-if-too-long length stream)
+ (output-object (pop list) stream)
+ (unless list
+ (return))
+ (when (or (atom list) (check-for-circularity list))
+ (write-string " . " stream)
+ (output-object list stream)
+ (return))
+ (write-char #\space stream)
+ (incf length)))
+ (write-char #\) stream)))
+
+(defun output-vector (vector stream)
+ (declare (vector vector))
+ (cond ((stringp vector)
+ (if (or *print-escape* *print-readably*)
+ (quote-string vector stream)
+ (write-string vector stream)))
+ ((not (or *print-array* *print-readably*))
+ (output-terse-array vector stream))
+ ((bit-vector-p vector)
+ (write-string "#*" stream)
+ (dotimes (i (length vector))
+ (output-object (aref vector i) stream)))
+ (t
+ (when (and *print-readably*
+ (not (eq (array-element-type vector) 't)))
+ (error 'print-not-readable :object vector))
+ (descend-into (stream)
+ (write-string "#(" stream)
+ (dotimes (i (length vector))
+ (unless (zerop i)
+ (write-char #\space stream))
+ (punt-if-too-long i stream)
+ (output-object (aref vector i) stream))
+ (write-string ")" stream)))))
+
+;;; This function outputs a string quoting characters sufficiently that so
+;;; someone can read it in again. Basically, put a slash in front of an
+;;; character satisfying NEEDS-SLASH-P
+(defun quote-string (string stream)
+ (macrolet ((needs-slash-p (char)
+ ;; KLUDGE: We probably should look at the readtable, but just do
+ ;; this for now. [noted by anonymous long ago] -- WHN 19991130
+ `(or (char= ,char #\\)
+ (char= ,char #\"))))
+ (write-char #\" stream)
+ (with-array-data ((data string) (start) (end (length string)))
+ (do ((index start (1+ index)))
+ ((>= index end))
+ (let ((char (schar data index)))
+ (when (needs-slash-p char) (write-char #\\ stream))
+ (write-char char stream))))
+ (write-char #\" stream)))
+
+(defun output-array (array stream)
+ #!+sb-doc
+ "Outputs the printed representation of any array in either the #< or #A
+ form."
+ (if (or *print-array* *print-readably*)
+ (output-array-guts array stream)
+ (output-terse-array array stream)))
+
+;;; to output the abbreviated #< form of an array
+(defun output-terse-array (array stream)
+ (let ((*print-level* nil)
+ (*print-length* nil))
+ (print-unreadable-object (array stream :type t :identity t))))
+
+;;; to output the readable #A form of an array
+(defun output-array-guts (array stream)
+ (when (and *print-readably*
+ (not (eq (array-element-type array) t)))
+ (error 'print-not-readable :object array))
+ (write-char #\# stream)
+ (let ((*print-base* 10))
+ (output-integer (array-rank array) stream))
+ (write-char #\A stream)
+ (with-array-data ((data array) (start) (end))
+ (declare (ignore end))
+ (sub-output-array-guts data (array-dimensions array) stream start)))
+
+(defun sub-output-array-guts (array dimensions stream index)
+ (declare (type (simple-array * (*)) array) (fixnum index))
+ (cond ((null dimensions)
+ (output-object (aref array index) stream))
+ (t
+ (descend-into (stream)
+ (write-char #\( stream)
+ (let* ((dimension (car dimensions))
+ (dimensions (cdr dimensions))
+ (count (reduce #'* dimensions)))
+ (dotimes (i dimension)
+ (unless (zerop i)
+ (write-char #\space stream))
+ (punt-if-too-long i stream)
+ (sub-output-array-guts array dimensions stream index)
+ (incf index count)))
+ (write-char #\) stream)))))
+
+;;; a trivial non-generic-function placeholder for PRINT-OBJECT, for use
+;;; until CLOS is set up (at which time it will be replaced with
+;;; the real generic function implementation)
+(defun print-object (instance stream)
+ (default-structure-print instance stream *current-level*))
+\f
+;;;; integer, ratio, and complex printing (i.e. everything but floats)
+
+(defun output-integer (integer stream)
+ ;; FIXME: This UNLESS form should be pulled out into something like
+ ;; GET-REASONABLE-PRINT-BASE, along the lines of GET-REASONABLE-PACKAGE
+ ;; for the *PACKAGE* variable.
+ (unless (and (fixnump *print-base*)
+ (< 1 *print-base* 37))
+ (let ((obase *print-base*))
+ (setq *print-base* 10.)
+ (error "~A is not a reasonable value for *PRINT-BASE*." obase)))
+ (when (and (not (= *print-base* 10.))
+ *print-radix*)
+ ;; First print leading base information, if any.
+ (write-char #\# stream)
+ (write-char (case *print-base*
+ (2. #\b)
+ (8. #\o)
+ (16. #\x)
+ (T (let ((fixbase *print-base*)
+ (*print-base* 10.)
+ (*print-radix* ()))
+ (sub-output-integer fixbase stream))
+ #\r))
+ stream))
+ ;; Then output a minus sign if the number is negative, then output
+ ;; the absolute value of the number.
+ (cond ((bignump integer) (print-bignum integer stream))
+ ((< integer 0)
+ (write-char #\- stream)
+ (sub-output-integer (- integer) stream))
+ (t
+ (sub-output-integer integer stream)))
+ ;; Print any trailing base information, if any.
+ (if (and (= *print-base* 10.) *print-radix*)
+ (write-char #\. stream)))
+
+(defun sub-output-integer (integer stream)
+ (let ((quotient ())
+ (remainder ()))
+ ;; Recurse until you have all the digits pushed on the stack.
+ (if (not (zerop (multiple-value-setq (quotient remainder)
+ (truncate integer *print-base*))))
+ (sub-output-integer quotient stream))
+ ;; Then as each recursive call unwinds, turn the digit (in remainder)
+ ;; into a character and output the character.
+ (write-char (code-char (if (and (> remainder 9.)
+ (> *print-base* 10.))
+ (+ (char-code #\A) (- remainder 10.))
+ (+ (char-code #\0) remainder)))
+ stream)))
+\f
+;;;; bignum printing
+;;;;
+;;;; written by Steven Handerson (based on Skef's idea)
+;;;;
+;;;; rewritten to remove assumptions about the length of fixnums for the
+;;;; MIPS port by William Lott
+
+;;; *BASE-POWER* holds the number that we keep dividing into the bignum for
+;;; each *print-base*. We want this number as close to *most-positive-fixnum*
+;;; as possible, i.e. (floor (log most-positive-fixnum *print-base*)).
+(defparameter *base-power* (make-array 37 :initial-element nil))
+
+;;; *FIXNUM-POWER--1* holds the number of digits for each *print-base* that
+;;; fit in the corresponding *base-power*.
+(defparameter *fixnum-power--1* (make-array 37 :initial-element nil))
+
+;;; Print the bignum to the stream. We first generate the correct value for
+;;; *base-power* and *fixnum-power--1* if we have not already. Then we call
+;;; bignum-print-aux to do the printing.
+(defun print-bignum (big stream)
+ (unless (aref *base-power* *print-base*)
+ (do ((power-1 -1 (1+ power-1))
+ (new-divisor *print-base* (* new-divisor *print-base*))
+ (divisor 1 new-divisor))
+ ((not (fixnump new-divisor))
+ (setf (aref *base-power* *print-base*) divisor)
+ (setf (aref *fixnum-power--1* *print-base*) power-1))))
+ (bignum-print-aux (cond ((minusp big)
+ (write-char #\- stream)
+ (- big))
+ (t big))
+ (aref *base-power* *print-base*)
+ (aref *fixnum-power--1* *print-base*)
+ stream)
+ big)
+
+(defun bignum-print-aux (big divisor power-1 stream)
+ (multiple-value-bind (newbig fix) (truncate big divisor)
+ (if (fixnump newbig)
+ (sub-output-integer newbig stream)
+ (bignum-print-aux newbig divisor power-1 stream))
+ (do ((zeros power-1 (1- zeros))
+ (base-power *print-base* (* base-power *print-base*)))
+ ((> base-power fix)
+ (dotimes (i zeros) (write-char #\0 stream))
+ (sub-output-integer fix stream)))))
+
+(defun output-ratio (ratio stream)
+ (when *print-radix*
+ (write-char #\# stream)
+ (case *print-base*
+ (2 (write-char #\b stream))
+ (8 (write-char #\o stream))
+ (16 (write-char #\x stream))
+ (t (write *print-base* :stream stream :radix nil :base 10)))
+ (write-char #\r stream))
+ (let ((*print-radix* nil))
+ (output-integer (numerator ratio) stream)
+ (write-char #\/ stream)
+ (output-integer (denominator ratio) stream)))
+
+(defun output-complex (complex stream)
+ (write-string "#C(" stream)
+ (output-object (realpart complex) stream)
+ (write-char #\space stream)
+ (output-object (imagpart complex) stream)
+ (write-char #\) stream))
+\f
+;;;; float printing
+;;;;
+;;;; written by Bill Maddox
+
+;;; FLONUM-TO-STRING (and its subsidiary function FLOAT-STRING) does most of
+;;; the work for all printing of floating point numbers in the printer and in
+;;; FORMAT. It converts a floating point number to a string in a free or
+;;; fixed format with no exponent. The interpretation of the arguments is as
+;;; follows:
+;;;
+;;; X - The floating point number to convert, which must not be
+;;; negative.
+;;; WIDTH - The preferred field width, used to determine the number
+;;; of fraction digits to produce if the FDIGITS parameter
+;;; is unspecified or NIL. If the non-fraction digits and the
+;;; decimal point alone exceed this width, no fraction digits
+;;; will be produced unless a non-NIL value of FDIGITS has been
+;;; specified. Field overflow is not considerd an error at this
+;;; level.
+;;; FDIGITS - The number of fractional digits to produce. Insignificant
+;;; trailing zeroes may be introduced as needed. May be
+;;; unspecified or NIL, in which case as many digits as possible
+;;; are generated, subject to the constraint that there are no
+;;; trailing zeroes.
+;;; SCALE - If this parameter is specified or non-NIL, then the number
+;;; printed is (* x (expt 10 scale)). This scaling is exact,
+;;; and cannot lose precision.
+;;; FMIN - This parameter, if specified or non-NIL, is the minimum
+;;; number of fraction digits which will be produced, regardless
+;;; of the value of WIDTH or FDIGITS. This feature is used by
+;;; the ~E format directive to prevent complete loss of
+;;; significance in the printed value due to a bogus choice of
+;;; scale factor.
+;;;
+;;; Most of the optional arguments are for the benefit for FORMAT and are not
+;;; used by the printer.
+;;;
+;;; Returns:
+;;; (VALUES DIGIT-STRING DIGIT-LENGTH LEADING-POINT TRAILING-POINT DECPNT)
+;;; where the results have the following interpretation:
+;;;
+;;; DIGIT-STRING - The decimal representation of X, with decimal point.
+;;; DIGIT-LENGTH - The length of the string DIGIT-STRING.
+;;; LEADING-POINT - True if the first character of DIGIT-STRING is the
+;;; decimal point.
+;;; TRAILING-POINT - True if the last character of DIGIT-STRING is the
+;;; decimal point.
+;;; POINT-POS - The position of the digit preceding the decimal
+;;; point. Zero indicates point before first digit.
+;;;
+;;; NOTE: FLONUM-TO-STRING goes to a lot of trouble to guarantee accuracy.
+;;; Specifically, the decimal number printed is the closest possible
+;;; approximation to the true value of the binary number to be printed from
+;;; among all decimal representations with the same number of digits. In
+;;; free-format output, i.e. with the number of digits unconstrained, it is
+;;; guaranteed that all the information is preserved, so that a properly-
+;;; rounding reader can reconstruct the original binary number, bit-for-bit,
+;;; from its printed decimal representation. Furthermore, only as many digits
+;;; as necessary to satisfy this condition will be printed.
+;;;
+;;; FLOAT-STRING actually generates the digits for positive numbers. The
+;;; algorithm is essentially that of algorithm Dragon4 in "How to Print
+;;; Floating-Point Numbers Accurately" by Steele and White. The current
+;;; (draft) version of this paper may be found in [CMUC]<steele>tradix.press.
+;;; DO NOT EVEN THINK OF ATTEMPTING TO UNDERSTAND THIS CODE WITHOUT READING
+;;; THE PAPER!
+
+(defvar *digits* "0123456789")
+
+(defun flonum-to-string (x &optional width fdigits scale fmin)
+ (cond ((zerop x)
+ ;; Zero is a special case which FLOAT-STRING cannot handle.
+ (if fdigits
+ (let ((s (make-string (1+ fdigits) :initial-element #\0)))
+ (setf (schar s 0) #\.)
+ (values s (length s) t (zerop fdigits) 0))
+ (values "." 1 t t 0)))
+ (t
+ (multiple-value-bind (sig exp) (integer-decode-float x)
+ (let* ((precision (float-precision x))
+ (digits (float-digits x))
+ (fudge (- digits precision))
+ (width (if width (max width 1) nil)))
+ (float-string (ash sig (- fudge)) (+ exp fudge) precision width
+ fdigits scale fmin))))))
+
+(defun float-string (fraction exponent precision width fdigits scale fmin)
+ (let ((r fraction) (s 1) (m- 1) (m+ 1) (k 0)
+ (digits 0) (decpnt 0) (cutoff nil) (roundup nil) u low high
+ (digit-string (make-array 50
+ :element-type 'base-char
+ :fill-pointer 0
+ :adjustable t)))
+ ;; Represent fraction as r/s, error bounds as m+/s and m-/s.
+ ;; Rational arithmetic avoids loss of precision in subsequent calculations.
+ (cond ((> exponent 0)
+ (setq r (ash fraction exponent))
+ (setq m- (ash 1 exponent))
+ (setq m+ m-))
+ ((< exponent 0)
+ (setq s (ash 1 (- exponent)))))
+ ;;adjust the error bounds m+ and m- for unequal gaps
+ (when (= fraction (ash 1 precision))
+ (setq m+ (ash m+ 1))
+ (setq r (ash r 1))
+ (setq s (ash s 1)))
+ ;;scale value by requested amount, and update error bounds
+ (when scale
+ (if (minusp scale)
+ (let ((scale-factor (expt 10 (- scale))))
+ (setq s (* s scale-factor)))
+ (let ((scale-factor (expt 10 scale)))
+ (setq r (* r scale-factor))
+ (setq m+ (* m+ scale-factor))
+ (setq m- (* m- scale-factor)))))
+ ;;scale r and s and compute initial k, the base 10 logarithm of r
+ (do ()
+ ((>= r (ceiling s 10)))
+ (decf k)
+ (setq r (* r 10))
+ (setq m- (* m- 10))
+ (setq m+ (* m+ 10)))
+ (do ()(nil)
+ (do ()
+ ((< (+ (ash r 1) m+) (ash s 1)))
+ (setq s (* s 10))
+ (incf k))
+ ;;determine number of fraction digits to generate
+ (cond (fdigits
+ ;;use specified number of fraction digits
+ (setq cutoff (- fdigits))
+ ;;don't allow less than fmin fraction digits
+ (if (and fmin (> cutoff (- fmin))) (setq cutoff (- fmin))))
+ (width
+ ;;use as many fraction digits as width will permit
+ ;;but force at least fmin digits even if width will be exceeded
+ (if (< k 0)
+ (setq cutoff (- 1 width))
+ (setq cutoff (1+ (- k width))))
+ (if (and fmin (> cutoff (- fmin))) (setq cutoff (- fmin)))))
+ ;;If we decided to cut off digit generation before precision has
+ ;;been exhausted, rounding the last digit may cause a carry propagation.
+ ;;We can prevent this, preserving left-to-right digit generation, with
+ ;;a few magical adjustments to m- and m+. Of course, correct rounding
+ ;;is also preserved.
+ (when (or fdigits width)
+ (let ((a (- cutoff k))
+ (y s))
+ (if (>= a 0)
+ (dotimes (i a) (setq y (* y 10)))
+ (dotimes (i (- a)) (setq y (ceiling y 10))))
+ (setq m- (max y m-))
+ (setq m+ (max y m+))
+ (when (= m+ y) (setq roundup t))))
+ (when (< (+ (ash r 1) m+) (ash s 1)) (return)))
+ ;;zero-fill before fraction if no integer part
+ (when (< k 0)
+ (setq decpnt digits)
+ (vector-push-extend #\. digit-string)
+ (dotimes (i (- k))
+ (incf digits) (vector-push-extend #\0 digit-string)))
+ ;;generate the significant digits
+ (do ()(nil)
+ (decf k)
+ (when (= k -1)
+ (vector-push-extend #\. digit-string)
+ (setq decpnt digits))
+ (multiple-value-setq (u r) (truncate (* r 10) s))
+ (setq m- (* m- 10))
+ (setq m+ (* m+ 10))
+ (setq low (< (ash r 1) m-))
+ (if roundup
+ (setq high (>= (ash r 1) (- (ash s 1) m+)))
+ (setq high (> (ash r 1) (- (ash s 1) m+))))
+ ;;stop when either precision is exhausted or we have printed as many
+ ;;fraction digits as permitted
+ (when (or low high (and cutoff (<= k cutoff))) (return))
+ (vector-push-extend (char *digits* u) digit-string)
+ (incf digits))
+ ;; If cutoff occurred before first digit, then no digits are
+ ;; generated at all.
+ (when (or (not cutoff) (>= k cutoff))
+ ;;last digit may need rounding
+ (vector-push-extend (char *digits*
+ (cond ((and low (not high)) u)
+ ((and high (not low)) (1+ u))
+ (t (if (<= (ash r 1) s) u (1+ u)))))
+ digit-string)
+ (incf digits))
+ ;;zero-fill after integer part if no fraction
+ (when (>= k 0)
+ (dotimes (i k) (incf digits) (vector-push-extend #\0 digit-string))
+ (vector-push-extend #\. digit-string)
+ (setq decpnt digits))
+ ;;add trailing zeroes to pad fraction if fdigits specified
+ (when fdigits
+ (dotimes (i (- fdigits (- digits decpnt)))
+ (incf digits)
+ (vector-push-extend #\0 digit-string)))
+ ;;all done
+ (values digit-string (1+ digits) (= decpnt 0) (= decpnt digits) decpnt)))
+
+;;; Given a non-negative floating point number, SCALE-EXPONENT returns a new
+;;; floating point number Z in the range (0.1, 1.0] and an exponent E such
+;;; that Z * 10^E is (approximately) equal to the original number. There may
+;;; be some loss of precision due the floating point representation. The
+;;; scaling is always done with long float arithmetic, which helps printing of
+;;; lesser precisions as well as avoiding generic arithmetic.
+;;;
+;;; When computing our initial scale factor using EXPT, we pull out part of
+;;; the computation to avoid over/under flow. When denormalized, we must pull
+;;; out a large factor, since there is more negative exponent range than
+;;; positive range.
+(defun scale-exponent (original-x)
+ (let* ((x (coerce original-x 'long-float)))
+ (multiple-value-bind (sig exponent) (decode-float x)
+ (declare (ignore sig))
+ (if (= x 0.0l0)
+ (values (float 0.0l0 original-x) 1)
+ (let* ((ex (round (* exponent (log 2l0 10))))
+ (x (if (minusp ex)
+ (if (float-denormalized-p x)
+ #!-long-float
+ (* x 1.0l16 (expt 10.0l0 (- (- ex) 16)))
+ #!+long-float
+ (* x 1.0l18 (expt 10.0l0 (- (- ex) 18)))
+ (* x 10.0l0 (expt 10.0l0 (- (- ex) 1))))
+ (/ x 10.0l0 (expt 10.0l0 (1- ex))))))
+ (do ((d 10.0l0 (* d 10.0l0))
+ (y x (/ x d))
+ (ex ex (1+ ex)))
+ ((< y 1.0l0)
+ (do ((m 10.0l0 (* m 10.0l0))
+ (z y (* y m))
+ (ex ex (1- ex)))
+ ((>= z 0.1l0)
+ (values (float z original-x) ex))))))))))
+\f
+;;;; entry point for the float printer
+
+;;; Entry point for the float printer as called by PRINT, PRIN1, PRINC,
+;;; etc. The argument is printed free-format, in either exponential or
+;;; non-exponential notation, depending on its magnitude.
+;;;
+;;; NOTE: When a number is to be printed in exponential format, it is scaled in
+;;; floating point. Since precision may be lost in this process, the
+;;; guaranteed accuracy properties of FLONUM-TO-STRING are lost. The
+;;; difficulty is that FLONUM-TO-STRING performs extensive computations with
+;;; integers of similar magnitude to that of the number being printed. For
+;;; large exponents, the bignums really get out of hand. If bignum arithmetic
+;;; becomes reasonably fast and the exponent range is not too large, then it
+;;; might become attractive to handle exponential notation with the same
+;;; accuracy as non-exponential notation, using the method described in the
+;;; Steele and White paper.
+
+;;; Print the appropriate exponent marker for X and the specified exponent.
+(defun print-float-exponent (x exp stream)
+ (declare (type float x) (type integer exp) (type stream stream))
+ (let ((*print-radix* nil)
+ (plusp (plusp exp)))
+ (if (typep x *read-default-float-format*)
+ (unless (eql exp 0)
+ (format stream "e~:[~;+~]~D" plusp exp))
+ (format stream "~C~:[~;+~]~D"
+ (etypecase x
+ (single-float #\f)
+ (double-float #\d)
+ (short-float #\s)
+ (long-float #\L))
+ plusp exp))))
+
+;;; Write out an infinity using #. notation, or flame out if
+;;; *print-readably* is true and *read-eval* is false.
+#!+sb-infinities
+(defun output-float-infinity (x stream)
+ (declare (type float x) (type stream stream))
+ (cond (*read-eval*
+ (write-string "#." stream))
+ (*print-readably*
+ (error 'print-not-readable :object x))
+ (t
+ (write-string "#<" stream)))
+ (write-string "EXT:" stream)
+ (princ (float-format-name x) stream)
+ (write-string (if (plusp x) "-POSITIVE-" "-NEGATIVE-")
+ stream)
+ (write-string "INFINITY" stream)
+ (unless *read-eval*
+ (write-string ">" stream)))
+
+;;; Output a #< NaN or die trying.
+(defun output-float-nan (x stream)
+ (print-unreadable-object (x stream)
+ (princ (float-format-name x) stream)
+ (write-string (if (float-trapping-nan-p x) " trapping" " quiet") stream)
+ (write-string " NaN" stream)))
+
+;;; the function called by OUTPUT-OBJECT to handle floats
+(defun output-float (x stream)
+ (cond
+ ((float-infinity-p x)
+ (output-float-infinity x stream))
+ ((float-nan-p x)
+ (output-float-nan x stream))
+ (t
+ (let ((x (cond ((minusp (float-sign x))
+ (write-char #\- stream)
+ (- x))
+ (t
+ x))))
+ (cond
+ ((zerop x)
+ (write-string "0.0" stream)
+ (print-float-exponent x 0 stream))
+ (t
+ (output-float-aux x stream (float 1/1000 x) (float 10000000 x))))))))
+(defun output-float-aux (x stream e-min e-max)
+ (if (and (>= x e-min) (< x e-max))
+ ;; free format
+ (multiple-value-bind (str len lpoint tpoint) (flonum-to-string x)
+ (declare (ignore len))
+ (when lpoint (write-char #\0 stream))
+ (write-string str stream)
+ (when tpoint (write-char #\0 stream))
+ (print-float-exponent x 0 stream))
+ ;; exponential format
+ (multiple-value-bind (f ex) (scale-exponent x)
+ (multiple-value-bind (str len lpoint tpoint)
+ (flonum-to-string f nil nil 1)
+ (declare (ignore len))
+ (when lpoint (write-char #\0 stream))
+ (write-string str stream)
+ (when tpoint (write-char #\0 stream))
+ ;; Subtract out scale factor of 1 passed to FLONUM-TO-STRING.
+ (print-float-exponent x (1- ex) stream)))))
+\f
+;;;; other leaf objects
+
+;;; If *PRINT-ESCAPE* is false, just do a WRITE-CHAR, otherwise output the
+;;; character name or the character in the #\char format.
+(defun output-character (char stream)
+ (if (or *print-escape* *print-readably*)
+ (let ((name (char-name char)))
+ (write-string "#\\" stream)
+ (if name
+ (write-string name stream)
+ (write-char char stream)))
+ (write-char char stream)))
+
+(defun output-sap (sap stream)
+ (declare (type system-area-pointer sap))
+ (cond (*read-eval*
+ (format stream "#.(~S #X~8,'0X)" 'int-sap (sap-int sap)))
+ (t
+ (print-unreadable-object (sap stream)
+ (format stream "system area pointer: #X~8,'0X" (sap-int sap))))))
+
+(defun output-weak-pointer (weak-pointer stream)
+ (declare (type weak-pointer weak-pointer))
+ (print-unreadable-object (weak-pointer stream)
+ (multiple-value-bind (value validp) (weak-pointer-value weak-pointer)
+ (cond (validp
+ (write-string "weak pointer: " stream)
+ (write value :stream stream))
+ (t
+ (write-string "broken weak pointer" stream))))))
+
+(defun output-code-component (component stream)
+ (print-unreadable-object (component stream :identity t)
+ (let ((dinfo (%code-debug-info component)))
+ (cond ((eq dinfo :bogus-lra)
+ (write-string "bogus code object" stream))
+ (t
+ (write-string "code object" stream)
+ (when dinfo
+ (write-char #\space stream)
+ (output-object (sb!c::debug-info-name dinfo) stream)))))))
+
+(defun output-lra (lra stream)
+ (print-unreadable-object (lra stream :identity t)
+ (write-string "return PC object" stream)))
+
+(defun output-fdefn (fdefn stream)
+ (print-unreadable-object (fdefn stream)
+ (write-string "FDEFINITION object for " stream)
+ (output-object (fdefn-name fdefn) stream)))
+\f
+;;;; functions
+
+;;; Output OBJECT as using PRINT-OBJECT if it's a
+;;; FUNCALLABLE-STANDARD-CLASS, or return NIL otherwise.
+;;;
+;;; The definition here is a simple temporary placeholder. It will be
+;;; overwritten by a smarter version (capable of calling generic
+;;; PRINT-OBJECT when appropriate) when CLOS is installed.
+(defun printed-as-clos-funcallable-standard-class (object stream)
+ (declare (ignore object stream))
+ nil)
+
+(defun output-function (object stream)
+ (let* ((*print-length* 3) ; in case we have to..
+ (*print-level* 3) ; ..print an interpreted function definition
+ (name (cond ((find (function-subtype object)
+ #(#.sb!vm:closure-header-type
+ #.sb!vm:byte-code-closure-type))
+ "CLOSURE")
+ ((sb!eval::interpreted-function-p object)
+ (or (sb!eval::interpreted-function-%name object)
+ (sb!eval:interpreted-function-lambda-expression
+ object)))
+ ((find (function-subtype object)
+ #(#.sb!vm:function-header-type
+ #.sb!vm:closure-function-header-type))
+ (%function-name object))
+ (t 'no-name-available)))
+ (identified-by-name-p (and (symbolp name)
+ (fboundp name)
+ (eq (fdefinition name) object))))
+ (print-unreadable-object (object
+ stream
+ :identity (not identified-by-name-p))
+ (prin1 'function stream)
+ (unless (eq name 'no-name-available)
+ (format stream " ~S" name)))))
+\f
+;;;; catch-all for unknown things
+
+(defun output-random (object stream)
+ (print-unreadable-object (object stream :identity t)
+ (let ((lowtag (get-lowtag object)))
+ (case lowtag
+ (#.sb!vm:other-pointer-type
+ (let ((type (get-type object)))
+ (case type
+ (#.sb!vm:value-cell-header-type
+ (write-string "value cell " stream)
+ (output-object (sb!c:value-cell-ref object) stream))
+ (t
+ (write-string "unknown pointer object, type=" stream)
+ (let ((*print-base* 16) (*print-radix* t))
+ (output-integer type stream))))))
+ ((#.sb!vm:function-pointer-type
+ #.sb!vm:instance-pointer-type
+ #.sb!vm:list-pointer-type)
+ (write-string "unknown pointer object, type=" stream))
+ (t
+ (case (get-type object)
+ (#.sb!vm:unbound-marker-type
+ (write-string "unbound marker" stream))
+ (t
+ (write-string "unknown immediate object, lowtag=" stream)
+ (let ((*print-base* 2) (*print-radix* t))
+ (output-integer lowtag stream))
+ (write-string ", type=" stream)
+ (let ((*print-base* 16) (*print-radix* t))
+ (output-integer (get-type object) stream)))))))))
--- /dev/null
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB-PROFILE")
+\f
+;;;; reading internal run time with high resolution and low overhead
+
+;;; FIXME: It might make sense to replace this with something
+;;; with finer resolution, e.g. milliseconds or microseconds.
+
+(defconstant +ticks-per-second+ internal-time-units-per-second)
+
+(declaim (inline get-internal-ticks))
+(defun get-internal-ticks () (get-internal-run-time))
+\f
+;;;; PCOUNTER
+
+;;; a PCOUNTER is used to represent an integer quantity which can grow
+;;; bigger than a fixnum, but typically does so, if at all, in many
+;;; small steps, where we don't want to cons on every step. (Total
+;;; system consing, time spent in a profiled function, and bytes
+;;; consed in a profiled function are all examples of such
+;;; quantities.)
+(defstruct (pcounter (:copier nil))
+ (integer 0 :type integer)
+ (fixnum 0 :type fixnum))
+
+(declaim (ftype (function (pcounter integer) pcounter) incf-pcounter))
+(declaim (inline incf-pcounter))
+(defun incf-pcounter (pcounter delta)
+ (let ((sum (+ (pcounter-fixnum pcounter) delta)))
+ (cond ((typep sum 'fixnum)
+ (setf (pcounter-fixnum pcounter) sum))
+ (t
+ (incf (pcounter-integer pcounter) sum)
+ (setf (pcounter-fixnum pcounter) 0))))
+ pcounter)
+
+(declaim (ftype (function (pcounter) integer) pcounter->integer))
+(declaim (inline pcounter->integer))
+(defun pcounter->integer (pcounter)
+ (+ (pcounter-integer pcounter)
+ (pcounter-fixnum pcounter)))
+\f
+;;;; operations on (OR PCOUNTER FIXNUM)
+;;;;
+;;;; When we don't want to cons a PCOUNTER unless we're forced to, we
+;;;; start with a FIXNUM counter and only create a PCOUNTER if the
+;;;; FIXNUM overflows.
+
+(declaim (ftype (function ((or pcounter fixnum) integer) (or pcounter fixnum)) %incf-pcounter-or-fixnum))
+(declaim (inline %incf-pcounter-or-fixnum))
+(defun %incf-pcounter-or-fixnum (x delta)
+ (etypecase x
+ (fixnum
+ (let ((sum (+ x delta)))
+ (if (typep sum 'fixnum)
+ sum
+ (make-pcounter :integer sum))))
+ (pcounter
+ (incf-pcounter x delta))))
+
+(define-modify-macro incf-pcounter-or-fixnum (delta) %incf-pcounter-or-fixnum)
+
+;;; Trade off space for execution time by handling the common fast
+;;; (TYPEP DELTA 'FIXNUM) case inline and only calling generic
+;;; arithmetic as a last resort.
+(defmacro fastbig-incf-pcounter-or-fixnum (x delta)
+ (once-only ((delta delta))
+ `(etypecase ,delta
+ (fixnum (incf-pcounter-or-fixnum ,x ,delta))
+ (integer (incf-pcounter-or-fixnum ,x ,delta)))))
+
+(declaim (ftype (function ((or pcounter fixnum)) integer) pcounter-or-fixnum->integer))
+(declaim (maybe-inline pcounter-or-fixnum->integer))
+(defun pcounter-or-fixnum->integer (x)
+ (etypecase x
+ (fixnum x)
+ (pcounter (pcounter->integer x))))
+\f
+;;;; implementation-dependent interfaces
+
+#|
+;;; To avoid unnecessary consing in the "encapsulation" code, we want
+;;; find out the number of required arguments, and use &REST to
+;;; capture only non-required arguments. This function returns (VALUES
+;;; MIN-ARGS OPTIONALS-P), where MIN-ARGS is the number of required
+;;; arguments and OPTIONALS-P is true iff there are any non-required
+;;; arguments (such as &OPTIONAL, &REST, or &KEY).
+(declaim (ftype (function ((or symbol cons)) (values fixnum t)) fun-signature))
+(defun fun-signature (name)
+ (let ((type (info :function :type name)))
+ (cond ((not (function-type-p type))
+ (values 0 t))
+ (t
+ (values (length (function-type-required type))
+ (or (function-type-optional type)
+ (function-type-keyp type)
+ (function-type-rest type)))))))
+|#
+\f
+;;;; global data structures
+
+;;; We associate a PROFILE-INFO structure with each profiled function
+;;; name. This holds the functions that we call to manipulate the
+;;; closure which implements the encapsulation.
+(defvar *profiled-function-name->info* (make-hash-table))
+(defstruct profile-info
+ (name (required-argument) :read-only t)
+ (encapsulated-fun (required-argument) :type function :read-only t)
+ (encapsulation-fun (required-argument) :type function :read-only t)
+ (read-stats-fun (required-argument) :type function :read-only t)
+ (clear-stats-fun (required-argument) :type function :read-only t))
+
+;;; These variables are used to subtract out the time and consing for
+;;; recursive and other dynamically nested profiled calls. The total
+;;; resource consumed for each nested call is added into the
+;;; appropriate variable. When the outer function returns, these
+;;; amounts are subtracted from the total.
+(defvar *enclosed-ticks* 0)
+(defvar *enclosed-consing* 0)
+(declaim (type (or pcounter fixnum) *enclosed-ticks* *enclosed-consing*))
+
+;;; This variable is also used to subtract out time for nested
+;;; profiled calls. The time inside the profile wrapper call --
+;;; between its two calls to GET-INTERNAL-TICKS -- is accounted
+;;; for by the *ENCLOSED-TIME* variable. However, there's also extra
+;;; overhead involved, before we get to the first call to
+;;; GET-INTERNAL-TICKS, and after we get to the second call. By
+;;; keeping track of the count of enclosed profiled calls, we can try
+;;; to compensate for that.
+(defvar *enclosed-profiles* 0)
+(declaim (type (or pcounter fixnum) *enclosed-profiles*))
+
+;;; the components of profiling overhead
+(defstruct overhead
+ ;; the number of ticks a bare function call takes. This is
+ ;; factored into the other overheads, but not used for itself.
+ (call (required-argument) :type single-float :read-only t)
+ ;; the number of ticks that will be charged to a profiled
+ ;; function due to the profiling code
+ (internal (required-argument) :type single-float :read-only t)
+ ;; the number of ticks of overhead for profiling that a single
+ ;; profiled call adds to the total runtime for the program
+ (total (required-argument) :type single-float :read-only t))
+(defvar *overhead*)
+(declaim (type overhead *overhead*))
+\f
+;;;; profile encapsulations
+
+;;; Trade off space for time by handling the usual all-FIXNUM cases
+;;; inline.
+(defmacro fastbig- (x y)
+ (once-only ((x x) (y y))
+ `(if (and (typep ,x 'fixnum)
+ (typep ,y 'fixnum))
+ (- ,x ,y)
+ (- ,x ,y))))
+(defmacro fastbig-1+ (x)
+ (once-only ((x x))
+ `(if (typep ,x 'index)
+ (1+ ,x)
+ (1+ ,x))))
+
+;;; Return a collection of closures over the same lexical context,
+;;; (VALUES ENCAPSULATION-FUN READ-STATS-FUN CLEAR-STATS-FUN).
+;;;
+;;; ENCAPSULATION-FUN is a plug-in replacement for ENCAPSULATED-FUN,
+;;; which updates statistics whenver it's called.
+;;;
+;;; READ-STATS-FUN returns the statistics:
+;;; (VALUES COUNT TIME CONSING PROFILE).
+;;; COUNT is the count of calls to ENCAPSULATION-FUN. TICKS is
+;;; the total number of ticks spent in ENCAPSULATED-FUN.
+;;; CONSING is the total consing of ENCAPSULATION-FUN. PROFILE is the
+;;; number of calls to the profiled function, stored for the purposes
+;;; of trying to estimate that part of profiling overhead which occurs
+;;; outside the interval between the profile wrapper function's timer
+;;; calls.
+;;;
+;;; CLEAR-STATS-FUN clears the statistics.
+;;;
+;;; (The reason for implementing this as coupled closures, with the
+;;; counts built into the lexical environment, is that we hopes this
+;;; will minimize profiling overhead.)
+(defun profile-encapsulation-lambdas (encapsulated-fun)
+ (declare (type function encapsulated-fun))
+ (declare (optimize speed safety))
+ (let* ((count 0)
+ (ticks 0)
+ (consing 0)
+ (profiles 0))
+ (declare (type (or pcounter fixnum) count ticks consing profiles))
+ (values
+ ;; ENCAPSULATION-FUN
+ (lambda (sb-c:&more arg-context arg-count)
+ #+nil (declare (optimize (speed 3) (safety 0))) ; FIXME: remove #+NIL?
+ (fastbig-incf-pcounter-or-fixnum count 1)
+ (let ((dticks 0)
+ (dconsing 0)
+ (inner-enclosed-profiles 0))
+ (declare (type unsigned-byte dticks dconsing))
+ (declare (type unsigned-byte inner-enclosed-profiles))
+ (multiple-value-prog1
+ (let ((start-ticks (get-internal-ticks))
+ ;; KLUDGE: We add (THE UNSIGNED-BYTE ..) wrappers
+ ;; around GET-BYTES-CONSED because as of
+ ;; sbcl-0.6.4, at the time that the FTYPE of
+ ;; GET-BYTES-CONSED is DECLAIMed, the
+ ;; cross-compiler's type system isn't mature enough
+ ;; to do anything about it. -- WHN 20000503
+ (start-consing (the unsigned-byte (get-bytes-consed)))
+ (*enclosed-ticks* 0)
+ (*enclosed-consing* 0)
+ (*enclosed-profiles* 0))
+ (declare (inline pcounter-or-fixnum->integer))
+ (multiple-value-prog1
+ (multiple-value-call encapsulated-fun
+ (sb-c:%more-arg-values arg-context
+ 0
+ arg-count))
+ (setf dticks (fastbig- (get-internal-ticks) start-ticks)
+ dconsing (fastbig- (the unsigned-byte
+ (get-bytes-consed))
+ start-consing))
+ (setf inner-enclosed-profiles
+ (pcounter-or-fixnum->integer *enclosed-profiles*))
+ (fastbig-incf-pcounter-or-fixnum ticks (fastbig-
+ dticks
+ *enclosed-ticks*))
+ (fastbig-incf-pcounter-or-fixnum consing
+ (fastbig-
+ dconsing
+ *enclosed-consing*))
+ (fastbig-incf-pcounter-or-fixnum profiles
+ inner-enclosed-profiles)))
+ (fastbig-incf-pcounter-or-fixnum *enclosed-ticks* dticks)
+ (fastbig-incf-pcounter-or-fixnum *enclosed-consing* dconsing)
+ (fastbig-incf-pcounter-or-fixnum *enclosed-profiles*
+ (fastbig-1+
+ inner-enclosed-profiles)))))
+ ;; READ-STATS-FUN
+ (lambda ()
+ (values (pcounter-or-fixnum->integer count)
+ (pcounter-or-fixnum->integer ticks)
+ (pcounter-or-fixnum->integer consing)
+ (pcounter-or-fixnum->integer profiles)))
+ ;; CLEAR-STATS-FUN
+ (lambda ()
+ (setf count 0
+ ticks 0
+ consing 0
+ profiles 0)))))
+\f
+;;; interfaces
+
+;;; A symbol names a function, a string names all the functions named
+;;; by symbols in the named package.
+(defun mapc-on-named-functions (function names)
+ (dolist (name names)
+ (etypecase name
+ (symbol (funcall function name))
+ (string (let ((package (find-undeleted-package-or-lose name)))
+ (do-symbols (symbol package)
+ (when (eq (symbol-package symbol) package)
+ (when (fboundp symbol)
+ (funcall function symbol))
+ (let ((setf-name `(setf ,symbol)))
+ (when (fboundp setf-name)
+ (funcall function setf-name)))))))))
+ (values))
+
+;;; Profile the named function, which should exist and not be profiled
+;;; already.
+(defun profile-1-unprofiled-function (name)
+ (let ((encapsulated-fun (fdefinition name)))
+ (multiple-value-bind (encapsulation-fun read-stats-fun clear-stats-fun)
+ (profile-encapsulation-lambdas encapsulated-fun)
+ (setf (fdefinition name)
+ encapsulation-fun)
+ (setf (gethash name *profiled-function-name->info*)
+ (make-profile-info :name name
+ :encapsulated-fun encapsulated-fun
+ :encapsulation-fun encapsulation-fun
+ :read-stats-fun read-stats-fun
+ :clear-stats-fun clear-stats-fun))
+ (values))))
+
+;;; Profile the named function. If already profiled, unprofile first.
+(defun profile-1-function (name)
+ (cond ((fboundp name)
+ (when (gethash name *profiled-function-name->info*)
+ (warn "~S is already profiled, so unprofiling it first." name)
+ (unprofile-1-function name))
+ (profile-1-unprofiled-function name))
+ (t
+ (warn "ignoring undefined function ~S" name)))
+ (values))
+
+;;; Unprofile the named function, if it is profiled.
+(defun unprofile-1-function (name)
+ (let ((pinfo (gethash name *profiled-function-name->info*)))
+ (cond (pinfo
+ (remhash name *profiled-function-name->info*)
+ (if (eq (fdefinition name) (profile-info-encapsulation-fun pinfo))
+ (setf (fdefinition name) (profile-info-encapsulated-fun pinfo))
+ (warn "preserving current definition of redefined function ~S"
+ name)))
+ (t
+ (warn "~S is not a profiled function."))))
+ (values))
+
+(defmacro profile (&rest names)
+ #+sb-doc
+ "PROFILE Name*
+
+ If no names are supplied, return the list of profiled functions.
+
+ If names are supplied, wrap profiling code around the named functions.
+ As in TRACE, the names are not evaluated. A symbol names a function.
+ A string names all the functions named by symbols in the named
+ package. If a function is already profiled, then unprofile and
+ reprofile (useful to notice function redefinition.) If a name is
+ undefined, then we give a warning and ignore it. See also
+ UNPROFILE, REPORT and RESET."
+ (if (null names)
+ `(loop for k being each hash-key in *profiled-function-name->info*
+ collecting k)
+ `(mapc-on-named-functions #'profile-1-function ',names)))
+
+(defmacro unprofile (&rest names)
+ #+sb-doc
+ "Unwrap any profiling code around the named functions, or if no names
+ are given, unprofile all profiled functions. A symbol names
+ a function. A string names all the functions named by symbols in the
+ named package. NAMES defaults to the list of names of all currently
+ profiled functions."
+ (if names
+ `(mapc-on-named-functions #'unprofile-1-function ',names)
+ `(unprofile-all)))
+
+(defun unprofile-all ()
+ (dohash (name profile-info *profiled-function-name->info*)
+ (declare (ignore profile-info))
+ (unprofile-1-function name)))
+
+(defun reset ()
+ "Reset the counters for all profiled functions."
+ (dohash (name profile-info *profiled-function-name->info*)
+ (declare (ignore name))
+ (funcall (profile-info-clear-stats-fun profile-info))))
+\f
+;;;; reporting results
+
+(defstruct time-info
+ name
+ calls
+ seconds
+ consing)
+
+;;; Return our best guess for the run time in a function, subtracting
+;;; out factors for profiling overhead. We subtract out the internal
+;;; overhead for each call to this function, since the internal
+;;; overhead is the part of the profiling overhead for a function that
+;;; is charged to that function.
+;;;
+;;; We also subtract out a factor for each call to a profiled function
+;;; within this profiled function. This factor is the total profiling
+;;; overhead *minus the internal overhead*. We don't subtract out the
+;;; internal overhead, since it was already subtracted when the nested
+;;; profiled functions subtracted their running time from the time for
+;;; the enclosing function.
+(defun compensate-time (calls ticks profile)
+ (let ((raw-compensated
+ (- (/ (float ticks) (float +ticks-per-second+))
+ (* (overhead-internal *overhead*) (float calls))
+ (* (- (overhead-total *overhead*)
+ (overhead-internal *overhead*))
+ (float profile)))))
+ (max raw-compensated 0.0)))
+
+(defun report ()
+ "Report results from profiling. The results are
+approximately adjusted for profiling overhead, but when RAW is true
+the unadjusted results are reported. The compensation may be somewhat
+inaccurate when bignums are involved in runtime calculation, as in
+a very-long-running Lisp process."
+ (declare (optimize (speed 0)))
+ (unless (boundp '*overhead*)
+ (setf *overhead*
+ (compute-overhead)))
+ (let ((time-info-list ())
+ (no-call-name-list ()))
+ (dohash (name pinfo *profiled-function-name->info*)
+ (unless (eq (fdefinition name)
+ (profile-info-encapsulation-fun pinfo))
+ (warn "Function ~S has been redefined, so times may be inaccurate.~@
+ PROFILE it again to record calls to the new definition."
+ name))
+ (multiple-value-bind (calls ticks consing profile)
+ (funcall (profile-info-read-stats-fun pinfo))
+ (if (zerop calls)
+ (push name no-call-name-list)
+ (push (make-time-info :name name
+ :calls calls
+ :seconds (compensate-time calls
+ ticks
+ profile)
+ :consing consing)
+ time-info-list))))
+
+ (setf time-info-list
+ (sort time-info-list
+ #'>=
+ :key #'time-info-seconds))
+
+ (format *trace-output*
+ "~& seconds | consed | calls | sec/call | name~@
+ ------------------------------------------------------~%")
+
+ (let ((total-time 0.0)
+ (total-consed 0)
+ (total-calls 0))
+ (dolist (time-info time-info-list)
+ (incf total-time (time-info-seconds time-info))
+ (incf total-calls (time-info-calls time-info))
+ (incf total-consed (time-info-consing time-info))
+ (format *trace-output*
+ "~10,3F | ~9:D | ~7:D | ~10,6F | ~S~%"
+ (time-info-seconds time-info)
+ (time-info-consing time-info)
+ (time-info-calls time-info)
+ (/ (time-info-seconds time-info)
+ (float (time-info-calls time-info)))
+ (time-info-name time-info)))
+ (format *trace-output*
+ "------------------------------------------------------~@
+ ~10,3F | ~9:D | ~7:D | | Total~%"
+ total-time total-consed total-calls)
+ (format *trace-output*
+ "~%estimated total profiling overhead: ~4,2F seconds~%"
+ (* (overhead-total *overhead*) (float total-calls)))
+ (format *trace-output*
+ "~&overhead estimation parameters:~% ~Ss/call, ~Ss total profiling, ~Ss internal profiling~%"
+ (overhead-call *overhead*)
+ (overhead-total *overhead*)
+ (overhead-internal *overhead*)))
+
+ (when no-call-name-list
+ (format *trace-output*
+ "~%These functions were not called:~%~{~<~%~:; ~S~>~}~%"
+ (sort no-call-name-list #'string<
+ :key (lambda (name)
+ (symbol-name (function-name-block-name name))))))
+
+ (values)))
+\f
+;;;; overhead estimation
+
+;;; We average the timing overhead over this many iterations.
+(defconstant +timer-overhead-iterations+ 50000)
+
+;;; a dummy function that we profile to find profiling overhead
+(declaim (notinline compute-overhead-aux))
+(defun compute-overhead-aux (x)
+ (declare (ignore x)))
+
+;;; Return a newly computed OVERHEAD object.
+(defun compute-overhead ()
+ (flet ((frob ()
+ (let ((start (get-internal-ticks))
+ (fun (symbol-function 'compute-overhead-aux)))
+ (dotimes (i +timer-overhead-iterations+)
+ (funcall fun fun))
+ (/ (float (- (get-internal-ticks) start))
+ (float +ticks-per-second+)
+ (float +timer-overhead-iterations+)))))
+ (let (;; Measure unprofiled calls to estimate call overhead.
+ (call-overhead (frob))
+ total-overhead
+ internal-overhead)
+ ;; Measure profiled calls to estimate profiling overhead.
+ (unwind-protect
+ (progn
+ (profile compute-overhead-aux)
+ (setf total-overhead
+ (- (frob) call-overhead)))
+ (let* ((pinfo (gethash 'compute-overhead-aux
+ *profiled-function-name->info*))
+ (read-stats-fun (profile-info-read-stats-fun pinfo))
+ (time (nth-value 1 (funcall read-stats-fun))))
+ (setf internal-overhead
+ (/ (float time)
+ (float +ticks-per-second+)
+ (float +timer-overhead-iterations+))))
+ (unprofile compute-overhead-aux))
+ (make-overhead :call call-overhead
+ :total total-overhead
+ :internal internal-overhead))))
+
+;;; It would be bad to compute *OVERHEAD*, save it into a .core file,
+;;; then load old *OVERHEAD* value from the .core file into a
+;;; different machine running at a different speed. We avoid this by
+;;; erasing *CALL-OVERHEAD* whenever we save a .core file.
+(pushnew (lambda ()
+ (makunbound '*overhead*))
+ *before-save-initializations*)
--- /dev/null
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!KERNEL")
+
+(file-comment
+ "$Header$")
+
+(sb!alien:def-alien-routine ("purify" %purify) sb!c-call:void
+ (static-roots sb!c-call:unsigned-long)
+ (read-only-roots sb!c-call:unsigned-long))
+
+;;; Compact the info environment. This is written with gratuitous
+;;; recursion to make sure that our (and compact-info-environment's)
+;;; local variables are above the stack top when purify runs.
+(defun compact-environment-aux (name n)
+ (cond
+ ((zerop n)
+ (let ((old-ie (car *info-environment*)))
+ (setq *info-environment*
+ (list* (make-info-environment :name "Working")
+ (compact-info-environment (first *info-environment*)
+ :name name)
+ (rest *info-environment*)))
+ (shrink-vector (sb!c::volatile-info-env-table old-ie) 0)))
+ (t
+ (compact-environment-aux name (1- n))
+ n)))
+
+(defun purify (&key root-structures (environment-name "Auxiliary"))
+ #!+sb-doc
+ "This function optimizes garbage collection by moving all currently live
+ objects into non-collected storage. ROOT-STRUCTURES is an optional list of
+ objects which should be copied first to maximize locality.
+
+ DEFSTRUCT structures defined with the (:PURE T) option are moved into
+ read-only storage, further reducing GC cost. List and vector slots of pure
+ structures are also moved into read-only storage.
+
+ ENVIRONMENT-NAME is gratuitous documentation for compacted version of the
+ current global environment (as seen in SB!C::*INFO-ENVIRONMENT*.) If NIL is
+ supplied, then environment compaction is inhibited."
+
+ (when environment-name (compact-environment-aux environment-name 200))
+
+ (let ((*gc-notify-before*
+ #'(lambda (notify-stream bytes-in-use)
+ (declare (ignore bytes-in-use))
+ (write-string "[doing purification: " notify-stream)
+ (force-output notify-stream)))
+ (*internal-gc*
+ #'(lambda ()
+ (%purify (get-lisp-obj-address root-structures)
+ (get-lisp-obj-address nil))))
+ (*gc-notify-after*
+ #'(lambda (notify-stream &rest ignore)
+ (declare (ignore ignore))
+ (write-line "done]" notify-stream))))
+ #!-gencgc (gc t)
+ #!+gencgc (gc :verbose t))
+ nil)
--- /dev/null
+;;;; querying the user: Y-OR-N-P, YES-OR-NO-P
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!IMPL")
+
+(file-comment
+ "$Header$")
+
+(defun query-readline ()
+ (force-output *query-io*)
+ (string-trim " " (read-line *query-io*)))
+
+;;; FIXME: The ANSI documentation for these says that they
+;;; prompt with strings a la "(Y or N)" or "(Yes or No)", but
+;;; these implementations don't.
+
+(defun y-or-n-p (&optional format-string &rest arguments)
+ #!+sb-doc
+ "Y-OR-N-P prints the message, if any, and reads characters from *QUERY-IO*
+ until the user enters y or Y as an affirmative, or either n or N as a
+ negative answer. It ignores preceding whitespace and asks again if you
+ enter any other characters."
+ (when format-string
+ (fresh-line *query-io*)
+ (apply #'format *query-io* format-string arguments))
+ (loop
+ (let* ((line (query-readline))
+ (ans (if (string= line "")
+ #\? ;Force CASE below to issue instruction.
+ (schar line 0))))
+ (unless (sb!impl::whitespacep ans)
+ (case ans
+ ((#\y #\Y) (return t))
+ ((#\n #\N) (return nil))
+ (t
+ (write-line "Please type \"y\" for yes or \"n\" for no. "
+ *query-io*)
+ (when format-string
+ (apply #'format *query-io* format-string arguments))
+ (force-output *query-io*)))))))
+
+;;; This is similar to Y-OR-N-P, but it clears the input buffer, beeps, and
+;;; uses READ-LINE to get "YES" or "NO".
+(defun yes-or-no-p (&optional format-string &rest arguments)
+ #!+sb-doc
+ "YES-OR-NO-P is similar to Y-OR-N-P, except that it clears the
+ input buffer, beeps, and uses READ-LINE to get the strings
+ YES or NO."
+ (clear-input *query-io*)
+ (beep)
+ (when format-string
+ (fresh-line *query-io*)
+ (apply #'format *query-io* format-string arguments))
+ (do ((ans (query-readline) (query-readline)))
+ (())
+ (cond ((string-equal ans "YES") (return t))
+ ((string-equal ans "NO") (return nil))
+ (t
+ (write-line "Please type \"yes\" for yes or \"no\" for no. "
+ *query-io*)
+ (when format-string
+ (apply #'format *query-io* format-string arguments))))))
--- /dev/null
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!KERNEL")
+
+(file-comment
+ "$Header$")
+
+;;; the size of the chunks returned by RANDOM-CHUNK
+(defconstant random-chunk-length 32)
+
+;;; the amount that we overlap chunks by when building a large integer
+;;; to make up for the loss of randomness in the low bits
+(defconstant random-integer-overlap 3)
+
+;;; extra bits of randomness that we generate before taking the value MOD the
+;;; limit, to avoid loss of randomness near the limit
+(defconstant random-integer-extra-bits 10)
+
+;;; the largest fixnum we can compute from one chunk of bits
+(defconstant random-fixnum-max
+ (1- (ash 1 (- random-chunk-length random-integer-extra-bits))))
+
+(sb!xc:defstruct (random-state (:constructor %make-random-state))
+ (state (init-random-state) :type (simple-array (unsigned-byte 32) (627))))
--- /dev/null
+;;;; READ and friends
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!IMPL")
+
+(file-comment
+ "$Header$")
+\f
+;;; miscellaneous global variables
+
+(defvar *read-default-float-format* 'single-float
+ #!+sb-doc "Float format for 1.0E1")
+(declaim (type (member short-float single-float double-float long-float)
+ *read-default-float-format*))
+
+(defvar *readtable*)
+(declaim (type readtable *readtable*))
+#!+sb-doc
+(setf (fdocumentation '*readtable* 'variable)
+ "Variable bound to current readtable.")
+
+;;; a standard Lisp readtable. This is for recovery from broken
+;;; read-tables (and for WITH-STANDARD-IO-SYNTAX), and should not
+;;; normally be user-visible.
+(defvar *standard-readtable*)
+
+(defvar *old-package* nil
+ #!+sb-doc
+ "the value of *PACKAGE* at the start of the last read, or NIL")
+
+;;; In case we get an error trying to parse a symbol, we want to rebind the
+;;; above stuff so it's cool.
+
+;;; FIXME: These forward declarations should be moved somewhere earlier,
+;;; or discarded.
+(declaim (special *package* *keyword-package* *read-base*))
+\f
+;;;; reader errors
+
+(defun reader-eof-error (stream context)
+ (error 'reader-eof-error
+ :stream stream
+ :context context))
+
+(defun %reader-error (stream control &rest args)
+ (error 'reader-error
+ :stream stream
+ :format-control control
+ :format-arguments args))
+\f
+;;;; constants for character attributes. These are all as in the manual.
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defconstant whitespace 0)
+ (defconstant terminating-macro 1)
+ (defconstant escape 2)
+ (defconstant constituent 3)
+ (defconstant constituent-dot 4)
+ (defconstant constituent-expt 5)
+ (defconstant constituent-slash 6)
+ (defconstant constituent-digit 7)
+ (defconstant constituent-sign 8)
+ ;; the "9" entry intentionally left blank for some reason -- WHN 19990806
+ (defconstant multiple-escape 10)
+ (defconstant package-delimiter 11)
+ ;; a fake attribute for use in read-unqualified-token
+ (defconstant delimiter 12))
+\f
+;;;; macros and functions for character tables
+
+;;; FIXME: could be SB!XC:DEFMACRO inside EVAL-WHEN (COMPILE EVAL)
+(defmacro get-cat-entry (char rt)
+ ;; KLUDGE: Only give this side-effect-free args.
+ ;; FIXME: should probably become inline function
+ `(elt (character-attribute-table ,rt)
+ (char-code ,char)))
+
+(defun set-cat-entry (char newvalue &optional (rt *readtable*))
+ (setf (elt (character-attribute-table rt)
+ (char-code char))
+ newvalue))
+
+;;; FIXME: could be SB!XC:DEFMACRO inside EVAL-WHEN (COMPILE EVAL)
+(defmacro get-cmt-entry (char rt)
+ `(the function
+ (elt (the simple-vector (character-macro-table ,rt))
+ (char-code ,char))))
+
+(defun set-cmt-entry (char newvalue &optional (rt *readtable*))
+ (setf (elt (the simple-vector (character-macro-table rt))
+ (char-code char))
+ (coerce newvalue 'function)))
+
+(defun undefined-macro-char (stream char)
+ (unless *read-suppress*
+ (%reader-error stream "undefined read-macro character ~S" char)))
+
+;;; The character attribute table is a CHAR-CODE-LIMIT vector of integers.
+
+(defmacro test-attribute (char whichclass rt)
+ `(= (the fixnum (get-cat-entry ,char ,rt)) ,whichclass))
+
+;;; predicates for testing character attributes
+
+#!-sb-fluid (declaim (inline whitespacep))
+(defun whitespacep (char &optional (rt *readtable*))
+ (test-attribute char whitespace rt))
+
+(defmacro constituentp (char &optional (rt '*readtable*))
+ `(>= (get-cat-entry ,char ,rt) #.constituent))
+
+(defmacro terminating-macrop (char &optional (rt '*readtable*))
+ `(test-attribute ,char #.terminating-macro ,rt))
+
+(defmacro escapep (char &optional (rt '*readtable*))
+ `(test-attribute ,char #.escape ,rt))
+
+(defmacro multiple-escape-p (char &optional (rt '*readtable*))
+ `(test-attribute ,char #.multiple-escape ,rt))
+
+(defmacro token-delimiterp (char &optional (rt '*readtable*))
+ ;; depends on actual attribute numbering above.
+ `(<= (get-cat-entry ,char ,rt) #.terminating-macro))
+\f
+;;;; secondary attribute table
+
+;;; There are a number of "secondary" attributes which are constant properties
+;;; of characters (as long as they are constituents).
+
+(defvar *secondary-attribute-table*)
+(declaim (type attribute-table *secondary-attribute-table*))
+
+(defun !set-secondary-attribute (char attribute)
+ (setf (elt *secondary-attribute-table* (char-code char))
+ attribute))
+
+(defun !cold-init-secondary-attribute-table ()
+ (setq *secondary-attribute-table*
+ (make-array char-code-limit :element-type '(unsigned-byte 8)
+ :initial-element #.constituent))
+ (!set-secondary-attribute #\: #.package-delimiter)
+ (!set-secondary-attribute #\| #.multiple-escape) ; |) [for EMACS]
+ (!set-secondary-attribute #\. #.constituent-dot)
+ (!set-secondary-attribute #\+ #.constituent-sign)
+ (!set-secondary-attribute #\- #.constituent-sign)
+ (!set-secondary-attribute #\/ #.constituent-slash)
+ (do ((i (char-code #\0) (1+ i)))
+ ((> i (char-code #\9)))
+ (!set-secondary-attribute (code-char i) #.constituent-digit))
+ (!set-secondary-attribute #\E #.constituent-expt)
+ (!set-secondary-attribute #\F #.constituent-expt)
+ (!set-secondary-attribute #\D #.constituent-expt)
+ (!set-secondary-attribute #\S #.constituent-expt)
+ (!set-secondary-attribute #\L #.constituent-expt)
+ (!set-secondary-attribute #\e #.constituent-expt)
+ (!set-secondary-attribute #\f #.constituent-expt)
+ (!set-secondary-attribute #\d #.constituent-expt)
+ (!set-secondary-attribute #\s #.constituent-expt)
+ (!set-secondary-attribute #\l #.constituent-expt))
+
+(defmacro get-secondary-attribute (char)
+ `(elt *secondary-attribute-table*
+ (char-code ,char)))
+\f
+;;;; readtable operations
+
+(defun copy-readtable (&optional (from-readtable *readtable*)
+ (to-readtable (make-readtable)))
+ (let ((really-from-readtable (or from-readtable *standard-readtable*)))
+ (replace (character-attribute-table to-readtable)
+ (character-attribute-table really-from-readtable))
+ (replace (character-macro-table to-readtable)
+ (character-macro-table really-from-readtable))
+ (setf (dispatch-tables to-readtable)
+ (mapcar #'(lambda (pair) (cons (car pair)
+ (copy-seq (cdr pair))))
+ (dispatch-tables really-from-readtable)))
+ to-readtable))
+
+(defun set-syntax-from-char (to-char from-char &optional
+ (to-readtable *readtable*)
+ (from-readtable ()))
+ #!+sb-doc
+ "Causes the syntax of TO-CHAR to be the same as FROM-CHAR in the
+ optional readtable (defaults to the current readtable). The
+ FROM-TABLE defaults to the standard Lisp readtable when NIL."
+ (let ((really-from-readtable (or from-readtable *standard-readtable*)))
+ ;; Copy from-char entries to to-char entries, but make sure that if
+ ;; from char is a constituent you don't copy non-movable secondary
+ ;; attributes (constituent types), and that said attributes magically
+ ;; appear if you transform a non-constituent to a constituent.
+ (let ((att (get-cat-entry from-char really-from-readtable)))
+ (if (constituentp from-char really-from-readtable)
+ (setq att (get-secondary-attribute to-char)))
+ (set-cat-entry to-char att to-readtable)
+ (set-cmt-entry to-char
+ (get-cmt-entry from-char really-from-readtable)
+ to-readtable)))
+ t)
+
+(defun set-macro-character (char function &optional
+ (non-terminatingp nil) (rt *readtable*))
+ #!+sb-doc
+ "Causes char to be a macro character which invokes function when
+ seen by the reader. The non-terminatingp flag can be used to
+ make the macro character non-terminating. The optional readtable
+ argument defaults to the current readtable. Set-macro-character
+ returns T."
+ (if non-terminatingp
+ (set-cat-entry char (get-secondary-attribute char) rt)
+ (set-cat-entry char #.terminating-macro rt))
+ (set-cmt-entry char function rt)
+ T)
+
+(defun get-macro-character (char &optional rt)
+ #!+sb-doc
+ "Returns the function associated with the specified char which is a macro
+ character. The optional readtable argument defaults to the current
+ readtable."
+ (let ((rt (or rt *readtable*)))
+ ;; Check macro syntax, return associated function if it's there.
+ ;; Returns a value for all constituents.
+ (cond ((constituentp char)
+ (values (get-cmt-entry char rt) t))
+ ((terminating-macrop char)
+ (values (get-cmt-entry char rt) nil))
+ (t nil))))
+\f
+;;;; definitions to support internal programming conventions
+
+;;; FIXME: DEFCONSTANT doesn't actually work this way..
+(defconstant eof-object '(*eof*))
+
+(defmacro eofp (char) `(eq ,char eof-object))
+
+(defun flush-whitespace (stream)
+ ;; This flushes whitespace chars, returning the last char it read (a
+ ;; non-white one). It always gets an error on end-of-file.
+ (let ((stream (in-synonym-of stream)))
+ (if (lisp-stream-p stream)
+ (prepare-for-fast-read-char stream
+ (do ((attribute-table (character-attribute-table *readtable*))
+ (char (fast-read-char t) (fast-read-char t)))
+ ((/= (the fixnum (aref attribute-table (char-code char)))
+ #.whitespace)
+ (done-with-fast-read-char)
+ char)))
+ ;; fundamental-stream
+ (do ((attribute-table (character-attribute-table *readtable*))
+ (char (stream-read-char stream) (stream-read-char stream)))
+ ((or (eq char :eof)
+ (/= (the fixnum (aref attribute-table (char-code char)))
+ #.whitespace))
+ (if (eq char :eof)
+ (error 'end-of-file :stream stream)
+ char))))))
+\f
+;;;; temporary initialization hack
+
+(defun !cold-init-standard-readtable ()
+ (setq *standard-readtable* (make-readtable))
+ ;; All characters default to "constituent" in MAKE-READTABLE.
+ ;; *** un-constituent-ize some of these ***
+ (let ((*readtable* *standard-readtable*))
+ (set-cat-entry (code-char tab-char-code) #.whitespace)
+ (set-cat-entry #\linefeed #.whitespace)
+ (set-cat-entry #\space #.whitespace)
+ (set-cat-entry (code-char form-feed-char-code) #.whitespace)
+ (set-cat-entry (code-char return-char-code) #.whitespace)
+ (set-cat-entry #\\ #.escape)
+ (set-cmt-entry #\\ #'read-token)
+ (set-cat-entry (code-char rubout-char-code) #.whitespace)
+ (set-cmt-entry #\: #'read-token)
+ (set-cmt-entry #\| #'read-token)
+ ;; macro definitions
+ (set-macro-character #\" #'read-string)
+ ;; * # macro
+ (set-macro-character #\' #'read-quote)
+ (set-macro-character #\( #'read-list)
+ (set-macro-character #\) #'read-right-paren)
+ (set-macro-character #\; #'read-comment)
+ ;; * backquote
+ ;; all constituents
+ (do ((ichar 0 (1+ ichar))
+ (char))
+ ((= ichar #O200))
+ (setq char (code-char ichar))
+ (when (constituentp char *standard-readtable*)
+ (set-cat-entry char (get-secondary-attribute char))
+ (set-cmt-entry char #'read-token)))))
+\f
+;;;; implementation of the read buffer
+
+(defvar *read-buffer*)
+(defvar *read-buffer-length*)
+;;; FIXME: Is it really helpful to have *READ-BUFFER-LENGTH* be a separate
+;;; variable instead of just calculating it on the fly as (LENGTH *READ-BUFFER*)?
+
+(defvar *inch-ptr*)
+(defvar *ouch-ptr*)
+
+(declaim (type index *read-buffer-length* *inch-ptr* *ouch-ptr*))
+(declaim (simple-string *read-buffer*))
+
+(defmacro reset-read-buffer ()
+ ;; Turn *read-buffer* into an empty read buffer.
+ ;; *Ouch-ptr* always points to next char to write.
+ `(progn
+ (setq *ouch-ptr* 0)
+ ;; *inch-ptr* always points to next char to read.
+ (setq *inch-ptr* 0)))
+
+(defun !cold-init-read-buffer ()
+ (setq *read-buffer* (make-string 512)) ; initial bufsize
+ (setq *read-buffer-length* 512)
+ (reset-read-buffer))
+
+;;; FIXME I removed "THE FIXNUM"'s from OUCH-READ-BUFFER and
+;;; OUCH-UNREAD-BUFFER, check to make sure that Python really is smart enough
+;;; to make good code without them. And while I'm at it, converting them
+;;; from macros to inline functions might be good, too.
+
+(defmacro ouch-read-buffer (char)
+ `(progn
+ ;; When buffer overflow
+ (when (>= *ouch-ptr* *read-buffer-length*)
+ ;; Size should be doubled.
+ (grow-read-buffer))
+ (setf (elt (the simple-string *read-buffer*) *ouch-ptr*) ,char)
+ (setq *ouch-ptr* (1+ *ouch-ptr*))))
+
+;;; macro to move *ouch-ptr* back one.
+(defmacro ouch-unread-buffer ()
+ '(when (> *ouch-ptr* *inch-ptr*)
+ (setq *ouch-ptr* (1- (the fixnum *ouch-ptr*)))))
+
+(defun grow-read-buffer ()
+ (let ((rbl (length (the simple-string *read-buffer*))))
+ (setq *read-buffer*
+ (concatenate 'simple-string
+ *read-buffer*
+ (make-string rbl)))
+ (setq *read-buffer-length* (* 2 rbl))))
+
+(defun inchpeek-read-buffer ()
+ (if (>= (the fixnum *inch-ptr*) (the fixnum *ouch-ptr*))
+ eof-object
+ (elt *read-buffer* *inch-ptr*)))
+
+(defun inch-read-buffer ()
+ (if (>= *inch-ptr* *ouch-ptr*)
+ eof-object
+ (prog1
+ (elt *read-buffer* *inch-ptr*)
+ (incf *inch-ptr*))))
+
+(defmacro unread-buffer ()
+ `(decf *inch-ptr*))
+
+(defun read-unwind-read-buffer ()
+ ;; Keep contents, but make next (INCH..) return first character.
+ (setq *inch-ptr* 0))
+
+(defun read-buffer-to-string ()
+ (subseq *read-buffer* 0 *ouch-ptr*))
+\f
+;;;; READ-PRESERVING-WHITESPACE, READ-DELIMITED-LIST, and READ
+
+;;; an alist for #=, used to keep track of objects with labels assigned that
+;;; have been completely read. Each entry is (integer-tag gensym-tag value).
+;;;
+;;; KLUDGE: Should this really be an alist? It seems as though users
+;;; could reasonably expect N log N performance for large datasets.
+;;; On the other hand, it's probably very very seldom a problem in practice.
+;;; On the third hand, it might be just as easy to use a hash table
+;;; as an alist, so maybe we should. -- WHN 19991202
+(defvar *sharp-equal-alist* ())
+
+(declaim (special *standard-input*))
+
+;;; READ-PRESERVING-WHITESPACE behaves just like READ, only it makes sure
+;;; to leave terminating whitespace in the stream.
+(defun read-preserving-whitespace (&optional (stream *standard-input*)
+ (eof-error-p t)
+ (eof-value nil)
+ (recursivep nil))
+ #!+sb-doc
+ "Reads from stream and returns the object read, preserving the whitespace
+ that followed the object."
+ (cond
+ (recursivep
+ ;; Loop for repeating when a macro returns nothing.
+ (loop
+ (let ((char (read-char stream eof-error-p eof-object)))
+ (cond ((eofp char) (return eof-value))
+ ((whitespacep char))
+ (t
+ (let* ((macrofun (get-cmt-entry char *readtable*))
+ (result (multiple-value-list
+ (funcall macrofun stream char))))
+ ;; Repeat if macro returned nothing.
+ (if result (return (car result)))))))))
+ (t
+ (let ((*sharp-equal-alist* nil))
+ (read-preserving-whitespace stream eof-error-p eof-value t)))))
+
+(defun read-maybe-nothing (stream char)
+ ;;returns nil or a list with one thing, depending.
+ ;;for functions that want comments to return so they can look
+ ;;past them. Assumes char is not whitespace.
+ (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 ()))
+ #!+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)))))
+
+(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."
+ (declare (ignore recursive-p))
+ (do ((char (flush-whitespace input-stream)
+ (flush-whitespace input-stream))
+ (retlist ()))
+ ((char= char endchar) (nreverse retlist))
+ (setq retlist (nconc (read-maybe-nothing input-stream char) retlist))))
+\f
+;;;; basic readmacro definitions
+;;;;
+;;;; 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))
+ (list 'quote (read stream t nil t)))
+
+(defun read-comment (stream ignore)
+ (declare (ignore ignore))
+ (let ((stream (in-synonym-of stream)))
+ (if (lisp-stream-p stream)
+ (prepare-for-fast-read-char stream
+ (do ((char (fast-read-char nil nil)
+ (fast-read-char nil nil)))
+ ((or (not char) (char= char #\newline))
+ (done-with-fast-read-char))))
+ ;; FUNDAMENTAL-STREAM
+ (do ((char (stream-read-char stream) (stream-read-char stream)))
+ ((or (eq char :eof) (char= char #\newline))))))
+ ;; Don't return anything.
+ (values))
+
+(defun read-list (stream ignore)
+ (declare (ignore ignore))
+ (let* ((thelist (list nil))
+ (listtail thelist))
+ (do ((firstchar (flush-whitespace stream) (flush-whitespace stream)))
+ ((char= firstchar #\) ) (cdr thelist))
+ (when (char= firstchar #\.)
+ (let ((nextchar (read-char stream t)))
+ (cond ((token-delimiterp nextchar)
+ (cond ((eq listtail thelist)
+ (%reader-error
+ stream
+ "Nothing appears before . in list."))
+ ((whitespacep nextchar)
+ (setq nextchar (flush-whitespace stream))))
+ (rplacd listtail
+ ;; Return list containing last thing.
+ (car (read-after-dot stream nextchar)))
+ (return (cdr thelist)))
+ ;; Put back NEXTCHAR so that we can read it normally.
+ (t (unread-char nextchar stream)))))
+ ;; Next thing is not an isolated dot.
+ (let ((listobj (read-maybe-nothing stream firstchar)))
+ ;; allows the possibility that a comment was read
+ (when listobj
+ (rplacd listtail listobj)
+ (setq listtail listobj))))))
+
+(defun read-after-dot (stream firstchar)
+ ;; FIRSTCHAR is non-whitespace!
+ (let ((lastobj ()))
+ (do ((char firstchar (flush-whitespace stream)))
+ ((char= char #\) )
+ (%reader-error stream "Nothing appears after . in list."))
+ ;; See whether there's something there.
+ (setq lastobj (read-maybe-nothing stream char))
+ (when lastobj (return t)))
+ ;; At least one thing appears after the dot.
+ ;; Check for more than one thing following dot.
+ (do ((lastchar (flush-whitespace stream)
+ (flush-whitespace stream)))
+ ((char= lastchar #\) ) lastobj) ;success!
+ ;; Try reading virtual whitespace.
+ (if (read-maybe-nothing stream lastchar)
+ (%reader-error stream "More than one object follows . in list.")))))
+
+(defun read-string (stream closech)
+ ;; This accumulates chars until it sees same char that invoked it.
+ ;; For a very long string, this could end up bloating the read buffer.
+ (reset-read-buffer)
+ (let ((stream (in-synonym-of stream)))
+ (if (lisp-stream-p stream)
+ (prepare-for-fast-read-char stream
+ (do ((char (fast-read-char t) (fast-read-char t)))
+ ((char= char closech)
+ (done-with-fast-read-char))
+ (if (escapep char) (setq char (fast-read-char t)))
+ (ouch-read-buffer char)))
+ ;; FUNDAMENTAL-STREAM
+ (do ((char (stream-read-char stream) (stream-read-char stream)))
+ ((or (eq char :eof) (char= char closech))
+ (if (eq char :eof)
+ (error 'end-of-file :stream stream)))
+ (when (escapep char)
+ (setq char (stream-read-char stream))
+ (if (eq char :eof)
+ (error 'end-of-file :stream stream)))
+ (ouch-read-buffer char))))
+ (read-buffer-to-string))
+
+(defun read-right-paren (stream ignore)
+ (declare (ignore ignore))
+ (%reader-error stream "unmatched close parenthesis"))
+
+;;; Read from the stream up to the next delimiter. Leave the resulting token in
+;;; *read-buffer*, and return two values:
+;;; -- a list of the escaped character positions, and
+;;; -- The position of the first package delimiter (or NIL).
+(defun internal-read-extended-token (stream firstchar)
+ (reset-read-buffer)
+ (do ((char firstchar (read-char stream nil eof-object))
+ (escapes ())
+ (colon nil))
+ ((cond ((eofp char) t)
+ ((token-delimiterp char)
+ (unread-char char stream)
+ t)
+ (t nil))
+ (values escapes colon))
+ (cond ((escapep char)
+ ;; It can't be a number, even if it's 1\23.
+ ;; Read next char here, so it won't be casified.
+ (push *ouch-ptr* escapes)
+ (let ((nextchar (read-char stream nil eof-object)))
+ (if (eofp nextchar)
+ (reader-eof-error stream "after escape character")
+ (ouch-read-buffer nextchar))))
+ ((multiple-escape-p char)
+ ;; Read to next multiple-escape, escaping single chars along the
+ ;; way.
+ (loop
+ (let ((ch (read-char stream nil eof-object)))
+ (cond
+ ((eofp ch)
+ (reader-eof-error stream "inside extended token"))
+ ((multiple-escape-p ch) (return))
+ ((escapep ch)
+ (let ((nextchar (read-char stream nil eof-object)))
+ (if (eofp nextchar)
+ (reader-eof-error stream "after escape character")
+ (ouch-read-buffer nextchar))))
+ (t
+ (push *ouch-ptr* escapes)
+ (ouch-read-buffer ch))))))
+ (t
+ (when (and (constituentp char)
+ (eql (get-secondary-attribute char) #.package-delimiter)
+ (not colon))
+ (setq colon *ouch-ptr*))
+ (ouch-read-buffer char)))))
+\f
+;;;; character classes
+
+;;; Return the character class for CHAR.
+(defmacro char-class (char attable)
+ `(let ((att (aref ,attable (char-code ,char))))
+ (declare (fixnum att))
+ (if (<= att #.terminating-macro)
+ #.delimiter
+ att)))
+
+;;; Return the character class for CHAR, which might be part of a rational
+;;; number.
+(defmacro char-class2 (char attable)
+ `(let ((att (aref ,attable (char-code ,char))))
+ (declare (fixnum att))
+ (if (<= att #.terminating-macro)
+ #.delimiter
+ (if (digit-char-p ,char *read-base*)
+ constituent-digit
+ (if (= att constituent-digit)
+ constituent
+ att)))))
+
+;;; Return the character class for a char which might be part of a rational or
+;;; floating number. (Assume that it is a digit if it could be.)
+(defmacro char-class3 (char attable)
+ `(let ((att (aref ,attable (char-code ,char))))
+ (declare (fixnum att))
+ (if possibly-rational
+ (setq possibly-rational
+ (or (digit-char-p ,char *read-base*)
+ (= att constituent-slash))))
+ (if possibly-float
+ (setq possibly-float
+ (or (digit-char-p ,char 10)
+ (= att constituent-dot))))
+ (if (<= att #.terminating-macro)
+ #.delimiter
+ (if (digit-char-p ,char (max *read-base* 10))
+ (if (digit-char-p ,char *read-base*)
+ constituent-digit
+ constituent)
+ att))))
+\f
+;;;; token fetching
+
+(defvar *read-suppress* nil
+ #!+sb-doc
+ "Suppresses most interpreting of the reader when T")
+
+(defvar *read-base* 10
+ #!+sb-doc
+ "The radix that Lisp reads numbers in.")
+(declaim (type (integer 2 36) *read-base*))
+
+;;; Modify the read buffer according to READTABLE-CASE, ignoring escapes.
+;;; ESCAPES is a list of the escaped indices, in reverse order.
+(defun casify-read-buffer (escapes)
+ (let ((case (readtable-case *readtable*)))
+ (cond
+ ((and (null escapes) (eq case :upcase))
+ (dotimes (i *ouch-ptr*)
+ (setf (schar *read-buffer* i)
+ (char-upcase (schar *read-buffer* i)))))
+ ((eq case :preserve))
+ (t
+ (macrolet ((skip-esc (&body body)
+ `(do ((i (1- *ouch-ptr*) (1- i))
+ (escapes escapes))
+ ((minusp i))
+ (declare (fixnum i))
+ (when (or (null escapes)
+ (let ((esc (first escapes)))
+ (declare (fixnum esc))
+ (cond ((< esc i) t)
+ (t
+ (assert (= esc i))
+ (pop escapes)
+ nil))))
+ (let ((ch (schar *read-buffer* i)))
+ ,@body)))))
+ (flet ((lower-em ()
+ (skip-esc (setf (schar *read-buffer* i) (char-downcase ch))))
+ (raise-em ()
+ (skip-esc (setf (schar *read-buffer* i) (char-upcase ch)))))
+ (ecase case
+ (:upcase (raise-em))
+ (:downcase (lower-em))
+ (:invert
+ (let ((all-upper t)
+ (all-lower t))
+ (skip-esc
+ (when (both-case-p ch)
+ (if (upper-case-p ch)
+ (setq all-lower nil)
+ (setq all-upper nil))))
+ (cond (all-lower (raise-em))
+ (all-upper (lower-em))))))))))))
+
+(defun read-token (stream firstchar)
+ #!+sb-doc
+ "This function is just an fsm that recognizes numbers and symbols."
+ ;; Check explicitly whether firstchar has entry for non-terminating
+ ;; in character-attribute-table and read-dot-number-symbol in CMT.
+ ;; Report an error if these are violated (if we called this, we want
+ ;; something that is a legitimate token!).
+ ;; Read in the longest possible string satisfying the bnf for
+ ;; "unqualified-token". Leave the result in the *READ-BUFFER*.
+ ;; Return next char after token (last char read).
+ (when *read-suppress*
+ (internal-read-extended-token stream firstchar)
+ (return-from read-token nil))
+ (let ((attribute-table (character-attribute-table *readtable*))
+ (package-designator nil)
+ (colons 0)
+ (possibly-rational t)
+ (possibly-float t)
+ (escapes ()))
+ (reset-read-buffer)
+ (prog ((char firstchar))
+ (case (char-class3 char attribute-table)
+ (#.constituent-sign (go SIGN))
+ (#.constituent-digit (go LEFTDIGIT))
+ (#.constituent-dot (go FRONTDOT))
+ (#.escape (go ESCAPE))
+ (#.package-delimiter (go COLON))
+ (#.multiple-escape (go MULT-ESCAPE))
+ ;;can't have eof, whitespace, or terminating macro as first char!
+ (t (go SYMBOL)))
+ SIGN
+ ;;saw "sign"
+ (ouch-read-buffer char)
+ (setq char (read-char stream nil nil))
+ (unless char (go RETURN-SYMBOL))
+ (setq possibly-rational t
+ possibly-float t)
+ (case (char-class3 char attribute-table)
+ (#.constituent-digit (go LEFTDIGIT))
+ (#.constituent-dot (go SIGNDOT))
+ (#.escape (go ESCAPE))
+ (#.package-delimiter (go COLON))
+ (#.multiple-escape (go MULT-ESCAPE))
+ (#.delimiter (unread-char char stream) (go RETURN-SYMBOL))
+ (t (go SYMBOL)))
+ LEFTDIGIT
+ ;;saw "[sign] {digit}+"
+ (ouch-read-buffer char)
+ (setq char (read-char stream nil nil))
+ (unless char (return (make-integer)))
+ (case (char-class3 char attribute-table)
+ (#.constituent-digit (go LEFTDIGIT))
+ (#.constituent-dot (if possibly-float
+ (go MIDDLEDOT)
+ (go SYMBOL)))
+ (#.constituent-expt (go EXPONENT))
+ (#.constituent-slash (if possibly-rational
+ (go RATIO)
+ (go SYMBOL)))
+ (#.delimiter (unread-char char stream) (return (make-integer)))
+ (#.escape (go ESCAPE))
+ (#.multiple-escape (go MULT-ESCAPE))
+ (#.package-delimiter (go COLON))
+ (t (go SYMBOL)))
+ MIDDLEDOT
+ ;;saw "[sign] {digit}+ dot"
+ (ouch-read-buffer char)
+ (setq char (read-char stream nil nil))
+ (unless char (return (let ((*read-base* 10))
+ (make-integer))))
+ (case (char-class char attribute-table)
+ (#.constituent-digit (go RIGHTDIGIT))
+ (#.constituent-expt (go EXPONENT))
+ (#.delimiter
+ (unread-char char stream)
+ (return (let ((*read-base* 10))
+ (make-integer))))
+ (#.escape (go ESCAPE))
+ (#.multiple-escape (go MULT-ESCAPE))
+ (#.package-delimiter (go COLON))
+ (t (go SYMBOL)))
+ RIGHTDIGIT
+ ;;saw "[sign] {digit}* dot {digit}+"
+ (ouch-read-buffer char)
+ (setq char (read-char stream nil nil))
+ (unless char (return (make-float)))
+ (case (char-class char attribute-table)
+ (#.constituent-digit (go RIGHTDIGIT))
+ (#.constituent-expt (go EXPONENT))
+ (#.delimiter (unread-char char stream) (return (make-float)))
+ (#.escape (go ESCAPE))
+ (#.multiple-escape (go MULT-ESCAPE))
+ (#.package-delimiter (go COLON))
+ (t (go SYMBOL)))
+ SIGNDOT
+ ;;saw "[sign] dot"
+ (ouch-read-buffer char)
+ (setq char (read-char stream nil nil))
+ (unless char (go RETURN-SYMBOL))
+ (case (char-class char attribute-table)
+ (#.constituent-digit (go RIGHTDIGIT))
+ (#.delimiter (unread-char char stream) (go RETURN-SYMBOL))
+ (#.escape (go ESCAPE))
+ (#.multiple-escape (go MULT-ESCAPE))
+ (t (go SYMBOL)))
+ FRONTDOT
+ ;;saw "dot"
+ (ouch-read-buffer char)
+ (setq char (read-char stream nil nil))
+ (unless char (%reader-error stream "dot context error"))
+ (case (char-class char attribute-table)
+ (#.constituent-digit (go RIGHTDIGIT))
+ (#.constituent-dot (go DOTS))
+ (#.delimiter (%reader-error stream "dot context error"))
+ (#.escape (go ESCAPE))
+ (#.multiple-escape (go MULT-ESCAPE))
+ (#.package-delimiter (go COLON))
+ (t (go SYMBOL)))
+ EXPONENT
+ (ouch-read-buffer char)
+ (setq char (read-char stream nil nil))
+ (unless char (go RETURN-SYMBOL))
+ (case (char-class char attribute-table)
+ (#.constituent-sign (go EXPTSIGN))
+ (#.constituent-digit (go EXPTDIGIT))
+ (#.delimiter (unread-char char stream) (go RETURN-SYMBOL))
+ (#.escape (go ESCAPE))
+ (#.multiple-escape (go MULT-ESCAPE))
+ (#.package-delimiter (go COLON))
+ (t (go SYMBOL)))
+ EXPTSIGN
+ ;;we got to EXPONENT, and saw a sign character.
+ (ouch-read-buffer char)
+ (setq char (read-char stream nil nil))
+ (unless char (go RETURN-SYMBOL))
+ (case (char-class char attribute-table)
+ (#.constituent-digit (go EXPTDIGIT))
+ (#.delimiter (unread-char char stream) (go RETURN-SYMBOL))
+ (#.escape (go ESCAPE))
+ (#.multiple-escape (go MULT-ESCAPE))
+ (#.package-delimiter (go COLON))
+ (t (go SYMBOL)))
+ EXPTDIGIT
+ ;;got to EXPONENT, saw "[sign] {digit}+"
+ (ouch-read-buffer char)
+ (setq char (read-char stream nil nil))
+ (unless char (return (make-float)))
+ (case (char-class char attribute-table)
+ (#.constituent-digit (go EXPTDIGIT))
+ (#.delimiter (unread-char char stream) (return (make-float)))
+ (#.escape (go ESCAPE))
+ (#.multiple-escape (go MULT-ESCAPE))
+ (#.package-delimiter (go COLON))
+ (t (go SYMBOL)))
+ RATIO
+ ;;saw "[sign] {digit}+ slash"
+ (ouch-read-buffer char)
+ (setq char (read-char stream nil nil))
+ (unless char (go RETURN-SYMBOL))
+ (case (char-class2 char attribute-table)
+ (#.constituent-digit (go RATIODIGIT))
+ (#.delimiter (unread-char char stream) (go RETURN-SYMBOL))
+ (#.escape (go ESCAPE))
+ (#.multiple-escape (go MULT-ESCAPE))
+ (#.package-delimiter (go COLON))
+ (t (go SYMBOL)))
+ RATIODIGIT
+ ;;saw "[sign] {digit}+ slash {digit}+"
+ (ouch-read-buffer char)
+ (setq char (read-char stream nil nil))
+ (unless char (return (make-ratio)))
+ (case (char-class2 char attribute-table)
+ (#.constituent-digit (go RATIODIGIT))
+ (#.delimiter (unread-char char stream) (return (make-ratio)))
+ (#.escape (go ESCAPE))
+ (#.multiple-escape (go MULT-ESCAPE))
+ (#.package-delimiter (go COLON))
+ (t (go SYMBOL)))
+ DOTS
+ ;; saw "dot {dot}+"
+ (ouch-read-buffer char)
+ (setq char (read-char stream nil nil))
+ (unless char (%reader-error stream "too many dots"))
+ (case (char-class char attribute-table)
+ (#.constituent-dot (go DOTS))
+ (#.delimiter
+ (unread-char char stream)
+ (%reader-error stream "too many dots"))
+ (#.escape (go ESCAPE))
+ (#.multiple-escape (go MULT-ESCAPE))
+ (#.package-delimiter (go COLON))
+ (t (go SYMBOL)))
+ SYMBOL
+ ;; not a dot, dots, or number
+ (let ((stream (in-synonym-of stream)))
+ (if (lisp-stream-p stream)
+ (prepare-for-fast-read-char stream
+ (prog ()
+ SYMBOL-LOOP
+ (ouch-read-buffer char)
+ (setq char (fast-read-char nil nil))
+ (unless char (go RETURN-SYMBOL))
+ (case (char-class char attribute-table)
+ (#.escape (done-with-fast-read-char)
+ (go ESCAPE))
+ (#.delimiter (done-with-fast-read-char)
+ (unread-char char stream)
+ (go RETURN-SYMBOL))
+ (#.multiple-escape (done-with-fast-read-char)
+ (go MULT-ESCAPE))
+ (#.package-delimiter (done-with-fast-read-char)
+ (go COLON))
+ (t (go SYMBOL-LOOP)))))
+ ;; fundamental-stream
+ (prog ()
+ SYMBOL-LOOP
+ (ouch-read-buffer char)
+ (setq char (stream-read-char stream))
+ (when (eq char :eof) (go RETURN-SYMBOL))
+ (case (char-class char attribute-table)
+ (#.escape (go ESCAPE))
+ (#.delimiter (stream-unread-char stream char)
+ (go RETURN-SYMBOL))
+ (#.multiple-escape (go MULT-ESCAPE))
+ (#.package-delimiter (go COLON))
+ (t (go SYMBOL-LOOP))))))
+ ESCAPE
+ ;;saw an escape.
+ ;;don't put the escape in the read buffer.
+ ;;read-next char, put in buffer (no case conversion).
+ (let ((nextchar (read-char stream nil nil)))
+ (unless nextchar
+ (reader-eof-error stream "after escape character"))
+ (push *ouch-ptr* escapes)
+ (ouch-read-buffer nextchar))
+ (setq char (read-char stream nil nil))
+ (unless char (go RETURN-SYMBOL))
+ (case (char-class char attribute-table)
+ (#.delimiter (unread-char char stream) (go RETURN-SYMBOL))
+ (#.escape (go ESCAPE))
+ (#.multiple-escape (go MULT-ESCAPE))
+ (#.package-delimiter (go COLON))
+ (t (go SYMBOL)))
+ MULT-ESCAPE
+ (do ((char (read-char stream t) (read-char stream t)))
+ ((multiple-escape-p char))
+ (if (escapep char) (setq char (read-char stream t)))
+ (push *ouch-ptr* escapes)
+ (ouch-read-buffer char))
+ (setq char (read-char stream nil nil))
+ (unless char (go RETURN-SYMBOL))
+ (case (char-class char attribute-table)
+ (#.delimiter (unread-char char stream) (go RETURN-SYMBOL))
+ (#.escape (go ESCAPE))
+ (#.multiple-escape (go MULT-ESCAPE))
+ (#.package-delimiter (go COLON))
+ (t (go SYMBOL)))
+ COLON
+ (casify-read-buffer escapes)
+ (unless (zerop colons)
+ (%reader-error stream "too many colons in ~S"
+ (read-buffer-to-string)))
+ (setq colons 1)
+ (setq package-designator
+ (if (plusp *ouch-ptr*)
+ ;; FIXME: It seems inefficient to cons up a package
+ ;; designator string every time we read a symbol with an
+ ;; explicit package prefix. Perhaps we could implement
+ ;; a FIND-PACKAGE* function analogous to INTERN*
+ ;; and friends?
+ (read-buffer-to-string)
+ *keyword-package*))
+ (reset-read-buffer)
+ (setq escapes ())
+ (setq char (read-char stream nil nil))
+ (unless char (reader-eof-error stream "after reading a colon"))
+ (case (char-class char attribute-table)
+ (#.delimiter
+ (unread-char char stream)
+ (%reader-error stream
+ "illegal terminating character after a colon: ~S"
+ char))
+ (#.escape (go ESCAPE))
+ (#.multiple-escape (go MULT-ESCAPE))
+ (#.package-delimiter (go INTERN))
+ (t (go SYMBOL)))
+ INTERN
+ (setq colons 2)
+ (setq char (read-char stream nil nil))
+ (unless char
+ (reader-eof-error stream "after reading a colon"))
+ (case (char-class char attribute-table)
+ (#.delimiter
+ (unread-char char stream)
+ (%reader-error stream
+ "illegal terminating character after a colon: ~S"
+ char))
+ (#.escape (go ESCAPE))
+ (#.multiple-escape (go MULT-ESCAPE))
+ (#.package-delimiter
+ (%reader-error stream
+ "too many colons after ~S name"
+ package-designator))
+ (t (go SYMBOL)))
+ RETURN-SYMBOL
+ (casify-read-buffer escapes)
+ (let ((found (if package-designator
+ (find-package package-designator)
+ *package*)))
+ (unless found
+ (error 'reader-package-error :stream stream
+ :format-arguments (list package-designator)
+ :format-control "package ~S not found"))
+
+ (if (or (zerop colons) (= colons 2) (eq found *keyword-package*))
+ (return (intern* *read-buffer* *ouch-ptr* found))
+ (multiple-value-bind (symbol test)
+ (find-symbol* *read-buffer* *ouch-ptr* found)
+ (when (eq test :external) (return symbol))
+ (let ((name (read-buffer-to-string)))
+ (with-simple-restart (continue "Use symbol anyway.")
+ (error 'reader-package-error :stream stream
+ :format-arguments (list name (package-name found))
+ :format-control
+ (if test
+ "The symbol ~S is not external in the ~A package."
+ "Symbol ~S not found in the ~A package.")))
+ (return (intern name found)))))))))
+
+(defun read-extended-token (stream &optional (*readtable* *readtable*))
+ #!+sb-doc
+ "For semi-external use: returns 3 values: the string for the token,
+ a flag for whether there was an escape char, and the position of any
+ package delimiter."
+ (let ((firstch (read-char stream nil nil t)))
+ (cond (firstch
+ (multiple-value-bind (escapes colon)
+ (internal-read-extended-token stream firstch)
+ (casify-read-buffer escapes)
+ (values (read-buffer-to-string) (not (null escapes)) colon)))
+ (t
+ (values "" nil nil)))))
+\f
+;;;; number-reading functions
+
+(defmacro digit* nil
+ `(do ((ch char (inch-read-buffer)))
+ ((or (eofp ch) (not (digit-char-p ch))) (setq char ch))
+ ;;report if at least one digit is seen:
+ (setq one-digit t)))
+
+(defmacro exponent-letterp (letter)
+ `(memq ,letter '(#\E #\S #\F #\L #\D #\e #\s #\f #\l #\d)))
+
+;;; FIXME: It would be cleaner to have these generated automatically
+;;; by compile-time code instead of having them hand-created like
+;;; this. The !COLD-INIT-INTEGER-READER code below should be resurrected
+;;; and tested.
+(defvar *integer-reader-safe-digits*
+ #(nil nil
+ 26 17 13 11 10 9 8 8 8 7 7 7 7 6 6 6 6 6 6 6 6 5 5 5 5 5 5 5 5 5 5 5 5 5 5)
+ #!+sb-doc
+ "the mapping of base to 'safe' number of digits to read for a fixnum")
+(defvar *integer-reader-base-power*
+ #(nil nil
+ 67108864 129140163 67108864 48828125 60466176 40353607
+ 16777216 43046721 100000000 19487171 35831808 62748517 105413504 11390625
+ 16777216 24137569 34012224 47045881 64000000 85766121 113379904 6436343
+ 7962624 9765625 11881376 14348907 17210368 20511149 24300000 28629151
+ 33554432 39135393 45435424 52521875 60466176)
+ #!+sb-doc
+ "the largest fixnum power of the base for MAKE-INTEGER")
+(declaim (simple-vector *integer-reader-safe-digits*
+ *integer-reader-base-power*))
+#|
+(defun !cold-init-integer-reader ()
+ (do ((base 2 (1+ base)))
+ ((> base 36))
+ (let ((digits
+ (do ((fix (truncate most-positive-fixnum base)
+ (truncate fix base))
+ (digits 0 (1+ digits)))
+ ((zerop fix) digits))))
+ (setf (aref *integer-reader-safe-digits* base)
+ digits
+ (aref *integer-reader-base-power* base)
+ (expt base digits)))))
+|#
+
+(defun make-integer ()
+ #!+sb-doc
+ "Minimizes bignum-fixnum multiplies by reading a 'safe' number of digits,
+ then multiplying by a power of the base and adding."
+ (let* ((base *read-base*)
+ (digits-per (aref *integer-reader-safe-digits* base))
+ (base-power (aref *integer-reader-base-power* base))
+ (negativep nil)
+ (number 0))
+ (declare (type index digits-per base-power))
+ (read-unwind-read-buffer)
+ (let ((char (inch-read-buffer)))
+ (cond ((char= char #\-)
+ (setq negativep t))
+ ((char= char #\+))
+ (t (unread-buffer))))
+ (loop
+ (let ((num 0))
+ (declare (type index num))
+ (dotimes (digit digits-per)
+ (let* ((ch (inch-read-buffer)))
+ (cond ((or (eofp ch) (char= ch #\.))
+ (return-from make-integer
+ (let ((res
+ (if (zerop number) num
+ (+ num (* number
+ (expt base digit))))))
+ (if negativep (- res) res))))
+ (t (setq num (+ (digit-char-p ch base)
+ (the index (* num base))))))))
+ (setq number (+ num (* number base-power)))))))
+
+(defun make-float ()
+ ;; Assume that the contents of *read-buffer* are a legal float, with nothing
+ ;; else after it.
+ (read-unwind-read-buffer)
+ (let ((negative-fraction nil)
+ (number 0)
+ (divisor 1)
+ (negative-exponent nil)
+ (exponent 0)
+ (float-char ())
+ (char (inch-read-buffer)))
+ (if (cond ((char= char #\+) t)
+ ((char= char #\-) (setq negative-fraction t)))
+ ;; Flush it.
+ (setq char (inch-read-buffer)))
+ ;; Read digits before the dot.
+ (do* ((ch char (inch-read-buffer))
+ (dig (digit-char-p ch) (digit-char-p ch)))
+ ((not dig) (setq char ch))
+ (setq number (+ (* number 10) dig)))
+ ;; Deal with the dot, if it's there.
+ (when (char= char #\.)
+ (setq char (inch-read-buffer))
+ ;; Read digits after the dot.
+ (do* ((ch char (inch-read-buffer))
+ (dig (and (not (eofp ch)) (digit-char-p ch))
+ (and (not (eofp ch)) (digit-char-p ch))))
+ ((not dig) (setq char ch))
+ (setq divisor (* divisor 10))
+ (setq number (+ (* number 10) dig))))
+ ;; Is there an exponent letter?
+ (cond ((eofp char)
+ ;; If not, we've read the whole number.
+ (let ((num (make-float-aux number divisor
+ *read-default-float-format*)))
+ (return-from make-float (if negative-fraction (- num) num))))
+ ((exponent-letterp char)
+ (setq float-char char)
+ ;; Build exponent.
+ (setq char (inch-read-buffer))
+ ;; Check leading sign.
+ (if (cond ((char= char #\+) t)
+ ((char= char #\-) (setq negative-exponent t)))
+ ;; Flush sign.
+ (setq char (inch-read-buffer)))
+ ;; Read digits for exponent.
+ (do* ((ch char (inch-read-buffer))
+ (dig (and (not (eofp ch)) (digit-char-p ch))
+ (and (not (eofp ch)) (digit-char-p ch))))
+ ((not dig)
+ (setq exponent (if negative-exponent (- exponent) exponent)))
+ (setq exponent (+ (* exponent 10) dig)))
+ ;; Generate and return the float, depending on float-char:
+ (let* ((float-format (case (char-upcase float-char)
+ (#\E *read-default-float-format*)
+ (#\S 'short-float)
+ (#\F 'single-float)
+ (#\D 'double-float)
+ (#\L 'long-float)))
+ num)
+ ;; toy@rtp.ericsson.se: We need to watch out if the
+ ;; exponent is too small or too large. We add enough to
+ ;; EXPONENT to make it within range and scale NUMBER
+ ;; appropriately. This should avoid any unnecessary
+ ;; underflow or overflow problems.
+ (multiple-value-bind (min-expo max-expo)
+ (case float-format
+ (short-float
+ (values
+ #.(log least-positive-normalized-short-float 10s0)
+ #.(log most-positive-short-float 10s0)))
+ (single-float
+ (values
+ #.(log least-positive-normalized-single-float 10f0)
+ #.(log most-positive-single-float 10f0)))
+ (double-float
+ (values
+ #.(log least-positive-normalized-double-float 10d0)
+ #.(log most-positive-double-float 10d0)))
+ (long-float
+ (values
+ #.(log least-positive-normalized-long-float 10L0)
+ #.(log most-positive-long-float 10L0))))
+ (let ((correction (cond ((<= exponent min-expo)
+ (ceiling (- min-expo exponent)))
+ ((>= exponent max-expo)
+ (floor (- max-expo exponent)))
+ (t
+ 0))))
+ (incf exponent correction)
+ (setf number (/ number (expt 10 correction)))
+ (setq num (make-float-aux number divisor float-format))
+ (setq num (* num (expt 10 exponent)))
+ (return-from make-float (if negative-fraction (- num) num))))))
+ ;; should never happen:
+ (t (error "internal error in floating point reader")))))
+
+(defun make-float-aux (number divisor float-format)
+ (coerce (/ number divisor) float-format))
+
+(defun make-ratio ()
+ ;; Assume *read-buffer* contains a legal ratio. Build the number from
+ ;; the string.
+ ;;
+ ;; Look for optional "+" or "-".
+ (let ((numerator 0) (denominator 0) (char ()) (negative-number nil))
+ (read-unwind-read-buffer)
+ (setq char (inch-read-buffer))
+ (cond ((char= char #\+)
+ (setq char (inch-read-buffer)))
+ ((char= char #\-)
+ (setq char (inch-read-buffer))
+ (setq negative-number t)))
+ ;; Get numerator.
+ (do* ((ch char (inch-read-buffer))
+ (dig (digit-char-p ch *read-base*)
+ (digit-char-p ch *read-base*)))
+ ((not dig))
+ (setq numerator (+ (* numerator *read-base*) dig)))
+ ;; Get denominator.
+ (do* ((ch (inch-read-buffer) (inch-read-buffer))
+ (dig ()))
+ ((or (eofp ch) (not (setq dig (digit-char-p ch *read-base*)))))
+ (setq denominator (+ (* denominator *read-base*) dig)))
+ (let ((num (/ numerator denominator)))
+ (if negative-number (- num) num))))
+\f
+;;;; cruft for dispatch macros
+
+(defun make-char-dispatch-table ()
+ (make-array char-code-limit :initial-element #'dispatch-char-error))
+
+(defun dispatch-char-error (stream sub-char ignore)
+ (declare (ignore ignore))
+ (if *read-suppress*
+ (values)
+ (%reader-error stream "no dispatch function defined for ~S" sub-char)))
+
+(defun make-dispatch-macro-character (char &optional
+ (non-terminating-p nil)
+ (rt *readtable*))
+ #!+sb-doc
+ "Causes char to become a dispatching macro character in readtable
+ (which defaults to the current readtable). If the non-terminating-p
+ flag is set to T, the char will be non-terminating. Make-dispatch-
+ macro-character returns T."
+ (set-macro-character char #'read-dispatch-char non-terminating-p rt)
+ (let* ((dalist (dispatch-tables rt))
+ (dtable (cdr (find char dalist :test #'char= :key #'car))))
+ (cond (dtable
+ (error "Dispatch character already exists."))
+ (t
+ (setf (dispatch-tables rt)
+ (push (cons char (make-char-dispatch-table)) dalist))))))
+
+(defun set-dispatch-macro-character
+ (disp-char sub-char function &optional (rt *readtable*))
+ #!+sb-doc
+ "Causes function to be called whenever the reader reads
+ disp-char followed by sub-char. Set-dispatch-macro-character
+ returns T."
+ ;; Get the dispatch char for macro (error if not there), diddle
+ ;; entry for sub-char.
+ (when (digit-char-p sub-char)
+ (error "SUB-CHAR must not be a decimal digit: ~S" sub-char))
+ (let* ((sub-char (char-upcase sub-char))
+ (dpair (find disp-char (dispatch-tables rt)
+ :test #'char= :key #'car)))
+ (if dpair
+ (setf (elt (the simple-vector (cdr dpair))
+ (char-code sub-char))
+ (coerce function 'function))
+ (error "~S is not a dispatch char." disp-char))))
+
+(defun get-dispatch-macro-character (disp-char sub-char &optional rt)
+ #!+sb-doc
+ "Returns the macro character function for sub-char under disp-char
+ or nil if there is no associated function."
+ (unless (digit-char-p sub-char)
+ (let* ((sub-char (char-upcase sub-char))
+ (rt (or rt *readtable*))
+ (dpair (find disp-char (dispatch-tables rt)
+ :test #'char= :key #'car)))
+ (if dpair
+ (elt (the simple-vector (cdr dpair))
+ (char-code sub-char))
+ (error "~S is not a dispatch char." disp-char)))))
+
+(defun read-dispatch-char (stream char)
+ ;; Read some digits.
+ (let ((numargp nil)
+ (numarg 0)
+ (sub-char ()))
+ (do* ((ch (read-char stream nil eof-object)
+ (read-char stream nil eof-object))
+ (dig ()))
+ ((or (eofp ch)
+ (not (setq dig (digit-char-p ch))))
+ ;; Take care of the extra char.
+ (if (eofp ch)
+ (reader-eof-error stream "inside dispatch character")
+ (setq sub-char (char-upcase ch))))
+ (setq numargp t)
+ (setq numarg (+ (* numarg 10) dig)))
+ ;; Look up the function and call it.
+ (let ((dpair (find char (dispatch-tables *readtable*)
+ :test #'char= :key #'car)))
+ (if dpair
+ (funcall (the function
+ (elt (the simple-vector (cdr dpair))
+ (char-code sub-char)))
+ stream sub-char (if numargp numarg nil))
+ (%reader-error stream "no dispatch table for dispatch char")))))
+\f
+;;;; READ-FROM-STRING
+
+;;; FIXME: Is it really worth keeping this pool?
+(defvar *read-from-string-spares* ()
+ #!+sb-doc
+ "A resource of string streams for Read-From-String.")
+
+(defun read-from-string (string &optional eof-error-p eof-value
+ &key (start 0) end
+ preserve-whitespace)
+ #!+sb-doc
+ "The characters of string are successively given to the lisp reader
+ and the lisp object built by the reader is returned. Macro chars
+ will take effect."
+ (declare (string string))
+ (with-array-data ((string string)
+ (start start)
+ (end (or end (length string))))
+ (unless *read-from-string-spares*
+ (push (internal-make-string-input-stream "" 0 0)
+ *read-from-string-spares*))
+ (let ((stream (pop *read-from-string-spares*)))
+ (setf (string-input-stream-string stream) string)
+ (setf (string-input-stream-current stream) start)
+ (setf (string-input-stream-end stream) end)
+ (unwind-protect
+ (values (if preserve-whitespace
+ (read-preserving-whitespace stream eof-error-p eof-value)
+ (read stream eof-error-p eof-value))
+ (string-input-stream-current stream))
+ (push stream *read-from-string-spares*)))))
+\f
+;;;; PARSE-INTEGER
+
+(defun parse-integer (string &key (start 0) end (radix 10) junk-allowed)
+ #!+sb-doc
+ "Examine the substring of string delimited by start and end
+ (default to the beginning and end of the string) It skips over
+ whitespace characters and then tries to parse an integer. The
+ radix parameter must be between 2 and 36."
+ (with-array-data ((string string)
+ (start start)
+ (end (or end (length string))))
+ (let ((index (do ((i start (1+ i)))
+ ((= i end)
+ (if junk-allowed
+ (return-from parse-integer (values nil end))
+ (error "no non-whitespace characters in number")))
+ (declare (fixnum i))
+ (unless (whitespacep (char string i)) (return i))))
+ (minusp nil)
+ (found-digit nil)
+ (result 0))
+ (declare (fixnum index))
+ (let ((char (char string index)))
+ (cond ((char= char #\-)
+ (setq minusp t)
+ (incf index))
+ ((char= char #\+)
+ (incf index))))
+ (loop
+ (when (= index end) (return nil))
+ (let* ((char (char string index))
+ (weight (digit-char-p char radix)))
+ (cond (weight
+ (setq result (+ weight (* result radix))
+ found-digit t))
+ (junk-allowed (return nil))
+ ((whitespacep char)
+ (do ((jndex (1+ index) (1+ jndex)))
+ ((= jndex end))
+ (declare (fixnum jndex))
+ (unless (whitespacep (char string jndex))
+ (error "junk in string ~S" string)))
+ (return nil))
+ (t
+ (error "junk in string ~S" string))))
+ (incf index))
+ (values
+ (if found-digit
+ (if minusp (- result) result)
+ (if junk-allowed
+ nil
+ (error "no digits in string ~S" string)))
+ index))))
+\f
+;;;; reader initialization code
+
+(defun !reader-cold-init ()
+ (!cold-init-read-buffer)
+ (!cold-init-secondary-attribute-table)
+ (!cold-init-standard-readtable)
+ ;; FIXME: This was commented out, but should probably be restored.
+ #+nil (!cold-init-integer-reader))
+\f
+(def!method print-object ((readtable readtable) stream)
+ (print-unreadable-object (readtable stream :identity t :type t)))
--- /dev/null
+;;;; READTABLEs
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!IMPL")
+
+(file-comment
+ "$Header$")
+
+(sb!xc:deftype attribute-table ()
+ '(simple-array (unsigned-byte 8) (#.char-code-limit)))
+
+(sb!xc:defstruct (readtable (:conc-name nil)
+ (:predicate readtablep)
+ (:copier nil))
+ #!+sb-doc
+ "Readtable is a data structure that maps characters into syntax
+ types for the Common Lisp expression reader."
+ ;; The CHARACTER-ATTRIBUTE-TABLE is a vector of CHAR-CODE-LIMIT
+ ;; integers for describing the character type. Conceptually, there
+ ;; are 4 distinct "primary" character attributes: WHITESPACE,
+ ;; TERMINATING-MACRO, ESCAPE, and CONSTITUENT. Non-terminating
+ ;; macros (such as the symbol reader) have the attribute
+ ;; CONSTITUENT.
+ ;;
+ ;; In order to make the READ-TOKEN fast, all this information is
+ ;; stored in the character attribute table by having different
+ ;; varieties of constituents.
+ (character-attribute-table
+ (make-array char-code-limit :element-type '(unsigned-byte 8)
+ :initial-element constituent)
+ :type attribute-table)
+ ;; The CHARACTER-MACRO-TABLE is a vector of CHAR-CODE-LIMIT
+ ;; functions. One of these functions called with appropriate
+ ;; arguments whenever any non-WHITESPACE character is encountered
+ ;; inside READ-PRESERVING-WHITESPACE. These functions are used to
+ ;; implement user-defined read-macros, system read-macros, and the
+ ;; number-symbol reader.
+ (character-macro-table
+ (make-array char-code-limit :initial-element #'undefined-macro-char)
+ :type (simple-vector #.char-code-limit))
+ ;; DISPATCH-TABLES entry, which is an alist from dispatch characters
+ ;; to vectors of CHAR-CODE-LIMIT functions, for use in defining
+ ;; dispatching macros (like #-macro).
+ (dispatch-tables () :type list)
+ (readtable-case :upcase :type (member :upcase :downcase :preserve :invert)))
--- /dev/null
+;;;; heap-grovelling memory usage stuff
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!VM")
+
+(file-comment
+ "$Header$")
+\f
+;;;; type format database
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (def!struct (room-info (:make-load-form-fun just-dump-it-normally))
+ ;; The name of this type.
+ (name nil :type symbol)
+ ;; Kind of type (how we determine length).
+ (kind (required-argument)
+ :type (member :lowtag :fixed :header :vector
+ :string :code :closure :instance))
+ ;; Length if fixed-length, shift amount for element size if :vector.
+ (length nil :type (or fixnum null))))
+
+(eval-when (:compile-toplevel :execute)
+
+(defvar *meta-room-info* (make-array 256 :initial-element nil))
+
+(dolist (obj *primitive-objects*)
+ (let ((header (primitive-object-header obj))
+ (lowtag (primitive-object-lowtag obj))
+ (name (primitive-object-name obj))
+ (variable (primitive-object-variable-length obj))
+ (size (primitive-object-size obj)))
+ (cond
+ ((not lowtag))
+ ((not header)
+ (let ((info (make-room-info :name name
+ :kind :lowtag))
+ (lowtag (symbol-value lowtag)))
+ (declare (fixnum lowtag))
+ (dotimes (i 32)
+ (setf (svref *meta-room-info* (logior lowtag (ash i 3))) info))))
+ (variable)
+ (t
+ (setf (svref *meta-room-info* (symbol-value header))
+ (make-room-info :name name
+ :kind :fixed
+ :length size))))))
+
+(dolist (code (list complex-string-type simple-array-type
+ complex-bit-vector-type complex-vector-type
+ complex-array-type))
+ (setf (svref *meta-room-info* code)
+ (make-room-info :name 'array-header
+ :kind :header)))
+
+(setf (svref *meta-room-info* bignum-type)
+ (make-room-info :name 'bignum
+ :kind :header))
+
+(setf (svref *meta-room-info* closure-header-type)
+ (make-room-info :name 'closure
+ :kind :closure))
+
+(dolist (stuff '((simple-bit-vector-type . -3)
+ (simple-vector-type . 2)
+ (simple-array-unsigned-byte-2-type . -2)
+ (simple-array-unsigned-byte-4-type . -1)
+ (simple-array-unsigned-byte-8-type . 0)
+ (simple-array-unsigned-byte-16-type . 1)
+ (simple-array-unsigned-byte-32-type . 2)
+ (simple-array-signed-byte-8-type . 0)
+ (simple-array-signed-byte-16-type . 1)
+ (simple-array-signed-byte-30-type . 2)
+ (simple-array-signed-byte-32-type . 2)
+ (simple-array-single-float-type . 2)
+ (simple-array-double-float-type . 3)
+ (simple-array-complex-single-float-type . 3)
+ (simple-array-complex-double-float-type . 4)))
+ (let ((name (car stuff))
+ (size (cdr stuff)))
+ (setf (svref *meta-room-info* (symbol-value name))
+ (make-room-info :name name
+ :kind :vector
+ :length size))))
+
+(setf (svref *meta-room-info* simple-string-type)
+ (make-room-info :name 'simple-string-type
+ :kind :string
+ :length 0))
+
+(setf (svref *meta-room-info* code-header-type)
+ (make-room-info :name 'code
+ :kind :code))
+
+(setf (svref *meta-room-info* instance-header-type)
+ (make-room-info :name 'instance
+ :kind :instance))
+
+); eval-when (compile eval)
+
+(defparameter *room-info* '#.*meta-room-info*)
+(deftype spaces () '(member :static :dynamic :read-only))
+\f
+;;;; MAP-ALLOCATED-OBJECTS
+
+(declaim (type fixnum *static-space-free-pointer*
+ *read-only-space-free-pointer* ))
+
+(defun space-bounds (space)
+ (declare (type spaces space))
+ (ecase space
+ (:static
+ (values (int-sap (static-space-start))
+ (int-sap (* *static-space-free-pointer* word-bytes))))
+ (:read-only
+ (values (int-sap (read-only-space-start))
+ (int-sap (* *read-only-space-free-pointer* word-bytes))))
+ (:dynamic
+ (values (int-sap (current-dynamic-space-start))
+ (dynamic-space-free-pointer)))))
+
+;;; Return the total number of bytes used in SPACE.
+(defun space-bytes (space)
+ (multiple-value-bind (start end) (space-bounds space)
+ (- (sap-int end) (sap-int start))))
+
+;;; Round SIZE (in bytes) up to the next dualword (eight byte) boundary.
+#!-sb-fluid (declaim (inline round-to-dualword))
+(defun round-to-dualword (size)
+ (declare (fixnum size))
+ (logand (the fixnum (+ size lowtag-mask)) (lognot lowtag-mask)))
+
+;;; Return the total size of a vector in bytes, including any pad.
+#!-sb-fluid (declaim (inline vector-total-size))
+(defun vector-total-size (obj info)
+ (let ((shift (room-info-length info))
+ (len (+ (length (the (simple-array * (*)) obj))
+ (ecase (room-info-kind info)
+ (:vector 0)
+ (:string 1)))))
+ (declare (type (integer -3 3) shift))
+ (round-to-dualword
+ (+ (* vector-data-offset word-bytes)
+ (the fixnum
+ (if (minusp shift)
+ (ash (the fixnum
+ (+ len (the fixnum
+ (1- (the fixnum (ash 1 (- shift)))))))
+ shift)
+ (ash len shift)))))))
+
+;;; Iterate over all the objects allocated in SPACE, calling FUN with
+;;; the object, the object's type code, and the objects total size in
+;;; bytes, including any header and padding.
+#!-sb-fluid (declaim (maybe-inline map-allocated-objects))
+(defun map-allocated-objects (fun space)
+ (declare (type function fun) (type spaces space))
+ (without-gcing
+ (multiple-value-bind (start end) (space-bounds space)
+ (declare (type system-area-pointer start end))
+ (declare (optimize (speed 3) (safety 0)))
+ (let ((current start)
+ #+nil
+ (prev nil))
+ (loop
+ (let* ((header (sap-ref-32 current 0))
+ (header-type (logand header #xFF))
+ (info (svref *room-info* header-type)))
+ (cond
+ ((or (not info)
+ (eq (room-info-kind info) :lowtag))
+ (let ((size (* cons-size word-bytes)))
+ (funcall fun
+ (make-lisp-obj (logior (sap-int current)
+ list-pointer-type))
+ list-pointer-type
+ size)
+ (setq current (sap+ current size))))
+ ((eql header-type closure-header-type)
+ (let* ((obj (make-lisp-obj (logior (sap-int current)
+ function-pointer-type)))
+ (size (round-to-dualword
+ (* (the fixnum (1+ (get-closure-length obj)))
+ word-bytes))))
+ (funcall fun obj header-type size)
+ (setq current (sap+ current size))))
+ ((eq (room-info-kind info) :instance)
+ (let* ((obj (make-lisp-obj
+ (logior (sap-int current) instance-pointer-type)))
+ (size (round-to-dualword
+ (* (+ (%instance-length obj) 1) word-bytes))))
+ (declare (fixnum size))
+ (funcall fun obj header-type size)
+ (assert (zerop (logand size lowtag-mask)))
+ #+nil
+ (when (> size 200000) (break "implausible size, prev ~S" prev))
+ #+nil
+ (setq prev current)
+ (setq current (sap+ current size))))
+ (t
+ (let* ((obj (make-lisp-obj
+ (logior (sap-int current) other-pointer-type)))
+ (size (ecase (room-info-kind info)
+ (:fixed
+ (assert (or (eql (room-info-length info)
+ (1+ (get-header-data obj)))
+ (floatp obj)))
+ (round-to-dualword
+ (* (room-info-length info) word-bytes)))
+ ((:vector :string)
+ (vector-total-size obj info))
+ (:header
+ (round-to-dualword
+ (* (1+ (get-header-data obj)) word-bytes)))
+ (:code
+ (+ (the fixnum
+ (* (get-header-data obj) word-bytes))
+ (round-to-dualword
+ (* (the fixnum (%code-code-size obj))
+ word-bytes)))))))
+ (declare (fixnum size))
+ (funcall fun obj header-type size)
+ (assert (zerop (logand size lowtag-mask)))
+ #+nil
+ (when (> size 200000)
+ (break "Implausible size, prev ~S" prev))
+ #+nil
+ (setq prev current)
+ (setq current (sap+ current size))))))
+ (unless (sap< current end)
+ (assert (sap= current end))
+ (return)))
+
+ #+nil
+ prev))))
+\f
+;;;; MEMORY-USAGE
+
+;;; Return a list of 3-lists (bytes object type-name) for the objects
+;;; allocated in Space.
+(defun type-breakdown (space)
+ (let ((sizes (make-array 256 :initial-element 0 :element-type 'fixnum))
+ (counts (make-array 256 :initial-element 0 :element-type 'fixnum)))
+ (map-allocated-objects
+ #'(lambda (obj type size)
+ (declare (fixnum size) (optimize (speed 3) (safety 0)) (ignore obj))
+ (incf (aref sizes type) size)
+ (incf (aref counts type)))
+ space)
+
+ (let ((totals (make-hash-table :test 'eq)))
+ (dotimes (i 256)
+ (let ((total-count (aref counts i)))
+ (unless (zerop total-count)
+ (let* ((total-size (aref sizes i))
+ (name (room-info-name (aref *room-info* i)))
+ (found (gethash name totals)))
+ (cond (found
+ (incf (first found) total-size)
+ (incf (second found) total-count))
+ (t
+ (setf (gethash name totals)
+ (list total-size total-count name))))))))
+
+ (collect ((totals-list))
+ (maphash #'(lambda (k v)
+ (declare (ignore k))
+ (totals-list v))
+ totals)
+ (sort (totals-list) #'> :key #'first)))))
+
+;;; Handle the summary printing for MEMORY-USAGE. Totals is a list of lists
+;;; (space-name . totals-for-space), where totals-for-space is the list
+;;; returned by TYPE-BREAKDOWN.
+(defun print-summary (spaces totals)
+ (let ((summary (make-hash-table :test 'eq)))
+ (dolist (space-total totals)
+ (dolist (total (cdr space-total))
+ (push (cons (car space-total) total)
+ (gethash (third total) summary))))
+
+ (collect ((summary-totals))
+ (maphash #'(lambda (k v)
+ (declare (ignore k))
+ (let ((sum 0))
+ (declare (fixnum sum))
+ (dolist (space-total v)
+ (incf sum (first (cdr space-total))))
+ (summary-totals (cons sum v))))
+ summary)
+
+ (format t "~2&Summary of spaces: ~(~{~A ~}~)~%" spaces)
+ (let ((summary-total-bytes 0)
+ (summary-total-objects 0))
+ (declare (fixnum summary-total-bytes summary-total-objects))
+ (dolist (space-totals
+ (mapcar #'cdr (sort (summary-totals) #'> :key #'car)))
+ (let ((total-objects 0)
+ (total-bytes 0)
+ name)
+ (declare (fixnum total-objects total-bytes))
+ (collect ((spaces))
+ (dolist (space-total space-totals)
+ (let ((total (cdr space-total)))
+ (setq name (third total))
+ (incf total-bytes (first total))
+ (incf total-objects (second total))
+ (spaces (cons (car space-total) (first total)))))
+ (format t "~%~A:~% ~:D bytes, ~:D object~:P"
+ name total-bytes total-objects)
+ (dolist (space (spaces))
+ (format t ", ~D% ~(~A~)"
+ (round (* (cdr space) 100) total-bytes)
+ (car space)))
+ (format t ".~%")
+ (incf summary-total-bytes total-bytes)
+ (incf summary-total-objects total-objects))))
+ (format t "~%Summary total:~% ~:D bytes, ~:D objects.~%"
+ summary-total-bytes summary-total-objects)))))
+
+;;; Report object usage for a single space.
+(defun report-space-total (space-total cutoff)
+ (declare (list space-total) (type (or single-float null) cutoff))
+ (format t "~2&Breakdown for ~(~A~) space:~%" (car space-total))
+ (let* ((types (cdr space-total))
+ (total-bytes (reduce #'+ (mapcar #'first types)))
+ (total-objects (reduce #'+ (mapcar #'second types)))
+ (cutoff-point (if cutoff
+ (truncate (* (float total-bytes) cutoff))
+ 0))
+ (reported-bytes 0)
+ (reported-objects 0))
+ (declare (fixnum total-objects total-bytes cutoff-point reported-objects
+ reported-bytes))
+ (loop for (bytes objects name) in types do
+ (when (<= bytes cutoff-point)
+ (format t " ~10:D bytes for ~9:D other object~2:*~P.~%"
+ (- total-bytes reported-bytes)
+ (- total-objects reported-objects))
+ (return))
+ (incf reported-bytes bytes)
+ (incf reported-objects objects)
+ (format t " ~10:D bytes for ~9:D ~(~A~) object~2:*~P.~%"
+ bytes objects name))
+ (format t " ~10:D bytes for ~9:D ~(~A~) object~2:*~P (space total.)~%"
+ total-bytes total-objects (car space-total))))
+
+(defun memory-usage (&key print-spaces (count-spaces '(:dynamic))
+ (print-summary t) cutoff)
+ #!+sb-doc
+ "Print out information about the heap memory in use. :Print-Spaces is a list
+ of the spaces to print detailed information for. :Count-Spaces is a list of
+ the spaces to scan. For either one, T means all spaces (:Static, :Dyanmic
+ and :Read-Only.) If :Print-Summary is true, then summary information will be
+ printed. The defaults print only summary information for dynamic space.
+ If true, Cutoff is a fraction of the usage in a report below which types will
+ be combined as OTHER."
+ (declare (type (or single-float null) cutoff))
+ (let* ((spaces (if (eq count-spaces t)
+ '(:static :dynamic :read-only)
+ count-spaces))
+ (totals (mapcar #'(lambda (space)
+ (cons space (type-breakdown space)))
+ spaces)))
+
+ (dolist (space-total totals)
+ (when (or (eq print-spaces t)
+ (member (car space-total) print-spaces))
+ (report-space-total space-total cutoff)))
+
+ (when print-summary (print-summary spaces totals)))
+
+ (values))
+\f
+(defun count-no-ops (space)
+ #!+sb-doc
+ "Print info about how much code and no-ops there are in Space."
+ (declare (type spaces space))
+ (let ((code-words 0)
+ (no-ops 0)
+ (total-bytes 0))
+ (declare (fixnum code-words no-ops)
+ (type unsigned-byte total-bytes))
+ (map-allocated-objects
+ #'(lambda (obj type size)
+ (declare (fixnum size) (optimize (safety 0)))
+ (when (eql type code-header-type)
+ (incf total-bytes size)
+ (let ((words (truly-the fixnum (%code-code-size obj)))
+ (sap (truly-the system-area-pointer
+ (%primitive code-instructions obj))))
+ (incf code-words words)
+ (dotimes (i words)
+ (when (zerop (sap-ref-32 sap (* i sb!vm:word-bytes)))
+ (incf no-ops))))))
+ space)
+
+ (format t
+ "~:D code-object bytes, ~:D code words, with ~:D no-ops (~D%).~%"
+ total-bytes code-words no-ops
+ (round (* no-ops 100) code-words)))
+
+ (values))
+\f
+(defun descriptor-vs-non-descriptor-storage (&rest spaces)
+ (let ((descriptor-words 0)
+ (non-descriptor-headers 0)
+ (non-descriptor-bytes 0))
+ (declare (type unsigned-byte descriptor-words non-descriptor-headers
+ non-descriptor-bytes))
+ (dolist (space (or spaces '(:read-only :static :dynamic)))
+ (declare (inline map-allocated-objects))
+ (map-allocated-objects
+ #'(lambda (obj type size)
+ (declare (fixnum size) (optimize (safety 0)))
+ (case type
+ (#.code-header-type
+ (let ((inst-words (truly-the fixnum (%code-code-size obj))))
+ (declare (type fixnum inst-words))
+ (incf non-descriptor-bytes (* inst-words word-bytes))
+ (incf descriptor-words
+ (- (truncate size word-bytes) inst-words))))
+ ((#.bignum-type
+ #.single-float-type
+ #.double-float-type
+ #.simple-string-type
+ #.simple-bit-vector-type
+ #.simple-array-unsigned-byte-2-type
+ #.simple-array-unsigned-byte-4-type
+ #.simple-array-unsigned-byte-8-type
+ #.simple-array-unsigned-byte-16-type
+ #.simple-array-unsigned-byte-32-type
+ #.simple-array-signed-byte-8-type
+ #.simple-array-signed-byte-16-type
+ #.simple-array-signed-byte-30-type
+ #.simple-array-signed-byte-32-type
+ #.simple-array-single-float-type
+ #.simple-array-double-float-type
+ #.simple-array-complex-single-float-type
+ #.simple-array-complex-double-float-type)
+ (incf non-descriptor-headers)
+ (incf non-descriptor-bytes (- size word-bytes)))
+ ((#.list-pointer-type
+ #.instance-pointer-type
+ #.ratio-type
+ #.complex-type
+ #.simple-array-type
+ #.simple-vector-type
+ #.complex-string-type
+ #.complex-bit-vector-type
+ #.complex-vector-type
+ #.complex-array-type
+ #.closure-header-type
+ #.funcallable-instance-header-type
+ #.value-cell-header-type
+ #.symbol-header-type
+ #.sap-type
+ #.weak-pointer-type
+ #.instance-header-type)
+ (incf descriptor-words (truncate size word-bytes)))
+ (t
+ (error "Bogus type: ~D" type))))
+ space))
+ (format t "~:D words allocated for descriptor objects.~%"
+ descriptor-words)
+ (format t "~:D bytes data/~:D words header for non-descriptor objects.~%"
+ non-descriptor-bytes non-descriptor-headers)
+ (values)))
+\f
+(defun instance-usage (space &key (top-n 15))
+ (declare (type spaces space) (type (or fixnum null) top-n))
+ #!+sb-doc
+ "Print a breakdown by instance type of all the instances allocated in
+ Space. If TOP-N is true, print only information for the the TOP-N types with
+ largest usage."
+ (format t "~2&~@[Top ~D ~]~(~A~) instance types:~%" top-n space)
+ (let ((totals (make-hash-table :test 'eq))
+ (total-objects 0)
+ (total-bytes 0))
+ (declare (fixnum total-objects total-bytes))
+ (map-allocated-objects
+ #'(lambda (obj type size)
+ (declare (fixnum size) (optimize (speed 3) (safety 0)))
+ (when (eql type instance-header-type)
+ (incf total-objects)
+ (incf total-bytes size)
+ (let* ((class (layout-class (%instance-ref obj 0)))
+ (found (gethash class totals)))
+ (cond (found
+ (incf (the fixnum (car found)))
+ (incf (the fixnum (cdr found)) size))
+ (t
+ (setf (gethash class totals) (cons 1 size)))))))
+ space)
+
+ (collect ((totals-list))
+ (maphash #'(lambda (class what)
+ (totals-list (cons (prin1-to-string
+ (class-proper-name class))
+ what)))
+ totals)
+ (let ((sorted (sort (totals-list) #'> :key #'cddr))
+ (printed-bytes 0)
+ (printed-objects 0))
+ (declare (fixnum printed-bytes printed-objects))
+ (dolist (what (if top-n
+ (subseq sorted 0 (min (length sorted) top-n))
+ sorted))
+ (let ((bytes (cddr what))
+ (objects (cadr what)))
+ (incf printed-bytes bytes)
+ (incf printed-objects objects)
+ (format t " ~A: ~:D bytes, ~D object~:P.~%" (car what)
+ bytes objects)))
+
+ (let ((residual-objects (- total-objects printed-objects))
+ (residual-bytes (- total-bytes printed-bytes)))
+ (unless (zerop residual-objects)
+ (format t " Other types: ~:D bytes, ~D: object~:P.~%"
+ residual-bytes residual-objects))))
+
+ (format t " ~:(~A~) instance total: ~:D bytes, ~:D object~:P.~%"
+ space total-bytes total-objects)))
+
+ (values))
+\f
+(defun find-holes (&rest spaces)
+ (dolist (space (or spaces '(:read-only :static :dynamic)))
+ (format t "In ~A space:~%" space)
+ (let ((start-addr nil)
+ (total-bytes 0))
+ (declare (type (or null (unsigned-byte 32)) start-addr)
+ (type (unsigned-byte 32) total-bytes))
+ (map-allocated-objects
+ #'(lambda (object typecode bytes)
+ (declare (ignore typecode)
+ (type (unsigned-byte 32) bytes))
+ (if (and (consp object)
+ (eql (car object) 0)
+ (eql (cdr object) 0))
+ (if start-addr
+ (incf total-bytes bytes)
+ (setf start-addr (sb!di::get-lisp-obj-address object)
+ total-bytes bytes))
+ (when start-addr
+ (format t "~D bytes at #X~X~%" total-bytes start-addr)
+ (setf start-addr nil))))
+ space)
+ (when start-addr
+ (format t "~D bytes at #X~X~%" total-bytes start-addr))))
+ (values))
+\f
+;;;; PRINT-ALLOCATED-OBJECTS
+
+(defun print-allocated-objects (space &key (percent 0) (pages 5)
+ type larger smaller count
+ (stream *standard-output*))
+ (declare (type (integer 0 99) percent) (type sb!c::index pages)
+ (type stream stream) (type spaces space)
+ (type (or sb!c::index null) type larger smaller count))
+ (multiple-value-bind (start-sap end-sap) (space-bounds space)
+ (let* ((space-start (sap-int start-sap))
+ (space-end (sap-int end-sap))
+ (space-size (- space-end space-start))
+ (pagesize (sb!sys:get-page-size))
+ (start (+ space-start (round (* space-size percent) 100)))
+ (printed-conses (make-hash-table :test 'eq))
+ (pages-so-far 0)
+ (count-so-far 0)
+ (last-page 0))
+ (declare (type (unsigned-byte 32) last-page start)
+ (fixnum pages-so-far count-so-far pagesize))
+ (labels ((note-conses (x)
+ (unless (or (atom x) (gethash x printed-conses))
+ (setf (gethash x printed-conses) t)
+ (note-conses (car x))
+ (note-conses (cdr x)))))
+ (map-allocated-objects
+ #'(lambda (obj obj-type size)
+ (declare (optimize (safety 0)))
+ (let ((addr (get-lisp-obj-address obj)))
+ (when (>= addr start)
+ (when (if count
+ (> count-so-far count)
+ (> pages-so-far pages))
+ (return-from print-allocated-objects (values)))
+
+ (unless count
+ (let ((this-page (* (the (unsigned-byte 32)
+ (truncate addr pagesize))
+ pagesize)))
+ (declare (type (unsigned-byte 32) this-page))
+ (when (/= this-page last-page)
+ (when (< pages-so-far pages)
+ (format stream "~2&**** Page ~D, address ~X:~%"
+ pages-so-far addr))
+ (setq last-page this-page)
+ (incf pages-so-far))))
+
+ (when (and (or (not type) (eql obj-type type))
+ (or (not smaller) (<= size smaller))
+ (or (not larger) (>= size larger)))
+ (incf count-so-far)
+ (case type
+ (#.code-header-type
+ (let ((dinfo (%code-debug-info obj)))
+ (format stream "~&Code object: ~S~%"
+ (if dinfo
+ (sb!c::compiled-debug-info-name dinfo)
+ "No debug info."))))
+ (#.symbol-header-type
+ (format stream "~&~S~%" obj))
+ (#.list-pointer-type
+ (unless (gethash obj printed-conses)
+ (note-conses obj)
+ (let ((*print-circle* t)
+ (*print-level* 5)
+ (*print-length* 10))
+ (format stream "~&~S~%" obj))))
+ (t
+ (fresh-line stream)
+ (let ((str (write-to-string obj :level 5 :length 10
+ :pretty nil)))
+ (unless (eql type instance-header-type)
+ (format stream "~S: " (type-of obj)))
+ (format stream "~A~%"
+ (subseq str 0 (min (length str) 60))))))))))
+ space))))
+ (values))
+\f
+;;;; LIST-ALLOCATED-OBJECTS, LIST-REFERENCING-OBJECTS
+
+(defvar *ignore-after* nil)
+
+(defun maybe-cons (space x stuff)
+ (if (or (not (eq space :dynamic))
+ (< (get-lisp-obj-address x) (get-lisp-obj-address *ignore-after*)))
+ (cons x stuff)
+ stuff))
+
+(defun list-allocated-objects (space &key type larger smaller count
+ test)
+ (declare (type spaces space)
+ (type (or sb!c::index null) larger smaller type count)
+ (type (or function null) test)
+ (inline map-allocated-objects))
+ (unless *ignore-after* (setq *ignore-after* (cons 1 2)))
+ (collect ((counted 0 1+))
+ (let ((res ()))
+ (map-allocated-objects
+ #'(lambda (obj obj-type size)
+ (declare (optimize (safety 0)))
+ (when (and (or (not type) (eql obj-type type))
+ (or (not smaller) (<= size smaller))
+ (or (not larger) (>= size larger))
+ (or (not test) (funcall test obj)))
+ (setq res (maybe-cons space obj res))
+ (when (and count (>= (counted) count))
+ (return-from list-allocated-objects res))))
+ space)
+ res)))
+
+(defun list-referencing-objects (space object)
+ (declare (type spaces space) (inline map-allocated-objects))
+ (unless *ignore-after* (setq *ignore-after* (cons 1 2)))
+ (let ((res ()))
+ (flet ((res (x)
+ (setq res (maybe-cons space x res))))
+ (map-allocated-objects
+ #'(lambda (obj obj-type size)
+ (declare (optimize (safety 0)) (ignore obj-type size))
+ (typecase obj
+ (cons
+ (when (or (eq (car obj) object) (eq (cdr obj) object))
+ (res obj)))
+ (instance
+ (dotimes (i (%instance-length obj))
+ (when (eq (%instance-ref obj i) object)
+ (res obj)
+ (return))))
+ (simple-vector
+ (dotimes (i (length obj))
+ (when (eq (svref obj i) object)
+ (res obj)
+ (return))))
+ (symbol
+ (when (or (eq (symbol-name obj) object)
+ (eq (symbol-package obj) object)
+ (eq (symbol-plist obj) object)
+ (eq (symbol-value obj) object))
+ (res obj)))))
+ space))
+ res))
--- /dev/null
+.. not working .. not working .. not working .. not working ..
+
+KLUDGE: This is CMU CL code which needs more porting before it can
+work on SBCL. At the very least:
+ * Package references need to be renamed from the CMU CL "SYSTEM" style
+ to the SBCL "SB-SYS" style. Possibly some referenced symbols have
+ moved to new packages or been renamed, as well.
+ * The environment-handling needs to be updated to read directly from
+ the Unix environment, since SBCL, unlike CMU CL, doesn't maintain
+ its own local copy.
+ * The DEFCONSTANT #+SVR4 stuff needs to be checked and cleaned up for
+ currently supported OSes, since SBCL doesn't use the :SVR4 feature.
+ * The conditional code for other stuff not supported by SBCL (e.g.
+ HPUX) should probably go away.
+-- WHN 20000825
+
+;;;; support for running Unix programs from inside Lisp
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB-EXT")
+
+(file-comment
+ "$Header$")
+\f
+;;;; Import wait3(2) from Unix.
+
+(alien:def-alien-routine ("wait3" c-wait3) c-call:int
+ (status c-call:int :out)
+ (options c-call:int)
+ (rusage c-call:int))
+
+(eval-when (load eval compile)
+ (defconstant wait-wnohang #-svr4 1 #+svr4 #o100)
+ (defconstant wait-wuntraced #-svr4 2 #+svr4 4)
+ (defconstant wait-wstopped #-svr4 #o177 #+svr4 wait-wuntraced))
+
+(defun wait3 (&optional do-not-hang check-for-stopped)
+ "Return any available status information on child process."
+ (multiple-value-bind (pid status)
+ (c-wait3 (logior (if do-not-hang
+ wait-wnohang
+ 0)
+ (if check-for-stopped
+ wait-wuntraced
+ 0))
+ 0)
+ (cond ((or (minusp pid)
+ (zerop pid))
+ nil)
+ ((eql (ldb (byte 8 0) status)
+ wait-wstopped)
+ (values pid
+ :stopped
+ (ldb (byte 8 8) status)))
+ ((zerop (ldb (byte 7 0) status))
+ (values pid
+ :exited
+ (ldb (byte 8 8) status)))
+ (t
+ (let ((signal (ldb (byte 7 0) status)))
+ (values pid
+ (if (or (eql signal unix:sigstop)
+ (eql signal unix:sigtstp)
+ (eql signal unix:sigttin)
+ (eql signal unix:sigttou))
+ :stopped
+ :signaled)
+ signal
+ (not (zerop (ldb (byte 1 7) status)))))))))
+\f
+;;;; stuff for process control
+
+(defvar *active-processes* nil
+ "List of process structures for all active processes.")
+
+(defstruct (process (:print-function %print-process))
+ pid ; PID of child process
+ %status ; either :RUNNING, :STOPPED, :EXITED, or :SIGNALED
+ exit-code ; either exit code or signal
+ core-dumped ; T if a core image was dumped
+ pty ; stream to child's pty, or NIL
+ input ; stream to child's input, or NIL
+ output ; stream from child's output, or NIL
+ error ; stream from child's error output, or NIL
+ status-hook ; closure to call when PROC changes status
+ plist ; a place for clients to stash things
+ cookie ; list of the number of pipes from the subprocess
+ )
+
+(defun %print-process (proc stream depth)
+ (declare (ignore depth))
+ (format stream "#<PROCESS ~D ~S>"
+ (process-pid proc)
+ (process-status proc)))
+
+(defun process-status (proc)
+ "Return the current status of process. The result is one of :RUNNING,
+ :STOPPED, :EXITED, or :SIGNALED."
+ (get-processes-status-changes)
+ (process-%status proc))
+
+(defun process-wait (proc &optional check-for-stopped)
+ "Wait for PROC to quit running for some reason. Returns PROC."
+ (loop
+ (case (process-status proc)
+ (:running)
+ (:stopped
+ (when check-for-stopped
+ (return)))
+ (t
+ (when (zerop (car (process-cookie proc)))
+ (return))))
+ (system:serve-all-events 1))
+ proc)
+
+;;; Find the current foreground process group id.
+(defun find-current-foreground-process (proc)
+ (alien:with-alien ((result c-call:int))
+ (multiple-value-bind
+ (wonp error)
+ (unix:unix-ioctl (system:fd-stream-fd (ext:process-pty proc))
+ unix:TIOCGPGRP
+ (alien:alien-sap (alien:addr result)))
+ (unless wonp
+ (error "TIOCPGRP ioctl failed: ~S"
+ (unix:get-unix-error-msg error)))
+ result))
+ (process-pid proc))
+
+(defun process-kill (proc signal &optional (whom :pid))
+ "Send SIGNAL to PROC. If WHOM is :PID, then use the kill(2) Unix system
+ call. If WHOM is :PROCESS-GROUP, use the killpg(2) Unix system call.
+ If WHOM is :PTY-PROCESS-GROUP, then deliver the signal to whichever
+ process group is currently in the foreground."
+ (let ((pid (ecase whom
+ ((:pid :process-group)
+ (process-pid proc))
+ (:pty-process-group
+ #-hpux
+ (find-current-foreground-process proc)))))
+ (multiple-value-bind
+ (okay errno)
+ (case whom
+ #+hpux
+ (:pty-process-group
+ (unix:unix-ioctl (system:fd-stream-fd (process-pty proc))
+ unix:TIOCSIGSEND
+ (system:int-sap
+ (unix:unix-signal-number signal))))
+ ((:process-group #-hpux :pty-process-group)
+ (unix:unix-killpg pid signal))
+ (t
+ (unix:unix-kill pid signal)))
+ (cond ((not okay)
+ (values nil errno))
+ ((and (eql pid (process-pid proc))
+ (= (unix:unix-signal-number signal) unix:sigcont))
+ (setf (process-%status proc) :running)
+ (setf (process-exit-code proc) nil)
+ (when (process-status-hook proc)
+ (funcall (process-status-hook proc) proc))
+ t)
+ (t
+ t)))))
+
+(defun process-alive-p (proc)
+ "Return T if the process is still alive, NIL otherwise."
+ (let ((status (process-status proc)))
+ (if (or (eq status :running)
+ (eq status :stopped))
+ t
+ nil)))
+
+(defun process-close (proc)
+ "Close all streams connected to PROC and stop maintaining the status slot."
+ (macrolet ((frob (stream abort)
+ `(when ,stream (close ,stream :abort ,abort))))
+ (frob (process-pty proc) t) ; Don't FLUSH-OUTPUT to dead process, ..
+ (frob (process-input proc) t) ; .. 'cause it will generate SIGPIPE.
+ (frob (process-output proc) nil)
+ (frob (process-error proc) nil))
+ (system:without-interrupts
+ (setf *active-processes* (delete proc *active-processes*)))
+ proc)
+
+;;; the handler for SIGCHLD signals that RUN-PROGRAM establishes
+(defun sigchld-handler (ignore1 ignore2 ignore3)
+ (declare (ignore ignore1 ignore2 ignore3))
+ (get-processes-status-changes))
+
+(defun get-processes-status-changes ()
+ (loop
+ (multiple-value-bind (pid what code core)
+ (wait3 t t)
+ (unless pid
+ (return))
+ (let ((proc (find pid *active-processes* :key #'process-pid)))
+ (when proc
+ (setf (process-%status proc) what)
+ (setf (process-exit-code proc) code)
+ (setf (process-core-dumped proc) core)
+ (when (process-status-hook proc)
+ (funcall (process-status-hook proc) proc))
+ (when (or (eq what :exited)
+ (eq what :signaled))
+ (system:without-interrupts
+ (setf *active-processes*
+ (delete proc *active-processes*)))))))))
+\f
+;;;; RUN-PROGRAM and close friends
+
+(defvar *close-on-error* nil
+ "List of file descriptors to close when RUN-PROGRAM exits due to an error.")
+(defvar *close-in-parent* nil
+ "List of file descriptors to close when RUN-PROGRAM returns in the parent.")
+(defvar *handlers-installed* nil
+ "List of handlers installed by RUN-PROGRAM.")
+
+;;; Find a pty that is not in use. Returns three values: the file
+;;; descriptor for the master side of the pty, the file descriptor for
+;;; the slave side of the pty, and the name of the tty device for the
+;;; slave side.
+(defun find-a-pty ()
+ "Returns the master fd, the slave fd, and the name of the tty"
+ (dolist (char '(#\p #\q))
+ (dotimes (digit 16)
+ (let* ((master-name (format nil "/dev/pty~C~X" char digit))
+ (master-fd (unix:unix-open master-name
+ unix:o_rdwr
+ #o666)))
+ (when master-fd
+ (let* ((slave-name (format nil "/dev/tty~C~X" char digit))
+ (slave-fd (unix:unix-open slave-name
+ unix:o_rdwr
+ #o666)))
+ (when slave-fd
+ ; Maybe put a vhangup here?
+ #-glibc2
+ (alien:with-alien ((stuff (alien:struct unix:sgttyb)))
+ (let ((sap (alien:alien-sap stuff)))
+ (unix:unix-ioctl slave-fd unix:TIOCGETP sap)
+ (setf (alien:slot stuff 'unix:sg-flags) #o300) ; EVENP|ODDP
+ (unix:unix-ioctl slave-fd unix:TIOCSETP sap)
+ (unix:unix-ioctl master-fd unix:TIOCGETP sap)
+ (setf (alien:slot stuff 'unix:sg-flags)
+ (logand (alien:slot stuff 'unix:sg-flags)
+ (lognot 8))) ; ~ECHO
+ (unix:unix-ioctl master-fd unix:TIOCSETP sap)))
+ (return-from find-a-pty
+ (values master-fd
+ slave-fd
+ slave-name)))
+ (unix:unix-close master-fd))))))
+ (error "could not find a pty"))
+
+(defun open-pty (pty cookie)
+ (when pty
+ (multiple-value-bind
+ (master slave name)
+ (find-a-pty)
+ (push master *close-on-error*)
+ (push slave *close-in-parent*)
+ (when (streamp pty)
+ (multiple-value-bind (new-fd errno) (unix:unix-dup master)
+ (unless new-fd
+ (error "could not UNIX:UNIX-DUP ~D: ~A"
+ master (unix:get-unix-error-msg errno)))
+ (push new-fd *close-on-error*)
+ (copy-descriptor-to-stream new-fd pty cookie)))
+ (values name
+ (system:make-fd-stream master :input t :output t)))))
+
+(defmacro round-bytes-to-words (n)
+ `(logand (the fixnum (+ (the fixnum ,n) 3)) (lognot 3)))
+
+(defun string-list-to-c-strvec (string-list)
+ ;; Make a pass over STRING-LIST to calculate the amount of memory
+ ;; needed to hold the strvec.
+ (let ((string-bytes 0)
+ ;; We need an extra for the null, and an extra 'cause exect
+ ;; clobbers argv[-1].
+ (vec-bytes (* #-alpha 4 #+alpha 8 (+ (length string-list) 2))))
+ (declare (fixnum string-bytes vec-bytes))
+ (dolist (s string-list)
+ (check-type s simple-string)
+ (incf string-bytes (round-bytes-to-words (1+ (length s)))))
+ ;; Now allocate the memory and fill it in.
+ (let* ((total-bytes (+ string-bytes vec-bytes))
+ (vec-sap (system:allocate-system-memory total-bytes))
+ (string-sap (sap+ vec-sap vec-bytes))
+ (i #-alpha 4 #+alpha 8))
+ (declare (type (and unsigned-byte fixnum) total-bytes i)
+ (type system:system-area-pointer vec-sap string-sap))
+ (dolist (s string-list)
+ (declare (simple-string s))
+ (let ((n (length s)))
+ ;; Blast the string into place.
+ (kernel:copy-to-system-area (the simple-string s)
+ (* vm:vector-data-offset vm:word-bits)
+ string-sap 0
+ (* (1+ n) vm:byte-bits))
+ ;; Blast the pointer to the string into place.
+ (setf (sap-ref-sap vec-sap i) string-sap)
+ (setf string-sap (sap+ string-sap (round-bytes-to-words (1+ n))))
+ (incf i #-alpha 4 #+alpha 8)))
+ ;; Blast in the last null pointer.
+ (setf (sap-ref-sap vec-sap i) (int-sap 0))
+ (values vec-sap (sap+ vec-sap #-alpha 4 #+alpha 8) total-bytes))))
+
+(defmacro with-c-strvec ((var str-list) &body body)
+ (let ((sap (gensym "SAP-"))
+ (size (gensym "SIZE-")))
+ `(multiple-value-bind
+ (,sap ,var ,size)
+ (string-list-to-c-strvec ,str-list)
+ (unwind-protect
+ (progn
+ ,@body)
+ (system:deallocate-system-memory ,sap ,size)))))
+
+(alien:def-alien-routine spawn c-call:int
+ (program c-call:c-string)
+ (argv (* c-call:c-string))
+ (envp (* c-call:c-string))
+ (pty-name c-call:c-string)
+ (stdin c-call:int)
+ (stdout c-call:int)
+ (stderr c-call:int))
+
+;;; RUN-PROGRAM uses fork and execve to run a different program.
+;;; Strange stuff happens to keep the unix state of the world
+;;; coherent.
+;;;
+;;; The child process needs to get it's input from somewhere, and send it's
+;;; output (both standard and error) to somewhere. We have to do different
+;;; things depending on where these somewheres really are.
+;;;
+;;; For input, there are five options:
+;;; - T: Just leave fd 0 alone. Pretty simple.
+;;; - "file": Read from the file. We need to open the file and pull the
+;;; descriptor out of the stream. The parent should close this stream after
+;;; the child is up and running to free any storage used in the parent.
+;;; - NIL: Same as "file", but use "/dev/null" as the file.
+;;; - :STREAM: Use unix-pipe to create two descriptors. Use system:make-fd-stream
+;;; to create the output stream on the writeable descriptor, and pass the
+;;; readable descriptor to the child. The parent must close the readable
+;;; descriptor for EOF to be passed up correctly.
+;;; - a stream: If it's a fd-stream, just pull the descriptor out of it.
+;;; Otherwise make a pipe as in :STREAM, and copy everything across.
+;;;
+;;; For output, there are n options:
+;;; - T: Leave descriptor 1 alone.
+;;; - "file": dump output to the file.
+;;; - NIL: dump output to /dev/null.
+;;; - :STREAM: return a stream that can be read from.
+;;; - a stream: if it's a fd-stream, use the descriptor in it. Otherwise, copy
+;;; stuff from output to stream.
+;;;
+;;; For error, there are all the same options as output plus:
+;;; - :OUTPUT: redirect to the same place as output.
+;;;
+;;; RUN-PROGRAM returns a process struct for the process if the fork
+;;; worked, and NIL if it did not.
+(defun run-program (program args
+ &key
+ (env *environment-list*)
+ (wait t)
+ pty
+ input
+ if-input-does-not-exist
+ output
+ (if-output-exists :error)
+ (error :output)
+ (if-error-exists :error)
+ status-hook)
+ "RUN-PROGRAM creates a new process and runs the unix program in the
+ file specified by PROGRAM (a SIMPLE-STRING). ARGS are the standard
+ arguments that can be passed to a Unix program; for no arguments
+ use NIL (which means just the name of the program is passed as arg 0).
+
+ RUN-PROGRAM will either return NIL or a PROCESS structure. See the CMU
+ Common Lisp Users Manual for details about the PROCESS structure.
+
+ The keyword arguments have the following meanings:
+ :env -
+ An alist mapping keyword environment variables to SIMPLE-STRING
+ values.
+ :wait -
+ If non-NIL (default), wait until the created process finishes. If
+ NIL, continue running Lisp until the program finishes.
+ :pty -
+ Either T, NIL, or a stream. Unless NIL, the subprocess is established
+ under a PTY. If :pty is a stream, all output to this pty is sent to
+ this stream, otherwise the PROCESS-PTY slot is filled in with a stream
+ connected to pty that can read output and write input.
+ :input -
+ Either T, NIL, a pathname, a stream, or :STREAM. If T, the standard
+ input for the current process is inherited. If NIL, /dev/null
+ is used. If a pathname, the file so specified is used. If a stream,
+ all the input is read from that stream and send to the subprocess. If
+ :STREAM, the PROCESS-INPUT slot is filled in with a stream that sends
+ its output to the process. Defaults to NIL.
+ :if-input-does-not-exist (when :input is the name of a file) -
+ can be one of:
+ :error - generate an error.
+ :create - create an empty file.
+ nil (default) - return nil from run-program.
+ :output -
+ Either T, NIL, a pathname, a stream, or :STREAM. If T, the standard
+ output for the current process is inherited. If NIL, /dev/null
+ is used. If a pathname, the file so specified is used. If a stream,
+ all the output from the process is written to this stream. If
+ :STREAM, the PROCESS-OUTPUT slot is filled in with a stream that can
+ be read to get the output. Defaults to NIL.
+ :if-output-exists (when :input is the name of a file) -
+ can be one of:
+ :error (default) - generates an error if the file already exists.
+ :supersede - output from the program supersedes the file.
+ :append - output from the program is appended to the file.
+ nil - run-program returns nil without doing anything.
+ :error and :if-error-exists -
+ Same as :output and :if-output-exists, except that :error can also be
+ specified as :output in which case all error output is routed to the
+ same place as normal output.
+ :status-hook -
+ This is a function the system calls whenever the status of the
+ process changes. The function takes the process as an argument."
+
+ ;; Make sure that the interrupt handler is installed.
+ (system:enable-interrupt unix:sigchld #'sigchld-handler)
+ ;; Make sure that all the args are okay.
+ (unless (every #'simple-string-p args)
+ ;; FIXME: should be some sort of TYPE-ERROR? or perhaps we should
+ ;; just be nice and call (COERCE FOO 'SIMPLE-STRING) on each of
+ ;; our arguments, since it's reasonable for the user to pass in
+ ;; (at least) non-SIMPLE STRING values.
+ (error "All args to program must be simple strings: ~S." args))
+ ;; Prepend the program to the argument list.
+ (push (namestring program) args)
+ ;; Clear various specials used by GET-DESCRIPTOR-FOR to communicate
+ ;; cleanup info. Also, establish proc at this level so that we can
+ ;; return it.
+ (let (*close-on-error* *close-in-parent* *handlers-installed* proc)
+ (unwind-protect
+ (let ((pfile (unix-namestring (merge-pathnames program "path:") t t))
+ (cookie (list 0)))
+ (unless pfile
+ (error "no such program: ~S" program))
+ (multiple-value-bind
+ (stdin input-stream)
+ (get-descriptor-for input cookie
+ :direction :input
+ :if-does-not-exist if-input-does-not-exist)
+ (multiple-value-bind
+ (stdout output-stream)
+ (get-descriptor-for output cookie
+ :direction :output
+ :if-exists if-output-exists)
+ (multiple-value-bind
+ (stderr error-stream)
+ (if (eq error :output)
+ (values stdout output-stream)
+ (get-descriptor-for error cookie
+ :direction :output
+ :if-exists if-error-exists))
+ (multiple-value-bind (pty-name pty-stream)
+ (open-pty pty cookie)
+ ;; Make sure we are not notified about the child
+ ;; death before we have installed the process struct
+ ;; in *ACTIVE-PROCESSES*.
+ (system:without-interrupts
+ (with-c-strvec (argv args)
+ (with-c-strvec
+ (envp (mapcar (lambda (entry)
+ (concatenate
+ 'string
+ (symbol-name (car entry))
+ "="
+ (cdr entry)))
+ env))
+ (let ((child-pid
+ (without-gcing
+ (spawn pfile argv envp pty-name
+ stdin stdout stderr))))
+ (when (< child-pid 0)
+ (error "could not fork child process: ~A"
+ (unix:get-unix-error-msg)))
+ (setf proc (make-process :pid child-pid
+ :%status :running
+ :pty pty-stream
+ :input input-stream
+ :output output-stream
+ :error error-stream
+ :status-hook status-hook
+ :cookie cookie))
+ (push proc *active-processes*))))))))))
+ (dolist (fd *close-in-parent*)
+ (unix:unix-close fd))
+ (unless proc
+ (dolist (fd *close-on-error*)
+ (unix:unix-close fd))
+ (dolist (handler *handlers-installed*)
+ (system:remove-fd-handler handler))))
+ (when (and wait proc)
+ (process-wait proc))
+ proc))
+
+;;; Install a handler for any input that shows up on the file
+;;; descriptor. The handler reads the data and writes it to the stream.
+(defun copy-descriptor-to-stream (descriptor stream cookie)
+ (incf (car cookie))
+ (let ((string (make-string 256))
+ handler)
+ (setf handler
+ (system:add-fd-handler descriptor :input
+ #'(lambda (fd)
+ (declare (ignore fd))
+ (loop
+ (unless handler
+ (return))
+ (multiple-value-bind
+ (result readable/errno)
+ (unix:unix-select (1+ descriptor) (ash 1 descriptor)
+ 0 0 0)
+ (cond ((null result)
+ (error "could not select on sub-process: ~A"
+ (unix:get-unix-error-msg readable/errno)))
+ ((zerop result)
+ (return))))
+ (alien:with-alien ((buf (alien:array c-call:char 256)))
+ (multiple-value-bind
+ (count errno)
+ (unix:unix-read descriptor (alien-sap buf) 256)
+ (cond ((or (and (null count)
+ (eql errno unix:eio))
+ (eql count 0))
+ (system:remove-fd-handler handler)
+ (setf handler nil)
+ (decf (car cookie))
+ (unix:unix-close descriptor)
+ (return))
+ ((null count)
+ (system:remove-fd-handler handler)
+ (setf handler nil)
+ (decf (car cookie))
+ (error "could not read input from sub-process: ~A"
+ (unix:get-unix-error-msg errno)))
+ (t
+ (kernel:copy-from-system-area
+ (alien-sap buf) 0
+ string (* vm:vector-data-offset vm:word-bits)
+ (* count vm:byte-bits))
+ (write-string string stream
+ :end count)))))))))))
+
+;;; Find a file descriptor to use for object given the direction.
+;;; Return the descriptor. If object is :STREAM, return the created
+;;; stream as the second value.
+(defun get-descriptor-for (object
+ cookie
+ &rest keys
+ &key direction
+ &allow-other-keys)
+ (cond ((eq object t)
+ ;; No new descriptor is needed.
+ (values -1 nil))
+ ((eq object nil)
+ ;; Use /dev/null.
+ (multiple-value-bind
+ (fd errno)
+ (unix:unix-open "/dev/null"
+ (case direction
+ (:input unix:o_rdonly)
+ (:output unix:o_wronly)
+ (t unix:o_rdwr))
+ #o666)
+ (unless fd
+ (error "could not open \"/dev/null\": ~A"
+ (unix:get-unix-error-msg errno)))
+ (push fd *close-in-parent*)
+ (values fd nil)))
+ ((eq object :stream)
+ (multiple-value-bind
+ (read-fd write-fd)
+ (unix:unix-pipe)
+ (unless read-fd
+ (error "could not create pipe: ~A"
+ (unix:get-unix-error-msg write-fd)))
+ (case direction
+ (:input
+ (push read-fd *close-in-parent*)
+ (push write-fd *close-on-error*)
+ (let ((stream (system:make-fd-stream write-fd :output t)))
+ (values read-fd stream)))
+ (:output
+ (push read-fd *close-on-error*)
+ (push write-fd *close-in-parent*)
+ (let ((stream (system:make-fd-stream read-fd :input t)))
+ (values write-fd stream)))
+ (t
+ (unix:unix-close read-fd)
+ (unix:unix-close write-fd)
+ (error "direction must be either :INPUT or :OUTPUT, not ~S"
+ direction)))))
+ ((or (pathnamep object) (stringp object))
+ (with-open-stream (file (apply #'open object keys))
+ (multiple-value-bind
+ (fd errno)
+ (unix:unix-dup (system:fd-stream-fd file))
+ (cond (fd
+ (push fd *close-in-parent*)
+ (values fd nil))
+ (t
+ (error "could not duplicate file descriptor: ~A"
+ (unix:get-unix-error-msg errno)))))))
+ ((system:fd-stream-p object)
+ (values (system:fd-stream-fd object) nil))
+ ((streamp object)
+ (ecase direction
+ (:input
+ (dotimes (count
+ 256
+ (error "could not open a temporary file in /tmp"))
+ (let* ((name (format nil "/tmp/.run-program-~D" count))
+ (fd (unix:unix-open name
+ (logior unix:o_rdwr
+ unix:o_creat
+ unix:o_excl)
+ #o666)))
+ (unix:unix-unlink name)
+ (when fd
+ (let ((newline (string #\Newline)))
+ (loop
+ (multiple-value-bind
+ (line no-cr)
+ (read-line object nil nil)
+ (unless line
+ (return))
+ (unix:unix-write fd line 0 (length line))
+ (if no-cr
+ (return)
+ (unix:unix-write fd newline 0 1)))))
+ (unix:unix-lseek fd 0 unix:l_set)
+ (push fd *close-in-parent*)
+ (return (values fd nil))))))
+ (:output
+ (multiple-value-bind (read-fd write-fd)
+ (unix:unix-pipe)
+ (unless read-fd
+ (error "could not create pipe: ~A"
+ (unix:get-unix-error-msg write-fd)))
+ (copy-descriptor-to-stream read-fd object cookie)
+ (push read-fd *close-on-error*)
+ (push write-fd *close-in-parent*)
+ (values write-fd nil)))))
+ (t
+ (error "invalid option to RUN-PROGRAM: ~S" object))))
--- /dev/null
+;;;; Dump the current Lisp image into a core file. Also contains
+;;;; various high-level initialization stuff: loading init files and
+;;;; parsing environment variables.
+;;;;
+;;;; (All the real work is done by C.)
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!IMPL")
+
+(file-comment
+ "$Header$")
+\f
+(defvar *before-save-initializations* nil
+ #!+sb-doc
+ "This is a list of functions which are called before creating a saved core
+ image. These functions are executed in the child process which has no ports,
+ so they cannot do anything that tries to talk to the outside world.")
+
+(defvar *after-save-initializations* nil
+ #!+sb-doc
+ "This is a list of functions which are called when a saved core image starts
+ up. The system itself should be initialized at this point, but applications
+ might not be.")
+\f
+;;;; SAVE-LISP-AND-DIE itself
+
+(sb!alien:def-alien-routine "save" (sb!alien:boolean)
+ (file sb!c-call:c-string)
+ (initial-function (sb!alien:unsigned #.sb!vm:word-bits)))
+
+;;; FIXME: When this is run without the PURIFY option,
+;;; it seems to save memory all the way up to the high-water mark,
+;;; not just what's currently used; and then after loading the
+;;; image to make a running Lisp, the memory never gets reclaimed.
+;;; (But with the PURIFY option it seems to work OK.)
+(defun save-lisp-and-die (core-file-name &key
+ (toplevel #'toplevel)
+ (purify nil)
+ (root-structures ())
+ (environment-name "auxiliary"))
+ #!+sb-doc
+ "Saves a CMU Common Lisp core image in the file of the specified name,
+ killing the current Lisp invocation in the process (unless it bails
+ out early because of some argument error or something).
+
+ The following keyword args are defined:
+
+ :TOPLEVEL
+ The function to run when the created core file is resumed.
+ The default function handles command line toplevel option
+ processing and runs the top level read-eval-print loop. This
+ function should not return.
+
+ :PURIFY
+ If true (the default), do a purifying GC which moves all dynamically
+ allocated objects into static space so that they stay pure. This takes
+ somewhat longer than the normal GC which is otherwise done, but it's only
+ done once, and subsequent GC's will be done less often and will take less
+ time in the resulting core file. See PURIFY.
+
+ :ROOT-STRUCTURES
+ This should be a list of the main entry points in any newly loaded
+ systems. This need not be supplied, but locality and/or GC performance
+ may be better if they are. Meaningless if :PURIFY is NIL. See PURIFY.
+
+ :ENVIRONMENT-NAME
+ This is also passed to PURIFY when :PURIFY is T. (rarely used)"
+
+ #!+mp (sb!mp::shutdown-multi-processing)
+ (when (fboundp 'sb!eval:flush-interpreted-function-cache)
+ (sb!eval:flush-interpreted-function-cache))
+ ;; FIXME: What is this for? Explain.
+ (when (fboundp 'cancel-finalization)
+ (cancel-finalization sb!sys:*tty*))
+ ;; FIXME: Would it be possible to unmix the PURIFY logic from this
+ ;; function, and just do a GC :FULL T here? (Then if the user wanted
+ ;; a PURIFYed image, he'd just run PURIFY immediately before calling
+ ;; SAVE-LISP-AND-DIE.)
+ (if purify
+ (purify :root-structures root-structures
+ :environment-name environment-name)
+ #!-gencgc (gc) #!+gencgc (gc :full t))
+ ;; FIXME: Wouldn't it be more correct to go through this list backwards
+ ;; instead of forwards?
+ (dolist (f *before-save-initializations*)
+ (funcall f))
+ (flet ((restart-lisp ()
+ (sb!unix:unix-exit
+ (catch '%end-of-the-world
+ (reinit)
+ ;; FIXME: Wouldn't it be more correct to do this running
+ ;; backwards through the list, instead of forwards?
+ (dolist (f *after-save-initializations*)
+ (funcall f))
+ (funcall toplevel)))))
+ ;; FIXME: Perhaps WITHOUT-GCING should be wrapped around the
+ ;; LET as well, to avoid the off chance of an interrupt triggering
+ ;; GC and making our saved RESTART-LISP address invalid?
+ (without-gcing
+ (save (unix-namestring core-file-name nil)
+ (get-lisp-obj-address #'restart-lisp)))))
+\f
+;;;; functions used by worldload.lisp in CMU CL bootstrapping
+
+;;; If Name has been byte-compiled, and :RUNTIME is a feature, then load the
+;;; byte-compiled version, otherwise just do normal load.
+#+nil ; no longer needed in SBCL.. I think.. -- WHN 19990814
+(defun maybe-byte-load (name &optional (load-native t))
+ (let ((bname (make-pathname
+ :defaults name
+ :type #.(sb!c:backend-byte-fasl-file-type))))
+ (cond ((and (featurep :runtime)
+ (probe-file bname))
+ (load bname))
+ (load-native
+ (load name)))))
+
+;;; Replace a cold-loaded native object file with a byte-compiled one, if it
+;;; exists.
+#+nil ; no longer needed in SBCL.. I think.. -- WHN 19990814
+(defun byte-load-over (name)
+ (load (make-pathname
+ :defaults name
+ :type #.(sb!c:backend-byte-fasl-file-type))
+ :if-does-not-exist nil))
--- /dev/null
+;;;; generic SEQUENCEs
+;;;;
+;;;; KLUDGE: comment from original CMU CL source:
+;;;; Be careful when modifying code. A lot of the structure of the
+;;;; code is affected by the fact that compiler transforms use the
+;;;; lower level support functions. If transforms are written for
+;;;; some sequence operation, note how the END argument is handled
+;;;; in other operations with transforms.
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!IMPL")
+
+(file-comment
+ "$Header$")
+\f
+;;;; utilities
+
+(eval-when (:compile-toplevel)
+
+;;; Seq-Dispatch does an efficient type-dispatch on the given Sequence.
+
+;;; FIXME: It might be worth making three cases here, LIST, SIMPLE-VECTOR,
+;;; and VECTOR, instead of the current LIST and VECTOR. It tend to make code
+;;; run faster but be bigger; some benchmarking is needed to decide.
+(sb!xc:defmacro seq-dispatch (sequence list-form array-form)
+ `(if (listp ,sequence)
+ ,list-form
+ ,array-form))
+
+;;; FIXME: Implementations of MAPFOO which use this are O(N*N) when users
+;;; could reasonably expect them to be O(N). This should be fixed.
+(sb!xc:defmacro elt-slice (sequences n)
+ #!+sb-doc
+ "Returns a list of the Nth element of each of the sequences. Used by MAP
+ and friends."
+ `(mapcar #'(lambda (seq) (elt seq ,n)) ,sequences))
+
+(sb!xc:defmacro make-sequence-like (sequence length)
+ #!+sb-doc
+ "Returns a sequence of the same type as SEQUENCE and the given LENGTH."
+ `(make-sequence-of-type (type-of ,sequence) ,length))
+
+(sb!xc:defmacro type-specifier-atom (type)
+ #!+sb-doc "Returns the broad class of which TYPE is a specific subclass."
+ `(if (atom ,type) ,type (car ,type)))
+
+) ; EVAL-WHEN
+
+;;; Given an arbitrary type specifier, return a sane sequence type
+;;; specifier that we can directly match.
+(defun result-type-or-lose (type &optional nil-ok)
+ (let ((type (specifier-type type)))
+ (cond
+ ((eq type *empty-type*)
+ (if nil-ok
+ nil
+ (error 'simple-type-error
+ :datum type
+ :expected-type '(or vector cons)
+ :format-control
+ "NIL output type invalid for this sequence function."
+ :format-arguments ())))
+ ((dolist (seq-type '(list string simple-vector bit-vector))
+ (when (csubtypep type (specifier-type seq-type))
+ (return seq-type))))
+ ((csubtypep type (specifier-type 'vector))
+ (type-specifier type))
+ (t
+ (error 'simple-type-error
+ :datum type
+ :expected-type 'sequence
+ :format-control
+ "~S is a bad type specifier for sequence functions."
+ :format-arguments (list type))))))
+
+(defun signal-index-too-large-error (sequence index)
+ (let* ((length (length sequence))
+ (max-index (and (plusp length)(1- length))))
+ (error 'index-too-large-error
+ :datum index
+ :expected-type (if max-index
+ `(integer 0 ,max-index)
+ ;; This seems silly, is there something better?
+ '(integer (0) (0))))))
+
+(defun make-sequence-of-type (type length)
+ #!+sb-doc "Returns a sequence of the given TYPE and LENGTH."
+ (declare (fixnum length))
+ (case (type-specifier-atom type)
+ (list (make-list length))
+ ((bit-vector simple-bit-vector) (make-array length :element-type '(mod 2)))
+ ((string simple-string base-string simple-base-string)
+ (make-string length))
+ (simple-vector (make-array length))
+ ((array simple-array vector)
+ (if (listp type)
+ (make-array length :element-type (cadr type))
+ (make-array length)))
+ (t
+ (make-sequence-of-type (result-type-or-lose type) length))))
+\f
+(defun elt (sequence index)
+ #!+sb-doc "Returns the element of SEQUENCE specified by INDEX."
+ (etypecase sequence
+ (list
+ (do ((count index (1- count))
+ (list sequence (cdr list)))
+ ((= count 0)
+ (if (endp list)
+ (signal-index-too-large-error sequence index)
+ (car list)))
+ (declare (type (integer 0) count))))
+ (vector
+ (when (>= index (length sequence))
+ (signal-index-too-large-error sequence index))
+ (aref sequence index))))
+
+(defun %setelt (sequence index newval)
+ #!+sb-doc "Store NEWVAL as the component of SEQUENCE specified by INDEX."
+ (etypecase sequence
+ (list
+ (do ((count index (1- count))
+ (seq sequence))
+ ((= count 0) (rplaca seq newval) newval)
+ (declare (fixnum count))
+ (if (atom (cdr seq))
+ (signal-index-too-large-error sequence index)
+ (setq seq (cdr seq)))))
+ (vector
+ (when (>= index (length sequence))
+ (signal-index-too-large-error sequence index))
+ (setf (aref sequence index) newval))))
+
+(defun length (sequence)
+ #!+sb-doc "Returns an integer that is the length of SEQUENCE."
+ (etypecase sequence
+ (vector (length (truly-the vector sequence)))
+ (list (length (truly-the list sequence)))))
+
+(defun make-sequence (type length &key (initial-element NIL iep))
+ #!+sb-doc
+ "Returns a sequence of the given Type and Length, with elements initialized
+ to :Initial-Element."
+ (declare (fixnum length))
+ (let ((type (specifier-type type)))
+ (cond ((csubtypep type (specifier-type 'list))
+ (make-list length :initial-element initial-element))
+ ((csubtypep type (specifier-type 'string))
+ (if iep
+ (make-string length :initial-element initial-element)
+ (make-string length)))
+ ((csubtypep type (specifier-type 'simple-vector))
+ (make-array length :initial-element initial-element))
+ ((csubtypep type (specifier-type 'bit-vector))
+ (if iep
+ (make-array length :element-type '(mod 2)
+ :initial-element initial-element)
+ (make-array length :element-type '(mod 2))))
+ ((csubtypep type (specifier-type 'vector))
+ (if (typep type 'array-type)
+ (let ((etype (type-specifier
+ (array-type-specialized-element-type type)))
+ (vlen (car (array-type-dimensions type))))
+ (if (and (numberp vlen) (/= vlen length))
+ (error 'simple-type-error
+ ;; these two are under-specified by ANSI
+ :datum (type-specifier type)
+ :expected-type (type-specifier type)
+ :format-control
+ "The length of ~S does not match the specified length of ~S."
+ :format-arguments
+ (list (type-specifier type) length)))
+ (if iep
+ (make-array length :element-type etype
+ :initial-element initial-element)
+ (make-array length :element-type etype)))
+ (make-array length :initial-element initial-element)))
+ (t (error 'simple-type-error
+ :datum type
+ :expected-type 'sequence
+ :format-control "~S is a bad type specifier for sequences."
+ :format-arguments (list type))))))
+\f
+;;;; SUBSEQ
+;;;;
+;;;; The support routines for SUBSEQ are used by compiler transforms, so we
+;;;; worry about dealing with END being supplied or defaulting to NIL
+;;;; at this level.
+
+(defun vector-subseq* (sequence start &optional end)
+ (declare (type vector sequence))
+ (declare (type fixnum start))
+ (declare (type (or null fixnum) end))
+ (when (null end) (setf end (length sequence)))
+ (do ((old-index start (1+ old-index))
+ (new-index 0 (1+ new-index))
+ (copy (make-sequence-like sequence (- end start))))
+ ((= old-index end) copy)
+ (declare (fixnum old-index new-index))
+ (setf (aref copy new-index) (aref sequence old-index))))
+
+(defun list-subseq* (sequence start &optional end)
+ (declare (type list sequence))
+ (declare (type fixnum start))
+ (declare (type (or null fixnum) end))
+ (if (and end (>= start (the fixnum end)))
+ ()
+ (let* ((groveled (nthcdr start sequence))
+ (result (list (car groveled))))
+ (if groveled
+ (do ((list (cdr groveled) (cdr list))
+ (splice result (cdr (rplacd splice (list (car list)))))
+ (index (1+ start) (1+ index)))
+ ((or (atom list) (and end (= index (the fixnum end))))
+ result)
+ (declare (fixnum index)))
+ ()))))
+
+;;; SUBSEQ cannot default end to the length of sequence since it is not
+;;; an error to supply nil for its value. We must test for end being nil
+;;; in the body of the function, and this is actually done in the support
+;;; routines for other reasons (see above).
+(defun subseq (sequence start &optional end)
+ #!+sb-doc
+ "Returns a copy of a subsequence of SEQUENCE starting with element number
+ START and continuing to the end of SEQUENCE or the optional END."
+ (seq-dispatch sequence
+ (list-subseq* sequence start end)
+ (vector-subseq* sequence start end)))
+\f
+;;;; COPY-SEQ
+
+(eval-when (:compile-toplevel :execute)
+
+(sb!xc:defmacro vector-copy-seq (sequence type)
+ `(let ((length (length (the vector ,sequence))))
+ (declare (fixnum length))
+ (do ((index 0 (1+ index))
+ (copy (make-sequence-of-type ,type length)))
+ ((= index length) copy)
+ (declare (fixnum index))
+ (setf (aref copy index) (aref ,sequence index)))))
+
+(sb!xc:defmacro list-copy-seq (list)
+ `(if (atom ,list) '()
+ (let ((result (cons (car ,list) '()) ))
+ (do ((x (cdr ,list) (cdr x))
+ (splice result
+ (cdr (rplacd splice (cons (car x) '() ))) ))
+ ((atom x) (unless (null x)
+ (rplacd splice x))
+ result)))))
+
+) ; EVAL-WHEN
+
+(defun copy-seq (sequence)
+ #!+sb-doc "Returns a copy of SEQUENCE which is EQUAL to SEQUENCE but not EQ."
+ (seq-dispatch sequence
+ (list-copy-seq* sequence)
+ (vector-copy-seq* sequence)))
+
+;;; internal frobs
+
+(defun list-copy-seq* (sequence)
+ (list-copy-seq sequence))
+
+(defun vector-copy-seq* (sequence)
+ (vector-copy-seq sequence (type-of sequence)))
+\f
+;;;; FILL
+
+(eval-when (:compile-toplevel :execute)
+
+(sb!xc:defmacro vector-fill (sequence item start end)
+ `(do ((index ,start (1+ index)))
+ ((= index (the fixnum ,end)) ,sequence)
+ (declare (fixnum index))
+ (setf (aref ,sequence index) ,item)))
+
+(sb!xc:defmacro list-fill (sequence item start end)
+ `(do ((current (nthcdr ,start ,sequence) (cdr current))
+ (index ,start (1+ index)))
+ ((or (atom current) (and end (= index (the fixnum ,end))))
+ sequence)
+ (declare (fixnum index))
+ (rplaca current ,item)))
+
+) ; EVAL-WHEN
+
+;;; The support routines for FILL are used by compiler transforms, so we
+;;; worry about dealing with END being supplied or defaulting to NIL
+;;; at this level.
+
+(defun list-fill* (sequence item start end)
+ (declare (list sequence))
+ (list-fill sequence item start end))
+
+(defun vector-fill* (sequence item start end)
+ (declare (vector sequence))
+ (when (null end) (setq end (length sequence)))
+ (vector-fill sequence item start end))
+
+;;; FILL cannot default end to the length of sequence since it is not
+;;; an error to supply nil for its value. We must test for end being nil
+;;; in the body of the function, and this is actually done in the support
+;;; routines for other reasons (see above).
+(defun fill (sequence item &key (start 0) end)
+ #!+sb-doc "Replace the specified elements of SEQUENCE with ITEM."
+ (seq-dispatch sequence
+ (list-fill* sequence item start end)
+ (vector-fill* sequence item start end)))
+\f
+;;;; REPLACE
+
+(eval-when (:compile-toplevel :execute)
+
+;;; If we are copying around in the same vector, be careful not to copy the
+;;; same elements over repeatedly. We do this by copying backwards.
+(sb!xc:defmacro mumble-replace-from-mumble ()
+ `(if (and (eq target-sequence source-sequence) (> target-start source-start))
+ (let ((nelts (min (- target-end target-start)
+ (- source-end source-start))))
+ (do ((target-index (+ (the fixnum target-start) (the fixnum nelts) -1)
+ (1- target-index))
+ (source-index (+ (the fixnum source-start) (the fixnum nelts) -1)
+ (1- source-index)))
+ ((= target-index (the fixnum (1- target-start))) target-sequence)
+ (declare (fixnum target-index source-index))
+ (setf (aref target-sequence target-index)
+ (aref source-sequence source-index))))
+ (do ((target-index target-start (1+ target-index))
+ (source-index source-start (1+ source-index)))
+ ((or (= target-index (the fixnum target-end))
+ (= source-index (the fixnum source-end)))
+ target-sequence)
+ (declare (fixnum target-index source-index))
+ (setf (aref target-sequence target-index)
+ (aref source-sequence source-index)))))
+
+(sb!xc:defmacro list-replace-from-list ()
+ `(if (and (eq target-sequence source-sequence) (> target-start source-start))
+ (let ((new-elts (subseq source-sequence source-start
+ (+ (the fixnum source-start)
+ (the fixnum
+ (min (- (the fixnum target-end)
+ (the fixnum target-start))
+ (- (the fixnum source-end)
+ (the fixnum source-start))))))))
+ (do ((n new-elts (cdr n))
+ (o (nthcdr target-start target-sequence) (cdr o)))
+ ((null n) target-sequence)
+ (rplaca o (car n))))
+ (do ((target-index target-start (1+ target-index))
+ (source-index source-start (1+ source-index))
+ (target-sequence-ref (nthcdr target-start target-sequence)
+ (cdr target-sequence-ref))
+ (source-sequence-ref (nthcdr source-start source-sequence)
+ (cdr source-sequence-ref)))
+ ((or (= target-index (the fixnum target-end))
+ (= source-index (the fixnum source-end))
+ (null target-sequence-ref) (null source-sequence-ref))
+ target-sequence)
+ (declare (fixnum target-index source-index))
+ (rplaca target-sequence-ref (car source-sequence-ref)))))
+
+(sb!xc:defmacro list-replace-from-mumble ()
+ `(do ((target-index target-start (1+ target-index))
+ (source-index source-start (1+ source-index))
+ (target-sequence-ref (nthcdr target-start target-sequence)
+ (cdr target-sequence-ref)))
+ ((or (= target-index (the fixnum target-end))
+ (= source-index (the fixnum source-end))
+ (null target-sequence-ref))
+ target-sequence)
+ (declare (fixnum source-index target-index))
+ (rplaca target-sequence-ref (aref source-sequence source-index))))
+
+(sb!xc:defmacro mumble-replace-from-list ()
+ `(do ((target-index target-start (1+ target-index))
+ (source-index source-start (1+ source-index))
+ (source-sequence (nthcdr source-start source-sequence)
+ (cdr source-sequence)))
+ ((or (= target-index (the fixnum target-end))
+ (= source-index (the fixnum source-end))
+ (null source-sequence))
+ target-sequence)
+ (declare (fixnum target-index source-index))
+ (setf (aref target-sequence target-index) (car source-sequence))))
+
+) ; EVAL-WHEN
+
+;;;; The support routines for REPLACE are used by compiler transforms, so we
+;;;; worry about dealing with END being supplied or defaulting to NIL
+;;;; at this level.
+
+(defun list-replace-from-list* (target-sequence source-sequence target-start
+ target-end source-start source-end)
+ (when (null target-end) (setq target-end (length target-sequence)))
+ (when (null source-end) (setq source-end (length source-sequence)))
+ (list-replace-from-list))
+
+(defun list-replace-from-vector* (target-sequence source-sequence target-start
+ target-end source-start source-end)
+ (when (null target-end) (setq target-end (length target-sequence)))
+ (when (null source-end) (setq source-end (length source-sequence)))
+ (list-replace-from-mumble))
+
+(defun vector-replace-from-list* (target-sequence source-sequence target-start
+ target-end source-start source-end)
+ (when (null target-end) (setq target-end (length target-sequence)))
+ (when (null source-end) (setq source-end (length source-sequence)))
+ (mumble-replace-from-list))
+
+(defun vector-replace-from-vector* (target-sequence source-sequence
+ target-start target-end source-start
+ source-end)
+ (when (null target-end) (setq target-end (length target-sequence)))
+ (when (null source-end) (setq source-end (length source-sequence)))
+ (mumble-replace-from-mumble))
+
+;;; REPLACE cannot default end arguments to the length of sequence since it
+;;; is not an error to supply nil for their values. We must test for ends
+;;; being nil in the body of the function.
+(defun replace (target-sequence source-sequence &key
+ ((:start1 target-start) 0)
+ ((:end1 target-end))
+ ((:start2 source-start) 0)
+ ((:end2 source-end)))
+ #!+sb-doc
+ "The target sequence is destructively modified by copying successive
+ elements into it from the source sequence."
+ (let ((target-end (or target-end (length target-sequence)))
+ (source-end (or source-end (length source-sequence))))
+ (seq-dispatch target-sequence
+ (seq-dispatch source-sequence
+ (list-replace-from-list)
+ (list-replace-from-mumble))
+ (seq-dispatch source-sequence
+ (mumble-replace-from-list)
+ (mumble-replace-from-mumble)))))
+\f
+;;;; REVERSE
+
+(eval-when (:compile-toplevel :execute)
+
+(sb!xc:defmacro vector-reverse (sequence type)
+ `(let ((length (length ,sequence)))
+ (declare (fixnum length))
+ (do ((forward-index 0 (1+ forward-index))
+ (backward-index (1- length) (1- backward-index))
+ (new-sequence (make-sequence-of-type ,type length)))
+ ((= forward-index length) new-sequence)
+ (declare (fixnum forward-index backward-index))
+ (setf (aref new-sequence forward-index)
+ (aref ,sequence backward-index)))))
+
+(sb!xc:defmacro list-reverse-macro (sequence)
+ `(do ((new-list ()))
+ ((atom ,sequence) new-list)
+ (push (pop ,sequence) new-list)))
+
+) ; EVAL-WHEN
+
+(defun reverse (sequence)
+ #!+sb-doc
+ "Returns a new sequence containing the same elements but in reverse order."
+ (seq-dispatch sequence
+ (list-reverse* sequence)
+ (vector-reverse* sequence)))
+
+;;; internal frobs
+
+(defun list-reverse* (sequence)
+ (list-reverse-macro sequence))
+
+(defun vector-reverse* (sequence)
+ (vector-reverse sequence (type-of sequence)))
+\f
+;;;; NREVERSE
+
+(eval-when (:compile-toplevel :execute)
+
+(sb!xc:defmacro vector-nreverse (sequence)
+ `(let ((length (length (the vector ,sequence))))
+ (declare (fixnum length))
+ (do ((left-index 0 (1+ left-index))
+ (right-index (1- length) (1- right-index))
+ (half-length (truncate length 2)))
+ ((= left-index half-length) ,sequence)
+ (declare (fixnum left-index right-index half-length))
+ (rotatef (aref ,sequence left-index)
+ (aref ,sequence right-index)))))
+
+(sb!xc:defmacro list-nreverse-macro (list)
+ `(do ((1st (cdr ,list) (if (atom 1st) 1st (cdr 1st)))
+ (2nd ,list 1st)
+ (3rd '() 2nd))
+ ((atom 2nd) 3rd)
+ (rplacd 2nd 3rd)))
+
+) ; EVAL-WHEN
+
+(defun list-nreverse* (sequence)
+ (list-nreverse-macro sequence))
+
+(defun vector-nreverse* (sequence)
+ (vector-nreverse sequence))
+
+(defun nreverse (sequence)
+ #!+sb-doc
+ "Returns a sequence of the same elements in reverse order; the argument
+ is destroyed."
+ (seq-dispatch sequence
+ (list-nreverse* sequence)
+ (vector-nreverse* sequence)))
+\f
+;;;; CONCATENATE
+
+(eval-when (:compile-toplevel :execute)
+
+(sb!xc:defmacro concatenate-to-list (sequences)
+ `(let ((result (list nil)))
+ (do ((sequences ,sequences (cdr sequences))
+ (splice result))
+ ((null sequences) (cdr result))
+ (let ((sequence (car sequences)))
+ ;; FIXME: It appears to me that this and CONCATENATE-TO-MUMBLE
+ ;; could benefit from a DO-SEQUENCE macro.
+ (seq-dispatch sequence
+ (do ((sequence sequence (cdr sequence)))
+ ((atom sequence))
+ (setq splice
+ (cdr (rplacd splice (list (car sequence))))))
+ (do ((index 0 (1+ index))
+ (length (length sequence)))
+ ((= index length))
+ (declare (fixnum index length))
+ (setq splice
+ (cdr (rplacd splice
+ (list (aref sequence index)))))))))))
+
+(sb!xc:defmacro concatenate-to-mumble (output-type-spec sequences)
+ `(do ((seqs ,sequences (cdr seqs))
+ (total-length 0)
+ (lengths ()))
+ ((null seqs)
+ (do ((sequences ,sequences (cdr sequences))
+ (lengths lengths (cdr lengths))
+ (index 0)
+ (result (make-sequence-of-type ,output-type-spec total-length)))
+ ((= index total-length) result)
+ (declare (fixnum index))
+ (let ((sequence (car sequences)))
+ (seq-dispatch sequence
+ (do ((sequence sequence (cdr sequence)))
+ ((atom sequence))
+ (setf (aref result index) (car sequence))
+ (setq index (1+ index)))
+ (do ((jndex 0 (1+ jndex))
+ (this-length (car lengths)))
+ ((= jndex this-length))
+ (declare (fixnum jndex this-length))
+ (setf (aref result index)
+ (aref sequence jndex))
+ (setq index (1+ index)))))))
+ (let ((length (length (car seqs))))
+ (declare (fixnum length))
+ (setq lengths (nconc lengths (list length)))
+ (setq total-length (+ total-length length)))))
+
+) ; EVAL-WHEN
+\f
+;;; FIXME: Make a compiler macro or transform for this which efficiently
+;;; handles the case of constant 'STRING first argument. (It's not just time
+;;; efficiency, but space efficiency..)
+(defun concatenate (output-type-spec &rest sequences)
+ #!+sb-doc
+ "Returns a new sequence of all the argument sequences concatenated together
+ which shares no structure with the original argument sequences of the
+ specified OUTPUT-TYPE-SPEC."
+ (case (type-specifier-atom output-type-spec)
+ ((simple-vector simple-string vector string array simple-array
+ bit-vector simple-bit-vector base-string
+ simple-base-string) ; FIXME: unifying principle here?
+ (let ((result (apply #'concat-to-simple* output-type-spec sequences)))
+ #!+high-security
+ (check-type-var result output-type-spec)
+ result))
+ (list (apply #'concat-to-list* sequences))
+ (t
+ (apply #'concatenate (result-type-or-lose output-type-spec) sequences))))
+
+;;; internal frobs
+;;; FIXME: These are weird. They're never called anywhere except in
+;;; CONCATENATE. It seems to me that the macros ought to just
+;;; be expanded directly in CONCATENATE, or in CONCATENATE-STRING
+;;; and CONCATENATE-LIST variants. Failing that, these ought to be local
+;;; functions (FLET).
+(defun concat-to-list* (&rest sequences)
+ (concatenate-to-list sequences))
+(defun concat-to-simple* (type &rest sequences)
+ (concatenate-to-mumble type sequences))
+\f
+;;;; MAP
+
+;;; helper functions to handle the common consing subcases of MAP
+(declaim (ftype (function (function sequence) list) %map-list-arity-1))
+(declaim (ftype (function (function sequence) simple-vector)
+ %map-simple-vector-arity-1))
+(macrolet ((dosequence ((i sequence) &body body)
+ (once-only ((sequence sequence))
+ `(etypecase ,sequence
+ (list (dolist (,i ,sequence) ,@body))
+ (simple-vector (dovector (,i sequence) ,@body))
+ (vector (dovector (,i sequence) ,@body))))))
+ (defun %map-to-list-arity-1 (fun sequence)
+ (declare (type function fun))
+ (let ((really-fun (if (functionp fun) fun (%coerce-name-to-function fun)))
+ (reversed-result nil))
+ (dosequence (element sequence)
+ (push (funcall really-fun element)
+ reversed-result))
+ (nreverse reversed-result)))
+ (defun %map-to-simple-vector-arity-1 (fun sequence)
+ (declare (type function fun))
+ (let ((really-fun (if (functionp fun) fun (%coerce-name-to-function fun)))
+ (result (make-array (length sequence)))
+ (index 0))
+ (declare (type index index))
+ (dosequence (element sequence)
+ (setf (aref result index)
+ (funcall really-fun element))
+ (incf index))
+ result)))
+
+(eval-when (:compile-toplevel :execute)
+
+(sb!xc:defmacro map-to-list (function sequences)
+ `(do ((seqs more-sequences (cdr seqs))
+ (min-length (length first-sequence)))
+ ((null seqs)
+ (let ((result (list nil)))
+ (do ((index 0 (1+ index))
+ (splice result))
+ ((= index min-length) (cdr result))
+ (declare (fixnum index))
+ (setq splice
+ (cdr (rplacd splice
+ (list (apply ,function (elt-slice ,sequences
+ index)))))))))
+ (declare (fixnum min-length))
+ (let ((length (length (car seqs))))
+ (declare (fixnum length))
+ (if (< length min-length)
+ (setq min-length length)))))
+
+(sb!xc:defmacro map-to-simple (output-type-spec function sequences)
+ `(do ((seqs more-sequences (cdr seqs))
+ (min-length (length first-sequence)))
+ ((null seqs)
+ (do ((index 0 (1+ index))
+ (result (make-sequence-of-type ,output-type-spec min-length)))
+ ((= index min-length) result)
+ (declare (fixnum index))
+ (setf (aref result index)
+ (apply ,function (elt-slice ,sequences index)))))
+ (declare (fixnum min-length))
+ (let ((length (length (car seqs))))
+ (declare (fixnum length))
+ (if (< length min-length)
+ (setq min-length length)))))
+
+(sb!xc:defmacro map-for-effect (function sequences)
+ `(do ((seqs more-sequences (cdr seqs))
+ (min-length (length first-sequence)))
+ ((null seqs)
+ (do ((index 0 (1+ index)))
+ ((= index min-length) nil)
+ (apply ,function (elt-slice ,sequences index))))
+ (declare (fixnum min-length))
+ (let ((length (length (car seqs))))
+ (declare (fixnum length))
+ (if (< length min-length)
+ (setq min-length length)))))
+
+) ; EVAL-WHEN
+
+#!+high-security-support
+(defun get-minimum-length-sequences (sequences)
+ #!+sb-doc "Gets the minimum length of the sequences. This is
+needed to check whether the supplied type is appropriate."
+ (let ((min nil))
+ (dolist (i sequences)
+ (when (or (listp i) (vectorp i))
+ (let ((l (length i)))
+ (when (or (null min)
+ (> min l)))
+ (setf min l))))
+ min))
+
+(defun map (output-type-spec function first-sequence &rest more-sequences)
+ #!+sb-doc
+ "FUNCTION must take as many arguments as there are sequences provided. The
+ result is a sequence such that element i is the result of applying FUNCTION
+ to element i of each of the argument sequences."
+ (let ((really-function (if (functionp function)
+ function
+ (%coerce-name-to-function function))))
+ ;; Pick off the easy non-consing arity-1 special case and handle
+ ;; it without consing, since the user probably didn't expect us to
+ ;; cons here. (Notably, the super duper users who wrote PCL in
+ ;; terms of quantifiers without declaring the types of their
+ ;; sequence arguments didn't expect to end up consing when SBCL
+ ;; transforms the quantifiers into calls to MAP NIL.)
+ (when (and (null more-sequences)
+ (null output-type-spec))
+ (macrolet ((frob () '(return-from map
+ (map nil really-function first-sequence))))
+ (etypecase first-sequence
+ (simple-vector (frob))
+ (list (frob))
+ (vector (frob)))))
+ ;; Otherwise, if the user didn't give us enough information to
+ ;; simplify at compile time, we cons and cons and cons..
+ (let ((sequences (cons first-sequence more-sequences)))
+ (case (type-specifier-atom output-type-spec)
+ ((nil) (map-for-effect really-function sequences))
+ (list (map-to-list really-function sequences))
+ ((simple-vector simple-string vector string array simple-array
+ bit-vector simple-bit-vector base-string simple-base-string)
+ #!+high-security
+ (let ((min-length-sequences (get-minimum-length-sequences
+ sequences))
+ (dimensions (array-type-dimensions (specifier-type
+ output-type-spec))))
+ (when (or (/= (length dimensions) 1)
+ (and (not (eq (car dimensions) '*))
+ (/= (car dimensions) min-length-sequences)))
+ (error 'simple-type-error
+ :datum output-type-spec
+ :expected-type
+ (ecase (type-specifier-atom output-type-spec)
+ ((simple-vector bit-vector simple-bit-vector string simple-string base-string)
+ `(,(type-specifier-atom output-type-spec) ,min-length-sequences))
+ ((array vector simple-array) `(,(type-specifier-atom output-type-spec) * ,min-length-sequences)))
+ :format-control "Minimum length of sequences is ~S, this is not compatible with the type ~S."
+ :format-arguments
+ (list min-length-sequences output-type-spec))))
+ (let ((result (map-to-simple output-type-spec
+ really-function
+ sequences)))
+ #!+high-security
+ (check-type-var result output-type-spec)
+ result))
+ (t
+ (apply #'map (result-type-or-lose output-type-spec t)
+ really-function sequences))))))
+
+#!+high-security-support
+(defun map-without-errorchecking
+ (output-type-spec function first-sequence &rest more-sequences)
+ #!+sb-doc
+ "FUNCTION must take as many arguments as there are sequences provided. The
+ result is a sequence such that element i is the result of applying FUNCTION
+ to element I of each of the argument sequences. This version has no
+ error-checking, to pass cold-load."
+ (let ((sequences (cons first-sequence more-sequences)))
+ (case (type-specifier-atom output-type-spec)
+ ((nil) (map-for-effect function sequences))
+ (list (map-to-list function sequences))
+ ((simple-vector simple-string vector string array simple-array
+ bit-vector simple-bit-vector base-string simple-base-string)
+ (map-to-simple output-type-spec function sequences))
+ (t
+ (apply #'map (result-type-or-lose output-type-spec t)
+ function sequences)))))
+
+(defun map-into (result-sequence function &rest sequences)
+ (let* ((fp-result
+ (and (arrayp result-sequence)
+ (array-has-fill-pointer-p result-sequence)))
+ (len (apply #'min
+ (if fp-result
+ (array-dimension result-sequence 0)
+ (length result-sequence))
+ (mapcar #'length sequences))))
+
+ (when fp-result
+ (setf (fill-pointer result-sequence) len))
+
+ (dotimes (index len)
+ (setf (elt result-sequence index)
+ (apply function
+ (mapcar #'(lambda (seq) (elt seq index))
+ sequences)))))
+ result-sequence)
+\f
+;;;; quantifiers
+
+;;; We borrow the logic from (MAP NIL ..) to handle iteration over
+;;; arbitrary sequence arguments, both in the full call case and in
+;;; the open code case.
+(macrolet ((defquantifier (name found-test found-result
+ &key doc (unfound-result (not found-result)))
+ `(progn
+ ;; KLUDGE: It would be really nice if we could simply
+ ;; do something like this
+ ;; (declaim (inline ,name))
+ ;; (defun ,name (pred first-seq &rest more-seqs)
+ ;; ,doc
+ ;; (flet ((map-me (&rest rest)
+ ;; (let ((pred-value (apply pred rest)))
+ ;; (,found-test pred-value
+ ;; (return-from ,name
+ ;; ,found-result)))))
+ ;; (declare (inline map-me))
+ ;; (apply #'map nil #'map-me first-seq more-seqs)
+ ;; ,unfound-result))
+ ;; but Python doesn't seem to be smart enough about
+ ;; inlining and APPLY to recognize that it can use
+ ;; the DEFTRANSFORM for MAP in the resulting inline
+ ;; expansion. I don't have any appetite for deep
+ ;; compiler hacking right now, so I'll just work
+ ;; around the apparent problem by using a compiler
+ ;; macro instead. -- WHN 20000410
+ (defun ,name (pred first-seq &rest more-seqs)
+ #!+sb-doc ,doc
+ (flet ((map-me (&rest rest)
+ (let ((pred-value (apply pred rest)))
+ (,found-test pred-value
+ (return-from ,name
+ ,found-result)))))
+ (declare (inline map-me))
+ (apply #'map nil #'map-me first-seq more-seqs)
+ ,unfound-result))
+ ;; KLUDGE: It would be more obviously correct -- but
+ ;; also significantly messier -- for PRED-VALUE to be
+ ;; a gensym. However, a private symbol really does
+ ;; seem to be good enough; and anyway the really
+ ;; obviously correct solution is to make Python smart
+ ;; enough that we can use an inline function instead
+ ;; of a compiler macro (as above). -- WHN 20000410
+ (define-compiler-macro ,name (pred first-seq &rest more-seqs)
+ (let ((elements (mapcar (lambda (x)
+ (declare (ignore x))
+ (gensym "ARG"))
+ (cons first-seq more-seqs)))
+ (blockname (gensym "BLOCK")))
+ (once-only ((pred pred))
+ `(block ,blockname
+ (map nil
+ (lambda (,@elements)
+ (let ((pred-value (funcall ,pred ,@elements)))
+ (,',found-test pred-value
+ (return-from ,blockname
+ ,',found-result))))
+ ,first-seq
+ ,@more-seqs)
+ ,',unfound-result)))))))
+ (defquantifier some when pred-value :unfound-result nil :doc
+ "PREDICATE is applied to the elements with index 0 of the sequences, then
+ possibly to those with index 1, and so on. SOME returns the first
+ non-NIL value encountered, or NIL if the end of a sequence is reached.")
+ (defquantifier every unless nil :doc
+ "PREDICATE is applied to the elements with index 0 of the sequences, then
+ possibly to those with index 1, and so on. EVERY returns NIL as soon
+ as any invocation of PREDICATE returns NIL, or T if every invocation
+ is non-NIL.")
+ (defquantifier notany when nil :doc
+ "PREDICATE is applied to the elements with index 0 of the sequences, then
+ possibly to those with index 1, and so on. NOTANY returns NIL as soon
+ as any invocation of PREDICATE returns a non-NIL value, or T if the end
+ of a sequence is reached.")
+ (defquantifier notevery unless t :doc
+ "PREDICATE is applied to the elements with index 0 of the sequences, then
+ possibly to those with index 1, and so on. NOTEVERY returns T as soon
+ as any invocation of PREDICATE returns NIL, or NIL if every invocation
+ is non-NIL."))
+\f
+;;;; REDUCE
+
+(eval-when (:compile-toplevel :execute)
+
+(sb!xc:defmacro mumble-reduce (function
+ sequence
+ key
+ start
+ end
+ initial-value
+ ref)
+ `(do ((index ,start (1+ index))
+ (value ,initial-value))
+ ((= index (the fixnum ,end)) value)
+ (declare (fixnum index))
+ (setq value (funcall ,function value
+ (apply-key ,key (,ref ,sequence index))))))
+
+(sb!xc:defmacro mumble-reduce-from-end (function
+ sequence
+ key
+ start
+ end
+ initial-value
+ ref)
+ `(do ((index (1- ,end) (1- index))
+ (value ,initial-value)
+ (terminus (1- ,start)))
+ ((= index terminus) value)
+ (declare (fixnum index terminus))
+ (setq value (funcall ,function
+ (apply-key ,key (,ref ,sequence index))
+ value))))
+
+(sb!xc:defmacro list-reduce (function
+ sequence
+ key
+ start
+ end
+ initial-value
+ ivp)
+ `(let ((sequence (nthcdr ,start ,sequence)))
+ (do ((count (if ,ivp ,start (1+ (the fixnum ,start)))
+ (1+ count))
+ (sequence (if ,ivp sequence (cdr sequence))
+ (cdr sequence))
+ (value (if ,ivp ,initial-value (apply-key ,key (car sequence)))
+ (funcall ,function value (apply-key ,key (car sequence)))))
+ ((= count (the fixnum ,end)) value)
+ (declare (fixnum count)))))
+
+(sb!xc:defmacro list-reduce-from-end (function
+ sequence
+ key
+ start
+ end
+ initial-value
+ ivp)
+ `(let ((sequence (nthcdr (- (the fixnum (length ,sequence))
+ (the fixnum ,end))
+ (reverse ,sequence))))
+ (do ((count (if ,ivp ,start (1+ (the fixnum ,start)))
+ (1+ count))
+ (sequence (if ,ivp sequence (cdr sequence))
+ (cdr sequence))
+ (value (if ,ivp ,initial-value (apply-key ,key (car sequence)))
+ (funcall ,function (apply-key ,key (car sequence)) value)))
+ ((= count (the fixnum ,end)) value)
+ (declare (fixnum count)))))
+
+) ; EVAL-WHEN
+
+(defun reduce (function sequence &key key from-end (start 0)
+ end (initial-value nil ivp))
+ (declare (type index start))
+ (let ((start start)
+ (end (or end (length sequence))))
+ (declare (type index start end))
+ (cond ((= end start)
+ (if ivp initial-value (funcall function)))
+ ((listp sequence)
+ (if from-end
+ (list-reduce-from-end function sequence key start end
+ initial-value ivp)
+ (list-reduce function sequence key start end
+ initial-value ivp)))
+ (from-end
+ (when (not ivp)
+ (setq end (1- (the fixnum end)))
+ (setq initial-value (apply-key key (aref sequence end))))
+ (mumble-reduce-from-end function sequence key start end
+ initial-value aref))
+ (t
+ (when (not ivp)
+ (setq initial-value (apply-key key (aref sequence start)))
+ (setq start (1+ start)))
+ (mumble-reduce function sequence key start end
+ initial-value aref)))))
+\f
+;;;; DELETE
+
+(eval-when (:compile-toplevel :execute)
+
+(sb!xc:defmacro mumble-delete (pred)
+ `(do ((index start (1+ index))
+ (jndex start)
+ (number-zapped 0))
+ ((or (= index (the fixnum end)) (= number-zapped (the fixnum count)))
+ (do ((index index (1+ index)) ; Copy the rest of the vector.
+ (jndex jndex (1+ jndex)))
+ ((= index (the fixnum length))
+ (shrink-vector sequence jndex))
+ (declare (fixnum index jndex))
+ (setf (aref sequence jndex) (aref sequence index))))
+ (declare (fixnum index jndex number-zapped))
+ (setf (aref sequence jndex) (aref sequence index))
+ (if ,pred
+ (setq number-zapped (1+ number-zapped))
+ (setq jndex (1+ jndex)))))
+
+(sb!xc:defmacro mumble-delete-from-end (pred)
+ `(do ((index (1- (the fixnum end)) (1- index)) ; Find the losers.
+ (number-zapped 0)
+ (losers ())
+ this-element
+ (terminus (1- start)))
+ ((or (= index terminus) (= number-zapped (the fixnum count)))
+ (do ((losers losers) ; Delete the losers.
+ (index start (1+ index))
+ (jndex start))
+ ((or (null losers) (= index (the fixnum end)))
+ (do ((index index (1+ index)) ; Copy the rest of the vector.
+ (jndex jndex (1+ jndex)))
+ ((= index (the fixnum length))
+ (shrink-vector sequence jndex))
+ (declare (fixnum index jndex))
+ (setf (aref sequence jndex) (aref sequence index))))
+ (declare (fixnum index jndex))
+ (setf (aref sequence jndex) (aref sequence index))
+ (if (= index (the fixnum (car losers)))
+ (pop losers)
+ (setq jndex (1+ jndex)))))
+ (declare (fixnum index number-zapped terminus))
+ (setq this-element (aref sequence index))
+ (when ,pred
+ (setq number-zapped (1+ number-zapped))
+ (push index losers))))
+
+(sb!xc:defmacro normal-mumble-delete ()
+ `(mumble-delete
+ (if test-not
+ (not (funcall test-not item (apply-key key (aref sequence index))))
+ (funcall test item (apply-key key (aref sequence index))))))
+
+(sb!xc:defmacro normal-mumble-delete-from-end ()
+ `(mumble-delete-from-end
+ (if test-not
+ (not (funcall test-not item (apply-key key this-element)))
+ (funcall test item (apply-key key this-element)))))
+
+(sb!xc:defmacro list-delete (pred)
+ `(let ((handle (cons nil sequence)))
+ (do ((current (nthcdr start sequence) (cdr current))
+ (previous (nthcdr start handle))
+ (index start (1+ index))
+ (number-zapped 0))
+ ((or (= index (the fixnum end)) (= number-zapped (the fixnum count)))
+ (cdr handle))
+ (declare (fixnum index number-zapped))
+ (cond (,pred
+ (rplacd previous (cdr current))
+ (setq number-zapped (1+ number-zapped)))
+ (t
+ (setq previous (cdr previous)))))))
+
+(sb!xc:defmacro list-delete-from-end (pred)
+ `(let* ((reverse (nreverse (the list sequence)))
+ (handle (cons nil reverse)))
+ (do ((current (nthcdr (- (the fixnum length) (the fixnum end)) reverse)
+ (cdr current))
+ (previous (nthcdr (- (the fixnum length) (the fixnum end)) handle))
+ (index start (1+ index))
+ (number-zapped 0))
+ ((or (= index (the fixnum end)) (= number-zapped (the fixnum count)))
+ (nreverse (cdr handle)))
+ (declare (fixnum index number-zapped))
+ (cond (,pred
+ (rplacd previous (cdr current))
+ (setq number-zapped (1+ number-zapped)))
+ (t
+ (setq previous (cdr previous)))))))
+
+(sb!xc:defmacro normal-list-delete ()
+ '(list-delete
+ (if test-not
+ (not (funcall test-not item (apply-key key (car current))))
+ (funcall test item (apply-key key (car current))))))
+
+(sb!xc:defmacro normal-list-delete-from-end ()
+ '(list-delete-from-end
+ (if test-not
+ (not (funcall test-not item (apply-key key (car current))))
+ (funcall test item (apply-key key (car current))))))
+
+) ; EVAL-WHEN
+
+(defun delete (item sequence &key from-end (test #'eql) test-not (start 0)
+ end count key)
+ #!+sb-doc
+ "Returns a sequence formed by destructively removing the specified Item from
+ the given Sequence."
+ (declare (fixnum start))
+ (let* ((length (length sequence))
+ (end (or end length))
+ (count (or count most-positive-fixnum)))
+ (declare (type index length end)
+ (fixnum count))
+ (seq-dispatch sequence
+ (if from-end
+ (normal-list-delete-from-end)
+ (normal-list-delete))
+ (if from-end
+ (normal-mumble-delete-from-end)
+ (normal-mumble-delete)))))
+
+(eval-when (:compile-toplevel :execute)
+
+(sb!xc:defmacro if-mumble-delete ()
+ `(mumble-delete
+ (funcall predicate (apply-key key (aref sequence index)))))
+
+(sb!xc:defmacro if-mumble-delete-from-end ()
+ `(mumble-delete-from-end
+ (funcall predicate (apply-key key this-element))))
+
+(sb!xc:defmacro if-list-delete ()
+ '(list-delete
+ (funcall predicate (apply-key key (car current)))))
+
+(sb!xc:defmacro if-list-delete-from-end ()
+ '(list-delete-from-end
+ (funcall predicate (apply-key key (car current)))))
+
+) ; EVAL-WHEN
+
+(defun delete-if (predicate sequence &key from-end (start 0) key end count)
+ #!+sb-doc
+ "Returns a sequence formed by destructively removing the elements satisfying
+ the specified Predicate from the given Sequence."
+ (declare (fixnum start))
+ (let* ((length (length sequence))
+ (end (or end length))
+ (count (or count most-positive-fixnum)))
+ (declare (type index length end)
+ (fixnum count))
+ (seq-dispatch sequence
+ (if from-end
+ (if-list-delete-from-end)
+ (if-list-delete))
+ (if from-end
+ (if-mumble-delete-from-end)
+ (if-mumble-delete)))))
+
+(eval-when (:compile-toplevel :execute)
+
+(sb!xc:defmacro if-not-mumble-delete ()
+ `(mumble-delete
+ (not (funcall predicate (apply-key key (aref sequence index))))))
+
+(sb!xc:defmacro if-not-mumble-delete-from-end ()
+ `(mumble-delete-from-end
+ (not (funcall predicate (apply-key key this-element)))))
+
+(sb!xc:defmacro if-not-list-delete ()
+ '(list-delete
+ (not (funcall predicate (apply-key key (car current))))))
+
+(sb!xc:defmacro if-not-list-delete-from-end ()
+ '(list-delete-from-end
+ (not (funcall predicate (apply-key key (car current))))))
+
+) ; EVAL-WHEN
+
+(defun delete-if-not (predicate sequence &key from-end (start 0) end key count)
+ #!+sb-doc
+ "Returns a sequence formed by destructively removing the elements not
+ satisfying the specified Predicate from the given Sequence."
+ (declare (fixnum start))
+ (let* ((length (length sequence))
+ (end (or end length))
+ (count (or count most-positive-fixnum)))
+ (declare (type index length end)
+ (fixnum count))
+ (seq-dispatch sequence
+ (if from-end
+ (if-not-list-delete-from-end)
+ (if-not-list-delete))
+ (if from-end
+ (if-not-mumble-delete-from-end)
+ (if-not-mumble-delete)))))
+\f
+;;;; REMOVE
+
+(eval-when (:compile-toplevel :execute)
+
+;;; MUMBLE-REMOVE-MACRO does not include (removes) each element that
+;;; satisfies the predicate.
+(sb!xc:defmacro mumble-remove-macro (bump left begin finish right pred)
+ `(do ((index ,begin (,bump index))
+ (result
+ (do ((index ,left (,bump index))
+ (result (make-sequence-like sequence length)))
+ ((= index (the fixnum ,begin)) result)
+ (declare (fixnum index))
+ (setf (aref result index) (aref sequence index))))
+ (new-index ,begin)
+ (number-zapped 0)
+ (this-element))
+ ((or (= index (the fixnum ,finish))
+ (= number-zapped (the fixnum count)))
+ (do ((index index (,bump index))
+ (new-index new-index (,bump new-index)))
+ ((= index (the fixnum ,right)) (shrink-vector result new-index))
+ (declare (fixnum index new-index))
+ (setf (aref result new-index) (aref sequence index))))
+ (declare (fixnum index new-index number-zapped))
+ (setq this-element (aref sequence index))
+ (cond (,pred (setq number-zapped (1+ number-zapped)))
+ (t (setf (aref result new-index) this-element)
+ (setq new-index (,bump new-index))))))
+
+(sb!xc:defmacro mumble-remove (pred)
+ `(mumble-remove-macro 1+ 0 start end length ,pred))
+
+(sb!xc:defmacro mumble-remove-from-end (pred)
+ `(let ((sequence (copy-seq sequence)))
+ (mumble-delete-from-end ,pred)))
+
+(sb!xc:defmacro normal-mumble-remove ()
+ `(mumble-remove
+ (if test-not
+ (not (funcall test-not item (apply-key key this-element)))
+ (funcall test item (apply-key key this-element)))))
+
+(sb!xc:defmacro normal-mumble-remove-from-end ()
+ `(mumble-remove-from-end
+ (if test-not
+ (not (funcall test-not item (apply-key key this-element)))
+ (funcall test item (apply-key key this-element)))))
+
+(sb!xc:defmacro if-mumble-remove ()
+ `(mumble-remove (funcall predicate (apply-key key this-element))))
+
+(sb!xc:defmacro if-mumble-remove-from-end ()
+ `(mumble-remove-from-end (funcall predicate (apply-key key this-element))))
+
+(sb!xc:defmacro if-not-mumble-remove ()
+ `(mumble-remove (not (funcall predicate (apply-key key this-element)))))
+
+(sb!xc:defmacro if-not-mumble-remove-from-end ()
+ `(mumble-remove-from-end
+ (not (funcall predicate (apply-key key this-element)))))
+
+;;; LIST-REMOVE-MACRO does not include (removes) each element that satisfies
+;;; the predicate.
+(sb!xc:defmacro list-remove-macro (pred reverse?)
+ `(let* ((sequence ,(if reverse?
+ '(reverse (the list sequence))
+ 'sequence))
+ (splice (list nil))
+ (results (do ((index 0 (1+ index))
+ (before-start splice))
+ ((= index (the fixnum start)) before-start)
+ (declare (fixnum index))
+ (setq splice
+ (cdr (rplacd splice (list (pop sequence))))))))
+ (do ((index start (1+ index))
+ (this-element)
+ (number-zapped 0))
+ ((or (= index (the fixnum end)) (= number-zapped (the fixnum count)))
+ (do ((index index (1+ index)))
+ ((null sequence)
+ ,(if reverse?
+ '(nreverse (the list (cdr results)))
+ '(cdr results)))
+ (declare (fixnum index))
+ (setq splice (cdr (rplacd splice (list (pop sequence)))))))
+ (declare (fixnum index number-zapped))
+ (setq this-element (pop sequence))
+ (if ,pred
+ (setq number-zapped (1+ number-zapped))
+ (setq splice (cdr (rplacd splice (list this-element))))))))
+
+(sb!xc:defmacro list-remove (pred)
+ `(list-remove-macro ,pred nil))
+
+(sb!xc:defmacro list-remove-from-end (pred)
+ `(list-remove-macro ,pred t))
+
+(sb!xc:defmacro normal-list-remove ()
+ `(list-remove
+ (if test-not
+ (not (funcall test-not item (apply-key key this-element)))
+ (funcall test item (apply-key key this-element)))))
+
+(sb!xc:defmacro normal-list-remove-from-end ()
+ `(list-remove-from-end
+ (if test-not
+ (not (funcall test-not item (apply-key key this-element)))
+ (funcall test item (apply-key key this-element)))))
+
+(sb!xc:defmacro if-list-remove ()
+ `(list-remove
+ (funcall predicate (apply-key key this-element))))
+
+(sb!xc:defmacro if-list-remove-from-end ()
+ `(list-remove-from-end
+ (funcall predicate (apply-key key this-element))))
+
+(sb!xc:defmacro if-not-list-remove ()
+ `(list-remove
+ (not (funcall predicate (apply-key key this-element)))))
+
+(sb!xc:defmacro if-not-list-remove-from-end ()
+ `(list-remove-from-end
+ (not (funcall predicate (apply-key key this-element)))))
+
+) ; EVAL-WHEN
+
+(defun remove (item sequence &key from-end (test #'eql) test-not (start 0)
+ end count key)
+ #!+sb-doc
+ "Returns a copy of SEQUENCE with elements satisfying the test (default is
+ EQL) with ITEM removed."
+ (declare (fixnum start))
+ (let* ((length (length sequence))
+ (end (or end length))
+ (count (or count most-positive-fixnum)))
+ (declare (type index length end)
+ (fixnum count))
+ (seq-dispatch sequence
+ (if from-end
+ (normal-list-remove-from-end)
+ (normal-list-remove))
+ (if from-end
+ (normal-mumble-remove-from-end)
+ (normal-mumble-remove)))))
+
+(defun remove-if (predicate sequence &key from-end (start 0) end count key)
+ #!+sb-doc
+ "Returns a copy of sequence with elements such that predicate(element)
+ is non-null are removed"
+ (declare (fixnum start))
+ (let* ((length (length sequence))
+ (end (or end length))
+ (count (or count most-positive-fixnum)))
+ (declare (type index length end)
+ (fixnum count))
+ (seq-dispatch sequence
+ (if from-end
+ (if-list-remove-from-end)
+ (if-list-remove))
+ (if from-end
+ (if-mumble-remove-from-end)
+ (if-mumble-remove)))))
+
+(defun remove-if-not (predicate sequence &key from-end (start 0) end count key)
+ #!+sb-doc
+ "Returns a copy of sequence with elements such that predicate(element)
+ is null are removed"
+ (declare (fixnum start))
+ (let* ((length (length sequence))
+ (end (or end length))
+ (count (or count most-positive-fixnum)))
+ (declare (type index length end)
+ (fixnum count))
+ (seq-dispatch sequence
+ (if from-end
+ (if-not-list-remove-from-end)
+ (if-not-list-remove))
+ (if from-end
+ (if-not-mumble-remove-from-end)
+ (if-not-mumble-remove)))))
+\f
+;;;; REMOVE-DUPLICATES
+
+;;; Remove duplicates from a list. If from-end, remove the later duplicates,
+;;; not the earlier ones. Thus if we check from-end we don't copy an item
+;;; if we look into the already copied structure (from after :start) and see
+;;; the item. If we check from beginning we check into the rest of the
+;;; original list up to the :end marker (this we have to do by running a
+;;; do loop down the list that far and using our test.
+(defun list-remove-duplicates* (list test test-not start end key from-end)
+ (declare (fixnum start))
+ (let* ((result (list ())) ; Put a marker on the beginning to splice with.
+ (splice result)
+ (current list))
+ (do ((index 0 (1+ index)))
+ ((= index start))
+ (declare (fixnum index))
+ (setq splice (cdr (rplacd splice (list (car current)))))
+ (setq current (cdr current)))
+ (do ((index 0 (1+ index)))
+ ((or (and end (= index (the fixnum end)))
+ (atom current)))
+ (declare (fixnum index))
+ (if (or (and from-end
+ (not (member (apply-key key (car current))
+ (nthcdr (1+ start) result)
+ :test test
+ :test-not test-not
+ :key key)))
+ (and (not from-end)
+ (not (do ((it (apply-key key (car current)))
+ (l (cdr current) (cdr l))
+ (i (1+ index) (1+ i)))
+ ((or (atom l) (and end (= i (the fixnum end))))
+ ())
+ (declare (fixnum i))
+ (if (if test-not
+ (not (funcall test-not it (apply-key key (car l))))
+ (funcall test it (apply-key key (car l))))
+ (return t))))))
+ (setq splice (cdr (rplacd splice (list (car current))))))
+ (setq current (cdr current)))
+ (do ()
+ ((atom current))
+ (setq splice (cdr (rplacd splice (list (car current)))))
+ (setq current (cdr current)))
+ (cdr result)))
+
+(defun vector-remove-duplicates* (vector test test-not start end key from-end
+ &optional (length (length vector)))
+ (declare (vector vector) (fixnum start length))
+ (when (null end) (setf end (length vector)))
+ (let ((result (make-sequence-like vector length))
+ (index 0)
+ (jndex start))
+ (declare (fixnum index jndex))
+ (do ()
+ ((= index start))
+ (setf (aref result index) (aref vector index))
+ (setq index (1+ index)))
+ (do ((elt))
+ ((= index end))
+ (setq elt (aref vector index))
+ (unless (or (and from-end
+ (position (apply-key key elt) result :start start
+ :end jndex :test test :test-not test-not :key key))
+ (and (not from-end)
+ (position (apply-key key elt) vector :start (1+ index)
+ :end end :test test :test-not test-not :key key)))
+ (setf (aref result jndex) elt)
+ (setq jndex (1+ jndex)))
+ (setq index (1+ index)))
+ (do ()
+ ((= index length))
+ (setf (aref result jndex) (aref vector index))
+ (setq index (1+ index))
+ (setq jndex (1+ jndex)))
+ (shrink-vector result jndex)))
+
+(defun remove-duplicates (sequence &key
+ (test #'eql)
+ test-not
+ (start 0)
+ from-end
+ end
+ key)
+ #!+sb-doc
+ "The elements of Sequence are compared pairwise, and if any two match,
+ the one occurring earlier is discarded, unless FROM-END is true, in
+ which case the one later in the sequence is discarded. The resulting
+ sequence is returned.
+
+ The :TEST-NOT argument is depreciated."
+ (declare (fixnum start))
+ (seq-dispatch sequence
+ (if sequence
+ (list-remove-duplicates* sequence test test-not
+ start end key from-end))
+ (vector-remove-duplicates* sequence test test-not
+ start end key from-end)))
+\f
+;;;; DELETE-DUPLICATES
+
+(defun list-delete-duplicates* (list test test-not key from-end start end)
+ (declare (fixnum start))
+ (let ((handle (cons nil list)))
+ (do ((current (nthcdr start list) (cdr current))
+ (previous (nthcdr start handle))
+ (index start (1+ index)))
+ ((or (and end (= index (the fixnum end))) (null current))
+ (cdr handle))
+ (declare (fixnum index))
+ (if (do ((x (if from-end
+ (nthcdr (1+ start) handle)
+ (cdr current))
+ (cdr x))
+ (i (1+ index) (1+ i)))
+ ((or (null x)
+ (and (not from-end) end (= i (the fixnum end)))
+ (eq x current))
+ nil)
+ (declare (fixnum i))
+ (if (if test-not
+ (not (funcall test-not
+ (apply-key key (car current))
+ (apply-key key (car x))))
+ (funcall test
+ (apply-key key (car current))
+ (apply-key key (car x))))
+ (return t)))
+ (rplacd previous (cdr current))
+ (setq previous (cdr previous))))))
+
+(defun vector-delete-duplicates* (vector test test-not key from-end start end
+ &optional (length (length vector)))
+ (declare (vector vector) (fixnum start length))
+ (when (null end) (setf end (length vector)))
+ (do ((index start (1+ index))
+ (jndex start))
+ ((= index end)
+ (do ((index index (1+ index)) ; copy the rest of the vector
+ (jndex jndex (1+ jndex)))
+ ((= index length)
+ (shrink-vector vector jndex)
+ vector)
+ (setf (aref vector jndex) (aref vector index))))
+ (declare (fixnum index jndex))
+ (setf (aref vector jndex) (aref vector index))
+ (unless (position (apply-key key (aref vector index)) vector :key key
+ :start (if from-end start (1+ index)) :test test
+ :end (if from-end jndex end) :test-not test-not)
+ (setq jndex (1+ jndex)))))
+
+(defun delete-duplicates (sequence &key
+ (test #'eql)
+ test-not
+ (start 0)
+ from-end
+ end
+ key)
+ #!+sb-doc
+ "The elements of Sequence are examined, and if any two match, one is
+ discarded. The resulting sequence, which may be formed by destroying the
+ given sequence, is returned.
+
+ The :TEST-NOT argument is depreciated."
+ (seq-dispatch sequence
+ (if sequence
+ (list-delete-duplicates* sequence test test-not key from-end start end))
+ (vector-delete-duplicates* sequence test test-not key from-end start end)))
+\f
+;;;; SUBSTITUTE
+
+(defun list-substitute* (pred new list start end count key test test-not old)
+ (declare (fixnum start end count))
+ (let* ((result (list nil))
+ elt
+ (splice result)
+ (list list)) ; Get a local list for a stepper.
+ (do ((index 0 (1+ index)))
+ ((= index start))
+ (declare (fixnum index))
+ (setq splice (cdr (rplacd splice (list (car list)))))
+ (setq list (cdr list)))
+ (do ((index start (1+ index)))
+ ((or (= index end) (null list) (= count 0)))
+ (declare (fixnum index))
+ (setq elt (car list))
+ (setq splice
+ (cdr (rplacd splice
+ (list
+ (cond
+ ((case pred
+ (normal
+ (if test-not
+ (not
+ (funcall test-not old (apply-key key elt)))
+ (funcall test old (apply-key key elt))))
+ (if (funcall test (apply-key key elt)))
+ (if-not (not (funcall test (apply-key key elt)))))
+ (setq count (1- count))
+ new)
+ (t elt))))))
+ (setq list (cdr list)))
+ (do ()
+ ((null list))
+ (setq splice (cdr (rplacd splice (list (car list)))))
+ (setq list (cdr list)))
+ (cdr result)))
+
+;;; Replace old with new in sequence moving from left to right by incrementer
+;;; on each pass through the loop. Called by all three substitute functions.
+(defun vector-substitute* (pred new sequence incrementer left right length
+ start end count key test test-not old)
+ (declare (fixnum start count end incrementer right))
+ (let ((result (make-sequence-like sequence length))
+ (index left))
+ (declare (fixnum index))
+ (do ()
+ ((= index start))
+ (setf (aref result index) (aref sequence index))
+ (setq index (+ index incrementer)))
+ (do ((elt))
+ ((or (= index end) (= count 0)))
+ (setq elt (aref sequence index))
+ (setf (aref result index)
+ (cond ((case pred
+ (normal
+ (if test-not
+ (not (funcall test-not old (apply-key key elt)))
+ (funcall test old (apply-key key elt))))
+ (if (funcall test (apply-key key elt)))
+ (if-not (not (funcall test (apply-key key elt)))))
+ (setq count (1- count))
+ new)
+ (t elt)))
+ (setq index (+ index incrementer)))
+ (do ()
+ ((= index right))
+ (setf (aref result index) (aref sequence index))
+ (setq index (+ index incrementer)))
+ result))
+
+(eval-when (:compile-toplevel :execute)
+
+(sb!xc:defmacro subst-dispatch (pred)
+ `(if (listp sequence)
+ (if from-end
+ (nreverse (list-substitute* ,pred
+ new
+ (reverse sequence)
+ (- (the fixnum length)
+ (the fixnum end))
+ (- (the fixnum length)
+ (the fixnum start))
+ count key test test-not old))
+ (list-substitute* ,pred
+ new sequence start end count key test test-not
+ old))
+ (if from-end
+ (vector-substitute* ,pred new sequence -1 (1- (the fixnum length))
+ -1 length (1- (the fixnum end))
+ (1- (the fixnum start))
+ count key test test-not old)
+ (vector-substitute* ,pred new sequence 1 0 length length
+ start end count key test test-not old))))
+
+) ; EVAL-WHEN
+
+(defun substitute (new old sequence &key from-end (test #'eql) test-not
+ (start 0) count end key)
+ #!+sb-doc
+ "Returns a sequence of the same kind as Sequence with the same elements
+ except that all elements equal to Old are replaced with New. See manual
+ for details."
+ (declare (fixnum start))
+ (let* ((length (length sequence))
+ (end (or end length))
+ (count (or count most-positive-fixnum)))
+ (declare (type index length end)
+ (fixnum count))
+ (subst-dispatch 'normal)))
+\f
+;;;; SUBSTITUTE-IF, SUBSTITUTE-IF-NOT
+
+(defun substitute-if (new test sequence &key from-end (start 0) end count key)
+ #!+sb-doc
+ "Returns a sequence of the same kind as Sequence with the same elements
+ except that all elements satisfying the Test are replaced with New. See
+ manual for details."
+ (declare (fixnum start))
+ (let* ((length (length sequence))
+ (end (or end length))
+ (count (or count most-positive-fixnum))
+ test-not
+ old)
+ (declare (type index length end)
+ (fixnum count))
+ (subst-dispatch 'if)))
+
+(defun substitute-if-not (new test sequence &key from-end (start 0)
+ end count key)
+ #!+sb-doc
+ "Returns a sequence of the same kind as Sequence with the same elements
+ except that all elements not satisfying the Test are replaced with New.
+ See manual for details."
+ (declare (fixnum start))
+ (let* ((length (length sequence))
+ (end (or end length))
+ (count (or count most-positive-fixnum))
+ test-not
+ old)
+ (declare (type index length end)
+ (fixnum count))
+ (subst-dispatch 'if-not)))
+\f
+;;;; NSUBSTITUTE
+
+(defun nsubstitute (new old sequence &key from-end (test #'eql) test-not
+ end count key (start 0))
+ #!+sb-doc
+ "Returns a sequence of the same kind as Sequence with the same elements
+ except that all elements equal to Old are replaced with New. The Sequence
+ may be destroyed. See manual for details."
+ (declare (fixnum start))
+ (let ((end (or end (length sequence)))
+ (count (or count most-positive-fixnum)))
+ (declare (fixnum count))
+ (if (listp sequence)
+ (if from-end
+ (nreverse (nlist-substitute*
+ new old (nreverse (the list sequence))
+ test test-not start end count key))
+ (nlist-substitute* new old sequence
+ test test-not start end count key))
+ (if from-end
+ (nvector-substitute* new old sequence -1
+ test test-not (1- end) (1- start) count key)
+ (nvector-substitute* new old sequence 1
+ test test-not start end count key)))))
+
+(defun nlist-substitute* (new old sequence test test-not start end count key)
+ (declare (fixnum start count end))
+ (do ((list (nthcdr start sequence) (cdr list))
+ (index start (1+ index)))
+ ((or (= index end) (null list) (= count 0)) sequence)
+ (declare (fixnum index))
+ (when (if test-not
+ (not (funcall test-not old (apply-key key (car list))))
+ (funcall test old (apply-key key (car list))))
+ (rplaca list new)
+ (setq count (1- count)))))
+
+(defun nvector-substitute* (new old sequence incrementer
+ test test-not start end count key)
+ (declare (fixnum start incrementer count end))
+ (do ((index start (+ index incrementer)))
+ ((or (= index end) (= count 0)) sequence)
+ (declare (fixnum index))
+ (when (if test-not
+ (not (funcall test-not
+ old
+ (apply-key key (aref sequence index))))
+ (funcall test old (apply-key key (aref sequence index))))
+ (setf (aref sequence index) new)
+ (setq count (1- count)))))
+\f
+;;;; NSUBSTITUTE-IF, NSUBSTITUTE-IF-NOT
+
+(defun nsubstitute-if (new test sequence &key from-end (start 0) end count key)
+ #!+sb-doc
+ "Returns a sequence of the same kind as Sequence with the same elements
+ except that all elements satisfying the Test are replaced with New. The
+ Sequence may be destroyed. See manual for details."
+ (declare (fixnum start))
+ (let ((end (or end (length sequence)))
+ (count (or count most-positive-fixnum)))
+ (declare (fixnum end count))
+ (if (listp sequence)
+ (if from-end
+ (nreverse (nlist-substitute-if*
+ new test (nreverse (the list sequence))
+ start end count key))
+ (nlist-substitute-if* new test sequence
+ start end count key))
+ (if from-end
+ (nvector-substitute-if* new test sequence -1
+ (1- end) (1- start) count key)
+ (nvector-substitute-if* new test sequence 1
+ start end count key)))))
+
+(defun nlist-substitute-if* (new test sequence start end count key)
+ (declare (fixnum end))
+ (do ((list (nthcdr start sequence) (cdr list))
+ (index start (1+ index)))
+ ((or (= index end) (null list) (= count 0)) sequence)
+ (when (funcall test (apply-key key (car list)))
+ (rplaca list new)
+ (setq count (1- count)))))
+
+(defun nvector-substitute-if* (new test sequence incrementer
+ start end count key)
+ (do ((index start (+ index incrementer)))
+ ((or (= index end) (= count 0)) sequence)
+ (when (funcall test (apply-key key (aref sequence index)))
+ (setf (aref sequence index) new)
+ (setq count (1- count)))))
+
+(defun nsubstitute-if-not (new test sequence &key from-end (start 0)
+ end count key)
+ #!+sb-doc
+ "Returns a sequence of the same kind as Sequence with the same elements
+ except that all elements not satisfying the Test are replaced with New.
+ The Sequence may be destroyed. See manual for details."
+ (declare (fixnum start))
+ (let ((end (or end (length sequence)))
+ (count (or count most-positive-fixnum)))
+ (declare (fixnum end count))
+ (if (listp sequence)
+ (if from-end
+ (nreverse (nlist-substitute-if-not*
+ new test (nreverse (the list sequence))
+ start end count key))
+ (nlist-substitute-if-not* new test sequence
+ start end count key))
+ (if from-end
+ (nvector-substitute-if-not* new test sequence -1
+ (1- end) (1- start) count key)
+ (nvector-substitute-if-not* new test sequence 1
+ start end count key)))))
+
+(defun nlist-substitute-if-not* (new test sequence start end count key)
+ (declare (fixnum end))
+ (do ((list (nthcdr start sequence) (cdr list))
+ (index start (1+ index)))
+ ((or (= index end) (null list) (= count 0)) sequence)
+ (when (not (funcall test (apply-key key (car list))))
+ (rplaca list new)
+ (setq count (1- count)))))
+
+(defun nvector-substitute-if-not* (new test sequence incrementer
+ start end count key)
+ (do ((index start (+ index incrementer)))
+ ((or (= index end) (= count 0)) sequence)
+ (when (not (funcall test (apply-key key (aref sequence index))))
+ (setf (aref sequence index) new)
+ (setq count (1- count)))))
+\f
+;;; locater macros used by FIND and POSITION
+
+(eval-when (:compile-toplevel :execute)
+
+(sb!xc:defmacro vector-locater-macro (sequence body-form return-type)
+ `(let ((incrementer (if from-end -1 1))
+ (start (if from-end (1- (the fixnum end)) start))
+ (end (if from-end (1- (the fixnum start)) end)))
+ (declare (fixnum start end incrementer))
+ (do ((index start (+ index incrementer))
+ ,@(case return-type (:position nil) (:element '(current))))
+ ((= index end) ())
+ (declare (fixnum index))
+ ,@(case return-type
+ (:position nil)
+ (:element `((setf current (aref ,sequence index)))))
+ ,body-form)))
+
+(sb!xc:defmacro locater-test-not (item sequence seq-type return-type)
+ (let ((seq-ref (case return-type
+ (:position
+ (case seq-type
+ (:vector `(aref ,sequence index))
+ (:list `(pop ,sequence))))
+ (:element 'current)))
+ (return (case return-type
+ (:position 'index)
+ (:element 'current))))
+ `(if test-not
+ (if (not (funcall test-not ,item (apply-key key ,seq-ref)))
+ (return ,return))
+ (if (funcall test ,item (apply-key key ,seq-ref))
+ (return ,return)))))
+
+(sb!xc:defmacro vector-locater (item sequence return-type)
+ `(vector-locater-macro ,sequence
+ (locater-test-not ,item ,sequence :vector ,return-type)
+ ,return-type))
+\f
+(sb!xc:defmacro locater-if-test (test sequence seq-type return-type sense)
+ (let ((seq-ref (case return-type
+ (:position
+ (case seq-type
+ (:vector `(aref ,sequence index))
+ (:list `(pop ,sequence))))
+ (:element 'current)))
+ (return (case return-type
+ (:position 'index)
+ (:element 'current))))
+ (if sense
+ `(if (funcall ,test (apply-key key ,seq-ref))
+ (return ,return))
+ `(if (not (funcall ,test (apply-key key ,seq-ref)))
+ (return ,return)))))
+
+(sb!xc:defmacro vector-locater-if-macro (test sequence return-type sense)
+ `(vector-locater-macro ,sequence
+ (locater-if-test ,test ,sequence :vector ,return-type ,sense)
+ ,return-type))
+
+(sb!xc:defmacro vector-locater-if (test sequence return-type)
+ `(vector-locater-if-macro ,test ,sequence ,return-type t))
+
+(sb!xc:defmacro vector-locater-if-not (test sequence return-type)
+ `(vector-locater-if-macro ,test ,sequence ,return-type nil))
+\f
+(sb!xc:defmacro list-locater-macro (sequence body-form return-type)
+ `(if from-end
+ (do ((sequence (nthcdr (- (the fixnum (length sequence))
+ (the fixnum end))
+ (reverse (the list ,sequence))))
+ (index (1- (the fixnum end)) (1- index))
+ (terminus (1- (the fixnum start)))
+ ,@(case return-type (:position nil) (:element '(current))))
+ ((or (= index terminus) (null sequence)) ())
+ (declare (fixnum index terminus))
+ ,@(case return-type
+ (:position nil)
+ (:element `((setf current (pop ,sequence)))))
+ ,body-form)
+ (do ((sequence (nthcdr start ,sequence))
+ (index start (1+ index))
+ ,@(case return-type (:position nil) (:element '(current))))
+ ((or (= index (the fixnum end)) (null sequence)) ())
+ (declare (fixnum index))
+ ,@(case return-type
+ (:position nil)
+ (:element `((setf current (pop ,sequence)))))
+ ,body-form)))
+
+(sb!xc:defmacro list-locater (item sequence return-type)
+ `(list-locater-macro ,sequence
+ (locater-test-not ,item ,sequence :list ,return-type)
+ ,return-type))
+
+(sb!xc:defmacro list-locater-if-macro (test sequence return-type sense)
+ `(list-locater-macro ,sequence
+ (locater-if-test ,test ,sequence :list ,return-type ,sense)
+ ,return-type))
+
+(sb!xc:defmacro list-locater-if (test sequence return-type)
+ `(list-locater-if-macro ,test ,sequence ,return-type t))
+
+(sb!xc:defmacro list-locater-if-not (test sequence return-type)
+ `(list-locater-if-macro ,test ,sequence ,return-type nil))
+
+) ; EVAL-WHEN
+\f
+;;; POSITION
+
+(eval-when (:compile-toplevel :execute)
+
+(sb!xc:defmacro vector-position (item sequence)
+ `(vector-locater ,item ,sequence :position))
+
+(sb!xc:defmacro list-position (item sequence)
+ `(list-locater ,item ,sequence :position))
+
+) ; EVAL-WHEN
+
+;;; POSITION cannot default end to the length of sequence since it is not
+;;; an error to supply nil for its value. We must test for end being nil
+;;; in the body of the function, and this is actually done in the support
+;;; routines for other reasons (see below).
+(defun position (item sequence &key from-end (test #'eql) test-not (start 0)
+ end key)
+ #!+sb-doc
+ "Returns the zero-origin index of the first element in SEQUENCE
+ satisfying the test (default is EQL) with the given ITEM"
+ (seq-dispatch sequence
+ (list-position* item sequence from-end test test-not start end key)
+ (vector-position* item sequence from-end test test-not start end key)))
+
+;;; The support routines for SUBSEQ are used by compiler transforms, so we
+;;; worry about dealing with END being supplied or defaulting to NIL
+;;; at this level.
+
+(defun list-position* (item sequence from-end test test-not start end key)
+ (declare (fixnum start))
+ (when (null end) (setf end (length sequence)))
+ (list-position item sequence))
+
+(defun vector-position* (item sequence from-end test test-not start end key)
+ (declare (fixnum start))
+ (when (null end) (setf end (length sequence)))
+ (vector-position item sequence))
+\f
+;;;; POSITION-IF
+
+(eval-when (:compile-toplevel :execute)
+
+(sb!xc:defmacro vector-position-if (test sequence)
+ `(vector-locater-if ,test ,sequence :position))
+
+(sb!xc:defmacro list-position-if (test sequence)
+ `(list-locater-if ,test ,sequence :position))
+
+) ; EVAL-WHEN
+
+(defun position-if (test sequence &key from-end (start 0) key end)
+ #!+sb-doc
+ "Returns the zero-origin index of the first element satisfying test(el)"
+ (declare (fixnum start))
+ (let ((end (or end (length sequence))))
+ (declare (type index end))
+ (seq-dispatch sequence
+ (list-position-if test sequence)
+ (vector-position-if test sequence))))
+\f
+;;;; POSITION-IF-NOT
+
+(eval-when (:compile-toplevel :execute)
+
+(sb!xc:defmacro vector-position-if-not (test sequence)
+ `(vector-locater-if-not ,test ,sequence :position))
+
+(sb!xc:defmacro list-position-if-not (test sequence)
+ `(list-locater-if-not ,test ,sequence :position))
+
+) ; EVAL-WHEN
+
+(defun position-if-not (test sequence &key from-end (start 0) key end)
+ #!+sb-doc
+ "Returns the zero-origin index of the first element not satisfying test(el)"
+ (declare (fixnum start))
+ (let ((end (or end (length sequence))))
+ (declare (type index end))
+ (seq-dispatch sequence
+ (list-position-if-not test sequence)
+ (vector-position-if-not test sequence))))
+\f
+;;;; FIND
+
+(eval-when (:compile-toplevel :execute)
+
+(sb!xc:defmacro vector-find (item sequence)
+ `(vector-locater ,item ,sequence :element))
+
+(sb!xc:defmacro list-find (item sequence)
+ `(list-locater ,item ,sequence :element))
+
+) ; EVAL-WHEN
+
+;;; Note: FIND cannot default end to the length of sequence since it
+;;; is not an error to supply NIL for its value. We must test for end
+;;; being NIL in the body of the function, and this is actually done
+;;; in the support routines for other reasons (see above).
+(defun find (item sequence &key from-end (test #'eql) test-not (start 0)
+ end key)
+ #!+sb-doc
+ "Returns the first element in SEQUENCE satisfying the test (default
+ is EQL) with the given ITEM"
+ (declare (fixnum start))
+ (seq-dispatch sequence
+ (list-find* item sequence from-end test test-not start end key)
+ (vector-find* item sequence from-end test test-not start end key)))
+
+;;; The support routines for FIND are used by compiler transforms, so we
+;;; worry about dealing with END being supplied or defaulting to NIL
+;;; at this level.
+
+(defun list-find* (item sequence from-end test test-not start end key)
+ (when (null end) (setf end (length sequence)))
+ (list-find item sequence))
+
+(defun vector-find* (item sequence from-end test test-not start end key)
+ (when (null end) (setf end (length sequence)))
+ (vector-find item sequence))
+\f
+;;;; FIND-IF and FIND-IF-NOT
+
+(eval-when (:compile-toplevel :execute)
+
+(sb!xc:defmacro vector-find-if (test sequence)
+ `(vector-locater-if ,test ,sequence :element))
+
+(sb!xc:defmacro list-find-if (test sequence)
+ `(list-locater-if ,test ,sequence :element))
+
+) ; EVAL-WHEN
+
+(defun find-if (test sequence &key from-end (start 0) end key)
+ #!+sb-doc
+ "Returns the zero-origin index of the first element satisfying the test."
+ (declare (fixnum start))
+ (let ((end (or end (length sequence))))
+ (declare (type index end))
+ (seq-dispatch sequence
+ (list-find-if test sequence)
+ (vector-find-if test sequence))))
+
+(eval-when (:compile-toplevel :execute)
+
+(sb!xc:defmacro vector-find-if-not (test sequence)
+ `(vector-locater-if-not ,test ,sequence :element))
+
+(sb!xc:defmacro list-find-if-not (test sequence)
+ `(list-locater-if-not ,test ,sequence :element))
+
+) ; EVAL-WHEN
+
+(defun find-if-not (test sequence &key from-end (start 0) end key)
+ #!+sb-doc
+ "Returns the zero-origin index of the first element not satisfying the test."
+ (declare (fixnum start))
+ (let ((end (or end (length sequence))))
+ (declare (type index end))
+ (seq-dispatch sequence
+ (list-find-if-not test sequence)
+ (vector-find-if-not test sequence))))
+\f
+;;;; COUNT
+
+(eval-when (:compile-toplevel :execute)
+
+(sb!xc:defmacro vector-count (item sequence)
+ `(do ((index start (1+ index))
+ (count 0))
+ ((= index (the fixnum end)) count)
+ (declare (fixnum index count))
+ (if test-not
+ (unless (funcall test-not ,item
+ (apply-key key (aref ,sequence index)))
+ (setq count (1+ count)))
+ (when (funcall test ,item (apply-key key (aref ,sequence index)))
+ (setq count (1+ count))))))
+
+(sb!xc:defmacro list-count (item sequence)
+ `(do ((sequence (nthcdr start ,sequence))
+ (index start (1+ index))
+ (count 0))
+ ((or (= index (the fixnum end)) (null sequence)) count)
+ (declare (fixnum index count))
+ (if test-not
+ (unless (funcall test-not ,item (apply-key key (pop sequence)))
+ (setq count (1+ count)))
+ (when (funcall test ,item (apply-key key (pop sequence)))
+ (setq count (1+ count))))))
+
+) ; EVAL-WHEN
+
+(defun count (item sequence &key from-end (test #'eql) test-not (start 0)
+ end key)
+ #!+sb-doc
+ "Returns the number of elements in SEQUENCE satisfying a test with ITEM,
+ which defaults to EQL."
+ (declare (ignore from-end) (fixnum start))
+ (let ((end (or end (length sequence))))
+ (declare (type index end))
+ (seq-dispatch sequence
+ (list-count item sequence)
+ (vector-count item sequence))))
+\f
+;;;; COUNT-IF and COUNT-IF-NOT
+
+(eval-when (:compile-toplevel :execute)
+
+(sb!xc:defmacro vector-count-if (predicate sequence)
+ `(do ((index start (1+ index))
+ (count 0))
+ ((= index (the fixnum end)) count)
+ (declare (fixnum index count))
+ (if (funcall ,predicate (apply-key key (aref ,sequence index)))
+ (setq count (1+ count)))))
+
+(sb!xc:defmacro list-count-if (predicate sequence)
+ `(do ((sequence (nthcdr start ,sequence))
+ (index start (1+ index))
+ (count 0))
+ ((or (= index (the fixnum end)) (null sequence)) count)
+ (declare (fixnum index count))
+ (if (funcall ,predicate (apply-key key (pop sequence)))
+ (setq count (1+ count)))))
+
+) ; EVAL-WHEN
+
+(defun count-if (test sequence &key from-end (start 0) end key)
+ #!+sb-doc
+ "Returns the number of elements in SEQUENCE satisfying TEST(el)."
+ (declare (ignore from-end) (fixnum start))
+ (let ((end (or end (length sequence))))
+ (declare (type index end))
+ (seq-dispatch sequence
+ (list-count-if test sequence)
+ (vector-count-if test sequence))))
+
+(eval-when (:compile-toplevel :execute)
+
+(sb!xc:defmacro vector-count-if-not (predicate sequence)
+ `(do ((index start (1+ index))
+ (count 0))
+ ((= index (the fixnum end)) count)
+ (declare (fixnum index count))
+ (if (not (funcall ,predicate (apply-key key (aref ,sequence index))))
+ (setq count (1+ count)))))
+
+(sb!xc:defmacro list-count-if-not (predicate sequence)
+ `(do ((sequence (nthcdr start ,sequence))
+ (index start (1+ index))
+ (count 0))
+ ((or (= index (the fixnum end)) (null sequence)) count)
+ (declare (fixnum index count))
+ (if (not (funcall ,predicate (apply-key key (pop sequence))))
+ (setq count (1+ count)))))
+
+) ; EVAL-WHEN
+
+(defun count-if-not (test sequence &key from-end (start 0) end key)
+ #!+sb-doc
+ "Returns the number of elements in SEQUENCE not satisfying TEST(el)."
+ (declare (ignore from-end) (fixnum start))
+ (let ((end (or end (length sequence))))
+ (declare (type index end))
+ (seq-dispatch sequence
+ (list-count-if-not test sequence)
+ (vector-count-if-not test sequence))))
+\f
+;;;; MISMATCH
+
+(eval-when (:compile-toplevel :execute)
+
+(sb!xc:defmacro match-vars (&rest body)
+ `(let ((inc (if from-end -1 1))
+ (start1 (if from-end (1- (the fixnum end1)) start1))
+ (start2 (if from-end (1- (the fixnum end2)) start2))
+ (end1 (if from-end (1- (the fixnum start1)) end1))
+ (end2 (if from-end (1- (the fixnum start2)) end2)))
+ (declare (fixnum inc start1 start2 end1 end2))
+ ,@body))
+
+(sb!xc:defmacro matchify-list ((sequence start length end) &body body)
+ (declare (ignore end)) ;; ### Should END be used below?
+ `(let ((,sequence (if from-end
+ (nthcdr (- (the fixnum ,length) (the fixnum ,start) 1)
+ (reverse (the list ,sequence)))
+ (nthcdr ,start ,sequence))))
+ (declare (type list ,sequence))
+ ,@body))
+
+) ; EVAL-WHEN
+
+(eval-when (:compile-toplevel :execute)
+
+(sb!xc:defmacro if-mismatch (elt1 elt2)
+ `(cond ((= (the fixnum index1) (the fixnum end1))
+ (return (if (= (the fixnum index2) (the fixnum end2))
+ nil
+ (if from-end
+ (1+ (the fixnum index1))
+ (the fixnum index1)))))
+ ((= (the fixnum index2) (the fixnum end2))
+ (return (if from-end (1+ (the fixnum index1)) index1)))
+ (test-not
+ (if (funcall test-not (apply-key key ,elt1) (apply-key key ,elt2))
+ (return (if from-end (1+ (the fixnum index1)) index1))))
+ (t (if (not (funcall test (apply-key key ,elt1)
+ (apply-key key ,elt2)))
+ (return (if from-end (1+ (the fixnum index1)) index1))))))
+
+(sb!xc:defmacro mumble-mumble-mismatch ()
+ `(do ((index1 start1 (+ index1 (the fixnum inc)))
+ (index2 start2 (+ index2 (the fixnum inc))))
+ (())
+ (declare (fixnum index1 index2))
+ (if-mismatch (aref sequence1 index1) (aref sequence2 index2))))
+
+(sb!xc:defmacro mumble-list-mismatch ()
+ `(do ((index1 start1 (+ index1 (the fixnum inc)))
+ (index2 start2 (+ index2 (the fixnum inc))))
+ (())
+ (declare (fixnum index1 index2))
+ (if-mismatch (aref sequence1 index1) (pop sequence2))))
+\f
+(sb!xc:defmacro list-mumble-mismatch ()
+ `(do ((index1 start1 (+ index1 (the fixnum inc)))
+ (index2 start2 (+ index2 (the fixnum inc))))
+ (())
+ (declare (fixnum index1 index2))
+ (if-mismatch (pop sequence1) (aref sequence2 index2))))
+
+(sb!xc:defmacro list-list-mismatch ()
+ `(do ((sequence1 sequence1)
+ (sequence2 sequence2)
+ (index1 start1 (+ index1 (the fixnum inc)))
+ (index2 start2 (+ index2 (the fixnum inc))))
+ (())
+ (declare (fixnum index1 index2))
+ (if-mismatch (pop sequence1) (pop sequence2))))
+
+) ; EVAL-WHEN
+
+(defun mismatch (sequence1 sequence2 &key from-end (test #'eql) test-not
+ (start1 0) end1 (start2 0) end2 key)
+ #!+sb-doc
+ "The specified subsequences of Sequence1 and Sequence2 are compared
+ element-wise. If they are of equal length and match in every element, the
+ result is Nil. Otherwise, the result is a non-negative integer, the index
+ within Sequence1 of the leftmost position at which they fail to match; or,
+ if one is shorter than and a matching prefix of the other, the index within
+ Sequence1 beyond the last position tested is returned. If a non-Nil
+ :From-End keyword argument is given, then one plus the index of the
+ rightmost position in which the sequences differ is returned."
+ (declare (fixnum start1 start2))
+ (let* ((length1 (length sequence1))
+ (end1 (or end1 length1))
+ (length2 (length sequence2))
+ (end2 (or end2 length2)))
+ (declare (type index length1 end1 length2 end2))
+ (match-vars
+ (seq-dispatch sequence1
+ (matchify-list (sequence1 start1 length1 end1)
+ (seq-dispatch sequence2
+ (matchify-list (sequence2 start2 length2 end2)
+ (list-list-mismatch))
+ (list-mumble-mismatch)))
+ (seq-dispatch sequence2
+ (matchify-list (sequence2 start2 length2 end2)
+ (mumble-list-mismatch))
+ (mumble-mumble-mismatch))))))
+\f
+;;; search comparison functions
+
+(eval-when (:compile-toplevel :execute)
+
+;;; Compare two elements and return if they don't match.
+(sb!xc:defmacro compare-elements (elt1 elt2)
+ `(if test-not
+ (if (funcall test-not (apply-key key ,elt1) (apply-key key ,elt2))
+ (return nil)
+ t)
+ (if (not (funcall test (apply-key key ,elt1) (apply-key key ,elt2)))
+ (return nil)
+ t)))
+
+(sb!xc:defmacro search-compare-list-list (main sub)
+ `(do ((main ,main (cdr main))
+ (jndex start1 (1+ jndex))
+ (sub (nthcdr start1 ,sub) (cdr sub)))
+ ((or (null main) (null sub) (= (the fixnum end1) jndex))
+ t)
+ (declare (fixnum jndex))
+ (compare-elements (car main) (car sub))))
+
+(sb!xc:defmacro search-compare-list-vector (main sub)
+ `(do ((main ,main (cdr main))
+ (index start1 (1+ index)))
+ ((or (null main) (= index (the fixnum end1))) t)
+ (declare (fixnum index))
+ (compare-elements (car main) (aref ,sub index))))
+
+(sb!xc:defmacro search-compare-vector-list (main sub index)
+ `(do ((sub (nthcdr start1 ,sub) (cdr sub))
+ (jndex start1 (1+ jndex))
+ (index ,index (1+ index)))
+ ((or (= (the fixnum end1) jndex) (null sub)) t)
+ (declare (fixnum jndex index))
+ (compare-elements (aref ,main index) (car sub))))
+
+(sb!xc:defmacro search-compare-vector-vector (main sub index)
+ `(do ((index ,index (1+ index))
+ (sub-index start1 (1+ sub-index)))
+ ((= sub-index (the fixnum end1)) t)
+ (declare (fixnum sub-index index))
+ (compare-elements (aref ,main index) (aref ,sub sub-index))))
+
+(sb!xc:defmacro search-compare (main-type main sub index)
+ (if (eq main-type 'list)
+ `(seq-dispatch ,sub
+ (search-compare-list-list ,main ,sub)
+ (search-compare-list-vector ,main ,sub))
+ `(seq-dispatch ,sub
+ (search-compare-vector-list ,main ,sub ,index)
+ (search-compare-vector-vector ,main ,sub ,index))))
+
+) ; EVAL-WHEN
+\f
+;;;; SEARCH
+
+(eval-when (:compile-toplevel :execute)
+
+(sb!xc:defmacro list-search (main sub)
+ `(do ((main (nthcdr start2 ,main) (cdr main))
+ (index2 start2 (1+ index2))
+ (terminus (- (the fixnum end2)
+ (the fixnum (- (the fixnum end1)
+ (the fixnum start1)))))
+ (last-match ()))
+ ((> index2 terminus) last-match)
+ (declare (fixnum index2 terminus))
+ (if (search-compare list main ,sub index2)
+ (if from-end
+ (setq last-match index2)
+ (return index2)))))
+
+(sb!xc:defmacro vector-search (main sub)
+ `(do ((index2 start2 (1+ index2))
+ (terminus (- (the fixnum end2)
+ (the fixnum (- (the fixnum end1)
+ (the fixnum start1)))))
+ (last-match ()))
+ ((> index2 terminus) last-match)
+ (declare (fixnum index2 terminus))
+ (if (search-compare vector ,main ,sub index2)
+ (if from-end
+ (setq last-match index2)
+ (return index2)))))
+
+) ; EVAL-WHEN
+
+(defun search (sequence1 sequence2 &key from-end (test #'eql) test-not
+ (start1 0) end1 (start2 0) end2 key)
+ (declare (fixnum start1 start2))
+ (let ((end1 (or end1 (length sequence1)))
+ (end2 (or end2 (length sequence2))))
+ (seq-dispatch sequence2
+ (list-search sequence2 sequence1)
+ (vector-search sequence2 sequence1))))
--- /dev/null
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!IMPL")
+
+(file-comment
+ "$Header$")
+\f
+#|
+;;;; object set stuff
+
+;;; a hashtable from ports to objects. Each entry is a cons (object . set).
+;(defvar *port-table* (make-hash-table :test 'eql))
+
+(defstruct (object-set
+ (:constructor make-object-set
+ (name &optional
+ (default-handler #'default-default-handler)))
+ (:print-object
+ (lambda (s stream)
+ (format stream "#<Object Set ~S>" (object-set-name s)))))
+ name ; Name, for descriptive purposes.
+ (table (make-hash-table :test 'eq)) ; Message-ID or
+ ; xevent-type --> handler fun.
+ default-handler)
+
+#!+sb-doc
+(setf (fdocumentation 'make-object-set 'function)
+ "Make an object set for use by a RPC/xevent server. Name is for
+ descriptive purposes only.")
+
+;;; If no such operation defined, signal an error.
+(defun default-default-handler (object)
+ (error "You lose, object: ~S" object))
+
+;;; Look up the handler function for a given message ID.
+(defun object-set-operation (object-set message-id)
+ #!+sb-doc
+ "Return the handler function in Object-Set for the operation specified by
+ Message-ID, if none, NIL is returned."
+ (check-type object-set object-set)
+ (check-type message-id fixnum)
+ (values (gethash message-id (object-set-table object-set))))
+
+;;; The setf inverse for Object-Set-Operation.
+(defun %set-object-set-operation (object-set message-id new-value)
+ (check-type object-set object-set)
+ (check-type message-id fixnum)
+ (setf (gethash message-id (object-set-table object-set)) new-value))
+
+|#
+\f
+;;;; file descriptor I/O noise
+
+(defstruct (handler
+ (:constructor make-handler (direction descriptor function)))
+ ;; Reading or writing...
+ (direction nil :type (member :input :output))
+ ;; File descriptor this handler is tied to.
+ (descriptor 0 :type (mod #.sb!unix:fd-setsize))
+
+ active ; T iff this handler is running.
+ (function nil :type function) ; Function to call.
+ bogus) ; T if this descriptor is bogus.
+(def!method print-object ((handler handler) stream)
+ (print-unreadable-object (handler stream :type t)
+ (format stream
+ "~A on ~:[~;BOGUS ~]descriptor ~D: ~S"
+ (handler-direction handler)
+ (handler-bogus handler)
+ (handler-descriptor handler)
+ (handler-function handler))))
+
+(defvar *descriptor-handlers* nil
+ #!+sb-doc
+ "List of all the currently active handlers for file descriptors")
+
+;;; Add a new handler to *descriptor-handlers*.
+(defun add-fd-handler (fd direction function)
+ #!+sb-doc
+ "Arange to call FUNCTION whenever FD is usable. DIRECTION should be
+ either :INPUT or :OUTPUT. The value returned should be passed to
+ SYSTEM:REMOVE-FD-HANDLER when it is no longer needed."
+ (assert (member direction '(:input :output))
+ (direction)
+ "Invalid direction ~S, must be either :INPUT or :OUTPUT" direction)
+ (let ((handler (make-handler direction fd function)))
+ (push handler *descriptor-handlers*)
+ handler))
+
+;;; Remove an old handler from *descriptor-handlers*.
+(defun remove-fd-handler (handler)
+ #!+sb-doc
+ "Removes HANDLER from the list of active handlers."
+ (setf *descriptor-handlers*
+ (delete handler *descriptor-handlers*
+ :test #'eq)))
+
+;;; Search *descriptor-handlers* for any reference to fd, and nuke 'em.
+(defun invalidate-descriptor (fd)
+ #!+sb-doc
+ "Remove any handers refering to fd. This should only be used when attempting
+ to recover from a detected inconsistancy."
+ (setf *descriptor-handlers*
+ (delete fd *descriptor-handlers*
+ :key #'handler-descriptor)))
+
+;;; Add the handler to *descriptor-handlers* for the duration of BODY.
+(defmacro with-fd-handler ((fd direction function) &rest body)
+ #!+sb-doc
+ "Establish a handler with SYSTEM:ADD-FD-HANDLER for the duration of BODY.
+ DIRECTION should be either :INPUT or :OUTPUT, FD is the file descriptor to
+ use, and FUNCTION is the function to call whenever FD is usable."
+ (let ((handler (gensym)))
+ `(let (,handler)
+ (unwind-protect
+ (progn
+ (setf ,handler (add-fd-handler ,fd ,direction ,function))
+ ,@body)
+ (when ,handler
+ (remove-fd-handler ,handler))))))
+
+;;; First, get a list and mark bad file descriptors. Then signal an error
+;;; offering a few restarts.
+(defun handler-descriptors-error ()
+ (let ((bogus-handlers nil))
+ (dolist (handler *descriptor-handlers*)
+ (unless (or (handler-bogus handler)
+ (sb!unix:unix-fstat (handler-descriptor handler)))
+ (setf (handler-bogus handler) t)
+ (push handler bogus-handlers)))
+ (restart-case (error "~S ~[have~;has a~:;have~] bad file descriptor~:P."
+ bogus-handlers (length bogus-handlers))
+ (remove-them () :report "Remove bogus handlers."
+ (setf *descriptor-handlers*
+ (delete-if #'handler-bogus *descriptor-handlers*)))
+ (retry-them () :report "Retry bogus handlers."
+ (dolist (handler bogus-handlers)
+ (setf (handler-bogus handler) nil)))
+ (continue () :report "Go on, leaving handlers marked as bogus."))))
+\f
+;;;; SERVE-ALL-EVENTS, SERVE-EVENT, and friends
+
+;;; Break a real timeout into seconds and microseconds.
+(defun decode-timeout (timeout)
+ (declare (values (or index null) index))
+ (typecase timeout
+ (integer (values timeout 0))
+ (null (values nil 0))
+ (real
+ (multiple-value-bind (q r) (truncate (coerce timeout 'single-float))
+ (declare (type index q) (single-float r))
+ (values q (the index (truncate (* r 1f6))))))
+ (t
+ (error "Timeout is not a real number or NIL: ~S" timeout))))
+
+;;; Wait until FD is usable for DIRECTION. The timeout given to serve-event is
+;;; recalculated each time through the loop so that WAIT-UNTIL-FD-USABLE will
+;;; timeout at the correct time irrespective of how many events are handled in
+;;; the meantime.
+(defun wait-until-fd-usable (fd direction &optional timeout)
+ #!+sb-doc
+ "Wait until FD is usable for DIRECTION. DIRECTION should be either :INPUT or
+ :OUTPUT. TIMEOUT, if supplied, is the number of seconds to wait before giving
+ up."
+ (declare (type (or real null) timeout))
+ (let (usable)
+ (multiple-value-bind (to-sec to-usec) (decode-timeout timeout)
+ (declare (type (or index null) to-sec to-usec))
+ (multiple-value-bind (stop-sec stop-usec)
+ (if to-sec
+ (multiple-value-bind (okay start-sec start-usec)
+ (sb!unix:unix-gettimeofday)
+ (declare (ignore okay))
+ (let ((usec (+ to-usec start-usec))
+ (sec (+ to-sec start-sec)))
+ (declare (type (unsigned-byte 31) usec sec))
+ (if (>= usec 1000000)
+ (values (1+ sec) (- usec 1000000))
+ (values sec usec))))
+ (values 0 0))
+ (declare (type (unsigned-byte 31) stop-sec stop-usec))
+ (with-fd-handler (fd direction #'(lambda (fd)
+ (declare (ignore fd))
+ (setf usable t)))
+ (loop
+ (sub-serve-event to-sec to-usec)
+
+ (when usable
+ (return t))
+
+ (when timeout
+ (multiple-value-bind (okay sec usec) (sb!unix:unix-gettimeofday)
+ (declare (ignore okay))
+ (when (or (> sec stop-sec)
+ (and (= sec stop-sec) (>= usec stop-usec)))
+ (return nil))
+ (setq to-sec (- stop-sec sec))
+ (cond ((> usec stop-usec)
+ (decf to-sec)
+ (setq to-usec (- (+ stop-usec 1000000) usec)))
+ (t
+ (setq to-usec (- stop-usec usec))))))))))))
+\f
+;;; Wait for up to timeout seconds for an event to happen. Make sure all
+;;; pending events are processed before returning.
+(defun serve-all-events (&optional timeout)
+ #!+sb-doc
+ "SERVE-ALL-EVENTS calls SERVE-EVENT with the specified timeout. If
+ SERVE-EVENT does something (returns T) it loops over SERVE-EVENT with timeout
+ 0 until all events have been served. SERVE-ALL-EVENTS returns T if
+ SERVE-EVENT did something and NIL if not."
+ (do ((res nil)
+ (sval (serve-event timeout) (serve-event 0)))
+ ((null sval) res)
+ (setq res t)))
+
+;;; Serve a single event.
+(defun serve-event (&optional timeout)
+ #!+sb-doc
+ "Receive on all ports and Xevents and dispatch to the appropriate handler
+ function. If timeout is specified, server will wait the specified time (in
+ seconds) and then return, otherwise it will wait until something happens.
+ Server returns T if something happened and NIL otherwise."
+ (multiple-value-bind (to-sec to-usec) (decode-timeout timeout)
+ (sub-serve-event to-sec to-usec)))
+
+;;; These macros are chunks of code from SUB-SERVE-EVENT. They randomly
+;;; reference the READ-FDS and WRITE-FDS Alien variables (which wold be consed
+;;; if passed as function arguments.)
+(eval-when (:compile-toplevel :execute)
+
+;;; Initialize the fd-sets for UNIX-SELECT and return the active descriptor
+;;; count.
+(sb!xc:defmacro calc-masks ()
+ '(progn
+ (sb!unix:fd-zero read-fds)
+ (sb!unix:fd-zero write-fds)
+ (let ((count 0))
+ (declare (type index count))
+ (dolist (handler *descriptor-handlers*)
+ (unless (or (handler-active handler)
+ (handler-bogus handler))
+ (let ((fd (handler-descriptor handler)))
+ (ecase (handler-direction handler)
+ (:input (sb!unix:fd-set fd read-fds))
+ (:output (sb!unix:fd-set fd write-fds)))
+ (when (> fd count)
+ (setf count fd)))))
+ (1+ count))))
+
+;;; Call file descriptor handlers according to the readable and writable masks
+;;; returned by select.
+(sb!xc:defmacro call-fd-handler ()
+ '(let ((result nil))
+ (dolist (handler *descriptor-handlers*)
+ (let ((desc (handler-descriptor handler)))
+ (when (ecase (handler-direction handler)
+ (:input (sb!unix:fd-isset desc read-fds))
+ (:output (sb!unix:fd-isset desc write-fds)))
+ (unwind-protect
+ (progn
+ ;; Doesn't work -- ACK
+ ;(setf (handler-active handler) t)
+ (funcall (handler-function handler) desc))
+ (setf (handler-active handler) nil))
+ (ecase (handler-direction handler)
+ (:input (sb!unix:fd-clr desc read-fds))
+ (:output (sb!unix:fd-clr desc write-fds)))
+ (setf result t)))
+ result)))
+
+) ; EVAL-WHEN
+
+;;; When a *periodic-polling-function* is defined the server will not
+;;; block for more than the maximum event timeout and will call the
+;;; polling function if it does time out. One important use of this
+;;; is to periodically call process-yield.
+(declaim (type (or null function) *periodic-polling-function*))
+(defvar *periodic-polling-function*
+ #!-mp nil #!+mp #'sb!mp:process-yield)
+(declaim (type (unsigned-byte 29) *max-event-to-sec* *max-event-to-usec*))
+(defvar *max-event-to-sec* 1)
+(defvar *max-event-to-usec* 0)
+
+;;; Takes timeout broken into seconds and microseconds.
+(defun sub-serve-event (to-sec to-usec)
+ (declare (type (or null (unsigned-byte 29)) to-sec to-usec))
+
+ (let ((call-polling-fn nil))
+ (when (and *periodic-polling-function*
+ ;; Enforce a maximum timeout.
+ (or (null to-sec)
+ (> to-sec *max-event-to-sec*)
+ (and (= to-sec *max-event-to-sec*)
+ (> to-usec *max-event-to-usec*))))
+ (setf to-sec *max-event-to-sec*)
+ (setf to-usec *max-event-to-usec*)
+ (setf call-polling-fn t))
+
+ ;; Next, wait for something to happen.
+ (sb!alien:with-alien ((read-fds (sb!alien:struct sb!unix:fd-set))
+ (write-fds (sb!alien:struct sb!unix:fd-set)))
+ (let ((count (calc-masks)))
+ (multiple-value-bind (value err) (sb!unix:unix-fast-select
+ count
+ (sb!alien:addr read-fds) (sb!alien:addr write-fds)
+ nil to-sec to-usec)
+
+ ;; Now see what it was (if anything)
+ (cond (value
+ (cond ((zerop value)
+ ;; Timed out.
+ (when call-polling-fn
+ (funcall *periodic-polling-function*)))
+ (t
+ (call-fd-handler))))
+ ((eql err sb!unix:eintr)
+ ;; We did an interrupt.
+ t)
+ (t
+ ;; One of the file descriptors is bad.
+ (handler-descriptors-error)
+ nil)))))))
--- /dev/null
+;;;; stuff to automatically generate SETF functions for all the standard
+;;;; functions that are currently implemented with SETF macros
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!KERNEL")
+
+(file-comment
+ "$Header$")
+
+(eval-when (:compile-toplevel :execute)
+
+(defun compute-one-setter (name type)
+ (let* ((args (second type))
+ (res (type-specifier
+ (single-value-type
+ (values-specifier-type (third type)))))
+ (arglist (loop repeat (1+ (length args)) collect (gensym))))
+ (cond
+ ((null (intersection args lambda-list-keywords))
+ `(defun (setf ,name) ,arglist
+ (declare ,@(mapcar #'(lambda (arg type)
+ `(type ,type ,arg))
+ arglist
+ (cons res args)))
+ (setf (,name ,@(rest arglist)) ,(first arglist))))
+ (t
+ (warn "hairy SETF expander for function ~S" name)
+ nil))))
+
+;;; FIXME: should probably become MACROLET
+(sb!xc:defmacro define-setters (packages &rest ignore)
+ (collect ((res))
+ (dolist (pkg packages)
+ (do-external-symbols (sym pkg)
+ (when (and (fboundp sym)
+ (eq (info :function :kind sym) :function)
+ (or (info :setf :inverse sym)
+ (info :setf :expander sym))
+ (not (member sym ignore)))
+ (let ((type (type-specifier (info :function :type sym))))
+ (assert (consp type))
+ #!-sb-fluid (res `(declaim (inline (setf ,sym))))
+ (res (compute-one-setter sym type))))))
+ `(progn ,@(res))))
+
+); eval-when (compile eval)
+
+(define-setters ("COMMON-LISP")
+ ;; Semantically silly...
+ getf apply ldb mask-field logbitp subseq values
+ ;; Have explicit redundant definitions...
+ setf bit sbit get aref gethash)
--- /dev/null
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!IMPL")
+
+(file-comment
+ "$Header$")
+\f
+(declaim (special *read-suppress* *standard-readtable* *bq-vector-flag*))
+
+;;; FIXME: Is it standard to ignore numeric args instead of raising errors?
+(defun ignore-numarg (sub-char numarg)
+ (when numarg
+ (warn "A numeric argument was ignored in #~D~A." numarg sub-char)))
+\f
+;;;; reading arrays and vectors: the #(, #*, and #A readmacros
+
+(defun sharp-left-paren (stream ignore length)
+ (declare (ignore ignore) (special *backquote-count*))
+ (let* ((list (read-list stream nil))
+ (listlength (length list)))
+ (declare (list list)
+ (fixnum listlength))
+ (cond (*read-suppress* nil)
+ ((zerop *backquote-count*)
+ (if length
+ (cond ((> listlength (the fixnum length))
+ (%reader-error
+ stream
+ "vector longer than specified length: #~S~S"
+ length list))
+ (t
+ (fill (the simple-vector
+ (replace (the simple-vector
+ (make-array length))
+ list))
+ (car (last list))
+ :start listlength)))
+ (coerce list 'vector)))
+ (t (cons *bq-vector-flag* list)))))
+
+(defun sharp-star (stream ignore numarg)
+ (declare (ignore ignore))
+ (multiple-value-bind (bstring escape-appearedp) (read-extended-token stream)
+ (declare (simple-string bstring))
+ (cond (*read-suppress* nil)
+ (escape-appearedp
+ (%reader-error stream "An escape character appeared after #*"))
+ ((and numarg (zerop (length bstring)) (not (zerop numarg)))
+ (%reader-error
+ stream
+ "You have to give a little bit for non-zero #* bit-vectors."))
+ ((or (null numarg) (>= (the fixnum numarg) (length bstring)))
+ (let* ((len1 (length bstring))
+ (last1 (1- len1))
+ (len2 (or numarg len1))
+ (bvec (make-array len2 :element-type 'bit
+ :initial-element 0)))
+ (declare (fixnum len1 last1 len2))
+ (do ((i 0 (1+ i))
+ (char ()))
+ ((= i len2))
+ (declare (fixnum i))
+ (setq char (elt bstring (if (< i len1) i last1)))
+ (setf (elt bvec i)
+ (cond ((char= char #\0) 0)
+ ((char= char #\1) 1)
+ (t
+ (%reader-error
+ stream
+ "illegal element given for bit-vector: ~S"
+ char)))))
+ bvec))
+ (t
+ (%reader-error stream
+ "Bit vector is longer than specified length #~A*~A"
+ numarg bstring)))))
+
+(defun sharp-A (stream ignore dimensions)
+ (declare (ignore ignore))
+ (when *read-suppress*
+ (read stream t nil t)
+ (return-from sharp-A nil))
+ (unless dimensions (%reader-error stream "no dimensions argument to #A"))
+ (collect ((dims))
+ (let* ((contents (read stream t nil t))
+ (seq contents))
+ (dotimes (axis dimensions
+ (make-array (dims) :initial-contents contents))
+ (unless (typep seq 'sequence)
+ (%reader-error stream
+ "#~DA axis ~D is not a sequence:~% ~S"
+ dimensions axis seq))
+ (let ((len (length seq)))
+ (dims len)
+ (unless (= axis (1- dimensions))
+ (when (zerop len)
+ (%reader-error stream
+ "#~DA axis ~D is empty, but is not ~
+ the last dimension."
+ dimensions axis))
+ (setq seq (elt seq 0))))))))
+\f
+;;;; reading structure instances: the #S readmacro
+
+(defun sharp-S (stream sub-char numarg)
+ (ignore-numarg sub-char numarg)
+ (when *read-suppress*
+ (read stream t nil t)
+ (return-from sharp-S nil))
+ (let ((body (if (char= (read-char stream t) #\( )
+ (read-list stream nil)
+ (%reader-error stream "non-list following #S"))))
+ (unless (listp body)
+ (%reader-error stream "non-list following #S: ~S" body))
+ (unless (symbolp (car body))
+ (%reader-error stream "Structure type is not a symbol: ~S" (car body)))
+ (let ((class (sb!xc:find-class (car body) nil)))
+ (unless (typep class 'sb!xc:structure-class)
+ (%reader-error stream "~S is not a defined structure type."
+ (car body)))
+ (let ((def-con (dd-default-constructor
+ (layout-info
+ (class-layout class)))))
+ (unless def-con
+ (%reader-error
+ stream "The ~S structure does not have a default constructor."
+ (car body)))
+ (apply (fdefinition def-con) (rest body))))))
+\f
+;;;; reading numbers: the #B, #C, #O, #R, and #X readmacros
+
+(defun sharp-B (stream sub-char numarg)
+ (ignore-numarg sub-char numarg)
+ (sharp-r stream sub-char 2))
+
+(defun sharp-C (stream sub-char numarg)
+ (ignore-numarg sub-char numarg)
+ ;; The next thing had better be a list of two numbers.
+ (let ((cnum (read stream t nil t)))
+ (when *read-suppress* (return-from sharp-c nil))
+ (if (and (listp cnum) (= (length cnum) 2))
+ (complex (car cnum) (cadr cnum))
+ (%reader-error stream "illegal complex number format: #C~S" cnum))))
+
+(defun sharp-O (stream sub-char numarg)
+ (ignore-numarg sub-char numarg)
+ (sharp-r stream sub-char 8))
+
+(defun sharp-R (stream sub-char radix)
+ (cond (*read-suppress*
+ (read-extended-token stream)
+ nil)
+ ((not radix)
+ (%reader-error stream "radix missing in #R"))
+ ((not (<= 2 radix 36))
+ (%reader-error stream "illegal radix for #R: ~D" radix))
+ (t
+ (let ((res (let ((*read-base* radix))
+ (read stream t nil t))))
+ (unless (typep res 'rational)
+ (%reader-error stream
+ "#~A (base ~D) value is not a rational: ~S."
+ sub-char
+ radix
+ res))
+ res))))
+
+(defun sharp-X (stream sub-char numarg)
+ (ignore-numarg sub-char numarg)
+ (sharp-r stream sub-char 16))
+\f
+;;;; reading circular data: the #= and ## readmacros
+
+;;; objects already seen by CIRCLE-SUBST
+(defvar *sharp-equal-circle-table*)
+(declaim (type hash-table *sharp-equal-circle-table*))
+
+;; This function is kind of like NSUBLIS, but checks for circularities and
+;; substitutes in arrays and structures as well as lists. The first arg is an
+;; alist of the things to be replaced assoc'd with the things to replace them.
+(defun circle-subst (old-new-alist tree)
+ (cond ((not (typep tree '(or cons (array t) structure-object)))
+ (let ((entry (find tree old-new-alist :key #'second)))
+ (if entry (third entry) tree)))
+ ((null (gethash tree *sharp-equal-circle-table*))
+ (setf (gethash tree *sharp-equal-circle-table*) t)
+ (cond ((typep tree 'structure-object)
+ (do ((i 1 (1+ i))
+ (end (%instance-length tree)))
+ ((= i end))
+ (let* ((old (%instance-ref tree i))
+ (new (circle-subst old-new-alist old)))
+ (unless (eq old new)
+ (setf (%instance-ref tree i) new)))))
+ ((arrayp tree)
+ (with-array-data ((data tree) (start) (end))
+ (declare (fixnum start end))
+ (do ((i start (1+ i)))
+ ((>= i end))
+ (let* ((old (aref data i))
+ (new (circle-subst old-new-alist old)))
+ (unless (eq old new)
+ (setf (aref data i) new))))))
+ (t
+ (let ((a (circle-subst old-new-alist (car tree)))
+ (d (circle-subst old-new-alist (cdr tree))))
+ (unless (eq a (car tree))
+ (rplaca tree a))
+ (unless (eq d (cdr tree))
+ (rplacd tree d)))))
+ tree)
+ (t tree)))
+
+;;; Sharp-equal works as follows. When a label is assigned (ie when #= is
+;;; called) we GENSYM a symbol is which is used as an unforgeable tag.
+;;; *SHARP-SHARP-ALIST* maps the integer tag to this gensym.
+;;;
+;;; When SHARP-SHARP encounters a reference to a label, it returns the symbol
+;;; assoc'd with the label. Resolution of the reference is deferred until the
+;;; read done by #= finishes. Any already resolved tags (in
+;;; *SHARP-EQUAL-ALIST*) are simply returned.
+;;;
+;;; After reading of the #= form is completed, we add an entry to
+;;; *SHARP-EQUAL-ALIST* that maps the gensym tag to the resolved object. Then
+;;; for each entry in the *SHARP-SHARP-ALIST, the current object is searched
+;;; and any uses of the gensysm token are replaced with the actual value.
+(defvar *sharp-sharp-alist* ())
+
+(defun sharp-equal (stream ignore label)
+ (declare (ignore ignore))
+ (when *read-suppress* (return-from sharp-equal (values)))
+ (unless label
+ (%reader-error stream "missing label for #=" label))
+ (when (or (assoc label *sharp-sharp-alist*)
+ (assoc label *sharp-equal-alist*))
+ (%reader-error stream "multiply defined label: #~D=" label))
+ (let* ((tag (gensym))
+ (*sharp-sharp-alist* (acons label tag *sharp-sharp-alist*))
+ (obj (read stream t nil t)))
+ (when (eq obj tag)
+ (%reader-error stream
+ "must tag something more than just #~D#"
+ label))
+ (push (list label tag obj) *sharp-equal-alist*)
+ (let ((*sharp-equal-circle-table* (make-hash-table :test 'eq :size 20)))
+ (circle-subst *sharp-equal-alist* obj))))
+
+(defun sharp-sharp (stream ignore label)
+ (declare (ignore ignore))
+ (when *read-suppress* (return-from sharp-sharp nil))
+ (unless label
+ (%reader-error stream "missing label for ##" label))
+
+ (let ((entry (assoc label *sharp-equal-alist*)))
+ (if entry
+ (third entry)
+ (let ((pair (assoc label *sharp-sharp-alist*)))
+ (unless pair
+ (%reader-error stream "object is not labelled #~S#" label))
+ (cdr pair)))))
+\f
+;;;; conditional compilation: the #+ and #- readmacros
+
+(flet ((guts (stream not-p)
+ (unless (if (handler-case
+ (let ((*package* *keyword-package*)
+ (*read-suppress* nil))
+ (featurep (read stream t nil t)))
+ (reader-package-error
+ (condition)
+ (declare (ignore condition))
+ nil))
+ (not not-p)
+ not-p)
+ (let ((*read-suppress* t))
+ (read stream t nil t)))
+ (values)))
+
+ (defun sharp-plus (stream sub-char numarg)
+ (ignore-numarg sub-char numarg)
+ (guts stream nil))
+
+ (defun sharp-minus (stream sub-char numarg)
+ (ignore-numarg sub-char numarg)
+ (guts stream t)))
+\f
+;;;; reading miscellaneous objects: the #P, #\, and #| readmacros
+
+(defun sharp-P (stream sub-char numarg)
+ (ignore-numarg sub-char numarg)
+ (let ((namestring (read stream t nil t)))
+ (unless *read-suppress*
+ (parse-namestring namestring))))
+
+(defun sharp-backslash (stream backslash numarg)
+ (ignore-numarg backslash numarg)
+ (unread-char backslash stream)
+ (let* ((*readtable* *standard-readtable*)
+ (charstring (read-extended-token stream)))
+ (declare (simple-string charstring))
+ (cond (*read-suppress* nil)
+ ((= (the fixnum (length charstring)) 1)
+ (char charstring 0))
+ ((name-char charstring))
+ (t
+ (%reader-error stream
+ "unrecognized character name: ~S"
+ charstring)))))
+
+(defun sharp-vertical-bar (stream sub-char numarg)
+ (ignore-numarg sub-char numarg)
+ (let ((stream (in-synonym-of stream)))
+ (if (lisp-stream-p stream)
+ (prepare-for-fast-read-char stream
+ (do ((level 1)
+ (prev (fast-read-char) char)
+ (char (fast-read-char) (fast-read-char)))
+ (())
+ (cond ((and (char= prev #\|) (char= char #\#))
+ (setq level (1- level))
+ (when (zerop level)
+ (done-with-fast-read-char)
+ (return (values)))
+ (setq char (fast-read-char)))
+ ((and (char= prev #\#) (char= char #\|))
+ (setq char (fast-read-char))
+ (setq level (1+ level))))))
+ ;; fundamental-stream
+ (do ((level 1)
+ (prev (read-char stream t) char)
+ (char (read-char stream t) (read-char stream t)))
+ (())
+ (cond ((and (char= prev #\|) (char= char #\#))
+ (setq level (1- level))
+ (when (zerop level)
+ (return (values)))
+ (setq char (read-char stream t)))
+ ((and (char= prev #\#) (char= char #\|))
+ (setq char (read-char stream t))
+ (setq level (1+ level))))))))
+\f
+;;;; a grab bag of other sharp readmacros: #', #:, and #.
+
+(defun sharp-quote (stream sub-char numarg)
+ (ignore-numarg sub-char numarg)
+ ;; The fourth arg tells READ that this is a recursive call.
+ `(function ,(read stream t nil t)))
+
+(defun sharp-colon (stream sub-char numarg)
+ (ignore-numarg sub-char numarg)
+ (multiple-value-bind (token escapep colon) (read-extended-token stream)
+ (declare (simple-string token) (ignore escapep))
+ (cond
+ (*read-suppress* nil)
+ (colon
+ (%reader-error stream
+ "The symbol following #: contains a package marker: ~S"
+ token))
+ (t
+ (make-symbol token)))))
+
+(defvar *read-eval* t
+ #!+sb-doc
+ "If false, then the #. read macro is disabled.")
+
+(defun sharp-dot (stream sub-char numarg)
+ (ignore-numarg sub-char numarg)
+ (let ((token (read stream t nil t)))
+ (unless *read-suppress*
+ (unless *read-eval*
+ (%reader-error stream "can't read #. while *READ-EVAL* is NIL"))
+ (eval token))))
+\f
+(defun sharp-illegal (stream sub-char ignore)
+ (declare (ignore ignore))
+ (%reader-error stream "illegal sharp macro character: ~S" sub-char))
+
+;;; for cold init: Install SHARPM stuff in the current *READTABLE*.
+(defun !sharpm-cold-init ()
+ (make-dispatch-macro-character #\# t)
+ (set-dispatch-macro-character #\# #\\ #'sharp-backslash)
+ (set-dispatch-macro-character #\# #\' #'sharp-quote)
+ (set-dispatch-macro-character #\# #\( #'sharp-left-paren)
+ (set-dispatch-macro-character #\# #\* #'sharp-star)
+ (set-dispatch-macro-character #\# #\: #'sharp-colon)
+ (set-dispatch-macro-character #\# #\. #'sharp-dot)
+ (set-dispatch-macro-character #\# #\R #'sharp-R)
+ (set-dispatch-macro-character #\# #\r #'sharp-R)
+ (set-dispatch-macro-character #\# #\B #'sharp-B)
+ (set-dispatch-macro-character #\# #\b #'sharp-B)
+ (set-dispatch-macro-character #\# #\O #'sharp-O)
+ (set-dispatch-macro-character #\# #\o #'sharp-O)
+ (set-dispatch-macro-character #\# #\X #'sharp-X)
+ (set-dispatch-macro-character #\# #\x #'sharp-X)
+ (set-dispatch-macro-character #\# #\A #'sharp-A)
+ (set-dispatch-macro-character #\# #\a #'sharp-A)
+ (set-dispatch-macro-character #\# #\S #'sharp-S)
+ (set-dispatch-macro-character #\# #\s #'sharp-S)
+ (set-dispatch-macro-character #\# #\= #'sharp-equal)
+ (set-dispatch-macro-character #\# #\# #'sharp-sharp)
+ (set-dispatch-macro-character #\# #\+ #'sharp-plus)
+ (set-dispatch-macro-character #\# #\- #'sharp-minus)
+ (set-dispatch-macro-character #\# #\C #'sharp-C)
+ (set-dispatch-macro-character #\# #\c #'sharp-C)
+ (set-dispatch-macro-character #\# #\| #'sharp-vertical-bar)
+ (set-dispatch-macro-character #\# #\p #'sharp-p)
+ (set-dispatch-macro-character #\# #\P #'sharp-p)
+ (set-dispatch-macro-character #\# #\ #'sharp-illegal)
+ (set-dispatch-macro-character #\# #\) #'sharp-illegal)
+ (set-dispatch-macro-character #\# #\< #'sharp-illegal)
+ ;; FIXME: Should linefeed/newline go in this list too?
+ (dolist (cc '#.(list tab-char-code form-feed-char-code return-char-code))
+ (set-dispatch-macro-character #\# (code-char cc) #'sharp-illegal)))
--- /dev/null
+;;;; some stuff for displaying information for debugging/experimenting
+;;;; with the system, mostly conditionalized with #!+SB-SHOW
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!INT")
+
+;;; FIXME: Look for any other calls to %PRIMITIVE PRINT and check whether
+;;; any of them need removing too.
+\f
+;;;; FIXME: Remove this after all in-the-flow-of-control EXPORTs
+;;;; have been cleaned up.
+
+(defvar *rogue-export*)
+\f
+;;;; FILE-COMMENT
+
+;;;; FILE-COMMENT arguably doesn't belong in this file, even though
+;;;; it's sort of for displaying information about the system.
+;;;; However, it's convenient to put it in this file, since we'd like
+;;;; this file to be the first file in the system, and we'd like to be
+;;;; able to use FILE-COMMENT in this file.
+
+;;; The real implementation of SB!INT:FILE-COMMENT is a special form,
+;;; but this macro expansion for it is still useful for
+;;; (1) documentation,
+;;; (2) code walkers, and
+;;; (3) compiling the cross-compiler itself under the cross-compilation
+;;; host ANSI Common Lisp.
+(defmacro file-comment (string)
+ #!+sb-doc
+ "FILE-COMMENT String
+ When COMPILE-FILE sees this form at top-level, it places the constant string
+ in the run-time source location information. DESCRIBE will print the file
+ comment for the file that a function was defined in. The string is also
+ textually present in the FASL, so the RCS \"ident\" command can find it,
+ etc."
+ (declare (ignore string))
+ '(values))
+
+;;; Now that we've got it, we can use it.
+(file-comment
+ "$Header$")
+\f
+;;;; various SB-SHOW-dependent forms
+
+;;; Set this to NIL to suppress output from /SHOW-related forms.
+#!+sb-show (defvar */show* t)
+
+;;; shorthand for a common idiom in output statements used in debugging:
+;;; (/SHOW "Case 2:" X Y) becomes a pretty-printed version of
+;;; (FORMAT .. "~&/Case 2: X=~S Y=~S~%" X Y).
+(defmacro /show (&rest xlist)
+ #!-sb-show (declare (ignore xlist))
+ #!+sb-show
+ (flet (;; Is X something we want to just show literally by itself?
+ ;; (instead of showing it as NAME=VALUE)
+ (literal-p (x) (or (stringp x) (numberp x))))
+ ;; We build a FORMAT statement out of what we find in XLIST.
+ (let ((format-stream (make-string-output-stream)) ; string arg to FORMAT
+ (format-reverse-rest) ; reversed &REST argument to FORMAT
+ (first-p t)) ; first pass through loop?
+ (write-string "~&~<~;/" format-stream)
+ (dolist (x xlist)
+ (if first-p
+ (setq first-p nil)
+ (write-string #+ansi-cl " ~_"
+ #-ansi-cl " " ; for CLISP (CLTL1-ish)
+ format-stream))
+ (if (literal-p x)
+ (princ x format-stream)
+ (progn (let ((*print-pretty* nil))
+ (format format-stream "~S=~~S" x))
+ (push x format-reverse-rest))))
+ (write-string "~;~:>~%" format-stream)
+ (let ((format-string (get-output-stream-string format-stream))
+ (format-rest (reverse format-reverse-rest)))
+ `(locally
+ (declare (optimize (speed 1) (space 2) (safety 3)))
+ ;; For /SHOW to work, we need *TRACE-OUTPUT* of course, but
+ ;; also *READTABLE* (used by the printer to decide what
+ ;; case convention to use when outputting symbols).
+ (if (every #'boundp '(*trace-output* *readtable*))
+ (when */show*
+ (format *trace-output*
+ ,format-string
+ #+ansi-cl (list ,@format-rest)
+ #-ansi-cl ,@format-rest)) ; for CLISP (CLTL1-ish)
+ #+sb-xc-host (error "can't /SHOW, unbound vars")
+ ;; We end up in this situation when we execute /SHOW
+ ;; too early in cold init. That happens often enough
+ ;; that it's really annoying for it to cause a hard
+ ;; failure -- which at that point is hard to recover
+ ;; from -- instead of just diagnostic output.
+ #-sb-xc-host (sb!sys:%primitive
+ print
+ "/(can't /SHOW, unbound vars)"))
+ (values))))))
+
+;;; a disabled-at-compile-time /SHOW, implemented as a macro instead
+;;; of a function so that leaving occasionally-useful /SHOWs in place
+;;; but disabled incurs no run-time overhead and works even when the
+;;; arguments can't be evaluated due to code flux
+(defmacro /noshow (&rest rest)
+ (declare (ignore rest)))
+
+;;; like /SHOW, except displaying values in hexadecimal
+(defmacro /xhow (&rest rest)
+ `(let ((*print-base* 16))
+ (/show ,@rest)))
+(defmacro /noxhow (&rest rest)
+ (declare (ignore rest)))
+
+;;; a trivial version of /SHOW which only prints a constant string,
+;;; implemented at a sufficiently low level that it can be used early
+;;; in cold load
+;;;
+;;; Unlike the other /SHOW-related functions, this one doesn't test
+;;; */SHOW* at runtime, because messing with special variables early
+;;; in cold load is too much trouble to be worth it.
+(defmacro /show0 (s)
+ (declare (type simple-string s))
+ (declare (ignorable s)) ; (for when #!-SB-SHOW)
+ #+sb-xc-host `(/show ,s)
+ #-sb-xc-host `(progn
+ #!+sb-show
+ (sb!sys:%primitive print
+ ,(concatenate 'simple-string "/" s))))
+(defmacro /noshow0 (s)
+ (declare (ignore s)))
+\f
+(/show0 "done with show.lisp")
--- /dev/null
+;;;; handling UNIX signals
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!UNIX")
+
+(file-comment
+ "$Header$")
+\f
+;;;; macros for dynamically enabling and disabling signal handling
+
+;;; Notes on how the without-interrupts/with-interrupts stuff works:
+;;;
+;;; Before invoking the supplied handler for any of the signals that
+;;; can be blocked, the C interrupt support code checks to see whether
+;;; *interrupts-enabled* has been bound to NIL. If so, it saves the
+;;; signal number and the value of the signal mask (from the signal
+;;; context), sets the signal mask to block all blockable signals,
+;;; sets *interrupt-pending* and returns without handling the signal.
+;;;
+;;; When we drop out the without interrupts, we check to see whether
+;;; *interrupt-pending* has been set. If so, we call
+;;; do-pending-interrupt, which generates a SIGTRAP. The C code
+;;; invokes the handler for the saved signal instead of the SIGTRAP
+;;; after replacing the signal mask in the signal context with the
+;;; saved value. When that hander returns, the original signal mask is
+;;; installed, allowing any other pending signals to be handled.
+;;;
+;;; This means that the cost of without-interrupts is just a special
+;;; binding in the case when no signals are delivered (the normal
+;;; case). It's only when a signal is actually delivered that we use
+;;; any system calls, and by then the cost of the extra system calls
+;;; are lost in the noise when compared with the cost of delivering
+;;; the signal in the first place.
+
+;;; Magically converted by the compiler into a break instruction.
+(defun do-pending-interrupt ()
+ (do-pending-interrupt))
+
+#!-gengc (progn
+
+(defvar *interrupts-enabled* t)
+(defvar *interrupt-pending* nil)
+
+(sb!xc:defmacro without-interrupts (&body body)
+ #!+sb-doc
+ "Execute BODY in a context impervious to interrupts."
+ (let ((name (gensym)))
+ `(flet ((,name () ,@body))
+ (if *interrupts-enabled*
+ (unwind-protect
+ (let ((*interrupts-enabled* nil))
+ (,name))
+ ;; FIXME: Does it matter that an interrupt coming in here
+ ;; could be executed before any of the pending interrupts?
+ ;; Or do incoming interrupts have the good grace to check
+ ;; whether interrupts are pending before executing themselves
+ ;; immediately?
+ (when *interrupt-pending*
+ (do-pending-interrupt)))
+ (,name)))))
+
+(sb!xc:defmacro with-interrupts (&body body)
+ #!+sb-doc
+ "Allow interrupts while executing BODY. As interrupts are normally allowed,
+ this is only useful inside a WITHOUT-INTERRUPTS."
+ (let ((name (gensym)))
+ `(flet ((,name () ,@body))
+ (if *interrupts-enabled*
+ (,name)
+ (let ((*interrupts-enabled* t))
+ (when *interrupt-pending*
+ (do-pending-interrupt))
+ (,name))))))
+
+) ; PROGN
+
+;;; On the GENGC system, we have to do it slightly differently because of the
+;;; existence of threads. Each thread has a suspends_disabled_count in its
+;;; mutator structure. When this value is other then zero, the low level stuff
+;;; will not suspend the thread, but will instead set the suspend_pending flag
+;;; (also in the mutator). So when we finish the without-interrupts, we just
+;;; check the suspend_pending flag and trigger a do-pending-interrupt if
+;;; necessary.
+
+#!+gengc
+(defmacro without-interrupts (&body body)
+ `(unwind-protect
+ (progn
+ (locally
+ (declare (optimize (speed 3) (safety 0)))
+ (incf (sb!kernel:mutator-interrupts-disabled-count)))
+ ,@body)
+ (locally
+ (declare (optimize (speed 3) (safety 0)))
+ (when (and (zerop (decf (sb!kernel:mutator-interrupts-disabled-count)))
+ (not (zerop (sb!kernel:mutator-interrupt-pending))))
+ (do-pending-interrupt)))))
+\f
+;;;; utilities for dealing with signal names and numbers
+
+(defstruct (unix-signal
+ (:constructor make-unix-signal (%name %number %description)))
+ %name ; signal keyword
+ (%number nil :type integer) ; UNIX signal number
+ (%description nil :type string)) ; documentation
+
+(defvar *unix-signals* nil
+ #!+sb-doc
+ "A list of Unix signal structures.")
+
+(defmacro def-unix-signal (name number description)
+ (let ((symbol (intern (symbol-name name))))
+ `(progn
+ ;; KLUDGE: This PUSH should be probably be something like PUSHNEW if we
+ ;; want to be able to cleanly reload this file. (Or perhaps
+ ;; *UNIX-SIGNALS* should be a hash table keyed by signal name, or a
+ ;; vector keyed by signal number?)
+ (push (make-unix-signal ,name ,number ,description) *unix-signals*)
+ ;; This is to make the new signal lookup stuff compatible with
+ ;; old code which expects the symbol with the same print name as
+ ;; our keywords to be a constant with a value equal to the signal
+ ;; number.
+ (defconstant ,symbol ,number ,description)
+ (let ((sb!int::*rogue-export* "DEF-MATH-RTN"))
+ (export ',symbol)))))
+
+(defun unix-signal-or-lose (arg)
+ (let ((signal (find arg *unix-signals*
+ :key (etypecase arg
+ (symbol #'unix-signal-%name)
+ (number #'unix-signal-%number)))))
+ (unless signal
+ (error "~S is not a valid signal name or number." arg))
+ signal))
+
+(defun unix-signal-name (signal)
+ #!+sb-doc
+ "Return the name of the signal as a string. Signal should be a valid
+ signal number or a keyword of the standard UNIX signal name."
+ (symbol-name (unix-signal-%name (unix-signal-or-lose signal))))
+
+(defun unix-signal-description (signal)
+ #!+sb-doc
+ "Return a string describing signal. Signal should be a valid signal
+ number or a keyword of the standard UNIX signal name."
+ (unix-signal-%description (unix-signal-or-lose signal)))
+
+(defun unix-signal-number (signal)
+ #!+sb-doc
+ "Return the number of the given signal. Signal should be a valid
+ signal number or a keyword of the standard UNIX signal name."
+ (unix-signal-%number (unix-signal-or-lose signal)))
+
+;;; Known signals
+(def-unix-signal :CHECK 0 "Check")
+
+(def-unix-signal :SIGHUP 1 "Hangup")
+(def-unix-signal :SIGINT 2 "Interrupt")
+(def-unix-signal :SIGQUIT 3 "Quit")
+(def-unix-signal :SIGILL 4 "Illegal instruction")
+(def-unix-signal :SIGTRAP 5 "Trace trap")
+(def-unix-signal :SIGIOT 6 "Iot instruction")
+#!-linux
+(def-unix-signal :SIGEMT 7 "Emt instruction")
+(def-unix-signal :SIGFPE 8 "Floating point exception")
+(def-unix-signal :SIGKILL 9 "Kill")
+(def-unix-signal :SIGBUS #!-linux 10 #!+linux 7 "Bus error")
+(def-unix-signal :SIGSEGV 11 "Segmentation violation")
+#!-linux
+(def-unix-signal :SIGSYS 12 "Bad argument to system call")
+(def-unix-signal :SIGPIPE 13 "Write on a pipe with no one to read it")
+(def-unix-signal :SIGALRM 14 "Alarm clock")
+(def-unix-signal :SIGTERM 15 "Software termination signal")
+#!+linux
+(def-unix-signal :SIGSTKFLT 16 "Stack fault on coprocessor")
+(def-unix-signal :SIGURG #!+svr4 21 #!-(or hpux svr4 linux) 16 #!+hpux 29
+ #!+linux 23 "Urgent condition present on socket")
+(def-unix-signal :SIGSTOP #!-(or hpux svr4 linux) 17 #!+hpux 24 #!+svr4 23
+ #!+linux 19 "Stop")
+(def-unix-signal :SIGTSTP #!-(or hpux svr4 linux) 18 #!+hpux 25 #!+svr4 24
+ #!+linux 20 "Stop signal generated from keyboard")
+(def-unix-signal :SIGCONT #!-(or hpux svr4 linux) 19 #!+hpux 26 #!+svr4 25
+ #!+linux 18 "Continue after stop")
+(def-unix-signal :SIGCHLD #!-(or linux hpux) 20
+ #!+hpux 18 #!+linux 17 "Child status has changed")
+(def-unix-signal :SIGTTIN #!-(or hpux svr4) 21 #!+hpux 27 #!+svr4 26
+ "Background read attempted from control terminal")
+(def-unix-signal :SIGTTOU #!-(or hpux svr4) 22 #!+hpux 28 #!+svr4 27
+ "Background write attempted to control terminal")
+(def-unix-signal :SIGIO #!-(or hpux irix linux) 23 #!+(or hpux irix) 22
+ #!+linux 29
+ "I/O is possible on a descriptor")
+#!-hpux
+(def-unix-signal :SIGXCPU #!-svr4 24 #!+svr4 30 "Cpu time limit exceeded")
+#!-hpux
+(def-unix-signal :SIGXFSZ #!-svr4 25 #!+svr4 31 "File size limit exceeded")
+(def-unix-signal :SIGVTALRM #!-(or hpux svr4) 26 #!+hpux 20 #!+svr4 28
+ "Virtual time alarm")
+(def-unix-signal :SIGPROF #!-(or hpux svr4 linux) 27 #!+hpux 21 #!+svr4 29
+ #!+linux 30 "Profiling timer alarm")
+(def-unix-signal :SIGWINCH #!-(or hpux svr4) 28 #!+hpux 23 #!+svr4 20
+ "Window size change")
+(def-unix-signal :SIGUSR1 #!-(or hpux svr4 linux) 30 #!+(or hpux svr4) 16
+ #!+linux 10 "User defined signal 1")
+(def-unix-signal :SIGUSR2 #!-(or hpux svr4 linux) 31 #!+(or hpux svr4) 17
+ #!+linux 12 "User defined signal 2")
+
+#!+mach
+(def-unix-signal :SIGEMSG 30 "Mach Emergency message")
+#!+mach
+(def-unix-signal :SIGMSG 31 "Mach message")
+
+;;; SVR4 (or Solaris?) specific signals
+#!+svr4
+(def-unix-signal :SIGWAITING 32 "Process's lwps are blocked")
+
+(sb!xc:defmacro sigmask (&rest signals)
+ #!+sb-doc
+ "Returns a mask given a set of signals."
+ (apply #'logior
+ (mapcar #'(lambda (signal)
+ (ash 1 (1- (unix-signal-number signal))))
+ signals)))
--- /dev/null
+;;;; SORT and friends
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!IMPL")
+
+(file-comment
+ "$Header$")
+
+(defun sort (sequence predicate &key key)
+ #!+sb-doc
+ "Destructively sorts sequence. Predicate should return non-Nil if
+ Arg1 is to precede Arg2."
+ (typecase sequence
+ (simple-vector
+ (if (> (the fixnum (length (the simple-vector sequence))) 0)
+ (sort-simple-vector sequence predicate key)
+ sequence))
+ (list
+ (sort-list sequence predicate key))
+ (vector
+ (if (> (the fixnum (length sequence)) 0)
+ (sort-vector sequence predicate key)
+ sequence))
+ (t
+ (error 'simple-type-error
+ :datum sequence
+ :expected-type 'sequence
+ :format-control "~S is not a sequence."
+ :format-arguments (list sequence)))))
+\f
+;;;; sorting vectors
+
+;;; Make simple-vector and miscellaneous vector sorting functions.
+(macrolet (;; BUILD-HEAP rearranges seq elements into a heap to start heap
+ ;; sorting.
+ (build-heap (seq type len-1 pred key)
+ (let ((i (gensym)))
+ `(do ((,i (floor ,len-1 2) (1- ,i)))
+ ((minusp ,i) ,seq)
+ (declare (fixnum ,i))
+ (heapify ,seq ,type ,i ,len-1 ,pred ,key))))
+ ;; HEAPIFY, assuming both sons of root are heaps, percolates the
+ ;; root element through the sons to form a heap at root. Root and
+ ;; max are zero based coordinates, but the heap algorithm only works
+ ;; on arrays indexed from 1 through N (not 0 through N-1); This is
+ ;; because a root at I has sons at 2*I and 2*I+1 which does not work
+ ;; for a root at 0. Because of this, boundaries, roots, and
+ ;; termination are computed using 1..N indexes.
+ (heapify (seq vector-ref root max pred key)
+ (let ((heap-root (gensym))
+ (heap-max (gensym))
+ (root-ele (gensym))
+ (root-key (gensym))
+ (heap-max/2 (gensym))
+ (heap-l-son (gensym))
+ (one-son (gensym))
+ (one-son-ele (gensym))
+ (one-son-key (gensym))
+ (r-son-ele (gensym))
+ (r-son-key (gensym))
+ (var-root (gensym)))
+ `(let* ((,var-root ,root) ; (necessary to not clobber calling
+ ; root var)
+ (,heap-root (1+ ,root))
+ (,heap-max (1+ ,max))
+ (,root-ele (,vector-ref ,seq ,root))
+ (,root-key (apply-key ,key ,root-ele))
+ (,heap-max/2 (ash ,heap-max -1))) ; (floor heap-max 2)
+ (declare (fixnum ,var-root ,heap-root ,heap-max ,heap-max/2))
+ (loop
+ (if (> ,heap-root ,heap-max/2) (return))
+ (let* ((,heap-l-son (ash ,heap-root 1)) ; (* 2 heap-root)
+ ;; l-son index in seq (0..N-1) is one less than heap
+ ;; computation.
+ (,one-son (1- ,heap-l-son))
+ (,one-son-ele (,vector-ref ,seq ,one-son))
+ (,one-son-key (apply-key ,key ,one-son-ele)))
+ (declare (fixnum ,heap-l-son ,one-son))
+ (if (< ,heap-l-son ,heap-max)
+ ;; There is a right son.
+ (let* ((,r-son-ele (,vector-ref ,seq ,heap-l-son))
+ (,r-son-key (apply-key ,key ,r-son-ele)))
+ ;; Choose the greater of the two sons.
+ (when (funcall ,pred ,one-son-key ,r-son-key)
+ (setf ,one-son ,heap-l-son)
+ (setf ,one-son-ele ,r-son-ele)
+ (setf ,one-son-key ,r-son-key))))
+ ;; If greater son is less than root, then we've formed a
+ ;; heap again..
+ (if (funcall ,pred ,one-son-key ,root-key) (return))
+ ;; ..else put greater son at root and make greater son
+ ;; node be the root.
+ (setf (,vector-ref ,seq ,var-root) ,one-son-ele)
+ (setf ,heap-root (1+ ,one-son)) ; (one plus to be in heap coordinates)
+ (setf ,var-root ,one-son))) ; actual index into vector for root ele
+ ;; Now really put percolated value into heap at the
+ ;; appropriate root node.
+ (setf (,vector-ref ,seq ,var-root) ,root-ele))))
+ (def-vector-sort-fun (fun-name vector-ref)
+ `(defun ,fun-name (seq pred key)
+ (let ((len-1 (1- (length (the vector seq)))))
+ (declare (fixnum len-1))
+ (build-heap seq ,vector-ref len-1 pred key)
+ (do* ((i len-1 i-1)
+ (i-1 (1- i) (1- i-1)))
+ ((zerop i) seq)
+ (declare (fixnum i i-1))
+ (rotatef (,vector-ref seq 0) (,vector-ref seq i))
+ (heapify seq ,vector-ref 0 i-1 pred key))))))
+ (def-vector-sort-fun sort-vector aref)
+ (def-vector-sort-fun sort-simple-vector svref))
+\f
+;;;; stable sorting
+
+(defun stable-sort (sequence predicate &key key)
+ #!+sb-doc
+ "Destructively sorts sequence. Predicate should return non-Nil if
+ Arg1 is to precede Arg2."
+ (typecase sequence
+ (simple-vector
+ (stable-sort-simple-vector sequence predicate key))
+ (list
+ (sort-list sequence predicate key))
+ (vector
+ (stable-sort-vector sequence predicate key))
+ (t
+ (error 'simple-type-error
+ :datum sequence
+ :expected-type 'sequence
+ :format-control "~S is not a sequence."
+ :format-arguments (list sequence)))))
+
+;;; stable sort of lists
+
+;;; SORT-LIST uses a bottom up merge sort. First a pass is made over the list
+;;; grabbing one element at a time and merging it with the next one form pairs
+;;; of sorted elements. Then n is doubled, and elements are taken in runs of
+;;; two, merging one run with the next to form quadruples of sorted elements.
+;;; This continues until n is large enough that the inner loop only runs for
+;;; one iteration; that is, there are only two runs that can be merged, the
+;;; first run starting at the beginning of the list, and the second being the
+;;; remaining elements.
+
+(defun sort-list (list pred key)
+ (let ((head (cons :header list)) ; head holds on to everything
+ (n 1) ; bottom-up size of lists to be merged
+ unsorted ; unsorted is the remaining list to be
+ ; broken into n size lists and merged
+ list-1 ; list-1 is one length n list to be merged
+ last) ; last points to the last visited cell
+ (declare (fixnum n))
+ (loop
+ ;; start collecting runs of n at the first element
+ (setf unsorted (cdr head))
+ ;; tack on the first merge of two n-runs to the head holder
+ (setf last head)
+ (let ((n-1 (1- n)))
+ (declare (fixnum n-1))
+ (loop
+ (setf list-1 unsorted)
+ (let ((temp (nthcdr n-1 list-1))
+ list-2)
+ (cond (temp
+ ;; there are enough elements for a second run
+ (setf list-2 (cdr temp))
+ (setf (cdr temp) nil)
+ (setf temp (nthcdr n-1 list-2))
+ (cond (temp
+ (setf unsorted (cdr temp))
+ (setf (cdr temp) nil))
+ ;; the second run goes off the end of the list
+ (t (setf unsorted nil)))
+ (multiple-value-bind (merged-head merged-last)
+ (merge-lists* list-1 list-2 pred key)
+ (setf (cdr last) merged-head)
+ (setf last merged-last))
+ (if (null unsorted) (return)))
+ ;; if there is only one run, then tack it on to the end
+ (t (setf (cdr last) list-1)
+ (return)))))
+ (setf n (ash n 1)) ; (+ n n)
+ ;; If the inner loop only executed once, then there were only enough
+ ;; elements for two runs given n, so all the elements have been merged
+ ;; into one list. This may waste one outer iteration to realize.
+ (if (eq list-1 (cdr head))
+ (return list-1))))))
+
+;;; APPLY-PRED saves us a function call sometimes.
+(eval-when (:compile-toplevel :execute)
+ (sb!xc:defmacro apply-pred (one two pred key)
+ `(if ,key
+ (funcall ,pred (funcall ,key ,one)
+ (funcall ,key ,two))
+ (funcall ,pred ,one ,two)))
+) ; EVAL-WHEN
+
+(defvar *merge-lists-header* (list :header))
+
+;;; MERGE-LISTS* originally written by Jim Large.
+;;; modified to return a pointer to the end of the result
+;;; and to not cons header each time its called.
+;;; It destructively merges list-1 with list-2. In the resulting
+;;; list, elements of list-2 are guaranteed to come after equal elements
+;;; of list-1.
+(defun merge-lists* (list-1 list-2 pred key)
+ (do* ((result *merge-lists-header*)
+ (P result)) ; points to last cell of result
+ ((or (null list-1) (null list-2)) ; done when either list used up
+ (if (null list-1) ; in which case, append the
+ (rplacd p list-2) ; other list
+ (rplacd p list-1))
+ (do ((drag p lead)
+ (lead (cdr p) (cdr lead)))
+ ((null lead)
+ (values (prog1 (cdr result) ; Return the result sans header
+ (rplacd result nil)) ; (free memory, be careful)
+ drag)))) ; and return pointer to last element.
+ (cond ((apply-pred (car list-2) (car list-1) pred key)
+ (rplacd p list-2) ; Append the lesser list to last cell of
+ (setq p (cdr p)) ; result. Note: test must bo done for
+ (pop list-2)) ; LIST-2 < LIST-1 so merge will be
+ (T (rplacd p list-1) ; stable for LIST-1.
+ (setq p (cdr p))
+ (pop list-1)))))
+
+;;; stable sort of vectors
+
+;;; Stable sorting vectors is done with the same algorithm used for
+;;; lists, using a temporary vector to merge back and forth between it
+;;; and the given vector to sort.
+
+(eval-when (:compile-toplevel :execute)
+
+;;; STABLE-SORT-MERGE-VECTORS* takes a source vector with subsequences,
+;;; start-1 (inclusive) ... end-1 (exclusive) and
+;;; end-1 (inclusive) ... end-2 (exclusive),
+;;; and merges them into a target vector starting at index start-1.
+
+(sb!xc:defmacro stable-sort-merge-vectors* (source target start-1 end-1 end-2
+ pred key source-ref
+ target-ref)
+ (let ((i (gensym))
+ (j (gensym))
+ (target-i (gensym)))
+ `(let ((,i ,start-1)
+ (,j ,end-1) ; start-2
+ (,target-i ,start-1))
+ (declare (fixnum ,i ,j ,target-i))
+ (loop
+ (cond ((= ,i ,end-1)
+ (loop (if (= ,j ,end-2) (return))
+ (setf (,target-ref ,target ,target-i)
+ (,source-ref ,source ,j))
+ (incf ,target-i)
+ (incf ,j))
+ (return))
+ ((= ,j ,end-2)
+ (loop (if (= ,i ,end-1) (return))
+ (setf (,target-ref ,target ,target-i)
+ (,source-ref ,source ,i))
+ (incf ,target-i)
+ (incf ,i))
+ (return))
+ ((apply-pred (,source-ref ,source ,j)
+ (,source-ref ,source ,i)
+ ,pred ,key)
+ (setf (,target-ref ,target ,target-i)
+ (,source-ref ,source ,j))
+ (incf ,j))
+ (t (setf (,target-ref ,target ,target-i)
+ (,source-ref ,source ,i))
+ (incf ,i)))
+ (incf ,target-i)))))
+
+;;; VECTOR-MERGE-SORT is the same algorithm used to stable sort lists, but
+;;; it uses a temporary vector. Direction determines whether we are merging
+;;; into the temporary (T) or back into the given vector (NIL).
+
+(sb!xc:defmacro vector-merge-sort (vector pred key vector-ref)
+ (let ((vector-len (gensym)) (n (gensym))
+ (direction (gensym)) (unsorted (gensym))
+ (start-1 (gensym)) (end-1 (gensym))
+ (end-2 (gensym)) (temp-len (gensym))
+ (i (gensym)))
+ `(let ((,vector-len (length (the vector ,vector)))
+ (,n 1) ; bottom-up size of contiguous runs to be merged
+ (,direction t) ; t vector --> temp nil temp --> vector
+ (,temp-len (length (the simple-vector *merge-sort-temp-vector*)))
+ (,unsorted 0) ; unsorted..vector-len are the elements that need
+ ; to be merged for a given n
+ (,start-1 0)) ; one n-len subsequence to be merged with the next
+ (declare (fixnum ,vector-len ,n ,temp-len ,unsorted ,start-1))
+ (if (> ,vector-len ,temp-len)
+ (setf *merge-sort-temp-vector*
+ (make-array (max ,vector-len (+ ,temp-len ,temp-len)))))
+ (loop
+ ;; for each n, we start taking n-runs from the start of the vector
+ (setf ,unsorted 0)
+ (loop
+ (setf ,start-1 ,unsorted)
+ (let ((,end-1 (+ ,start-1 ,n)))
+ (declare (fixnum ,end-1))
+ (cond ((< ,end-1 ,vector-len)
+ ;; there are enough elements for a second run
+ (let ((,end-2 (+ ,end-1 ,n)))
+ (declare (fixnum ,end-2))
+ (if (> ,end-2 ,vector-len) (setf ,end-2 ,vector-len))
+ (setf ,unsorted ,end-2)
+ (if ,direction
+ (stable-sort-merge-vectors*
+ ,vector *merge-sort-temp-vector*
+ ,start-1 ,end-1 ,end-2 ,pred ,key ,vector-ref svref)
+ (stable-sort-merge-vectors*
+ *merge-sort-temp-vector* ,vector
+ ,start-1 ,end-1 ,end-2 ,pred ,key svref ,vector-ref))
+ (if (= ,unsorted ,vector-len) (return))))
+ ;; if there is only one run, copy those elements to the end
+ (t (if ,direction
+ (do ((,i ,start-1 (1+ ,i)))
+ ((= ,i ,vector-len))
+ (declare (fixnum ,i))
+ (setf (svref *merge-sort-temp-vector* ,i)
+ (,vector-ref ,vector ,i)))
+ (do ((,i ,start-1 (1+ ,i)))
+ ((= ,i ,vector-len))
+ (declare (fixnum ,i))
+ (setf (,vector-ref ,vector ,i)
+ (svref *merge-sort-temp-vector* ,i))))
+ (return)))))
+ ;; If the inner loop only executed once, then there were only enough
+ ;; elements for two subsequences given n, so all the elements have
+ ;; been merged into one list. Start-1 will have remained 0 upon exit.
+ (when (zerop ,start-1)
+ (if ,direction
+ ;; if we just merged into the temporary, copy it all back
+ ;; to the given vector.
+ (dotimes (,i ,vector-len)
+ (setf (,vector-ref ,vector ,i)
+ (svref *merge-sort-temp-vector* ,i))))
+ (return ,vector))
+ (setf ,n (ash ,n 1)) ; (* 2 n)
+ (setf ,direction (not ,direction))))))
+
+) ; EVAL-when
+
+;;; Temporary vector for stable sorting vectors.
+(defvar *merge-sort-temp-vector*
+ (make-array 50))
+
+(declaim (simple-vector *merge-sort-temp-vector*))
+
+(defun stable-sort-simple-vector (vector pred key)
+ (declare (simple-vector vector))
+ (vector-merge-sort vector pred key svref))
+
+(defun stable-sort-vector (vector pred key)
+ (vector-merge-sort vector pred key aref))
+
+;;;; merging
+
+(eval-when (:compile-toplevel :execute)
+
+;;; MERGE-VECTORS returns a new vector which contains an interleaving
+;;; of the elements of vector-1 and vector-2. Elements from vector-2 are
+;;; chosen only if they are strictly less than elements of vector-1,
+;;; (pred elt-2 elt-1), as specified in the manual.
+
+(sb!xc:defmacro merge-vectors (vector-1 length-1 vector-2 length-2
+ result-vector pred key access)
+ (let ((result-i (gensym))
+ (i (gensym))
+ (j (gensym)))
+ `(let* ((,result-i 0)
+ (,i 0)
+ (,j 0))
+ (declare (fixnum ,result-i ,i ,j))
+ (loop
+ (cond ((= ,i ,length-1)
+ (loop (if (= ,j ,length-2) (return))
+ (setf (,access ,result-vector ,result-i)
+ (,access ,vector-2 ,j))
+ (incf ,result-i)
+ (incf ,j))
+ (return ,result-vector))
+ ((= ,j ,length-2)
+ (loop (if (= ,i ,length-1) (return))
+ (setf (,access ,result-vector ,result-i)
+ (,access ,vector-1 ,i))
+ (incf ,result-i)
+ (incf ,i))
+ (return ,result-vector))
+ ((apply-pred (,access ,vector-2 ,j) (,access ,vector-1 ,i)
+ ,pred ,key)
+ (setf (,access ,result-vector ,result-i)
+ (,access ,vector-2 ,j))
+ (incf ,j))
+ (t (setf (,access ,result-vector ,result-i)
+ (,access ,vector-1 ,i))
+ (incf ,i)))
+ (incf ,result-i)))))
+
+) ; EVAL-WHEN
+
+(defun merge (result-type sequence1 sequence2 predicate &key key)
+ #!+sb-doc
+ "The sequences Sequence1 and Sequence2 are destructively merged into
+ a sequence of type Result-Type using the Predicate to order the elements."
+ (if (eq result-type 'list)
+ (let ((result (merge-lists* (coerce sequence1 'list)
+ (coerce sequence2 'list)
+ predicate key)))
+ result)
+ (let* ((vector-1 (coerce sequence1 'vector))
+ (vector-2 (coerce sequence2 'vector))
+ (length-1 (length vector-1))
+ (length-2 (length vector-2))
+ (result (make-sequence-of-type result-type (+ length-1 length-2))))
+ (declare (vector vector-1 vector-2)
+ (fixnum length-1 length-2))
+
+ #!+high-security
+ (check-type-var result result-type)
+ (if (and (simple-vector-p result)
+ (simple-vector-p vector-1)
+ (simple-vector-p vector-2))
+ (merge-vectors vector-1 length-1 vector-2 length-2
+ result predicate key svref)
+ (merge-vectors vector-1 length-1 vector-2 length-2
+ result predicate key aref)))))
--- /dev/null
+;;;; a hack to suppress array specialization when building under the
+;;;; cross-compiler
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!KERNEL")
+
+(file-comment
+ "$Header$")
+
+;;; It's hard to dump specialized vectors portably, because ANSI
+;;; doesn't guarantee much about what specialized vectors exist.
+;;; Thus, if we do
+;;; (MAKE-ARRAY 10 :ELEMENT-TYPE '(UNSIGNED-BYTE 4))
+;;; in the cross-compilation host, we could easily end up with a
+;;; vector of (UNSIGNED-BYTE 8) or of T, and the dumped result would
+;;; reflect this.
+;;;
+;;; To reduce the prominence of this issue in cross-compilation, we
+;;; can use these types, which expands into a specialized vector type when
+;;; building the cross-compiler, and a SIMPLE-VECTOR otherwise.
+(deftype specializable (type)
+ #+sb-xc-host (declare (ignore type))
+ #+sb-xc-host t
+ #-sb-xc-host type)
+(deftype specializable-vector (element-type)
+ `(array (specializable ,element-type) 1))
+
+;;; MAKE-SPECIALIZABLE-ARRAY is MAKE-ARRAY, except that in the interests of
+;;; being able to dump the result without worrying about nonportable
+;;; dependences on what kinds of specialized vectors actually exist in the
+;;; cross-compilation host, any :ELEMENT-TYPE argument is discarded when
+;;; running under the cross-compilation host ANSI Common Lisp.
+#+sb-xc-host
+(defun make-specializable-array (dimensions
+ &rest rest
+ &key (element-type t)
+ &allow-other-keys)
+ (apply #'make-array
+ dimensions
+ (if (eq element-type t)
+ rest
+ (do ((reversed-modified-rest nil))
+ ((null rest) (nreverse reversed-modified-rest))
+ (let ((first (pop rest))
+ (second (pop rest)))
+ (when (eq first :element-type)
+ (setf second t))
+ (push first reversed-modified-rest)
+ (push second reversed-modified-rest))))))
+#-sb-xc-host
+(declaim #!-sb-fluid (inline make-specializable-array))
+#-sb-xc-host
+(defun make-specializable-array (&rest rest) (apply #'make-array rest))
--- /dev/null
+;;;; os-independent stream functions
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!IMPL")
+
+(file-comment
+ "$Header$")
+
+(deftype string-stream ()
+ '(or string-input-stream string-output-stream
+ fill-pointer-output-stream))
+
+;;;; standard streams
+
+;;; The initialization of these streams is performed by
+;;; STREAM-COLD-INIT-OR-RESET.
+(defvar *terminal-io* () #!+sb-doc "Terminal I/O stream.")
+(defvar *standard-input* () #!+sb-doc "Default input stream.")
+(defvar *standard-output* () #!+sb-doc "Default output stream.")
+(defvar *error-output* () #!+sb-doc "Error output stream.")
+(defvar *query-io* () #!+sb-doc "Query I/O stream.")
+(defvar *trace-output* () #!+sb-doc "Trace output stream.")
+(defvar *debug-io* () #!+sb-doc "Interactive debugging stream.")
+
+(defun ill-in (stream &rest ignore)
+ (declare (ignore ignore))
+ (error 'simple-type-error
+ :datum stream
+ :expected-type '(satisfies input-stream-p)
+ :format-control "~S is not a character input stream."
+ :format-arguments (list stream)))
+(defun ill-out (stream &rest ignore)
+ (declare (ignore ignore))
+ (error 'simple-type-error
+ :datum stream
+ :expected-type '(satisfies output-stream-p)
+ :format-control "~S is not a character output stream."
+ :format-arguments (list stream)))
+(defun ill-bin (stream &rest ignore)
+ (declare (ignore ignore))
+ (error 'simple-type-error
+ :datum stream
+ :expected-type '(satisfies input-stream-p)
+ :format-control "~S is not a binary input stream."
+ :format-arguments (list stream)))
+(defun ill-bout (stream &rest ignore)
+ (declare (ignore ignore))
+ (error 'simple-type-error
+ :datum stream
+ :expected-type '(satisfies output-stream-p)
+ :format-control "~S is not a binary output stream."
+ :format-arguments (list stream)))
+(defun closed-flame (stream &rest ignore)
+ (declare (ignore ignore))
+ (error "~S is closed." stream))
+(defun do-nothing (&rest ignore)
+ (declare (ignore ignore)))
+\f
+;;; HOW THE STREAM STRUCTURE IS USED:
+;;;
+;;; Many of the slots of the stream structure contain functions
+;;; which are called to perform some operation on the stream. Closed
+;;; streams have #'Closed-Flame in all of their function slots. If
+;;; one side of an I/O or echo stream is closed, the whole stream is
+;;; considered closed. The functions in the operation slots take
+;;; arguments as follows:
+;;;
+;;; In: Stream, Eof-Errorp, Eof-Value
+;;; Bin: Stream, Eof-Errorp, Eof-Value
+;;; N-Bin: Stream, Buffer, Start, Numbytes, Eof-Errorp
+;;; Out: Stream, Character
+;;; Bout: Stream, Integer
+;;; Sout: Stream, String, Start, End
+;;; Misc: Stream, Operation, &Optional Arg1, Arg2
+;;;
+;;; In order to save space, some of the less common stream operations
+;;; are handled by just one function, the Misc method. This function
+;;; is passed a keyword which indicates the operation to perform.
+;;; The following keywords are used:
+;;; :listen - Return the following values:
+;;; t if any input waiting.
+;;; :eof if at eof.
+;;; nil if no input is available and not at eof.
+;;; :unread - Unread the character Arg.
+;;; :close - Do any stream specific stuff to close the stream.
+;;; The methods are set to closed-flame by the close
+;;; function, so that need not be done by this
+;;; function.
+;;; :clear-input - Clear any unread input
+;;; :finish-output,
+;;; :force-output - Cause output to happen
+;;; :clear-output - Clear any undone output
+;;; :element-type - Return the type of element the stream deals wit<h.
+;;; :line-length - Return the length of a line of output.
+;;; :charpos - Return current output position on the line.
+;;; :file-length - Return the file length of a file stream.
+;;; :file-position - Return or change the current position of a file stream.
+;;; :file-name - Return the name of an associated file.
+;;; :interactive-p - Is this an interactive device?
+;;;
+;;; In order to do almost anything useful, it is necessary to
+;;; define a new type of structure that includes stream, so that the
+;;; stream can have some state information.
+;;;
+;;; THE STREAM IN-BUFFER:
+;;;
+;;; The In-Buffer in the stream holds characters or bytes that
+;;; are ready to be read by some input function. If there is any
+;;; stuff in the In-Buffer, then the reading function can use it
+;;; without calling any stream method. Any stream may put stuff in
+;;; the In-Buffer, and may also assume that any input in the In-Buffer
+;;; has been consumed before any in-method is called. If a text
+;;; stream has in In-Buffer, then the first character should not be
+;;; used to buffer normal input so that it is free for unreading into.
+;;;
+;;; The In-Buffer slot is a vector In-Buffer-Length long. The
+;;; In-Index is the index in the In-Buffer of the first available
+;;; object. The available objects are thus between In-Index and the
+;;; length of the In-Buffer.
+;;;
+;;; When this buffer is only accessed by the normal stream
+;;; functions, the number of function calls is halved, thus
+;;; potentially doubling the speed of simple operations. If the
+;;; Fast-Read-Char and Fast-Read-Byte macros are used, nearly all
+;;; function call overhead is removed, vastly speeding up these
+;;; important operations.
+;;;
+;;; If a stream does not have an In-Buffer, then the In-Buffer slot
+;;; must be nil, and the In-Index must be In-Buffer-Length. These are
+;;; the default values for the slots.
+\f
+;;; stream manipulation functions
+
+(defun input-stream-p (stream)
+ (declare (type stream stream))
+
+ #!+high-security
+ (when (synonym-stream-p stream)
+ (setf stream
+ (symbol-value (synonym-stream-symbol stream))))
+
+ (and (lisp-stream-p stream)
+ (not (eq (lisp-stream-in stream) #'closed-flame))
+ ;;; KLUDGE: It's probably not good to have EQ tests on function
+ ;;; values like this. What if someone's redefined the function?
+ ;;; Is there a better way? (Perhaps just VALID-FOR-INPUT and
+ ;;; VALID-FOR-OUTPUT flags? -- WHN 19990902
+ (or (not (eq (lisp-stream-in stream) #'ill-in))
+ (not (eq (lisp-stream-bin stream) #'ill-bin)))))
+
+(defun output-stream-p (stream)
+ (declare (type stream stream))
+
+ #!+high-security
+ (when (synonym-stream-p stream)
+ (setf stream (symbol-value
+ (synonym-stream-symbol stream))))
+
+ (and (lisp-stream-p stream)
+ (not (eq (lisp-stream-in stream) #'closed-flame))
+ (or (not (eq (lisp-stream-out stream) #'ill-out))
+ (not (eq (lisp-stream-bout stream) #'ill-bout)))))
+
+(defun open-stream-p (stream)
+ (declare (type stream stream))
+ (not (eq (lisp-stream-in stream) #'closed-flame)))
+
+(defun stream-element-type (stream)
+ (declare (type stream stream))
+ (funcall (lisp-stream-misc stream) stream :element-type))
+
+(defun interactive-stream-p (stream)
+ (declare (type stream stream))
+ (funcall (lisp-stream-misc stream) stream :interactive-p))
+
+(defun open-stream-p (stream)
+ (declare (type stream stream))
+ (not (eq (lisp-stream-in stream) #'closed-flame)))
+
+(defun close (stream &key abort)
+ (declare (type stream stream))
+ (when (open-stream-p stream)
+ (funcall (lisp-stream-misc stream) stream :close abort))
+ t)
+
+(defun set-closed-flame (stream)
+ (setf (lisp-stream-in stream) #'closed-flame)
+ (setf (lisp-stream-bin stream) #'closed-flame)
+ (setf (lisp-stream-n-bin stream) #'closed-flame)
+ (setf (lisp-stream-in stream) #'closed-flame)
+ (setf (lisp-stream-out stream) #'closed-flame)
+ (setf (lisp-stream-bout stream) #'closed-flame)
+ (setf (lisp-stream-sout stream) #'closed-flame)
+ (setf (lisp-stream-misc stream) #'closed-flame))
+\f
+;;;; file position and file length
+
+;;; Call the misc method with the :file-position operation.
+(defun file-position (stream &optional position)
+ (declare (type stream stream))
+ (declare (type (or index (member nil :start :end)) position))
+ (cond
+ (position
+ (setf (lisp-stream-in-index stream) in-buffer-length)
+ (funcall (lisp-stream-misc stream) stream :file-position position))
+ (t
+ (let ((res (funcall (lisp-stream-misc stream) stream :file-position nil)))
+ (when res (- res (- in-buffer-length (lisp-stream-in-index stream))))))))
+
+;;; declaration test functions
+
+#!+high-security
+(defun stream-associated-with-file (stream)
+ #!+sb-doc
+ "Tests if the stream is associated with a file"
+ (or (typep stream 'file-stream)
+ (and (synonym-stream-p stream)
+ (typep (symbol-value (synonym-stream-symbol stream))
+ 'file-stream))))
+
+;;; Like File-Position, only use :file-length.
+(defun file-length (stream)
+ (declare (type (or file-stream synonym-stream) stream))
+
+ #!+high-security
+ (check-type-var stream '(satisfies stream-associated-with-file)
+ "a stream associated with a file")
+
+ (funcall (lisp-stream-misc stream) stream :file-length))
+\f
+;;;; input functions
+
+(defun read-line (&optional (stream *standard-input*) (eof-error-p t) eof-value
+ recursive-p)
+ (declare (ignore recursive-p))
+ (let ((stream (in-synonym-of stream)))
+ (if (lisp-stream-p stream)
+ (prepare-for-fast-read-char stream
+ (let ((res (make-string 80))
+ (len 80)
+ (index 0))
+ (loop
+ (let ((ch (fast-read-char nil nil)))
+ (cond (ch
+ (when (char= ch #\newline)
+ (done-with-fast-read-char)
+ (return (values (shrink-vector res index) nil)))
+ (when (= index len)
+ (setq len (* len 2))
+ (let ((new (make-string len)))
+ (replace new res)
+ (setq res new)))
+ (setf (schar res index) ch)
+ (incf index))
+ ((zerop index)
+ (done-with-fast-read-char)
+ (return (values (eof-or-lose stream
+ eof-error-p
+ eof-value)
+ t)))
+ ;; Since FAST-READ-CHAR already hit the eof char, we
+ ;; shouldn't do another READ-CHAR.
+ (t
+ (done-with-fast-read-char)
+ (return (values (shrink-vector res index) t))))))))
+ ;; must be FUNDAMENTAL-STREAM
+ (multiple-value-bind (string eof) (stream-read-line stream)
+ (if (and eof (zerop (length string)))
+ (values (eof-or-lose stream eof-error-p eof-value) t)
+ (values string eof))))))
+
+;;; We proclaim them INLINE here, then proclaim them MAYBE-INLINE at EOF,
+;;; so, except in this file, they are not inline by default, but they can be.
+#!-sb-fluid (declaim (inline read-char unread-char read-byte listen))
+
+(defun read-char (&optional (stream *standard-input*)
+ (eof-error-p t)
+ eof-value
+ recursive-p)
+ (declare (ignore recursive-p))
+ (let ((stream (in-synonym-of stream)))
+ (if (lisp-stream-p stream)
+ (prepare-for-fast-read-char stream
+ (prog1
+ (fast-read-char eof-error-p eof-value)
+ (done-with-fast-read-char)))
+ ;; FUNDAMENTAL-STREAM
+ (let ((char (stream-read-char stream)))
+ (if (eq char :eof)
+ (eof-or-lose stream eof-error-p eof-value)
+ char)))))
+
+(defun unread-char (character &optional (stream *standard-input*))
+ (let ((stream (in-synonym-of stream)))
+ (if (lisp-stream-p stream)
+ (let ((index (1- (lisp-stream-in-index stream)))
+ (buffer (lisp-stream-in-buffer stream)))
+ (declare (fixnum index))
+ (when (minusp index) (error "Nothing to unread."))
+ (cond (buffer
+ (setf (aref buffer index) (char-code character))
+ (setf (lisp-stream-in-index stream) index))
+ (t
+ (funcall (lisp-stream-misc stream) stream
+ :unread character))))
+ ;; Fundamental-stream
+ (stream-unread-char stream character)))
+ nil)
+
+(defun peek-char (&optional (peek-type nil)
+ (stream *standard-input*)
+ (eof-error-p t)
+ eof-value recursive-p)
+
+ (let ((stream (in-synonym-of stream)))
+ (if (lisp-stream-p stream)
+ (let ((char (read-char stream eof-error-p eof-value)))
+ (cond ((eq char eof-value) char)
+ ((characterp peek-type)
+ (do ((char char (read-char stream eof-error-p eof-value)))
+ ((or (eq char eof-value) (char= char peek-type))
+ (unless (eq char eof-value)
+ (unread-char char stream))
+ char)))
+ ((eq peek-type t)
+ (do ((char char (read-char stream eof-error-p eof-value)))
+ ((or (eq char eof-value) (not (whitespace-char-p char)))
+ (unless (eq char eof-value)
+ (unread-char char stream))
+ char)))
+ (t
+ (unread-char char stream)
+ char)))
+ ;; Fundamental-stream.
+ (cond ((characterp peek-type)
+ (do ((char (stream-read-char stream) (stream-read-char stream)))
+ ((or (eq char :eof) (char= char peek-type))
+ (cond ((eq char :eof)
+ (eof-or-lose stream eof-error-p eof-value))
+ (t
+ (stream-unread-char stream char)
+ char)))))
+ ((eq peek-type t)
+ (do ((char (stream-read-char stream) (stream-read-char stream)))
+ ((or (eq char :eof) (not (whitespace-char-p char)))
+ (cond ((eq char :eof)
+ (eof-or-lose stream eof-error-p eof-value))
+ (t
+ (stream-unread-char stream char)
+ char)))))
+ (t
+ (let ((char (stream-peek-char stream)))
+ (if (eq char :eof)
+ (eof-or-lose stream eof-error-p eof-value)
+ char)))))))
+
+(defun listen (&optional (stream *standard-input*))
+ (let ((stream (in-synonym-of stream)))
+ (if (lisp-stream-p stream)
+ (or (/= (the fixnum (lisp-stream-in-index stream)) in-buffer-length)
+ ;; Test for t explicitly since misc methods return :eof sometimes.
+ (eq (funcall (lisp-stream-misc stream) stream :listen) t))
+ ;; Fundamental-stream.
+ (stream-listen stream))))
+
+(defun read-char-no-hang (&optional (stream *standard-input*)
+ (eof-error-p t)
+ eof-value
+ recursive-p)
+ (declare (ignore recursive-p))
+ (let ((stream (in-synonym-of stream)))
+ (if (lisp-stream-p stream)
+ (if (funcall (lisp-stream-misc stream) stream :listen)
+ ;; On t or :eof get READ-CHAR to do the work.
+ (read-char stream eof-error-p eof-value)
+ nil)
+ ;; Fundamental-stream.
+ (let ((char (stream-read-char-no-hang stream)))
+ (if (eq char :eof)
+ (eof-or-lose stream eof-error-p eof-value)
+ char)))))
+
+(defun clear-input (&optional (stream *standard-input*))
+ (let ((stream (in-synonym-of stream)))
+ (cond ((lisp-stream-p stream)
+ (setf (lisp-stream-in-index stream) in-buffer-length)
+ (funcall (lisp-stream-misc stream) stream :clear-input))
+ (t
+ (stream-clear-input stream))))
+ nil)
+\f
+(declaim (maybe-inline read-byte))
+(defun read-byte (stream &optional (eof-error-p t) eof-value)
+ (let ((stream (in-synonym-of stream)))
+ (if (lisp-stream-p stream)
+ (prepare-for-fast-read-byte stream
+ (prog1
+ (fast-read-byte eof-error-p eof-value t)
+ (done-with-fast-read-byte)))
+ ;; FUNDAMENTAL-STREAM
+ (let ((char (stream-read-byte stream)))
+ (if (eq char :eof)
+ (eof-or-lose stream eof-error-p eof-value)
+ char)))))
+
+;;; Read NUMBYTES bytes into BUFFER beginning at START, and return the
+;;; number of bytes read.
+;;;
+;;; Note: CMU CL's version of this had a special interpretation of EOF-ERROR-P
+;;; which SBCL does not have. (In the EOF-ERROR-P=NIL case, CMU CL's version
+;;; would return as soon as any data became available.) This could be useful
+;;; behavior for things like pipes in some cases, but it wasn't being used in
+;;; SBCL, so it was dropped. If we ever need it, it could be added later as a
+;;; new variant N-BIN method (perhaps N-BIN-ASAP?) or something.
+(defun read-n-bytes (stream buffer start numbytes &optional (eof-error-p t))
+ (declare (type lisp-stream stream)
+ (type index numbytes start)
+ (type (or (simple-array * (*)) system-area-pointer) buffer))
+ (let* ((stream (in-synonym-of stream lisp-stream))
+ (in-buffer (lisp-stream-in-buffer stream))
+ (index (lisp-stream-in-index stream))
+ (num-buffered (- in-buffer-length index)))
+ (declare (fixnum index num-buffered))
+ (cond
+ ((not in-buffer)
+ (funcall (lisp-stream-n-bin stream)
+ stream
+ buffer
+ start
+ numbytes
+ eof-error-p))
+ ((<= numbytes num-buffered)
+ (%primitive sb!c:byte-blt
+ in-buffer
+ index
+ buffer
+ start
+ (+ start numbytes))
+ (setf (lisp-stream-in-index stream) (+ index numbytes))
+ numbytes)
+ (t
+ (let ((end (+ start num-buffered)))
+ (%primitive sb!c:byte-blt in-buffer index buffer start end)
+ (setf (lisp-stream-in-index stream) in-buffer-length)
+ (+ (funcall (lisp-stream-n-bin stream)
+ stream
+ buffer
+ end
+ (- numbytes num-buffered)
+ eof-error-p)
+ num-buffered))))))
+
+;;; the amount of space we leave at the start of the in-buffer for unreading
+;;;
+;;; (It's 4 instead of 1 to allow word-aligned copies.)
+(defconstant in-buffer-extra 4) ; FIXME: should be symbolic constant
+
+;;; This function is called by the fast-read-char expansion to refill the
+;;; in-buffer for text streams. There is definitely an in-buffer, and hence
+;;; must be an n-bin method.
+(defun fast-read-char-refill (stream eof-error-p eof-value)
+ (let* ((ibuf (lisp-stream-in-buffer stream))
+ (count (funcall (lisp-stream-n-bin stream)
+ stream
+ ibuf
+ in-buffer-extra
+ (- in-buffer-length in-buffer-extra)
+ nil))
+ (start (- in-buffer-length count)))
+ (declare (type index start count))
+ (cond ((zerop count)
+ (setf (lisp-stream-in-index stream) in-buffer-length)
+ (funcall (lisp-stream-in stream) stream eof-error-p eof-value))
+ (t
+ (when (/= start in-buffer-extra)
+ (bit-bash-copy ibuf (+ (* in-buffer-extra sb!vm:byte-bits)
+ (* sb!vm:vector-data-offset
+ sb!vm:word-bits))
+ ibuf (+ (the index (* start sb!vm:byte-bits))
+ (* sb!vm:vector-data-offset
+ sb!vm:word-bits))
+ (* count sb!vm:byte-bits)))
+ (setf (lisp-stream-in-index stream) (1+ start))
+ (code-char (aref ibuf start))))))
+
+;;; Similar to FAST-READ-CHAR-REFILL, but we don't have to leave room for
+;;; unreading.
+(defun fast-read-byte-refill (stream eof-error-p eof-value)
+ (let* ((ibuf (lisp-stream-in-buffer stream))
+ (count (funcall (lisp-stream-n-bin stream) stream
+ ibuf 0 in-buffer-length
+ nil))
+ (start (- in-buffer-length count)))
+ (declare (type index start count))
+ (cond ((zerop count)
+ (setf (lisp-stream-in-index stream) in-buffer-length)
+ (funcall (lisp-stream-bin stream) stream eof-error-p eof-value))
+ (t
+ (unless (zerop start)
+ (bit-bash-copy ibuf (* sb!vm:vector-data-offset sb!vm:word-bits)
+ ibuf (+ (the index (* start sb!vm:byte-bits))
+ (* sb!vm:vector-data-offset
+ sb!vm:word-bits))
+ (* count sb!vm:byte-bits)))
+ (setf (lisp-stream-in-index stream) (1+ start))
+ (aref ibuf start)))))
+\f
+;;; output functions
+
+(defun write-char (character &optional (stream *standard-output*))
+ (with-out-stream stream (lisp-stream-out character)
+ (stream-write-char character))
+ character)
+
+(defun terpri (&optional (stream *standard-output*))
+ (with-out-stream stream (lisp-stream-out #\newline) (stream-terpri))
+ nil)
+
+(defun fresh-line (&optional (stream *standard-output*))
+ (let ((stream (out-synonym-of stream)))
+ (if (lisp-stream-p stream)
+ (when (/= (or (charpos stream) 1) 0)
+ (funcall (lisp-stream-out stream) stream #\newline)
+ t)
+ ;; Fundamental-stream.
+ (stream-fresh-line stream))))
+
+(defun write-string (string &optional (stream *standard-output*)
+ &key (start 0) (end (length (the vector string))))
+
+ ;; FIXME: These SETFs don't look right to me. Looking at the definition
+ ;; of "bounding indices" in the glossary of the ANSI spec, and extrapolating
+ ;; from the behavior of other operations when their operands are the
+ ;; wrong type, it seems that it would be more correct to essentially
+ ;; (ASSERT (<= 0 START END (LENGTH STRING)))
+ ;; instead of modifying the incorrect values.
+ #!+high-security
+ (setf end (min end (length (the vector string))))
+ #!+high-security
+ (setf start (max start 0))
+
+ ;; FIXME: And I'd just signal a non-continuable error..
+ #!+high-security
+ (when (< end start)
+ (cerror "Continue with switched start and end ~S <-> ~S"
+ "Write-string: start (~S) and end (~S) exchanged."
+ start end string)
+ (rotatef start end))
+
+ (write-string* string stream start end))
+
+(defun write-string* (string &optional (stream *standard-output*)
+ (start 0) (end (length (the vector string))))
+ (declare (fixnum start end))
+ (let ((stream (out-synonym-of stream)))
+ (cond ((lisp-stream-p stream)
+ (if (array-header-p string)
+ (with-array-data ((data string) (offset-start start)
+ (offset-end end))
+ (funcall (lisp-stream-sout stream)
+ stream data offset-start offset-end))
+ (funcall (lisp-stream-sout stream) stream string start end))
+ string)
+ (t ; Fundamental-stream.
+ (stream-write-string stream string start end)))))
+
+(defun write-line (string &optional (stream *standard-output*)
+ &key (start 0) (end (length string)))
+ (write-line* string stream start end))
+
+(defun write-line* (string &optional (stream *standard-output*)
+ (start 0) (end (length string)))
+ (declare (fixnum start end))
+ (let ((stream (out-synonym-of stream)))
+ (cond ((lisp-stream-p stream)
+ (if (array-header-p string)
+ (with-array-data ((data string) (offset-start start)
+ (offset-end end))
+ (with-out-stream stream (lisp-stream-sout data offset-start
+ offset-end)))
+ (with-out-stream stream (lisp-stream-sout string start end)))
+ (funcall (lisp-stream-out stream) stream #\newline))
+ (t ; Fundamental-stream.
+ (stream-write-string stream string start end)
+ (stream-write-char stream #\Newline)))
+ string))
+
+(defun charpos (&optional (stream *standard-output*))
+ (with-out-stream stream (lisp-stream-misc :charpos) (stream-line-column)))
+
+(defun line-length (&optional (stream *standard-output*))
+ (with-out-stream stream (lisp-stream-misc :line-length)
+ (stream-line-length)))
+
+(defun finish-output (&optional (stream *standard-output*))
+ (with-out-stream stream (lisp-stream-misc :finish-output)
+ (stream-finish-output))
+ nil)
+
+(defun force-output (&optional (stream *standard-output*))
+ (with-out-stream stream (lisp-stream-misc :force-output)
+ (stream-force-output))
+ nil)
+
+(defun clear-output (&optional (stream *standard-output*))
+ (with-out-stream stream (lisp-stream-misc :clear-output)
+ (stream-force-output))
+ nil)
+
+(defun write-byte (integer stream)
+ (with-out-stream stream (lisp-stream-bout integer) (stream-write-byte))
+ integer)
+\f
+;;; Stream-misc-dispatch
+;;;
+;;; Called from lisp-steam routines that encapsulate CLOS streams to
+;;; handle the misc routines and dispatch to the appropriate Gray
+;;; stream functions.
+(defun stream-misc-dispatch (stream operation &optional arg1 arg2)
+ (declare (type fundamental-stream stream)
+ (ignore arg2))
+ (case operation
+ (:listen
+ ;; Return true is input available, :eof for eof-of-file, otherwise Nil.
+ (let ((char (stream-read-char-no-hang stream)))
+ (when (characterp char)
+ (stream-unread-char stream char))
+ char))
+ (:unread
+ (stream-unread-char stream arg1))
+ (:close
+ (close stream))
+ (:clear-input
+ (stream-clear-input stream))
+ (:force-output
+ (stream-force-output stream))
+ (:finish-output
+ (stream-finish-output stream))
+ (:element-type
+ (stream-element-type stream))
+ (:interactive-p
+ (interactive-stream-p stream))
+ (:line-length
+ (stream-line-length stream))
+ (:charpos
+ (stream-line-column stream))
+ (:file-length
+ (file-length stream))
+ (:file-position
+ (file-position stream arg1))))
+\f
+;;;; broadcast streams
+
+(defstruct (broadcast-stream (:include lisp-stream
+ (out #'broadcast-out)
+ (bout #'broadcast-bout)
+ (sout #'broadcast-sout)
+ (misc #'broadcast-misc))
+ (:constructor #!-high-security-support
+ make-broadcast-stream
+ #!+high-security-support
+ %make-broadcast-stream (&rest streams)))
+ ;; This is a list of all the streams we broadcast to.
+ (streams () :type list :read-only t))
+
+#!+high-security-support
+(defun make-broadcast-stream (&rest streams)
+ (dolist (stream streams)
+ (unless (or (and (synonym-stream-p stream)
+ (output-stream-p (symbol-value
+ (synonym-stream-symbol stream))))
+ (output-stream-p stream))
+ (error 'type-error
+ :datum stream
+ :expected-type '(satisfies output-stream-p))))
+ (apply #'%make-broadcast-stream streams))
+
+(macrolet ((out-fun (fun method stream-method &rest args)
+ `(defun ,fun (stream ,@args)
+ (dolist (stream (broadcast-stream-streams stream))
+ (if (lisp-stream-p stream)
+ (funcall (,method stream) stream ,@args)
+ (,stream-method stream ,@args))))))
+ (out-fun broadcast-out lisp-stream-out stream-write-char char)
+ (out-fun broadcast-bout lisp-stream-bout stream-write-byte byte)
+ (out-fun broadcast-sout lisp-stream-sout stream-write-string
+ string start end))
+
+(defun broadcast-misc (stream operation &optional arg1 arg2)
+ (let ((streams (broadcast-stream-streams stream)))
+ (case operation
+ (:charpos
+ (dolist (stream streams)
+ (let ((charpos (charpos stream)))
+ (if charpos (return charpos)))))
+ (:line-length
+ (let ((min nil))
+ (dolist (stream streams min)
+ (let ((res (line-length stream)))
+ (when res (setq min (if min (min res min) res)))))))
+ (:element-type
+ (let (res)
+ (dolist (stream streams (if (> (length res) 1) `(and ,@res) res))
+ (pushnew (stream-element-type stream) res :test #'equal))))
+ (:close)
+ (t
+ (let ((res nil))
+ (dolist (stream streams res)
+ (setq res
+ (if (lisp-stream-p stream)
+ (funcall (lisp-stream-misc stream) stream operation
+ arg1 arg2)
+ (stream-misc-dispatch stream operation arg1 arg2)))))))))
+\f
+;;;; synonym streams
+
+(defstruct (synonym-stream (:include lisp-stream
+ (in #'synonym-in)
+ (bin #'synonym-bin)
+ (n-bin #'synonym-n-bin)
+ (out #'synonym-out)
+ (bout #'synonym-bout)
+ (sout #'synonym-sout)
+ (misc #'synonym-misc))
+ (:constructor make-synonym-stream (symbol)))
+ ;; This is the symbol, the value of which is the stream we are synonym to.
+ (symbol nil :type symbol :read-only t))
+(def!method print-object ((x synonym-stream) stream)
+ (print-unreadable-object (x stream :type t :identity t)
+ (format stream ":SYMBOL ~S" (synonym-stream-symbol x))))
+
+;;; The output simple output methods just call the corresponding method
+;;; in the synonymed stream.
+(macrolet ((out-fun (name slot stream-method &rest args)
+ `(defun ,name (stream ,@args)
+ (declare (optimize (safety 1)))
+ (let ((syn (symbol-value (synonym-stream-symbol stream))))
+ (if (lisp-stream-p syn)
+ (funcall (,slot syn) syn ,@args)
+ (,stream-method syn ,@args))))))
+ (out-fun synonym-out lisp-stream-out stream-write-char ch)
+ (out-fun synonym-bout lisp-stream-bout stream-write-byte n)
+ (out-fun synonym-sout lisp-stream-sout stream-write-string string start end))
+
+;;; For the input methods, we just call the corresponding function on the
+;;; synonymed stream. These functions deal with getting input out of
+;;; the In-Buffer if there is any.
+(macrolet ((in-fun (name fun &rest args)
+ `(defun ,name (stream ,@args)
+ (declare (optimize (safety 1)))
+ (,fun (symbol-value (synonym-stream-symbol stream))
+ ,@args))))
+ (in-fun synonym-in read-char eof-error-p eof-value)
+ (in-fun synonym-bin read-byte eof-error-p eof-value)
+ (in-fun synonym-n-bin read-n-bytes buffer start numbytes eof-error-p))
+
+;;; We have to special-case the operations which could look at stuff in
+;;; the in-buffer.
+(defun synonym-misc (stream operation &optional arg1 arg2)
+ (declare (optimize (safety 1)))
+ (let ((syn (symbol-value (synonym-stream-symbol stream))))
+ (if (lisp-stream-p syn)
+ (case operation
+ (:listen (or (/= (the fixnum (lisp-stream-in-index syn))
+ in-buffer-length)
+ (funcall (lisp-stream-misc syn) syn :listen)))
+ (t
+ (funcall (lisp-stream-misc syn) syn operation arg1 arg2)))
+ (stream-misc-dispatch syn operation arg1 arg2))))
+\f
+;;;; two-way streams
+
+(defstruct (two-way-stream
+ (:include lisp-stream
+ (in #'two-way-in)
+ (bin #'two-way-bin)
+ (n-bin #'two-way-n-bin)
+ (out #'two-way-out)
+ (bout #'two-way-bout)
+ (sout #'two-way-sout)
+ (misc #'two-way-misc))
+ (:constructor #!-high-security-support
+ make-two-way-stream
+ #!+high-security-support
+ %make-two-way-stream (input-stream output-stream)))
+ (input-stream (required-argument) :type stream :read-only t)
+ (output-stream (required-argument) :type stream :read-only t))
+(def!method print-object ((x two-way-stream) stream)
+ (print-unreadable-object (x stream :type t :identity t)
+ (format stream
+ ":INPUT-STREAM ~S :OUTPUT-STREAM ~S"
+ (two-way-stream-input-stream x)
+ (two-way-stream-output-stream x))))
+
+#!-high-security-support
+(setf (fdocumentation 'make-two-way-stream 'function)
+ "Returns a bidirectional stream which gets its input from Input-Stream and
+ sends its output to Output-Stream.")
+#!+high-security-support
+(defun make-two-way-stream (input-stream output-stream)
+ #!+sb-doc
+ "Returns a bidirectional stream which gets its input from Input-Stream and
+ sends its output to Output-Stream."
+ ;; FIXME: This idiom of the-real-stream-of-a-possibly-synonym-stream
+ ;; should be encapsulated in a function, and used here and most of
+ ;; the other places that SYNONYM-STREAM-P appears.
+ (unless (or (and (synonym-stream-p output-stream)
+ (output-stream-p (symbol-value
+ (synonym-stream-symbol output-stream))))
+ (output-stream-p output-stream))
+ (error 'type-error
+ :datum output-stream
+ :expected-type '(satisfies output-stream-p)))
+ (unless (or (and (synonym-stream-p input-stream)
+ (input-stream-p (symbol-value
+ (synonym-stream-symbol input-stream))))
+ (input-stream-p input-stream))
+ (error 'type-error
+ :datum input-stream
+ :expected-type '(satisfies input-stream-p)))
+ (funcall #'%make-two-way-stream input-stream output-stream))
+
+(macrolet ((out-fun (name slot stream-method &rest args)
+ `(defun ,name (stream ,@args)
+ (let ((syn (two-way-stream-output-stream stream)))
+ (if (lisp-stream-p syn)
+ (funcall (,slot syn) syn ,@args)
+ (,stream-method syn ,@args))))))
+ (out-fun two-way-out lisp-stream-out stream-write-char ch)
+ (out-fun two-way-bout lisp-stream-bout stream-write-byte n)
+ (out-fun two-way-sout lisp-stream-sout stream-write-string string start end))
+
+(macrolet ((in-fun (name fun &rest args)
+ `(defun ,name (stream ,@args)
+ (force-output (two-way-stream-output-stream stream))
+ (,fun (two-way-stream-input-stream stream) ,@args))))
+ (in-fun two-way-in read-char eof-error-p eof-value)
+ (in-fun two-way-bin read-byte eof-error-p eof-value)
+ (in-fun two-way-n-bin read-n-bytes buffer start numbytes eof-error-p))
+
+(defun two-way-misc (stream operation &optional arg1 arg2)
+ (let* ((in (two-way-stream-input-stream stream))
+ (out (two-way-stream-output-stream stream))
+ (in-lisp-stream-p (lisp-stream-p in))
+ (out-lisp-stream-p (lisp-stream-p out)))
+ (case operation
+ (:listen
+ (if in-lisp-stream-p
+ (or (/= (the fixnum (lisp-stream-in-index in)) in-buffer-length)
+ (funcall (lisp-stream-misc in) in :listen))
+ (stream-listen in)))
+ ((:finish-output :force-output :clear-output)
+ (if out-lisp-stream-p
+ (funcall (lisp-stream-misc out) out operation arg1 arg2)
+ (stream-misc-dispatch out operation arg1 arg2)))
+ ((:clear-input :unread)
+ (if in-lisp-stream-p
+ (funcall (lisp-stream-misc in) in operation arg1 arg2)
+ (stream-misc-dispatch in operation arg1 arg2)))
+ (:element-type
+ (let ((in-type (stream-element-type in))
+ (out-type (stream-element-type out)))
+ (if (equal in-type out-type)
+ in-type `(and ,in-type ,out-type))))
+ (:close
+ (set-closed-flame stream))
+ (t
+ (or (if in-lisp-stream-p
+ (funcall (lisp-stream-misc in) in operation arg1 arg2)
+ (stream-misc-dispatch in operation arg1 arg2))
+ (if out-lisp-stream-p
+ (funcall (lisp-stream-misc out) out operation arg1 arg2)
+ (stream-misc-dispatch out operation arg1 arg2)))))))
+\f
+;;;; concatenated streams
+
+(defstruct (concatenated-stream
+ (:include lisp-stream
+ (in #'concatenated-in)
+ (bin #'concatenated-bin)
+ (misc #'concatenated-misc))
+ (:constructor
+ #!-high-security-support make-concatenated-stream
+ #!+high-security-support %make-concatenated-stream
+ (&rest streams &aux (current streams))))
+ ;; The car of this is the stream we are reading from now.
+ current
+ ;; This is a list of all the streams. We need to remember them so that
+ ;; we can close them.
+ ;;
+ ;; FIXME: ANSI says this is supposed to be the list of streams that
+ ;; we still have to read from. So either this needs to become a
+ ;; private member %STREAM (with CONCATENATED-STREAM-STREAMS a wrapper
+ ;; around it which discards closed files from the head of the list)
+ ;; or we need to update it as we run out of files.
+ (streams nil :type list :read-only t))
+(def!method print-object ((x concatenated-stream) stream)
+ (print-unreadable-object (x stream :type t :identity t)
+ (format stream
+ ":STREAMS ~S"
+ (concatenated-stream-streams x))))
+
+#!-high-security-support
+(setf (fdocumentation 'make-concatenated-stream 'function)
+ "Returns a stream which takes its input from each of the Streams in turn,
+ going on to the next at EOF.")
+
+#!+high-security-support
+(defun make-concatenated-stream (&rest streams)
+ #!+sb-doc
+ "Returns a stream which takes its input from each of the Streams in turn,
+ going on to the next at EOF."
+ (dolist (stream streams)
+ (unless (or (and (synonym-stream-p stream)
+ (input-stream-p (symbol-value
+ (synonym-stream-symbol stream))))
+ (input-stream-p stream))
+ (error 'type-error
+ :datum stream
+ :expected-type '(satisfies input-stream-p))))
+ (apply #'%make-concatenated-stream streams))
+
+(macrolet ((in-fun (name fun)
+ `(defun ,name (stream eof-error-p eof-value)
+ (do ((current (concatenated-stream-current stream) (cdr current)))
+ ((null current)
+ (eof-or-lose stream eof-error-p eof-value))
+ (let* ((stream (car current))
+ (result (,fun stream nil nil)))
+ (when result (return result)))
+ (setf (concatenated-stream-current stream) current)))))
+ (in-fun concatenated-in read-char)
+ (in-fun concatenated-bin read-byte))
+
+(defun concatenated-misc (stream operation &optional arg1 arg2)
+ (let ((left (concatenated-stream-current stream)))
+ (when left
+ (let* ((current (car left)))
+ (case operation
+ (:listen
+ (loop
+ (let ((stuff (if (lisp-stream-p current)
+ (funcall (lisp-stream-misc current) current
+ :listen)
+ (stream-misc-dispatch current :listen))))
+ (cond ((eq stuff :eof)
+ ;; Advance current, and try again.
+ (pop (concatenated-stream-current stream))
+ (setf current
+ (car (concatenated-stream-current stream)))
+ (unless current
+ ;; No further streams. EOF.
+ (return :eof)))
+ (stuff
+ ;; Stuff's available.
+ (return t))
+ (t
+ ;; Nothing available yet.
+ (return nil))))))
+ (:close
+ (set-closed-flame stream))
+ (t
+ (if (lisp-stream-p current)
+ (funcall (lisp-stream-misc current) current operation arg1 arg2)
+ (stream-misc-dispatch current operation arg1 arg2))))))))
+\f
+;;;; echo streams
+
+(defstruct (echo-stream
+ (:include two-way-stream
+ (in #'echo-in)
+ (bin #'echo-bin)
+ (misc #'echo-misc)
+ (n-bin #'ill-bin))
+ (:constructor make-echo-stream (input-stream output-stream)))
+ unread-stuff)
+(def!method print-object ((x echo-stream) stream)
+ (print-unreadable-object (x stream :type t :identity t)
+ (format stream
+ ":INPUT-STREAM ~S :OUTPUT-STREAM ~S"
+ (two-way-stream-input-stream x)
+ (two-way-stream-output-stream x))))
+
+(macrolet ((in-fun (name fun out-slot stream-method &rest args)
+ `(defun ,name (stream ,@args)
+ (or (pop (echo-stream-unread-stuff stream))
+ (let* ((in (echo-stream-input-stream stream))
+ (out (echo-stream-output-stream stream))
+ (result (,fun in ,@args)))
+ (if (lisp-stream-p out)
+ (funcall (,out-slot out) out result)
+ (,stream-method out result))
+ result)))))
+ (in-fun echo-in read-char lisp-stream-out stream-write-char
+ eof-error-p eof-value)
+ (in-fun echo-bin read-byte lisp-stream-bout stream-write-byte
+ eof-error-p eof-value))
+
+(defun echo-misc (stream operation &optional arg1 arg2)
+ (let* ((in (two-way-stream-input-stream stream))
+ (out (two-way-stream-output-stream stream)))
+ (case operation
+ (:listen
+ (or (not (null (echo-stream-unread-stuff stream)))
+ (if (lisp-stream-p in)
+ (or (/= (the fixnum (lisp-stream-in-index in)) in-buffer-length)
+ (funcall (lisp-stream-misc in) in :listen))
+ (stream-misc-dispatch in :listen))))
+ (:unread (push arg1 (echo-stream-unread-stuff stream)))
+ (:element-type
+ (let ((in-type (stream-element-type in))
+ (out-type (stream-element-type out)))
+ (if (equal in-type out-type)
+ in-type `(and ,in-type ,out-type))))
+ (:close
+ (set-closed-flame stream))
+ (t
+ (or (if (lisp-stream-p in)
+ (funcall (lisp-stream-misc in) in operation arg1 arg2)
+ (stream-misc-dispatch in operation arg1 arg2))
+ (if (lisp-stream-p out)
+ (funcall (lisp-stream-misc out) out operation arg1 arg2)
+ (stream-misc-dispatch out operation arg1 arg2)))))))
+
+#!+sb-doc
+(setf (fdocumentation 'make-echo-stream 'function)
+ "Returns a bidirectional stream which gets its input from Input-Stream and
+ sends its output to Output-Stream. In addition, all input is echoed to
+ the output stream")
+\f
+;;;; string input streams
+
+(defstruct (string-input-stream
+ (:include lisp-stream
+ (in #'string-inch)
+ (bin #'string-binch)
+ (n-bin #'string-stream-read-n-bytes)
+ (misc #'string-in-misc))
+ (:constructor internal-make-string-input-stream
+ (string current end)))
+ (string nil :type simple-string)
+ (current nil :type index)
+ (end nil :type index))
+
+(defun string-inch (stream eof-error-p eof-value)
+ (let ((string (string-input-stream-string stream))
+ (index (string-input-stream-current stream)))
+ (declare (simple-string string) (fixnum index))
+ (cond ((= index (the index (string-input-stream-end stream)))
+ (eof-or-lose stream eof-error-p eof-value))
+ (t
+ (setf (string-input-stream-current stream) (1+ index))
+ (aref string index)))))
+
+(defun string-binch (stream eof-error-p eof-value)
+ (let ((string (string-input-stream-string stream))
+ (index (string-input-stream-current stream)))
+ (declare (simple-string string)
+ (type index index))
+ (cond ((= index (the index (string-input-stream-end stream)))
+ (eof-or-lose stream eof-error-p eof-value))
+ (t
+ (setf (string-input-stream-current stream) (1+ index))
+ (char-code (aref string index))))))
+
+(defun string-stream-read-n-bytes (stream buffer start requested eof-error-p)
+ (declare (type string-input-stream stream)
+ (type index start requested))
+ (let* ((string (string-input-stream-string stream))
+ (index (string-input-stream-current stream))
+ (available (- (string-input-stream-end stream) index))
+ (copy (min available requested)))
+ (declare (simple-string string)
+ (type index index available copy))
+ (when (plusp copy)
+ (setf (string-input-stream-current stream)
+ (truly-the index (+ index copy)))
+ (sb!sys:without-gcing
+ (system-area-copy (vector-sap string)
+ (* index sb!vm:byte-bits)
+ (if (typep buffer 'system-area-pointer)
+ buffer
+ (vector-sap buffer))
+ (* start sb!vm:byte-bits)
+ (* copy sb!vm:byte-bits))))
+ (if (and (> requested copy) eof-error-p)
+ (error 'end-of-file :stream stream)
+ copy)))
+
+(defun string-in-misc (stream operation &optional arg1 arg2)
+ (declare (ignore arg2))
+ (case operation
+ (:file-position
+ (if arg1
+ (setf (string-input-stream-current stream) arg1)
+ (string-input-stream-current stream)))
+ (:file-length (length (string-input-stream-string stream)))
+ (:unread (decf (string-input-stream-current stream)))
+ (:listen (or (/= (the fixnum (string-input-stream-current stream))
+ (the fixnum (string-input-stream-end stream)))
+ :eof))
+ (:element-type 'base-char)))
+
+(defun make-string-input-stream (string &optional
+ (start 0) (end (length string)))
+ #!+sb-doc
+ "Returns an input stream which will supply the characters of String between
+ Start and End in order."
+ (declare (type string string)
+ (type index start)
+ (type (or index null) end))
+
+ #!+high-security
+ (when (> end (length string))
+ (cerror "Continue with end changed from ~S to ~S"
+ "Write-string: end (~S) is larger then the length of the string (~S)"
+ end (1- (length string))))
+
+ (internal-make-string-input-stream (coerce string 'simple-string)
+ start end))
+\f
+;;;; string output streams
+
+(defstruct (string-output-stream
+ (:include lisp-stream
+ (out #'string-ouch)
+ (sout #'string-sout)
+ (misc #'string-out-misc))
+ (:constructor make-string-output-stream ()))
+ ;; The string we throw stuff in.
+ (string (make-string 40) :type simple-string)
+ ;; Index of the next location to use.
+ (index 0 :type fixnum))
+
+#!+sb-doc
+(setf (fdocumentation 'make-string-output-stream 'function)
+ "Returns an Output stream which will accumulate all output given it for
+ the benefit of the function Get-Output-Stream-String.")
+
+(defun string-ouch (stream character)
+ (let ((current (string-output-stream-index stream))
+ (workspace (string-output-stream-string stream)))
+ (declare (simple-string workspace) (fixnum current))
+ (if (= current (the fixnum (length workspace)))
+ (let ((new-workspace (make-string (* current 2))))
+ (replace new-workspace workspace)
+ (setf (aref new-workspace current) character)
+ (setf (string-output-stream-string stream) new-workspace))
+ (setf (aref workspace current) character))
+ (setf (string-output-stream-index stream) (1+ current))))
+
+(defun string-sout (stream string start end)
+ (declare (simple-string string) (fixnum start end))
+ (let* ((current (string-output-stream-index stream))
+ (length (- end start))
+ (dst-end (+ length current))
+ (workspace (string-output-stream-string stream)))
+ (declare (simple-string workspace)
+ (fixnum current length dst-end))
+ (if (> dst-end (the fixnum (length workspace)))
+ (let ((new-workspace (make-string (+ (* current 2) length))))
+ (replace new-workspace workspace :end2 current)
+ (replace new-workspace string
+ :start1 current :end1 dst-end
+ :start2 start :end2 end)
+ (setf (string-output-stream-string stream) new-workspace))
+ (replace workspace string
+ :start1 current :end1 dst-end
+ :start2 start :end2 end))
+ (setf (string-output-stream-index stream) dst-end)))
+
+(defun string-out-misc (stream operation &optional arg1 arg2)
+ (declare (ignore arg2))
+ (case operation
+ (:file-position
+ (if (null arg1)
+ (string-output-stream-index stream)))
+ (:charpos
+ (do ((index (1- (the fixnum (string-output-stream-index stream)))
+ (1- index))
+ (count 0 (1+ count))
+ (string (string-output-stream-string stream)))
+ ((< index 0) count)
+ (declare (simple-string string)
+ (fixnum index count))
+ (if (char= (schar string index) #\newline)
+ (return count))))
+ (:element-type 'base-char)))
+
+(defun get-output-stream-string (stream)
+ #!+sb-doc
+ "Returns a string of all the characters sent to a stream made by
+ Make-String-Output-Stream since the last call to this function."
+ (declare (type string-output-stream stream))
+ (let* ((length (string-output-stream-index stream))
+ (result (make-string length)))
+ (replace result (string-output-stream-string stream))
+ (setf (string-output-stream-index stream) 0)
+ result))
+
+(defun dump-output-stream-string (in-stream out-stream)
+ #!+sb-doc
+ "Dumps the characters buffer up in the In-Stream to the Out-Stream as
+ Get-Output-Stream-String would return them."
+ (write-string* (string-output-stream-string in-stream) out-stream
+ 0 (string-output-stream-index in-stream))
+ (setf (string-output-stream-index in-stream) 0))
+\f
+;;;; fill-pointer streams
+
+;;; Fill pointer string output streams are not explicitly mentioned in the CLM,
+;;; but they are required for the implementation of With-Output-To-String.
+
+(defstruct (fill-pointer-output-stream
+ (:include lisp-stream
+ (out #'fill-pointer-ouch)
+ (sout #'fill-pointer-sout)
+ (misc #'fill-pointer-misc))
+ (:constructor make-fill-pointer-output-stream (string)))
+ ;; The string we throw stuff in.
+ string)
+
+(defun fill-pointer-ouch (stream character)
+ (let* ((buffer (fill-pointer-output-stream-string stream))
+ (current (fill-pointer buffer))
+ (current+1 (1+ current)))
+ (declare (fixnum current))
+ (with-array-data ((workspace buffer) (start) (end))
+ (declare (simple-string workspace))
+ (let ((offset-current (+ start current)))
+ (declare (fixnum offset-current))
+ (if (= offset-current end)
+ (let* ((new-length (* current 2))
+ (new-workspace (make-string new-length)))
+ (declare (simple-string new-workspace))
+ (%primitive sb!c:byte-blt
+ workspace
+ start
+ new-workspace
+ 0
+ current)
+ (setf workspace new-workspace)
+ (setf offset-current current)
+ (set-array-header buffer workspace new-length
+ current+1 0 new-length nil))
+ (setf (fill-pointer buffer) current+1))
+ (setf (schar workspace offset-current) character)))
+ current+1))
+
+(defun fill-pointer-sout (stream string start end)
+ (declare (simple-string string) (fixnum start end))
+ (let* ((buffer (fill-pointer-output-stream-string stream))
+ (current (fill-pointer buffer))
+ (string-len (- end start))
+ (dst-end (+ string-len current)))
+ (declare (fixnum current dst-end string-len))
+ (with-array-data ((workspace buffer) (dst-start) (dst-length))
+ (declare (simple-string workspace))
+ (let ((offset-dst-end (+ dst-start dst-end))
+ (offset-current (+ dst-start current)))
+ (declare (fixnum offset-dst-end offset-current))
+ (if (> offset-dst-end dst-length)
+ (let* ((new-length (+ (the fixnum (* current 2)) string-len))
+ (new-workspace (make-string new-length)))
+ (declare (simple-string new-workspace))
+ (%primitive sb!c:byte-blt
+ workspace
+ dst-start
+ new-workspace
+ 0
+ current)
+ (setf workspace new-workspace)
+ (setf offset-current current)
+ (setf offset-dst-end dst-end)
+ (set-array-header buffer
+ workspace
+ new-length
+ dst-end
+ 0
+ new-length
+ nil))
+ (setf (fill-pointer buffer) dst-end))
+ (%primitive sb!c:byte-blt
+ string
+ start
+ workspace
+ offset-current
+ offset-dst-end)))
+ dst-end))
+
+(defun fill-pointer-misc (stream operation &optional arg1 arg2)
+ (declare (ignore arg1 arg2))
+ (case operation
+ (:charpos
+ (let* ((buffer (fill-pointer-output-stream-string stream))
+ (current (fill-pointer buffer)))
+ (with-array-data ((string buffer) (start) (end current))
+ (declare (simple-string string) (ignore start))
+ (let ((found (position #\newline string :test #'char=
+ :end end :from-end t)))
+ (if found
+ (- end (the fixnum found))
+ current)))))
+ (:element-type 'base-char)))
+\f
+;;;; indenting streams
+
+(defstruct (indenting-stream (:include lisp-stream
+ (out #'indenting-out)
+ (sout #'indenting-sout)
+ (misc #'indenting-misc))
+ (:constructor make-indenting-stream (stream)))
+ ;; the stream we're based on
+ stream
+ ;; how much we indent on each line
+ (indentation 0))
+
+#!+sb-doc
+(setf (fdocumentation 'make-indenting-stream 'function)
+ "Returns an output stream which indents its output by some amount.")
+
+;;; Indenting-Indent writes the correct number of spaces needed to indent
+;;; output on the given Stream based on the specified Sub-Stream.
+(defmacro indenting-indent (stream sub-stream)
+ ;; KLUDGE: bare magic number 60
+ `(do ((i 0 (+ i 60))
+ (indentation (indenting-stream-indentation ,stream)))
+ ((>= i indentation))
+ (write-string*
+ " "
+ ,sub-stream 0 (min 60 (- indentation i)))))
+
+;;; Indenting-Out writes a character to an indenting stream.
+(defun indenting-out (stream char)
+ (let ((sub-stream (indenting-stream-stream stream)))
+ (write-char char sub-stream)
+ (if (char= char #\newline)
+ (indenting-indent stream sub-stream))))
+
+;;; Indenting-Sout writes a string to an indenting stream.
+
+(defun indenting-sout (stream string start end)
+ (declare (simple-string string) (fixnum start end))
+ (do ((i start)
+ (sub-stream (indenting-stream-stream stream)))
+ ((= i end))
+ (let ((newline (position #\newline string :start i :end end)))
+ (cond (newline
+ (write-string* string sub-stream i (1+ newline))
+ (indenting-indent stream sub-stream)
+ (setq i (+ newline 1)))
+ (t
+ (write-string* string sub-stream i end)
+ (setq i end))))))
+
+;;; Indenting-Misc just treats just the :Line-Length message differently.
+;;; Indenting-Charpos says the charpos is the charpos of the base stream minus
+;;; the stream's indentation.
+
+(defun indenting-misc (stream operation &optional arg1 arg2)
+ (let ((sub-stream (indenting-stream-stream stream)))
+ (if (lisp-stream-p sub-stream)
+ (let ((method (lisp-stream-misc sub-stream)))
+ (case operation
+ (:line-length
+ (let ((line-length (funcall method sub-stream operation)))
+ (if line-length
+ (- line-length (indenting-stream-indentation stream)))))
+ (:charpos
+ (let ((charpos (funcall method sub-stream operation)))
+ (if charpos
+ (- charpos (indenting-stream-indentation stream)))))
+ (t
+ (funcall method sub-stream operation arg1 arg2))))
+ ;; Fundamental-stream.
+ (case operation
+ (:line-length
+ (let ((line-length (stream-line-length sub-stream)))
+ (if line-length
+ (- line-length (indenting-stream-indentation stream)))))
+ (:charpos
+ (let ((charpos (stream-line-column sub-stream)))
+ (if charpos
+ (- charpos (indenting-stream-indentation stream)))))
+ (t
+ (stream-misc-dispatch sub-stream operation arg1 arg2))))))
+
+(declaim (maybe-inline read-char unread-char read-byte listen))
+\f
+;;;; case frobbing streams, used by format ~(...~)
+
+(defstruct (case-frob-stream
+ (:include lisp-stream
+ (:misc #'case-frob-misc))
+ (:constructor %make-case-frob-stream (target out sout)))
+ (target (required-argument) :type stream))
+
+(defun make-case-frob-stream (target kind)
+ #!+sb-doc
+ "Returns a stream that sends all output to the stream TARGET, but modifies
+ the case of letters, depending on KIND, which should be one of:
+ :upcase - convert to upper case.
+ :downcase - convert to lower case.
+ :capitalize - convert the first letter of words to upper case and the
+ rest of the word to lower case.
+ :capitalize-first - convert the first letter of the first word to upper
+ case and everything else to lower case."
+ (declare (type stream target)
+ (type (member :upcase :downcase :capitalize :capitalize-first)
+ kind)
+ (values stream))
+ (if (case-frob-stream-p target)
+ ;; If we are going to be writing to a stream that already does case
+ ;; frobbing, why bother frobbing the case just so it can frob it
+ ;; again?
+ target
+ (multiple-value-bind (out sout)
+ (ecase kind
+ (:upcase
+ (values #'case-frob-upcase-out
+ #'case-frob-upcase-sout))
+ (:downcase
+ (values #'case-frob-downcase-out
+ #'case-frob-downcase-sout))
+ (:capitalize
+ (values #'case-frob-capitalize-out
+ #'case-frob-capitalize-sout))
+ (:capitalize-first
+ (values #'case-frob-capitalize-first-out
+ #'case-frob-capitalize-first-sout)))
+ (%make-case-frob-stream target out sout))))
+
+(defun case-frob-misc (stream op &optional arg1 arg2)
+ (declare (type case-frob-stream stream))
+ (case op
+ (:close)
+ (t
+ (let ((target (case-frob-stream-target stream)))
+ (if (lisp-stream-p target)
+ (funcall (lisp-stream-misc target) target op arg1 arg2)
+ (stream-misc-dispatch target op arg1 arg2))))))
+
+(defun case-frob-upcase-out (stream char)
+ (declare (type case-frob-stream stream)
+ (type base-char char))
+ (let ((target (case-frob-stream-target stream))
+ (char (char-upcase char)))
+ (if (lisp-stream-p target)
+ (funcall (lisp-stream-out target) target char)
+ (stream-write-char target char))))
+
+(defun case-frob-upcase-sout (stream str start end)
+ (declare (type case-frob-stream stream)
+ (type simple-base-string str)
+ (type index start)
+ (type (or index null) end))
+ (let* ((target (case-frob-stream-target stream))
+ (len (length str))
+ (end (or end len))
+ (string (if (and (zerop start) (= len end))
+ (string-upcase str)
+ (nstring-upcase (subseq str start end))))
+ (string-len (- end start)))
+ (if (lisp-stream-p target)
+ (funcall (lisp-stream-sout target) target string 0 string-len)
+ (stream-write-string target string 0 string-len))))
+
+(defun case-frob-downcase-out (stream char)
+ (declare (type case-frob-stream stream)
+ (type base-char char))
+ (let ((target (case-frob-stream-target stream))
+ (char (char-downcase char)))
+ (if (lisp-stream-p target)
+ (funcall (lisp-stream-out target) target char)
+ (stream-write-char target char))))
+
+(defun case-frob-downcase-sout (stream str start end)
+ (declare (type case-frob-stream stream)
+ (type simple-base-string str)
+ (type index start)
+ (type (or index null) end))
+ (let* ((target (case-frob-stream-target stream))
+ (len (length str))
+ (end (or end len))
+ (string (if (and (zerop start) (= len end))
+ (string-downcase str)
+ (nstring-downcase (subseq str start end))))
+ (string-len (- end start)))
+ (if (lisp-stream-p target)
+ (funcall (lisp-stream-sout target) target string 0 string-len)
+ (stream-write-string target string 0 string-len))))
+
+(defun case-frob-capitalize-out (stream char)
+ (declare (type case-frob-stream stream)
+ (type base-char char))
+ (let ((target (case-frob-stream-target stream)))
+ (cond ((alphanumericp char)
+ (let ((char (char-upcase char)))
+ (if (lisp-stream-p target)
+ (funcall (lisp-stream-out target) target char)
+ (stream-write-char target char)))
+ (setf (case-frob-stream-out stream) #'case-frob-capitalize-aux-out)
+ (setf (case-frob-stream-sout stream)
+ #'case-frob-capitalize-aux-sout))
+ (t
+ (if (lisp-stream-p target)
+ (funcall (lisp-stream-out target) target char)
+ (stream-write-char target char))))))
+
+(defun case-frob-capitalize-sout (stream str start end)
+ (declare (type case-frob-stream stream)
+ (type simple-base-string str)
+ (type index start)
+ (type (or index null) end))
+ (let* ((target (case-frob-stream-target stream))
+ (str (subseq str start end))
+ (len (length str))
+ (inside-word nil))
+ (dotimes (i len)
+ (let ((char (schar str i)))
+ (cond ((not (alphanumericp char))
+ (setf inside-word nil))
+ (inside-word
+ (setf (schar str i) (char-downcase char)))
+ (t
+ (setf inside-word t)
+ (setf (schar str i) (char-upcase char))))))
+ (when inside-word
+ (setf (case-frob-stream-out stream)
+ #'case-frob-capitalize-aux-out)
+ (setf (case-frob-stream-sout stream)
+ #'case-frob-capitalize-aux-sout))
+ (if (lisp-stream-p target)
+ (funcall (lisp-stream-sout target) target str 0 len)
+ (stream-write-string target str 0 len))))
+
+(defun case-frob-capitalize-aux-out (stream char)
+ (declare (type case-frob-stream stream)
+ (type base-char char))
+ (let ((target (case-frob-stream-target stream)))
+ (cond ((alphanumericp char)
+ (let ((char (char-downcase char)))
+ (if (lisp-stream-p target)
+ (funcall (lisp-stream-out target) target char)
+ (stream-write-char target char))))
+ (t
+ (if (lisp-stream-p target)
+ (funcall (lisp-stream-out target) target char)
+ (stream-write-char target char))
+ (setf (case-frob-stream-out stream)
+ #'case-frob-capitalize-out)
+ (setf (case-frob-stream-sout stream)
+ #'case-frob-capitalize-sout)))))
+
+(defun case-frob-capitalize-aux-sout (stream str start end)
+ (declare (type case-frob-stream stream)
+ (type simple-base-string str)
+ (type index start)
+ (type (or index null) end))
+ (let* ((target (case-frob-stream-target stream))
+ (str (subseq str start end))
+ (len (length str))
+ (inside-word t))
+ (dotimes (i len)
+ (let ((char (schar str i)))
+ (cond ((not (alphanumericp char))
+ (setf inside-word nil))
+ (inside-word
+ (setf (schar str i) (char-downcase char)))
+ (t
+ (setf inside-word t)
+ (setf (schar str i) (char-upcase char))))))
+ (unless inside-word
+ (setf (case-frob-stream-out stream)
+ #'case-frob-capitalize-out)
+ (setf (case-frob-stream-sout stream)
+ #'case-frob-capitalize-sout))
+ (if (lisp-stream-p target)
+ (funcall (lisp-stream-sout target) target str 0 len)
+ (stream-write-string target str 0 len))))
+
+(defun case-frob-capitalize-first-out (stream char)
+ (declare (type case-frob-stream stream)
+ (type base-char char))
+ (let ((target (case-frob-stream-target stream)))
+ (cond ((alphanumericp char)
+ (let ((char (char-upcase char)))
+ (if (lisp-stream-p target)
+ (funcall (lisp-stream-out target) target char)
+ (stream-write-char target char)))
+ (setf (case-frob-stream-out stream)
+ #'case-frob-downcase-out)
+ (setf (case-frob-stream-sout stream)
+ #'case-frob-downcase-sout))
+ (t
+ (if (lisp-stream-p target)
+ (funcall (lisp-stream-out target) target char)
+ (stream-write-char target char))))))
+
+(defun case-frob-capitalize-first-sout (stream str start end)
+ (declare (type case-frob-stream stream)
+ (type simple-base-string str)
+ (type index start)
+ (type (or index null) end))
+ (let* ((target (case-frob-stream-target stream))
+ (str (subseq str start end))
+ (len (length str)))
+ (dotimes (i len)
+ (let ((char (schar str i)))
+ (when (alphanumericp char)
+ (setf (schar str i) (char-upcase char))
+ (do ((i (1+ i) (1+ i)))
+ ((= i len))
+ (setf (schar str i) (char-downcase (schar str i))))
+ (setf (case-frob-stream-out stream)
+ #'case-frob-downcase-out)
+ (setf (case-frob-stream-sout stream)
+ #'case-frob-downcase-sout)
+ (return))))
+ (if (lisp-stream-p target)
+ (funcall (lisp-stream-sout target) target str 0 len)
+ (stream-write-string target str 0 len))))
+\f
+;;;; public interface from "EXTENSIONS" package
+
+(defstruct (stream-command (:constructor make-stream-command
+ (name &optional args)))
+ (name nil :type symbol)
+ (args nil :type list))
+(def!method print-object ((obj stream-command) str)
+ (print-unreadable-object (obj str :type t :identity t)
+ (prin1 (stream-command-name obj) str)))
+
+;;; We can't simply call the stream's misc method because NIL is an
+;;; ambiguous return value: does it mean text arrived, or does it mean the
+;;; stream's misc method had no :GET-COMMAND implementation. We can't return
+;;; NIL until there is text input. We don't need to loop because any stream
+;;; implementing :get-command would wait until it had some input. If the
+;;; LISTEN fails, then we have some stream we must wait on.
+(defun get-stream-command (stream)
+ #!+sb-doc
+ "This takes a stream and waits for text or a command to appear on it. If
+ text appears before a command, this returns nil, and otherwise it returns
+ a command."
+ (let ((cmdp (funcall (lisp-stream-misc stream) stream :get-command)))
+ (cond (cmdp)
+ ((listen stream)
+ nil)
+ (t
+ ;; This waits for input and returns nil when it arrives.
+ (unread-char (read-char stream) stream)))))
+\f
+(defun read-sequence (seq stream &key (start 0) (end nil))
+ #!+sb-doc
+ "Destructively modify SEQ by reading elements from STREAM.
+ That part of SEQ bounded by START and END is destructively modified by
+ copying successive elements into it from STREAM. If the end of file
+ for STREAM is reached before copying all elements of the subsequence,
+ then the extra elements near the end of sequence are not updated, and
+ the index of the next element is returned."
+ (declare (type sequence seq)
+ (type stream stream)
+ (type index start)
+ (type sequence-end end)
+ (values index))
+ (let ((end (or end (length seq))))
+ (declare (type index end))
+ (etypecase seq
+ (list
+ (let ((read-function
+ (if (subtypep (stream-element-type stream) 'character)
+ #'read-char
+ #'read-byte)))
+ (do ((rem (nthcdr start seq) (rest rem))
+ (i start (1+ i)))
+ ((or (endp rem) (>= i end)) i)
+ (declare (type list rem)
+ (type index i))
+ (let ((el (funcall read-function stream nil :eof)))
+ (when (eq el :eof)
+ (return i))
+ (setf (first rem) el)))))
+ (vector
+ (with-array-data ((data seq) (offset-start start) (offset-end end))
+ (typecase data
+ ((or (simple-array (unsigned-byte 8) (*))
+ (simple-array (signed-byte 8) (*))
+ simple-string)
+ (let* ((numbytes (- end start))
+ (bytes-read (sb!sys:read-n-bytes stream
+ data
+ offset-start
+ numbytes
+ nil)))
+ (if (< bytes-read numbytes)
+ (+ start bytes-read)
+ end)))
+ (t
+ (let ((read-function
+ (if (subtypep (stream-element-type stream) 'character)
+ #'read-char
+ #'read-byte)))
+ (do ((i offset-start (1+ i)))
+ ((>= i offset-end) end)
+ (declare (type index i))
+ (let ((el (funcall read-function stream nil :eof)))
+ (when (eq el :eof)
+ (return (+ start (- i offset-start))))
+ (setf (aref data i) el)))))))))))
+
+(defun write-sequence (seq stream &key (start 0) (end nil))
+ #!+sb-doc
+ "Write the elements of SEQ bounded by START and END to STREAM."
+ (declare (type sequence seq)
+ (type stream stream)
+ (type index start)
+ (type sequence-end end)
+ (values sequence))
+ (let ((end (or end (length seq))))
+ (declare (type index start end))
+ (etypecase seq
+ (list
+ (let ((write-function
+ (if (subtypep (stream-element-type stream) 'character)
+ #'write-char
+ #'write-byte)))
+ (do ((rem (nthcdr start seq) (rest rem))
+ (i start (1+ i)))
+ ((or (endp rem) (>= i end)) seq)
+ (declare (type list rem)
+ (type index i))
+ (funcall write-function (first rem) stream))))
+ (string
+ (write-string* seq stream start end))
+ (vector
+ (let ((write-function
+ (if (subtypep (stream-element-type stream) 'character)
+ #'write-char
+ #'write-byte)))
+ (do ((i start (1+ i)))
+ ((>= i end) seq)
+ (declare (type index i))
+ (funcall write-function (aref seq i) stream)))))))
+
+;;; (These were inline throughout this file, but that's not appropriate
+;;; globally.)
+(declaim (maybe-inline read-char unread-char read-byte listen))
--- /dev/null
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!IMPL")
+
+(file-comment
+ "$Header$")
+
+(defun string (x)
+ #!+sb-doc
+ "Coerces X into a string. If X is a string, X is returned. If X is a
+ symbol, X's pname is returned. If X is a character then a one element
+ string containing that character is returned. If X cannot be coerced
+ into a string, an error occurs."
+ (cond ((stringp x) x)
+ ((symbolp x) (symbol-name x))
+ ((characterp x)
+ (let ((res (make-string 1)))
+ (setf (schar res 0) x) res))
+ (t
+ (error 'simple-type-error
+ :datum x
+ :expected-type 'stringable
+ :format-control "~S cannot be coerced to a string."
+ :format-arguments (list x)))))
+
+;;; With-One-String is used to set up some string hacking things. The keywords
+;;; are parsed, and the string is hacked into a simple-string.
+
+(eval-when (:compile-toplevel)
+
+(sb!xc:defmacro with-one-string (string start end cum-offset &rest forms)
+ `(let ((,string (if (stringp ,string) ,string (string ,string))))
+ (with-array-data ((,string ,string :offset-var ,cum-offset)
+ (,start ,start)
+ (,end (or ,end (length (the vector ,string)))))
+ ,@forms)))
+
+) ; EVAN-WHEN
+
+;;; With-String is like With-One-String, but doesn't parse keywords.
+
+(eval-when (:compile-toplevel)
+
+(sb!xc:defmacro with-string (string &rest forms)
+ `(let ((,string (if (stringp ,string) ,string (string ,string))))
+ (with-array-data ((,string ,string)
+ (start)
+ (end (length (the vector ,string))))
+ ,@forms)))
+
+) ; EVAL-WHEN
+
+;;; With-Two-Strings is used to set up string comparison operations. The
+;;; keywords are parsed, and the strings are hacked into simple-strings.
+
+(eval-when (:compile-toplevel)
+
+(sb!xc:defmacro with-two-strings (string1 string2 start1 end1 cum-offset-1
+ start2 end2 &rest forms)
+ `(let ((,string1 (if (stringp ,string1) ,string1 (string ,string1)))
+ (,string2 (if (stringp ,string2) ,string2 (string ,string2))))
+ (with-array-data ((,string1 ,string1 :offset-var ,cum-offset-1)
+ (,start1 ,start1)
+ (,end1 (or ,end1 (length (the vector ,string1)))))
+ (with-array-data ((,string2 ,string2)
+ (,start2 ,start2)
+ (,end2 (or ,end2 (length (the vector ,string2)))))
+ ,@forms))))
+
+) ; EVAL-WHEN
+
+(defun char (string index)
+ #!+sb-doc
+ "Given a string and a non-negative integer index less than the length of
+ the string, returns the character object representing the character at
+ that position in the string."
+ (declare (optimize (safety 1)))
+ (char string index))
+
+(defun %charset (string index new-el)
+ (declare (optimize (safety 1)))
+ (setf (char string index) new-el))
+
+(defun schar (string index)
+ #!+sb-doc
+ "SCHAR returns the character object at an indexed position in a string
+ just as CHAR does, except the string must be a simple-string."
+ (declare (optimize (safety 1)))
+ (schar string index))
+
+(defun %scharset (string index new-el)
+ (declare (optimize (safety 1)))
+ (setf (schar string index) new-el))
+
+(defun string=* (string1 string2 start1 end1 start2 end2)
+ (with-two-strings string1 string2 start1 end1 offset1 start2 end2
+ (not (%sp-string-compare string1 start1 end1 string2 start2 end2))))
+
+(defun string/=* (string1 string2 start1 end1 start2 end2)
+ (with-two-strings string1 string2 start1 end1 offset1 start2 end2
+ (let ((comparison (%sp-string-compare string1 start1 end1
+ string2 start2 end2)))
+ (if comparison (- (the fixnum comparison) offset1)))))
+
+(eval-when (:compile-toplevel :execute)
+
+;;; Lessp is true if the desired expansion is for string<* or string<=*.
+;;; Equalp is true if the desired expansion is for string<=* or string>=*.
+(sb!xc:defmacro string<>=*-body (lessp equalp)
+ (let ((offset1 (gensym)))
+ `(with-two-strings string1 string2 start1 end1 ,offset1 start2 end2
+ (let ((index (%sp-string-compare string1 start1 end1
+ string2 start2 end2)))
+ (if index
+ (cond ((= (the fixnum index) (the fixnum end1))
+ ,(if lessp
+ `(- (the fixnum index) ,offset1)
+ `nil))
+ ((= (+ (the fixnum index) (- start2 start1))
+ (the fixnum end2))
+ ,(if lessp
+ `nil
+ `(- (the fixnum index) ,offset1)))
+ ((,(if lessp 'char< 'char>)
+ (schar string1 index)
+ (schar string2 (+ (the fixnum index) (- start2 start1))))
+ (- (the fixnum index) ,offset1))
+ (t nil))
+ ,(if equalp `(- (the fixnum end1) ,offset1) 'nil))))))
+) ; eval-when
+
+(defun string<* (string1 string2 start1 end1 start2 end2)
+ (declare (fixnum start1 start2))
+ (string<>=*-body t nil))
+
+(defun string>* (string1 string2 start1 end1 start2 end2)
+ (declare (fixnum start1 start2))
+ (string<>=*-body nil nil))
+
+(defun string<=* (string1 string2 start1 end1 start2 end2)
+ (declare (fixnum start1 start2))
+ (string<>=*-body t t))
+
+(defun string>=* (string1 string2 start1 end1 start2 end2)
+ (declare (fixnum start1 start2))
+ (string<>=*-body nil t))
+
+(defun string< (string1 string2 &key (start1 0) end1 (start2 0) end2)
+ #!+sb-doc
+ "Given two strings, if the first string is lexicographically less than
+ the second string, returns the longest common prefix (using char=)
+ of the two strings. Otherwise, returns ()."
+ (string<* string1 string2 start1 end1 start2 end2))
+
+(defun string> (string1 string2 &key (start1 0) end1 (start2 0) end2)
+ #!+sb-doc
+ "Given two strings, if the first string is lexicographically greater than
+ the second string, returns the longest common prefix (using char=)
+ of the two strings. Otherwise, returns ()."
+ (string>* string1 string2 start1 end1 start2 end2))
+
+(defun string<= (string1 string2 &key (start1 0) end1 (start2 0) end2)
+ #!+sb-doc
+ "Given two strings, if the first string is lexicographically less than
+ or equal to the second string, returns the longest common prefix
+ (using char=) of the two strings. Otherwise, returns ()."
+ (string<=* string1 string2 start1 end1 start2 end2))
+
+(defun string>= (string1 string2 &key (start1 0) end1 (start2 0) end2)
+ "Given two strings, if the first string is lexicographically greater
+ than or equal to the second string, returns the longest common prefix
+ (using char=) of the two strings. Otherwise, returns ()."
+ (string>=* string1 string2 start1 end1 start2 end2))
+
+;;; Note: (STRING= "PREFIX" "SHORT" :END2 (LENGTH "PREFIX")) gives
+;;; an error instead of returning NIL as I would have expected.
+;;; The ANSI spec for STRING= itself doesn't seem to clarify this
+;;; much, but the SUBSEQ-OUT-OF-BOUNDS writeup seems to say that
+;;; this is conforming (and required) behavior, because any index
+;;; out of range is an error. (So there seems to be no concise and
+;;; efficient way to test for strings which begin with a particular
+;;; pattern. Alas..) -- WHN 19991206
+(defun string= (string1 string2 &key (start1 0) end1 (start2 0) end2)
+ #!+sb-doc
+ "Given two strings (string1 and string2), and optional integers start1,
+ start2, end1 and end2, compares characters in string1 to characters in
+ string2 (using char=)."
+ (string=* string1 string2 start1 end1 start2 end2))
+
+(defun string/= (string1 string2 &key (start1 0) end1 (start2 0) end2)
+ #!+sb-doc
+ "Given two strings, if the first string is not lexicographically equal
+ to the second string, returns the longest common prefix (using char=)
+ of the two strings. Otherwise, returns ()."
+ (string/=* string1 string2 start1 end1 start2 end2))
+
+(eval-when (:compile-toplevel :execute)
+
+;;; STRING-NOT-EQUAL-LOOP is used to generate character comparison loops for
+;;; STRING-EQUAL and STRING-NOT-EQUAL.
+(sb!xc:defmacro string-not-equal-loop (end
+ end-value
+ &optional (abort-value nil abortp))
+ (declare (fixnum end))
+ (let ((end-test (if (= end 1)
+ `(= index1 (the fixnum end1))
+ `(= index2 (the fixnum end2)))))
+ `(do ((index1 start1 (1+ index1))
+ (index2 start2 (1+ index2)))
+ (,(if abortp
+ end-test
+ `(or ,end-test
+ (not (char-equal (schar string1 index1)
+ (schar string2 index2)))))
+ ,end-value)
+ (declare (fixnum index1 index2))
+ ,@(if abortp
+ `((if (not (char-equal (schar string1 index1)
+ (schar string2 index2)))
+ (return ,abort-value)))))))
+
+) ; EVAL-WHEN
+
+(defun string-equal (string1 string2 &key (start1 0) end1 (start2 0) end2)
+ #!+sb-doc
+ "Given two strings (string1 and string2), and optional integers start1,
+ start2, end1 and end2, compares characters in string1 to characters in
+ string2 (using char-equal)."
+ (declare (fixnum start1 start2))
+ (with-two-strings string1 string2 start1 end1 offset1 start2 end2
+ (let ((slen1 (- (the fixnum end1) start1))
+ (slen2 (- (the fixnum end2) start2)))
+ (declare (fixnum slen1 slen2))
+ (if (or (minusp slen1) (minusp slen2))
+ ;;prevent endless looping later.
+ (error "Improper bounds for string comparison."))
+ (if (= slen1 slen2)
+ ;;return () immediately if lengths aren't equal.
+ (string-not-equal-loop 1 t nil)))))
+
+(defun string-not-equal (string1 string2 &key (start1 0) end1 (start2 0) end2)
+ #!+sb-doc
+ "Given two strings, if the first string is not lexicographically equal
+ to the second string, returns the longest common prefix (using char-equal)
+ of the two strings. Otherwise, returns ()."
+ (with-two-strings string1 string2 start1 end1 offset1 start2 end2
+ (let ((slen1 (- end1 start1))
+ (slen2 (- end2 start2)))
+ (declare (fixnum slen1 slen2))
+ (if (or (minusp slen1) (minusp slen2))
+ ;;prevent endless looping later.
+ (error "Improper bounds for string comparison."))
+ (cond ((or (minusp slen1) (or (minusp slen2)))
+ (error "Improper substring for comparison."))
+ ((= slen1 slen2)
+ (string-not-equal-loop 1 nil (- index1 offset1)))
+ ((< slen1 slen2)
+ (string-not-equal-loop 1 (- index1 offset1)))
+ (t
+ (string-not-equal-loop 2 (- index1 offset1)))))))
+
+(eval-when (:compile-toplevel :execute)
+
+;;; STRING-LESS-GREATER-EQUAL-TESTS returns a test on the lengths of string1
+;;; and string2 and a test on the current characters from string1 and string2
+;;; for the following macro.
+(defun string-less-greater-equal-tests (lessp equalp)
+ (if lessp
+ (if equalp
+ ;; STRING-NOT-GREATERP
+ (values '<= `(not (char-greaterp char1 char2)))
+ ;; STRING-LESSP
+ (values '< `(char-lessp char1 char2)))
+ (if equalp
+ ;; STRING-NOT-LESSP
+ (values '>= `(not (char-lessp char1 char2)))
+ ;; STRING-GREATERP
+ (values '> `(char-greaterp char1 char2)))))
+
+(sb!xc:defmacro string-less-greater-equal (lessp equalp)
+ (multiple-value-bind (length-test character-test)
+ (string-less-greater-equal-tests lessp equalp)
+ `(with-two-strings string1 string2 start1 end1 offset1 start2 end2
+ (let ((slen1 (- (the fixnum end1) start1))
+ (slen2 (- (the fixnum end2) start2)))
+ (declare (fixnum slen1 slen2))
+ (if (or (minusp slen1) (minusp slen2))
+ ;;prevent endless looping later.
+ (error "Improper bounds for string comparison."))
+ (do ((index1 start1 (1+ index1))
+ (index2 start2 (1+ index2))
+ (char1)
+ (char2))
+ ((or (= index1 (the fixnum end1)) (= index2 (the fixnum end2)))
+ (if (,length-test slen1 slen2) (- index1 offset1)))
+ (declare (fixnum index1 index2))
+ (setq char1 (schar string1 index1))
+ (setq char2 (schar string2 index2))
+ (if (not (char-equal char1 char2))
+ (if ,character-test
+ (return (- index1 offset1))
+ (return ()))))))))
+
+) ; EVAL-WHEN
+
+(defun string-lessp* (string1 string2 start1 end1 start2 end2)
+ (declare (fixnum start1 start2))
+ (string-less-greater-equal t nil))
+
+(defun string-greaterp* (string1 string2 start1 end1 start2 end2)
+ (declare (fixnum start1 start2))
+ (string-less-greater-equal nil nil))
+
+(defun string-not-lessp* (string1 string2 start1 end1 start2 end2)
+ (declare (fixnum start1 start2))
+ (string-less-greater-equal nil t))
+
+(defun string-not-greaterp* (string1 string2 start1 end1 start2 end2)
+ (declare (fixnum start1 start2))
+ (string-less-greater-equal t t))
+
+(defun string-lessp (string1 string2 &key (start1 0) end1 (start2 0) end2)
+ #!+sb-doc
+ "Given two strings, if the first string is lexicographically less than
+ the second string, returns the longest common prefix (using char-equal)
+ of the two strings. Otherwise, returns ()."
+ (string-lessp* string1 string2 start1 end1 start2 end2))
+
+(defun string-greaterp (string1 string2 &key (start1 0) end1 (start2 0) end2)
+ #!+sb-doc
+ "Given two strings, if the first string is lexicographically greater than
+ the second string, returns the longest common prefix (using char-equal)
+ of the two strings. Otherwise, returns ()."
+ (string-greaterp* string1 string2 start1 end1 start2 end2))
+
+(defun string-not-lessp (string1 string2 &key (start1 0) end1 (start2 0) end2)
+ #!+sb-doc
+ "Given two strings, if the first string is lexicographically greater
+ than or equal to the second string, returns the longest common prefix
+ (using char-equal) of the two strings. Otherwise, returns ()."
+ (string-not-lessp* string1 string2 start1 end1 start2 end2))
+
+(defun string-not-greaterp (string1 string2 &key (start1 0) end1 (start2 0)
+ end2)
+ #!+sb-doc
+ "Given two strings, if the first string is lexicographically less than
+ or equal to the second string, returns the longest common prefix
+ (using char-equal) of the two strings. Otherwise, returns ()."
+ (string-not-greaterp* string1 string2 start1 end1 start2 end2))
+
+(defun make-string (count &key element-type ((:initial-element fill-char)))
+ #!+sb-doc
+ "Given a character count and an optional fill character, makes and returns
+ a new string Count long filled with the fill character."
+ (declare (fixnum count)
+ (ignore element-type))
+ (if fill-char
+ (do ((i 0 (1+ i))
+ (string (make-string count)))
+ ((= i count) string)
+ (declare (fixnum i))
+ (setf (schar string i) fill-char))
+ (make-string count)))
+
+(defun string-upcase (string &key (start 0) end)
+ #!+sb-doc
+ "Given a string, returns a new string that is a copy of it with
+ all lower case alphabetic characters converted to uppercase."
+ (declare (fixnum start))
+ (let* ((string (if (stringp string) string (string string)))
+ (slen (length string)))
+ (declare (fixnum slen))
+ (with-one-string string start end offset
+ (let ((offset-slen (+ slen offset))
+ (newstring (make-string slen)))
+ (declare (fixnum offset-slen))
+ (do ((index offset (1+ index))
+ (new-index 0 (1+ new-index)))
+ ((= index start))
+ (declare (fixnum index new-index))
+ (setf (schar newstring new-index) (schar string index)))
+ (do ((index start (1+ index))
+ (new-index (- start offset) (1+ new-index)))
+ ((= index (the fixnum end)))
+ (declare (fixnum index new-index))
+ (setf (schar newstring new-index)
+ (char-upcase (schar string index))))
+ (do ((index end (1+ index))
+ (new-index (- (the fixnum end) offset) (1+ new-index)))
+ ((= index offset-slen))
+ (declare (fixnum index new-index))
+ (setf (schar newstring new-index) (schar string index)))
+ newstring))))
+
+(defun string-downcase (string &key (start 0) end)
+ #!+sb-doc
+ "Given a string, returns a new string that is a copy of it with
+ all upper case alphabetic characters converted to lowercase."
+ (declare (fixnum start))
+ (let* ((string (if (stringp string) string (string string)))
+ (slen (length string)))
+ (declare (fixnum slen))
+ (with-one-string string start end offset
+ (let ((offset-slen (+ slen offset))
+ (newstring (make-string slen)))
+ (declare (fixnum offset-slen))
+ (do ((index offset (1+ index))
+ (new-index 0 (1+ new-index)))
+ ((= index start))
+ (declare (fixnum index new-index))
+ (setf (schar newstring new-index) (schar string index)))
+ (do ((index start (1+ index))
+ (new-index (- start offset) (1+ new-index)))
+ ((= index (the fixnum end)))
+ (declare (fixnum index new-index))
+ (setf (schar newstring new-index)
+ (char-downcase (schar string index))))
+ (do ((index end (1+ index))
+ (new-index (- (the fixnum end) offset) (1+ new-index)))
+ ((= index offset-slen))
+ (declare (fixnum index new-index))
+ (setf (schar newstring new-index) (schar string index)))
+ newstring))))
+
+(defun string-capitalize (string &key (start 0) end)
+ #!+sb-doc
+ "Given a string, returns a copy of the string with the first
+ character of each ``word'' converted to upper-case, and remaining
+ chars in the word converted to lower case. A ``word'' is defined
+ to be a string of case-modifiable characters delimited by
+ non-case-modifiable chars."
+ (declare (fixnum start))
+ (let* ((string (if (stringp string) string (string string)))
+ (slen (length string)))
+ (declare (fixnum slen))
+ (with-one-string string start end offset
+ (let ((offset-slen (+ slen offset))
+ (newstring (make-string slen)))
+ (declare (fixnum offset-slen))
+ (do ((index offset (1+ index))
+ (new-index 0 (1+ new-index)))
+ ((= index start))
+ (declare (fixnum index new-index))
+ (setf (schar newstring new-index) (schar string index)))
+ (do ((index start (1+ index))
+ (new-index (- start offset) (1+ new-index))
+ (newword t)
+ (char ()))
+ ((= index (the fixnum end)))
+ (declare (fixnum index new-index))
+ (setq char (schar string index))
+ (cond ((not (alphanumericp char))
+ (setq newword t))
+ (newword
+ ;;char is first case-modifiable after non-case-modifiable
+ (setq char (char-upcase char))
+ (setq newword ()))
+ ;;char is case-modifiable, but not first
+ (t (setq char (char-downcase char))))
+ (setf (schar newstring new-index) char))
+ (do ((index end (1+ index))
+ (new-index (- (the fixnum end) offset) (1+ new-index)))
+ ((= index offset-slen))
+ (declare (fixnum index new-index))
+ (setf (schar newstring new-index) (schar string index)))
+ newstring))))
+
+(defun nstring-upcase (string &key (start 0) end)
+ #!+sb-doc
+ "Given a string, returns that string with all lower case alphabetic
+ characters converted to uppercase."
+ (declare (fixnum start))
+ (let ((save-header string))
+ (with-one-string string start end offset
+ (do ((index start (1+ index)))
+ ((= index (the fixnum end)))
+ (declare (fixnum index))
+ (setf (schar string index) (char-upcase (schar string index)))))
+ save-header))
+
+(defun nstring-downcase (string &key (start 0) end)
+ #!+sb-doc
+ "Given a string, returns that string with all upper case alphabetic
+ characters converted to lowercase."
+ (declare (fixnum start))
+ (let ((save-header string))
+ (with-one-string string start end offset
+ (do ((index start (1+ index)))
+ ((= index (the fixnum end)))
+ (declare (fixnum index))
+ (setf (schar string index) (char-downcase (schar string index)))))
+ save-header))
+
+(defun nstring-capitalize (string &key (start 0) end)
+ #!+sb-doc
+ "Given a string, returns that string with the first
+ character of each ``word'' converted to upper-case, and remaining
+ chars in the word converted to lower case. A ``word'' is defined
+ to be a string of case-modifiable characters delimited by
+ non-case-modifiable chars."
+ (declare (fixnum start))
+ (let ((save-header string))
+ (with-one-string string start end offset
+ (do ((index start (1+ index))
+ (newword t)
+ (char ()))
+ ((= index (the fixnum end)))
+ (declare (fixnum index))
+ (setq char (schar string index))
+ (cond ((not (alphanumericp char))
+ (setq newword t))
+ (newword
+ ;;char is first case-modifiable after non-case-modifiable
+ (setf (schar string index) (char-upcase char))
+ (setq newword ()))
+ (t
+ (setf (schar string index) (char-downcase char))))))
+ save-header))
+
+(defun string-left-trim (char-bag string)
+ #!+sb-doc
+ "Given a set of characters (a list or string) and a string, returns
+ a copy of the string with the characters in the set removed from the
+ left end."
+ (with-string string
+ (do ((index start (1+ index)))
+ ((or (= index (the fixnum end))
+ (not (find (schar string index) char-bag :test #'char=)))
+ (subseq (the simple-string string) index end))
+ (declare (fixnum index)))))
+
+(defun string-right-trim (char-bag string)
+ #!+sb-doc
+ "Given a set of characters (a list or string) and a string, returns
+ a copy of the string with the characters in the set removed from the
+ right end."
+ (with-string string
+ (do ((index (1- (the fixnum end)) (1- index)))
+ ((or (< index start)
+ (not (find (schar string index) char-bag :test #'char=)))
+ (subseq (the simple-string string) start (1+ index)))
+ (declare (fixnum index)))))
+
+(defun string-trim (char-bag string)
+ #!+sb-doc
+ "Given a set of characters (a list or string) and a string, returns a
+ copy of the string with the characters in the set removed from both
+ ends."
+ (with-string string
+ (let* ((left-end (do ((index start (1+ index)))
+ ((or (= index (the fixnum end))
+ (not (find (schar string index)
+ char-bag
+ :test #'char=)))
+ index)
+ (declare (fixnum index))))
+ (right-end (do ((index (1- (the fixnum end)) (1- index)))
+ ((or (< index left-end)
+ (not (find (schar string index)
+ char-bag
+ :test #'char=)))
+ (1+ index))
+ (declare (fixnum index)))))
+ (subseq (the simple-string string) left-end right-end))))
--- /dev/null
+;;;; that part of SXHASH logic which runs not only in the target Lisp but
+;;;; in the cross-compilation host Lisp
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!C")
+
+(sb!xc:define-modify-macro mixf (y) mix)
+
+;;; SXHASH of FLOAT values is defined directly in terms of DEFTRANSFORM in
+;;; order to avoid boxing.
+(deftransform sxhash ((x) (single-float))
+ '(let ((bits (single-float-bits x)))
+ (logxor 66194023
+ (sxhash (the fixnum
+ (logand most-positive-fixnum
+ (logxor bits
+ (ash bits -7))))))))
+(deftransform sxhash ((x) (double-float))
+ '(let* ((val x)
+ (hi (double-float-high-bits val))
+ (lo (double-float-low-bits val))
+ (hilo (logxor hi lo)))
+ (logxor 475038542
+ (sxhash (the fixnum
+ (logand most-positive-fixnum
+ (logxor hilo
+ (ash hilo -7))))))))
+
+;;; SXHASH of FIXNUM values is defined as a DEFTRANSFORM because it's so
+;;; simple.
+(deftransform sxhash ((x) (fixnum))
+ '(logand most-positive-fixnum
+ (logxor x
+ (ash x -3) ; to get sign bit into hash
+ 361475658)))
+
+;;;; Some other common SXHASH cases are defined as DEFTRANSFORMs in order to
+;;;; avoid having to do TYPECASE at runtime.
+(deftransform sxhash ((x) (simple-string))
+ '(%sxhash-simple-string x))
+(deftransform sxhash ((x) (symbol))
+ '(%sxhash-simple-string (symbol-name x)))
--- /dev/null
+;;;; code to manipulate symbols (but not packages, which are handled
+;;;; elsewhere)
+;;;;
+;;;; Many of these definitions are trivial interpreter entries to
+;;;; functions open-coded by the compiler.
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!IMPL")
+
+(file-comment
+ "$Header$")
+
+(declaim (maybe-inline get %put getf remprop %putf get-properties keywordp))
+
+(defun symbol-value (variable)
+ #!+sb-doc
+ "VARIABLE must evaluate to a symbol. This symbol's current special
+ value is returned."
+ (declare (optimize (safety 1)))
+ (symbol-value variable))
+
+(defun boundp (variable)
+ #!+sb-doc
+ "VARIABLE must evaluate to a symbol. Return NIL if this symbol is
+ unbound, T if it has a value."
+ (boundp variable))
+
+(defun set (variable new-value)
+ #!+sb-doc
+ "VARIABLE must evaluate to a symbol. This symbol's special value cell is
+ set to the specified new value."
+ (declare (type symbol variable))
+ (cond ((null variable)
+ (error "Nihil ex nihil, NIL can't be set."))
+ ((eq variable t)
+ (error "Veritas aeterna, T can't be set."))
+ ((and (boundp '*keyword-package*)
+ (keywordp variable))
+ (error "Keywords can't be set."))
+ (t
+ (%set-symbol-value variable new-value))))
+
+(defun %set-symbol-value (symbol new-value)
+ (%set-symbol-value symbol new-value))
+
+(defun makunbound (variable)
+ #!+sb-doc
+ "VARIABLE must evaluate to a symbol. This symbol is made unbound,
+ removing any value it may currently have."
+ (set variable
+ (%primitive sb!c:make-other-immediate-type 0 sb!vm:unbound-marker-type))
+ variable)
+
+(defun symbol-hash (symbol)
+ #!+sb-doc
+ "Return the built-in hash value for symbol."
+ (symbol-hash symbol))
+
+(defun symbol-function (variable)
+ #!+sb-doc
+ "VARIABLE must evaluate to a symbol. This symbol's current definition
+ is returned. Settable with SETF."
+ (raw-definition variable))
+
+(defun fset (symbol new-value)
+ (declare (type symbol symbol) (type function new-value))
+ (setf (raw-definition symbol) new-value))
+
+(defun symbol-plist (variable)
+ #!+sb-doc
+ "Return the property list of a symbol."
+ (symbol-plist variable))
+
+(defun %set-symbol-plist (symbol new-value)
+ (setf (symbol-plist symbol) new-value))
+
+(defun symbol-name (variable)
+ #!+sb-doc
+ "Return the print name of a symbol."
+ (symbol-name variable))
+
+(defun symbol-package (variable)
+ #!+sb-doc
+ "Return the package a symbol is interned in, or NIL if none."
+ (symbol-package variable))
+
+(defun %set-symbol-package (symbol package)
+ (declare (type symbol symbol))
+ (%set-symbol-package symbol package))
+
+(defun make-symbol (string)
+ #!+sb-doc
+ "Make and return a new symbol with the STRING as its print name."
+ #!-gengc (make-symbol string)
+ #!+gengc (%make-symbol (random most-positive-fixnum) string))
+
+(defun get (symbol indicator &optional (default nil))
+ #!+sb-doc
+ "Look on the property list of SYMBOL for the specified INDICATOR. If this
+ is found, return the associated value, else return DEFAULT."
+ (do ((pl (symbol-plist symbol) (cddr pl)))
+ ((atom pl) default)
+ (cond ((atom (cdr pl))
+ (error "~S has an odd number of items in its property list."
+ symbol))
+ ((eq (car pl) indicator)
+ (return (cadr pl))))))
+
+(defun %put (symbol indicator value)
+ #!+sb-doc
+ "The VALUE is added as a property of SYMBOL under the specified INDICATOR.
+ Returns VALUE."
+ (do ((pl (symbol-plist symbol) (cddr pl)))
+ ((endp pl)
+ (setf (symbol-plist symbol)
+ (list* indicator value (symbol-plist symbol)))
+ value)
+ (cond ((endp (cdr pl))
+ (error "~S has an odd number of items in its property list."
+ symbol))
+ ((eq (car pl) indicator)
+ (rplaca (cdr pl) value)
+ (return value)))))
+
+(defun remprop (symbol indicator)
+ #!+sb-doc
+ "Look on property list of SYMBOL for property with specified
+ INDICATOR. If found, splice this indicator and its value out of
+ the plist, and return the tail of the original list starting with
+ INDICATOR. If not found, return () with no side effects.
+
+ NOTE: The ANSI specification requires REMPROP to return true (not false)
+ or false (the symbol NIL). Portable code should not rely on any other value."
+ (do ((pl (symbol-plist symbol) (cddr pl))
+ (prev nil pl))
+ ((atom pl) nil)
+ (cond ((atom (cdr pl))
+ (error "~S has an odd number of items in its property list."
+ symbol))
+ ((eq (car pl) indicator)
+ (cond (prev (rplacd (cdr prev) (cddr pl)))
+ (t
+ (setf (symbol-plist symbol) (cddr pl))))
+ (return pl)))))
+
+(defun getf (place indicator &optional (default ()))
+ #!+sb-doc
+ "Searches the property list stored in Place for an indicator EQ to Indicator.
+ If one is found, the corresponding value is returned, else the Default is
+ returned."
+ (do ((plist place (cddr plist)))
+ ((null plist) default)
+ (cond ((atom (cdr plist))
+ (error "~S is a malformed property list."
+ place))
+ ((eq (car plist) indicator)
+ (return (cadr plist))))))
+
+(defun %putf (place property new-value)
+ (declare (type list place))
+ (do ((plist place (cddr plist)))
+ ((endp plist) (list* property new-value place))
+ (declare (type list plist))
+ (when (eq (car plist) property)
+ (setf (cadr plist) new-value)
+ (return place))))
+
+(defun get-properties (place indicator-list)
+ #!+sb-doc
+ "Like GETF, except that Indicator-List is a list of indicators which will
+ be looked for in the property list stored in Place. Three values are
+ returned, see manual for details."
+ (do ((plist place (cddr plist)))
+ ((null plist) (values nil nil nil))
+ (cond ((atom (cdr plist))
+ (error "~S is a malformed proprty list."
+ place))
+ ((memq (car plist) indicator-list)
+ (return (values (car plist) (cadr plist) plist))))))
+
+(defun copy-symbol (symbol &optional (copy-props nil) &aux new-symbol)
+ #!+sb-doc
+ "Make and return a new uninterned symbol with the same print name
+ as SYMBOL. If COPY-PROPS is false, the new symbol is neither bound
+ nor fbound and has no properties, else it has a copy of SYMBOL's
+ function, value and property list."
+ (declare (type symbol symbol))
+ (setq new-symbol (make-symbol (symbol-name symbol)))
+ (when copy-props
+ (%set-symbol-value new-symbol
+ (%primitive sb!c:fast-symbol-value symbol))
+ (setf (symbol-plist new-symbol)
+ (copy-list (symbol-plist symbol)))
+ (when (fboundp symbol)
+ (setf (symbol-function new-symbol) (symbol-function symbol))))
+ new-symbol)
+
+(declaim (special *keyword-package*))
+
+(defun keywordp (object)
+ #!+sb-doc
+ "Returns true if Object is a symbol in the keyword package."
+ (and (symbolp object)
+ (eq (symbol-package object) *keyword-package*)))
+\f
+;;;; GENSYM and friends
+
+(defvar *gensym-counter* 0
+ #!+sb-doc
+ "counter for generating unique GENSYM symbols")
+(declaim (type unsigned-byte *gensym-counter*))
+
+(defun gensym (&optional (thing "G"))
+ #!+sb-doc
+ "Creates a new uninterned symbol whose name is a prefix string (defaults
+ to \"G\"), followed by a decimal number. Thing, when supplied, will
+ alter the prefix if it is a string, or be used for the decimal number
+ if it is a number, of this symbol. The default value of the number is
+ the current value of *gensym-counter* which is incremented each time
+ it is used."
+ (let ((old *gensym-counter*))
+ (unless (numberp thing)
+ (let ((new (etypecase old
+ (index (1+ old))
+ (unsigned-byte (1+ old)))))
+ (declare (optimize (speed 3) (safety 0)(inhibit-warnings 3)))
+ (setq *gensym-counter* new)))
+ (multiple-value-bind (prefix int)
+ (etypecase thing
+ (simple-string (values thing old))
+ (fixnum (values "G" thing))
+ (string (values (coerce thing 'simple-string) old)))
+ (declare (simple-string prefix))
+ (make-symbol
+ (concatenate 'simple-string prefix
+ (the simple-string
+ (quick-integer-to-string int)))))))
+
+(defvar *gentemp-counter* 0)
+(declaim (type unsigned-byte *gentemp-counter*))
+
+(defun gentemp (&optional (prefix "T") (package *package*))
+ #!+sb-doc
+ "Creates a new symbol interned in package Package with the given Prefix."
+ (declare (type string prefix))
+ (loop
+ (let ((*print-base* 10)
+ (*print-radix* nil)
+ (*print-pretty* nil)
+ (new-pname (format nil "~A~D" prefix (incf *gentemp-counter*))))
+ (multiple-value-bind (symbol existsp) (find-symbol new-pname package)
+ (declare (ignore symbol))
+ (unless existsp (return (values (intern new-pname package))))))))
--- /dev/null
+;;;; miscellaneous system hacking macros
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!IMPL")
+
+(file-comment
+ "$Header$")
+
+;;; This checks to see whether the array is simple and the start and
+;;; end are in bounds. If so, it proceeds with those values.
+;;; Otherwise, it calls %WITH-ARRAY-DATA. Note that there is a
+;;; DERIVE-TYPE method for %WITH-ARRAY-DATA.
+(defmacro with-array-data (((data-var array &key (offset-var (gensym)))
+ (start-var &optional (svalue 0))
+ (end-var &optional (evalue nil)))
+ &body forms)
+ #!+sb-doc
+ "Given any Array, binds Data-Var to the array's data vector and Start-Var and
+ End-Var to the start and end of the designated portion of the data vector.
+ Svalue and Evalue are any start and end specified to the original operation,
+ and are factored into the bindings of Start-Var and End-Var. Offset-Var is
+ the cumulative offset of all displacements encountered, and does not
+ include Svalue."
+ (once-only ((n-array array)
+ (n-svalue `(the index ,svalue))
+ (n-evalue `(the (or index null) ,evalue)))
+ `(multiple-value-bind (,data-var ,start-var ,end-var ,offset-var)
+ (if (not (array-header-p ,n-array))
+ (let ((,n-array ,n-array))
+ (declare (type (simple-array * (*)) ,n-array))
+ ,(once-only ((n-len `(length ,n-array))
+ (n-end `(or ,n-evalue ,n-len)))
+ `(if (<= ,n-svalue ,n-end ,n-len)
+ (values ,n-array ,n-svalue ,n-end 0)
+ (%with-array-data ,n-array ,n-svalue ,n-evalue))))
+ (%with-array-data ,n-array ,n-svalue ,n-evalue))
+ (declare (ignorable ,offset-var))
+ ,@forms)))
+
+#!-gengc
+(defmacro without-gcing (&rest body)
+ #!+sb-doc
+ "Executes the forms in the body without doing a garbage collection."
+ `(unwind-protect
+ (let ((*gc-inhibit* t))
+ ,@body)
+ (when (and *need-to-collect-garbage* (not *gc-inhibit*))
+ (maybe-gc nil))))
+
+#!+gengc
+(defmacro without-gcing (&rest body)
+ #!+sb-doc
+ "Executes the forms in the body without doing a garbage collection."
+ `(without-interrupts ,@body))
+\f
+;;; Eof-Or-Lose is a useful macro that handles EOF.
+(defmacro eof-or-lose (stream eof-error-p eof-value)
+ `(if ,eof-error-p
+ (error 'end-of-file :stream ,stream)
+ ,eof-value))
+
+;;; These macros handle the special cases of t and nil for input and
+;;; output streams.
+;;;
+;;; FIXME: Shouldn't these be functions instead of macros?
+(defmacro in-synonym-of (stream &optional check-type)
+ (let ((svar (gensym)))
+ `(let ((,svar ,stream))
+ (cond ((null ,svar) *standard-input*)
+ ((eq ,svar t) *terminal-io*)
+ (T ,@(if check-type `((check-type ,svar ,check-type)))
+ #!+high-security
+ (unless (input-stream-p ,svar)
+ (error 'simple-type-error
+ :datum ,svar
+ :expected-type '(satisfies input-stream-p)
+ :format-control "~S isn't an input stream"
+ :format-arguments ,(list svar)))
+ ,svar)))))
+(defmacro out-synonym-of (stream &optional check-type)
+ (let ((svar (gensym)))
+ `(let ((,svar ,stream))
+ (cond ((null ,svar) *standard-output*)
+ ((eq ,svar t) *terminal-io*)
+ (T ,@(if check-type `((check-type ,svar ,check-type)))
+ #!+high-security
+ (unless (output-stream-p ,svar)
+ (error 'simple-type-error
+ :datum ,svar
+ :expected-type '(satisfies output-stream-p)
+ :format-control "~S isn't an output stream."
+ :format-arguments ,(list svar)))
+ ,svar)))))
+
+;;; With-Mumble-Stream calls the function in the given Slot of the
+;;; Stream with the Args for lisp-streams, or the Function with the
+;;; Args for fundamental-streams.
+(defmacro with-in-stream (stream (slot &rest args) &optional stream-dispatch)
+ `(let ((stream (in-synonym-of ,stream)))
+ ,(if stream-dispatch
+ `(if (lisp-stream-p stream)
+ (funcall (,slot stream) stream ,@args)
+ ,@(when stream-dispatch
+ `(,(destructuring-bind (function &rest args) stream-dispatch
+ `(,function stream ,@args)))))
+ `(funcall (,slot stream) stream ,@args))))
+
+(defmacro with-out-stream (stream (slot &rest args) &optional stream-dispatch)
+ `(let ((stream (out-synonym-of ,stream)))
+ ,(if stream-dispatch
+ `(if (lisp-stream-p stream)
+ (funcall (,slot stream) stream ,@args)
+ ,@(when stream-dispatch
+ `(,(destructuring-bind (function &rest args) stream-dispatch
+ `(,function stream ,@args)))))
+ `(funcall (,slot stream) stream ,@args))))
+\f
+;;;; These are hacks to make the reader win.
+
+;;; This macro sets up some local vars for use by the
+;;; Fast-Read-Char macro within the enclosed lexical scope. The stream
+;;; is assumed to be a lisp-stream.
+(defmacro prepare-for-fast-read-char (stream &body forms)
+ `(let* ((%frc-stream% ,stream)
+ (%frc-method% (lisp-stream-in %frc-stream%))
+ (%frc-buffer% (lisp-stream-in-buffer %frc-stream%))
+ (%frc-index% (lisp-stream-in-index %frc-stream%)))
+ (declare (type index %frc-index%)
+ (type lisp-stream %frc-stream%))
+ ,@forms))
+
+;;; This macro must be called after one is done with fast-read-char
+;;; inside its scope to decache the lisp-stream-in-index.
+(defmacro done-with-fast-read-char ()
+ `(setf (lisp-stream-in-index %frc-stream%) %frc-index%))
+
+;;; a macro with the same calling convention as READ-CHAR, to be
+;;; used within the scope of a PREPARE-FOR-FAST-READ-CHAR
+(defmacro fast-read-char (&optional (eof-error-p t) (eof-value ()))
+ `(cond
+ ((not %frc-buffer%)
+ (funcall %frc-method% %frc-stream% ,eof-error-p ,eof-value))
+ ((= %frc-index% in-buffer-length)
+ (prog1 (fast-read-char-refill %frc-stream% ,eof-error-p ,eof-value)
+ (setq %frc-index% (lisp-stream-in-index %frc-stream%))))
+ (t
+ (prog1 (code-char (aref %frc-buffer% %frc-index%))
+ (incf %frc-index%)))))
+
+;;;; And these for the fasloader...
+
+;;; Just like Prepare-For-Fast-Read-Char except that we get the Bin
+;;; method. The stream is assumed to be a lisp-stream.
+;;;
+;;; KLUDGE: It seems weird to have to remember to explicitly call
+;;; DONE-WITH-FAST-READ-BYTE at the end of this, given that we're
+;;; already wrapping the stuff inside in a block. Why not rename this
+;;; macro to WITH-FAST-READ-BYTE, do the DONE-WITH-FAST-READ-BYTE stuff
+;;; automatically at the end of the block, and eliminate
+;;; DONE-WITH-FAST-READ-BYTE as a separate entity? (and similarly
+;;; for the FAST-READ-CHAR stuff) -- WHN 19990825
+(defmacro prepare-for-fast-read-byte (stream &body forms)
+ `(let* ((%frc-stream% ,stream)
+ (%frc-method% (lisp-stream-bin %frc-stream%))
+ (%frc-buffer% (lisp-stream-in-buffer %frc-stream%))
+ (%frc-index% (lisp-stream-in-index %frc-stream%)))
+ (declare (type index %frc-index%)
+ (type lisp-stream %frc-stream%))
+ ,@forms))
+
+;;; Similar to fast-read-char, but we use a different refill routine & don't
+;;; convert to characters. If ANY-TYPE is true, then this can be used on any
+;;; integer streams, and we don't assert the result type.
+(defmacro fast-read-byte (&optional (eof-error-p t) (eof-value ()) any-type)
+ ;; KLUDGE: should use ONCE-ONLY on EOF-ERROR-P and EOF-VALUE -- WHN 19990825
+ `(truly-the
+ ,(if (and (eq eof-error-p 't) (not any-type)) '(unsigned-byte 8) 't)
+ (cond
+ ((not %frc-buffer%)
+ (funcall %frc-method% %frc-stream% ,eof-error-p ,eof-value))
+ ((= %frc-index% in-buffer-length)
+ (prog1 (fast-read-byte-refill %frc-stream% ,eof-error-p ,eof-value)
+ (setq %frc-index% (lisp-stream-in-index %frc-stream%))))
+ (t
+ (prog1 (aref %frc-buffer% %frc-index%)
+ (incf %frc-index%))))))
+(defmacro done-with-fast-read-byte ()
+ `(done-with-fast-read-char))
--- /dev/null
+;;;; This file contains parts of the ALIEN implementation that
+;;;; are not part of the compiler.
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!ALIEN")
+
+(file-comment
+ "$Header$")
+\f
+;;;; alien variables
+
+;;; Make a string out of the symbol, converting all uppercase letters to
+;;; lower case and hyphens into underscores.
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defun guess-alien-name-from-lisp-name (lisp-name)
+ (declare (type symbol lisp-name))
+ (nsubstitute #\_ #\- (string-downcase (symbol-name lisp-name)))))
+
+;;; The opposite of GUESS-ALIEN-NAME-FROM-LISP-NAME. Make a symbol out
+;;; of the string, converting all lowercase letters to uppercase and
+;;; underscores into hyphens.
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defun guess-lisp-name-from-alien-name (alien-name)
+ (declare (type simple-string alien-name))
+ (intern (nsubstitute #\- #\_ (string-upcase alien-name)))))
+
+;;; Extract the Lisp and alien names from NAME. If only one is given,
+;;; guess the other.
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defun pick-lisp-and-alien-names (name)
+ (etypecase name
+ (string
+ (values (guess-lisp-name-from-alien-name name) name))
+ (symbol
+ (values name (guess-alien-name-from-lisp-name name)))
+ (list
+ (unless (proper-list-of-length-p name 2)
+ (error "badly formed alien name"))
+ (values (cadr name) (car name))))))
+
+(defmacro def-alien-variable (name type &environment env)
+ #!+sb-doc
+ "Define NAME as an external alien variable of type TYPE. NAME should be
+ a list of a string holding the alien name and a symbol to use as the Lisp
+ name. If NAME is just a symbol or string, then the other name is guessed
+ from the one supplied."
+ (multiple-value-bind (lisp-name alien-name) (pick-lisp-and-alien-names name)
+ (with-auxiliary-alien-types env
+ (let ((alien-type (parse-alien-type type env)))
+ `(eval-when (:compile-toplevel :load-toplevel :execute)
+ ,@(when *new-auxiliary-types*
+ `((%def-auxiliary-alien-types ',*new-auxiliary-types*)))
+ (%def-alien-variable ',lisp-name
+ ',alien-name
+ ',alien-type))))))
+
+;;; Do the actual work of DEF-ALIEN-VARIABLE.
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defun %def-alien-variable (lisp-name alien-name type)
+ (setf (info :variable :kind lisp-name) :alien)
+ (setf (info :variable :where-from lisp-name) :defined)
+ (clear-info :variable :constant-value lisp-name)
+ (setf (info :variable :alien-info lisp-name)
+ (make-heap-alien-info :type type
+ :sap-form `(foreign-symbol-address
+ ',alien-name)))))
+
+(defmacro extern-alien (name type &environment env)
+ #!+sb-doc
+ "Access the alien variable named NAME, assuming it is of type TYPE. This
+ is SETFable."
+ (let ((alien-name (etypecase name
+ (symbol (guess-alien-name-from-lisp-name name))
+ (string name))))
+ `(%heap-alien ',(make-heap-alien-info
+ :type (parse-alien-type type env)
+ :sap-form `(foreign-symbol-address ',alien-name)))))
+
+(defmacro with-alien (bindings &body body &environment env)
+ #!+sb-doc
+ "Establish some local alien variables. Each BINDING is of the form:
+ VAR TYPE [ ALLOCATION ] [ INITIAL-VALUE | EXTERNAL-NAME ]
+ ALLOCATION should be one of:
+ :LOCAL (the default)
+ The alien is allocated on the stack, and has dynamic extent.
+ :STATIC
+ The alien is allocated on the heap, and has infinite extent. The alien
+ is allocated at load time, so the same piece of memory is used each time
+ this form executes.
+ :EXTERN
+ No alien is allocated, but VAR is established as a local name for
+ the external alien given by EXTERNAL-NAME."
+ (with-auxiliary-alien-types env
+ (dolist (binding (reverse bindings))
+ (destructuring-bind
+ (symbol type &optional (opt1 nil opt1p) (opt2 nil opt2p))
+ binding
+ (let ((alien-type (parse-alien-type type env)))
+ (multiple-value-bind (allocation initial-value)
+ (if opt2p
+ (values opt1 opt2)
+ (case opt1
+ (:extern
+ (values opt1 (guess-alien-name-from-lisp-name symbol)))
+ (:static
+ (values opt1 nil))
+ (t
+ (values :local opt1))))
+ (setf body
+ (ecase allocation
+ #+nil
+ (:static
+ (let ((sap
+ (make-symbol (concatenate 'string "SAP-FOR-"
+ (symbol-name symbol)))))
+ `((let ((,sap (load-time-value (%make-alien ...))))
+ (declare (type system-area-pointer ,sap))
+ (symbol-macrolet
+ ((,symbol (sap-alien ,sap ,type)))
+ ,@(when initial-value
+ `((setq ,symbol ,initial-value)))
+ ,@body)))))
+ (:extern
+ (let ((info (make-heap-alien-info
+ :type alien-type
+ :sap-form `(foreign-symbol-address
+ ',initial-value))))
+ `((symbol-macrolet
+ ((,symbol (%heap-alien ',info)))
+ ,@body))))
+ (:local
+ (let ((var (gensym))
+ (initval (if initial-value (gensym)))
+ (info (make-local-alien-info :type alien-type)))
+ `((let ((,var (make-local-alien ',info))
+ ,@(when initial-value
+ `((,initval ,initial-value))))
+ (note-local-alien-type ',info ,var)
+ (multiple-value-prog1
+ (symbol-macrolet
+ ((,symbol (local-alien ',info ,var)))
+ ,@(when initial-value
+ `((setq ,symbol ,initval)))
+ ,@body)
+ (dispose-local-alien ',info ,var))))))))))))
+ (verify-local-auxiliaries-okay)
+ `(symbol-macrolet ((&auxiliary-type-definitions&
+ ,(append *new-auxiliary-types*
+ (auxiliary-type-definitions env))))
+ ,@body)))
+\f
+;;;; runtime C values that don't correspond directly to Lisp types
+
+;;; ALIEN-VALUE
+;;;
+;;; Note: The DEFSTRUCT for ALIEN-VALUE lives in a separate file
+;;; 'cause it has to be real early in the cold-load order.
+#!-sb-fluid (declaim (freeze-type alien-value))
+(def!method print-object ((value alien-value) stream)
+ (print-unreadable-object (value stream)
+ (format stream
+ "~S :SAP #X~8,'0X"
+ 'alien-value
+ (sap-int (alien-value-sap value)))))
+
+#!-sb-fluid (declaim (inline null-alien))
+(defun null-alien (x)
+ #!+sb-doc
+ "Return true if X (which must be an ALIEN pointer) is null, false otherwise."
+ (zerop (sap-int (alien-sap x))))
+
+(defmacro sap-alien (sap type &environment env)
+ #!+sb-doc
+ "Convert the system area pointer SAP to an ALIEN of the specified TYPE (not
+ evaluated.) TYPE must be pointer-like."
+ (let ((alien-type (parse-alien-type type env)))
+ (if (eq (compute-alien-rep-type alien-type) 'system-area-pointer)
+ `(%sap-alien ,sap ',alien-type)
+ (error "cannot make aliens of type ~S out of SAPs" type))))
+
+(defun %sap-alien (sap type)
+ (declare (type system-area-pointer sap)
+ (type alien-type type))
+ (make-alien-value :sap sap :type type))
+
+(defun alien-sap (alien)
+ #!+sb-doc
+ "Return a System-Area-Pointer pointing to Alien's data."
+ (declare (type alien-value alien))
+ (alien-value-sap alien))
+\f
+;;;; allocation/deallocation of heap aliens
+
+(defmacro make-alien (type &optional size &environment env)
+ #!+sb-doc
+ "Allocate an alien of type TYPE and return an alien pointer to it. If SIZE
+ is supplied, how it is interpreted depends on TYPE. If TYPE is an array
+ type, SIZE is used as the first dimension for the allocated array. If TYPE
+ is not an array, then SIZE is the number of elements to allocate. The
+ memory is allocated using ``malloc'', so it can be passed to foreign
+ functions which use ``free''."
+ (let ((alien-type (if (alien-type-p type)
+ type
+ (parse-alien-type type env))))
+ (multiple-value-bind (size-expr element-type)
+ (if (alien-array-type-p alien-type)
+ (let ((dims (alien-array-type-dimensions alien-type)))
+ (cond
+ (size
+ (unless dims
+ (error
+ "cannot override the size of zero-dimensional arrays"))
+ (when (constantp size)
+ (setf alien-type (copy-alien-array-type alien-type))
+ (setf (alien-array-type-dimensions alien-type)
+ (cons (eval size) (cdr dims)))))
+ (dims
+ (setf size (car dims)))
+ (t
+ (setf size 1)))
+ (values `(* ,size ,@(cdr dims))
+ (alien-array-type-element-type alien-type)))
+ (values (or size 1) alien-type))
+ (let ((bits (alien-type-bits element-type))
+ (alignment (alien-type-alignment element-type)))
+ (unless bits
+ (error "The size of ~S is unknown."
+ (unparse-alien-type element-type)))
+ (unless alignment
+ (error "The alignment of ~S is unknown."
+ (unparse-alien-type element-type)))
+ `(%sap-alien (%make-alien (* ,(align-offset bits alignment)
+ ,size-expr))
+ ',(make-alien-pointer-type :to alien-type))))))
+
+;;; Allocate a block of memory at least BITS bits long and return a
+;;; system area pointer to it.
+#!-sb-fluid (declaim (inline %make-alien))
+(defun %make-alien (bits)
+ (declare (type sb!kernel:index bits) (optimize-interface (safety 2)))
+ (alien-funcall (extern-alien "malloc" (function system-area-pointer unsigned))
+ (ash (the sb!kernel:index (+ bits 7)) -3)))
+
+#!-sb-fluid (declaim (inline free-alien))
+(defun free-alien (alien)
+ #!+sb-doc
+ "Dispose of the storage pointed to by ALIEN. ALIEN must have been allocated
+ by MAKE-ALIEN or ``malloc''."
+ (alien-funcall (extern-alien "free" (function (values) system-area-pointer))
+ (alien-sap alien))
+ nil)
+\f
+;;;; the SLOT operator
+
+;;; Find the field named SLOT, or die trying.
+(defun slot-or-lose (type slot)
+ (declare (type alien-record-type type)
+ (type symbol slot))
+ (or (find slot (alien-record-type-fields type)
+ :key #'alien-record-field-name)
+ (error "There is no slot named ~S in ~S" slot type)))
+
+;;; Extract the value from the named slot from the record ALIEN. If
+;;; ALIEN is actually a pointer, then DEREF it first.
+(defun slot (alien slot)
+ #!+sb-doc
+ "Extract SLOT from the Alien STRUCT or UNION ALIEN. May be set with SETF."
+ (declare (type alien-value alien)
+ (type symbol slot)
+ (optimize (inhibit-warnings 3)))
+ (let ((type (alien-value-type alien)))
+ (etypecase type
+ (alien-pointer-type
+ (slot (deref alien) slot))
+ (alien-record-type
+ (let ((field (slot-or-lose type slot)))
+ (extract-alien-value (alien-value-sap alien)
+ (alien-record-field-offset field)
+ (alien-record-field-type field)))))))
+
+;;; Deposit the value in the specified slot of the record ALIEN. If
+;;; the ALIEN is really a pointer, DEREF it first. The compiler uses
+;;; this when it can't figure out anything better.
+(defun %set-slot (alien slot value)
+ (declare (type alien-value alien)
+ (type symbol slot)
+ (optimize (inhibit-warnings 3)))
+ (let ((type (alien-value-type alien)))
+ (etypecase type
+ (alien-pointer-type
+ (%set-slot (deref alien) slot value))
+ (alien-record-type
+ (let ((field (slot-or-lose type slot)))
+ (deposit-alien-value (alien-value-sap alien)
+ (alien-record-field-offset field)
+ (alien-record-field-type field)
+ value))))))
+
+;;; Compute the address of the specified slot and return a pointer to it.
+(defun %slot-addr (alien slot)
+ (declare (type alien-value alien)
+ (type symbol slot)
+ (optimize (inhibit-warnings 3)))
+ (let ((type (alien-value-type alien)))
+ (etypecase type
+ (alien-pointer-type
+ (%slot-addr (deref alien) slot))
+ (alien-record-type
+ (let* ((field (slot-or-lose type slot))
+ (offset (alien-record-field-offset field))
+ (field-type (alien-record-field-type field)))
+ (%sap-alien (sap+ (alien-sap alien) (/ offset sb!vm:byte-bits))
+ (make-alien-pointer-type :to field-type)))))))
+\f
+;;;; the DEREF operator
+
+;;; Does most of the work of the different DEREF methods. Returns two values:
+;;; the type and the offset (in bits) of the refered to alien.
+(defun deref-guts (alien indices)
+ (declare (type alien-value alien)
+ (type list indices)
+ (values alien-type integer))
+ (let ((type (alien-value-type alien)))
+ (etypecase type
+ (alien-pointer-type
+ (when (cdr indices)
+ (error "too many indices when derefing ~S: ~D"
+ type
+ (length indices)))
+ (let ((element-type (alien-pointer-type-to type)))
+ (values element-type
+ (if indices
+ (* (align-offset (alien-type-bits element-type)
+ (alien-type-alignment element-type))
+ (car indices))
+ 0))))
+ (alien-array-type
+ (unless (= (length indices) (length (alien-array-type-dimensions type)))
+ (error "incorrect number of indices when derefing ~S: ~D"
+ type (length indices)))
+ (labels ((frob (dims indices offset)
+ (if (null dims)
+ offset
+ (frob (cdr dims) (cdr indices)
+ (+ (if (zerop offset)
+ 0
+ (* offset (car dims)))
+ (car indices))))))
+ (let ((element-type (alien-array-type-element-type type)))
+ (values element-type
+ (* (align-offset (alien-type-bits element-type)
+ (alien-type-alignment element-type))
+ (frob (alien-array-type-dimensions type)
+ indices 0)))))))))
+
+;;; Dereference the alien and return the results.
+(defun deref (alien &rest indices)
+ #!+sb-doc
+ "De-reference an Alien pointer or array. If an array, the indices are used
+ as the indices of the array element to access. If a pointer, one index can
+ optionally be specified, giving the equivalent of C pointer arithmetic."
+ (declare (type alien-value alien)
+ (type list indices)
+ (optimize (inhibit-warnings 3)))
+ (multiple-value-bind (target-type offset) (deref-guts alien indices)
+ (extract-alien-value (alien-value-sap alien)
+ offset
+ target-type)))
+
+(defun %set-deref (alien value &rest indices)
+ (declare (type alien-value alien)
+ (type list indices)
+ (optimize (inhibit-warnings 3)))
+ (multiple-value-bind (target-type offset) (deref-guts alien indices)
+ (deposit-alien-value (alien-value-sap alien)
+ offset
+ target-type
+ value)))
+
+(defun %deref-addr (alien &rest indices)
+ (declare (type alien-value alien)
+ (type list indices)
+ (optimize (inhibit-warnings 3)))
+ (multiple-value-bind (target-type offset) (deref-guts alien indices)
+ (%sap-alien (sap+ (alien-value-sap alien) (/ offset sb!vm:byte-bits))
+ (make-alien-pointer-type :to target-type))))
+\f
+;;;; accessing heap alien variables
+
+(defun %heap-alien (info)
+ (declare (type heap-alien-info info)
+ (optimize (inhibit-warnings 3)))
+ (extract-alien-value (eval (heap-alien-info-sap-form info))
+ 0
+ (heap-alien-info-type info)))
+
+(defun %set-heap-alien (info value)
+ (declare (type heap-alien-info info)
+ (optimize (inhibit-warnings 3)))
+ (deposit-alien-value (eval (heap-alien-info-sap-form info))
+ 0
+ (heap-alien-info-type info)
+ value))
+
+(defun %heap-alien-addr (info)
+ (declare (type heap-alien-info info)
+ (optimize (inhibit-warnings 3)))
+ (%sap-alien (eval (heap-alien-info-sap-form info))
+ (make-alien-pointer-type :to (heap-alien-info-type info))))
+\f
+;;;; accessing local aliens
+
+(defun make-local-alien (info)
+ (let* ((alien (eval `(make-alien ,(local-alien-info-type info))))
+ (alien-sap (alien-sap alien)))
+ (finalize
+ alien
+ #'(lambda ()
+ (alien-funcall
+ (extern-alien "free" (function (values) system-area-pointer))
+ alien-sap)))
+ alien))
+
+(defun note-local-alien-type (info alien)
+ (declare (ignore info alien))
+ nil)
+
+(defun local-alien (info alien)
+ (declare (ignore info))
+ (deref alien))
+
+(defun %set-local-alien (info alien value)
+ (declare (ignore info))
+ (setf (deref alien) value))
+
+(define-setf-expander local-alien (&whole whole info alien)
+ (let ((value (gensym))
+ (info (if (and (consp info)
+ (eq (car info) 'quote))
+ (second info)
+ (error "Something is wrong; local-alien-info not found: ~S"
+ whole))))
+ (values nil
+ nil
+ (list value)
+ (if sb!c:*converting-for-interpreter*
+ `(%set-local-alien ',info ,alien ,value)
+ `(if (%local-alien-forced-to-memory-p ',info)
+ (%set-local-alien ',info ,alien ,value)
+ (setf ,alien
+ (deport ,value ',(local-alien-info-type info)))))
+ whole)))
+
+(defun %local-alien-forced-to-memory-p (info)
+ (local-alien-info-force-to-memory-p info))
+
+(defun %local-alien-addr (info alien)
+ (declare (type local-alien-info info))
+ (unless (local-alien-info-force-to-memory-p info)
+ (error "~S isn't forced to memory. Something went wrong." alien))
+ alien)
+
+(defun dispose-local-alien (info alien)
+ (declare (ignore info))
+ (cancel-finalization alien)
+ (free-alien alien))
+\f
+;;;; the CAST macro
+
+(defmacro cast (alien type &environment env)
+ #!+sb-doc
+ "Convert ALIEN to an Alien of the specified TYPE (not evaluated.) Both types
+ must be Alien array, pointer or function types."
+ `(%cast ,alien ',(parse-alien-type type env)))
+
+(defun %cast (alien target-type)
+ (declare (type alien-value alien)
+ (type alien-type target-type)
+ (optimize-interface (safety 2))
+ (optimize (inhibit-warnings 3)))
+ (if (or (alien-pointer-type-p target-type)
+ (alien-array-type-p target-type)
+ (alien-function-type-p target-type))
+ (let ((alien-type (alien-value-type alien)))
+ (if (or (alien-pointer-type-p alien-type)
+ (alien-array-type-p alien-type)
+ (alien-function-type-p alien-type))
+ (naturalize (alien-value-sap alien) target-type)
+ (error "~S cannot be casted." alien)))
+ (error "cannot cast to alien type ~S" (unparse-alien-type target-type))))
+\f
+;;;; the ALIEN-SIZE macro
+
+(defmacro alien-size (type &optional (units :bits) &environment env)
+ #!+sb-doc
+ "Return the size of the alien type TYPE. UNITS specifies the units to
+ use and can be either :BITS, :BYTES, or :WORDS."
+ (let* ((alien-type (parse-alien-type type env))
+ (bits (alien-type-bits alien-type)))
+ (if bits
+ (values (ceiling bits
+ (ecase units
+ (:bits 1)
+ (:bytes sb!vm:byte-bits)
+ (:words sb!vm:word-bits))))
+ (error "unknown size for alien type ~S"
+ (unparse-alien-type alien-type)))))
+\f
+;;;; NATURALIZE, DEPORT, EXTRACT-ALIEN-VALUE, DEPOSIT-ALIEN-VALUE
+
+(defun naturalize (alien type)
+ (declare (type alien-type type))
+ (funcall (coerce (compute-naturalize-lambda type) 'function)
+ alien type))
+
+(defun deport (value type)
+ (declare (type alien-type type))
+ (funcall (coerce (compute-deport-lambda type) 'function)
+ value type))
+
+(defun extract-alien-value (sap offset type)
+ (declare (type system-area-pointer sap)
+ (type unsigned-byte offset)
+ (type alien-type type))
+ (funcall (coerce (compute-extract-lambda type) 'function)
+ sap offset type))
+
+(defun deposit-alien-value (sap offset type value)
+ (declare (type system-area-pointer sap)
+ (type unsigned-byte offset)
+ (type alien-type type))
+ (funcall (coerce (compute-deposit-lambda type) 'function)
+ sap offset type value))
+\f
+;;;; ALIEN-FUNCALL, DEF-ALIEN-ROUTINE
+
+(defun alien-funcall (alien &rest args)
+ #!+sb-doc
+ "Call the foreign function ALIEN with the specified arguments. ALIEN's
+ type specifies the argument and result types."
+ (declare (type alien-value alien))
+ (let ((type (alien-value-type alien)))
+ (typecase type
+ (alien-pointer-type
+ (apply #'alien-funcall (deref alien) args))
+ (alien-function-type
+ (unless (= (length (alien-function-type-arg-types type))
+ (length args))
+ (error "wrong number of arguments for ~S~%expected ~D, got ~D"
+ type
+ (length (alien-function-type-arg-types type))
+ (length args)))
+ (let ((stub (alien-function-type-stub type)))
+ (unless stub
+ (setf stub
+ (let ((fun (gensym))
+ (parms (loop repeat (length args) collect (gensym))))
+ (compile nil
+ `(lambda (,fun ,@parms)
+ (declare (type (alien ,type) ,fun))
+ (alien-funcall ,fun ,@parms)))))
+ (setf (alien-function-type-stub type) stub))
+ (apply stub alien args)))
+ (t
+ (error "~S is not an alien function." alien)))))
+
+(defmacro def-alien-routine (name result-type &rest args &environment env)
+ #!+sb-doc
+ "Def-C-Routine Name Result-Type
+ {(Arg-Name Arg-Type [Style])}*
+
+ Define a foreign interface function for the routine with the specified Name,
+ which may be either a string, symbol or list of the form (string symbol).
+ Return-Type is the Alien type for the function return value. VOID may be
+ used to specify a function with no result.
+
+ The remaining forms specifiy individual arguments that are passed to the
+ routine. Arg-Name is a symbol that names the argument, primarily for
+ documentation. Arg-Type is the C-Type of the argument. Style specifies the
+ say that the argument is passed.
+
+ :IN
+ An :In argument is simply passed by value. The value to be passed is
+ obtained from argument(s) to the interface function. No values are
+ returned for :In arguments. This is the default mode.
+
+ :OUT
+ The specified argument type must be a pointer to a fixed sized object.
+ A pointer to a preallocated object is passed to the routine, and the
+ the object is accessed on return, with the value being returned from
+ the interface function. :OUT and :IN-OUT cannot be used with pointers
+ to arrays, records or functions.
+
+ :COPY
+ Similar to :IN, except that the argument values are stored in on
+ the stack, and a pointer to the object is passed instead of
+ the values themselves.
+
+ :IN-OUT
+ A combination of :OUT and :COPY. A pointer to the argument is passed,
+ with the object being initialized from the supplied argument and
+ the return value being determined by accessing the object on return."
+ (multiple-value-bind (lisp-name alien-name)
+ (pick-lisp-and-alien-names name)
+ (collect ((docs) (lisp-args) (arg-types) (alien-vars)
+ (alien-args) (results))
+ (dolist (arg args)
+ (if (stringp arg)
+ (docs arg)
+ (destructuring-bind (name type &optional (style :in)) arg
+ (unless (member style '(:in :copy :out :in-out))
+ (error "bogus argument style ~S in ~S" style arg))
+ (unless (eq style :out)
+ (lisp-args name))
+ (when (and (member style '(:out :in-out))
+ (typep (parse-alien-type type env)
+ 'alien-pointer-type))
+ (error "can't use :OUT or :IN-OUT on pointer-like type:~% ~S"
+ type))
+ (cond ((eq style :in)
+ (arg-types type)
+ (alien-args name))
+ (t
+ (arg-types `(* ,type))
+ (if (eq style :out)
+ (alien-vars `(,name ,type))
+ (alien-vars `(,name ,type ,name)))
+ (alien-args `(addr ,name))))
+ (when (or (eq style :out) (eq style :in-out))
+ (results name)))))
+ `(defun ,lisp-name ,(lisp-args)
+ ,@(docs)
+ (with-alien
+ ((,lisp-name (function ,result-type ,@(arg-types))
+ :extern ,alien-name)
+ ,@(alien-vars))
+ ,(if (alien-values-type-p result-type)
+ (let ((temps (loop
+ repeat (length (alien-values-type-values
+ result-type))
+ collect (gensym))))
+ `(multiple-value-bind ,temps
+ (alien-funcall ,lisp-name ,@(alien-args))
+ (values ,@temps ,@(results))))
+ `(values (alien-funcall ,lisp-name ,@(alien-args))
+ ,@(results))))))))
+\f
+(defun alien-typep (object type)
+ #!+sb-doc
+ "Return T iff OBJECT is an alien of type TYPE."
+ (let ((lisp-rep-type (compute-lisp-rep-type type)))
+ (if lisp-rep-type
+ (typep object lisp-rep-type)
+ (and (alien-value-p object)
+ (alien-subtype-p (alien-value-type object) type)))))
--- /dev/null
+;;;; This file contains some extensions to the Alien facility to
+;;;; simplify importing C interfaces.
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!C-CALL")
+
+(sb!int:file-comment
+ "$Header$")
+\f
+;;;; extra types
+
+(def-alien-type char (integer 8))
+(def-alien-type short (integer 16))
+(def-alien-type int (integer 32))
+(def-alien-type long (integer #!-alpha 32 #!+alpha 64))
+
+(def-alien-type unsigned-char (unsigned 8))
+(def-alien-type unsigned-short (unsigned 16))
+(def-alien-type unsigned-int (unsigned 32))
+(def-alien-type unsigned-long (unsigned #!-alpha 32 #!+alpha 64))
+
+(def-alien-type float single-float)
+(def-alien-type double double-float)
+
+(def-alien-type-translator void ()
+ (parse-alien-type '(values) (sb!kernel:make-null-lexenv)))
+\f
+(defun %naturalize-c-string (sap)
+ (declare (type system-area-pointer sap))
+ (with-alien ((ptr (* char) sap))
+ (locally
+ (declare (optimize (speed 3) (safety 0)))
+ (let ((length (loop
+ for offset of-type fixnum upfrom 0
+ until (zerop (deref ptr offset))
+ finally (return offset))))
+ (let ((result (make-string length)))
+ (sb!kernel:copy-from-system-area (alien-sap ptr) 0
+ result (* sb!vm:vector-data-offset
+ sb!vm:word-bits)
+ (* length sb!vm:byte-bits))
+ result)))))
--- /dev/null
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!IMPL")
+
+(file-comment
+ "$Header$")
+
+(defvar *delayed-def!method-args* nil)
--- /dev/null
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!KERNEL")
+
+(file-comment
+ "$Header$")
+\f
+;;;; structure frobbing primitives
+
+(defun %make-instance (length)
+ #!+sb-doc
+ "Allocate a new instance with LENGTH data slots."
+ (declare (type index length))
+ (%make-instance length))
+
+(defun %instance-length (instance)
+ #!+sb-doc
+ "Given an instance, return its length."
+ (declare (type instance instance))
+ (%instance-length instance))
+
+(defun %instance-ref (instance index)
+ #!+sb-doc
+ "Return the value from the INDEXth slot of INSTANCE. This is SETFable."
+ (%instance-ref instance index))
+
+(defun %instance-set (instance index new-value)
+ #!+sb-doc
+ "Set the INDEXth slot of INSTANCE to NEW-VALUE."
+ (setf (%instance-ref instance index) new-value))
+
+(defun %raw-ref-single (vec index)
+ (declare (type index index))
+ (%raw-ref-single vec index))
+
+(defun %raw-ref-double (vec index)
+ (declare (type index index))
+ (%raw-ref-double vec index))
+
+#!+long-float
+(defun %raw-ref-long (vec index)
+ (declare (type index index))
+ (%raw-ref-long vec index))
+
+(defun %raw-set-single (vec index val)
+ (declare (type index index))
+ (%raw-set-single vec index val))
+
+(defun %raw-set-double (vec index val)
+ (declare (type index index))
+ (%raw-set-double vec index val))
+
+#!+long-float
+(defun %raw-set-long (vec index val)
+ (declare (type index index))
+ (%raw-set-long vec index val))
+
+(defun %raw-ref-complex-single (vec index)
+ (declare (type index index))
+ (%raw-ref-complex-single vec index))
+
+(defun %raw-ref-complex-double (vec index)
+ (declare (type index index))
+ (%raw-ref-complex-double vec index))
+
+#!+long-float
+(defun %raw-ref-complex-long (vec index)
+ (declare (type index index))
+ (%raw-ref-complex-long vec index))
+
+(defun %raw-set-complex-single (vec index val)
+ (declare (type index index))
+ (%raw-set-complex-single vec index val))
+
+(defun %raw-set-complex-double (vec index val)
+ (declare (type index index))
+ (%raw-set-complex-double vec index val))
+
+#!+long-float
+(defun %raw-set-complex-long (vec index val)
+ (declare (type index index))
+ (%raw-set-complex-long vec index val))
+
+(defun %instance-layout (instance)
+ (%instance-layout instance))
+
+(defun %set-instance-layout (instance new-value)
+ (%set-instance-layout instance new-value))
+
+(defun %make-funcallable-instance (len layout)
+ (%make-funcallable-instance len layout))
+
+(defun funcallable-instance-p (x) (funcallable-instance-p x))
+
+(defun %funcallable-instance-info (fin i)
+ (%funcallable-instance-info fin i))
+
+(defun %set-funcallable-instance-info (fin i new-value)
+ (%set-funcallable-instance-info fin i new-value))
+
+(defun funcallable-instance-function (fin)
+ (%funcallable-instance-lexenv fin))
+
+;;; The heart of the magic of funcallable instances ("FINs"). The
+;;; function for a FIN must be a magical INSTANCE-LAMBDA form. When
+;;; called (as with any other function), we grab the code pointer, and
+;;; call it, leaving the original function object in LEXENV (in case
+;;; it was a closure). If it is actually a FIN, then we need to do an
+;;; extra indirection with funcallable-instance-lexenv to get at any
+;;; closure environment. This extra indirection is set up when
+;;; accessing the closure environment of an INSTANCE-LAMBDA. Note that
+;;; the original FIN pointer is lost, so if the called function wants
+;;; to get at the original object to do some slot accesses, it must
+;;; close over the FIN object.
+;;;
+;;; If we set the FIN function to be a FIN, we directly copy across
+;;; both the code pointer and the lexenv, since that code pointer (for
+;;; an instance-lambda) is expecting that lexenv to be accessed. This
+;;; effectively pre-flattens what would otherwise be a chain of
+;;; indirections. Lest this sound like an excessively obscure case,
+;;; note that it happens when PCL dispatch functions are
+;;; byte-compiled.
+;;;
+;;; The only loss is that if someone accesses the
+;;; FUNCALLABLE-INSTANCE-FUNCTION, then won't get a FIN back. This
+;;; probably doesn't matter, since PCL only sets the FIN function. And
+;;; the only reason that interpreted functions are FINs instead of
+;;; bare closures is for debuggability.
+(defun (setf funcallable-instance-function) (new-value fin)
+ (setf (%funcallable-instance-function fin)
+ (%closure-function new-value))
+ (setf (%funcallable-instance-lexenv fin)
+ (if (funcallable-instance-p new-value)
+ (%funcallable-instance-lexenv new-value)
+ new-value)))
+\f
+;;; Copy any old kind of structure.
+(defun copy-structure (structure)
+ #!+sb-doc
+ "Return a copy of STRUCTURE with the same (EQL) slot values."
+ (declare (type structure-object structure))
+ (let* ((len (%instance-length structure))
+ (res (%make-instance len))
+ (layout (%instance-layout structure)))
+
+ (declare (type index len))
+ (when (layout-invalid layout)
+ (error "attempt to copy an obsolete structure:~% ~S" structure))
+
+ ;; Copy ordinary slots.
+ (dotimes (i len)
+ (declare (type index i))
+ (setf (%instance-ref res i)
+ (%instance-ref structure i)))
+
+ ;; Copy raw slots.
+ (let ((raw-index (dd-raw-index (layout-info layout))))
+ (when raw-index
+ (let* ((data (%instance-ref structure raw-index))
+ (raw-len (length data))
+ (new (make-array raw-len :element-type '(unsigned-byte 32))))
+ (declare (type (simple-array (unsigned-byte 32) (*)) data))
+ (setf (%instance-ref res raw-index) new)
+ (dotimes (i raw-len)
+ (setf (aref new i) (aref data i))))))
+
+ res))
+\f
+;;; default PRINT and MAKE-LOAD-FORM methods
+
+(defun default-structure-print (structure stream depth)
+ (declare (ignore depth))
+ (if (funcallable-instance-p structure)
+ (print-unreadable-object (structure stream :identity t :type t))
+ (let* ((type (%instance-layout structure))
+ (name (sb!xc:class-name (layout-class type)))
+ (dd (layout-info type)))
+ (if *print-pretty*
+ (pprint-logical-block (stream nil :prefix "#S(" :suffix ")")
+ (prin1 name stream)
+ (let ((slots (dd-slots dd)))
+ (when slots
+ (write-char #\space stream)
+ ;; CMU CL had (PPRINT-INDENT :BLOCK 2 STREAM) here,
+ ;; but I can't see why. -- WHN 20000205
+ (pprint-newline :linear stream)
+ (loop
+ (pprint-pop)
+ (let ((slot (pop slots)))
+ (write-char #\: stream)
+ (output-symbol-name (dsd-%name slot) stream)
+ (write-char #\space stream)
+ (pprint-newline :miser stream)
+ (output-object (funcall (fdefinition (dsd-accessor slot))
+ structure)
+ stream)
+ (when (null slots)
+ (return))
+ (write-char #\space stream)
+ (pprint-newline :linear stream))))))
+ (descend-into (stream)
+ (write-string "#S(" stream)
+ (prin1 name stream)
+ (do ((index 0 (1+ index))
+ (slots (dd-slots dd) (cdr slots)))
+ ((or (null slots)
+ (and (not *print-readably*)
+ (>= index *print-length*)))
+ (if (null slots)
+ (write-string ")" stream)
+ (write-string " ...)" stream)))
+ (declare (type index index))
+ (write-char #\space stream)
+ (write-char #\: stream)
+ (let ((slot (first slots)))
+ (output-symbol-name (dsd-%name slot) stream)
+ (write-char #\space stream)
+ (output-object (funcall (fdefinition (dsd-accessor slot))
+ structure)
+ stream))))))))
+(def!method print-object ((x structure-object) stream)
+ (default-structure-print x stream *current-level*))
+
+(defun make-load-form-saving-slots (object &key slot-names environment)
+ (declare (ignore object environment))
+ (if slot-names
+ (error "stub: MAKE-LOAD-FORM-SAVING-SLOTS :SLOT-NAMES not implemented") ; KLUDGE
+ :just-dump-it-normally))
+\f
+;;; Return true if OBJ is an object of the structure type
+;;; corresponding to LAYOUT. This is called by the accessor closures,
+;;; which have a handle on the type's layout.
+;;;
+;;; FIXME: This is fairly big, so it should probably become
+;;; MAYBE-INLINE instead of INLINE. Or else we could fix things up so
+;;; that the things which call it are all closures, so that it's
+;;; expanded only in a small number of places.
+#!-sb-fluid (declaim (inline typep-to-layout))
+(defun typep-to-layout (obj layout)
+ (declare (type layout layout) (optimize (speed 3) (safety 0)))
+ (when (layout-invalid layout)
+ (error "An obsolete structure accessor function was called."))
+ ;; FIXME: CMU CL used (%INSTANCEP OBJ) here. Check that
+ ;; (TYPEP OBJ 'INSTANCE) is optimized to equally efficient code.
+ (and (typep obj 'instance)
+ (let (;; FIXME: Mightn't there be a slight efficiency improvement
+ ;; by delaying the binding of DEPTHOID 'til it's needed?
+ (depthoid (layout-depthoid layout))
+ (obj-layout (%instance-layout obj)))
+ (cond ((eq obj-layout layout)
+ t)
+ ;; FIXME: Does the test for LAYOUT-INVALID really belong
+ ;; after the test for EQ LAYOUT? Either explain why this
+ ;; is, or change the order.
+ ((layout-invalid obj-layout)
+ (error 'layout-invalid
+ :expected-type (layout-class obj-layout)
+ :datum obj))
+ (t
+ (and (> (layout-depthoid obj-layout) depthoid)
+ (eq (svref (layout-inherits obj-layout) depthoid)
+ layout)))))))
+\f
+;;;; implementing structure slot accessors as closures
+
+;;; In the normal case of structures that have a real type (i.e. no
+;;; :TYPE option was specified), we want to optimize things for space
+;;; as well as speed, since there can be thousands of defined slot
+;;; accessors.
+;;;
+;;; What we do is define the accessors and copier as closures over
+;;; general-case code. Since the compiler will normally open-code
+;;; accessors, the (minor) extra speed penalty for full calls is not a
+;;; concern.
+;;;
+;;; KLUDGE: This is a minor headache at cold init time, since genesis
+;;; doesn't know how to create the closures in the cold image, so the
+;;; function definitions aren't done until the appropriate top level
+;;; forms are executed, so any forward references to structure slots
+;;; (which are compiled into full calls) fail. The headache can be
+;;; treated by using SB!XC:DEFSTRUCT on the relevant structure at
+;;; build-the-cross-compiler time, so that the compiler is born
+;;; knowing how to inline accesses to the relevant structure, so no
+;;; full calls are made. This can be achieved by calling
+;;; SB!XC:DEFSTRUCT directly, or by using DEF!STRUCT, which (among
+;;; other things) calls SB!XC:DEFSTRUCT for you.
+
+;;; Return closures to do slot access according to Layout and DSD. We check
+;;; types, then do the access. This is only used for normal slots, not raw
+;;; slots.
+(defun structure-slot-getter (layout dsd)
+ (let ((class (layout-class layout)))
+ (if (typep class 'basic-structure-class)
+ #'(lambda (structure)
+ (declare (optimize (speed 3) (safety 0)))
+ (flet ((structure-test (structure)
+ (typep-to-layout structure layout)))
+ (unless (structure-test structure)
+ (error 'simple-type-error
+ :datum structure
+ ;; FIXME: :EXPECTED-TYPE should be something
+ ;; comprehensible to the user, not this. Perhaps we
+ ;; could work backwards from the LAYOUT-CLASS slot to
+ ;; find something. (Note that all four SIMPLE-TYPE-ERROR
+ ;; calls in this section have the same disease.)
+ :expected-type '(satisfies structure-test)
+ :format-control
+ "Structure for accessor ~S is not a ~S:~% ~S"
+ :format-arguments
+ (list (dsd-accessor dsd)
+ (sb!xc:class-name (layout-class layout))
+ structure))))
+ (%instance-ref structure (dsd-index dsd)))
+ #'(lambda (structure)
+ (declare (optimize (speed 3) (safety 0)))
+ (unless (%typep structure class)
+ (error 'simple-type-error
+ :datum structure
+ :expected-type 'class
+ :format-control
+ "The structure for accessor ~S is not a ~S:~% ~S"
+ :format-arguments
+ (list (dsd-accessor dsd) class
+ structure)))
+ (%instance-ref structure (dsd-index dsd))))))
+(defun structure-slot-setter (layout dsd)
+ (let ((class (layout-class layout)))
+ (if (typep class 'basic-structure-class)
+ #'(lambda (new-value structure)
+ (declare (optimize (speed 3) (safety 0)))
+ (flet ((structure-test (structure)
+ (typep-to-layout structure layout))
+ (typep-test (new-value)
+ (%typep new-value (dsd-type dsd))))
+ (unless (structure-test structure)
+ (error 'simple-type-error
+ :datum structure
+ :expected-type '(satisfies structure-test)
+ :format-control
+ "The structure for setter ~S is not a ~S:~% ~S"
+ :format-arguments
+ (list `(setf ,(dsd-accessor dsd))
+ (sb!xc:class-name (layout-class layout))
+ structure)))
+ (unless (typep-test new-value)
+ (error 'simple-type-error
+ :datum new-value
+ :expected-type '(satisfies typep-test)
+ :format-control
+ "The new value for setter ~S is not a ~S:~% ~S"
+ :format-arguments
+ (list `(setf ,(dsd-accessor dsd))
+ (dsd-type dsd)
+ new-value))))
+ (setf (%instance-ref structure (dsd-index dsd)) new-value))
+ #'(lambda (new-value structure)
+ (declare (optimize (speed 3) (safety 0)))
+ (flet ((structure-test (structure)
+ (sb!xc:typep structure class))
+ (typep-test (new-value)
+ (%typep new-value (dsd-type dsd))))
+ (unless (structure-test structure)
+ (error 'simple-type-error
+ :datum structure
+ :expected-type '(satisfies structure-test)
+ :format-control
+ "The structure for setter ~S is not a ~S:~% ~S"
+ :format-arguments
+ (list `(setf ,(dsd-accessor dsd))
+ (sb!xc:class-name class)
+ structure)))
+ (unless (typep-test new-value)
+ (error 'simple-type-error
+ :datum new-value
+ :expected-type '(satisfies typep-test)
+ :format-control
+ "The new value for setter ~S is not a ~S:~% ~S"
+ :format-arguments
+ (list `(setf ,(dsd-accessor dsd))
+ (dsd-type dsd)
+ new-value))))
+ (setf (%instance-ref structure (dsd-index dsd)) new-value)))))
--- /dev/null
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!IMPL")
+
+(file-comment
+ "$Header$")
+
+;;; FIXME: These probably belong in some package other than SB!IMPL.
+;;; Perhaps SB!KERNEL?
+
+(defconstant call-arguments-limit most-positive-fixnum
+ #!+sb-doc
+ "The exclusive upper bound on the number of arguments which may be passed
+ to a function, including rest args.")
+
+(defconstant lambda-parameters-limit most-positive-fixnum
+ #!+sb-doc
+ "The exclusive upper bound on the number of parameters which may be specifed
+ in a given lambda list. This is actually the limit on required and optional
+ parameters. With &key and &aux you can get more.")
+
+(defconstant multiple-values-limit most-positive-fixnum
+ #!+sb-doc
+ "The exclusive upper bound on the number of multiple-values that you can
+ have.")
+\f
+;;; FIXME: more than one IN-PACKAGE in one file, ick
+(in-package "SB!EVAL")
+
+;;; This is defined here so that the printer etc. can call
+;;; INTERPRETED-FUNCTION-P before the full interpreter is loaded.
+
+;;; an interpreted function
+(defstruct (interpreted-function
+ (:alternate-metaclass sb!kernel:funcallable-instance
+ sb!kernel:funcallable-structure-class
+ sb!kernel:make-funcallable-structure-class)
+ (:type sb!kernel:funcallable-structure)
+ (:constructor %make-interpreted-function)
+ (:copier nil)
+ ;; FIXME: Binding PRINT-OBJECT isn't going to help unless
+ ;; we fix the print-a-funcallable-instance code so that
+ ;; it calls PRINT-OBJECT in this case.
+ (:print-object
+ (lambda (x stream)
+ (print-unreadable-object (x stream :identity t)
+ (sb!impl::output-interpreted-function x stream)))))
+ ;; The name of this interpreted function, or NIL if none specified.
+ (%name nil)
+ ;; This function's debug arglist.
+ (arglist nil)
+ ;; A lambda that can be converted to get the definition.
+ (lambda nil)
+ ;; If this function has been converted, then this is the XEP. If this is
+ ;; false, then the function is not in the cache (or is in the process of
+ ;; being removed.)
+ (definition nil :type (or sb!c::clambda null))
+ ;; The number of consequtive GCs that this function has been unused. This is
+ ;; used to control cache replacement.
+ (gcs 0 :type sb!c::index)
+ ;; True if Lambda has been converted at least once, and thus warnings should
+ ;; be suppressed on additional conversions.
+ (converted-once nil)
+ ;; For a closure, the closure date vector.
+ (closure nil :type (or null simple-vector)))
+\f
+(in-package "SB!IMPL")
+
+;;;; One of the steps in building a nice debuggable macro is changing
+;;;; its MACRO-FUNCTION to print as e.g.
+;;;; #<Interpreted Function "DEFMACRO BAR" {9166351}>
+;;;; instead of some
+;;;; weird internal representation showing the environment argument and stuff.
+;;;; This function is called in order to try to make that happen.
+;;;;
+;;;; When we're running in the target SBCL, we own the INTERPRETED-FUNCTION
+;;;; definition, and we can do this; that's what the definition below does.
+;;;; When we're a Python cross-compiler running in some arbitrary ANSI Common
+;;;; Lisp, we can't do this (and we don't care that much about making nice
+;;;; debuggable macros anyway). In that environment, a stub no-op version of
+;;;; this function is used.
+(defun try-to-rename-interpreted-function-as-macro (f name lambda-list)
+ (assert (sb!eval:interpreted-function-p f))
+ (setf (sb!eval:interpreted-function-name f)
+ (format nil "DEFMACRO ~S" name)
+ (sb!eval:interpreted-function-arglist f)
+ lambda-list)
+ (values))
+\f
+;;;; EVAL and friends
+
+;;; This needs to be initialized in the cold load, since the top-level catcher
+;;; will always restore the initial value.
+(defvar *eval-stack-top* 0)
+
+;;; Pick off a few easy cases, and call INTERNAL-EVAL for the rest. If
+;;; *ALREADY-EVALED-THIS* is true, then we bind it to NIL before doing a call
+;;; so that the effect is confined to the lexical scope of the EVAL-WHEN.
+(defun eval (original-exp)
+ #!+sb-doc
+ "Evaluates its single arg in a null lexical environment, returns the
+ result or results."
+ (declare (optimize (safety 1)))
+ (let ((exp (macroexpand original-exp)))
+ (typecase exp
+ (symbol
+ (ecase (info :variable :kind exp)
+ (:constant
+ (values (info :variable :constant-value exp)))
+ ((:special :global)
+ (symbol-value exp))
+ (:alien
+ (sb!eval:internal-eval original-exp))))
+ (list
+ (let ((name (first exp))
+ (args (1- (length exp))))
+ (case name
+ (function
+ (unless (= args 1)
+ (error "wrong number of args to FUNCTION:~% ~S" exp))
+ (let ((name (second exp)))
+ (if (or (atom name)
+ (and (consp name)
+ (eq (car name) 'setf)))
+ (fdefinition name)
+ (sb!eval:make-interpreted-function name))))
+ (quote
+ (unless (= args 1)
+ (error "wrong number of args to QUOTE:~% ~S" exp))
+ (second exp))
+ (setq
+ (unless (evenp args)
+ (error "odd number of args to SETQ:~% ~S" exp))
+ (unless (zerop args)
+ (do ((name (cdr exp) (cddr name)))
+ ((null name)
+ (do ((args (cdr exp) (cddr args)))
+ ((null (cddr args))
+ ;; We duplicate the call to SET so that the correct
+ ;; value gets returned.
+ (set (first args) (eval (second args))))
+ (set (first args) (eval (second args)))))
+ (let ((symbol (first name)))
+ (case (info :variable :kind symbol)
+ ;; FIXME: I took out the *TOP-LEVEL-AUTO-DECLARE*
+ ;; test here, and removed the *TOP-LEVEL-AUTO-DECLARE*
+ ;; variable; the code should now act as though that
+ ;; variable is NIL. This should be tested..
+ (:special)
+ (t (return (sb!eval:internal-eval original-exp))))))))
+ ((progn)
+ (when (> args 0)
+ (dolist (x (butlast (rest exp)) (eval (car (last exp))))
+ (eval x))))
+ ((eval-when)
+ (if (and (> args 0)
+ (or (member 'eval (second exp))
+ (member :execute (second exp))))
+ (when (> args 1)
+ (dolist (x (butlast (cddr exp)) (eval (car (last exp))))
+ (eval x)))
+ (sb!eval:internal-eval original-exp)))
+ (t
+ (if (and (symbolp name)
+ (eq (info :function :kind name) :function))
+ (collect ((args))
+ (dolist (arg (rest exp))
+ (args (eval arg)))
+ (if sb!eval::*already-evaled-this*
+ (let ((sb!eval::*already-evaled-this* nil))
+ (apply (symbol-function name) (args)))
+ (apply (symbol-function name) (args))))
+ (sb!eval:internal-eval original-exp))))))
+ (t
+ exp))))
+
+;;; not needed in new from-scratch cross-compilation procedure -- WHN 19990714
+#|
+;;; Dummy stubs for SB!EVAL:INTERNAL-EVAL and SB!EVAL:MAKE-INTERPRETED-FUNCTION
+;;; in case the compiler isn't loaded yet.
+(defun sb!eval:internal-eval (x)
+ (error "attempt to evaluation a complex expression:~% ~S~@
+ This expression must be compiled, but the compiler is not loaded."
+ x))
+(defun sb!eval:make-interpreted-function (x)
+ (error "EVAL called on #'(lambda (x) ...) when the compiler isn't loaded:~
+ ~% ~S~%"
+ x))
+|#
+
+;;; If interpreted, use the interpreter interface. Otherwise, see
+;;; whether it was compiled with COMPILE. If that fails, check for an
+;;; inline expansion.
+(defun function-lambda-expression (fun)
+ #!+sb-doc
+ "Given a function, return three values:
+ 1] A lambda expression that could be used to define the function, or NIL if
+ the definition isn't available.
+ 2] NIL if the function was definitely defined in a null lexical environment,
+ and T otherwise.
+ 3] Some object that \"names\" the function. Although this is allowed to be
+ any object, CMU CL always returns a valid function name or a string."
+ (declare (type function fun))
+ (if (sb!eval:interpreted-function-p fun)
+ (sb!eval:interpreted-function-lambda-expression fun)
+ (let* ((fun (%function-self fun))
+ (name (%function-name fun))
+ (code (sb!di::function-code-header fun))
+ (info (sb!kernel:%code-debug-info code)))
+ (if info
+ (let ((source (first (sb!c::compiled-debug-info-source info))))
+ (cond ((and (eq (sb!c::debug-source-from source) :lisp)
+ (eq (sb!c::debug-source-info source) fun))
+ (values (second (svref (sb!c::debug-source-name source) 0))
+ nil name))
+ ((stringp name)
+ (values nil t name))
+ (t
+ (let ((exp (info :function :inline-expansion name)))
+ (if exp
+ (values exp nil name)
+ (values nil t name))))))
+ (values nil t name)))))
+
+;;; Like FIND-IF, only we do it on a compiled closure's environment.
+(defun find-if-in-closure (test fun)
+ (dotimes (index (1- (get-closure-length fun)))
+ (let ((elt (%closure-index-ref fun index)))
+ (when (funcall test elt)
+ (return elt)))))
+\f
+;;; function invocation
+
+(defun apply (function arg &rest args)
+ #!+sb-doc
+ "Applies FUNCTION to a list of arguments produced by evaluating ARGS in
+ the manner of LIST*. That is, a list is made of the values of all but the
+ last argument, appended to the value of the last argument, which must be a
+ list."
+ (cond ((atom args)
+ (apply function arg))
+ ((atom (cdr args))
+ (apply function (cons arg (car args))))
+ (t (do* ((a1 args a2)
+ (a2 (cdr args) (cdr a2)))
+ ((atom (cdr a2))
+ (rplacd a1 (car a2))
+ (apply function (cons arg args)))))))
+
+(defun funcall (function &rest arguments)
+ #!+sb-doc
+ "Calls Function with the given Arguments."
+ (apply function arguments))
+\f
+;;; multiple-value forms
+
+(defun values (&rest values)
+ #!+sb-doc
+ "Returns all arguments, in order, as values."
+ (values-list values))
+
+(defun values-list (list)
+ #!+sb-doc
+ "Returns all of the elements of LIST, in order, as values."
+ (values-list list))
--- /dev/null
+;;;; This file contains things for the extensions package which can't
+;;;; be built at cross-compile time, and perhaps also some things
+;;;; which might as well not be built at cross-compile time because
+;;;; they're not needed then. Things which can't be built at
+;;;; cross-compile time (e.g. because they need machinery which only
+;;;; exists inside SBCL's implementation of the LISP package) do not
+;;;; belong in this file.
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!EXT")
+
+(file-comment
+ "$Header$")
+
+;;; INDENTING-FURTHER is a user-level macro which may be used to locally
+;;; increment the indentation of a stream.
+(defmacro indenting-further (stream more &rest body)
+ #!+sb-doc
+ "Causes the output of the indenting Stream to indent More spaces. More is
+ evaluated twice."
+ `(unwind-protect
+ (progn
+ (incf (sb!impl::indenting-stream-indentation ,stream) ,more)
+ ,@body)
+ (decf (sb!impl::indenting-stream-indentation ,stream) ,more)))
+
+(defun skip-whitespace (&optional (stream *standard-input*))
+ (loop (let ((char (read-char stream)))
+ (unless (sb!impl::whitespacep char)
+ (return (unread-char char stream))))))
+
+(defun listen-skip-whitespace (&optional (stream *standard-input*))
+ #!+sb-doc
+ "See LISTEN. Any whitespace in the input stream will be flushed."
+ (do ((char (read-char-no-hang stream nil nil nil)
+ (read-char-no-hang stream nil nil nil)))
+ ((null char) nil)
+ (cond ((not (sb!impl::whitespace-char-p char))
+ (unread-char char stream)
+ (return t)))))
--- /dev/null
+;;;; functions to implement FORMAT and FORMATTER
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!FORMAT")
+
+(file-comment
+ "$Header$")
+\f
+;;;; FORMAT
+
+(defun format (destination control-string &rest format-arguments)
+ #!+sb-doc
+ "Provides various facilities for formatting output.
+ CONTROL-STRING contains a string to be output, possibly with embedded
+ directives, which are flagged with the escape character \"~\". Directives
+ generally expand into additional text to be output, usually consuming one
+ or more of the FORMAT-ARGUMENTS in the process. A few useful directives
+ are:
+ ~A or ~nA Prints one argument as if by PRINC
+ ~S or ~nS Prints one argument as if by PRIN1
+ ~D or ~nD Prints one argument as a decimal integer
+ ~% Does a TERPRI
+ ~& Does a FRESH-LINE
+
+ where n is the width of the field in which the object is printed.
+
+ DESTINATION controls where the result will go. If DESTINATION is T, then
+ the output is sent to the standard output stream. If it is NIL, then the
+ output is returned in a string as the value of the call. Otherwise,
+ DESTINATION must be a stream to which the output will be sent.
+
+ Example: (FORMAT NIL \"The answer is ~D.\" 10) => \"The answer is 10.\"
+
+ FORMAT has many additional capabilities not described here. Consult the
+ manual for details."
+ (etypecase destination
+ (null
+ (with-output-to-string (stream)
+ (%format stream control-string format-arguments)))
+ (string
+ (with-output-to-string (stream destination)
+ (%format stream control-string format-arguments)))
+ ((member t)
+ (%format *standard-output* control-string format-arguments)
+ nil)
+ (stream
+ (%format destination control-string format-arguments)
+ nil)))
+
+(defun %format (stream string-or-fun orig-args &optional (args orig-args))
+ (if (functionp string-or-fun)
+ (apply string-or-fun stream args)
+ (catch 'up-and-out
+ (let* ((string (etypecase string-or-fun
+ (simple-string
+ string-or-fun)
+ (string
+ (coerce string-or-fun 'simple-string))))
+ (*default-format-error-control-string* string)
+ (*logical-block-popper* nil))
+ (interpret-directive-list stream (tokenize-control-string string)
+ orig-args args)))))
+
+(defun interpret-directive-list (stream directives orig-args args)
+ (if directives
+ (let ((directive (car directives)))
+ (etypecase directive
+ (simple-string
+ (write-string directive stream)
+ (interpret-directive-list stream (cdr directives) orig-args args))
+ (format-directive
+ (multiple-value-bind (new-directives new-args)
+ (let ((function
+ (svref *format-directive-interpreters*
+ (char-code (format-directive-character
+ directive))))
+ (*default-format-error-offset*
+ (1- (format-directive-end directive))))
+ (unless function
+ (error 'format-error
+ :complaint "unknown format directive"))
+ (multiple-value-bind (new-directives new-args)
+ (funcall function stream directive
+ (cdr directives) orig-args args)
+ (values new-directives new-args)))
+ (interpret-directive-list stream new-directives
+ orig-args new-args)))))
+ args))
+\f
+;;;; FORMAT directive definition macros and runtime support
+
+(eval-when (:compile-toplevel :execute)
+
+;;; This macro is used to extract the next argument from the current arg list.
+;;; This is the version used by format directive interpreters.
+(sb!xc:defmacro next-arg (&optional offset)
+ `(progn
+ (when (null args)
+ (error 'format-error
+ :complaint "no more arguments"
+ ,@(when offset
+ `(:offset ,offset))))
+ (when *logical-block-popper*
+ (funcall *logical-block-popper*))
+ (pop args)))
+
+(sb!xc:defmacro def-complex-format-interpreter (char lambda-list &body body)
+ (let ((defun-name
+ (intern (format nil
+ "~:@(~:C~)-FORMAT-DIRECTIVE-INTERPRETER"
+ char)))
+ (directive (gensym))
+ (directives (if lambda-list (car (last lambda-list)) (gensym))))
+ `(progn
+ (defun ,defun-name (stream ,directive ,directives orig-args args)
+ (declare (ignorable stream orig-args args))
+ ,@(if lambda-list
+ `((let ,(mapcar #'(lambda (var)
+ `(,var
+ (,(intern (concatenate
+ 'string
+ "FORMAT-DIRECTIVE-"
+ (symbol-name var))
+ (symbol-package 'foo))
+ ,directive)))
+ (butlast lambda-list))
+ (values (progn ,@body) args)))
+ `((declare (ignore ,directive ,directives))
+ ,@body)))
+ (%set-format-directive-interpreter ,char #',defun-name))))
+
+(sb!xc:defmacro def-format-interpreter (char lambda-list &body body)
+ (let ((directives (gensym)))
+ `(def-complex-format-interpreter ,char (,@lambda-list ,directives)
+ ,@body
+ ,directives)))
+
+(sb!xc:defmacro interpret-bind-defaults (specs params &body body)
+ (once-only ((params params))
+ (collect ((bindings))
+ (dolist (spec specs)
+ (destructuring-bind (var default) spec
+ (bindings `(,var (let* ((param-and-offset (pop ,params))
+ (offset (car param-and-offset))
+ (param (cdr param-and-offset)))
+ (case param
+ (:arg (next-arg offset))
+ (:remaining (length args))
+ ((nil) ,default)
+ (t param)))))))
+ `(let* ,(bindings)
+ (when ,params
+ (error 'format-error
+ :complaint
+ "too many parameters, expected no more than ~D"
+ :arguments (list ,(length specs))
+ :offset (caar ,params)))
+ ,@body))))
+
+) ; EVAL-WHEN
+\f
+;;;; format interpreters and support functions for simple output
+
+(defun format-write-field (stream string mincol colinc minpad padchar padleft)
+ (unless padleft
+ (write-string string stream))
+ (dotimes (i minpad)
+ (write-char padchar stream))
+ (do ((chars (+ (length string) minpad) (+ chars colinc)))
+ ((>= chars mincol))
+ (dotimes (i colinc)
+ (write-char padchar stream)))
+ (when padleft
+ (write-string string stream)))
+
+(defun format-princ (stream arg colonp atsignp mincol colinc minpad padchar)
+ (format-write-field stream
+ (if (or arg (not colonp))
+ (princ-to-string arg)
+ "()")
+ mincol colinc minpad padchar atsignp))
+
+(def-format-interpreter #\A (colonp atsignp params)
+ (if params
+ (interpret-bind-defaults ((mincol 0) (colinc 1) (minpad 0)
+ (padchar #\space))
+ params
+ (format-princ stream (next-arg) colonp atsignp
+ mincol colinc minpad padchar))
+ (princ (if colonp (or (next-arg) "()") (next-arg)) stream)))
+
+(defun format-prin1 (stream arg colonp atsignp mincol colinc minpad padchar)
+ (format-write-field stream
+ (if (or arg (not colonp))
+ (prin1-to-string arg)
+ "()")
+ mincol colinc minpad padchar atsignp))
+
+(def-format-interpreter #\S (colonp atsignp params)
+ (cond (params
+ (interpret-bind-defaults ((mincol 0) (colinc 1) (minpad 0)
+ (padchar #\space))
+ params
+ (format-prin1 stream (next-arg) colonp atsignp
+ mincol colinc minpad padchar)))
+ (colonp
+ (let ((arg (next-arg)))
+ (if arg
+ (prin1 arg stream)
+ (princ "()" stream))))
+ (t
+ (prin1 (next-arg) stream))))
+
+(def-format-interpreter #\C (colonp atsignp params)
+ (interpret-bind-defaults () params
+ (if colonp
+ (format-print-named-character (next-arg) stream)
+ (if atsignp
+ (prin1 (next-arg) stream)
+ (write-char (next-arg) stream)))))
+
+(defun format-print-named-character (char stream)
+ (let* ((name (char-name char)))
+ (cond (name
+ (write-string (string-capitalize name) stream))
+ ((<= 0 (char-code char) 31)
+ ;; Print control characters as "^"<char>
+ (write-char #\^ stream)
+ (write-char (code-char (+ 64 (char-code char))) stream))
+ (t
+ (write-char char stream)))))
+
+(def-format-interpreter #\W (colonp atsignp params)
+ (interpret-bind-defaults () params
+ (let ((*print-pretty* (or colonp *print-pretty*))
+ (*print-level* (and atsignp *print-level*))
+ (*print-length* (and atsignp *print-length*)))
+ (output-object (next-arg) stream))))
+\f
+;;;; format interpreters and support functions for integer output
+
+;;; FORMAT-PRINT-NUMBER does most of the work for the numeric printing
+;;; directives. The parameters are interpreted as defined for ~D.
+(defun format-print-integer (stream number print-commas-p print-sign-p
+ radix mincol padchar commachar commainterval)
+ (let ((*print-base* radix)
+ (*print-radix* nil))
+ (if (integerp number)
+ (let* ((text (princ-to-string (abs number)))
+ (commaed (if print-commas-p
+ (format-add-commas text commachar commainterval)
+ text))
+ (signed (cond ((minusp number)
+ (concatenate 'string "-" commaed))
+ (print-sign-p
+ (concatenate 'string "+" commaed))
+ (t commaed))))
+ ;; colinc = 1, minpad = 0, padleft = t
+ (format-write-field stream signed mincol 1 0 padchar t))
+ (princ number))))
+
+(defun format-add-commas (string commachar commainterval)
+ (let ((length (length string)))
+ (multiple-value-bind (commas extra) (truncate (1- length) commainterval)
+ (let ((new-string (make-string (+ length commas)))
+ (first-comma (1+ extra)))
+ (replace new-string string :end1 first-comma :end2 first-comma)
+ (do ((src first-comma (+ src commainterval))
+ (dst first-comma (+ dst commainterval 1)))
+ ((= src length))
+ (setf (schar new-string dst) commachar)
+ (replace new-string string :start1 (1+ dst)
+ :start2 src :end2 (+ src commainterval)))
+ new-string))))
+
+;;; FIXME: This is only needed in this file, could be defined with
+;;; SB!XC:DEFMACRO inside EVAL-WHEN
+(defmacro interpret-format-integer (base)
+ `(if (or colonp atsignp params)
+ (interpret-bind-defaults
+ ((mincol 0) (padchar #\space) (commachar #\,) (commainterval 3))
+ params
+ (format-print-integer stream (next-arg) colonp atsignp ,base mincol
+ padchar commachar commainterval))
+ (write (next-arg) :stream stream :base ,base :radix nil :escape nil)))
+
+(def-format-interpreter #\D (colonp atsignp params)
+ (interpret-format-integer 10))
+
+(def-format-interpreter #\B (colonp atsignp params)
+ (interpret-format-integer 2))
+
+(def-format-interpreter #\O (colonp atsignp params)
+ (interpret-format-integer 8))
+
+(def-format-interpreter #\X (colonp atsignp params)
+ (interpret-format-integer 16))
+
+(def-format-interpreter #\R (colonp atsignp params)
+ (if params
+ (interpret-bind-defaults
+ ((base 10) (mincol 0) (padchar #\space) (commachar #\,)
+ (commainterval 3))
+ params
+ (format-print-integer stream (next-arg) colonp atsignp base mincol
+ padchar commachar commainterval))
+ (if atsignp
+ (if colonp
+ (format-print-old-roman stream (next-arg))
+ (format-print-roman stream (next-arg)))
+ (if colonp
+ (format-print-ordinal stream (next-arg))
+ (format-print-cardinal stream (next-arg))))))
+
+(defconstant cardinal-ones
+ #(nil "one" "two" "three" "four" "five" "six" "seven" "eight" "nine"))
+
+(defconstant cardinal-tens
+ #(nil nil "twenty" "thirty" "forty"
+ "fifty" "sixty" "seventy" "eighty" "ninety"))
+
+(defconstant cardinal-teens
+ #("ten" "eleven" "twelve" "thirteen" "fourteen" ;;; RAD
+ "fifteen" "sixteen" "seventeen" "eighteen" "nineteen"))
+
+(defconstant cardinal-periods
+ #("" " thousand" " million" " billion" " trillion" " quadrillion"
+ " quintillion" " sextillion" " septillion" " octillion" " nonillion"
+ " decillion" " undecillion" " duodecillion" " tredecillion"
+ " quattuordecillion" " quindecillion" " sexdecillion" " septendecillion"
+ " octodecillion" " novemdecillion" " vigintillion"))
+
+(defconstant ordinal-ones
+ #(nil "first" "second" "third" "fourth"
+ "fifth" "sixth" "seventh" "eighth" "ninth")
+ #!+sb-doc
+ "Table of ordinal ones-place digits in English")
+
+(defconstant ordinal-tens
+ #(nil "tenth" "twentieth" "thirtieth" "fortieth"
+ "fiftieth" "sixtieth" "seventieth" "eightieth" "ninetieth")
+ #!+sb-doc
+ "Table of ordinal tens-place digits in English")
+
+(defun format-print-small-cardinal (stream n)
+ (multiple-value-bind (hundreds rem) (truncate n 100)
+ (when (plusp hundreds)
+ (write-string (svref cardinal-ones hundreds) stream)
+ (write-string " hundred" stream)
+ (when (plusp rem)
+ (write-char #\space stream)))
+ (when (plusp rem)
+ (multiple-value-bind (tens ones) (truncate rem 10)
+ (cond ((< 1 tens)
+ (write-string (svref cardinal-tens tens) stream)
+ (when (plusp ones)
+ (write-char #\- stream)
+ (write-string (svref cardinal-ones ones) stream)))
+ ((= tens 1)
+ (write-string (svref cardinal-teens ones) stream))
+ ((plusp ones)
+ (write-string (svref cardinal-ones ones) stream)))))))
+
+(defun format-print-cardinal (stream n)
+ (cond ((minusp n)
+ (write-string "negative " stream)
+ (format-print-cardinal-aux stream (- n) 0 n))
+ ((zerop n)
+ (write-string "zero" stream))
+ (t
+ (format-print-cardinal-aux stream n 0 n))))
+
+(defun format-print-cardinal-aux (stream n period err)
+ (multiple-value-bind (beyond here) (truncate n 1000)
+ (unless (<= period 20)
+ (error "number too large to print in English: ~:D" err))
+ (unless (zerop beyond)
+ (format-print-cardinal-aux stream beyond (1+ period) err))
+ (unless (zerop here)
+ (unless (zerop beyond)
+ (write-char #\space stream))
+ (format-print-small-cardinal stream here)
+ (write-string (svref cardinal-periods period) stream))))
+
+(defun format-print-ordinal (stream n)
+ (when (minusp n)
+ (write-string "negative " stream))
+ (let ((number (abs n)))
+ (multiple-value-bind (top bot) (truncate number 100)
+ (unless (zerop top)
+ (format-print-cardinal stream (- number bot)))
+ (when (and (plusp top) (plusp bot))
+ (write-char #\space stream))
+ (multiple-value-bind (tens ones) (truncate bot 10)
+ (cond ((= bot 12) (write-string "twelfth" stream))
+ ((= tens 1)
+ (write-string (svref cardinal-teens ones) stream);;;RAD
+ (write-string "th" stream))
+ ((and (zerop tens) (plusp ones))
+ (write-string (svref ordinal-ones ones) stream))
+ ((and (zerop ones)(plusp tens))
+ (write-string (svref ordinal-tens tens) stream))
+ ((plusp bot)
+ (write-string (svref cardinal-tens tens) stream)
+ (write-char #\- stream)
+ (write-string (svref ordinal-ones ones) stream))
+ ((plusp number)
+ (write-string "th" stream))
+ (t
+ (write-string "zeroth" stream)))))))
+
+;;; Print Roman numerals
+
+(defun format-print-old-roman (stream n)
+ (unless (< 0 n 5000)
+ (error "Number too large to print in old Roman numerals: ~:D" n))
+ (do ((char-list '(#\D #\C #\L #\X #\V #\I) (cdr char-list))
+ (val-list '(500 100 50 10 5 1) (cdr val-list))
+ (cur-char #\M (car char-list))
+ (cur-val 1000 (car val-list))
+ (start n (do ((i start (progn
+ (write-char cur-char stream)
+ (- i cur-val))))
+ ((< i cur-val) i))))
+ ((zerop start))))
+
+(defun format-print-roman (stream n)
+ (unless (< 0 n 4000)
+ (error "Number too large to print in Roman numerals: ~:D" n))
+ (do ((char-list '(#\D #\C #\L #\X #\V #\I) (cdr char-list))
+ (val-list '(500 100 50 10 5 1) (cdr val-list))
+ (sub-chars '(#\C #\X #\X #\I #\I) (cdr sub-chars))
+ (sub-val '(100 10 10 1 1 0) (cdr sub-val))
+ (cur-char #\M (car char-list))
+ (cur-val 1000 (car val-list))
+ (cur-sub-char #\C (car sub-chars))
+ (cur-sub-val 100 (car sub-val))
+ (start n (do ((i start (progn
+ (write-char cur-char stream)
+ (- i cur-val))))
+ ((< i cur-val)
+ (cond ((<= (- cur-val cur-sub-val) i)
+ (write-char cur-sub-char stream)
+ (write-char cur-char stream)
+ (- i (- cur-val cur-sub-val)))
+ (t i))))))
+ ((zerop start))))
+\f
+;;;; plural
+
+(def-format-interpreter #\P (colonp atsignp params)
+ (interpret-bind-defaults () params
+ (let ((arg (if colonp
+ (if (eq orig-args args)
+ (error 'format-error
+ :complaint "no previous argument")
+ (do ((arg-ptr orig-args (cdr arg-ptr)))
+ ((eq (cdr arg-ptr) args)
+ (car arg-ptr))))
+ (next-arg))))
+ (if atsignp
+ (write-string (if (eql arg 1) "y" "ies") stream)
+ (unless (eql arg 1) (write-char #\s stream))))))
+\f
+;;;; format interpreters and support functions for floating point output
+
+(defun decimal-string (n)
+ (write-to-string n :base 10 :radix nil :escape nil))
+
+(def-format-interpreter #\F (colonp atsignp params)
+ (when colonp
+ (error 'format-error
+ :complaint
+ "cannot specify the colon modifier with this directive"))
+ (interpret-bind-defaults ((w nil) (d nil) (k nil) (ovf nil) (pad #\space))
+ params
+ (format-fixed stream (next-arg) w d k ovf pad atsignp)))
+
+(defun format-fixed (stream number w d k ovf pad atsign)
+ (if (numberp number)
+ (if (floatp number)
+ (format-fixed-aux stream number w d k ovf pad atsign)
+ (if (rationalp number)
+ (format-fixed-aux stream
+ (coerce number 'single-float)
+ w d k ovf pad atsign)
+ (format-write-field stream
+ (decimal-string number)
+ w 1 0 #\space t)))
+ (format-princ stream number nil nil w 1 0 pad)))
+
+;;; We return true if we overflowed, so that ~G can output the overflow char
+;;; instead of spaces.
+(defun format-fixed-aux (stream number w d k ovf pad atsign)
+ (cond
+ ((or (not (or w d))
+ (and (floatp number)
+ (or (float-infinity-p number)
+ (float-nan-p number))))
+ (prin1 number stream)
+ nil)
+ (t
+ (let ((spaceleft w))
+ (when (and w (or atsign (minusp number))) (decf spaceleft))
+ (multiple-value-bind (str len lpoint tpoint)
+ (sb!impl::flonum-to-string (abs number) spaceleft d k)
+ ;;if caller specifically requested no fraction digits, suppress the
+ ;;optional trailing zero
+ (when (and d (zerop d)) (setq tpoint nil))
+ (when w
+ (decf spaceleft len)
+ ;;optional leading zero
+ (when lpoint
+ (if (or (> spaceleft 0) tpoint) ;force at least one digit
+ (decf spaceleft)
+ (setq lpoint nil)))
+ ;;optional trailing zero
+ (when tpoint
+ (if (> spaceleft 0)
+ (decf spaceleft)
+ (setq tpoint nil))))
+ (cond ((and w (< spaceleft 0) ovf)
+ ;;field width overflow
+ (dotimes (i w) (write-char ovf stream))
+ t)
+ (t
+ (when w (dotimes (i spaceleft) (write-char pad stream)))
+ (if (minusp number)
+ (write-char #\- stream)
+ (if atsign (write-char #\+ stream)))
+ (when lpoint (write-char #\0 stream))
+ (write-string str stream)
+ (when tpoint (write-char #\0 stream))
+ nil)))))))
+
+(def-format-interpreter #\E (colonp atsignp params)
+ (when colonp
+ (error 'format-error
+ :complaint
+ "cannot specify the colon modifier with this directive"))
+ (interpret-bind-defaults
+ ((w nil) (d nil) (e nil) (k 1) (ovf nil) (pad #\space) (mark nil))
+ params
+ (format-exponential stream (next-arg) w d e k ovf pad mark atsignp)))
+
+(defun format-exponential (stream number w d e k ovf pad marker atsign)
+ (if (numberp number)
+ (if (floatp number)
+ (format-exp-aux stream number w d e k ovf pad marker atsign)
+ (if (rationalp number)
+ (format-exp-aux stream
+ (coerce number 'single-float)
+ w d e k ovf pad marker atsign)
+ (format-write-field stream
+ (decimal-string number)
+ w 1 0 #\space t)))
+ (format-princ stream number nil nil w 1 0 pad)))
+
+(defun format-exponent-marker (number)
+ (if (typep number *read-default-float-format*)
+ #\e
+ (typecase number
+ (single-float #\f)
+ (double-float #\d)
+ (short-float #\s)
+ (long-float #\l))))
+
+;;; Here we prevent the scale factor from shifting all significance out of
+;;; a number to the right. We allow insignificant zeroes to be shifted in
+;;; to the left right, athough it is an error to specify k and d such that this
+;;; occurs. Perhaps we should detect both these condtions and flag them as
+;;; errors. As for now, we let the user get away with it, and merely guarantee
+;;; that at least one significant digit will appear.
+
+;;; toy@rtp.ericsson.se: The Hyperspec seems to say that the exponent
+;;; marker is always printed. Make it so. Also, the original version
+;;; causes errors when printing infinities or NaN's. The Hyperspec is
+;;; silent here, so let's just print out infinities and NaN's instead
+;;; of causing an error.
+(defun format-exp-aux (stream number w d e k ovf pad marker atsign)
+ (if (and (floatp number)
+ (or (float-infinity-p number)
+ (float-nan-p number)))
+ (prin1 number stream)
+ (multiple-value-bind (num expt) (sb!impl::scale-exponent (abs number))
+ (let* ((expt (- expt k))
+ (estr (decimal-string (abs expt)))
+ (elen (if e (max (length estr) e) (length estr)))
+ (fdig (if d (if (plusp k) (1+ (- d k)) d) nil))
+ (fmin (if (minusp k) (- 1 k) nil))
+ (spaceleft (if w
+ (- w 2 elen
+ (if (or atsign (minusp number))
+ 1 0))
+ nil)))
+ (if (and w ovf e (> elen e)) ;exponent overflow
+ (dotimes (i w) (write-char ovf stream))
+ (multiple-value-bind (fstr flen lpoint)
+ (sb!impl::flonum-to-string num spaceleft fdig k fmin)
+ (when w
+ (decf spaceleft flen)
+ (when lpoint
+ (if (> spaceleft 0)
+ (decf spaceleft)
+ (setq lpoint nil))))
+ (cond ((and w (< spaceleft 0) ovf)
+ ;;significand overflow
+ (dotimes (i w) (write-char ovf stream)))
+ (t (when w
+ (dotimes (i spaceleft) (write-char pad stream)))
+ (if (minusp number)
+ (write-char #\- stream)
+ (if atsign (write-char #\+ stream)))
+ (when lpoint (write-char #\0 stream))
+ (write-string fstr stream)
+ (write-char (if marker
+ marker
+ (format-exponent-marker number))
+ stream)
+ (write-char (if (minusp expt) #\- #\+) stream)
+ (when e
+ ;;zero-fill before exponent if necessary
+ (dotimes (i (- e (length estr)))
+ (write-char #\0 stream)))
+ (write-string estr stream)))))))))
+
+(def-format-interpreter #\G (colonp atsignp params)
+ (when colonp
+ (error 'format-error
+ :complaint
+ "cannot specify the colon modifier with this directive"))
+ (interpret-bind-defaults
+ ((w nil) (d nil) (e nil) (k nil) (ovf nil) (pad #\space) (mark nil))
+ params
+ (format-general stream (next-arg) w d e k ovf pad mark atsignp)))
+
+(defun format-general (stream number w d e k ovf pad marker atsign)
+ (if (numberp number)
+ (if (floatp number)
+ (format-general-aux stream number w d e k ovf pad marker atsign)
+ (if (rationalp number)
+ (format-general-aux stream
+ (coerce number 'single-float)
+ w d e k ovf pad marker atsign)
+ (format-write-field stream
+ (decimal-string number)
+ w 1 0 #\space t)))
+ (format-princ stream number nil nil w 1 0 pad)))
+
+;;; toy@rtp.ericsson.se: Same change as for format-exp-aux.
+(defun format-general-aux (stream number w d e k ovf pad marker atsign)
+ (if (and (floatp number)
+ (or (float-infinity-p number)
+ (float-nan-p number)))
+ (prin1 number stream)
+ (multiple-value-bind (ignore n) (sb!impl::scale-exponent (abs number))
+ (declare (ignore ignore))
+ ;; KLUDGE: Default d if omitted. The procedure is taken directly from
+ ;; the definition given in the manual, and is not very efficient, since
+ ;; we generate the digits twice. Future maintainers are encouraged to
+ ;; improve on this. -- rtoy?? 1998??
+ (unless d
+ (multiple-value-bind (str len)
+ (sb!impl::flonum-to-string (abs number))
+ (declare (ignore str))
+ (let ((q (if (= len 1) 1 (1- len))))
+ (setq d (max q (min n 7))))))
+ (let* ((ee (if e (+ e 2) 4))
+ (ww (if w (- w ee) nil))
+ (dd (- d n)))
+ (cond ((<= 0 dd d)
+ (let ((char (if (format-fixed-aux stream number ww dd nil
+ ovf pad atsign)
+ ovf
+ #\space)))
+ (dotimes (i ee) (write-char char stream))))
+ (t
+ (format-exp-aux stream number w d e (or k 1)
+ ovf pad marker atsign)))))))
+
+(def-format-interpreter #\$ (colonp atsignp params)
+ (interpret-bind-defaults ((d 2) (n 1) (w 0) (pad #\space)) params
+ (format-dollars stream (next-arg) d n w pad colonp atsignp)))
+
+(defun format-dollars (stream number d n w pad colon atsign)
+ (if (rationalp number) (setq number (coerce number 'single-float)))
+ (if (floatp number)
+ (let* ((signstr (if (minusp number) "-" (if atsign "+" "")))
+ (signlen (length signstr)))
+ (multiple-value-bind (str strlen ig2 ig3 pointplace)
+ (sb!impl::flonum-to-string number nil d nil)
+ (declare (ignore ig2 ig3))
+ (when colon (write-string signstr stream))
+ (dotimes (i (- w signlen (- n pointplace) strlen))
+ (write-char pad stream))
+ (unless colon (write-string signstr stream))
+ (dotimes (i (- n pointplace)) (write-char #\0 stream))
+ (write-string str stream)))
+ (format-write-field stream
+ (decimal-string number)
+ w 1 0 #\space t)))
+\f
+;;;; format interpreters and support functions for line/page breaks etc.
+
+(def-format-interpreter #\% (colonp atsignp params)
+ (when (or colonp atsignp)
+ (error 'format-error
+ :complaint
+ "cannot specify either colon or atsign for this directive"))
+ (interpret-bind-defaults ((count 1)) params
+ (dotimes (i count)
+ (terpri stream))))
+
+(def-format-interpreter #\& (colonp atsignp params)
+ (when (or colonp atsignp)
+ (error 'format-error
+ :complaint
+ "cannot specify either colon or atsign for this directive"))
+ (interpret-bind-defaults ((count 1)) params
+ (fresh-line stream)
+ (dotimes (i (1- count))
+ (terpri stream))))
+
+(def-format-interpreter #\| (colonp atsignp params)
+ (when (or colonp atsignp)
+ (error 'format-error
+ :complaint
+ "cannot specify either colon or atsign for this directive"))
+ (interpret-bind-defaults ((count 1)) params
+ (dotimes (i count)
+ (write-char (code-char form-feed-char-code) stream))))
+
+(def-format-interpreter #\~ (colonp atsignp params)
+ (when (or colonp atsignp)
+ (error 'format-error
+ :complaint
+ "cannot specify either colon or atsign for this directive"))
+ (interpret-bind-defaults ((count 1)) params
+ (dotimes (i count)
+ (write-char #\~ stream))))
+
+(def-complex-format-interpreter #\newline (colonp atsignp params directives)
+ (when (and colonp atsignp)
+ (error 'format-error
+ :complaint
+ "cannot specify both colon and atsign for this directive"))
+ (interpret-bind-defaults () params
+ (when atsignp
+ (write-char #\newline stream)))
+ (if (and (not colonp)
+ directives
+ (simple-string-p (car directives)))
+ (cons (string-left-trim *format-whitespace-chars*
+ (car directives))
+ (cdr directives))
+ directives))
+\f
+;;;; format interpreters and support functions for tabs and simple pretty
+;;;; printing
+
+(def-format-interpreter #\T (colonp atsignp params)
+ (if colonp
+ (interpret-bind-defaults ((n 1) (m 1)) params
+ (pprint-tab (if atsignp :section-relative :section) n m stream))
+ (if atsignp
+ (interpret-bind-defaults ((colrel 1) (colinc 1)) params
+ (format-relative-tab stream colrel colinc))
+ (interpret-bind-defaults ((colnum 1) (colinc 1)) params
+ (format-absolute-tab stream colnum colinc)))))
+
+(defun output-spaces (stream n)
+ (let ((spaces #.(make-string 100 :initial-element #\space)))
+ (loop
+ (when (< n (length spaces))
+ (return))
+ (write-string spaces stream)
+ (decf n (length spaces)))
+ (write-string spaces stream :end n)))
+
+(defun format-relative-tab (stream colrel colinc)
+ (if (sb!pretty:pretty-stream-p stream)
+ (pprint-tab :line-relative colrel colinc stream)
+ (let* ((cur (sb!impl::charpos stream))
+ (spaces (if (and cur (plusp colinc))
+ (- (* (ceiling (+ cur colrel) colinc) colinc) cur)
+ colrel)))
+ (output-spaces stream spaces))))
+
+(defun format-absolute-tab (stream colnum colinc)
+ (if (sb!pretty:pretty-stream-p stream)
+ (pprint-tab :line colnum colinc stream)
+ (let ((cur (sb!impl::charpos stream)))
+ (cond ((null cur)
+ (write-string " " stream))
+ ((< cur colnum)
+ (output-spaces stream (- colnum cur)))
+ (t
+ (unless (zerop colinc)
+ (output-spaces stream
+ (- colinc (rem (- cur colnum) colinc)))))))))
+
+(def-format-interpreter #\_ (colonp atsignp params)
+ (interpret-bind-defaults () params
+ (pprint-newline (if colonp
+ (if atsignp
+ :mandatory
+ :fill)
+ (if atsignp
+ :miser
+ :linear))
+ stream)))
+
+(def-format-interpreter #\I (colonp atsignp params)
+ (when atsignp
+ (error 'format-error
+ :complaint "cannot specify the at-sign modifier"))
+ (interpret-bind-defaults ((n 0)) params
+ (pprint-indent (if colonp :current :block) n stream)))
+\f
+;;;; format interpreter for ~*
+
+(def-format-interpreter #\* (colonp atsignp params)
+ (if atsignp
+ (if colonp
+ (error 'format-error
+ :complaint "cannot specify both colon and at-sign")
+ (interpret-bind-defaults ((posn 0)) params
+ (if (<= 0 posn (length orig-args))
+ (setf args (nthcdr posn orig-args))
+ (error 'format-error
+ :complaint "Index ~D is out of bounds. (It should ~
+ have been between 0 and ~D.)"
+ :arguments (list posn (length orig-args))))))
+ (if colonp
+ (interpret-bind-defaults ((n 1)) params
+ (do ((cur-posn 0 (1+ cur-posn))
+ (arg-ptr orig-args (cdr arg-ptr)))
+ ((eq arg-ptr args)
+ (let ((new-posn (- cur-posn n)))
+ (if (<= 0 new-posn (length orig-args))
+ (setf args (nthcdr new-posn orig-args))
+ (error 'format-error
+ :complaint
+ "Index ~D is out of bounds. (It should
+ have been between 0 and ~D.)"
+ :arguments
+ (list new-posn (length orig-args))))))))
+ (interpret-bind-defaults ((n 1)) params
+ (dotimes (i n)
+ (next-arg))))))
+\f
+;;;; format interpreter for indirection
+
+(def-format-interpreter #\? (colonp atsignp params string end)
+ (when colonp
+ (error 'format-error
+ :complaint "cannot specify the colon modifier"))
+ (interpret-bind-defaults () params
+ (handler-bind
+ ((format-error
+ #'(lambda (condition)
+ (error 'format-error
+ :complaint
+ "~A~%while processing indirect format string:"
+ :arguments (list condition)
+ :print-banner nil
+ :control-string string
+ :offset (1- end)))))
+ (if atsignp
+ (setf args (%format stream (next-arg) orig-args args))
+ (%format stream (next-arg) (next-arg))))))
+\f
+;;;; format interpreters for capitalization
+
+(def-complex-format-interpreter #\( (colonp atsignp params directives)
+ (let ((close (find-directive directives #\) nil)))
+ (unless close
+ (error 'format-error
+ :complaint "no corresponding close paren"))
+ (interpret-bind-defaults () params
+ (let* ((posn (position close directives))
+ (before (subseq directives 0 posn))
+ (after (nthcdr (1+ posn) directives))
+ (stream (make-case-frob-stream stream
+ (if colonp
+ (if atsignp
+ :upcase
+ :capitalize)
+ (if atsignp
+ :capitalize-first
+ :downcase)))))
+ (setf args (interpret-directive-list stream before orig-args args))
+ after))))
+
+(def-complex-format-interpreter #\) ()
+ (error 'format-error
+ :complaint "no corresponding open paren"))
+\f
+;;;; format interpreters and support functions for conditionalization
+
+(def-complex-format-interpreter #\[ (colonp atsignp params directives)
+ (multiple-value-bind (sublists last-semi-with-colon-p remaining)
+ (parse-conditional-directive directives)
+ (setf args
+ (if atsignp
+ (if colonp
+ (error 'format-error
+ :complaint
+ "cannot specify both the colon and at-sign modifiers")
+ (if (cdr sublists)
+ (error 'format-error
+ :complaint
+ "can only specify one section")
+ (interpret-bind-defaults () params
+ (let ((prev-args args)
+ (arg (next-arg)))
+ (if arg
+ (interpret-directive-list stream
+ (car sublists)
+ orig-args
+ prev-args)
+ args)))))
+ (if colonp
+ (if (= (length sublists) 2)
+ (interpret-bind-defaults () params
+ (if (next-arg)
+ (interpret-directive-list stream (car sublists)
+ orig-args args)
+ (interpret-directive-list stream (cadr sublists)
+ orig-args args)))
+ (error 'format-error
+ :complaint
+ "must specify exactly two sections"))
+ (interpret-bind-defaults ((index (next-arg))) params
+ (let* ((default (and last-semi-with-colon-p
+ (pop sublists)))
+ (last (1- (length sublists)))
+ (sublist
+ (if (<= 0 index last)
+ (nth (- last index) sublists)
+ default)))
+ (interpret-directive-list stream sublist orig-args
+ args))))))
+ remaining))
+
+(def-complex-format-interpreter #\; ()
+ (error 'format-error
+ :complaint
+ "~~; not contained within either ~~[...~~] or ~~<...~~>"))
+
+(def-complex-format-interpreter #\] ()
+ (error 'format-error
+ :complaint
+ "no corresponding open bracket"))
+\f
+;;;; format interpreter for up-and-out
+
+(defvar *outside-args*)
+
+(def-format-interpreter #\^ (colonp atsignp params)
+ (when atsignp
+ (error 'format-error
+ :complaint "cannot specify the at-sign modifier"))
+ (when (and colonp (not *up-up-and-out-allowed*))
+ (error 'format-error
+ :complaint "attempt to use ~~:^ outside a ~~:{...~~} construct"))
+ (when (case (length params)
+ (0 (if colonp
+ (null *outside-args*)
+ (null args)))
+ (1 (interpret-bind-defaults ((count 0)) params
+ (zerop count)))
+ (2 (interpret-bind-defaults ((arg1 0) (arg2 0)) params
+ (= arg1 arg2)))
+ (t (interpret-bind-defaults ((arg1 0) (arg2 0) (arg3 0)) params
+ (<= arg1 arg2 arg3))))
+ (throw (if colonp 'up-up-and-out 'up-and-out)
+ args)))
+\f
+;;;; format interpreters for iteration
+
+(def-complex-format-interpreter #\{
+ (colonp atsignp params string end directives)
+ (let ((close (find-directive directives #\} nil)))
+ (unless close
+ (error 'format-error
+ :complaint
+ "no corresponding close brace"))
+ (interpret-bind-defaults ((max-count nil)) params
+ (let* ((closed-with-colon (format-directive-colonp close))
+ (posn (position close directives))
+ (insides (if (zerop posn)
+ (next-arg)
+ (subseq directives 0 posn)))
+ (*up-up-and-out-allowed* colonp))
+ (labels
+ ((do-guts (orig-args args)
+ (if (zerop posn)
+ (handler-bind
+ ((format-error
+ #'(lambda (condition)
+ (error 'format-error
+ :complaint
+ "~A~%while processing indirect format string:"
+ :arguments (list condition)
+ :print-banner nil
+ :control-string string
+ :offset (1- end)))))
+ (%format stream insides orig-args args))
+ (interpret-directive-list stream insides
+ orig-args args)))
+ (bind-args (orig-args args)
+ (if colonp
+ (let* ((arg (next-arg))
+ (*logical-block-popper* nil)
+ (*outside-args* args))
+ (catch 'up-and-out
+ (do-guts arg arg)
+ args))
+ (do-guts orig-args args)))
+ (do-loop (orig-args args)
+ (catch (if colonp 'up-up-and-out 'up-and-out)
+ (loop
+ (when (and (not closed-with-colon) (null args))
+ (return))
+ (when (and max-count (minusp (decf max-count)))
+ (return))
+ (setf args (bind-args orig-args args))
+ (when (and closed-with-colon (null args))
+ (return)))
+ args)))
+ (if atsignp
+ (setf args (do-loop orig-args args))
+ (let ((arg (next-arg))
+ (*logical-block-popper* nil))
+ (do-loop arg arg)))
+ (nthcdr (1+ posn) directives))))))
+
+(def-complex-format-interpreter #\} ()
+ (error 'format-error
+ :complaint "no corresponding open brace"))
+\f
+;;;; format interpreters and support functions for justification
+
+(def-complex-format-interpreter #\<
+ (colonp atsignp params string end directives)
+ (multiple-value-bind (segments first-semi close remaining)
+ (parse-format-justification directives)
+ (setf args
+ (if (format-directive-colonp close)
+ (multiple-value-bind (prefix per-line-p insides suffix)
+ (parse-format-logical-block segments colonp first-semi
+ close params string end)
+ (interpret-format-logical-block stream orig-args args
+ prefix per-line-p insides
+ suffix atsignp))
+ (interpret-format-justification stream orig-args args
+ segments colonp atsignp
+ first-semi params)))
+ remaining))
+
+(defun interpret-format-justification
+ (stream orig-args args segments colonp atsignp first-semi params)
+ (interpret-bind-defaults
+ ((mincol 0) (colinc 1) (minpad 0) (padchar #\space))
+ params
+ (let ((newline-string nil)
+ (strings nil)
+ (extra-space 0)
+ (line-len 0))
+ (setf args
+ (catch 'up-and-out
+ (when (and first-semi (format-directive-colonp first-semi))
+ (interpret-bind-defaults
+ ((extra 0)
+ (len (or (sb!impl::line-length stream) 72)))
+ (format-directive-params first-semi)
+ (setf newline-string
+ (with-output-to-string (stream)
+ (setf args
+ (interpret-directive-list stream
+ (pop segments)
+ orig-args
+ args))))
+ (setf extra-space extra)
+ (setf line-len len)))
+ (dolist (segment segments)
+ (push (with-output-to-string (stream)
+ (setf args
+ (interpret-directive-list stream segment
+ orig-args args)))
+ strings))
+ args))
+ (format-justification stream newline-string extra-space line-len strings
+ colonp atsignp mincol colinc minpad padchar)))
+ args)
+
+(defun format-justification (stream newline-prefix extra-space line-len strings
+ pad-left pad-right mincol colinc minpad padchar)
+ (setf strings (reverse strings))
+ (when (and (not pad-left) (not pad-right) (null (cdr strings)))
+ (setf pad-left t))
+ (let* ((num-gaps (+ (1- (length strings))
+ (if pad-left 1 0)
+ (if pad-right 1 0)))
+ (chars (+ (* num-gaps minpad)
+ (loop
+ for string in strings
+ summing (length string))))
+ (length (if (> chars mincol)
+ (+ mincol (* (ceiling (- chars mincol) colinc) colinc))
+ mincol))
+ (padding (- length chars)))
+ (when (and newline-prefix
+ (> (+ (or (sb!impl::charpos stream) 0)
+ length extra-space)
+ line-len))
+ (write-string newline-prefix stream))
+ (flet ((do-padding ()
+ (let ((pad-len (truncate padding num-gaps)))
+ (decf padding pad-len)
+ (decf num-gaps)
+ (dotimes (i pad-len) (write-char padchar stream)))))
+ (when pad-left
+ (do-padding))
+ (when strings
+ (write-string (car strings) stream)
+ (dolist (string (cdr strings))
+ (do-padding)
+ (write-string string stream)))
+ (when pad-right
+ (do-padding)))))
+
+(defun interpret-format-logical-block
+ (stream orig-args args prefix per-line-p insides suffix atsignp)
+ (let ((arg (if atsignp args (next-arg))))
+ (if per-line-p
+ (pprint-logical-block
+ (stream arg :per-line-prefix prefix :suffix suffix)
+ (let ((*logical-block-popper* #'(lambda () (pprint-pop))))
+ (catch 'up-and-out
+ (interpret-directive-list stream insides
+ (if atsignp orig-args arg)
+ arg))))
+ (pprint-logical-block (stream arg :prefix prefix :suffix suffix)
+ (let ((*logical-block-popper* #'(lambda () (pprint-pop))))
+ (catch 'up-and-out
+ (interpret-directive-list stream insides
+ (if atsignp orig-args arg)
+ arg))))))
+ (if atsignp nil args))
+\f
+;;;; format interpreter and support functions for user-defined method
+
+(def-format-interpreter #\/ (string start end colonp atsignp params)
+ (let ((symbol (extract-user-function-name string start end)))
+ (collect ((args))
+ (dolist (param-and-offset params)
+ (let ((param (cdr param-and-offset)))
+ (case param
+ (:arg (args (next-arg)))
+ (:remaining (args (length args)))
+ (t (args param)))))
+ (apply (fdefinition symbol) stream (next-arg) colonp atsignp (args)))))
--- /dev/null
+;;;; that part of the implementation of HASH-TABLE which lives solely
+;;;; on the target system, not on the cross-compilation host
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!IMPL")
+
+(file-comment
+ "$Header$")
+\f
+;;;; utilities
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defconstant max-hash most-positive-fixnum))
+
+(deftype hash ()
+ `(integer 0 ,max-hash))
+
+#!-sb-fluid (declaim (inline pointer-hash))
+(defun pointer-hash (key)
+ (declare (values hash))
+ (truly-the hash (%primitive sb!c:make-fixnum key)))
+
+#!-sb-fluid (declaim (inline eq-hash))
+(defun eq-hash (key)
+ (declare (values hash (member t nil)))
+ (values (pointer-hash key)
+ (oddp (get-lisp-obj-address key))))
+
+#!-sb-fluid (declaim (inline equal-hash))
+(defun equal-hash (key)
+ (declare (values hash (member t nil)))
+ (values (sxhash key) nil))
+
+#!-sb-fluid (declaim (inline eql-hash))
+(defun eql-hash (key)
+ (declare (values hash (member t nil)))
+ (if (numberp key)
+ (equal-hash key)
+ (eq-hash key)))
+
+(defun equalp-hash (key)
+ (declare (values hash (member t nil)))
+ (values (psxhash key) nil))
+
+(defun almost-primify (num)
+ (declare (type index num))
+ #!+sb-doc
+ "Return an almost prime number greater than or equal to NUM."
+ (if (= (rem num 2) 0)
+ (setq num (+ 1 num)))
+ (if (= (rem num 3) 0)
+ (setq num (+ 2 num)))
+ (if (= (rem num 7) 0)
+ (setq num (+ 4 num)))
+ num)
+\f
+;;;; user-defined hash table tests
+
+(defvar *hash-table-tests* nil)
+
+(defun define-hash-table-test (name test-fun hash-fun)
+ #!+sb-doc
+ "Define a new kind of hash table test."
+ (declare (type symbol name)
+ (type function test-fun hash-fun))
+ (setf *hash-table-tests*
+ (cons (list name test-fun hash-fun)
+ (remove name *hash-table-tests* :test #'eq :key #'car)))
+ name)
+\f
+;;;; construction and simple accessors
+
+(defconstant +min-hash-table-size+ 16)
+
+(defun make-hash-table (&key (test 'eql)
+ (size +min-hash-table-size+)
+ (rehash-size 1.5)
+ (rehash-threshold 1)
+ (weak-p nil))
+ #!+sb-doc
+ "Create and return a new hash table. The keywords are as follows:
+ :TEST -- Indicates what kind of test to use.
+ :SIZE -- A hint as to how many elements will be put in this hash
+ table.
+ :REHASH-SIZE -- Indicates how to expand the table when it fills up.
+ If an integer, add space for that many elements. If a floating
+ point number (which must be greater than 1.0), multiply the size
+ by that amount.
+ :REHASH-THRESHOLD -- Indicates how dense the table can become before
+ forcing a rehash. Can be any positive number <=1, with density
+ approaching zero as the threshold approaches 0. Density 1 means an
+ average of one entry per bucket.
+ :WEAK-P -- (This is an extension from CMU CL, not currently supported
+ in SBCL 0.6.6, but perhaps supported in a future version.) If T,
+ don't keep entries if the key would otherwise be garbage."
+ (declare (type (or function symbol) test))
+ (declare (type unsigned-byte size))
+ (when weak-p
+ (error "stub: unsupported WEAK-P option"))
+ (multiple-value-bind (test test-fun hash-fun)
+ (cond ((or (eq test #'eq) (eq test 'eq))
+ (values 'eq #'eq #'eq-hash))
+ ((or (eq test #'eql) (eq test 'eql))
+ (values 'eql #'eql #'eql-hash))
+ ((or (eq test #'equal) (eq test 'equal))
+ (values 'equal #'equal #'equal-hash))
+ ((or (eq test #'equalp) (eq test 'equalp))
+ (values 'equalp #'equalp #'equalp-hash))
+ (t
+ ;; FIXME: I'd like to remove *HASH-TABLE-TESTS* stuff.
+ ;; Failing that, I'd like to rename it to
+ ;; *USER-HASH-TABLE-TESTS*.
+ (dolist (info *hash-table-tests*
+ (error "unknown :TEST for MAKE-HASH-TABLE: ~S"
+ test))
+ (destructuring-bind (test-name test-fun hash-fun) info
+ (when (or (eq test test-name) (eq test test-fun))
+ (return (values test-name test-fun hash-fun)))))))
+ (let* ((size (max +min-hash-table-size+
+ (min size
+ ;; SIZE is just a hint, so if the user asks
+ ;; for a SIZE which'd be too big for us to
+ ;; easily implement, we bump it down.
+ (floor array-dimension-limit 16))))
+ (rehash-size (if (integerp rehash-size)
+ rehash-size
+ (float rehash-size 1.0)))
+ ;; FIXME: Original REHASH-THRESHOLD default should be 1.0,
+ ;; not 1, to make it easier for the compiler to avoid
+ ;; boxing.
+ (rehash-threshold (float rehash-threshold 1.0))
+ (size+1 (1+ size)) ; The first element is not usable.
+ (scaled-size (round (/ (float size+1) rehash-threshold)))
+ (length (almost-primify (max scaled-size
+ (1+ +min-hash-table-size+))))
+ (index-vector (make-array length
+ :element-type '(unsigned-byte 32)
+ :initial-element 0))
+ ;; needs to be the same length as the KV vector
+ (next-vector (make-array size+1
+ :element-type '(unsigned-byte 32)))
+ (kv-vector (make-array (* 2 size+1)
+ :initial-element +empty-ht-slot+))
+ (table (%make-hash-table
+ :test test
+ :test-fun test-fun
+ :hash-fun hash-fun
+ :rehash-size rehash-size
+ :rehash-threshold rehash-threshold
+ :rehash-trigger size
+ :table kv-vector
+ :weak-p weak-p
+ :index-vector index-vector
+ :next-vector next-vector
+ :hash-vector (unless (eq test 'eq)
+ (make-array size+1
+ :element-type '(unsigned-byte 32)
+ :initial-element #x80000000)))))
+ (declare (type index size+1 scaled-size length))
+ ;; Set up the free list, all free. These lists are 0 terminated.
+ (do ((i 1 (1+ i)))
+ ((>= i size))
+ (setf (aref next-vector i) (1+ i)))
+ (setf (aref next-vector size) 0)
+ (setf (hash-table-next-free-kv table) 1)
+ (setf (hash-table-needing-rehash table) 0)
+ (setf (aref kv-vector 0) table)
+ table)))
+
+(defun hash-table-count (hash-table)
+ #!+sb-doc
+ "Returns the number of entries in the given HASH-TABLE."
+ (declare (type hash-table hash-table)
+ (values index))
+ (hash-table-number-entries hash-table))
+
+#!+sb-doc
+(setf (fdocumentation 'hash-table-rehash-size 'function)
+ "Return the rehash-size HASH-TABLE was created with.")
+
+#!+sb-doc
+(setf (fdocumentation 'hash-table-rehash-threshold 'function)
+ "Return the rehash-threshold HASH-TABLE was created with.")
+
+(defun hash-table-size (hash-table)
+ #!+sb-doc
+ "Return a size that can be used with MAKE-HASH-TABLE to create a hash
+ table that can hold however many entries HASH-TABLE can hold without
+ having to be grown."
+ (hash-table-rehash-trigger hash-table))
+
+#!+sb-doc
+(setf (fdocumentation 'hash-table-test 'function)
+ "Return the test HASH-TABLE was created with.")
+
+#!+sb-doc
+(setf (fdocumentation 'hash-table-weak-p 'function)
+ "Return T if HASH-TABLE will not keep entries for keys that would
+ otherwise be garbage, and NIL if it will.")
+\f
+;;;; accessing functions
+
+;;; Make new vectors for the table, extending the table based on the
+;;; rehash-size.
+(defun rehash (table)
+ (declare (type hash-table table))
+ (let* ((old-kv-vector (hash-table-table table))
+ (old-next-vector (hash-table-next-vector table))
+ (old-hash-vector (hash-table-hash-vector table))
+ (old-size (length old-next-vector))
+ (new-size
+ (let ((rehash-size (hash-table-rehash-size table)))
+ (etypecase rehash-size
+ (fixnum
+ (+ rehash-size old-size))
+ (float
+ (the index (round (* rehash-size old-size)))))))
+ (new-kv-vector (make-array (* 2 new-size)
+ :initial-element +empty-ht-slot+))
+ (new-next-vector (make-array new-size
+ :element-type '(unsigned-byte 32)
+ :initial-element 0))
+ (new-hash-vector (when old-hash-vector
+ (make-array new-size
+ :element-type '(unsigned-byte 32)
+ :initial-element #x80000000)))
+ (old-index-vector (hash-table-index-vector table))
+ (new-length (almost-primify
+ (round (/ (float new-size)
+ (hash-table-rehash-threshold table)))))
+ (new-index-vector (make-array new-length
+ :element-type '(unsigned-byte 32)
+ :initial-element 0)))
+ (declare (type index new-size new-length old-size))
+
+ ;; Disable GC tricks on the OLD-KV-VECTOR.
+ (set-header-data old-kv-vector sb!vm:vector-normal-subtype)
+
+ ;; Copy over the kv-vector. The element positions should not move
+ ;; in case there are active scans.
+ (dotimes (i (* old-size 2))
+ (declare (type index i))
+ (setf (aref new-kv-vector i) (aref old-kv-vector i)))
+
+ ;; Copy over the hash-vector.
+ (when old-hash-vector
+ (dotimes (i old-size)
+ (setf (aref new-hash-vector i) (aref old-hash-vector i))))
+
+ (setf (hash-table-next-free-kv table) 0)
+ (setf (hash-table-needing-rehash table) 0)
+ ;; Rehash all the entries; last to first so that after the pushes
+ ;; the chains are first to last.
+ (do ((i (1- new-size) (1- i)))
+ ((zerop i))
+ (let ((key (aref new-kv-vector (* 2 i)))
+ (value (aref new-kv-vector (1+ (* 2 i)))))
+ (cond ((and (eq key +empty-ht-slot+)
+ (eq value +empty-ht-slot+))
+ ;; Slot is empty, push it onto the free list.
+ (setf (aref new-next-vector i)
+ (hash-table-next-free-kv table))
+ (setf (hash-table-next-free-kv table) i))
+ ((and new-hash-vector
+ (not (= (aref new-hash-vector i) #x80000000)))
+ ;; Can use the existing hash value (not EQ based)
+ (let* ((hashing (aref new-hash-vector i))
+ (index (rem hashing new-length))
+ (next (aref new-index-vector index)))
+ (declare (type index index)
+ (type hash hashing))
+ ;; Push this slot into the next chain.
+ (setf (aref new-next-vector i) next)
+ (setf (aref new-index-vector index) i)))
+ (t
+ ;; EQ base hash.
+ ;; Enable GC tricks.
+ (set-header-data new-kv-vector
+ sb!vm:vector-valid-hashing-subtype)
+ (let* ((hashing (pointer-hash key))
+ (index (rem hashing new-length))
+ (next (aref new-index-vector index)))
+ (declare (type index index)
+ (type hash hashing))
+ ;; Push this slot onto the next chain.
+ (setf (aref new-next-vector i) next)
+ (setf (aref new-index-vector index) i))))))
+ (setf (hash-table-table table) new-kv-vector)
+ (setf (hash-table-index-vector table) new-index-vector)
+ (setf (hash-table-next-vector table) new-next-vector)
+ (setf (hash-table-hash-vector table) new-hash-vector)
+ ;; Shrink the old vectors to 0 size to help the conservative GC.
+ (shrink-vector old-kv-vector 0)
+ (shrink-vector old-index-vector 0)
+ (shrink-vector old-next-vector 0)
+ (when old-hash-vector
+ (shrink-vector old-hash-vector 0))
+ (setf (hash-table-rehash-trigger table) new-size))
+ (values))
+
+;;; Use the same size as before, re-using the vectors.
+(defun rehash-without-growing (table)
+ (declare (type hash-table table))
+ (let* ((kv-vector (hash-table-table table))
+ (next-vector (hash-table-next-vector table))
+ (hash-vector (hash-table-hash-vector table))
+ (size (length next-vector))
+ (index-vector (hash-table-index-vector table))
+ (length (length index-vector)))
+ (declare (type index size length)
+ (type (simple-array (unsigned-byte 32) (*))))
+
+ ;; Disable GC tricks, they will be re-enabled during the re-hash
+ ;; if necesary.
+ (set-header-data kv-vector sb!vm:vector-normal-subtype)
+
+ ;; Rehash all the entries.
+ (setf (hash-table-next-free-kv table) 0)
+ (setf (hash-table-needing-rehash table) 0)
+ (dotimes (i size)
+ (setf (aref next-vector i) 0))
+ (dotimes (i length)
+ (setf (aref index-vector i) 0))
+ (do ((i (1- size) (1- i)))
+ ((zerop i))
+ (let ((key (aref kv-vector (* 2 i)))
+ (value (aref kv-vector (1+ (* 2 i)))))
+ (cond ((and (eq key +empty-ht-slot+)
+ (eq value +empty-ht-slot+))
+ ;; Slot is empty, push it onto free list.
+ (setf (aref next-vector i) (hash-table-next-free-kv table))
+ (setf (hash-table-next-free-kv table) i))
+ ((and hash-vector (not (= (aref hash-vector i) #x80000000)))
+ ;; Can use the existing hash value (not EQ based)
+ (let* ((hashing (aref hash-vector i))
+ (index (rem hashing length))
+ (next (aref index-vector index)))
+ (declare (type index index))
+ ;; Push this slot into the next chain.
+ (setf (aref next-vector i) next)
+ (setf (aref index-vector index) i)))
+ (t
+ ;; EQ base hash.
+ ;; Enable GC tricks.
+ (set-header-data kv-vector sb!vm:vector-valid-hashing-subtype)
+ (let* ((hashing (pointer-hash key))
+ (index (rem hashing length))
+ (next (aref index-vector index)))
+ (declare (type index index)
+ (type hash hashing))
+ ;; Push this slot into the next chain.
+ (setf (aref next-vector i) next)
+ (setf (aref index-vector index) i)))))))
+ (values))
+
+(defun flush-needing-rehash (table)
+ (let* ((kv-vector (hash-table-table table))
+ (index-vector (hash-table-index-vector table))
+ (next-vector (hash-table-next-vector table))
+ (length (length index-vector)))
+ (do ((next (hash-table-needing-rehash table)))
+ ((zerop next))
+ (declare (type index next))
+ (let* ((key (aref kv-vector (* 2 next)))
+ (hashing (pointer-hash key))
+ (index (rem hashing length))
+ (temp (aref next-vector next)))
+ (setf (aref next-vector next) (aref index-vector index))
+ (setf (aref index-vector index) next)
+ (setf next temp))))
+ (setf (hash-table-needing-rehash table) 0)
+ (values))
+
+(defun gethash (key hash-table &optional default)
+ #!+sb-doc
+ "Finds the entry in HASH-TABLE whose key is KEY and returns the associated
+ value and T as multiple values, or returns DEFAULT and NIL if there is no
+ such entry. Entries can be added using SETF."
+ (declare (type hash-table hash-table)
+ (values t (member t nil)))
+ (without-gcing
+ (cond ((= (get-header-data (hash-table-table hash-table))
+ sb!vm:vector-must-rehash-subtype)
+ (rehash-without-growing hash-table))
+ ((not (zerop (hash-table-needing-rehash hash-table)))
+ (flush-needing-rehash hash-table)))
+ ;; Search for key in the hash table.
+ (multiple-value-bind (hashing eq-based)
+ (funcall (hash-table-hash-fun hash-table) key)
+ (declare (type hash hashing))
+ (let* ((index-vector (hash-table-index-vector hash-table))
+ (length (length index-vector))
+ (index (rem hashing length))
+ (next (aref index-vector index))
+ (table (hash-table-table hash-table))
+ (next-vector (hash-table-next-vector hash-table))
+ (hash-vector (hash-table-hash-vector hash-table))
+ (test-fun (hash-table-test-fun hash-table)))
+ (declare (type index index))
+ ;; Search next-vector chain for a matching key.
+ (if (or eq-based (not hash-vector))
+ (do ((next next (aref next-vector next)))
+ ((zerop next) (values default nil))
+ (declare (type index next))
+ (when (eq key (aref table (* 2 next)))
+ (return (values (aref table (1+ (* 2 next))) t))))
+ (do ((next next (aref next-vector next)))
+ ((zerop next) (values default nil))
+ (declare (type index next))
+ (when (and (= hashing (aref hash-vector next))
+ (funcall test-fun key (aref table (* 2 next))))
+ ;; Found.
+ (return (values (aref table (1+ (* 2 next))) t)))))))))
+
+;;; so people can call #'(SETF GETHASH)
+(defun (setf gethash) (new-value key table &optional default)
+ (declare (ignore default))
+ (%puthash key table new-value))
+
+(defun %puthash (key hash-table value)
+ (declare (type hash-table hash-table))
+ (assert (hash-table-index-vector hash-table))
+ (without-gcing
+ ;; We need to rehash here so that a current key can be found if it
+ ;; exists. Check that there is room for one more entry. May not be
+ ;; needed if the key is already present.
+ (cond ((zerop (hash-table-next-free-kv hash-table))
+ (rehash hash-table))
+ ((= (get-header-data (hash-table-table hash-table))
+ sb!vm:vector-must-rehash-subtype)
+ (rehash-without-growing hash-table))
+ ((not (zerop (hash-table-needing-rehash hash-table)))
+ (flush-needing-rehash hash-table)))
+
+ ;; Search for key in the hash table.
+ (multiple-value-bind (hashing eq-based)
+ (funcall (hash-table-hash-fun hash-table) key)
+ (declare (type hash hashing))
+ (let* ((index-vector (hash-table-index-vector hash-table))
+ (length (length index-vector))
+ (index (rem hashing length))
+ (next (aref index-vector index))
+ (kv-vector (hash-table-table hash-table))
+ (next-vector (hash-table-next-vector hash-table))
+ (hash-vector (hash-table-hash-vector hash-table))
+ (test-fun (hash-table-test-fun hash-table)))
+ (declare (type index index))
+
+ (cond ((or eq-based (not hash-vector))
+ (when eq-based
+ (set-header-data kv-vector sb!vm:vector-valid-hashing-subtype))
+
+ ;; Search next-vector chain for a matching key.
+ (do ((next next (aref next-vector next)))
+ ((zerop next))
+ (declare (type index next))
+ (when (eq key (aref kv-vector (* 2 next)))
+ ;; Found, just replace the value.
+ (setf (aref kv-vector (1+ (* 2 next))) value)
+ (return-from %puthash value))))
+ (t
+ ;; Search next-vector chain for a matching key.
+ (do ((next next (aref next-vector next)))
+ ((zerop next))
+ (declare (type index next))
+ (when (and (= hashing (aref hash-vector next))
+ (funcall test-fun key
+ (aref kv-vector (* 2 next))))
+ ;; Found, just replace the value.
+ (setf (aref kv-vector (1+ (* 2 next))) value)
+ (return-from %puthash value)))))
+
+ ;; Pop a KV slot off the free list
+ (let ((free-kv-slot (hash-table-next-free-kv hash-table)))
+ ;; Double-check for overflow.
+ (assert (not (zerop free-kv-slot)))
+ (setf (hash-table-next-free-kv hash-table)
+ (aref next-vector free-kv-slot))
+ (incf (hash-table-number-entries hash-table))
+
+ (setf (aref kv-vector (* 2 free-kv-slot)) key)
+ (setf (aref kv-vector (1+ (* 2 free-kv-slot))) value)
+
+ ;; Setup the hash-vector if necessary.
+ (when hash-vector
+ (if (not eq-based)
+ (setf (aref hash-vector free-kv-slot) hashing)
+ (assert (= (aref hash-vector free-kv-slot) #x80000000))))
+
+ ;; Push this slot into the next chain.
+ (setf (aref next-vector free-kv-slot) next)
+ (setf (aref index-vector index) free-kv-slot)))))
+ value)
+
+(defun remhash (key hash-table)
+ #!+sb-doc
+ "Remove the entry in HASH-TABLE associated with KEY. Returns T if there
+ was such an entry, and NIL if not."
+ (declare (type hash-table hash-table)
+ (values (member t nil)))
+ (without-gcing
+ ;; We need to rehash here so that a current key can be found if it
+ ;; exists.
+ (cond ((= (get-header-data (hash-table-table hash-table))
+ sb!vm:vector-must-rehash-subtype)
+ (rehash-without-growing hash-table))
+ ((not (zerop (hash-table-needing-rehash hash-table)))
+ (flush-needing-rehash hash-table)))
+
+ ;; Search for key in the hash table.
+ (multiple-value-bind (hashing eq-based)
+ (funcall (hash-table-hash-fun hash-table) key)
+ (declare (type hash hashing))
+ (let* ((index-vector (hash-table-index-vector hash-table))
+ (length (length index-vector))
+ (index (rem hashing length))
+ (next (aref index-vector index))
+ (table (hash-table-table hash-table))
+ (next-vector (hash-table-next-vector hash-table))
+ (hash-vector (hash-table-hash-vector hash-table))
+ (test-fun (hash-table-test-fun hash-table)))
+ (declare (type index index next))
+ (cond ((zerop next)
+ nil)
+ ((if (or eq-based (not hash-vector))
+ (eq key (aref table (* 2 next)))
+ (and (= hashing (aref hash-vector next))
+ (funcall test-fun key (aref table (* 2 next)))))
+
+ ;; FIXME: Substantially the same block of code seems to
+ ;; appear in all three cases. (In the first case, it
+ ;; appear bare; in the other two cases, it's wrapped in
+ ;; DO.) It should be defined in a separate (possibly
+ ;; inline) DEFUN or FLET.
+
+ ;; Mark slot as empty.
+ (setf (aref table (* 2 next)) +empty-ht-slot+
+ (aref table (1+ (* 2 next))) +empty-ht-slot+)
+ ;; Update the index-vector pointer.
+ (setf (aref index-vector index) (aref next-vector next))
+ ;; Push KV slot onto free chain.
+ (setf (aref next-vector next)
+ (hash-table-next-free-kv hash-table))
+ (setf (hash-table-next-free-kv hash-table) next)
+ (when hash-vector
+ (setf (aref hash-vector next) #x80000000))
+ (decf (hash-table-number-entries hash-table))
+ t)
+ ;; Search next-vector chain for a matching key.
+ ((or eq-based (not hash-vector))
+ ;; EQ based
+ (do ((prior next next)
+ (next (aref next-vector next) (aref next-vector next)))
+ ((zerop next) nil)
+ (declare (type index next))
+ (when (eq key (aref table (* 2 next)))
+ ;; Mark slot as empty.
+ (setf (aref table (* 2 next)) +empty-ht-slot+
+ (aref table (1+ (* 2 next))) +empty-ht-slot+)
+ ;; Update the prior pointer in the chain to skip this.
+ (setf (aref next-vector prior) (aref next-vector next))
+ ;; Push KV slot onto free chain.
+ (setf (aref next-vector next)
+ (hash-table-next-free-kv hash-table))
+ (setf (hash-table-next-free-kv hash-table) next)
+ (when hash-vector
+ (setf (aref hash-vector next) #x80000000))
+ (decf (hash-table-number-entries hash-table))
+ (return t))))
+ (t
+ ;; not EQ based
+ (do ((prior next next)
+ (next (aref next-vector next) (aref next-vector next)))
+ ((zerop next) nil)
+ (declare (type index next))
+ (when (and (= hashing (aref hash-vector next))
+ (funcall test-fun key (aref table (* 2 next))))
+ ;; Mark slot as empty.
+ (setf (aref table (* 2 next)) +empty-ht-slot+)
+ (setf (aref table (1+ (* 2 next))) +empty-ht-slot+)
+ ;; Update the prior pointer in the chain to skip this.
+ (setf (aref next-vector prior) (aref next-vector next))
+ ;; Push KV slot onto free chain.
+ (setf (aref next-vector next)
+ (hash-table-next-free-kv hash-table))
+ (setf (hash-table-next-free-kv hash-table) next)
+ (when hash-vector
+ (setf (aref hash-vector next) #x80000000))
+ (decf (hash-table-number-entries hash-table))
+ (return t)))))))))
+
+(defun clrhash (hash-table)
+ #!+sb-doc
+ "This removes all the entries from HASH-TABLE and returns the hash table
+ itself."
+ (let* ((kv-vector (hash-table-table hash-table))
+ (kv-length (length kv-vector))
+ (next-vector (hash-table-next-vector hash-table))
+ (hash-vector (hash-table-hash-vector hash-table))
+ (size (length next-vector))
+ (index-vector (hash-table-index-vector hash-table))
+ (length (length index-vector)))
+ ;; Disable GC tricks.
+ (set-header-data kv-vector sb!vm:vector-normal-subtype)
+ ;; Mark all slots as empty by setting all keys and values to magic
+ ;; tag.
+ (do ((i 2 (1+ i)))
+ ((>= i kv-length))
+ (setf (aref kv-vector i) +empty-ht-slot+))
+ (assert (eq (aref kv-vector 0) hash-table))
+ ;; Set up the free list, all free.
+ (do ((i 1 (1+ i)))
+ ((>= i (1- size)))
+ (setf (aref next-vector i) (1+ i)))
+ (setf (aref next-vector (1- size)) 0)
+ (setf (hash-table-next-free-kv hash-table) 1)
+ (setf (hash-table-needing-rehash hash-table) 0)
+ ;; Clear the index-vector.
+ (dotimes (i length)
+ (setf (aref index-vector i) 0))
+ ;; Clear the hash-vector.
+ (when hash-vector
+ (dotimes (i size)
+ (setf (aref hash-vector i) #x80000000))))
+ (setf (hash-table-number-entries hash-table) 0)
+ hash-table)
+\f
+;;;; MAPHASH
+
+;;; FIXME: This should be made into a compiler transform for two reasons:
+;;; 1. It would then be available for compiling the entire system,
+;;; not only parts of the system which are defined after DEFUN MAPHASH.
+;;; 2. It could be conditional on compilation policy, so that
+;;; it could be compiled as a full call instead of an inline
+;;; expansion when SPACE>SPEED. (Not only would this save space,
+;;; it might actually be faster when a call is made from byte-compiled
+;;; code.)
+(declaim (inline maphash))
+(defun maphash (function-designator hash-table)
+ #!+sb-doc
+ "For each entry in HASH-TABLE, call the designated function on the key
+ and value of the entry. Return NIL."
+ (let ((fun (coerce function-designator 'function))
+ (size (length (hash-table-next-vector hash-table))))
+ (declare (type function fun))
+ (do ((i 1 (1+ i)))
+ ((>= i size))
+ (declare (type index i))
+ (let* ((kv-vector (hash-table-table hash-table))
+ (key (aref kv-vector (* 2 i)))
+ (value (aref kv-vector (1+ (* 2 i)))))
+ (unless (and (eq key +empty-ht-slot+)
+ (eq value +empty-ht-slot+))
+ (funcall fun key value))))))
+\f
+;;;; methods on HASH-TABLE
+
+(def!method print-object ((ht hash-table) stream)
+ (declare (type stream stream))
+ (print-unreadable-object (ht stream :type t :identity t)
+ (format stream
+ ":TEST ~S :COUNT ~D"
+ (hash-table-test ht)
+ (hash-table-number-entries ht))))
+
+(def!method make-load-form ((hash-table hash-table) &optional environment)
+ (declare (ignorable environment))
+ (values
+ `(make-hash-table
+ :test ',(hash-table-test hash-table)
+ :size ',(hash-table-size hash-table)
+ :rehash-size ',(hash-table-rehash-size hash-table)
+ :rehash-threshold ',(hash-table-rehash-threshold hash-table))
+ (let ((alist nil))
+ (maphash (lambda (key value)
+ (push (cons key value) alist))
+ hash-table)
+ (if alist
+ ;; FIXME: It'd probably be more efficient here to write the
+ ;; hash table values as a SIMPLE-VECTOR rather than an alist.
+ ;; (Someone dumping a huge hash table might well thank us..)
+ `(stuff-hash-table ,hash-table ',alist)
+ nil))))
+
+(defun stuff-hash-table (table alist)
+ (dolist (x alist)
+ (setf (gethash (car x) table) (cdr x))))
--- /dev/null
+;;;; that part of the loader is only needed on the target system
+;;;; (which is basically synonymous with "that part of the loader
+;;;; which is not needed by GENESIS")
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!IMPL")
+
+(file-comment
+ "$Header$")
+
+(defvar *load-source-types* '("lisp" "l" "cl" "lsp")
+ #!+sb-doc
+ "The source file types which LOAD recognizes.")
+
+(defvar *load-object-types*
+ '(#.sb!c:*backend-fasl-file-type*
+ #.(sb!c:backend-byte-fasl-file-type)
+ "fasl")
+ #!+sb-doc
+ "A list of the object file types recognized by LOAD.")
+
+(declaim (list *load-source-types* *load-object-types*))
+
+(defvar *load-truename* nil
+ #!+sb-doc
+ "the TRUENAME of the file that LOAD is currently loading")
+
+(defvar *load-pathname* nil
+ #!+sb-doc
+ "the defaulted pathname that LOAD is currently loading")
+
+(declaim (type (or pathname null) *load-truename* *load-pathname*))
+\f
+;;;; SLOLOAD
+
+;;; something not EQ to anything read from a file
+;;; FIXME: shouldn't be DEFCONSTANT; and maybe make a shared EOF cookie in
+;;; SB-INT:*EOF-VALUE*?
+(defconstant load-eof-value '(()))
+
+;;; Load a text file.
+(defun sloload (stream verbose print)
+ (do-load-verbose stream verbose)
+ (do ((sexpr (read stream nil load-eof-value)
+ (read stream nil load-eof-value)))
+ ((eq sexpr load-eof-value)
+ t)
+ (if print
+ (let ((results (multiple-value-list (eval sexpr))))
+ (load-fresh-line)
+ (format t "~{~S~^, ~}~%" results))
+ (eval sexpr))))
+\f
+;;;; LOAD itself
+
+;;; a helper function for LOAD: Load the stuff in a file when we have the name.
+(defun internal-load (pathname truename if-does-not-exist verbose print
+ &optional contents)
+ (declare (type (member nil :error) if-does-not-exist))
+ (unless truename
+ (if if-does-not-exist
+ (error 'simple-file-error
+ :pathname pathname
+ :format-control "~S does not exist."
+ :format-arguments (list (namestring pathname)))
+ (return-from internal-load nil)))
+
+ (let ((*load-truename* truename)
+ (*load-pathname* pathname))
+ (case contents
+ (:source
+ (with-open-file (stream truename
+ :direction :input
+ :if-does-not-exist if-does-not-exist)
+ (sloload stream verbose print)))
+ (:binary
+ (with-open-file (stream truename
+ :direction :input
+ :if-does-not-exist if-does-not-exist
+ :element-type '(unsigned-byte 8))
+ (fasload stream verbose print)))
+ (t
+ (let ((first-line (with-open-file (stream truename :direction :input)
+ (read-line stream nil)))
+ (fhs sb!c:*fasl-header-string-start-string*))
+ (cond
+ ((and first-line
+ (>= (length (the simple-string first-line))
+ (length fhs))
+ (string= first-line fhs :end1 (length fhs)))
+ (internal-load pathname truename if-does-not-exist verbose print
+ :binary))
+ (t
+ (when (member (pathname-type truename)
+ *load-object-types*
+ :test #'string=)
+ (error "File has a fasl file type, but no fasl file header:~% ~S"
+ (namestring truename)))
+ (internal-load pathname truename if-does-not-exist verbose print
+ :source))))))))
+
+;;; a helper function for INTERNAL-LOAD-DEFAULT-TYPE
+(defun try-default-types (pathname types lp-type)
+ ;; Modified 18-Jan-97/pw for logical-pathname support.
+ ;;
+ ;; FIXME: How does logical-pathname support interact with
+ ;; *LOAD-SOURCE-TYPES* and *LOAD-OBJECT-TYPES*?
+ (flet ((frob (pathname type)
+ (let* ((pn (make-pathname :type type :defaults pathname))
+ (tn (probe-file pn)))
+ (values pn tn))))
+ (if (typep pathname 'logical-pathname)
+ (frob pathname lp-type)
+ (dolist (type types (values nil nil))
+ (multiple-value-bind (pn tn) (frob pathname type)
+ (when tn
+ (return (values pn tn))))))))
+
+;;; a helper function for LOAD: Handle the case of INTERNAL-LOAD where the file
+;;; does not exist.
+(defun internal-load-default-type (pathname if-does-not-exist verbose print)
+ (declare (type (member nil :error) if-does-not-exist))
+ ;; FIXME: How do the fixed "LISP" and "FASL" types interact with the
+ ;; *LOAD-SOURCE-TYPES* and *LOAD-OBJECT-TYPES* values?
+ (multiple-value-bind (src-pn src-tn)
+ (try-default-types pathname *load-source-types* "LISP")
+ (multiple-value-bind (obj-pn obj-tn)
+ (try-default-types pathname *load-object-types* "FASL")
+ (cond
+ ((and obj-tn
+ src-tn
+ (> (file-write-date src-tn) (file-write-date obj-tn)))
+ (restart-case
+ (error "The object file ~A is~@
+ older than the presumed source:~% ~A."
+ (namestring obj-tn)
+ (namestring src-tn))
+ ;; FIXME: In CMU CL one of these was a CONTINUE case.
+ ;; There's not one now. I don't remember how restart-case
+ ;; works very well, make sure that it doesn't do anything
+ ;; weird when we don't specify the CONTINUE case.
+ (source () :report "load source file"
+ (internal-load src-pn src-tn if-does-not-exist verbose print
+ :source))
+ (object () :report "load object file"
+ (internal-load src-pn obj-tn if-does-not-exist verbose print
+ :binary))))
+ (obj-tn
+ (internal-load obj-pn obj-tn if-does-not-exist verbose print :binary))
+ (src-pn
+ (internal-load src-pn src-tn if-does-not-exist verbose print :source))
+ (t
+ (internal-load pathname nil if-does-not-exist verbose print nil))))))
+
+;;; This function mainly sets up special bindings and then calls sub-functions.
+;;; We conditionally bind the switches with PROGV so that people can set them
+;;; in their init files and have the values take effect. If the compiler is
+;;; loaded, we make the compiler-policy local to LOAD by binding it to itself.
+;;;
+;;; FIXME: ANSI specifies an EXTERNAL-FORMAT keyword argument.
+;;;
+;;; FIXME: Daniel Barlow's ilsb.tar ILISP-for-SBCL patches contain an
+;;; implementation of "DEFUN SOURCE-FILE" which claims, in a comment, that CMU
+;;; CL does not correctly record source file information when LOADing a
+;;; non-compiled file. Check whether this bug exists in SBCL and fix it if so.
+(defun load (filespec
+ &key
+ (verbose *load-verbose*)
+ (print *load-print*)
+ (if-does-not-exist t))
+ #!+sb-doc
+ "Loads the file given by FILESPEC into the Lisp environment, returning
+ T on success. These options are defined:
+
+ :IF-DOES-NOT-EXIST
+ What should we do if the file can't be located? If true (the
+ default), signal an error. If NIL, simply return NIL.
+
+ :VERBOSE
+ If true, print a line describing each file loaded. The default
+ is *LOAD-VERBOSE*.
+
+ :PRINT
+ If true, print information about loaded values. When loading the
+ source, the result of evaluating each top-level form is printed.
+ The default is *LOAD-PRINT*."
+
+ (let ((sb!c::*default-cookie* sb!c::*default-cookie*)
+ (sb!c::*default-interface-cookie* sb!c::*default-interface-cookie*)
+ (*package* *package*)
+ (*readtable* *readtable*)
+ (*load-depth* (1+ *load-depth*))
+ ;; The old CMU CL LOAD function used an IF-DOES-NOT-EXIST argument of
+ ;; (MEMBER :ERROR NIL) type. ANSI constrains us to accept a generalized
+ ;; boolean argument value for this externally-visible function, but the
+ ;; internal functions still use the old convention.
+ (internal-if-does-not-exist (if if-does-not-exist :error nil)))
+ ;; FIXME: This VALUES wrapper is inherited from CMU CL.
+ ;; Once SBCL gets function return type checking right, we can
+ ;; achieve a similar effect better by adding FTYPE declarations.
+ (values
+ (if (streamp filespec)
+ (if (or (equal (stream-element-type filespec)
+ '(unsigned-byte 8)))
+ (fasload filespec verbose print)
+ (sloload filespec verbose print))
+ (let ((pn (merge-pathnames (pathname filespec)
+ *default-pathname-defaults*)))
+ (if (wild-pathname-p pn)
+ (let ((files (directory pn)))
+ #!+high-security
+ (when (null files)
+ (error 'file-error :pathname filespec))
+ (dolist (file files t)
+ (internal-load pn
+ file
+ internal-if-does-not-exist
+ verbose
+ print)))
+ (let ((tn (probe-file pn)))
+ (if (or tn (pathname-type pn))
+ (internal-load pn
+ tn
+ internal-if-does-not-exist
+ verbose
+ print)
+ (internal-load-default-type
+ pn
+ internal-if-does-not-exist
+ verbose
+ print)))))))))
+\f
+;;; Load a code object. BOX-NUM objects are popped off the stack for
+;;; the boxed storage section, then SIZE bytes of code are read in.
+#!-x86
+(defun load-code (box-num code-length)
+ (declare (fixnum box-num code-length))
+ (with-fop-stack t
+ (let ((code (%primitive sb!c:allocate-code-object box-num code-length))
+ (index (+ #!-gengc sb!vm:code-trace-table-offset-slot
+ #!+gengc sb!vm:code-debug-info-slot
+ box-num)))
+ (declare (type index index))
+ #!-gengc (setf (%code-debug-info code) (pop-stack))
+ (dotimes (i box-num)
+ (declare (fixnum i))
+ (setf (code-header-ref code (decf index)) (pop-stack)))
+ (sb!sys:without-gcing
+ (read-n-bytes *fasl-file*
+ (code-instructions code)
+ 0
+ #!-gengc code-length
+ #!+gengc (* code-length sb!vm:word-bytes)))
+ code)))
+
+#!+x86
+(defun load-code (box-num code-length)
+ (declare (fixnum box-num code-length))
+ (with-fop-stack t
+ (let ((stuff (list (pop-stack))))
+ (dotimes (i box-num)
+ (declare (fixnum i))
+ (push (pop-stack) stuff))
+ (let* ((dbi (car (last stuff))) ; debug-info
+ (tto (first stuff)) ; trace-table-offset
+ (load-to-dynamic-space
+ (or *enable-dynamic-space-code*
+ ;; definitely byte-compiled code?
+ (and *load-byte-compiled-code-to-dynamic-space*
+ (sb!c::debug-info-p dbi)
+ (not (sb!c::compiled-debug-info-p dbi)))
+ ;; or a x86 top level form?
+ (and *load-x86-tlf-to-dynamic-space*
+ (sb!c::compiled-debug-info-p dbi)
+ (string= (sb!c::compiled-debug-info-name dbi)
+ "top-level form")))) )
+
+ (setq stuff (nreverse stuff))
+
+ ;; Check that tto is always a list for byte-compiled
+ ;; code. Could be used an alternate check.
+ (when (and (typep tto 'list)
+ (not (and (sb!c::debug-info-p dbi)
+ (not (sb!c::compiled-debug-info-p dbi)))))
+ ;; FIXME: What is this for?
+ (format t "* tto list on non-bc code: ~S~% ~S ~S~%"
+ stuff dbi tto))
+
+ ;; FIXME: *LOAD-CODE-VERBOSE* should probably be #!+SB-SHOW.
+ (when *load-code-verbose*
+ (format t "stuff: ~S~%" stuff)
+ (format t
+ " : ~S ~S ~S ~S~%"
+ (sb!c::compiled-debug-info-p dbi)
+ (sb!c::debug-info-p dbi)
+ (sb!c::compiled-debug-info-name dbi)
+ tto)
+ (if load-to-dynamic-space
+ (format t " loading to the dynamic space~%")
+ (format t " loading to the static space~%")))
+
+ (let ((code
+ (if load-to-dynamic-space
+ (%primitive sb!c:allocate-dynamic-code-object
+ box-num
+ code-length)
+ (%primitive sb!c:allocate-code-object
+ box-num
+ code-length)))
+ (index (+ sb!vm:code-trace-table-offset-slot box-num)))
+ (declare (type index index))
+ (when *load-code-verbose*
+ (format t
+ " obj addr=~X~%"
+ (sb!kernel::get-lisp-obj-address code)))
+ (setf (%code-debug-info code) (pop stuff))
+ (dotimes (i box-num)
+ (declare (fixnum i))
+ (setf (code-header-ref code (decf index)) (pop stuff)))
+ (sb!sys:without-gcing
+ (read-n-bytes *fasl-file* (code-instructions code) 0 code-length))
+ code)))))
+\f
+;;;; linkage fixups
+
+;;; how we learn about assembler routines and foreign symbols at startup
+(defvar *!initial-assembler-routines*)
+(defvar *!initial-foreign-symbols*)
+(defun !loader-cold-init ()
+ (dolist (routine *!initial-assembler-routines*)
+ (setf (gethash (car routine) *assembler-routines*) (cdr routine)))
+ (dolist (symbol *!initial-foreign-symbols*)
+ (setf (gethash (car symbol) *static-foreign-symbols*) (cdr symbol))))
+
+(declaim (ftype (function (string) sb!vm:word) foreign-symbol-address-as-integer))
+(defun foreign-symbol-address-as-integer (foreign-symbol)
+ (or (gethash foreign-symbol *static-foreign-symbols*)
+ (gethash (concatenate 'simple-string
+ #!+linux "ldso_stub__"
+ #!+openbsd "_"
+ #!+freebsd ""
+ foreign-symbol)
+ *static-foreign-symbols*)
+ (sb!sys:get-dynamic-foreign-symbol-address foreign-symbol)
+ (error "unknown foreign symbol: ~S" foreign-symbol)))
+
+(defun foreign-symbol-address (symbol)
+ (int-sap (foreign-symbol-address-as-integer (sb!vm:extern-alien-name symbol))))
--- /dev/null
+;;;; Environment query functions, DOCUMENTATION and DRIBBLE.
+;;;;
+;;;; FIXME: If there are exactly three things in here, it could be
+;;;; exactly three files named e.g. equery.lisp, doc.lisp, and dribble.lisp.
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!IMPL")
+
+(file-comment
+ "$Header$")
+
+;;; cobbled from stuff in describe.lisp.
+(defun function-doc (x)
+ (let ((name
+ (case (get-type x)
+ (#.sb!vm:closure-header-type
+ (%function-name (%closure-function x)))
+ ((#.sb!vm:function-header-type #.sb!vm:closure-function-header-type)
+ (%function-name x))
+ (#.sb!vm:funcallable-instance-header-type
+ (typecase x
+ (byte-function
+ (sb!c::byte-function-name x))
+ (byte-closure
+ (sb!c::byte-function-name (byte-closure-function x)))
+ (sb!eval:interpreted-function
+ (multiple-value-bind (exp closure-p dname)
+ (sb!eval:interpreted-function-lambda-expression x)
+ (declare (ignore exp closure-p))
+ dname))
+ (t ;; funcallable-instance
+ (%function-name
+ (funcallable-instance-function x))))))))
+ (when (and name (typep name '(or symbol cons)))
+ (values (info :function :documentation name)))))
+
+(defvar *features* '#.sb-cold:*shebang-features*
+ #!+sb-doc
+ "a list of symbols that describe features provided by the
+ implementation")
+\f
+;;; various environment inquiries
+
+(defun machine-instance ()
+ #!+sb-doc
+ "Return a string giving the name of the local machine."
+ (sb!unix:unix-gethostname))
+
+;;; FIXME: Don't forget to set these in a sample site-init file.
+;;; FIXME: Perhaps the functions could be SETFable instead of having the
+;;; interface be through special variables? As far as I can tell
+;;; from ANSI 11.1.2.1.1 "Constraints on the COMMON-LISP Package
+;;; for Conforming Implementations" it is kosher to add a SETF function for
+;;; a symbol in COMMON-LISP..
+(defvar *short-site-name* nil
+ #!+sb-doc
+ "The value of SHORT-SITE-NAME.")
+(defvar *long-site-name* nil
+ #!+sb-doc "the value of LONG-SITE-NAME")
+(defun short-site-name ()
+ #!+sb-doc
+ "Returns a string with the abbreviated site name, or NIL if not known."
+ *short-site-name*)
+(defun long-site-name ()
+ #!+sb-doc
+ "Returns a string with the long form of the site name, or NIL if not known."
+ *long-site-name*)
+\f
+;;;; dribble stuff
+
+;;; Each time we start dribbling to a new stream, we put it in
+;;; *DRIBBLE-STREAM*, and push a list of *DRIBBLE-STREAM*, *STANDARD-INPUT*,
+;;; *STANDARD-OUTPUT* and *ERROR-OUTPUT* in *PREVIOUS-DRIBBLE-STREAMS*.
+;;; *STANDARD-OUTPUT* and *ERROR-OUTPUT* is changed to a broadcast stream that
+;;; broadcasts to *DRIBBLE-STREAM* and to the old values of the variables.
+;;; *STANDARD-INPUT* is changed to an echo stream that echos input from the old
+;;; value of standard input to *DRIBBLE-STREAM*.
+;;;
+;;; When dribble is called with no arguments, *DRIBBLE-STREAM* is closed,
+;;; and the values of *DRIBBLE-STREAM*, *STANDARD-INPUT*, and
+;;; *STANDARD-OUTPUT* are popped from *PREVIOUS-DRIBBLE-STREAMS*.
+
+(defvar *previous-dribble-streams* nil)
+(defvar *dribble-stream* nil)
+
+(defun dribble (&optional pathname &key (if-exists :append))
+ #!+sb-doc
+ "With a file name as an argument, dribble opens the file and sends a
+ record of further I/O to that file. Without an argument, it closes
+ the dribble file, and quits logging."
+ (cond (pathname
+ (let* ((new-dribble-stream
+ (open pathname
+ :direction :output
+ :if-exists if-exists
+ :if-does-not-exist :create))
+ (new-standard-output
+ (make-broadcast-stream *standard-output* new-dribble-stream))
+ (new-error-output
+ (make-broadcast-stream *error-output* new-dribble-stream))
+ (new-standard-input
+ (make-echo-stream *standard-input* new-dribble-stream)))
+ (push (list *dribble-stream* *standard-input* *standard-output*
+ *error-output*)
+ *previous-dribble-streams*)
+ (setf *dribble-stream* new-dribble-stream)
+ (setf *standard-input* new-standard-input)
+ (setf *standard-output* new-standard-output)
+ (setf *error-output* new-error-output)))
+ ((null *dribble-stream*)
+ (error "not currently dribbling"))
+ (t
+ (let ((old-streams (pop *previous-dribble-streams*)))
+ (close *dribble-stream*)
+ (setf *dribble-stream* (first old-streams))
+ (setf *standard-input* (second old-streams))
+ (setf *standard-output* (third old-streams))
+ (setf *error-output* (fourth old-streams)))))
+ (values))
--- /dev/null
+;;;; This file contains the definitions of most number functions.
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!KERNEL")
+
+(file-comment
+ "$Header$")
+\f
+;;;; the NUMBER-DISPATCH macro
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+
+;;; Grovel an individual case to NUMBER-DISPATCH, augmenting Result with the
+;;; type dispatches and bodies. Result is a tree built of alists representing
+;;; the dispatching off each arg (in order). The leaf is the body to be
+;;; executed in that case.
+(defun parse-number-dispatch (vars result types var-types body)
+ (cond ((null vars)
+ (unless (null types) (error "More types than vars."))
+ (when (cdr result)
+ (error "Duplicate case: ~S." body))
+ (setf (cdr result)
+ (sublis var-types body :test #'equal)))
+ ((null types)
+ (error "More vars than types."))
+ (t
+ (flet ((frob (var type)
+ (parse-number-dispatch
+ (rest vars)
+ (or (assoc type (cdr result) :test #'equal)
+ (car (setf (cdr result)
+ (acons type nil (cdr result)))))
+ (rest types)
+ (acons `(dispatch-type ,var) type var-types)
+ body)))
+ (let ((type (first types))
+ (var (first vars)))
+ (if (and (consp type) (eq (first type) 'foreach))
+ (dolist (type (rest type))
+ (frob var type))
+ (frob var type)))))))
+
+;;; Our guess for the preferred order to do type tests in (cheaper and/or more
+;;; probable first.)
+;;; FIXME: not an EQL thing, should not be DEFCONSTANT
+(defconstant type-test-ordering
+ '(fixnum single-float double-float integer #!+long-float long-float bignum
+ complex ratio))
+
+;;; Return true if Type1 should be tested before Type2.
+(defun type-test-order (type1 type2)
+ (let ((o1 (position type1 type-test-ordering))
+ (o2 (position type2 type-test-ordering)))
+ (cond ((not o1) nil)
+ ((not o2) t)
+ (t
+ (< o1 o2)))))
+
+;;; Return an ETYPECASE form that does the type dispatch, ordering the cases
+;;; for efficiency.
+(defun generate-number-dispatch (vars error-tags cases)
+ (if vars
+ (let ((var (first vars))
+ (cases (sort cases #'type-test-order :key #'car)))
+ `((typecase ,var
+ ,@(mapcar #'(lambda (case)
+ `(,(first case)
+ ,@(generate-number-dispatch (rest vars)
+ (rest error-tags)
+ (cdr case))))
+ cases)
+ (t (go ,(first error-tags))))))
+ cases))
+
+) ; EVAL-WHEN
+
+(defmacro number-dispatch (var-specs &body cases)
+ #!+sb-doc
+ "NUMBER-DISPATCH ({(Var Type)}*) {((Type*) Form*) | (Symbol Arg*)}*
+ A vaguely case-like macro that does number cross-product dispatches. The
+ Vars are the variables we are dispatching off of. The Type paired with each
+ Var is used in the error message when no case matches. Each case specifies a
+ Type for each var, and is executed when that signature holds. A type may be
+ a list (FOREACH Each-Type*), causing that case to be repeatedly instantiated
+ for every Each-Type. In the body of each case, any list of the form
+ (DISPATCH-TYPE Var-Name) is substituted with the type of that var in that
+ instance of the case.
+
+ As an alternate to a case spec, there may be a form whose CAR is a symbol.
+ In this case, we apply the CAR of the form to the CDR and treat the result of
+ the call as a list of cases. This process is not applied recursively."
+ (let ((res (list nil))
+ (vars (mapcar #'car var-specs))
+ (block (gensym)))
+ (dolist (case cases)
+ (if (symbolp (first case))
+ (let ((cases (apply (symbol-function (first case)) (rest case))))
+ (dolist (case cases)
+ (parse-number-dispatch vars res (first case) nil (rest case))))
+ (parse-number-dispatch vars res (first case) nil (rest case))))
+
+ (collect ((errors)
+ (error-tags))
+ (dolist (spec var-specs)
+ (let ((var (first spec))
+ (type (second spec))
+ (tag (gensym)))
+ (error-tags tag)
+ (errors tag)
+ (errors `(return-from
+ ,block
+ (error 'simple-type-error :datum ,var
+ :expected-type ',type
+ :format-control
+ "Argument ~A is not a ~S: ~S."
+ :format-arguments
+ (list ',var ',type ,var))))))
+
+ `(block ,block
+ (tagbody
+ (return-from ,block
+ ,@(generate-number-dispatch vars (error-tags)
+ (cdr res)))
+ ,@(errors))))))
+\f
+;;;; binary operation dispatching utilities
+
+(eval-when (:compile-toplevel :execute)
+
+;;; Return NUMBER-DISPATCH forms for rational X float.
+(defun float-contagion (op x y &optional (rat-types '(fixnum bignum ratio)))
+ `(((single-float single-float) (,op ,x ,y))
+ (((foreach ,@rat-types)
+ (foreach single-float double-float #!+long-float long-float))
+ (,op (coerce ,x '(dispatch-type ,y)) ,y))
+ (((foreach single-float double-float #!+long-float long-float)
+ (foreach ,@rat-types))
+ (,op ,x (coerce ,y '(dispatch-type ,x))))
+ #!+long-float
+ (((foreach single-float double-float long-float) long-float)
+ (,op (coerce ,x 'long-float) ,y))
+ #!+long-float
+ ((long-float (foreach single-float double-float))
+ (,op ,x (coerce ,y 'long-float)))
+ (((foreach single-float double-float) double-float)
+ (,op (coerce ,x 'double-float) ,y))
+ ((double-float single-float)
+ (,op ,x (coerce ,y 'double-float)))))
+
+;;; Return NUMBER-DISPATCH forms for bignum X fixnum.
+(defun bignum-cross-fixnum (fix-op big-op)
+ `(((fixnum fixnum) (,fix-op x y))
+ ((fixnum bignum)
+ (,big-op (make-small-bignum x) y))
+ ((bignum fixnum)
+ (,big-op x (make-small-bignum y)))
+ ((bignum bignum)
+ (,big-op x y))))
+
+) ; EVAL-WHEN
+\f
+;;;; canonicalization utilities
+
+;;; If imagpart is 0, return realpart, otherwise make a complex. This is
+;;; used when we know that realpart and imagpart are the same type, but
+;;; rational canonicalization might still need to be done.
+#!-sb-fluid (declaim (inline canonical-complex))
+(defun canonical-complex (realpart imagpart)
+ (if (eql imagpart 0)
+ realpart
+ (cond #!+long-float
+ ((and (typep realpart 'long-float)
+ (typep imagpart 'long-float))
+ (truly-the (complex long-float) (complex realpart imagpart)))
+ ((and (typep realpart 'double-float)
+ (typep imagpart 'double-float))
+ (truly-the (complex double-float) (complex realpart imagpart)))
+ ((and (typep realpart 'single-float)
+ (typep imagpart 'single-float))
+ (truly-the (complex single-float) (complex realpart imagpart)))
+ (t
+ (%make-complex realpart imagpart)))))
+
+;;; Given a numerator and denominator with the GCD already divided out, make
+;;; a canonical rational. We make the denominator positive, and check whether
+;;; it is 1.
+#!-sb-fluid (declaim (inline build-ratio))
+(defun build-ratio (num den)
+ (multiple-value-bind (num den)
+ (if (minusp den)
+ (values (- num) (- den))
+ (values num den))
+ (if (eql den 1)
+ num
+ (%make-ratio num den))))
+
+;;; Truncate X and Y, but bum the case where Y is 1.
+#!-sb-fluid (declaim (inline maybe-truncate))
+(defun maybe-truncate (x y)
+ (if (eql y 1)
+ x
+ (truncate x y)))
+\f
+;;;; COMPLEXes
+
+(defun upgraded-complex-part-type (spec)
+ #!+sb-doc
+ "Returns the element type of the most specialized COMPLEX number type that
+ can hold parts of type Spec."
+ (cond ((subtypep spec 'single-float)
+ 'single-float)
+ ((subtypep spec 'double-float)
+ 'double-float)
+ #!+long-float
+ ((subtypep spec 'long-float)
+ 'long-float)
+ ((subtypep spec 'rational)
+ 'rational)
+ (t)))
+
+(defun complex (realpart &optional (imagpart 0))
+ #!+sb-doc
+ "Builds a complex number from the specified components."
+ (flet ((%%make-complex (realpart imagpart)
+ (cond #!+long-float
+ ((and (typep realpart 'long-float)
+ (typep imagpart 'long-float))
+ (truly-the (complex long-float)
+ (complex realpart imagpart)))
+ ((and (typep realpart 'double-float)
+ (typep imagpart 'double-float))
+ (truly-the (complex double-float)
+ (complex realpart imagpart)))
+ ((and (typep realpart 'single-float)
+ (typep imagpart 'single-float))
+ (truly-the (complex single-float)
+ (complex realpart imagpart)))
+ (t
+ (%make-complex realpart imagpart)))))
+ (number-dispatch ((realpart real) (imagpart real))
+ ((rational rational)
+ (canonical-complex realpart imagpart))
+ (float-contagion %%make-complex realpart imagpart (rational)))))
+
+(defun realpart (number)
+ #!+sb-doc
+ "Extracts the real part of a number."
+ (typecase number
+ #!+long-float
+ ((complex long-float)
+ (truly-the long-float (realpart number)))
+ ((complex double-float)
+ (truly-the double-float (realpart number)))
+ ((complex single-float)
+ (truly-the single-float (realpart number)))
+ ((complex rational)
+ (sb!kernel:%realpart number))
+ (t
+ number)))
+
+(defun imagpart (number)
+ #!+sb-doc
+ "Extracts the imaginary part of a number."
+ (typecase number
+ #!+long-float
+ ((complex long-float)
+ (truly-the long-float (imagpart number)))
+ ((complex double-float)
+ (truly-the double-float (imagpart number)))
+ ((complex single-float)
+ (truly-the single-float (imagpart number)))
+ ((complex rational)
+ (sb!kernel:%imagpart number))
+ (float
+ (float 0 number))
+ (t
+ 0)))
+
+(defun conjugate (number)
+ #!+sb-doc
+ "Returns the complex conjugate of NUMBER. For non-complex numbers, this is
+ an identity."
+ (if (complexp number)
+ (complex (realpart number) (- (imagpart number)))
+ number))
+
+(defun signum (number)
+ #!+sb-doc
+ "If NUMBER is zero, return NUMBER, else return (/ NUMBER (ABS NUMBER))."
+ (if (zerop number)
+ number
+ (if (rationalp number)
+ (if (plusp number) 1 -1)
+ (/ number (abs number)))))
+\f
+;;;; ratios
+
+(defun numerator (number)
+ #!+sb-doc
+ "Return the numerator of NUMBER, which must be rational."
+ (numerator number))
+
+(defun denominator (number)
+ #!+sb-doc
+ "Return the denominator of NUMBER, which must be rational."
+ (denominator number))
+\f
+;;;; arithmetic operations
+
+(macrolet ((define-arith (op init doc)
+ #!-sb-doc (declare (ignore doc))
+ `(defun ,op (&rest args)
+ #!+sb-doc ,doc
+ (if (null args) ,init
+ (do ((args (cdr args) (cdr args))
+ (res (car args) (,op res (car args))))
+ ((null args) res))))))
+ (define-arith + 0
+ "Returns the sum of its arguments. With no args, returns 0.")
+ (define-arith * 1
+ "Returns the product of its arguments. With no args, returns 1."))
+
+(defun - (number &rest more-numbers)
+ #!+sb-doc
+ "Subtracts the second and all subsequent arguments from the first.
+ With one arg, negates it."
+ (if more-numbers
+ (do ((nlist more-numbers (cdr nlist))
+ (result number))
+ ((atom nlist) result)
+ (declare (list nlist))
+ (setq result (- result (car nlist))))
+ (- number)))
+
+(defun / (number &rest more-numbers)
+ #!+sb-doc
+ "Divides the first arg by each of the following arguments, in turn.
+ With one arg, returns reciprocal."
+ (if more-numbers
+ (do ((nlist more-numbers (cdr nlist))
+ (result number))
+ ((atom nlist) result)
+ (declare (list nlist))
+ (setq result (/ result (car nlist))))
+ (/ number)))
+
+(defun 1+ (number)
+ #!+sb-doc
+ "Returns NUMBER + 1."
+ (1+ number))
+
+(defun 1- (number)
+ #!+sb-doc
+ "Returns NUMBER - 1."
+ (1- number))
+
+(eval-when (:compile-toplevel)
+
+(sb!xc:defmacro two-arg-+/- (name op big-op)
+ `(defun ,name (x y)
+ (number-dispatch ((x number) (y number))
+ (bignum-cross-fixnum ,op ,big-op)
+ (float-contagion ,op x y)
+
+ ((complex complex)
+ (canonical-complex (,op (realpart x) (realpart y))
+ (,op (imagpart x) (imagpart y))))
+ (((foreach bignum fixnum ratio single-float double-float
+ #!+long-float long-float) complex)
+ (complex (,op x (realpart y)) (,op (imagpart y))))
+ ((complex (or rational float))
+ (complex (,op (realpart x) y) (imagpart x)))
+
+ (((foreach fixnum bignum) ratio)
+ (let* ((dy (denominator y))
+ (n (,op (* x dy) (numerator y))))
+ (%make-ratio n dy)))
+ ((ratio integer)
+ (let* ((dx (denominator x))
+ (n (,op (numerator x) (* y dx))))
+ (%make-ratio n dx)))
+ ((ratio ratio)
+ (let* ((nx (numerator x))
+ (dx (denominator x))
+ (ny (numerator y))
+ (dy (denominator y))
+ (g1 (gcd dx dy)))
+ (if (eql g1 1)
+ (%make-ratio (,op (* nx dy) (* dx ny)) (* dx dy))
+ (let* ((t1 (,op (* nx (truncate dy g1)) (* (truncate dx g1) ny)))
+ (g2 (gcd t1 g1))
+ (t2 (truncate dx g1)))
+ (cond ((eql t1 0) 0)
+ ((eql g2 1)
+ (%make-ratio t1 (* t2 dy)))
+ (T (let* ((nn (truncate t1 g2))
+ (t3 (truncate dy g2))
+ (nd (if (eql t2 1) t3 (* t2 t3))))
+ (if (eql nd 1) nn (%make-ratio nn nd))))))))))))
+
+); Eval-When (Compile)
+
+(two-arg-+/- two-arg-+ + add-bignums)
+(two-arg-+/- two-arg-- - subtract-bignum)
+
+(defun two-arg-* (x y)
+ (flet ((integer*ratio (x y)
+ (if (eql x 0) 0
+ (let* ((ny (numerator y))
+ (dy (denominator y))
+ (gcd (gcd x dy)))
+ (if (eql gcd 1)
+ (%make-ratio (* x ny) dy)
+ (let ((nn (* (truncate x gcd) ny))
+ (nd (truncate dy gcd)))
+ (if (eql nd 1)
+ nn
+ (%make-ratio nn nd)))))))
+ (complex*real (x y)
+ (canonical-complex (* (realpart x) y) (* (imagpart x) y))))
+ (number-dispatch ((x number) (y number))
+ (float-contagion * x y)
+
+ ((fixnum fixnum) (multiply-fixnums x y))
+ ((bignum fixnum) (multiply-bignum-and-fixnum x y))
+ ((fixnum bignum) (multiply-bignum-and-fixnum y x))
+ ((bignum bignum) (multiply-bignums x y))
+
+ ((complex complex)
+ (let* ((rx (realpart x))
+ (ix (imagpart x))
+ (ry (realpart y))
+ (iy (imagpart y)))
+ (canonical-complex (- (* rx ry) (* ix iy)) (+ (* rx iy) (* ix ry)))))
+ (((foreach bignum fixnum ratio single-float double-float
+ #!+long-float long-float)
+ complex)
+ (complex*real y x))
+ ((complex (or rational float))
+ (complex*real x y))
+
+ (((foreach bignum fixnum) ratio) (integer*ratio x y))
+ ((ratio integer) (integer*ratio y x))
+ ((ratio ratio)
+ (let* ((nx (numerator x))
+ (dx (denominator x))
+ (ny (numerator y))
+ (dy (denominator y))
+ (g1 (gcd nx dy))
+ (g2 (gcd dx ny)))
+ (build-ratio (* (maybe-truncate nx g1)
+ (maybe-truncate ny g2))
+ (* (maybe-truncate dx g2)
+ (maybe-truncate dy g1))))))))
+
+;;; Divide two integers, producing a canonical rational. If a fixnum, we see
+;;; whether they divide evenly before trying the GCD. In the bignum case, we
+;;; don't bother, since bignum division is expensive, and the test is not very
+;;; likely to succeed.
+(defun integer-/-integer (x y)
+ (if (and (typep x 'fixnum) (typep y 'fixnum))
+ (multiple-value-bind (quo rem) (truncate x y)
+ (if (zerop rem)
+ quo
+ (let ((gcd (gcd x y)))
+ (declare (fixnum gcd))
+ (if (eql gcd 1)
+ (build-ratio x y)
+ (build-ratio (truncate x gcd) (truncate y gcd))))))
+ (let ((gcd (gcd x y)))
+ (if (eql gcd 1)
+ (build-ratio x y)
+ (build-ratio (truncate x gcd) (truncate y gcd))))))
+
+(defun two-arg-/ (x y)
+ (number-dispatch ((x number) (y number))
+ (float-contagion / x y (ratio integer))
+
+ ((complex complex)
+ (let* ((rx (realpart x))
+ (ix (imagpart x))
+ (ry (realpart y))
+ (iy (imagpart y)))
+ (if (> (abs ry) (abs iy))
+ (let* ((r (/ iy ry))
+ (dn (* ry (+ 1 (* r r)))))
+ (canonical-complex (/ (+ rx (* ix r)) dn)
+ (/ (- ix (* rx r)) dn)))
+ (let* ((r (/ ry iy))
+ (dn (* iy (+ 1 (* r r)))))
+ (canonical-complex (/ (+ (* rx r) ix) dn)
+ (/ (- (* ix r) rx) dn))))))
+ (((foreach integer ratio single-float double-float) complex)
+ (let* ((ry (realpart y))
+ (iy (imagpart y)))
+ (if (> (abs ry) (abs iy))
+ (let* ((r (/ iy ry))
+ (dn (* ry (+ 1 (* r r)))))
+ (canonical-complex (/ x dn)
+ (/ (- (* x r)) dn)))
+ (let* ((r (/ ry iy))
+ (dn (* iy (+ 1 (* r r)))))
+ (canonical-complex (/ (* x r) dn)
+ (/ (- x) dn))))))
+ ((complex (or rational float))
+ (canonical-complex (/ (realpart x) y)
+ (/ (imagpart x) y)))
+
+ ((ratio ratio)
+ (let* ((nx (numerator x))
+ (dx (denominator x))
+ (ny (numerator y))
+ (dy (denominator y))
+ (g1 (gcd nx ny))
+ (g2 (gcd dx dy)))
+ (build-ratio (* (maybe-truncate nx g1) (maybe-truncate dy g2))
+ (* (maybe-truncate dx g2) (maybe-truncate ny g1)))))
+
+ ((integer integer)
+ (integer-/-integer x y))
+
+ ((integer ratio)
+ (if (zerop x)
+ 0
+ (let* ((ny (numerator y))
+ (dy (denominator y))
+ (gcd (gcd x ny)))
+ (build-ratio (* (maybe-truncate x gcd) dy)
+ (maybe-truncate ny gcd)))))
+
+ ((ratio integer)
+ (let* ((nx (numerator x))
+ (gcd (gcd nx y)))
+ (build-ratio (maybe-truncate nx gcd)
+ (* (maybe-truncate y gcd) (denominator x)))))))
+
+(defun %negate (n)
+ (number-dispatch ((n number))
+ (((foreach fixnum single-float double-float #!+long-float long-float))
+ (%negate n))
+ ((bignum)
+ (negate-bignum n))
+ ((ratio)
+ (%make-ratio (- (numerator n)) (denominator n)))
+ ((complex)
+ (complex (- (realpart n)) (- (imagpart n))))))
+\f
+;;;; TRUNCATE and friends
+
+(defun truncate (number &optional (divisor 1))
+ #!+sb-doc
+ "Returns number (or number/divisor) as an integer, rounded toward 0.
+ The second returned value is the remainder."
+ (macrolet ((truncate-float (rtype)
+ `(let* ((float-div (coerce divisor ',rtype))
+ (res (%unary-truncate (/ number float-div))))
+ (values res
+ (- number
+ (* (coerce res ',rtype) float-div))))))
+ (number-dispatch ((number real) (divisor real))
+ ((fixnum fixnum) (truncate number divisor))
+ (((foreach fixnum bignum) ratio)
+ (let ((q (truncate (* number (denominator divisor))
+ (numerator divisor))))
+ (values q (- number (* q divisor)))))
+ ((fixnum bignum)
+ (values 0 number))
+ ((ratio (or float rational))
+ (let ((q (truncate (numerator number)
+ (* (denominator number) divisor))))
+ (values q (- number (* q divisor)))))
+ ((bignum fixnum)
+ (bignum-truncate number (make-small-bignum divisor)))
+ ((bignum bignum)
+ (bignum-truncate number divisor))
+
+ (((foreach single-float double-float #!+long-float long-float)
+ (or rational single-float))
+ (if (eql divisor 1)
+ (let ((res (%unary-truncate number)))
+ (values res (- number (coerce res '(dispatch-type number)))))
+ (truncate-float (dispatch-type number))))
+ #!+long-float
+ ((long-float (or single-float double-float long-float))
+ (truncate-float long-float))
+ #!+long-float
+ (((foreach double-float single-float) long-float)
+ (truncate-float long-float))
+ ((double-float (or single-float double-float))
+ (truncate-float double-float))
+ ((single-float double-float)
+ (truncate-float double-float))
+ (((foreach fixnum bignum ratio)
+ (foreach single-float double-float #!+long-float long-float))
+ (truncate-float (dispatch-type divisor))))))
+
+;;; Declare these guys inline to let them get optimized a little. ROUND and
+;;; FROUND are not declared inline since they seem too obscure and too
+;;; big to inline-expand by default. Also, this gives the compiler a chance to
+;;; pick off the unary float case. Similarly, CEILING and FLOOR are only
+;;; maybe-inline for now, so that the power-of-2 CEILING and FLOOR transforms
+;;; get a chance.
+#!-sb-fluid (declaim (inline rem mod fceiling ffloor ftruncate))
+(declaim (maybe-inline ceiling floor))
+
+;;; If the numbers do not divide exactly and the result of (/ number divisor)
+;;; would be negative then decrement the quotient and augment the remainder by
+;;; the divisor.
+(defun floor (number &optional (divisor 1))
+ #!+sb-doc
+ "Returns the greatest integer not greater than number, or number/divisor.
+ The second returned value is (mod number divisor)."
+ (multiple-value-bind (tru rem) (truncate number divisor)
+ (if (and (not (zerop rem))
+ (if (minusp divisor)
+ (plusp number)
+ (minusp number)))
+ (values (1- tru) (+ rem divisor))
+ (values tru rem))))
+
+;;; If the numbers do not divide exactly and the result of (/ number divisor)
+;;; would be positive then increment the quotient and decrement the remainder
+;;; by the divisor.
+(defun ceiling (number &optional (divisor 1))
+ #!+sb-doc
+ "Returns the smallest integer not less than number, or number/divisor.
+ The second returned value is the remainder."
+ (multiple-value-bind (tru rem) (truncate number divisor)
+ (if (and (not (zerop rem))
+ (if (minusp divisor)
+ (minusp number)
+ (plusp number)))
+ (values (+ tru 1) (- rem divisor))
+ (values tru rem))))
+
+(defun round (number &optional (divisor 1))
+ #!+sb-doc
+ "Rounds number (or number/divisor) to nearest integer.
+ The second returned value is the remainder."
+ (if (eql divisor 1)
+ (round number)
+ (multiple-value-bind (tru rem) (truncate number divisor)
+ (let ((thresh (/ (abs divisor) 2)))
+ (cond ((or (> rem thresh)
+ (and (= rem thresh) (oddp tru)))
+ (if (minusp divisor)
+ (values (- tru 1) (+ rem divisor))
+ (values (+ tru 1) (- rem divisor))))
+ ((let ((-thresh (- thresh)))
+ (or (< rem -thresh)
+ (and (= rem -thresh) (oddp tru))))
+ (if (minusp divisor)
+ (values (+ tru 1) (- rem divisor))
+ (values (- tru 1) (+ rem divisor))))
+ (t (values tru rem)))))))
+
+(defun rem (number divisor)
+ #!+sb-doc
+ "Returns second result of TRUNCATE."
+ (multiple-value-bind (tru rem) (truncate number divisor)
+ (declare (ignore tru))
+ rem))
+
+(defun mod (number divisor)
+ #!+sb-doc
+ "Returns second result of FLOOR."
+ (let ((rem (rem number divisor)))
+ (if (and (not (zerop rem))
+ (if (minusp divisor)
+ (plusp number)
+ (minusp number)))
+ (+ rem divisor)
+ rem)))
+
+(macrolet ((def-frob (name op doc)
+ `(defun ,name (number &optional (divisor 1))
+ ,doc
+ (multiple-value-bind (res rem) (,op number divisor)
+ (values (float res (if (floatp rem) rem 1.0)) rem)))))
+ (def-frob ffloor floor
+ "Same as FLOOR, but returns first value as a float.")
+ (def-frob fceiling ceiling
+ "Same as CEILING, but returns first value as a float." )
+ (def-frob ftruncate truncate
+ "Same as TRUNCATE, but returns first value as a float.")
+ (def-frob fround round
+ "Same as ROUND, but returns first value as a float."))
+\f
+;;;; comparisons
+
+(defun = (number &rest more-numbers)
+ #!+sb-doc
+ "Returns T if all of its arguments are numerically equal, NIL otherwise."
+ (do ((nlist more-numbers (cdr nlist)))
+ ((atom nlist) T)
+ (declare (list nlist))
+ (if (not (= (car nlist) number)) (return nil))))
+
+(defun /= (number &rest more-numbers)
+ #!+sb-doc
+ "Returns T if no two of its arguments are numerically equal, NIL otherwise."
+ (do* ((head number (car nlist))
+ (nlist more-numbers (cdr nlist)))
+ ((atom nlist) t)
+ (declare (list nlist))
+ (unless (do* ((nl nlist (cdr nl)))
+ ((atom nl) T)
+ (declare (list nl))
+ (if (= head (car nl)) (return nil)))
+ (return nil))))
+
+(defun < (number &rest more-numbers)
+ #!+sb-doc
+ "Returns T if its arguments are in strictly increasing order, NIL otherwise."
+ (do* ((n number (car nlist))
+ (nlist more-numbers (cdr nlist)))
+ ((atom nlist) t)
+ (declare (list nlist))
+ (if (not (< n (car nlist))) (return nil))))
+
+(defun > (number &rest more-numbers)
+ #!+sb-doc
+ "Returns T if its arguments are in strictly decreasing order, NIL otherwise."
+ (do* ((n number (car nlist))
+ (nlist more-numbers (cdr nlist)))
+ ((atom nlist) t)
+ (declare (list nlist))
+ (if (not (> n (car nlist))) (return nil))))
+
+(defun <= (number &rest more-numbers)
+ #!+sb-doc
+ "Returns T if arguments are in strictly non-decreasing order, NIL otherwise."
+ (do* ((n number (car nlist))
+ (nlist more-numbers (cdr nlist)))
+ ((atom nlist) t)
+ (declare (list nlist))
+ (if (not (<= n (car nlist))) (return nil))))
+
+(defun >= (number &rest more-numbers)
+ #!+sb-doc
+ "Returns T if arguments are in strictly non-increasing order, NIL otherwise."
+ (do* ((n number (car nlist))
+ (nlist more-numbers (cdr nlist)))
+ ((atom nlist) t)
+ (declare (list nlist))
+ (if (not (>= n (car nlist))) (return nil))))
+
+(defun max (number &rest more-numbers)
+ #!+sb-doc
+ "Returns the greatest of its arguments."
+ (do ((nlist more-numbers (cdr nlist))
+ (result number))
+ ((null nlist) (return result))
+ (declare (list nlist))
+ (if (> (car nlist) result) (setq result (car nlist)))))
+
+(defun min (number &rest more-numbers)
+ #!+sb-doc
+ "Returns the least of its arguments."
+ (do ((nlist more-numbers (cdr nlist))
+ (result number))
+ ((null nlist) (return result))
+ (declare (list nlist))
+ (if (< (car nlist) result) (setq result (car nlist)))))
+
+(eval-when (:compile-toplevel :execute)
+
+(defun basic-compare (op)
+ `(((fixnum fixnum) (,op x y))
+
+ ((single-float single-float) (,op x y))
+ #!+long-float
+ (((foreach single-float double-float long-float) long-float)
+ (,op (coerce x 'long-float) y))
+ #!+long-float
+ ((long-float (foreach single-float double-float))
+ (,op x (coerce y 'long-float)))
+ (((foreach single-float double-float) double-float)
+ (,op (coerce x 'double-float) y))
+ ((double-float single-float)
+ (,op x (coerce y 'double-float)))
+ (((foreach single-float double-float #!+long-float long-float) rational)
+ (if (eql y 0)
+ (,op x (coerce 0 '(dispatch-type x)))
+ (,op (rational x) y)))
+ (((foreach bignum fixnum ratio) float)
+ (,op x (rational y)))))
+
+(sb!xc:defmacro two-arg-</> (name op ratio-arg1 ratio-arg2 &rest cases)
+ `(defun ,name (x y)
+ (number-dispatch ((x real) (y real))
+ (basic-compare ,op)
+
+ (((foreach fixnum bignum) ratio)
+ (,op x (,ratio-arg2 (numerator y) (denominator y))))
+ ((ratio integer)
+ (,op (,ratio-arg1 (numerator x) (denominator x)) y))
+ ((ratio ratio)
+ (,op (* (numerator (truly-the ratio x))
+ (denominator (truly-the ratio y)))
+ (* (numerator (truly-the ratio y))
+ (denominator (truly-the ratio x)))))
+ ,@cases)))
+
+); Eval-When (Compile Eval)
+
+(two-arg-</> two-arg-< < floor ceiling
+ ((fixnum bignum)
+ (bignum-plus-p y))
+ ((bignum fixnum)
+ (not (bignum-plus-p x)))
+ ((bignum bignum)
+ (minusp (bignum-compare x y))))
+
+(two-arg-</> two-arg-> > ceiling floor
+ ((fixnum bignum)
+ (not (bignum-plus-p y)))
+ ((bignum fixnum)
+ (bignum-plus-p x))
+ ((bignum bignum)
+ (plusp (bignum-compare x y))))
+
+(defun two-arg-= (x y)
+ (number-dispatch ((x number) (y number))
+ (basic-compare =)
+
+ ((fixnum (or bignum ratio)) nil)
+
+ ((bignum (or fixnum ratio)) nil)
+ ((bignum bignum)
+ (zerop (bignum-compare x y)))
+
+ ((ratio integer) nil)
+ ((ratio ratio)
+ (and (eql (numerator x) (numerator y))
+ (eql (denominator x) (denominator y))))
+
+ ((complex complex)
+ (and (= (realpart x) (realpart y))
+ (= (imagpart x) (imagpart y))))
+ (((foreach fixnum bignum ratio single-float double-float
+ #!+long-float long-float) complex)
+ (and (= x (realpart y))
+ (zerop (imagpart y))))
+ ((complex (or float rational))
+ (and (= (realpart x) y)
+ (zerop (imagpart x))))))
+
+(defun eql (obj1 obj2)
+ #!+sb-doc
+ "Return T if OBJ1 and OBJ2 represent the same object, otherwise NIL."
+ (or (eq obj1 obj2)
+ (if (or (typep obj2 'fixnum)
+ (not (typep obj2 'number)))
+ nil
+ (macrolet ((foo (&rest stuff)
+ `(typecase obj2
+ ,@(mapcar #'(lambda (foo)
+ (let ((type (car foo))
+ (fn (cadr foo)))
+ `(,type
+ (and (typep obj1 ',type)
+ (,fn obj1 obj2)))))
+ stuff))))
+ (foo
+ (single-float eql)
+ (double-float eql)
+ #!+long-float
+ (long-float eql)
+ (bignum
+ (lambda (x y)
+ (zerop (bignum-compare x y))))
+ (ratio
+ (lambda (x y)
+ (and (eql (numerator x) (numerator y))
+ (eql (denominator x) (denominator y)))))
+ (complex
+ (lambda (x y)
+ (and (eql (realpart x) (realpart y))
+ (eql (imagpart x) (imagpart y))))))))))
+\f
+;;;; logicals
+
+(defun logior (&rest integers)
+ #!+sb-doc
+ "Returns the bit-wise or of its arguments. Args must be integers."
+ (declare (list integers))
+ (if integers
+ (do ((result (pop integers) (logior result (pop integers))))
+ ((null integers) result))
+ 0))
+
+(defun logxor (&rest integers)
+ #!+sb-doc
+ "Returns the bit-wise exclusive or of its arguments. Args must be integers."
+ (declare (list integers))
+ (if integers
+ (do ((result (pop integers) (logxor result (pop integers))))
+ ((null integers) result))
+ 0))
+
+(defun logand (&rest integers)
+ #!+sb-doc
+ "Returns the bit-wise and of its arguments. Args must be integers."
+ (declare (list integers))
+ (if integers
+ (do ((result (pop integers) (logand result (pop integers))))
+ ((null integers) result))
+ -1))
+
+(defun logeqv (&rest integers)
+ #!+sb-doc
+ "Returns the bit-wise equivalence of its arguments. Args must be integers."
+ (declare (list integers))
+ (if integers
+ (do ((result (pop integers) (logeqv result (pop integers))))
+ ((null integers) result))
+ -1))
+
+(defun lognand (integer1 integer2)
+ #!+sb-doc
+ "Returns the complement of the logical AND of integer1 and integer2."
+ (lognand integer1 integer2))
+
+(defun lognor (integer1 integer2)
+ #!+sb-doc
+ "Returns the complement of the logical OR of integer1 and integer2."
+ (lognor integer1 integer2))
+
+(defun logandc1 (integer1 integer2)
+ #!+sb-doc
+ "Returns the logical AND of (LOGNOT integer1) and integer2."
+ (logandc1 integer1 integer2))
+
+(defun logandc2 (integer1 integer2)
+ #!+sb-doc
+ "Returns the logical AND of integer1 and (LOGNOT integer2)."
+ (logandc2 integer1 integer2))
+
+(defun logorc1 (integer1 integer2)
+ #!+sb-doc
+ "Returns the logical OR of (LOGNOT integer1) and integer2."
+ (logorc1 integer1 integer2))
+
+(defun logorc2 (integer1 integer2)
+ #!+sb-doc
+ "Returns the logical OR of integer1 and (LOGNOT integer2)."
+ (logorc2 integer1 integer2))
+
+(defun lognot (number)
+ #!+sb-doc
+ "Returns the bit-wise logical not of integer."
+ (etypecase number
+ (fixnum (lognot (truly-the fixnum number)))
+ (bignum (bignum-logical-not number))))
+
+(macrolet ((def-frob (name op big-op)
+ `(defun ,name (x y)
+ (number-dispatch ((x integer) (y integer))
+ (bignum-cross-fixnum ,op ,big-op)))))
+ (def-frob two-arg-and logand bignum-logical-and)
+ (def-frob two-arg-ior logior bignum-logical-ior)
+ (def-frob two-arg-xor logxor bignum-logical-xor))
+
+(defun logcount (integer)
+ #!+sb-doc
+ "Count the number of 1 bits if INTEGER is positive, and the number of 0 bits
+ if INTEGER is negative."
+ (etypecase integer
+ (fixnum
+ (logcount (truly-the (integer 0 #.(max most-positive-fixnum
+ (lognot most-negative-fixnum)))
+ (if (minusp (truly-the fixnum integer))
+ (lognot (truly-the fixnum integer))
+ integer))))
+ (bignum
+ (bignum-logcount integer))))
+
+(defun logtest (integer1 integer2)
+ #!+sb-doc
+ "Predicate which returns T if logand of integer1 and integer2 is not zero."
+ (logtest integer1 integer2))
+
+(defun logbitp (index integer)
+ #!+sb-doc
+ "Predicate returns T if bit index of integer is a 1."
+ (logbitp index integer))
+
+(defun ash (integer count)
+ #!+sb-doc
+ "Shifts integer left by count places preserving sign. - count shifts right."
+ (declare (integer integer count))
+ (etypecase integer
+ (fixnum
+ (cond ((zerop integer)
+ 0)
+ ((fixnump count)
+ (let ((length (integer-length (truly-the fixnum integer)))
+ (count (truly-the fixnum count)))
+ (declare (fixnum length count))
+ (cond ((and (plusp count)
+ (> (+ length count)
+ (integer-length most-positive-fixnum)))
+ (bignum-ashift-left (make-small-bignum integer) count))
+ (t
+ (truly-the fixnum
+ (ash (truly-the fixnum integer) count))))))
+ ((minusp count)
+ (if (minusp integer) -1 0))
+ (t
+ (bignum-ashift-left (make-small-bignum integer) count))))
+ (bignum
+ (if (plusp count)
+ (bignum-ashift-left integer count)
+ (bignum-ashift-right integer (- count))))))
+
+(defun integer-length (integer)
+ #!+sb-doc
+ "Returns the number of significant bits in the absolute value of integer."
+ (etypecase integer
+ (fixnum
+ (integer-length (truly-the fixnum integer)))
+ (bignum
+ (bignum-integer-length integer))))
+\f
+;;;; BYTE, bytespecs, and related operations
+
+(defun byte (size position)
+ #!+sb-doc
+ "Returns a byte specifier which may be used by other byte functions."
+ (byte size position))
+
+(defun byte-size (bytespec)
+ #!+sb-doc
+ "Returns the size part of the byte specifier bytespec."
+ (byte-size bytespec))
+
+(defun byte-position (bytespec)
+ #!+sb-doc
+ "Returns the position part of the byte specifier bytespec."
+ (byte-position bytespec))
+
+(defun ldb (bytespec integer)
+ #!+sb-doc
+ "Extract the specified byte from integer, and right justify result."
+ (ldb bytespec integer))
+
+(defun ldb-test (bytespec integer)
+ #!+sb-doc
+ "Returns T if any of the specified bits in integer are 1's."
+ (ldb-test bytespec integer))
+
+(defun mask-field (bytespec integer)
+ #!+sb-doc
+ "Extract the specified byte from integer, but do not right justify result."
+ (mask-field bytespec integer))
+
+(defun dpb (newbyte bytespec integer)
+ #!+sb-doc
+ "Returns new integer with newbyte in specified position, newbyte is right justified."
+ (dpb newbyte bytespec integer))
+
+(defun deposit-field (newbyte bytespec integer)
+ #!+sb-doc
+ "Returns new integer with newbyte in specified position, newbyte is not right justified."
+ (deposit-field newbyte bytespec integer))
+
+(defun %ldb (size posn integer)
+ (logand (ash integer (- posn))
+ (1- (ash 1 size))))
+
+(defun %mask-field (size posn integer)
+ (logand integer (ash (1- (ash 1 size)) posn)))
+
+(defun %dpb (newbyte size posn integer)
+ (let ((mask (1- (ash 1 size))))
+ (logior (logand integer (lognot (ash mask posn)))
+ (ash (logand newbyte mask) posn))))
+
+(defun %deposit-field (newbyte size posn integer)
+ (let ((mask (ash (ldb (byte size 0) -1) posn)))
+ (logior (logand newbyte mask)
+ (logand integer (lognot mask)))))
+\f
+;;;; BOOLE
+
+;;; The boole function dispaches to any logic operation depending on
+;;; the value of a variable. Presently, legal selector values are [0..15].
+;;; boole is open coded for calls with a constant selector. or with calls
+;;; using any of the constants declared below.
+
+(defconstant boole-clr 0
+ #!+sb-doc
+ "Boole function op, makes BOOLE return 0.")
+
+(defconstant boole-set 1
+ #!+sb-doc
+ "Boole function op, makes BOOLE return -1.")
+
+(defconstant boole-1 2
+ #!+sb-doc
+ "Boole function op, makes BOOLE return integer1.")
+
+(defconstant boole-2 3
+ #!+sb-doc
+ "Boole function op, makes BOOLE return integer2.")
+
+(defconstant boole-c1 4
+ #!+sb-doc
+ "Boole function op, makes BOOLE return complement of integer1.")
+
+(defconstant boole-c2 5
+ #!+sb-doc
+ "Boole function op, makes BOOLE return complement of integer2.")
+
+(defconstant boole-and 6
+ #!+sb-doc
+ "Boole function op, makes BOOLE return logand of integer1 and integer2.")
+
+(defconstant boole-ior 7
+ #!+sb-doc
+ "Boole function op, makes BOOLE return logior of integer1 and integer2.")
+
+(defconstant boole-xor 8
+ #!+sb-doc
+ "Boole function op, makes BOOLE return logxor of integer1 and integer2.")
+
+(defconstant boole-eqv 9
+ #!+sb-doc
+ "Boole function op, makes BOOLE return logeqv of integer1 and integer2.")
+
+(defconstant boole-nand 10
+ #!+sb-doc
+ "Boole function op, makes BOOLE return log nand of integer1 and integer2.")
+
+(defconstant boole-nor 11
+ #!+sb-doc
+ "Boole function op, makes BOOLE return lognor of integer1 and integer2.")
+
+(defconstant boole-andc1 12
+ #!+sb-doc
+ "Boole function op, makes BOOLE return logandc1 of integer1 and integer2.")
+
+(defconstant boole-andc2 13
+ #!+sb-doc
+ "Boole function op, makes BOOLE return logandc2 of integer1 and integer2.")
+
+(defconstant boole-orc1 14
+ #!+sb-doc
+ "Boole function op, makes BOOLE return logorc1 of integer1 and integer2.")
+
+(defconstant boole-orc2 15
+ #!+sb-doc
+ "Boole function op, makes BOOLE return logorc2 of integer1 and integer2.")
+
+(defun boole (op integer1 integer2)
+ #!+sb-doc
+ "Bit-wise boolean function on two integers. Function chosen by OP:
+ 0 BOOLE-CLR
+ 1 BOOLE-SET
+ 2 BOOLE-1
+ 3 BOOLE-2
+ 4 BOOLE-C1
+ 5 BOOLE-C2
+ 6 BOOLE-AND
+ 7 BOOLE-IOR
+ 8 BOOLE-XOR
+ 9 BOOLE-EQV
+ 10 BOOLE-NAND
+ 11 BOOLE-NOR
+ 12 BOOLE-ANDC1
+ 13 BOOLE-ANDC2
+ 14 BOOLE-ORC1
+ 15 BOOLE-ORC2"
+ (case op
+ (0 (boole 0 integer1 integer2))
+ (1 (boole 1 integer1 integer2))
+ (2 (boole 2 integer1 integer2))
+ (3 (boole 3 integer1 integer2))
+ (4 (boole 4 integer1 integer2))
+ (5 (boole 5 integer1 integer2))
+ (6 (boole 6 integer1 integer2))
+ (7 (boole 7 integer1 integer2))
+ (8 (boole 8 integer1 integer2))
+ (9 (boole 9 integer1 integer2))
+ (10 (boole 10 integer1 integer2))
+ (11 (boole 11 integer1 integer2))
+ (12 (boole 12 integer1 integer2))
+ (13 (boole 13 integer1 integer2))
+ (14 (boole 14 integer1 integer2))
+ (15 (boole 15 integer1 integer2))
+ (t (error "~S is not of type (mod 16)." op))))
+\f
+;;;; GCD and LCM
+
+(defun gcd (&rest numbers)
+ #!+sb-doc
+ "Returns the greatest common divisor of the arguments, which must be
+ integers. Gcd with no arguments is defined to be 0."
+ (cond ((null numbers) 0)
+ ((null (cdr numbers)) (abs (the integer (car numbers))))
+ (t
+ (do ((gcd (the integer (car numbers))
+ (gcd gcd (the integer (car rest))))
+ (rest (cdr numbers) (cdr rest)))
+ ((null rest) gcd)
+ (declare (integer gcd)
+ (list rest))))))
+
+(defun lcm (&rest numbers)
+ #!+sb-doc
+ "Returns the least common multiple of one or more integers. LCM of no
+ arguments is defined to be 1."
+ (cond ((null numbers) 1)
+ ((null (cdr numbers)) (abs (the integer (car numbers))))
+ (t
+ (do ((lcm (the integer (car numbers))
+ (lcm lcm (the integer (car rest))))
+ (rest (cdr numbers) (cdr rest)))
+ ((null rest) lcm)
+ (declare (integer lcm) (list rest))))))
+
+(defun two-arg-lcm (n m)
+ (declare (integer n m))
+ (* (truncate (max n m) (gcd n m)) (min n m)))
+
+;;; Do the GCD of two integer arguments. With fixnum arguments, we use the
+;;; binary GCD algorithm from Knuth's seminumerical algorithms (slightly
+;;; structurified), otherwise we call BIGNUM-GCD. We pick off the special case
+;;; of 0 before the dispatch so that the bignum code doesn't have to worry
+;;; about "small bignum" zeros.
+(defun two-arg-gcd (u v)
+ (cond ((eql u 0) v)
+ ((eql v 0) u)
+ (t
+ (number-dispatch ((u integer) (v integer))
+ ((fixnum fixnum)
+ (locally
+ (declare (optimize (speed 3) (safety 0)))
+ (do ((k 0 (1+ k))
+ (u (abs u) (ash u -1))
+ (v (abs v) (ash v -1)))
+ ((oddp (logior u v))
+ (do ((temp (if (oddp u) (- v) (ash u -1))
+ (ash temp -1)))
+ (nil)
+ (declare (fixnum temp))
+ (when (oddp temp)
+ (if (plusp temp)
+ (setq u temp)
+ (setq v (- temp)))
+ (setq temp (- u v))
+ (when (zerop temp)
+ (let ((res (ash u k)))
+ (declare (type (signed-byte 31) res)
+ (optimize (inhibit-warnings 3)))
+ (return res))))))
+ (declare (type (mod 30) k)
+ (type (signed-byte 31) u v)))))
+ ((bignum bignum)
+ (bignum-gcd u v))
+ ((bignum fixnum)
+ (bignum-gcd u (make-small-bignum v)))
+ ((fixnum bignum)
+ (bignum-gcd (make-small-bignum u) v))))))
+\f
+;;; From discussion on comp.lang.lisp and Akira Kurihara.
+(defun isqrt (n)
+ #!+sb-doc
+ "Returns the root of the nearest integer less than n which is a perfect
+ square."
+ (declare (type unsigned-byte n) (values unsigned-byte))
+ ;; theoretically (> n 7), i.e., n-len-quarter > 0
+ (if (and (fixnump n) (<= n 24))
+ (cond ((> n 15) 4)
+ ((> n 8) 3)
+ ((> n 3) 2)
+ ((> n 0) 1)
+ (t 0))
+ (let* ((n-len-quarter (ash (integer-length n) -2))
+ (n-half (ash n (- (ash n-len-quarter 1))))
+ (n-half-isqrt (isqrt n-half))
+ (init-value (ash (1+ n-half-isqrt) n-len-quarter)))
+ (loop
+ (let ((iterated-value
+ (ash (+ init-value (truncate n init-value)) -1)))
+ (unless (< iterated-value init-value)
+ (return init-value))
+ (setq init-value iterated-value))))))
+\f
+;;;; miscellaneous number predicates
+
+(macrolet ((def-frob (name doc)
+ `(defun ,name (number) ,doc (,name number))))
+ (def-frob zerop "Returns T if number = 0, NIL otherwise.")
+ (def-frob plusp "Returns T if number > 0, NIL otherwise.")
+ (def-frob minusp "Returns T if number < 0, NIL otherwise.")
+ (def-frob oddp "Returns T if number is odd, NIL otherwise.")
+ (def-frob evenp "Returns T if number is even, NIL otherwise."))
--- /dev/null
+;;;; PACKAGEs and stuff like that
+;;;;
+;;;; Note: The code in this file signals many correctable errors. This
+;;;; is not just an arbitrary aesthetic decision on the part of the
+;;;; implementor -- many of these are specified by ANSI 11.1.1.2.5,
+;;;; "Prevention of Name Conflicts in Packages":
+;;;; Within one package, any particular name can refer to at most one
+;;;; symbol. A name conflict is said to occur when there would be more
+;;;; than one candidate symbol. Any time a name conflict is about to
+;;;; occur, a correctable error is signaled.
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!IMPL")
+
+(file-comment
+ "$Header$")
+
+(!begin-collecting-cold-init-forms)
+
+(!cold-init-forms
+ (/show0 "entering !PACKAGE-COLD-INIT"))
+
+(defvar *default-package-use-list*)
+(!cold-init-forms
+ (setf *default-package-use-list* '("COMMON-LISP")))
+#!+sb-doc
+(setf (fdocumentation '*default-package-use-list* 'variable)
+ "the list of packages to use by default when no :USE argument is supplied
+ to MAKE-PACKAGE or other package creation forms")
+\f
+;;;; PACKAGE-HASHTABLE stuff
+
+(def!method print-object ((table package-hashtable) stream)
+ (declare (type stream stream))
+ (print-unreadable-object (table stream :type t)
+ (format stream
+ ":SIZE ~S :FREE ~S :DELETED ~S"
+ (package-hashtable-size table)
+ (package-hashtable-free table)
+ (package-hashtable-deleted table))))
+
+;;; the maximum density we allow in a package hashtable
+(defconstant package-rehash-threshold 0.75)
+
+;;; Make a package hashtable having a prime number of entries at least
+;;; as great as (/ SIZE PACKAGE-REHASH-THRESHOLD). If RES is supplied,
+;;; then it is destructively modified to produce the result. This is
+;;; useful when changing the size, since there are many pointers to
+;;; the hashtable.
+(defun make-or-remake-package-hashtable (size
+ &optional
+ (res (%make-package-hashtable)))
+ (do ((n (logior (truncate size package-rehash-threshold) 1)
+ (+ n 2)))
+ ((positive-primep n)
+ (setf (package-hashtable-table res)
+ (make-array n))
+ (setf (package-hashtable-hash res)
+ (make-array n
+ :element-type '(unsigned-byte 8)
+ :initial-element 0))
+ (let ((size (truncate (* n package-rehash-threshold))))
+ (setf (package-hashtable-size res) size)
+ (setf (package-hashtable-free res) size))
+ (setf (package-hashtable-deleted res) 0)
+ res)
+ (declare (type fixnum n))))
+\f
+;;;; miscellaneous PACKAGE operations
+
+(def!method print-object ((package package) stream)
+ (let ((name (package-%name package)))
+ (if name
+ (print-unreadable-object (package stream :type t)
+ (prin1 name stream))
+ (print-unreadable-object (package stream :type t :identity t)
+ (write-string "(deleted)" stream)))))
+
+;;; ANSI says (in the definition of DELETE-PACKAGE) that these, and
+;;; most other operations, are unspecified for deleted packages. We
+;;; just do the easy thing and signal errors in that case.
+(macrolet ((def-frob (ext real)
+ `(defun ,ext (x) (,real (find-undeleted-package-or-lose x)))))
+ (def-frob package-nicknames package-%nicknames)
+ (def-frob package-use-list package-%use-list)
+ (def-frob package-used-by-list package-%used-by-list)
+ (def-frob package-shadowing-symbols package-%shadowing-symbols))
+
+(flet ((stuff (table)
+ (let ((size (the fixnum
+ (- (the fixnum (package-hashtable-size table))
+ (the fixnum
+ (package-hashtable-deleted table))))))
+ (declare (fixnum size))
+ (values (the fixnum
+ (- size
+ (the fixnum
+ (package-hashtable-free table))))
+ size))))
+ (defun package-internal-symbol-count (package)
+ (stuff (package-internal-symbols package)))
+ (defun package-external-symbol-count (package)
+ (stuff (package-external-symbols package))))
+\f
+(defvar *package* () ; actually initialized in cold load
+ #!+sb-doc "the current package")
+;;; FIXME: should be declared of type PACKAGE, with no NIL init form,
+;;; after I get around to cleaning up DOCUMENTATION
+;;;
+;;; FIXME: Setting *PACKAGE* to a non-PACKAGE value (even a plausible
+;;; one, like :CL-USER) makes the system fairly unusable, without
+;;; generating useful diagnostics. Is it possible to handle this
+;;; situation more gracefully by replacing references to *PACKAGE*
+;;; with references to (DEFAULT-PACKAGE) and implementing
+;;; DEFAULT-PACKAGE so that it checks for the PACKAGEness of *PACKAGE*
+;;; and helps the user to fix any problem (perhaps going through
+;;; CERROR)?
+;;; Error: An attempt was made to use the *PACKAGE* variable when it was
+;;; bound to the illegal (non-PACKAGE) value ~S. This is
+;;; forbidden by the ANSI specification and could have made
+;;; the system very confused. The *PACKAGE* variable has been
+;;; temporarily reset to #<PACKAGE "COMMON-LISP-USER">. How
+;;; would you like to proceed?
+;;; NAMED Set *PACKAGE* to ~S (which is the package which is
+;;; named by the old illegal ~S value of *PACKAGE*, and
+;;; is thus very likely the intended value) and continue
+;;; without signalling an error.
+;;; ERROR Leave *PACKAGE* set to #<PACKAGE "COMMON-LISP-USER">
+;;; and signal PACKAGE-ERROR to the code which tried to
+;;; use the old illegal value of *PACKAGE*.
+;;; CONTINUE Leave *PACKAGE* set to #<PACKAGE "COMMON-LISP-USER">
+;;; and continue without signalling an error.
+
+;;; a map from package names to packages
+(defvar *package-names*)
+(declaim (type hash-table *package-names*))
+(!cold-init-forms
+ (setf *package-names* (make-hash-table :test 'equal)))
+
+;;; This magical variable is T during initialization so that
+;;; USE-PACKAGE's of packages that don't yet exist quietly win. Such
+;;; packages are thrown onto the list *DEFERRED-USE-PACKAGES* so that
+;;; this can be fixed up later.
+;;;
+;;; FIXME: This could be cleaned up the same way I do it in my package
+;;; hacking when setting up the cross-compiler. Then we wouldn't have
+;;; this extraneous global variable and annoying runtime tests on
+;;; package operations. (*DEFERRED-USE-PACKAGES* would also go away.)
+(defvar *in-package-init*)
+
+;;; pending USE-PACKAGE arguments saved up while *IN-PACKAGE-INIT* is true
+(defvar *!deferred-use-packages*)
+(!cold-init-forms
+ (setf *!deferred-use-packages* nil))
+
+;;; FIXME: I rewrote this. Test it and the stuff that calls it.
+(defun find-package (package-designator)
+ (flet ((find-package-from-string (string)
+ (declare (type string string))
+ (values (gethash string *package-names*))))
+ (declare (inline find-package-from-string))
+ (typecase package-designator
+ (package package-designator)
+ (symbol (find-package-from-string (symbol-name package-designator)))
+ (string (find-package-from-string package-designator))
+ (character (find-package-from-string (string package-designator)))
+ (t (error 'type-error
+ :datum package-designator
+ :expected-type '(or character package string symbol))))))
+
+;;; Return a list of packages given a package designator or list of
+;;; package designators, or die trying.
+(defun package-listify (thing)
+ (let ((res ()))
+ (dolist (thing (if (listp thing) thing (list thing)) res)
+ (push (find-undeleted-package-or-lose thing) res))))
+
+;;; Make a package name into a simple-string.
+(defun package-namify (n)
+ (stringify-name n "package"))
+
+;;; ANSI specifies (in the definition of DELETE-PACKAGE) that PACKAGE-NAME
+;;; returns NIL (not an error) for a deleted package, so this is a special
+;;; case where we want to use bare %FIND-PACKAGE-OR-LOSE instead of
+;;; FIND-UNDELETED-PACKAGE-OR-LOSE.
+(defun package-name (package-designator)
+ (package-%name (%find-package-or-lose package-designator)))
+\f
+;;;; operations on package hashtables
+
+;;; Compute a number from the sxhash of the pname and the length which
+;;; must be between 2 and 255.
+(defmacro entry-hash (length sxhash)
+ `(the fixnum
+ (+ (the fixnum
+ (rem (the fixnum
+ (logxor ,length
+ ,sxhash
+ (the fixnum (ash ,sxhash -8))
+ (the fixnum (ash ,sxhash -16))
+ (the fixnum (ash ,sxhash -19))))
+ 254))
+ 2)))
+;;; FIXME: should be wrapped in EVAL-WHEN (COMPILE EXECUTE)
+
+;;; Add a symbol to a package hashtable. The symbol is assumed
+;;; not to be present.
+(defun add-symbol (table symbol)
+ (let* ((vec (package-hashtable-table table))
+ (hash (package-hashtable-hash table))
+ (len (length vec))
+ (sxhash (%sxhash-simple-string (symbol-name symbol)))
+ (h2 (the fixnum (1+ (the fixnum (rem sxhash
+ (the fixnum (- len 2))))))))
+ (declare (simple-vector vec)
+ (type (simple-array (unsigned-byte 8)) hash)
+ (fixnum len sxhash h2))
+ (cond ((zerop (the fixnum (package-hashtable-free table)))
+ (make-or-remake-package-hashtable (* (package-hashtable-size table)
+ 2)
+ table)
+ (add-symbol table symbol)
+ (dotimes (i len)
+ (declare (fixnum i))
+ (when (> (the fixnum (aref hash i)) 1)
+ (add-symbol table (svref vec i)))))
+ (t
+ (do ((i (rem sxhash len) (rem (+ i h2) len)))
+ ((< (the fixnum (aref hash i)) 2)
+ (if (zerop (the fixnum (aref hash i)))
+ (decf (the fixnum (package-hashtable-free table)))
+ (decf (the fixnum (package-hashtable-deleted table))))
+ (setf (svref vec i) symbol)
+ (setf (aref hash i)
+ (entry-hash (length (the simple-string
+ (symbol-name symbol)))
+ sxhash)))
+ (declare (fixnum i)))))))
+
+;;; Find where the symbol named String is stored in Table. Index-Var
+;;; is bound to the index, or NIL if it is not present. Symbol-Var
+;;; is bound to the symbol. Length and Hash are the length and sxhash
+;;; of String. Entry-Hash is the entry-hash of the string and length.
+(defmacro with-symbol ((index-var symbol-var table string length sxhash
+ entry-hash)
+ &body forms)
+ (let ((vec (gensym)) (hash (gensym)) (len (gensym)) (h2 (gensym))
+ (name (gensym)) (name-len (gensym)) (ehash (gensym)))
+ `(let* ((,vec (package-hashtable-table ,table))
+ (,hash (package-hashtable-hash ,table))
+ (,len (length ,vec))
+ (,h2 (1+ (the index (rem (the index ,sxhash)
+ (the index (- ,len 2)))))))
+ (declare (type (simple-array (unsigned-byte 8) (*)) ,hash)
+ (simple-vector ,vec)
+ (type index ,len ,h2))
+ (prog ((,index-var (rem (the index ,sxhash) ,len))
+ ,symbol-var ,ehash)
+ (declare (type (or index null) ,index-var))
+ LOOP
+ (setq ,ehash (aref ,hash ,index-var))
+ (cond ((eql ,ehash ,entry-hash)
+ (setq ,symbol-var (svref ,vec ,index-var))
+ (let* ((,name (symbol-name ,symbol-var))
+ (,name-len (length ,name)))
+ (declare (simple-string ,name)
+ (type index ,name-len))
+ (when (and (= ,name-len ,length)
+ (string= ,string ,name
+ :end1 ,length
+ :end2 ,name-len))
+ (go DOIT))))
+ ((zerop ,ehash)
+ (setq ,index-var nil)
+ (go DOIT)))
+ (setq ,index-var (+ ,index-var ,h2))
+ (when (>= ,index-var ,len)
+ (setq ,index-var (- ,index-var ,len)))
+ (go LOOP)
+ DOIT
+ (return (progn ,@forms))))))
+
+;;; Delete the entry for String in Table. The entry must exist.
+(defun nuke-symbol (table string)
+ (declare (simple-string string))
+ (let* ((length (length string))
+ (hash (%sxhash-simple-string string))
+ (ehash (entry-hash length hash)))
+ (declare (type index length hash))
+ (with-symbol (index symbol table string length hash ehash)
+ (setf (aref (package-hashtable-hash table) index) 1)
+ (setf (aref (package-hashtable-table table) index) nil)
+ (incf (package-hashtable-deleted table)))))
+\f
+;;; Enter any new Nicknames for Package into *package-names*.
+;;; If there is a conflict then give the user a chance to do
+;;; something about it.
+(defun enter-new-nicknames (package nicknames)
+ (check-type nicknames list)
+ (dolist (n nicknames)
+ (let* ((n (package-namify n))
+ (found (gethash n *package-names*)))
+ (cond ((not found)
+ (setf (gethash n *package-names*) package)
+ (push n (package-%nicknames package)))
+ ((eq found package))
+ ((string= (the string (package-%name found)) n)
+ ;; FIXME: This and the next error needn't have restarts.
+ (with-simple-restart (continue "Ignore this nickname.")
+ (error 'simple-package-error
+ :package package
+ :format-control "~S is a package name, so it cannot be a nickname for ~S."
+ :format-arguments (list n (package-%name package)))))
+ (t
+ (with-simple-restart (continue "Redefine this nickname.")
+ (error 'simple-package-error
+ :package package
+ :format-control "~S is already a nickname for ~S."
+ :format-arguments (list n (package-%name found))))
+ (setf (gethash n *package-names*) package)
+ (push n (package-%nicknames package)))))))
+
+(defun make-package (name &key
+ (use *default-package-use-list*)
+ nicknames
+ (internal-symbols 10)
+ (external-symbols 10))
+ #!+sb-doc
+ "Makes a new package having the specified Name and Nicknames. The
+ package will inherit all external symbols from each package in
+ the use list. :Internal-Symbols and :External-Symbols are
+ estimates for the number of internal and external symbols which
+ will ultimately be present in the package."
+
+ ;; Check for package name conflicts in name and nicknames, then
+ ;; make the package.
+ (when (find-package name)
+ ;; ANSI specifies that this error is correctable.
+ (cerror "Leave existing package alone."
+ "A package named ~S already exists" name))
+ (let* ((name (package-namify name))
+ (package (internal-make-package
+ :%name name
+ :internal-symbols (make-or-remake-package-hashtable
+ internal-symbols)
+ :external-symbols (make-or-remake-package-hashtable
+ external-symbols))))
+
+ ;; Do a USE-PACKAGE for each thing in the USE list so that checking for
+ ;; conflicting exports among used packages is done.
+ (if *in-package-init*
+ (push (list use package) *!deferred-use-packages*)
+ (use-package use package))
+
+ ;; FIXME: ENTER-NEW-NICKNAMES can fail (ERROR) if nicknames are illegal,
+ ;; which would leave us with possibly-bad side effects from the earlier
+ ;; USE-PACKAGE (e.g. this package on the used-by lists of other packages,
+ ;; but not in *PACKAGE-NAMES*, and possibly import side effects too?).
+ ;; Perhaps this can be solved by just moving ENTER-NEW-NICKNAMES before
+ ;; USE-PACKAGE, but I need to check what kinds of errors can be caused by
+ ;; USE-PACKAGE, too.
+ (enter-new-nicknames package nicknames)
+ (setf (gethash name *package-names*) package)))
+
+;;; Change the name if we can, blast any old nicknames and then
+;;; add in any new ones.
+;;;
+;;; FIXME: ANSI claims that NAME is a package designator (not just a
+;;; string designator -- weird). Thus, NAME could
+;;; be a package instead of a string. Presumably then we should not change
+;;; the package name if NAME is the same package that's referred to by PACKAGE.
+;;; If it's a *different* package, we should probably signal an error.
+;;; (perhaps (ERROR 'ANSI-WEIRDNESS ..):-)
+(defun rename-package (package name &optional (nicknames ()))
+ #!+sb-doc
+ "Changes the name and nicknames for a package."
+ (let* ((package (find-undeleted-package-or-lose package))
+ (name (string name))
+ (found (find-package name)))
+ (unless (or (not found) (eq found package))
+ (error "A package named ~S already exists." name))
+ (remhash (package-%name package) *package-names*)
+ (dolist (n (package-%nicknames package))
+ (remhash n *package-names*))
+ (setf (package-%name package) name)
+ (setf (gethash name *package-names*) package)
+ (setf (package-%nicknames package) ())
+ (enter-new-nicknames package nicknames)
+ package))
+
+(defun delete-package (package-or-name)
+ #!+sb-doc
+ "Delete the package-or-name from the package system data structures."
+ (let ((package (if (packagep package-or-name)
+ package-or-name
+ (find-package package-or-name))))
+ (cond ((not package)
+ ;; This continuable error is required by ANSI.
+ (with-simple-restart (continue "Return NIL")
+ (error 'simple-package-error
+ :package package-or-name
+ :format-control "There is no package named ~S."
+ :format-arguments (list package-or-name))))
+ ((not (package-name package)) ; already deleted
+ nil)
+ (t
+ (let ((use-list (package-used-by-list package)))
+ (when use-list
+ ;; This continuable error is specified by ANSI.
+ (with-simple-restart
+ (continue "Remove dependency in other packages.")
+ (error 'simple-package-error
+ :package package
+ :format-control
+ "Package ~S is used by package(s):~% ~S"
+ :format-arguments
+ (list (package-name package)
+ (mapcar #'package-name use-list))))
+ (dolist (p use-list)
+ (unuse-package package p))))
+ (dolist (used (package-use-list package))
+ (unuse-package used package))
+ (do-symbols (sym package)
+ (unintern sym package))
+ (remhash (package-name package) *package-names*)
+ (dolist (nick (package-nicknames package))
+ (remhash nick *package-names*))
+ (setf (package-%name package) nil
+ ;; Setting PACKAGE-%NAME to NIL is required in order to
+ ;; make PACKAGE-NAME return NIL for a deleted package as
+ ;; ANSI requires. Setting the other slots to NIL
+ ;; and blowing away the PACKAGE-HASHTABLES is just done
+ ;; for tidiness and to help the GC.
+ (package-%nicknames package) nil
+ (package-%use-list package) nil
+ (package-tables package) nil
+ (package-%shadowing-symbols package) nil
+ (package-internal-symbols package)
+ (make-or-remake-package-hashtable 0)
+ (package-external-symbols package)
+ (make-or-remake-package-hashtable 0))
+ t))))
+
+(defun list-all-packages ()
+ #!+sb-doc
+ "Returns a list of all existing packages."
+ (let ((res ()))
+ (maphash #'(lambda (k v)
+ (declare (ignore k))
+ (pushnew v res))
+ *package-names*)
+ res))
+\f
+(defun intern (name &optional (package *package*))
+ #!+sb-doc
+ "Returns a symbol having the specified name, creating it if necessary."
+ ;; We just simple-stringify the name and call INTERN*, where the real
+ ;; logic is.
+ (let ((name (if (simple-string-p name)
+ name
+ (coerce name 'simple-string))))
+ (declare (simple-string name))
+ (intern* name
+ (length name)
+ (find-undeleted-package-or-lose package))))
+
+(defun find-symbol (name &optional (package *package*))
+ #!+sb-doc
+ "Returns the symbol named String in Package. If such a symbol is found
+ then the second value is :internal, :external or :inherited to indicate
+ how the symbol is accessible. If no symbol is found then both values
+ are NIL."
+ ;; We just simple-stringify the name and call FIND-SYMBOL*, where the
+ ;; real logic is.
+ (let ((name (if (simple-string-p name) name (coerce name 'simple-string))))
+ (declare (simple-string name))
+ (find-symbol* name
+ (length name)
+ (find-undeleted-package-or-lose package))))
+
+;;; If the symbol named by the first LENGTH characters of NAME doesn't exist,
+;;; then create it, special-casing the keyword package.
+(defun intern* (name length package)
+ (declare (simple-string name))
+ (multiple-value-bind (symbol where) (find-symbol* name length package)
+ (if where
+ (values symbol where)
+ (let ((symbol (make-symbol (subseq name 0 length))))
+ (%set-symbol-package symbol package)
+ (cond ((eq package *keyword-package*)
+ (add-symbol (package-external-symbols package) symbol)
+ (%set-symbol-value symbol symbol))
+ (t
+ (add-symbol (package-internal-symbols package) symbol)))
+ (values symbol nil)))))
+
+;;; Check internal and external symbols, then scan down the list
+;;; of hashtables for inherited symbols. When an inherited symbol
+;;; is found pull that table to the beginning of the list.
+(defun find-symbol* (string length package)
+ (declare (simple-string string)
+ (type index length))
+ (let* ((hash (%sxhash-simple-substring string length))
+ (ehash (entry-hash length hash)))
+ (declare (type index hash ehash))
+ (with-symbol (found symbol (package-internal-symbols package)
+ string length hash ehash)
+ (when found
+ (return-from find-symbol* (values symbol :internal))))
+ (with-symbol (found symbol (package-external-symbols package)
+ string length hash ehash)
+ (when found
+ (return-from find-symbol* (values symbol :external))))
+ (let ((head (package-tables package)))
+ (do ((prev head table)
+ (table (cdr head) (cdr table)))
+ ((null table) (values nil nil))
+ (with-symbol (found symbol (car table) string length hash ehash)
+ (when found
+ (unless (eq prev head)
+ (shiftf (cdr prev) (cdr table) (cdr head) table))
+ (return-from find-symbol* (values symbol :inherited))))))))
+
+;;; Similar to Find-Symbol, but only looks for an external symbol.
+;;; This is used for fast name-conflict checking in this file and symbol
+;;; printing in the printer.
+(defun find-external-symbol (string package)
+ (declare (simple-string string))
+ (let* ((length (length string))
+ (hash (%sxhash-simple-string string))
+ (ehash (entry-hash length hash)))
+ (declare (type index length hash))
+ (with-symbol (found symbol (package-external-symbols package)
+ string length hash ehash)
+ (values symbol found))))
+\f
+;;; If we are uninterning a shadowing symbol, then a name conflict can
+;;; result, otherwise just nuke the symbol.
+(defun unintern (symbol &optional (package *package*))
+ #!+sb-doc
+ "Makes Symbol no longer present in Package. If Symbol was present
+ then T is returned, otherwise NIL. If Package is Symbol's home
+ package, then it is made uninterned."
+ (let* ((package (find-undeleted-package-or-lose package))
+ (name (symbol-name symbol))
+ (shadowing-symbols (package-%shadowing-symbols package)))
+ (declare (list shadowing-symbols) (simple-string name))
+
+ ;; If a name conflict is revealed, give use a chance to shadowing-import
+ ;; one of the accessible symbols.
+ (when (member symbol shadowing-symbols)
+ (let ((cset ()))
+ (dolist (p (package-%use-list package))
+ (multiple-value-bind (s w) (find-external-symbol name p)
+ (when w (pushnew s cset))))
+ (when (cdr cset)
+ (loop
+ (cerror
+ "Prompt for a symbol to SHADOWING-IMPORT."
+ "Uninterning symbol ~S causes name conflict among these symbols:~%~S"
+ symbol cset)
+ (write-string "Symbol to shadowing-import: " *query-io*)
+ (let ((sym (read *query-io*)))
+ (cond
+ ((not (symbolp sym))
+ (format *query-io* "~S is not a symbol."))
+ ((not (member sym cset))
+ (format *query-io* "~S is not one of the conflicting symbols."))
+ (t
+ (shadowing-import sym package)
+ (return-from unintern t)))))))
+ (setf (package-%shadowing-symbols package)
+ (remove symbol shadowing-symbols)))
+
+ (multiple-value-bind (s w) (find-symbol name package)
+ (declare (ignore s))
+ (cond ((or (eq w :internal) (eq w :external))
+ (nuke-symbol (if (eq w :internal)
+ (package-internal-symbols package)
+ (package-external-symbols package))
+ name)
+ (if (eq (symbol-package symbol) package)
+ (%set-symbol-package symbol nil))
+ t)
+ (t nil)))))
+\f
+;;; Take a symbol-or-list-of-symbols and return a list, checking types.
+(defun symbol-listify (thing)
+ (cond ((listp thing)
+ (dolist (s thing)
+ (unless (symbolp s) (error "~S is not a symbol." s)))
+ thing)
+ ((symbolp thing) (list thing))
+ (t
+ (error "~S is neither a symbol nor a list of symbols." thing))))
+
+;;; Like UNINTERN, but if symbol is inherited chases down the package
+;;; it is inherited from and uninterns it there. Used for
+;;; name-conflict resolution. Shadowing symbols are not uninterned
+;;; since they do not cause conflicts.
+(defun moby-unintern (symbol package)
+ (unless (member symbol (package-%shadowing-symbols package))
+ (or (unintern symbol package)
+ (let ((name (symbol-name symbol)))
+ (multiple-value-bind (s w) (find-symbol name package)
+ (declare (ignore s))
+ (when (eq w :inherited)
+ (dolist (q (package-%use-list package))
+ (multiple-value-bind (u x) (find-external-symbol name q)
+ (declare (ignore u))
+ (when x
+ (unintern symbol q)
+ (return t))))))))))
+\f
+(defun export (symbols &optional (package *package*))
+ #!+sb-doc
+ "Exports Symbols from Package, checking that no name conflicts result."
+ (let ((package (find-undeleted-package-or-lose package))
+ (syms ()))
+ ;; Punt any symbols that are already external.
+ (dolist (sym (symbol-listify symbols))
+ (multiple-value-bind (s w)
+ (find-external-symbol (symbol-name sym) package)
+ (declare (ignore s))
+ (unless (or w (member sym syms))
+ (push sym syms))))
+ ;; Find symbols and packages with conflicts.
+ (let ((used-by (package-%used-by-list package))
+ (cpackages ())
+ (cset ()))
+ (dolist (sym syms)
+ (let ((name (symbol-name sym)))
+ (dolist (p used-by)
+ (multiple-value-bind (s w) (find-symbol name p)
+ (when (and w (not (eq s sym))
+ (not (member s (package-%shadowing-symbols p))))
+ (pushnew sym cset)
+ (pushnew p cpackages))))))
+ (when cset
+ (restart-case
+ (error
+ 'simple-package-error
+ :package package
+ :format-control
+ "Exporting these symbols from the ~A package:~%~S~%~
+ results in name conflicts with these packages:~%~{~A ~}"
+ :format-arguments
+ (list (package-%name package) cset
+ (mapcar #'package-%name cpackages)))
+ (unintern-conflicting-symbols ()
+ :report "Unintern conflicting symbols."
+ (dolist (p cpackages)
+ (dolist (sym cset)
+ (moby-unintern sym p))))
+ (skip-exporting-these-symbols ()
+ :report "Skip exporting conflicting symbols."
+ (setq syms (nset-difference syms cset))))))
+
+ ;; Check that all symbols are accessible. If not, ask to import them.
+ (let ((missing ())
+ (imports ()))
+ (dolist (sym syms)
+ (multiple-value-bind (s w) (find-symbol (symbol-name sym) package)
+ (cond ((not (and w (eq s sym)))
+ (push sym missing))
+ ((eq w :inherited)
+ (push sym imports)))))
+ (when missing
+ (with-simple-restart
+ (continue "Import these symbols into the ~A package."
+ (package-%name package))
+ (error 'simple-package-error
+ :package package
+ :format-control
+ "These symbols are not accessible in the ~A package:~%~S"
+ :format-arguments
+ (list (package-%name package) missing)))
+ (import missing package))
+ (import imports package))
+
+ ;; And now, three pages later, we export the suckers.
+ (let ((internal (package-internal-symbols package))
+ (external (package-external-symbols package)))
+ (dolist (sym syms)
+ (nuke-symbol internal (symbol-name sym))
+ (add-symbol external sym)))
+ t))
+\f
+;;; Check that all symbols are accessible, then move from external to internal.
+(defun unexport (symbols &optional (package *package*))
+ #!+sb-doc
+ "Makes Symbols no longer exported from Package."
+ (let ((package (find-undeleted-package-or-lose package))
+ (syms ()))
+ (dolist (sym (symbol-listify symbols))
+ (multiple-value-bind (s w) (find-symbol (symbol-name sym) package)
+ (cond ((or (not w) (not (eq s sym)))
+ (error 'simple-package-error
+ :package package
+ :format-control "~S is not accessible in the ~A package."
+ :format-arguments (list sym (package-%name package))))
+ ((eq w :external) (pushnew sym syms)))))
+
+ (let ((internal (package-internal-symbols package))
+ (external (package-external-symbols package)))
+ (dolist (sym syms)
+ (add-symbol internal sym)
+ (nuke-symbol external (symbol-name sym))))
+ t))
+\f
+;;; Check for name conflict caused by the import and let the user
+;;; shadowing-import if there is.
+(defun import (symbols &optional (package *package*))
+ #!+sb-doc
+ "Make Symbols accessible as internal symbols in Package. If a symbol
+ is already accessible then it has no effect. If a name conflict
+ would result from the importation, then a correctable error is signalled."
+ (let ((package (find-undeleted-package-or-lose package))
+ (symbols (symbol-listify symbols))
+ (syms ())
+ (cset ()))
+ (dolist (sym symbols)
+ (multiple-value-bind (s w) (find-symbol (symbol-name sym) package)
+ (cond ((not w)
+ (let ((found (member sym syms :test #'string=)))
+ (if found
+ (when (not (eq (car found) sym))
+ (push sym cset))
+ (push sym syms))))
+ ((not (eq s sym)) (push sym cset))
+ ((eq w :inherited) (push sym syms)))))
+ (when cset
+ ;; ANSI specifies that this error is correctable.
+ (with-simple-restart
+ (continue "Import these symbols with Shadowing-Import.")
+ (error 'simple-package-error
+ :package package
+ :format-control
+ "Importing these symbols into the ~A package ~
+ causes a name conflict:~%~S"
+ :format-arguments (list (package-%name package) cset))))
+ ;; Add the new symbols to the internal hashtable.
+ (let ((internal (package-internal-symbols package)))
+ (dolist (sym syms)
+ (add-symbol internal sym)))
+ ;; If any of the symbols are uninterned, make them be owned by Package.
+ (dolist (sym symbols)
+ (unless (symbol-package sym) (%set-symbol-package sym package)))
+ (shadowing-import cset package)))
+\f
+;;; If a conflicting symbol is present, unintern it, otherwise just
+;;; stick the symbol in.
+(defun shadowing-import (symbols &optional (package *package*))
+ #!+sb-doc
+ "Import Symbols into package, disregarding any name conflict. If
+ a symbol of the same name is present, then it is uninterned.
+ The symbols are added to the Package-Shadowing-Symbols."
+ (let* ((package (find-undeleted-package-or-lose package))
+ (internal (package-internal-symbols package)))
+ (dolist (sym (symbol-listify symbols))
+ (multiple-value-bind (s w) (find-symbol (symbol-name sym) package)
+ (unless (and w (not (eq w :inherited)) (eq s sym))
+ (when (or (eq w :internal) (eq w :external))
+ ;; If it was shadowed, we don't want UNINTERN to flame out...
+ (setf (package-%shadowing-symbols package)
+ (remove s (the list (package-%shadowing-symbols package))))
+ (unintern s package))
+ (add-symbol internal sym))
+ (pushnew sym (package-%shadowing-symbols package)))))
+ t)
+
+(defun shadow (symbols &optional (package *package*))
+ #!+sb-doc
+ "Make an internal symbol in Package with the same name as each of the
+ specified symbols, adding the new symbols to the Package-Shadowing-Symbols.
+ If a symbol with the given name is already present in Package, then
+ the existing symbol is placed in the shadowing symbols list if it is
+ not already present."
+ (let* ((package (find-undeleted-package-or-lose package))
+ (internal (package-internal-symbols package)))
+ (dolist (name (mapcar #'string
+ (if (listp symbols) symbols (list symbols))))
+ (multiple-value-bind (s w) (find-symbol name package)
+ (when (or (not w) (eq w :inherited))
+ (setq s (make-symbol name))
+ (%set-symbol-package s package)
+ (add-symbol internal s))
+ (pushnew s (package-%shadowing-symbols package)))))
+ t)
+\f
+;;; Do stuff to use a package, with all kinds of fun name-conflict checking.
+(defun use-package (packages-to-use &optional (package *package*))
+ #!+sb-doc
+ "Add all the Packages-To-Use to the use list for Package so that
+ the external symbols of the used packages are accessible as internal
+ symbols in Package."
+ (let ((packages (package-listify packages-to-use))
+ (package (find-undeleted-package-or-lose package)))
+
+ ;; Loop over each package, USE'ing one at a time...
+ (dolist (pkg packages)
+ (unless (member pkg (package-%use-list package))
+ (let ((cset ())
+ (shadowing-symbols (package-%shadowing-symbols package))
+ (use-list (package-%use-list package)))
+
+ ;; If the number of symbols already accessible is less than the
+ ;; number to be inherited then it is faster to run the test the
+ ;; other way. This is particularly valuable in the case of
+ ;; a new package USEing Lisp.
+ (cond
+ ((< (+ (package-internal-symbol-count package)
+ (package-external-symbol-count package)
+ (let ((res 0))
+ (dolist (p use-list res)
+ (incf res (package-external-symbol-count p)))))
+ (package-external-symbol-count pkg))
+ (do-symbols (sym package)
+ (multiple-value-bind (s w)
+ (find-external-symbol (symbol-name sym) pkg)
+ (when (and w (not (eq s sym))
+ (not (member sym shadowing-symbols)))
+ (push sym cset))))
+ (dolist (p use-list)
+ (do-external-symbols (sym p)
+ (multiple-value-bind (s w)
+ (find-external-symbol (symbol-name sym) pkg)
+ (when (and w (not (eq s sym))
+ (not (member (find-symbol (symbol-name sym)
+ package)
+ shadowing-symbols)))
+ (push sym cset))))))
+ (t
+ (do-external-symbols (sym pkg)
+ (multiple-value-bind (s w)
+ (find-symbol (symbol-name sym) package)
+ (when (and w (not (eq s sym))
+ (not (member s shadowing-symbols)))
+ (push s cset))))))
+
+ (when cset
+ (cerror
+ "Unintern the conflicting symbols in the ~2*~A package."
+ "Use'ing package ~A results in name conflicts for these symbols:~%~S"
+ (package-%name pkg) cset (package-%name package))
+ (dolist (s cset) (moby-unintern s package))))
+
+ (push pkg (package-%use-list package))
+ (push (package-external-symbols pkg) (cdr (package-tables package)))
+ (push package (package-%used-by-list pkg)))))
+ t)
+
+(defun unuse-package (packages-to-unuse &optional (package *package*))
+ #!+sb-doc
+ "Remove Packages-To-Unuse from the use list for Package."
+ (let ((package (find-undeleted-package-or-lose package)))
+ (dolist (p (package-listify packages-to-unuse))
+ (setf (package-%use-list package)
+ (remove p (the list (package-%use-list package))))
+ (setf (package-tables package)
+ (delete (package-external-symbols p)
+ (the list (package-tables package))))
+ (setf (package-%used-by-list p)
+ (remove package (the list (package-%used-by-list p)))))
+ t))
+
+(defun find-all-symbols (string-or-symbol)
+ #!+sb-doc
+ "Return a list of all symbols in the system having the specified name."
+ (let ((string (string string-or-symbol))
+ (res ()))
+ (maphash #'(lambda (k v)
+ (declare (ignore k))
+ (multiple-value-bind (s w) (find-symbol string v)
+ (when w (pushnew s res))))
+ *package-names*)
+ res))
+\f
+;;;; APROPOS and APROPOS-LIST
+
+;;; KLUDGE: All the APROPOS stuff should probably be byte-compiled, since it's
+;;; only likely to be used interactively. -- WHN 19990827
+
+(defun briefly-describe-symbol (symbol)
+ (fresh-line)
+ (prin1 symbol)
+ (when (boundp symbol)
+ (write-string " (bound)"))
+ (when (fboundp symbol)
+ (write-string " (fbound)")))
+
+(defun apropos-list (string-designator &optional package external-only)
+ #!+sb-doc
+ "Like APROPOS, except that it returns a list of the symbols found instead
+ of describing them."
+ (if package
+ (let ((string (stringify-name string-designator "APROPOS search"))
+ (result nil))
+ (do-symbols (symbol package)
+ (when (and (eq (symbol-package symbol) package)
+ (or (not external-only)
+ (eq (find-symbol (symbol-name symbol) package)
+ :external))
+ (search string (symbol-name symbol) :test #'char-equal))
+ (push symbol result)))
+ result)
+ (mapcan (lambda (package)
+ (apropos-list string-designator package external-only))
+ (list-all-packages))))
+
+(defun apropos (string-designator &optional package external-only)
+ #!+sb-doc
+ "Briefly describe all symbols which contain the specified STRING.
+ If PACKAGE is supplied then only describe symbols present in
+ that package. If EXTERNAL-ONLY then only describe
+ external symbols in the specified package."
+ ;; Implementing this in terms of APROPOS-LIST keeps things simple at the cost
+ ;; of some unnecessary consing; and the unnecessary consing shouldn't be an
+ ;; issue, since this function is is only useful interactively anyway, and
+ ;; we can cons and GC a lot faster than the typical user can read..
+ (dolist (symbol (apropos-list string-designator package external-only))
+ (briefly-describe-symbol symbol))
+ (values))
+\f
+;;;; final initialization
+
+;;;; The cold loader (GENESIS) makes the data structure in
+;;;; *!INITIAL-SYMBOLS*. We grovel over it, making the specified
+;;;; packages and interning the symbols. For a description of the
+;;;; format of *!INITIAL-SYMBOLS*, see the GENESIS source.
+
+(defvar *!initial-symbols*)
+
+(!cold-init-forms
+
+ (setq *in-package-init* t)
+
+ (/show0 "about to loop over *!INITIAL-SYMBOLS* to make packages")
+ (dolist (spec *!initial-symbols*)
+ (let* ((pkg (apply #'make-package (first spec)))
+ (internal (package-internal-symbols pkg))
+ (external (package-external-symbols pkg)))
+ (/show0 "back from MAKE-PACKAGE")
+ #!+sb-show (sb!sys:%primitive print (package-name pkg))
+
+ ;; Put internal symbols in the internal hashtable and set package.
+ (dolist (symbol (second spec))
+ (add-symbol internal symbol)
+ (%set-symbol-package symbol pkg))
+
+ ;; External symbols same, only go in external table.
+ (dolist (symbol (third spec))
+ (add-symbol external symbol)
+ (%set-symbol-package symbol pkg))
+
+ ;; Don't set package for imported symbols.
+ (dolist (symbol (fourth spec))
+ (add-symbol internal symbol))
+ (dolist (symbol (fifth spec))
+ (add-symbol external symbol))
+
+ ;; Put shadowing symbols in the shadowing symbols list.
+ (setf (package-%shadowing-symbols pkg) (sixth spec))))
+
+ (/show0 "about to MAKUNBOUND *!INITIAL-SYMBOLS*")
+ (makunbound '*!initial-symbols*) ; (so that it gets GCed)
+
+ ;; Make some other packages that should be around in the cold load. The
+ ;; COMMON-LISP-USER package is required by the ANSI standard, but not
+ ;; completely specified by it, so in the cross-compilation host Lisp it could
+ ;; contain various symbols, USE-PACKAGEs, or nicknames that we don't want in
+ ;; our target SBCL. For that reason, we handle it specially, not dumping the
+ ;; host Lisp version at genesis time..
+ (assert (not (find-package "COMMON-LISP-USER")))
+ ;; ..but instead making our own from scratch here.
+ (/show0 "about to MAKE-PACKAGE COMMON-LISP-USER")
+ (make-package "COMMON-LISP-USER"
+ :nicknames '("CL-USER")
+ :use '("COMMON-LISP"
+ ;; ANSI encourages us to put extension packages in the
+ ;; USE list of COMMON-LISP-USER.
+ "SB!ALIEN" "SB!C-CALL" "SB!DEBUG"
+ "SB!EXT" "SB!GRAY" "SB!PROFILE"))
+
+ ;; Now do the *!DEFERRED-USE-PACKAGES*.
+ (/show0 "about to do *!DEFERRED-USE-PACKAGES*")
+ (dolist (args *!deferred-use-packages*)
+ (apply #'use-package args))
+
+ ;; The Age Of Magic is over, we can behave ANSIly henceforth.
+ (/show0 "about to SETQ *IN-PACKAGE-INIT*")
+ (setq *in-package-init* nil)
+
+ ;; FIXME: These assignments are also done at toplevel in
+ ;; boot-extensions.lisp. They should probably only be done once.
+ (setq *cl-package* (find-package "COMMON-LISP"))
+ (setq *keyword-package* (find-package "KEYWORD"))
+
+ ;; For the kernel core image wizards, set the package to *CL-PACKAGE*.
+ ;;
+ ;; FIXME: We should just set this to (FIND-PACKAGE "COMMON-LISP-USER")
+ ;; once and for all here, instead of setting it once here and resetting
+ ;; it later.
+ (setq *package* *cl-package*))
+\f
+(!cold-init-forms
+ (/show0 "done with !PACKAGE-COLD-INIT"))
+
+(!defun-from-collected-cold-init-forms !package-cold-init)
--- /dev/null
+;;;; machine/filesystem-independent pathname functions
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!IMPL")
+
+(file-comment
+ "$Header$")
+
+#!-sb-fluid (declaim (freeze-type logical-pathname logical-host))
+\f
+;;; host methods
+
+(def!method print-object ((host host) stream)
+ (print-unreadable-object (host stream :type t :identity t)))
+\f
+;;; pathname methods
+
+(def!method print-object ((pathname pathname) stream)
+ (let ((namestring (handler-case (namestring pathname)
+ (error nil))))
+ (if namestring
+ (format stream "#P~S" namestring)
+ ;; FIXME: This code was rewritten and should be tested. (How does
+ ;; control get to this case anyhow? Perhaps we could just punt it?)
+ (print-unreadable-object (pathname stream :type t)
+ (format stream
+ "(with no namestring) :HOST ~S :DEVICE ~S :DIRECTORY ~S ~
+ :NAME ~S :TYPE ~S :VERSION ~S"
+ (%pathname-host pathname)
+ (%pathname-device pathname)
+ (%pathname-directory pathname)
+ (%pathname-name pathname)
+ (%pathname-type pathname)
+ (%pathname-version pathname))))))
+
+(def!method make-load-form ((pathname pathname) &optional environment)
+ (make-load-form-saving-slots pathname :environment environment))
+
+;;; The potential conflict with search-lists requires isolating the printed
+;;; representation to use the i/o macro #.(logical-pathname <path-designator>).
+;;;
+;;; FIXME: We don't use search lists any more, so that comment is stale, right?
+(def!method print-object ((pathname logical-pathname) stream)
+ (let ((namestring (handler-case (namestring pathname)
+ (error nil))))
+ (if namestring
+ (format stream "#.(logical-pathname ~S)" namestring)
+ (print-unreadable-object (pathname stream :type t)
+ (format stream
+ ":HOST ~S :DIRECTORY ~S :FILE ~S :NAME=~S :VERSION ~S"
+ (%pathname-host pathname)
+ (%pathname-directory pathname)
+ (%pathname-name pathname)
+ (%pathname-type pathname)
+ (%pathname-version pathname))))))
+\f
+;;; A pathname is logical if the host component is a logical-host.
+;;; This constructor is used to make an instance of the correct type
+;;; from parsed arguments.
+(defun %make-pathname-object (host device directory name type version)
+ (if (typep host 'logical-host)
+ (%make-logical-pathname host :unspecific directory name type version)
+ (%make-pathname host device directory name type version)))
+
+;;; Hash table searching maps a logical-pathname's host to their physical
+;;; pathname translation.
+(defvar *logical-hosts* (make-hash-table :test 'equal))
+\f
+;;;; patterns
+
+(def!method make-load-form ((pattern pattern) &optional environment)
+ (make-load-form-saving-slots pattern :environment environment))
+
+(def!method print-object ((pattern pattern) stream)
+ (print-unreadable-object (pattern stream :type t)
+ (if *print-pretty*
+ (let ((*print-escape* t))
+ (pprint-fill stream (pattern-pieces pattern) nil))
+ (prin1 (pattern-pieces pattern) stream))))
+
+(defun pattern= (pattern1 pattern2)
+ (declare (type pattern pattern1 pattern2))
+ (let ((pieces1 (pattern-pieces pattern1))
+ (pieces2 (pattern-pieces pattern2)))
+ (and (= (length pieces1) (length pieces2))
+ (every #'(lambda (piece1 piece2)
+ (typecase piece1
+ (simple-string
+ (and (simple-string-p piece2)
+ (string= piece1 piece2)))
+ (cons
+ (and (consp piece2)
+ (eq (car piece1) (car piece2))
+ (string= (cdr piece1) (cdr piece2))))
+ (t
+ (eq piece1 piece2))))
+ pieces1
+ pieces2))))
+
+;;; If the string matches the pattern returns the multiple values T and a
+;;; list of the matched strings.
+(defun pattern-matches (pattern string)
+ (declare (type pattern pattern)
+ (type simple-string string))
+ (let ((len (length string)))
+ (labels ((maybe-prepend (subs cur-sub chars)
+ (if cur-sub
+ (let* ((len (length chars))
+ (new (make-string len))
+ (index len))
+ (dolist (char chars)
+ (setf (schar new (decf index)) char))
+ (cons new subs))
+ subs))
+ (matches (pieces start subs cur-sub chars)
+ (if (null pieces)
+ (if (= start len)
+ (values t (maybe-prepend subs cur-sub chars))
+ (values nil nil))
+ (let ((piece (car pieces)))
+ (etypecase piece
+ (simple-string
+ (let ((end (+ start (length piece))))
+ (and (<= end len)
+ (string= piece string
+ :start2 start :end2 end)
+ (matches (cdr pieces) end
+ (maybe-prepend subs cur-sub chars)
+ nil nil))))
+ (list
+ (ecase (car piece)
+ (:character-set
+ (and (< start len)
+ (let ((char (schar string start)))
+ (if (find char (cdr piece) :test #'char=)
+ (matches (cdr pieces) (1+ start) subs t
+ (cons char chars))))))))
+ ((member :single-char-wild)
+ (and (< start len)
+ (matches (cdr pieces) (1+ start) subs t
+ (cons (schar string start) chars))))
+ ((member :multi-char-wild)
+ (multiple-value-bind (won new-subs)
+ (matches (cdr pieces) start subs t chars)
+ (if won
+ (values t new-subs)
+ (and (< start len)
+ (matches pieces (1+ start) subs t
+ (cons (schar string start)
+ chars)))))))))))
+ (multiple-value-bind (won subs)
+ (matches (pattern-pieces pattern) 0 nil nil nil)
+ (values won (reverse subs))))))
+
+;;; Pathname-match-p for directory components.
+(defun directory-components-match (thing wild)
+ (or (eq thing wild)
+ (eq wild :wild)
+ (and (consp wild)
+ (let ((wild1 (first wild)))
+ (if (eq wild1 :wild-inferiors)
+ (let ((wild-subdirs (rest wild)))
+ (or (null wild-subdirs)
+ (loop
+ (when (directory-components-match thing wild-subdirs)
+ (return t))
+ (pop thing)
+ (unless thing (return nil)))))
+ (and (consp thing)
+ (components-match (first thing) wild1)
+ (directory-components-match (rest thing)
+ (rest wild))))))))
+
+;;; Return true if pathname component THING is matched by WILD. (not
+;;; commutative)
+(defun components-match (thing wild)
+ (declare (type (or pattern symbol simple-string integer) thing wild))
+ (or (eq thing wild)
+ (eq wild :wild)
+ (typecase thing
+ (simple-base-string
+ ;; String is matched by itself, a matching pattern or :WILD.
+ (typecase wild
+ (pattern
+ (values (pattern-matches wild thing)))
+ (simple-base-string
+ (string= thing wild))))
+ (pattern
+ ;; A pattern is only matched by an identical pattern.
+ (and (pattern-p wild) (pattern= thing wild)))
+ (integer
+ ;; an integer (version number) is matched by :WILD or the same
+ ;; integer. This branch will actually always be NIL as long as the
+ ;; version is a fixnum.
+ (eql thing wild)))))
+
+;;; A predicate for comparing two pathname slot component sub-entries.
+(defun compare-component (this that)
+ (or (eql this that)
+ (typecase this
+ (simple-string
+ (and (simple-string-p that)
+ (string= this that)))
+ (pattern
+ (and (pattern-p that)
+ (pattern= this that)))
+ (cons
+ (and (consp that)
+ (compare-component (car this) (car that))
+ (compare-component (cdr this) (cdr that)))))))
+\f
+;;;; pathname functions
+
+;;; implementation-determined defaults to pathname slots
+(defvar *default-pathname-defaults*)
+
+(defun pathname= (pathname1 pathname2)
+ (declare (type pathname pathname1)
+ (type pathname pathname2))
+ (and (eq (%pathname-host pathname1)
+ (%pathname-host pathname2))
+ (compare-component (%pathname-device pathname1)
+ (%pathname-device pathname2))
+ (compare-component (%pathname-directory pathname1)
+ (%pathname-directory pathname2))
+ (compare-component (%pathname-name pathname1)
+ (%pathname-name pathname2))
+ (compare-component (%pathname-type pathname1)
+ (%pathname-type pathname2))
+ (compare-component (%pathname-version pathname1)
+ (%pathname-version pathname2))))
+
+;;; Convert PATHNAME-DESIGNATOR (a pathname, or string, or
+;;; stream), into a pathname in pathname.
+;;;
+;;; FIXME: was rewritten, should be tested (or rewritten again, this
+;;; time using ONCE-ONLY, *then* tested)
+;;; FIXME: become SB!XC:DEFMACRO inside EVAL-WHEN (COMPILE EVAL)?
+(defmacro with-pathname ((pathname pathname-designator) &body body)
+ (let ((pd0 (gensym)))
+ `(let* ((,pd0 ,pathname-designator)
+ (,pathname (etypecase ,pd0
+ (pathname ,pd0)
+ (string (parse-namestring ,pd0))
+ (stream (file-name ,pd0)))))
+ ,@body)))
+
+;;; Converts the var, a host or string name for a host, into a logical-host
+;;; structure or nil if not defined.
+;;;
+;;; pw notes 1/12/97 this potentially useful macro is not used anywhere
+;;; and 'find-host' is not defined. 'find-logical-host' seems to be needed.
+#|
+(defmacro with-host ((var expr) &body body)
+ `(let ((,var (let ((,var ,expr))
+ (typecase ,var
+ (logical-host ,var)
+ (string (find-logical-host ,var nil))
+ (t nil)))))
+ ,@body))
+|#
+
+(defun pathname (thing)
+ #!+sb-doc
+ "Convert thing (a pathname, string or stream) into a pathname."
+ (declare (type pathname-designator thing))
+ (with-pathname (pathname thing)
+ pathname))
+
+;;; Change the case of thing if DIDDLE-P.
+(defun maybe-diddle-case (thing diddle-p)
+ (if (and diddle-p (not (or (symbolp thing) (integerp thing))))
+ (labels ((check-for (pred in)
+ (typecase in
+ (pattern
+ (dolist (piece (pattern-pieces in))
+ (when (typecase piece
+ (simple-string
+ (check-for pred piece))
+ (cons
+ (case (car in)
+ (:character-set
+ (check-for pred (cdr in))))))
+ (return t))))
+ (list
+ (dolist (x in)
+ (when (check-for pred x)
+ (return t))))
+ (simple-base-string
+ (dotimes (i (length in))
+ (when (funcall pred (schar in i))
+ (return t))))
+ (t nil)))
+ (diddle-with (fun thing)
+ (typecase thing
+ (pattern
+ (make-pattern
+ (mapcar #'(lambda (piece)
+ (typecase piece
+ (simple-base-string
+ (funcall fun piece))
+ (cons
+ (case (car piece)
+ (:character-set
+ (cons :character-set
+ (funcall fun (cdr piece))))
+ (t
+ piece)))
+ (t
+ piece)))
+ (pattern-pieces thing))))
+ (list
+ (mapcar fun thing))
+ (simple-base-string
+ (funcall fun thing))
+ (t
+ thing))))
+ (let ((any-uppers (check-for #'upper-case-p thing))
+ (any-lowers (check-for #'lower-case-p thing)))
+ (cond ((and any-uppers any-lowers)
+ ;; Mixed case, stays the same.
+ thing)
+ (any-uppers
+ ;; All uppercase, becomes all lower case.
+ (diddle-with #'(lambda (x) (if (stringp x)
+ (string-downcase x)
+ x)) thing))
+ (any-lowers
+ ;; All lowercase, becomes all upper case.
+ (diddle-with #'(lambda (x) (if (stringp x)
+ (string-upcase x)
+ x)) thing))
+ (t
+ ;; No letters? I guess just leave it.
+ thing))))
+ thing))
+
+(defun merge-directories (dir1 dir2 diddle-case)
+ (if (or (eq (car dir1) :absolute)
+ (null dir2))
+ dir1
+ (let ((results nil))
+ (flet ((add (dir)
+ (if (and (eq dir :back)
+ results
+ (not (eq (car results) :back)))
+ (pop results)
+ (push dir results))))
+ (dolist (dir (maybe-diddle-case dir2 diddle-case))
+ (add dir))
+ (dolist (dir (cdr dir1))
+ (add dir)))
+ (reverse results))))
+
+(defun merge-pathnames (pathname
+ &optional
+ (defaults *default-pathname-defaults*)
+ (default-version :newest))
+ #!+sb-doc
+ "Construct a filled in pathname by completing the unspecified components
+ from the defaults."
+ (declare (type pathname-designator pathname)
+ (type pathname-designator defaults)
+ (values pathname))
+ (with-pathname (defaults defaults)
+ (let ((pathname (let ((*default-pathname-defaults* defaults))
+ (pathname pathname))))
+ (let* ((default-host (%pathname-host defaults))
+ (pathname-host (%pathname-host pathname))
+ (diddle-case
+ (and default-host pathname-host
+ (not (eq (host-customary-case default-host)
+ (host-customary-case pathname-host))))))
+ (%make-pathname-object
+ (or pathname-host default-host)
+ (or (%pathname-device pathname)
+ (maybe-diddle-case (%pathname-device defaults)
+ diddle-case))
+ (merge-directories (%pathname-directory pathname)
+ (%pathname-directory defaults)
+ diddle-case)
+ (or (%pathname-name pathname)
+ (maybe-diddle-case (%pathname-name defaults)
+ diddle-case))
+ (or (%pathname-type pathname)
+ (maybe-diddle-case (%pathname-type defaults)
+ diddle-case))
+ (or (%pathname-version pathname)
+ default-version))))))
+
+(defun import-directory (directory diddle-case)
+ (etypecase directory
+ (null nil)
+ ((member :wild) '(:absolute :wild-inferiors))
+ ((member :unspecific) '(:relative))
+ (list
+ (collect ((results))
+ (ecase (pop directory)
+ (:absolute
+ (results :absolute)
+ (when (search-list-p (car directory))
+ (results (pop directory))))
+ (:relative
+ (results :relative)))
+ (dolist (piece directory)
+ (cond ((member piece '(:wild :wild-inferiors :up :back))
+ (results piece))
+ ((or (simple-string-p piece) (pattern-p piece))
+ (results (maybe-diddle-case piece diddle-case)))
+ ((stringp piece)
+ (results (maybe-diddle-case (coerce piece 'simple-string)
+ diddle-case)))
+ (t
+ (error "~S is not allowed as a directory component." piece))))
+ (results)))
+ (simple-string
+ `(:absolute
+ ,(maybe-diddle-case directory diddle-case)))
+ (string
+ `(:absolute
+ ,(maybe-diddle-case (coerce directory 'simple-string)
+ diddle-case)))))
+
+(defun make-pathname (&key host
+ (device nil devp)
+ (directory nil dirp)
+ (name nil namep)
+ (type nil typep)
+ (version nil versionp)
+ defaults
+ (case :local))
+ #!+sb-doc
+ "Makes a new pathname from the component arguments. Note that host is
+a host-structure or string."
+ (declare (type (or string host component-tokens) host)
+ (type (or string component-tokens) device)
+ (type (or list string pattern component-tokens) directory)
+ (type (or string pattern component-tokens) name type)
+ (type (or integer component-tokens (member :newest)) version)
+ (type (or pathname-designator null) defaults)
+ (type (member :common :local) case))
+ (let* ((defaults (when defaults
+ (with-pathname (defaults defaults) defaults)))
+ (default-host (if defaults
+ (%pathname-host defaults)
+ (pathname-host *default-pathname-defaults*)))
+ ;; toy@rtp.ericsson.se: CLHS says make-pathname can take a
+ ;; string (as a logical-host) for the host part. We map that
+ ;; string into the corresponding logical host structure.
+
+ ;; pw@snoopy.mv.com:
+ ;; HyperSpec says for the arg to MAKE-PATHNAME;
+ ;; "host---a valid physical pathname host. ..."
+ ;; where it probably means -- a valid pathname host.
+ ;; "valid pathname host n. a valid physical pathname host or
+ ;; a valid logical pathname host."
+ ;; and defines
+ ;; "valid physical pathname host n. any of a string,
+ ;; a list of strings, or the symbol :unspecific,
+ ;; that is recognized by the implementation as the name of a host."
+ ;; "valid logical pathname host n. a string that has been defined
+ ;; as the name of a logical host. ..."
+ ;; HS is silent on what happens if the :host arg is NOT one of these.
+ ;; It seems an error message is appropriate.
+ (host (typecase host
+ (host host) ; A valid host, use it.
+ (string (find-logical-host host t)) ; logical-host or lose.
+ (t default-host))) ; unix-host
+ (diddle-args (and (eq (host-customary-case host) :lower)
+ (eq case :common)))
+ (diddle-defaults
+ (not (eq (host-customary-case host)
+ (host-customary-case default-host))))
+ (dev (if devp device (if defaults (%pathname-device defaults))))
+ (dir (import-directory directory diddle-args))
+ (ver (cond
+ (versionp version)
+ (defaults (%pathname-version defaults))
+ (t nil))))
+ (when (and defaults (not dirp))
+ (setf dir
+ (merge-directories dir
+ (%pathname-directory defaults)
+ diddle-defaults)))
+
+ (macrolet ((pick (var varp field)
+ `(cond ((or (simple-string-p ,var)
+ (pattern-p ,var))
+ (maybe-diddle-case ,var diddle-args))
+ ((stringp ,var)
+ (maybe-diddle-case (coerce ,var 'simple-string)
+ diddle-args))
+ (,varp
+ (maybe-diddle-case ,var diddle-args))
+ (defaults
+ (maybe-diddle-case (,field defaults)
+ diddle-defaults))
+ (t
+ nil))))
+ (%make-pathname-object host
+ dev ; forced to :unspecific when logical-host
+ dir
+ (pick name namep %pathname-name)
+ (pick type typep %pathname-type)
+ ver))))
+
+(defun pathname-host (pathname &key (case :local))
+ #!+sb-doc
+ "Accessor for the pathname's host."
+ (declare (type pathname-designator pathname)
+ (type (member :local :common) case)
+ (values host)
+ (ignore case))
+ (with-pathname (pathname pathname)
+ (%pathname-host pathname)))
+
+(defun pathname-device (pathname &key (case :local))
+ #!+sb-doc
+ "Accessor for pathname's device."
+ (declare (type pathname-designator pathname)
+ (type (member :local :common) case))
+ (with-pathname (pathname pathname)
+ (maybe-diddle-case (%pathname-device pathname)
+ (and (eq case :common)
+ (eq (host-customary-case
+ (%pathname-host pathname))
+ :lower)))))
+
+(defun pathname-directory (pathname &key (case :local))
+ #!+sb-doc
+ "Accessor for the pathname's directory list."
+ (declare (type pathname-designator pathname)
+ (type (member :local :common) case))
+ (with-pathname (pathname pathname)
+ (maybe-diddle-case (%pathname-directory pathname)
+ (and (eq case :common)
+ (eq (host-customary-case
+ (%pathname-host pathname))
+ :lower)))))
+(defun pathname-name (pathname &key (case :local))
+ #!+sb-doc
+ "Accessor for the pathname's name."
+ (declare (type pathname-designator pathname)
+ (type (member :local :common) case))
+ (with-pathname (pathname pathname)
+ (maybe-diddle-case (%pathname-name pathname)
+ (and (eq case :common)
+ (eq (host-customary-case
+ (%pathname-host pathname))
+ :lower)))))
+
+;;; PATHNAME-TYPE
+(defun pathname-type (pathname &key (case :local))
+ #!+sb-doc
+ "Accessor for the pathname's name."
+ (declare (type pathname-designator pathname)
+ (type (member :local :common) case))
+ (with-pathname (pathname pathname)
+ (maybe-diddle-case (%pathname-type pathname)
+ (and (eq case :common)
+ (eq (host-customary-case
+ (%pathname-host pathname))
+ :lower)))))
+
+;;; PATHNAME-VERSION
+(defun pathname-version (pathname)
+ #!+sb-doc
+ "Accessor for the pathname's version."
+ (declare (type pathname-designator pathname))
+ (with-pathname (pathname pathname)
+ (%pathname-version pathname)))
+\f
+;;;; namestrings
+
+(defun %print-namestring-parse-error (condition stream)
+ (format stream "Parse error in namestring: ~?~% ~A~% ~V@T^"
+ (namestring-parse-error-complaint condition)
+ (namestring-parse-error-arguments condition)
+ (namestring-parse-error-namestring condition)
+ (namestring-parse-error-offset condition)))
+
+;;; Handle the case where parse-namestring is actually parsing a namestring.
+;;; We pick off the :JUNK-ALLOWED case then find a host to use for parsing,
+;;; call the parser, then check whether the host matches.
+(defun %parse-namestring (namestr host defaults start end junk-allowed)
+ (declare (type (or host null) host) (type string namestr)
+ (type index start) (type (or index null) end))
+ (if junk-allowed
+ (handler-case
+ (%parse-namestring namestr host defaults start end nil)
+ (namestring-parse-error (condition)
+ (values nil (namestring-parse-error-offset condition))))
+ (let* ((end (or end (length namestr)))
+ (parse-host (or host
+ (extract-logical-host-prefix namestr start end)
+ (pathname-host defaults))))
+ (unless parse-host
+ (error "When Host arg is not supplied, Defaults arg must ~
+ have a non-null PATHNAME-HOST."))
+
+ (multiple-value-bind (new-host device directory file type version)
+ (funcall (host-parse parse-host) namestr start end)
+ (when (and host new-host (not (eq new-host host)))
+ (error "Host in namestring: ~S~@
+ does not match explicit host argument: ~S"
+ host))
+ (let ((pn-host (or new-host parse-host)))
+ (values (%make-pathname-object
+ pn-host device directory file type version)
+ end))))))
+
+;;; If namestr begins with a colon-terminated, defined, logical host, then
+;;; return that host, otherwise return NIL.
+(defun extract-logical-host-prefix (namestr start end)
+ (declare (type simple-base-string namestr)
+ (type index start end)
+ (values (or logical-host null)))
+ (let ((colon-pos (position #\: namestr :start start :end end)))
+ (if colon-pos
+ (values (gethash (nstring-upcase (subseq namestr start colon-pos))
+ *logical-hosts*))
+ nil)))
+
+(defun parse-namestring (thing
+ &optional host (defaults *default-pathname-defaults*)
+ &key (start 0) end junk-allowed)
+ #!+sb-doc
+ "Converts pathname, a pathname designator, into a pathname structure,
+ for a physical pathname, returns the printed representation. Host may be
+ a physical host structure or host namestring."
+ (declare (type pathname-designator thing)
+ (type (or null host) host)
+ (type pathname defaults)
+ (type index start)
+ (type (or index null) end)
+ (type (or t null) junk-allowed)
+ (values (or null pathname) (or null index)))
+ (typecase thing
+ (simple-string
+ (%parse-namestring thing host defaults start end junk-allowed))
+ (string
+ (%parse-namestring (coerce thing 'simple-string)
+ host defaults start end junk-allowed))
+ (pathname
+ (let ((host (if host host (%pathname-host defaults))))
+ (unless (eq host (%pathname-host thing))
+ (error "Hosts do not match: ~S and ~S."
+ host (%pathname-host thing))))
+ (values thing start))
+ (stream
+ (let ((name (file-name thing)))
+ (unless name
+ (error "Can't figure out the file associated with stream:~% ~S"
+ thing))
+ name))))
+
+(defun namestring (pathname)
+ #!+sb-doc
+ "Construct the full (name)string form of the pathname."
+ (declare (type pathname-designator pathname)
+ (values (or null simple-base-string)))
+ (with-pathname (pathname pathname)
+ (when pathname
+ (let ((host (%pathname-host pathname)))
+ (unless host
+ (error "Cannot determine the namestring for pathnames with no ~
+ host:~% ~S" pathname))
+ (funcall (host-unparse host) pathname)))))
+
+(defun host-namestring (pathname)
+ #!+sb-doc
+ "Returns a string representation of the name of the host in the pathname."
+ (declare (type pathname-designator pathname)
+ (values (or null simple-base-string)))
+ (with-pathname (pathname pathname)
+ (let ((host (%pathname-host pathname)))
+ (if host
+ (funcall (host-unparse-host host) pathname)
+ (error
+ "Cannot determine the namestring for pathnames with no host:~% ~S"
+ pathname)))))
+
+(defun directory-namestring (pathname)
+ #!+sb-doc
+ "Returns a string representation of the directories used in the pathname."
+ (declare (type pathname-designator pathname)
+ (values (or null simple-base-string)))
+ (with-pathname (pathname pathname)
+ (let ((host (%pathname-host pathname)))
+ (if host
+ (funcall (host-unparse-directory host) pathname)
+ (error
+ "Cannot determine the namestring for pathnames with no host:~% ~S"
+ pathname)))))
+
+(defun file-namestring (pathname)
+ #!+sb-doc
+ "Returns a string representation of the name used in the pathname."
+ (declare (type pathname-designator pathname)
+ (values (or null simple-base-string)))
+ (with-pathname (pathname pathname)
+ (let ((host (%pathname-host pathname)))
+ (if host
+ (funcall (host-unparse-file host) pathname)
+ (error
+ "Cannot determine the namestring for pathnames with no host:~% ~S"
+ pathname)))))
+
+(defun enough-namestring (pathname
+ &optional (defaults *default-pathname-defaults*))
+ #!+sb-doc
+ "Returns an abbreviated pathname sufficent to identify the pathname relative
+ to the defaults."
+ (declare (type pathname-designator pathname))
+ (with-pathname (pathname pathname)
+ (let ((host (%pathname-host pathname)))
+ (if host
+ (with-pathname (defaults defaults)
+ (funcall (host-unparse-enough host) pathname defaults))
+ (error
+ "Cannot determine the namestring for pathnames with no host:~% ~S"
+ pathname)))))
+\f
+;;;; wild pathnames
+
+(defun wild-pathname-p (pathname &optional field-key)
+ #!+sb-doc
+ "Predicate for determining whether pathname contains any wildcards."
+ (declare (type pathname-designator pathname)
+ (type (member nil :host :device :directory :name :type :version)
+ field-key))
+ (with-pathname (pathname pathname)
+ (flet ((frob (x)
+ (or (pattern-p x) (member x '(:wild :wild-inferiors)))))
+ (ecase field-key
+ ((nil)
+ (or (wild-pathname-p pathname :host)
+ (wild-pathname-p pathname :device)
+ (wild-pathname-p pathname :directory)
+ (wild-pathname-p pathname :name)
+ (wild-pathname-p pathname :type)
+ (wild-pathname-p pathname :version)))
+ (:host (frob (%pathname-host pathname)))
+ (:device (frob (%pathname-host pathname)))
+ (:directory (some #'frob (%pathname-directory pathname)))
+ (:name (frob (%pathname-name pathname)))
+ (:type (frob (%pathname-type pathname)))
+ (:version (frob (%pathname-version pathname)))))))
+
+(defun pathname-match-p (in-pathname in-wildname)
+ #!+sb-doc
+ "Pathname matches the wildname template?"
+ (declare (type pathname-designator in-pathname))
+ (with-pathname (pathname in-pathname)
+ (with-pathname (wildname in-wildname)
+ (macrolet ((frob (field &optional (op 'components-match ))
+ `(or (null (,field wildname))
+ (,op (,field pathname) (,field wildname)))))
+ (and (or (null (%pathname-host wildname))
+ (eq (%pathname-host wildname) (%pathname-host pathname)))
+ (frob %pathname-device)
+ (frob %pathname-directory directory-components-match)
+ (frob %pathname-name)
+ (frob %pathname-type)
+ (frob %pathname-version))))))
+
+;;; Place the substitutions into the pattern and return the string or pattern
+;;; that results. If DIDDLE-CASE is true, we diddle the result case as well,
+;;; in case we are translating between hosts with difference conventional case.
+;;; The second value is the tail of subs with all of the values that we used up
+;;; stripped off. Note that PATTERN-MATCHES matches all consecutive wildcards
+;;; as a single string, so we ignore subsequent contiguous wildcards.
+(defun substitute-into (pattern subs diddle-case)
+ (declare (type pattern pattern)
+ (type list subs)
+ (values (or simple-base-string pattern)))
+ (let ((in-wildcard nil)
+ (pieces nil)
+ (strings nil))
+ (dolist (piece (pattern-pieces pattern))
+ (cond ((simple-string-p piece)
+ (push piece strings)
+ (setf in-wildcard nil))
+ (in-wildcard)
+ (t
+ (setf in-wildcard t)
+ (unless subs
+ (error "Not enough wildcards in FROM pattern to match ~
+ TO pattern:~% ~S"
+ pattern))
+ (let ((sub (pop subs)))
+ (typecase sub
+ (pattern
+ (when strings
+ (push (apply #'concatenate 'simple-string
+ (nreverse strings))
+ pieces))
+ (dolist (piece (pattern-pieces sub))
+ (push piece pieces)))
+ (simple-string
+ (push sub strings))
+ (t
+ (error "Can't substitute this into the middle of a word:~
+ ~% ~S"
+ sub)))))))
+
+ (when strings
+ (push (apply #'concatenate 'simple-string (nreverse strings))
+ pieces))
+ (values
+ (maybe-diddle-case
+ (if (and pieces (simple-string-p (car pieces)) (null (cdr pieces)))
+ (car pieces)
+ (make-pattern (nreverse pieces)))
+ diddle-case)
+ subs)))
+
+;;; Called when we can't see how source and from matched.
+(defun didnt-match-error (source from)
+ (error "Pathname components from SOURCE and FROM args to TRANSLATE-PATHNAME~@
+ did not match:~% ~S ~S"
+ source from))
+
+;;; Do TRANSLATE-COMPONENT for all components except host and directory.
+(defun translate-component (source from to diddle-case)
+ (typecase to
+ (pattern
+ (typecase from
+ (pattern
+ (typecase source
+ (pattern
+ (if (pattern= from source)
+ source
+ (didnt-match-error source from)))
+ (simple-string
+ (multiple-value-bind (won subs) (pattern-matches from source)
+ (if won
+ (values (substitute-into to subs diddle-case))
+ (didnt-match-error source from))))
+ (t
+ (maybe-diddle-case source diddle-case))))
+ ((member :wild)
+ (values (substitute-into to (list source) diddle-case)))
+ (t
+ (if (components-match source from)
+ (maybe-diddle-case source diddle-case)
+ (didnt-match-error source from)))))
+ ((member nil :wild)
+ (maybe-diddle-case source diddle-case))
+ (t
+ (if (components-match source from)
+ to
+ (didnt-match-error source from)))))
+
+;;; Return a list of all the things that we want to substitute into the TO
+;;; pattern (the things matched by from on source.) When From contains
+;;; :WILD-INFERIORS, the result contains a sublist of the matched source
+;;; subdirectories.
+(defun compute-directory-substitutions (orig-source orig-from)
+ (let ((source orig-source)
+ (from orig-from))
+ (collect ((subs))
+ (loop
+ (unless source
+ (unless (every #'(lambda (x) (eq x :wild-inferiors)) from)
+ (didnt-match-error orig-source orig-from))
+ (subs ())
+ (return))
+ (unless from (didnt-match-error orig-source orig-from))
+ (let ((from-part (pop from))
+ (source-part (pop source)))
+ (typecase from-part
+ (pattern
+ (typecase source-part
+ (pattern
+ (if (pattern= from-part source-part)
+ (subs source-part)
+ (didnt-match-error orig-source orig-from)))
+ (simple-string
+ (multiple-value-bind (won new-subs)
+ (pattern-matches from-part source-part)
+ (if won
+ (dolist (sub new-subs)
+ (subs sub))
+ (didnt-match-error orig-source orig-from))))
+ (t
+ (didnt-match-error orig-source orig-from))))
+ ((member :wild)
+ (subs source-part))
+ ((member :wild-inferiors)
+ (let ((remaining-source (cons source-part source)))
+ (collect ((res))
+ (loop
+ (when (directory-components-match remaining-source from)
+ (return))
+ (unless remaining-source
+ (didnt-match-error orig-source orig-from))
+ (res (pop remaining-source)))
+ (subs (res))
+ (setq source remaining-source))))
+ (simple-string
+ (unless (and (simple-string-p source-part)
+ (string= from-part source-part))
+ (didnt-match-error orig-source orig-from)))
+ (t
+ (didnt-match-error orig-source orig-from)))))
+ (subs))))
+
+;;; Called by TRANSLATE-PATHNAME on the directory components of its argument
+;;; pathanames to produce the result directory component. If any leaves the
+;;; directory NIL, we return the source directory. The :RELATIVE or :ABSOLUTE
+;;; is always taken from the source directory.
+(defun translate-directories (source from to diddle-case)
+ (if (not (and source to from))
+ (or to
+ (mapcar #'(lambda (x) (maybe-diddle-case x diddle-case)) source))
+ (collect ((res))
+ (res (first source))
+ (let ((subs-left (compute-directory-substitutions (rest source)
+ (rest from))))
+ (dolist (to-part (rest to))
+ (typecase to-part
+ ((member :wild)
+ (assert subs-left)
+ (let ((match (pop subs-left)))
+ (when (listp match)
+ (error ":WILD-INFERIORS not paired in from and to ~
+ patterns:~% ~S ~S" from to))
+ (res (maybe-diddle-case match diddle-case))))
+ ((member :wild-inferiors)
+ (assert subs-left)
+ (let ((match (pop subs-left)))
+ (unless (listp match)
+ (error ":WILD-INFERIORS not paired in from and to ~
+ patterns:~% ~S ~S" from to))
+ (dolist (x match)
+ (res (maybe-diddle-case x diddle-case)))))
+ (pattern
+ (multiple-value-bind (new new-subs-left)
+ (substitute-into to-part subs-left diddle-case)
+ (setf subs-left new-subs-left)
+ (res new)))
+ (t (res to-part)))))
+ (res))))
+
+(defun translate-pathname (source from-wildname to-wildname &key)
+ #!+sb-doc
+ "Use the source pathname to translate the from-wildname's wild and
+ unspecified elements into a completed to-pathname based on the to-wildname."
+ (declare (type pathname-designator source from-wildname to-wildname))
+ (with-pathname (source source)
+ (with-pathname (from from-wildname)
+ (with-pathname (to to-wildname)
+ (let* ((source-host (%pathname-host source))
+ (to-host (%pathname-host to))
+ (diddle-case
+ (and source-host to-host
+ (not (eq (host-customary-case source-host)
+ (host-customary-case to-host))))))
+ (macrolet ((frob (field &optional (op 'translate-component))
+ `(let ((result (,op (,field source)
+ (,field from)
+ (,field to)
+ diddle-case)))
+ (if (eq result :error)
+ (error "~S doesn't match ~S." source from)
+ result))))
+ (%make-pathname-object
+ (or to-host source-host)
+ (frob %pathname-device)
+ (frob %pathname-directory translate-directories)
+ (frob %pathname-name)
+ (frob %pathname-type)
+ (frob %pathname-version))))))))
+\f
+;;;; search lists
+
+(def!struct (search-list (:make-load-form-fun
+ (lambda (s)
+ (values `(intern-search-list
+ ',(search-list-name s))
+ nil))))
+ ;; The name of this search-list. Always stored in lowercase.
+ (name (required-argument) :type simple-string)
+ ;; T if this search-list has been defined. Otherwise NIL.
+ (defined nil :type (member t nil))
+ ;; The list of expansions for this search-list. Each expansion is the list
+ ;; of directory components to use in place of this search-list.
+ (expansions nil :type list))
+(def!method print-object ((sl search-list) stream)
+ (print-unreadable-object (sl stream :type t)
+ (write-string (search-list-name sl) stream)))
+
+;;; a hash table mapping search-list names to search-list structures
+(defvar *search-lists* (make-hash-table :test 'equal))
+
+;;; When search-lists are encountered in namestrings, they are converted to
+;;; search-list structures right then, instead of waiting until the search
+;;; list used. This allows us to verify ahead of time that there are no
+;;; circularities and makes expansion much quicker.
+(defun intern-search-list (name)
+ (let ((name (string-downcase name)))
+ (or (gethash name *search-lists*)
+ (let ((new (make-search-list :name name)))
+ (setf (gethash name *search-lists*) new)
+ new))))
+
+;;; Clear the definition. Note: we can't remove it from the hash-table
+;;; because there may be pathnames still refering to it. So we just clear
+;;; out the expansions and ste defined to NIL.
+(defun clear-search-list (name)
+ #!+sb-doc
+ "Clear the current definition for the search-list NAME. Returns T if such
+ a definition existed, and NIL if not."
+ (let* ((name (string-downcase name))
+ (search-list (gethash name *search-lists*)))
+ (when (and search-list (search-list-defined search-list))
+ (setf (search-list-defined search-list) nil)
+ (setf (search-list-expansions search-list) nil)
+ t)))
+
+;;; Again, we can't actually remove the entries from the hash-table, so we
+;;; just mark them as being undefined.
+(defun clear-all-search-lists ()
+ #!+sb-doc
+ "Clear the definition for all search-lists. Only use this if you know
+ what you are doing."
+ (maphash #'(lambda (name search-list)
+ (declare (ignore name))
+ (setf (search-list-defined search-list) nil)
+ (setf (search-list-expansions search-list) nil))
+ *search-lists*)
+ nil)
+
+;;; Extract the search-list from PATHNAME and return it. If PATHNAME
+;;; doesn't start with a search-list, then either error (if FLAME-IF-NONE
+;;; is true) or return NIL (if FLAME-IF-NONE is false).
+(defun extract-search-list (pathname flame-if-none)
+ (with-pathname (pathname pathname)
+ (let* ((directory (%pathname-directory pathname))
+ (search-list (cadr directory)))
+ (cond ((search-list-p search-list)
+ search-list)
+ (flame-if-none
+ (error "~S doesn't start with a search-list." pathname))
+ (t
+ nil)))))
+
+;;; We have to convert the internal form of the search-list back into a
+;;; bunch of pathnames.
+(defun search-list (pathname)
+ #!+sb-doc
+ "Return the expansions for the search-list starting PATHNAME. If PATHNAME
+ does not start with a search-list, then an error is signaled. If
+ the search-list has not been defined yet, then an error is signaled.
+ The expansion for a search-list can be set with SETF."
+ (with-pathname (pathname pathname)
+ (let ((search-list (extract-search-list pathname t))
+ (host (pathname-host pathname)))
+ (if (search-list-defined search-list)
+ (mapcar #'(lambda (directory)
+ (make-pathname :host host
+ :directory (cons :absolute directory)))
+ (search-list-expansions search-list))
+ (error "Search list ~S has not been defined yet." pathname)))))
+
+(defun search-list-defined-p (pathname)
+ #!+sb-doc
+ "Returns T if the search-list starting PATHNAME is currently defined, and
+ NIL otherwise. An error is signaled if PATHNAME does not start with a
+ search-list."
+ (with-pathname (pathname pathname)
+ (search-list-defined (extract-search-list pathname t))))
+
+;;; Set the expansion for the search-list in PATHNAME. If this would result
+;;; in any circularities, we flame out. If anything goes wrong, we leave the
+;;; old definition intact.
+(defun %set-search-list (pathname values)
+ (let ((search-list (extract-search-list pathname t)))
+ (labels
+ ((check (target-list path)
+ (when (eq search-list target-list)
+ (error "That would result in a circularity:~% ~
+ ~A~{ -> ~A~} -> ~A"
+ (search-list-name search-list)
+ (reverse path)
+ (search-list-name target-list)))
+ (when (search-list-p target-list)
+ (push (search-list-name target-list) path)
+ (dolist (expansion (search-list-expansions target-list))
+ (check (car expansion) path))))
+ (convert (pathname)
+ (with-pathname (pathname pathname)
+ (when (or (pathname-name pathname)
+ (pathname-type pathname)
+ (pathname-version pathname))
+ (error "Search-lists cannot expand into pathnames that have ~
+ a name, type, or ~%version specified:~% ~S"
+ pathname))
+ (let ((directory (pathname-directory pathname)))
+ (let ((expansion
+ (if directory
+ (ecase (car directory)
+ (:absolute (cdr directory))
+ (:relative (cons (intern-search-list "default")
+ (cdr directory))))
+ (list (intern-search-list "default")))))
+ (check (car expansion) nil)
+ expansion)))))
+ (setf (search-list-expansions search-list)
+ (if (listp values)
+ (mapcar #'convert values)
+ (list (convert values)))))
+ (setf (search-list-defined search-list) t))
+ values)
+
+(defun %enumerate-search-list (pathname function)
+ (/show0 "entering %ENUMERATE-SEARCH-LIST")
+ (let* ((pathname (if (typep pathname 'logical-pathname)
+ (translate-logical-pathname pathname)
+ pathname))
+ (search-list (extract-search-list pathname nil)))
+ (/show0 "PATHNAME and SEARCH-LIST computed")
+ (cond
+ ((not search-list)
+ (/show0 "no search list")
+ (funcall function pathname))
+ ((not (search-list-defined search-list))
+ (/show0 "undefined search list")
+ (error "Undefined search list: ~A"
+ (search-list-name search-list)))
+ (t
+ (/show0 "general case")
+ (let ((tail (cddr (pathname-directory pathname))))
+ (/show0 "TAIL computed")
+ (dolist (expansion
+ (search-list-expansions search-list))
+ (/show0 "tail recursing in %ENUMERATE-SEARCH-LIST")
+ (%enumerate-search-list (make-pathname :defaults pathname
+ :directory
+ (cons :absolute
+ (append expansion
+ tail)))
+ function)))))))
+\f
+;;;; logical pathname support. ANSI 92-102 specification.
+;;;; As logical-pathname translations are loaded they are canonicalized as
+;;;; patterns to enable rapid efficent translation into physical pathnames.
+
+;;;; utilities
+
+;;; Canonicalize a logical pathanme word by uppercasing it checking that it
+;;; contains only legal characters.
+(defun logical-word-or-lose (word)
+ (declare (string word))
+ (let ((word (string-upcase word)))
+ (dotimes (i (length word))
+ (let ((ch (schar word i)))
+ (unless (or (alpha-char-p ch) (digit-char-p ch) (char= ch #\-))
+ (error 'namestring-parse-error
+ :complaint "Logical namestring character ~
+ is not alphanumeric or hyphen:~% ~S"
+ :arguments (list ch)
+ :namestring word :offset i))))
+ word))
+
+;;; Given a logical host or string, return a logical host. If Error-p is
+;;; NIL, then return NIL when no such host exists.
+(defun find-logical-host (thing &optional (errorp t))
+ (etypecase thing
+ (string
+ (let ((found (gethash (logical-word-or-lose thing)
+ *logical-hosts*)))
+ (if (or found (not errorp))
+ found
+ (error 'simple-file-error
+ :pathname thing
+ :format-control "Logical host not yet defined: ~S"
+ :format-arguments (list thing)))))
+ (logical-host thing)))
+
+;;; Given a logical host name or host, return a logical host, creating a new
+;;; one if necessary.
+(defun intern-logical-host (thing)
+ (declare (values logical-host))
+ (or (find-logical-host thing nil)
+ (let* ((name (logical-word-or-lose thing))
+ (new (make-logical-host :name name)))
+ (setf (gethash name *logical-hosts*) new)
+ new)))
+\f
+;;;; logical pathname parsing
+
+;;; Deal with multi-char wildcards in a logical pathname token.
+(defun maybe-make-logical-pattern (namestring chunks)
+ (let ((chunk (caar chunks)))
+ (collect ((pattern))
+ (let ((last-pos 0)
+ (len (length chunk)))
+ (declare (fixnum last-pos))
+ (loop
+ (when (= last-pos len) (return))
+ (let ((pos (or (position #\* chunk :start last-pos) len)))
+ (if (= pos last-pos)
+ (when (pattern)
+ (error 'namestring-parse-error
+ :complaint "Double asterisk inside of logical ~
+ word: ~S"
+ :arguments (list chunk)
+ :namestring namestring
+ :offset (+ (cdar chunks) pos)))
+ (pattern (subseq chunk last-pos pos)))
+ (if (= pos len)
+ (return)
+ (pattern :multi-char-wild))
+ (setq last-pos (1+ pos)))))
+ (assert (pattern))
+ (if (cdr (pattern))
+ (make-pattern (pattern))
+ (let ((x (car (pattern))))
+ (if (eq x :multi-char-wild)
+ :wild
+ x))))))
+
+;;; Return a list of conses where the cdr is the start position and the car
+;;; is a string (token) or character (punctuation.)
+(defun logical-chunkify (namestr start end)
+ (collect ((chunks))
+ (do ((i start (1+ i))
+ (prev 0))
+ ((= i end)
+ (when (> end prev)
+ (chunks (cons (nstring-upcase (subseq namestr prev end)) prev))))
+ (let ((ch (schar namestr i)))
+ (unless (or (alpha-char-p ch) (digit-char-p ch)
+ (member ch '(#\- #\*)))
+ (when (> i prev)
+ (chunks (cons (nstring-upcase (subseq namestr prev i)) prev)))
+ (setq prev (1+ i))
+ (unless (member ch '(#\; #\: #\.))
+ (error 'namestring-parse-error
+ :complaint "Illegal character for logical pathname:~% ~S"
+ :arguments (list ch)
+ :namestring namestr
+ :offset i))
+ (chunks (cons ch i)))))
+ (chunks)))
+
+;;; Break up a logical-namestring, always a string, into its constituent parts.
+(defun parse-logical-namestring (namestr start end)
+ (declare (type simple-base-string namestr)
+ (type index start end))
+ (collect ((directory))
+ (let ((host nil)
+ (name nil)
+ (type nil)
+ (version nil))
+ (labels ((expecting (what chunks)
+ (unless (and chunks (simple-string-p (caar chunks)))
+ (error 'namestring-parse-error
+ :complaint "Expecting ~A, got ~:[nothing~;~S~]."
+ :arguments (list what (caar chunks))
+ :namestring namestr
+ :offset (if chunks (cdar chunks) end)))
+ (caar chunks))
+ (parse-host (chunks)
+ (case (caadr chunks)
+ (#\:
+ (setq host
+ (find-logical-host (expecting "a host name" chunks)))
+ (parse-relative (cddr chunks)))
+ (t
+ (parse-relative chunks))))
+ (parse-relative (chunks)
+ (case (caar chunks)
+ (#\;
+ (directory :relative)
+ (parse-directory (cdr chunks)))
+ (t
+ (directory :absolute) ; Assumption! Maybe revoked later.
+ (parse-directory chunks))))
+ (parse-directory (chunks)
+ (case (caadr chunks)
+ (#\;
+ (directory
+ (let ((res (expecting "a directory name" chunks)))
+ (cond ((string= res "..") :up)
+ ((string= res "**") :wild-inferiors)
+ (t
+ (maybe-make-logical-pattern namestr chunks)))))
+ (parse-directory (cddr chunks)))
+ (t
+ (parse-name chunks))))
+ (parse-name (chunks)
+ (when chunks
+ (expecting "a file name" chunks)
+ (setq name (maybe-make-logical-pattern namestr chunks))
+ (expecting-dot (cdr chunks))))
+ (expecting-dot (chunks)
+ (when chunks
+ (unless (eql (caar chunks) #\.)
+ (error 'namestring-parse-error
+ :complaint "Expecting a dot, got ~S."
+ :arguments (list (caar chunks))
+ :namestring namestr
+ :offset (cdar chunks)))
+ (if type
+ (parse-version (cdr chunks))
+ (parse-type (cdr chunks)))))
+ (parse-type (chunks)
+ (expecting "a file type" chunks)
+ (setq type (maybe-make-logical-pattern namestr chunks))
+ (expecting-dot (cdr chunks)))
+ (parse-version (chunks)
+ (let ((str (expecting "a positive integer, * or NEWEST"
+ chunks)))
+ (cond
+ ((string= str "*") (setq version :wild))
+ ((string= str "NEWEST") (setq version :newest))
+ (t
+ (multiple-value-bind (res pos)
+ (parse-integer str :junk-allowed t)
+ (unless (and res (plusp res))
+ (error 'namestring-parse-error
+ :complaint "Expected a positive integer, ~
+ got ~S"
+ :arguments (list str)
+ :namestring namestr
+ :offset (+ pos (cdar chunks))))
+ (setq version res)))))
+ (when (cdr chunks)
+ (error 'namestring-parse-error
+ :complaint "Extra stuff after end of file name."
+ :namestring namestr
+ :offset (cdadr chunks)))))
+ (parse-host (logical-chunkify namestr start end)))
+ (values host :unspecific
+ (and (not (equal (directory)'(:absolute)))(directory))
+ name type version))))
+
+;;; can't defvar here because not all host methods are loaded yet
+(declaim (special *logical-pathname-defaults*))
+
+(defun logical-pathname (pathspec)
+ #!+sb-doc
+ "Converts the pathspec argument to a logical-pathname and returns it."
+ (declare (type (or logical-pathname string stream) pathspec)
+ (values logical-pathname))
+ (if (typep pathspec 'logical-pathname)
+ pathspec
+ (let ((res (parse-namestring pathspec nil *logical-pathname-defaults*)))
+ (when (eq (%pathname-host res)
+ (%pathname-host *logical-pathname-defaults*))
+ (error "Logical namestring does not specify a host:~% ~S"
+ pathspec))
+ res)))
+\f
+;;;; logical pathname unparsing
+
+(defun unparse-logical-directory (pathname)
+ (declare (type pathname pathname))
+ (collect ((pieces))
+ (let ((directory (%pathname-directory pathname)))
+ (when directory
+ (ecase (pop directory)
+ (:absolute) ;; Nothing special.
+ (:relative (pieces ";")))
+ (dolist (dir directory)
+ (cond ((or (stringp dir) (pattern-p dir))
+ (pieces (unparse-logical-piece dir))
+ (pieces ";"))
+ ((eq dir :wild)
+ (pieces "*;"))
+ ((eq dir :wild-inferiors)
+ (pieces "**;"))
+ (t
+ (error "Invalid directory component: ~S" dir))))))
+ (apply #'concatenate 'simple-string (pieces))))
+
+(defun unparse-logical-piece (thing)
+ (etypecase thing
+ (simple-string thing)
+ (pattern
+ (collect ((strings))
+ (dolist (piece (pattern-pieces thing))
+ (etypecase piece
+ (simple-string (strings piece))
+ (keyword
+ (cond ((eq piece :wild-inferiors)
+ (strings "**"))
+ ((eq piece :multi-char-wild)
+ (strings "*"))
+ (t (error "Invalid keyword: ~S" piece))))))
+ (apply #'concatenate 'simple-string (strings))))))
+
+(defun unparse-logical-namestring (pathname)
+ (declare (type logical-pathname pathname))
+ (concatenate 'simple-string
+ (logical-host-name (%pathname-host pathname)) ":"
+ (unparse-logical-directory pathname)
+ (unparse-unix-file pathname)))
+\f
+;;;; logical pathname translations
+
+;;; Verify that the list of translations consists of lists and prepare
+;;; canonical translations (parse pathnames and expand out wildcards into
+;;; patterns).
+(defun canonicalize-logical-pathname-translations (transl-list host)
+ (declare (type list transl-list) (type host host)
+ (values list))
+ (collect ((res))
+ (dolist (tr transl-list)
+ (unless (and (consp tr) (= (length tr) 2))
+ (error "Logical pathname translation is not a two-list:~% ~S"
+ tr))
+ (let ((from (first tr)))
+ (res (list (if (typep from 'logical-pathname)
+ from
+ (parse-namestring from host))
+ (pathname (second tr))))))
+ (res)))
+
+(defun logical-pathname-translations (host)
+ #!+sb-doc
+ "Return the (logical) host object argument's list of translations."
+ (declare (type (or string logical-host) host)
+ (values list))
+ (logical-host-translations (find-logical-host host)))
+
+(defun (setf logical-pathname-translations) (translations host)
+ #!+sb-doc
+ "Set the translations list for the logical host argument.
+ Return translations."
+ (declare (type (or string logical-host) host)
+ (type list translations)
+ (values list))
+
+ (let ((host (intern-logical-host host)))
+ (setf (logical-host-canon-transls host)
+ (canonicalize-logical-pathname-translations translations host))
+ (setf (logical-host-translations host) translations)))
+
+;;; The search mechanism for loading pathname translations uses the CMU CL
+;;; extension of search-lists. The user can add to the "library:" search-list
+;;; using setf. The file for translations should have the name defined by
+;;; the hostname (a string) and with type component "translations".
+
+(defun load-logical-pathname-translations (host)
+ #!+sb-doc
+ "Search for a logical pathname named host, if not already defined. If already
+ defined no attempt to find or load a definition is attempted and NIL is
+ returned. If host is not already defined, but definition is found and loaded
+ successfully, T is returned, else error."
+ (declare (type string host)
+ (values (member t nil)))
+ (unless (find-logical-host host nil)
+ (with-open-file (in-str (make-pathname :defaults "library:"
+ :name host
+ :type "translations"))
+ (if *load-verbose*
+ (format *error-output*
+ ";; loading pathname translations from ~A~%"
+ (namestring (truename in-str))))
+ (setf (logical-pathname-translations host) (read in-str)))
+ t))
+
+(defun translate-logical-pathname (pathname &key)
+ #!+sb-doc
+ "Translates pathname to a physical pathname, which is returned."
+ (declare (type pathname-designator pathname)
+ (values (or null pathname)))
+ (typecase pathname
+ (logical-pathname
+ (dolist (x (logical-host-canon-transls (%pathname-host pathname))
+ (error 'simple-file-error
+ :pathname pathname
+ :format-control "No translation for ~S"
+ :format-arguments (list pathname)))
+ (destructuring-bind (from to) x
+ (when (pathname-match-p pathname from)
+ (return (translate-logical-pathname
+ (translate-pathname pathname from to)))))))
+ (pathname pathname)
+ (stream (translate-logical-pathname (pathname pathname)))
+ (t (translate-logical-pathname (logical-pathname pathname)))))
+
+(defvar *logical-pathname-defaults*
+ (%make-logical-pathname (make-logical-host :name "BOGUS")
+ :unspecific
+ nil
+ nil
+ nil
+ nil))
--- /dev/null
+;;;; This implementation of RANDOM is based on the Mersenne Twister random
+;;;; number generator "MT19937" due to Matsumoto and Nishimura. See:
+;;;; Makoto Matsumoto and T. Nishimura, "Mersenne twister: A
+;;;; 623-dimensionally equidistributed uniform pseudorandom number
+;;;; generator.", ACM Transactions on Modeling and Computer Simulation,
+;;;; 1997, to appear.
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!KERNEL")
+
+(file-comment
+ "$Header$")
+\f
+;;;; RANDOM-STATEs
+
+(def!method make-load-form ((random-state random-state) &optional environment)
+ (make-load-form-saving-slots random-state :environment environment))
+
+;;; The state is stored in a (simple-array (unsigned-byte 32) (627))
+;;; wrapped in a random-state structure:
+;;;
+;;; 0-1: Constant matrix A. [0, #x9908b0df]
+;;; 2: Index k.
+;;; 3-626: State.
+
+;;; Generate and initialize a new random-state array. Index is
+;;; initialized to 1 and the states to 32bit integers excluding zero.
+;;;
+;;; Seed - A 32bit number, not zero.
+;;;
+;;; Apparently uses the generator Line 25 of Table 1 in
+;;; [KNUTH 1981, The Art of Computer Programming, Vol. 2 (2nd Ed.), pp102]
+(defun init-random-state (&optional (seed 4357) state)
+ (declare (type (integer 1 #xffffffff) seed))
+ (let ((state (or state (make-array 627 :element-type '(unsigned-byte 32)))))
+ (declare (type (simple-array (unsigned-byte 32) (627)) state))
+ (setf (aref state 1) #x9908b0df)
+ (setf (aref state 2) 1)
+ (setf (aref state 3) seed)
+ (do ((k 1 (1+ k)))
+ ((>= k 624))
+ (declare (type (mod 625) k))
+ (setf (aref state (+ 3 k))
+ (logand (* 69069 (aref state (+ 3 (1- k)))) #xffffffff)))
+ state))
+
+(defvar *random-state*)
+(defun !random-cold-init ()
+ (setf *random-state* (%make-random-state)))
+
+(defun make-random-state (&optional state)
+ #!+sb-doc
+ "Make a random state object. If State is not supplied, return a copy
+ of the default random state. If State is a random state, then return a
+ copy of it. If state is T then return a random state generated from
+ the universal time."
+ (flet ((copy-random-state (state)
+ (let ((state (random-state-state state))
+ (new-state
+ (make-array 627 :element-type '(unsigned-byte 32))))
+ (dotimes (i 627)
+ (setf (aref new-state i) (aref state i)))
+ (%make-random-state :state new-state))))
+ (cond ((not state) (copy-random-state *random-state*))
+ ((random-state-p state) (copy-random-state state))
+ ((eq state t)
+ (%make-random-state :state (init-random-state
+ (logand (get-universal-time)
+ #xffffffff))))
+ ;; FIXME: should be TYPE-ERROR?
+ (t (error "Argument is not a RANDOM-STATE, T or NIL: ~S" state)))))
+\f
+;;;; random entries
+
+;;; This function generates a 32bit integer between 0 and #xffffffff
+;;; inclusive.
+#!-sb-fluid (declaim (inline random-chunk))
+;;; portable implementation
+(defconstant mt19937-n 624)
+(defconstant mt19937-m 397)
+(defconstant mt19937-upper-mask #x80000000)
+(defconstant mt19937-lower-mask #x7fffffff)
+(defconstant mt19937-b #x9D2C5680)
+(defconstant mt19937-c #xEFC60000)
+#!-x86
+(defun random-mt19937-update (state)
+ (declare (type (simple-array (unsigned-byte 32) (627)) state)
+ (optimize (speed 3) (safety 0)))
+ (let ((y 0))
+ (declare (type (unsigned-byte 32) y))
+ (do ((kk 3 (1+ kk)))
+ ((>= kk (+ 3 (- mt19937-n mt19937-m))))
+ (declare (type (mod 628) kk))
+ (setf y (logior (logand (aref state kk) mt19937-upper-mask)
+ (logand (aref state (1+ kk)) mt19937-lower-mask)))
+ (setf (aref state kk) (logxor (aref state (+ kk mt19937-m))
+ (ash y -1) (aref state (logand y 1)))))
+ (do ((kk (+ (- mt19937-n mt19937-m) 3) (1+ kk)))
+ ((>= kk (+ (1- mt19937-n) 3)))
+ (declare (type (mod 628) kk))
+ (setf y (logior (logand (aref state kk) mt19937-upper-mask)
+ (logand (aref state (1+ kk)) mt19937-lower-mask)))
+ (setf (aref state kk) (logxor (aref state (+ kk (- mt19937-m mt19937-n)))
+ (ash y -1) (aref state (logand y 1)))))
+ (setf y (logior (logand (aref state (+ 3 (1- mt19937-n)))
+ mt19937-upper-mask)
+ (logand (aref state 3) mt19937-lower-mask)))
+ (setf (aref state (+ 3 (1- mt19937-n)))
+ (logxor (aref state (+ 3 (1- mt19937-m)))
+ (ash y -1) (aref state (logand y 1)))))
+ (values))
+#!-x86
+(defun random-chunk (state)
+ (declare (type random-state state))
+ (let* ((state (random-state-state state))
+ (k (aref state 2)))
+ (declare (type (mod 628) k))
+ (when (= k mt19937-n)
+ (random-mt19937-update state)
+ (setf k 0))
+ (setf (aref state 2) (1+ k))
+ (let ((y (aref state (+ 3 k))))
+ (declare (type (unsigned-byte 32) y))
+ (setf y (logxor y (ash y -11)))
+ (setf y (logxor y (ash (logand y (ash mt19937-b -7)) 7)))
+ (setf y (logxor y (ash (logand y (ash mt19937-c -15)) 15)))
+ (setf y (logxor y (ash y -18)))
+ y)))
+
+;;; Using inline VOP support, only available on the x86 so far.
+;;;
+;;; FIXME: It would be nice to have some benchmark numbers on this.
+;;; My inclination is to get rid of the nonportable implementation
+;;; unless the performance difference is just enormous.
+#!+x86
+(defun random-chunk (state)
+ (declare (type random-state state))
+ (sb!vm::random-mt19937 (random-state-state state)))
+\f
+;;; Handle the single or double float case of RANDOM. We generate a
+;;; float between 0.0 and 1.0 by clobbering the significand of 1.0
+;;; with random bits, then subtracting 1.0. This hides the fact that
+;;; we have a hidden bit.
+#!-sb-fluid (declaim (inline %random-single-float %random-double-float))
+(declaim (ftype (function ((single-float (0f0)) random-state)
+ (single-float 0f0))
+ %random-single-float))
+(defun %random-single-float (arg state)
+ (declare (type (single-float (0f0)) arg)
+ (type random-state state))
+ (* arg
+ (- (make-single-float
+ (dpb (ash (random-chunk state)
+ (- sb!vm:single-float-digits random-chunk-length))
+ sb!vm:single-float-significand-byte
+ (single-float-bits 1.0)))
+ 1.0)))
+(declaim (ftype (function ((double-float (0d0)) random-state)
+ (double-float 0d0))
+ %random-double-float))
+
+;;; 32-bit version
+#!+nil
+(defun %random-double-float (arg state)
+ (declare (type (double-float (0d0)) arg)
+ (type random-state state))
+ (* (float (random-chunk state) 1d0) (/ 1d0 (expt 2 32))))
+
+;;; 53-bit version
+#!-x86
+(defun %random-double-float (arg state)
+ (declare (type (double-float (0d0)) arg)
+ (type random-state state))
+ (* arg
+ (- (sb!impl::make-double-float
+ (dpb (ash (random-chunk state)
+ (- sb!vm:double-float-digits random-chunk-length
+ sb!vm:word-bits))
+ sb!vm:double-float-significand-byte
+ (sb!impl::double-float-high-bits 1d0))
+ (random-chunk state))
+ 1d0)))
+
+;;; using a faster inline VOP
+#!+x86
+(defun %random-double-float (arg state)
+ (declare (type (double-float (0d0)) arg)
+ (type random-state state))
+ (let ((state-vector (random-state-state state)))
+ (* arg
+ (- (sb!impl::make-double-float
+ (dpb (ash (sb!vm::random-mt19937 state-vector)
+ (- sb!vm:double-float-digits random-chunk-length
+ sb!vm:word-bits))
+ sb!vm:double-float-significand-byte
+ (sb!impl::double-float-high-bits 1d0))
+ (sb!vm::random-mt19937 state-vector))
+ 1d0))))
+
+#!+long-float
+(declaim #!-sb-fluid (inline %random-long-float))
+#!+long-float
+(declaim (ftype (function ((long-float (0l0)) random-state) (long-float 0l0))
+ %random-long-float))
+
+;;; using a faster inline VOP
+#!+(and long-float x86)
+(defun %random-long-float (arg state)
+ (declare (type (long-float (0l0)) arg)
+ (type random-state state))
+ (let ((state-vector (random-state-state state)))
+ (* arg
+ (- (sb!impl::make-long-float
+ (sb!impl::long-float-exp-bits 1l0)
+ (logior (sb!vm::random-mt19937 state-vector)
+ sb!vm:long-float-hidden-bit)
+ (sb!vm::random-mt19937 state-vector))
+ 1l0))))
+
+#!+(and long-float sparc)
+(defun %random-long-float (arg state)
+ (declare (type (long-float (0l0)) arg)
+ (type random-state state))
+ (* arg
+ (- (sb!impl::make-long-float
+ (sb!impl::long-float-exp-bits 1l0) ; X needs more work
+ (random-chunk state) (random-chunk state) (random-chunk state))
+ 1l0)))
+\f
+;;;; random integers
+
+(defun %random-integer (arg state)
+ (declare (type (integer 1) arg) (type random-state state))
+ (let ((shift (- random-chunk-length random-integer-overlap)))
+ (do ((bits (random-chunk state)
+ (logxor (ash bits shift) (random-chunk state)))
+ (count (+ (integer-length arg)
+ (- random-integer-extra-bits shift))
+ (- count shift)))
+ ((minusp count)
+ (rem bits arg))
+ (declare (fixnum count)))))
+
+(defun random (arg &optional (state *random-state*))
+ #!+sb-doc
+ "Generate a uniformly distributed pseudo-random number between zero
+ and Arg. State, if supplied, is the random state to use."
+ (declare (inline %random-single-float %random-double-float
+ #!+long-float %long-float))
+ (cond
+ ((and (fixnump arg) (<= arg random-fixnum-max) #!+high-security (> arg 0))
+ (rem (random-chunk state) arg))
+ ((and (typep arg 'single-float) #!+high-security (> arg 0.0S0))
+ (%random-single-float arg state))
+ ((and (typep arg 'double-float) #!+high-security (> arg 0.0D0))
+ (%random-double-float arg state))
+ #!+long-float
+ ((and (typep arg 'long-float) #!+high-security (> arg 0.0L0))
+ (%random-long-float arg state))
+ ((and (integerp arg) #!+high-security (> arg 0))
+ (%random-integer arg state))
+ (t
+ (error 'simple-type-error
+ :expected-type '(or (integer 1) (float (0))) :datum arg
+ :format-control "Argument is not a positive integer or a positive float: ~S"
+ :format-arguments (list arg)))))
--- /dev/null
+;;;; support for System Area Pointers (SAPs) in the target machine
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!SYS")
+;;; FIXME: Shouldn't these be IN-PACKAGE SB!KERNEL instead? (They're
+;;; not dependent on the OS, only on the CPU architecture.)
+
+(file-comment
+ "$Header$")
+\f
+;;;; primitive SAP operations
+
+(defun sap< (x y)
+ #!+sb-doc
+ "Return T iff the SAP X points to a smaller address then the SAP Y."
+ (declare (type system-area-pointer x y))
+ (sap< x y))
+
+(defun sap<= (x y)
+ #!+sb-doc
+ "Return T iff the SAP X points to a smaller or the same address as
+ the SAP Y."
+ (declare (type system-area-pointer x y))
+ (sap<= x y))
+
+(defun sap= (x y)
+ #!+sb-doc
+ "Return T iff the SAP X points to the same address as the SAP Y."
+ (declare (type system-area-pointer x y))
+ (sap= x y))
+
+(defun sap>= (x y)
+ #!+sb-doc
+ "Return T iff the SAP X points to a larger or the same address as
+ the SAP Y."
+ (declare (type system-area-pointer x y))
+ (sap>= x y))
+
+(defun sap> (x y)
+ #!+sb-doc
+ "Return T iff the SAP X points to a larger address then the SAP Y."
+ (declare (type system-area-pointer x y))
+ (sap> x y))
+
+(defun sap+ (sap offset)
+ #!+sb-doc
+ "Return a new sap OFFSET bytes from SAP."
+ (declare (type system-area-pointer sap)
+ (fixnum offset))
+ (sap+ sap offset))
+
+(defun sap- (sap1 sap2)
+ #!+sb-doc
+ "Return the byte offset between SAP1 and SAP2."
+ (declare (type system-area-pointer sap1 sap2))
+ (sap- sap1 sap2))
+
+(defun sap-int (sap)
+ #!+sb-doc
+ "Converts a System Area Pointer into an integer."
+ (declare (type system-area-pointer sap))
+ (sap-int sap))
+
+(defun int-sap (int)
+ #!+sb-doc
+ "Converts an integer into a System Area Pointer."
+ (declare (type sap-int-type int))
+ (int-sap int))
+
+(defun sap-ref-8 (sap offset)
+ #!+sb-doc
+ "Returns the 8-bit byte at OFFSET bytes from SAP."
+ (declare (type system-area-pointer sap)
+ (fixnum offset))
+ (sap-ref-8 sap offset))
+
+(defun sap-ref-16 (sap offset)
+ #!+sb-doc
+ "Returns the 16-bit word at OFFSET bytes from SAP."
+ (declare (type system-area-pointer sap)
+ (fixnum offset))
+ (sap-ref-16 sap offset))
+
+(defun sap-ref-32 (sap offset)
+ #!+sb-doc
+ "Returns the 32-bit dualword at OFFSET bytes from SAP."
+ (declare (type system-area-pointer sap)
+ (fixnum offset))
+ (sap-ref-32 sap offset))
+
+#!+alpha
+(defun sap-ref-64 (sap offset)
+ #!+sb-doc
+ "Returns the 64-bit quadword at OFFSET bytes from SAP."
+ (declare (type system-area-pointer sap)
+ (fixnum offset))
+ (sap-ref-64 sap offset))
+
+(defun sap-ref-sap (sap offset)
+ #!+sb-doc
+ "Returns the 32-bit system-area-pointer at OFFSET bytes from SAP."
+ (declare (type system-area-pointer sap)
+ (fixnum offset))
+ (sap-ref-sap sap offset))
+
+(defun sap-ref-single (sap offset)
+ #!+sb-doc
+ "Returns the 32-bit single-float at OFFSET bytes from SAP."
+ (declare (type system-area-pointer sap)
+ (fixnum offset))
+ (sap-ref-single sap offset))
+
+(defun sap-ref-double (sap offset)
+ #!+sb-doc
+ "Returns the 64-bit double-float at OFFSET bytes from SAP."
+ (declare (type system-area-pointer sap)
+ (fixnum offset))
+ (sap-ref-double sap offset))
+
+#!+(or x86 long-float)
+(defun sap-ref-long (sap offset)
+ #!+sb-doc
+ "Returns the long-float at OFFSET bytes from SAP."
+ (declare (type system-area-pointer sap)
+ (fixnum offset))
+ (sap-ref-long sap offset))
+
+(defun signed-sap-ref-8 (sap offset)
+ #!+sb-doc
+ "Returns the signed 8-bit byte at OFFSET bytes from SAP."
+ (declare (type system-area-pointer sap)
+ (fixnum offset))
+ (signed-sap-ref-8 sap offset))
+
+(defun signed-sap-ref-16 (sap offset)
+ #!+sb-doc
+ "Returns the signed 16-bit word at OFFSET bytes from SAP."
+ (declare (type system-area-pointer sap)
+ (fixnum offset))
+ (signed-sap-ref-16 sap offset))
+
+(defun signed-sap-ref-32 (sap offset)
+ #!+sb-doc
+ "Returns the signed 32-bit dualword at OFFSET bytes from SAP."
+ (declare (type system-area-pointer sap)
+ (fixnum offset))
+ (signed-sap-ref-32 sap offset))
+
+#!+alpha
+(defun signed-sap-ref-64 (sap offset)
+ #!+sb-doc
+ "Returns the signed 64-bit quadword at OFFSET bytes from SAP."
+ (declare (type system-area-pointer sap)
+ (fixnum offset))
+ (signed-sap-ref-64 sap offset))
+
+(defun %set-sap-ref-8 (sap offset new-value)
+ (declare (type system-area-pointer sap)
+ (fixnum offset)
+ (type (unsigned-byte 8) new-value))
+ (setf (sap-ref-8 sap offset) new-value))
+
+(defun %set-sap-ref-16 (sap offset new-value)
+ (declare (type system-area-pointer sap)
+ (fixnum offset)
+ (type (unsigned-byte 16) new-value))
+ (setf (sap-ref-16 sap offset) new-value))
+
+(defun %set-sap-ref-32 (sap offset new-value)
+ (declare (type system-area-pointer sap)
+ (fixnum offset)
+ (type (unsigned-byte 32) new-value))
+ (setf (sap-ref-32 sap offset) new-value))
+
+#!+alpha
+(defun %set-sap-ref-64 (sap offset new-value)
+ (declare (type system-area-pointer sap)
+ (fixnum offset)
+ (type (unsigned-byte 64) new-value))
+ (setf (sap-ref-64 sap offset) new-value))
+
+(defun %set-signed-sap-ref-8 (sap offset new-value)
+ (declare (type system-area-pointer sap)
+ (fixnum offset)
+ (type (signed-byte 8) new-value))
+ (setf (signed-sap-ref-8 sap offset) new-value))
+
+(defun %set-signed-sap-ref-16 (sap offset new-value)
+ (declare (type system-area-pointer sap)
+ (fixnum offset)
+ (type (signed-byte 16) new-value))
+ (setf (signed-sap-ref-16 sap offset) new-value))
+
+(defun %set-signed-sap-ref-32 (sap offset new-value)
+ (declare (type system-area-pointer sap)
+ (fixnum offset)
+ (type (signed-byte 32) new-value))
+ (setf (signed-sap-ref-32 sap offset) new-value))
+
+#!+alpha
+(defun %set-signed-sap-ref-64 (sap offset new-value)
+ (declare (type system-area-pointer sap)
+ (fixnum offset)
+ (type (signed-byte 64) new-value))
+ (setf (signed-sap-ref-64 sap offset) new-value))
+
+(defun %set-sap-ref-sap (sap offset new-value)
+ (declare (type system-area-pointer sap new-value)
+ (fixnum offset))
+ (setf (sap-ref-sap sap offset) new-value))
+
+(defun %set-sap-ref-single (sap offset new-value)
+ (declare (type system-area-pointer sap)
+ (fixnum offset)
+ (type single-float new-value))
+ (setf (sap-ref-single sap offset) new-value))
+
+(defun %set-sap-ref-double (sap offset new-value)
+ (declare (type system-area-pointer sap)
+ (fixnum offset)
+ (type double-float new-value))
+ (setf (sap-ref-double sap offset) new-value))
+
+#!+long-float
+(defun %set-sap-ref-long (sap offset new-value)
+ (declare (type system-area-pointer sap)
+ (fixnum offset)
+ (type long-float new-value))
+ (setf (sap-ref-long sap offset) new-value))
+\f
+;;;; system memory allocation
+
+(sb!alien:def-alien-routine ("os_allocate" allocate-system-memory)
+ system-area-pointer
+ (bytes sb!c-call:unsigned-long))
+
+(sb!alien:def-alien-routine ("os_allocate_at" allocate-system-memory-at)
+ system-area-pointer
+ (address system-area-pointer)
+ (bytes sb!c-call:unsigned-long))
+
+(sb!alien:def-alien-routine ("os_reallocate" reallocate-system-memory)
+ system-area-pointer
+ (old system-area-pointer)
+ (old-size sb!c-call:unsigned-long)
+ (new-size sb!c-call:unsigned-long))
+
+(sb!alien:def-alien-routine ("os_deallocate" deallocate-system-memory)
+ sb!c-call:void
+ (addr system-area-pointer)
+ (bytes sb!c-call:unsigned-long))
--- /dev/null
+;;;; code for handling UNIX signals
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!UNIX")
+
+(file-comment
+ "$Header$")
+
+;;; These should probably be somewhere, but I don't know where.
+(defconstant sig_dfl 0)
+(defconstant sig_ign 1)
+\f
+;;;; system calls that deal with signals
+
+#!-sb-fluid (declaim (inline real-unix-kill))
+(sb!alien:def-alien-routine ("kill" real-unix-kill) sb!c-call:int
+ (pid sb!c-call:int)
+ (signal sb!c-call:int))
+
+(defun unix-kill (pid signal)
+ #!+sb-doc
+ "Unix-kill sends the signal signal to the process with process
+ id pid. Signal should be a valid signal number or a keyword of the
+ standard UNIX signal name."
+ (real-unix-kill pid (unix-signal-number signal)))
+
+#!-sb-fluid (declaim (inline real-unix-killpg))
+(sb!alien:def-alien-routine ("killpg" real-unix-killpg) sb!c-call:int
+ (pgrp sb!c-call:int)
+ (signal sb!c-call:int))
+
+(defun unix-killpg (pgrp signal)
+ #!+sb-doc
+ "Unix-killpg sends the signal signal to the all the process in process
+ group PGRP. Signal should be a valid signal number or a keyword of
+ the standard UNIX signal name."
+ (real-unix-killpg pgrp (unix-signal-number signal)))
+
+(sb!alien:def-alien-routine ("sigblock" unix-sigblock) sb!c-call:unsigned-long
+ #!+sb-doc
+ "Unix-sigblock cause the signals specified in mask to be
+ added to the set of signals currently being blocked from
+ delivery. The macro sigmask is provided to create masks."
+ (mask sb!c-call:unsigned-long))
+
+(sb!alien:def-alien-routine ("sigpause" unix-sigpause) sb!c-call:void
+ #!+sb-doc
+ "Unix-sigpause sets the set of masked signals to its argument
+ and then waits for a signal to arrive, restoring the previous
+ mask upon its return."
+ (mask sb!c-call:unsigned-long))
+
+(sb!alien:def-alien-routine ("sigsetmask" unix-sigsetmask)
+ sb!c-call:unsigned-long
+ #!+sb-doc
+ "Unix-sigsetmask sets the current set of masked signals (those
+ begin blocked from delivery) to the argument. The macro sigmask
+ can be used to create the mask. The previous value of the signal
+ mask is returned."
+ (mask sb!c-call:unsigned-long))
+\f
+;;;; C routines that actually do all the work of establishing signal handlers
+(sb!alien:def-alien-routine ("install_handler" install-handler)
+ sb!c-call:unsigned-long
+ (signal sb!c-call:int)
+ (handler sb!c-call:unsigned-long))
+\f
+;;;; interface to enabling and disabling signal handlers
+
+(defun enable-interrupt (signal handler)
+ (declare (type (or function (member :default :ignore)) handler))
+ (without-gcing
+ (let ((result (install-handler (unix-signal-number signal)
+ (case handler
+ (:default sig_dfl)
+ (:ignore sig_ign)
+ (t
+ (sb!kernel:get-lisp-obj-address
+ handler))))))
+ (cond ((= result sig_dfl) :default)
+ ((= result sig_ign) :ignore)
+ (t (the function (sb!kernel:make-lisp-obj result)))))))
+
+(defun default-interrupt (signal)
+ (enable-interrupt signal :default))
+
+(defun ignore-interrupt (signal)
+ (enable-interrupt signal :ignore))
+\f
+;;;; default LISP signal handlers
+;;;;
+;;;; Most of these just call ERROR to report the presence of the signal.
+
+(eval-when (:compile-toplevel :execute)
+ (sb!xc:defmacro define-signal-handler (name
+ what
+ &optional (function 'error))
+ `(defun ,name (signal info context)
+ (declare (ignore signal info))
+ (declare (type system-area-pointer context))
+ (/show "in Lisp-level signal handler" (sap-int context))
+ (,function ,(concatenate 'simple-string what " at #X~X")
+ (with-alien ((context (* os-context-t) context))
+ (sap-int (sb!vm:context-pc context)))))))
+
+(define-signal-handler sigint-handler "interrupted" break)
+(define-signal-handler sigill-handler "illegal instruction")
+(define-signal-handler sigtrap-handler "breakpoint/trap")
+(define-signal-handler sigiot-handler "SIGIOT")
+#!-linux
+(define-signal-handler sigemt-handler "SIGEMT")
+(define-signal-handler sigbus-handler "bus error")
+(define-signal-handler sigsegv-handler "segmentation violation")
+#!-linux
+(define-signal-handler sigsys-handler "bad argument to a system call")
+(define-signal-handler sigpipe-handler "SIGPIPE")
+(define-signal-handler sigalrm-handler "SIGALRM")
+
+(defun sigquit-handler (signal code context)
+ (declare (ignore signal code context))
+ (throw 'sb!impl::top-level-catcher nil))
+
+(defun sb!kernel:signal-cold-init-or-reinit ()
+ #!+sb-doc
+ "Enable all the default signals that Lisp knows how to deal with."
+ (enable-interrupt :sigint #'sigint-handler)
+ (enable-interrupt :sigquit #'sigquit-handler)
+ (enable-interrupt :sigill #'sigill-handler)
+ (enable-interrupt :sigtrap #'sigtrap-handler)
+ (enable-interrupt :sigiot #'sigiot-handler)
+ #!-linux
+ (enable-interrupt :sigemt #'sigemt-handler)
+ (enable-interrupt :sigfpe #'sb!vm:sigfpe-handler)
+ (enable-interrupt :sigbus #'sigbus-handler)
+ (enable-interrupt :sigsegv #'sigsegv-handler)
+ #!-linux
+ (enable-interrupt :sigsys #'sigsys-handler)
+ (enable-interrupt :sigpipe #'sigpipe-handler)
+ (enable-interrupt :sigalrm #'sigalrm-handler)
+ nil)
+\f
+;;; stale code which I'm insufficiently motivated to test -- WHN 19990714
+#|
+;;;; WITH-ENABLED-INTERRUPTS
+
+(defmacro with-enabled-interrupts (interrupt-list &body body)
+ #!+sb-doc
+ "With-enabled-interrupts ({(interrupt function)}*) {form}*
+ Establish function as a handler for the Unix signal interrupt which
+ should be a number between 1 and 31 inclusive."
+ (let ((il (gensym))
+ (it (gensym)))
+ `(let ((,il NIL))
+ (unwind-protect
+ (progn
+ ,@(do* ((item interrupt-list (cdr item))
+ (intr (caar item) (caar item))
+ (ifcn (cadar item) (cadar item))
+ (forms NIL))
+ ((null item) (nreverse forms))
+ (when (symbolp intr)
+ (setq intr (symbol-value intr)))
+ (push `(push `(,,intr ,(enable-interrupt ,intr ,ifcn)) ,il)
+ forms))
+ ,@body)
+ (dolist (,it (nreverse ,il))
+ (enable-interrupt (car ,it) (cadr ,it)))))))
+|#
--- /dev/null
+;;;; hashing functions
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!IMPL")
+
+(file-comment
+ "$Header$")
+
+;;; the depthoid explored when calculating hash values
+;;;
+;;; "Depthoid" here is a sort of mixture of what Common Lisp ordinarily calls
+;;; depth and what Common Lisp ordinarily calls length; it's incremented either
+;;; when we descend into a compound object or when we step through elements of
+;;; a compound object.
+(eval-when (:compile-toplevel :load-toplevel :execute)
+(defconstant +max-hash-depthoid+ 4)
+) ; EVAL-WHEN
+\f
+;;;; mixing hash values
+
+;;; a function for mixing hash values
+;;;
+;;; desiderata:
+;;; * Non-commutativity keeps us from hashing e.g. #(1 5) to the
+;;; same value as #(5 1), and ending up in real trouble in some
+;;; special cases like bit vectors the way that CMUCL SXHASH 18b
+;;; does. (Under CMUCL 18b, SXHASH of any bit vector is 1..)
+;;; * We'd like to scatter our hash values the entire possible range
+;;; of values instead of hashing small or common key values (like
+;;; 2 and NIL and #\a) to small FIXNUMs the way that the CMUCL 18b
+;;; SXHASH function does, again helping to avoid pathologies like
+;;; hashing all bit vectors to 1.
+;;; * We'd like this to be simple and fast, too.
+;;;
+;;; FIXME: Should this be INLINE?
+(declaim (ftype (function ((and fixnum unsigned-byte)
+ (and fixnum unsigned-byte))
+ (and fixnum unsigned-byte)) mix))
+(defun mix (x y)
+ ;; FIXME: We wouldn't need the nasty (SAFETY 0) here if the compiler
+ ;; were smarter about optimizing ASH. (Without the THE FIXNUM below,
+ ;; and the (SAFETY 0) declaration here to get the compiler to trust
+ ;; it, the sbcl-0.5.0m cross-compiler running under Debian
+ ;; cmucl-2.4.17 turns the ASH into a full call, requiring the
+ ;; UNSIGNED-BYTE 32 argument to be coerced to a bignum, requiring
+ ;; consing, and thus generally obliterating performance.)
+ (declare (optimize (speed 3) (safety 0)))
+ (declare (type (and fixnum unsigned-byte) x y))
+ ;; the ideas here:
+ ;; * Bits diffuse in both directions (shifted left by up to 2 places
+ ;; in the calculation of XY, and shifted right by up to 5 places
+ ;; by the ASH).
+ ;; * The #'+ and #'LOGXOR operations don't commute with each other,
+ ;; so different bit patterns are mixed together as they shift
+ ;; past each other.
+ ;; * The arbitrary constant in the #'LOGXOR expression is intended
+ ;; to help break up any weird anomalies we might otherwise get
+ ;; when hashing highly regular patterns.
+ ;; (These are vaguely like the ideas used in many cryptographic
+ ;; algorithms, but we're not pushing them hard enough here for them
+ ;; to be cryptographically strong.)
+ (let* ((xy (+ (* x 3) y)))
+ (declare (type (unsigned-byte 32) xy))
+ (the (and fixnum unsigned-byte)
+ (logand most-positive-fixnum
+ (logxor 441516657
+ xy
+ (the fixnum (ash xy -5)))))))
+\f
+;;;; hashing strings
+;;;;
+;;;; Note that this operation is used in compiler symbol table lookups, so we'd
+;;;; like it to be fast.
+
+#!-sb-fluid (declaim (inline %sxhash-substring))
+(defun %sxhash-substring (string &optional (count (length string)))
+ ;; FIXME: As in MIX above, we wouldn't need (SAFETY 0) here if the
+ ;; cross-compiler were smarter about ASH, but we need it for sbcl-0.5.0m.
+ (declare (optimize (speed 3) (safety 0)))
+ (declare (type string string))
+ (declare (type index count))
+ (let ((result 408967240))
+ (declare (type fixnum result))
+ (dotimes (i count)
+ (declare (type index i))
+ (mixf result
+ (the fixnum
+ (ash (char-code (aref string i)) 5))))
+ result))
+;;; test:
+;;; (let ((ht (make-hash-table :test 'equal)))
+;;; (do-all-symbols (symbol)
+;;; (let* ((string (symbol-name symbol))
+;;; (hash (%sxhash-substring string)))
+;;; (if (gethash hash ht)
+;;; (unless (string= (gethash hash ht) string)
+;;; (format t "collision: ~S ~S~%" string (gethash hash ht)))
+;;; (setf (gethash hash ht) string))))
+;;; (format t "final count=~D~%" (hash-table-count ht)))
+
+(defun %sxhash-simple-string (x)
+ (declare (optimize speed))
+ (declare (type simple-string x))
+ (%sxhash-substring x))
+
+(defun %sxhash-simple-substring (x count)
+ (declare (optimize speed))
+ (declare (type simple-string x))
+ (declare (type index count))
+ (%sxhash-substring x count))
+\f
+;;;; the SXHASH function
+
+(defun sxhash (x)
+ (labels ((sxhash-number (x)
+ (etypecase x
+ (fixnum (sxhash x)) ; through DEFTRANSFORM
+ (integer (sb!bignum:sxhash-bignum x))
+ (single-float (sxhash x)) ; through DEFTRANSFORM
+ (double-float (sxhash x)) ; through DEFTRANSFORM
+ #!+long-float (long-float (error "stub: no LONG-FLOAT"))
+ (ratio (let ((result 127810327))
+ (declare (type fixnum result))
+ (mixf result (sxhash-number (numerator x)))
+ (mixf result (sxhash-number (denominator x)))
+ result))
+ (complex (let ((result 535698211))
+ (declare (type fixnum result))
+ (mixf result (sxhash-number (realpart x)))
+ (mixf result (sxhash-number (imagpart x)))
+ result))))
+ (sxhash-recurse (x &optional (depthoid +max-hash-depthoid+))
+ (declare (type index depthoid))
+ (typecase x
+ (list
+ (if (plusp depthoid)
+ (mix (sxhash-recurse (car x) (1- depthoid))
+ (sxhash-recurse (cdr x) (1- depthoid)))
+ 261835505))
+ (instance
+ (if (typep x 'structure-object)
+ (logxor 422371266
+ (sxhash ; through DEFTRANSFORM
+ (class-name (layout-class (%instance-layout x)))))
+ 309518995))
+ (symbol (sxhash x)) ; through DEFTRANSFORM
+ (number (sxhash-number x))
+ (array
+ (typecase x
+ (simple-string (sxhash x)) ; through DEFTRANSFORM
+ (string (%sxhash-substring x))
+ (bit-vector (let ((result 410823708))
+ (declare (type fixnum result))
+ (dotimes (i (min depthoid (length x)))
+ (mixf result (aref x i)))
+ result))
+ (t (logxor 191020317 (sxhash (array-rank x))))))
+ (character
+ (logxor 72185131
+ (sxhash (char-code x)))) ; through DEFTRANSFORM
+ (t 42))))
+ (sxhash-recurse x)))
+\f
+;;;; the PSXHASH function
+
+;;;; FIXME: This code does a lot of unnecessary full calls. It could be made
+;;;; more efficient (in both time and space) by rewriting it along the lines
+;;;; of the SXHASH code above.
+
+;;; like SXHASH, but for EQUALP hashing instead of EQUAL hashing
+(defun psxhash (key &optional (depthoid +max-hash-depthoid+))
+ (declare (optimize speed))
+ (declare (type (integer 0 #.+max-hash-depthoid+) depthoid))
+ ;; Note: You might think it would be cleaner to use the ordering given in the
+ ;; table from Figure 5-13 in the EQUALP section of the ANSI specification
+ ;; here. So did I, but that is a snare for the unwary! Nothing in the ANSI
+ ;; spec says that HASH-TABLE can't be a STRUCTURE-OBJECT, and in fact our
+ ;; HASH-TABLEs *are* STRUCTURE-OBJECTs, so we need to pick off the special
+ ;; HASH-TABLE behavior before we fall through to the generic STRUCTURE-OBJECT
+ ;; comparison behavior.
+ (typecase key
+ (array (array-psxhash key depthoid))
+ (hash-table (hash-table-psxhash key))
+ (structure-object (structure-object-psxhash key depthoid))
+ (list (list-psxhash key depthoid))
+ (number (number-psxhash key))
+ (character (sxhash (char-upcase key)))
+ (t (sxhash key))))
+
+(defun array-psxhash (key depthoid)
+ (declare (optimize speed))
+ (declare (type array key))
+ (declare (type (integer 0 #.+max-hash-depthoid+) depthoid))
+ (typecase key
+ ;; VECTORs have to be treated specially because ANSI specifies
+ ;; that we must respect fill pointers.
+ (vector
+ (macrolet ((frob ()
+ '(let ((result 572539))
+ (declare (type fixnum result))
+ (mixf result (length key))
+ (dotimes (i (min depthoid (length key)))
+ (declare (type fixnum i))
+ (mixf result
+ (psxhash (aref key i)
+ (- depthoid 1 i))))
+ result)))
+ ;; CMU can compile SIMPLE-ARRAY operations so much more efficiently
+ ;; than the general case that it's probably worth picking off the
+ ;; common special cases.
+ (typecase key
+ (simple-string
+ ;;(format t "~&SIMPLE-STRING special case~%")
+ (frob))
+ (simple-vector
+ ;;(format t "~&SIMPLE-VECTOR special case~%")
+ (frob))
+ (t (frob)))))
+ ;; Any other array can be hashed by working with its underlying
+ ;; one-dimensional physical representation.
+ (t
+ (let ((result 60828))
+ (declare (type fixnum result))
+ (dotimes (i (min depthoid (array-rank key)))
+ (mixf result (array-dimension key i)))
+ (dotimes (i (min depthoid (array-total-size key)))
+ (mixf result
+ (psxhash (row-major-aref key i)
+ (- depthoid 1 i))))
+ result))))
+
+(defun structure-object-psxhash (key depthoid)
+ (declare (optimize speed))
+ (declare (type structure-object key))
+ (declare (type (integer 0 #.+max-hash-depthoid+) depthoid))
+ (let* ((layout (%instance-layout key)) ; i.e. slot #0
+ (length (layout-length layout))
+ (class (layout-class layout))
+ (name (class-name class))
+ (result (mix (sxhash name) (the fixnum 79867))))
+ (declare (type fixnum result))
+ (dotimes (i (min depthoid (1- length)))
+ (declare (type fixnum i))
+ (let ((j (1+ i))) ; skipping slot #0, which is for LAYOUT
+ (declare (type fixnum j))
+ (mixf result
+ (psxhash (%instance-ref key j)
+ (1- depthoid)))))
+ result))
+
+(defun list-psxhash (key depthoid)
+ (declare (optimize speed))
+ (declare (type list key))
+ (declare (type (integer 0 #.+max-hash-depthoid+) depthoid))
+ (cond ((null key)
+ (the fixnum 480929))
+ ((zerop depthoid)
+ (the fixnum 779578))
+ (t
+ (mix (psxhash (car key) (1- depthoid))
+ (psxhash (cdr key) (1- depthoid))))))
+
+(defun hash-table-psxhash (key)
+ (declare (optimize speed))
+ (declare (type hash-table key))
+ (let ((result 103924836))
+ (declare (type fixnum result))
+ (mixf result (hash-table-count key))
+ (mixf result (sxhash (hash-table-test key)))
+ result))
+
+(defun number-psxhash (key)
+ (declare (optimize speed))
+ (declare (type number key))
+ (flet ((sxhash-double-float (val)
+ (declare (type double-float val))
+ ;; FIXME: Check to make sure that the DEFTRANSFORM kicks in and the
+ ;; resulting code works without consing. (In Debian cmucl 2.4.17,
+ ;; it didn't.)
+ (sxhash val)))
+ (etypecase key
+ (integer (sxhash key))
+ (float (macrolet ((frob (type)
+ (let ((lo (coerce most-negative-fixnum type))
+ (hi (coerce most-positive-fixnum type)))
+ `(cond (;; This clause allows FIXNUM-sized integer
+ ;; values to be handled without consing.
+ (<= ,lo key ,hi)
+ (multiple-value-bind (q r)
+ (floor (the (,type ,lo ,hi) key))
+ (if (zerop (the ,type r))
+ (sxhash q)
+ (sxhash-double-float
+ (coerce key 'double-float)))))
+ (t
+ (multiple-value-bind (q r) (floor key)
+ (if (zerop (the ,type r))
+ (sxhash q)
+ (sxhash-double-float
+ (coerce key 'double-float)))))))))
+ (etypecase key
+ (single-float (frob single-float))
+ (double-float (frob double-float))
+ (short-float (frob short-float))
+ (long-float (error "LONG-FLOAT not currently supported")))))
+ (rational (if (and (<= most-negative-double-float
+ key
+ most-positive-double-float)
+ (= (coerce key 'double-float) key))
+ (sxhash-double-float (coerce key 'double-float))
+ (sxhash key)))
+ (complex (if (zerop (imagpart key))
+ (number-psxhash (realpart key))
+ (let ((result 330231))
+ (declare (type fixnum result))
+ (mixf result (number-psxhash (realpart key)))
+ (mixf result (number-psxhash (imagpart key)))
+ result))))))
+
+;;; SXHASH and PSXHASH should distribute hash values well over the
+;;; space of possible values, so that collisions between the hash values
+;;; of unequal objects should be very uncommon.
+;;;
+;;; FIXME: These tests should be enabled once the rest of the system is
+;;; stable. (For now, I don't want to mess with things like making sure
+;;; that bignums are hashed uniquely.)
+;;;#!+sb-test
+#+nil
+(let* ((test-cases `((0 . 1)
+ (0 . 1)
+ (1 . 0)
+ ((1 . 0) (0 . 0))
+ ((0 . 1) (0 . 0))
+ ((0 . 0) (1 . 0))
+ ((0 . 0) (0 . 1))
+ #((1 . 0) (0 . 0))
+ #((0 . 1) (0 . 0))
+ #((0 . 0) (1 . 0))
+ #((0 . 0) (0 . 1))
+ #((1 . 0) (0 . 0))
+ #((0 1) (0 0))
+ #((0 0) (1 0))
+ #((0 0) (0 1))
+ #(#(1 0) (0 0))
+ #(#(0 1) (0 0))
+ #(#(0 0) (1 0))
+ #(#(0 0) (0 1))
+ #(#*00 #*10)
+ #(#(0 0) (0 1.0d0))
+ #(#(-0.0d0 0) (1.0 0))
+ ;; KLUDGE: Some multi-dimensional array test cases would
+ ;; be good here too, but currently SBCL isn't smart enough
+ ;; to dump them as literals, and I'm too lazy to make
+ ;; code to create them at run time. -- WHN 20000111
+ 44 44.0 44.0d0
+ 44 44.0 44.0d0
+ -44 -44.0 -44.0d0
+ 0 0.0 0.0d0
+ -0 -0.0 -0.0d0
+ -121 -121.0 -121.0d0
+ 3/4 0.75 0.75d0
+ -3/4 -0.75 -0.75d0
+ 44.1 44.1d0
+ 45 45.0 45.0d0
+ ,(expt 2 33) ,(expt 2.0 33) ,(expt 2.0d0 33)
+ ,(- (expt 1/2 50)) ,(- (expt 0.5 50)) ,(- (expt 0.5d0 50))
+ ,(- (expt 1/2 50)) ,(- (expt 0.5 50)) ,(- (expt 0.5d0 50))
+ #c(1.0 2.0) #c(1 2.0) #c(1.5 -3/2) #c(3/2 -3/2) #c(0 1)
+ #c(1.0 2.0) #c(1 2.0) #c(1.5 -3/2) #c(3/2 -3/2) #c(0 1)
+ ,(make-hash-table)
+ ,(make-hash-table :test 'equal)
+ "abc" "ABC" "aBc" 'abc #(#\a #\b #\c) #(a b c) #("A" b c)
+ "abcc"
+ "" #* #() () (()) #(()) (#())
+ "" #* #() () (()) #(()) (#())
+ #\x #\X #\*
+ #\x #\X #\*)))
+ (dolist (i test-cases)
+ (unless (typep (sxhash i) '(and fixnum unsigned-byte))
+ (error "bad SXHASH behavior for ~S" i))
+ (unless (typep (psxhash i) '(and fixnum unsigned-byte))
+ (error "bad PSXHASH behavior for ~S" i))
+ (dolist (j test-cases)
+ (flet ((t->boolean (x) (if x t nil)))
+ ;; Note: It's possible that a change to the hashing algorithm could
+ ;; leave it correct but still cause this test to bomb by causing an
+ ;; unlucky random collision. That's not very likely (since there are
+ ;; (EXPT 2 29) possible hash values and only on the order of 100 test
+ ;; cases, but it's probably worth checking if you are getting a
+ ;; mystifying error from this test.
+ (unless (eq (t->boolean (equal i j))
+ (t->boolean (= (sxhash i) (sxhash j))))
+ (error "bad SXHASH behavior for ~S ~S" i j))
+ (unless (eq (t->boolean (equalp i j))
+ (t->boolean (= (psxhash i) (psxhash j))))
+ (error "bad PSXHASH behavior for ~S ~S" i j))))))
+
+;;; FIXME: Test that the the hash functions can deal with common cases without
+;;; consing.
+;(defun consless-test ()
+; (dotimes (j 100000)
+; (dolist (i '("yo" #(1 2 3) #2A((1 2) (1 2)) (1 2 (3)) 1 1.0 1.0d0))
+; (psxhash i))))
--- /dev/null
+;;;; type-related stuff which exists only in the target SBCL runtime
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!KERNEL")
+
+(file-comment
+ "$Header$")
+
+(!begin-collecting-cold-init-forms)
+\f
+;;; Just call %TYPEP.
+;;;
+;;; Note that when cross-compiling, SB!XC:TYPEP is interpreted as
+;;; a test that the host Lisp object OBJECT translates to a target SBCL
+;;; type TYPE. (This behavior is needed e.g. to test for the validity of
+;;; numeric subtype bounds read when cross-compiling.)
+;;;
+;;; KLUDGE: In classic CMU CL this was wrapped in a (DECLAIM (START-BLOCK
+;;; TYPEP %TYPEP CLASS-CELL-TYPEP)) to make calls efficient. Once I straighten
+;;; out bootstrapping and cross-compiling issues it'd likely be a good idea to
+;;; do this again. -- WHN 19990413
+(defun typep (object type)
+ #!+sb-doc
+ "Return T iff OBJECT is of type TYPE."
+ (%typep object type))
+
+;;; If Type is a type that we can do a compile-time test on, then return the
+;;; whether the object is of that type as the first value and second value
+;;; true. Otherwise return NIL, NIL.
+;;;
+;;; We give up on unknown types and pick off FUNCTION and UNION types. For
+;;; structure types, we require that the type be defined in both the current
+;;; and compiler environments, and that the INCLUDES be the same.
+(defun ctypep (obj type)
+ (declare (type ctype type))
+ (etypecase type
+ ((or numeric-type
+ named-type
+ member-type
+ array-type
+ sb!xc:built-in-class)
+ (values (%typep obj type) t))
+ (sb!xc:class
+ (if (if (csubtypep type (specifier-type 'funcallable-instance))
+ (funcallable-instance-p obj)
+ (typep obj 'instance))
+ (if (eq (class-layout type)
+ (info :type :compiler-layout (sb!xc:class-name type)))
+ (values (sb!xc:typep obj type) t)
+ (values nil nil))
+ (values nil t)))
+ (union-type
+ (dolist (mem (union-type-types type) (values nil t))
+ (multiple-value-bind (val win) (ctypep obj mem)
+ (unless win (return (values nil nil)))
+ (when val (return (values t t))))))
+ (function-type
+ (values (functionp obj) t))
+ (unknown-type
+ (values nil nil))
+ (alien-type-type
+ (values (alien-typep obj (alien-type-type-alien-type type)) t))
+ (hairy-type
+ ;; Now the tricky stuff.
+ (let* ((hairy-spec (hairy-type-specifier type))
+ (symbol (if (consp hairy-spec) (car hairy-spec) hairy-spec)))
+ (ecase symbol
+ (and
+ (if (atom hairy-spec)
+ (values t t)
+ (dolist (spec (cdr hairy-spec) (values t t))
+ (multiple-value-bind (res win)
+ (ctypep obj (specifier-type spec))
+ (unless win (return (values nil nil)))
+ (unless res (return (values nil t)))))))
+ (not
+ (multiple-value-bind (res win)
+ (ctypep obj (specifier-type (cadr hairy-spec)))
+ (if win
+ (values (not res) t)
+ (values nil nil))))
+ (satisfies
+ ;; KLUDGE: This stuff might well blow up if we tried to execute it
+ ;; when cross-compiling. But since for the foreseeable future the
+ ;; only code we'll try to cross-compile is SBCL itself, and SBCL is
+ ;; built without using SATISFIES types, it's arguably not important
+ ;; to worry about this. -- WHN 19990210.
+ (let ((fun (second hairy-spec)))
+ (cond ((and (consp fun)
+ (eq (car fun) 'lambda))
+ (values (not (null (funcall (coerce fun 'function) obj)))
+ t))
+ ((and (symbolp fun) (fboundp fun))
+ (values (not (null (funcall fun obj))) t))
+ (t
+ (values nil nil))))))))))
+\f
+;;; LAYOUT-OF -- Exported
+;;;
+;;; Return the layout for an object. This is the basic operation for
+;;; finding out the "type" of an object, and is used for generic function
+;;; dispatch. The standard doesn't seem to say as much as it should about what
+;;; this returns for built-in objects. For example, it seems that we must
+;;; return NULL rather than LIST when X is NIL so that GF's can specialize on
+;;; NULL.
+#!-sb-fluid (declaim (inline layout-of))
+(defun layout-of (x)
+ (declare (optimize (speed 3) (safety 0)))
+ (cond ((typep x 'instance) (%instance-layout x))
+ ((funcallable-instance-p x) (%funcallable-instance-layout x))
+ ((null x)
+ ;; Note: was #.((CLASS-LAYOUT (SB!XC:FIND-CLASS 'NULL))).
+ ;; I (WHN 19990209) replaced this with an expression evaluated at
+ ;; run time in order to make it easier to build the cross-compiler.
+ ;; If it doesn't work, something else will be needed..
+ (locally
+ ;; KLUDGE: In order to really make it run at run time (instead of
+ ;; doing some weird broken thing at cold load time),
+ ;; we need to suppress a DEFTRANSFORM.. -- WHN 19991004
+ (declare (notinline sb!xc:find-class))
+ (class-layout (sb!xc:find-class 'null))))
+ (t (svref *built-in-class-codes* (get-type x)))))
+
+#!-sb-fluid (declaim (inline sb!xc:class-of))
+(defun sb!xc:class-of (object)
+ #!+sb-doc
+ "Return the class of the supplied object, which may be any Lisp object, not
+ just a CLOS STANDARD-OBJECT."
+ (layout-class (layout-of object)))
+
+;;; Pull the type specifier out of a function object.
+(defun extract-function-type (fun)
+ (if (sb!eval:interpreted-function-p fun)
+ (sb!eval:interpreted-function-type fun)
+ (typecase fun
+ (byte-function (byte-function-type fun))
+ (byte-closure (byte-function-type (byte-closure-function fun)))
+ (t
+ (specifier-type (%function-type (%closure-function fun)))))))
+\f
+;;;; miscellaneous interfaces
+
+;;; Clear memoization of all type system operations that can be altered by
+;;; type definition/redefinition.
+(defun clear-type-caches ()
+ (when *type-system-initialized*
+ (dolist (sym '(values-specifier-type-cache-clear
+ values-type-union-cache-clear
+ type-union-cache-clear
+ values-subtypep-cache-clear
+ csubtypep-cache-clear
+ type-intersection-cache-clear
+ values-type-intersection-cache-clear))
+ (funcall (symbol-function sym))))
+ (values))
+
+;;; Like TYPE-OF, only we return a CTYPE structure instead of a type specifier,
+;;; and we try to return the type most useful for type checking, rather than
+;;; trying to come up with the one that the user might find most informative.
+(declaim (ftype (function (t) ctype) ctype-of))
+(defun-cached (ctype-of
+ :hash-function (lambda (x) (logand (sxhash x) #x1FF))
+ :hash-bits 9
+ :init-wrapper !cold-init-forms)
+ ((x eq))
+ (typecase x
+ (function
+ (if (funcallable-instance-p x)
+ (sb!xc:class-of x)
+ (extract-function-type x)))
+ (symbol
+ (make-member-type :members (list x)))
+ (number
+ (let* ((num (if (complexp x) (realpart x) x))
+ (res (make-numeric-type
+ :class (etypecase num
+ (integer 'integer)
+ (rational 'rational)
+ (float 'float))
+ :format (if (floatp num)
+ (float-format-name num)
+ nil))))
+ (cond ((complexp x)
+ (setf (numeric-type-complexp res) :complex)
+ (let ((imag (imagpart x)))
+ (setf (numeric-type-low res) (min num imag))
+ (setf (numeric-type-high res) (max num imag))))
+ (t
+ (setf (numeric-type-low res) num)
+ (setf (numeric-type-high res) num)))
+ res))
+ (array
+ (let ((etype (specifier-type (array-element-type x))))
+ (make-array-type :dimensions (array-dimensions x)
+ :complexp (not (typep x 'simple-array))
+ :element-type etype
+ :specialized-element-type etype)))
+ (t
+ (sb!xc:class-of x))))
+
+;;; Clear this cache on GC so that we don't hold onto too much garbage.
+(pushnew 'ctype-of-cache-clear *before-gc-hooks*)
+\f
+(!defun-from-collected-cold-init-forms !target-type-cold-init)
--- /dev/null
+;;;; low-level time functions
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!IMPL")
+
+(file-comment
+ "$Header$")
+
+(defconstant internal-time-units-per-second 100
+ #!+sb-doc
+ "The number of internal time units that fit into a second. See
+ GET-INTERNAL-REAL-TIME and GET-INTERNAL-RUN-TIME.")
+
+(defconstant micro-seconds-per-internal-time-unit
+ (/ 1000000 internal-time-units-per-second))
+\f
+;;; The base number of seconds for our internal "epoch". We initialize
+;;; this to the time of the first call to GET-INTERNAL-REAL-TIME, and
+;;; then subtract this out of the result.
+(defvar *internal-real-time-base-seconds* nil)
+(declaim (type (or (unsigned-byte 32) null) *internal-real-time-base-seconds*))
+
+(defun get-internal-real-time ()
+ #!+sb-doc
+ "Return the real time in the internal time format. This is useful for
+ finding elapsed time. See Internal-Time-Units-Per-Second."
+ ;; FIXME: See comment on OPTIMIZE declaration in GET-INTERNAL-RUN-TIME.
+ (declare (optimize (speed 3) (safety 3)))
+ (multiple-value-bind (ignore seconds useconds) (sb!unix:unix-gettimeofday)
+ (declare (ignore ignore) (type (unsigned-byte 32) seconds useconds))
+ (let ((base *internal-real-time-base-seconds*)
+ (uint (truncate useconds
+ micro-seconds-per-internal-time-unit)))
+ (declare (type (unsigned-byte 32) uint))
+ (cond (base
+ (truly-the (unsigned-byte 32)
+ (+ (the (unsigned-byte 32)
+ (* (the (unsigned-byte 32) (- seconds base))
+ internal-time-units-per-second))
+ uint)))
+ (t
+ (setq *internal-real-time-base-seconds* seconds)
+ uint)))))
+
+#!-(and sparc svr4)
+(defun get-internal-run-time ()
+ #!+sb-doc
+ "Return the run time in the internal time format. This is useful for
+ finding CPU usage."
+ (declare (values (unsigned-byte 32)))
+ ;; FIXME: In CMU CL this was (SPEED 3) (SAFETY 0), and perhaps
+ ;; someday it should be again, since overhead here is annoying. But
+ ;; it's even more annoying to worry about this function returning
+ ;; out-of-range values, so while debugging the profiling code,
+ ;; I set it to (SAFETY 3) for now.
+ (declare (optimize (speed 3) (safety 3)))
+ (multiple-value-bind (ignore utime-sec utime-usec stime-sec stime-usec)
+ (sb!unix:unix-fast-getrusage sb!unix:rusage_self)
+ (declare (ignore ignore)
+ (type (unsigned-byte 31) utime-sec stime-sec)
+ ;; (Classic CMU CL had these (MOD 1000000) instead, but
+ ;; at least in Linux 2.2.12, the type doesn't seem to be
+ ;; documented anywhere and the observed behavior is to
+ ;; sometimes return 1000000 exactly.)
+ (type (integer 0 1000000) utime-usec stime-usec))
+ (+ (the (unsigned-byte 32)
+ (* (the (unsigned-byte 32) (+ utime-sec stime-sec))
+ internal-time-units-per-second))
+ (truncate (+ utime-usec stime-usec)
+ micro-seconds-per-internal-time-unit))))
+
+#!+(and sparc svr4)
+(defun get-internal-run-time ()
+ #!+sb-doc
+ "Return the run time in the internal time format. This is useful for
+ finding CPU usage."
+ (declare (values (unsigned-byte 32)))
+ ;; FIXME: See comment on OPTIMIZE declaration in other
+ ;; version of GET-INTERNAL-RUN-TIME.
+ (declare (optimize (speed 3) (safety 3)))
+ (multiple-value-bind (ignore utime stime cutime cstime)
+ (sb!unix:unix-times)
+ (declare (ignore ignore cutime cstime)
+ (type (unsigned-byte 31) utime stime))
+ (the (unsigned-byte 32) (+ utime stime))))
+\f
+;;;; Encode and decode universal times.
+
+;;; Returns two values:
+;;; - the minutes west of GMT.
+;;; - T if daylight savings is in effect, NIL if not.
+(sb!alien:def-alien-routine get-timezone sb!c-call:void
+ (when sb!c-call:long :in)
+ (minutes-west sb!c-call:int :out)
+ (daylight-savings-p sb!alien:boolean :out))
+
+;;; Subtract from the returned Internal-Time to get the universal time.
+;;; The offset between our time base and the Perq one is 2145 weeks and
+;;; five days.
+(defconstant seconds-in-week (* 60 60 24 7))
+(defconstant weeks-offset 2145)
+(defconstant seconds-offset 432000)
+(defconstant minutes-per-day (* 24 60))
+(defconstant quarter-days-per-year (1+ (* 365 4)))
+(defconstant quarter-days-per-century 146097)
+(defconstant november-17-1858 678882)
+(defconstant weekday-november-17-1858 2)
+(defconstant unix-to-universal-time 2208988800)
+
+(defun get-universal-time ()
+ #!+sb-doc
+ "Returns a single integer for the current time of
+ day in universal time format."
+ (multiple-value-bind (res secs) (sb!unix:unix-gettimeofday)
+ (declare (ignore res))
+ (+ secs unix-to-universal-time)))
+
+(defun get-decoded-time ()
+ #!+sb-doc
+ "Returns nine values specifying the current time as follows:
+ second, minute, hour, date, month, year, day of week (0 = Monday), T
+ (daylight savings times) or NIL (standard time), and timezone."
+ (decode-universal-time (get-universal-time)))
+
+(defun decode-universal-time (universal-time &optional time-zone)
+ #!+sb-doc
+ "Converts a universal-time to decoded time format returning the following
+ nine values: second, minute, hour, date, month, year, day of week (0 =
+ Monday), T (daylight savings time) or NIL (standard time), and timezone.
+ Completely ignores daylight-savings-time when time-zone is supplied."
+ (multiple-value-bind (weeks secs)
+ (truncate (+ universal-time seconds-offset)
+ seconds-in-week)
+ (let* ((weeks (+ weeks weeks-offset))
+ (second NIL)
+ (minute NIL)
+ (hour NIL)
+ (date NIL)
+ (month NIL)
+ (year NIL)
+ (day NIL)
+ (daylight NIL)
+ (timezone (if (null time-zone)
+ (multiple-value-bind
+ (ignore minwest dst)
+ (get-timezone (- universal-time
+ unix-to-universal-time))
+ (declare (ignore ignore))
+ (setf daylight dst)
+ minwest)
+ (* time-zone 60))))
+ (declare (fixnum timezone))
+ (multiple-value-bind (t1 seconds) (truncate secs 60)
+ (setq second seconds)
+ (setq t1 (- t1 timezone))
+ (let* ((tday (if (< t1 0)
+ (1- (truncate (1+ t1) minutes-per-day))
+ (truncate t1 minutes-per-day))))
+ (multiple-value-setq (hour minute)
+ (truncate (- t1 (* tday minutes-per-day)) 60))
+ (let* ((t2 (1- (* (+ (* weeks 7) tday november-17-1858) 4)))
+ (tcent (truncate t2 quarter-days-per-century)))
+ (setq t2 (mod t2 quarter-days-per-century))
+ (setq t2 (+ (- t2 (mod t2 4)) 3))
+ (setq year (+ (* tcent 100) (truncate t2 quarter-days-per-year)))
+ (let ((days-since-mar0 (1+ (truncate (mod t2 quarter-days-per-year)
+ 4))))
+ (setq day (mod (+ tday weekday-november-17-1858) 7))
+ (let ((t3 (+ (* days-since-mar0 5) 456)))
+ (cond ((>= t3 1989)
+ (setq t3 (- t3 1836))
+ (setq year (1+ year))))
+ (multiple-value-setq (month t3) (truncate t3 153))
+ (setq date (1+ (truncate t3 5))))))))
+ (values second minute hour date month year day
+ daylight
+ (if daylight
+ (1+ (/ timezone 60))
+ (/ timezone 60))))))
+
+(defun pick-obvious-year (year)
+ (declare (type (mod 100) year))
+ (let* ((current-year (nth-value 5 (get-decoded-time)))
+ (guess (+ year (* (truncate (- current-year 50) 100) 100))))
+ (declare (type (integer 1900 9999) current-year guess))
+ (if (> (- current-year guess) 50)
+ (+ guess 100)
+ guess)))
+
+(defun leap-years-before (year)
+ (let ((years (- year 1901)))
+ (+ (- (truncate years 4)
+ (truncate years 100))
+ (truncate (+ years 300) 400))))
+
+(defvar *days-before-month*
+ #.(let ((reversed-result nil)
+ (sum 0))
+ (push nil reversed-result)
+ (dolist (days-in-month '(31 28 31 30 31 30 31 31 30 31 30 31))
+ (push sum reversed-result)
+ (incf sum days-in-month))
+ (coerce (nreverse reversed-result) 'simple-vector)))
+
+(defun encode-universal-time (second minute hour date month year
+ &optional time-zone)
+ #!+sb-doc
+ "The time values specified in decoded format are converted to
+ universal time, which is returned."
+ (declare (type (mod 60) second)
+ (type (mod 60) minute)
+ (type (mod 24) hour)
+ (type (integer 1 31) date)
+ (type (integer 1 12) month)
+ (type (or (integer 0 99) (integer 1900)) year)
+ (type (or null rational) time-zone))
+ (let* ((year (if (< year 100)
+ (pick-obvious-year year)
+ year))
+ (days (+ (1- date)
+ (aref *days-before-month* month)
+ (if (> month 2)
+ (leap-years-before (1+ year))
+ (leap-years-before year))
+ (* (- year 1900) 365)))
+ (hours (+ hour (* days 24))))
+ (if time-zone
+ (+ second (* (+ minute (* (+ hours time-zone) 60)) 60))
+ (let* ((minwest-guess
+ (nth-value 1
+ (get-timezone (- (* hours 60 60)
+ unix-to-universal-time))))
+ (guess (+ minute (* hours 60) minwest-guess))
+ (minwest
+ (nth-value 1
+ (get-timezone (- (* guess 60)
+ unix-to-universal-time)))))
+ (+ second (* (+ guess (- minwest minwest-guess)) 60))))))
+\f
+;;;; TIME
+
+(defmacro time (form)
+ #!+sb-doc
+ "Evaluates the Form and prints timing information on *Trace-Output*."
+ `(%time #'(lambda () ,form)))
+
+;;; Try to compile the closure arg to %TIME if it is interpreted.
+(defun massage-time-function (fun)
+ (cond
+ ((sb!eval:interpreted-function-p fun)
+ (multiple-value-bind (def env-p) (function-lambda-expression fun)
+ (declare (ignore def))
+ (cond
+ (env-p
+ (warn "TIME form in a non-null environment, forced to interpret.~@
+ Compiling entire form will produce more accurate times.")
+ fun)
+ (t
+ (compile nil fun)))))
+ (t fun)))
+
+;;; Return all the files that we want time to report.
+(defun time-get-sys-info ()
+ (multiple-value-bind (user sys faults) (sb!sys:get-system-info)
+ (values user sys faults (get-bytes-consed))))
+
+;;; The guts of the TIME macro. Compute overheads, run the (compiled)
+;;; function, report the times.
+(defun %time (fun)
+ (let ((fun (massage-time-function fun))
+ old-run-utime
+ new-run-utime
+ old-run-stime
+ new-run-stime
+ old-real-time
+ new-real-time
+ old-page-faults
+ new-page-faults
+ real-time-overhead
+ run-utime-overhead
+ run-stime-overhead
+ page-faults-overhead
+ old-bytes-consed
+ new-bytes-consed
+ cons-overhead)
+ ;; Calculate the overhead...
+ (multiple-value-setq
+ (old-run-utime old-run-stime old-page-faults old-bytes-consed)
+ (time-get-sys-info))
+ ;; Do it a second time to make sure everything is faulted in.
+ (multiple-value-setq
+ (old-run-utime old-run-stime old-page-faults old-bytes-consed)
+ (time-get-sys-info))
+ (multiple-value-setq
+ (new-run-utime new-run-stime new-page-faults new-bytes-consed)
+ (time-get-sys-info))
+ (setq run-utime-overhead (- new-run-utime old-run-utime))
+ (setq run-stime-overhead (- new-run-stime old-run-stime))
+ (setq page-faults-overhead (- new-page-faults old-page-faults))
+ (setq old-real-time (get-internal-real-time))
+ (setq old-real-time (get-internal-real-time))
+ (setq new-real-time (get-internal-real-time))
+ (setq real-time-overhead (- new-real-time old-real-time))
+ (setq cons-overhead (- new-bytes-consed old-bytes-consed))
+ ;; Now get the initial times.
+ (multiple-value-setq
+ (old-run-utime old-run-stime old-page-faults old-bytes-consed)
+ (time-get-sys-info))
+ (setq old-real-time (get-internal-real-time))
+ (let ((start-gc-run-time *gc-run-time*))
+ (multiple-value-prog1
+ ;; Execute the form and return its values.
+ (funcall fun)
+ (multiple-value-setq
+ (new-run-utime new-run-stime new-page-faults new-bytes-consed)
+ (time-get-sys-info))
+ (setq new-real-time (- (get-internal-real-time) real-time-overhead))
+ (let ((gc-run-time (max (- *gc-run-time* start-gc-run-time) 0)))
+ (format *trace-output*
+ "~&Evaluation took:~% ~
+ ~S second~:P of real time~% ~
+ ~S second~:P of user run time~% ~
+ ~S second~:P of system run time~% ~
+~@[ [Run times include ~S second~:P GC run time.]~% ~]~
+ ~S page fault~:P and~% ~
+ ~S bytes consed.~%"
+ (max (/ (- new-real-time old-real-time)
+ (float internal-time-units-per-second))
+ 0.0)
+ (max (/ (- new-run-utime old-run-utime) 1000000.0) 0.0)
+ (max (/ (- new-run-stime old-run-stime) 1000000.0) 0.0)
+ (unless (zerop gc-run-time)
+ (/ (float gc-run-time)
+ (float internal-time-units-per-second)))
+ (max (- new-page-faults old-page-faults) 0)
+ (max (- new-bytes-consed old-bytes-consed) 0)))))))
--- /dev/null
+;;;; stuff related to the toplevel read-eval-print loop, plus some
+;;;; other miscellaneous functions that we don't have any better place
+;;;; for
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!IMPL")
+
+(file-comment
+ "$Header$")
+\f
+(defconstant most-positive-fixnum #.sb!vm:*target-most-positive-fixnum*
+ #!+sb-doc
+ "The fixnum closest in value to positive infinity.")
+
+(defconstant most-negative-fixnum #.sb!vm:*target-most-negative-fixnum*
+ #!+sb-doc
+ "The fixnum closest in value to negative infinity.")
+\f
+;;;; magic specials initialized by genesis
+
+#!-gengc
+(progn
+ (defvar *current-catch-block*)
+ (defvar *current-unwind-protect-block*)
+ (defvar *free-interrupt-context-index*))
+\f
+;;; specials initialized by !COLD-INIT
+
+;;; FIXME: These could be converted to DEFVARs, and the stuff shared
+;;; in both #!+GENGC and #!-GENGC (actually everything in #!+GENGC)
+;;; could be made non-conditional.
+(declaim
+ #!-gengc
+ (special *gc-inhibit* *already-maybe-gcing*
+ *need-to-collect-garbage* *gc-verbose*
+ *gc-notify-stream*
+ *before-gc-hooks* *after-gc-hooks*
+ #!+x86 *pseudo-atomic-atomic*
+ #!+x86 *pseudo-atomic-interrupted*
+ sb!unix::*interrupts-enabled*
+ sb!unix::*interrupt-pending*
+ *type-system-initialized*)
+ #!+gengc
+ (special *gc-verbose* *before-gc-hooks* *after-gc-hooks*
+ *gc-notify-stream*
+ *type-system-initialized*))
+
+(defvar *cold-init-complete-p*)
+
+;;; counts of nested errors (with internal errors double-counted)
+(defvar *maximum-error-depth*)
+(defvar *current-error-depth*)
+\f
+;;;; working with *CURRENT-ERROR-DEPTH* and *MAXIMUM-ERROR-DEPTH*
+
+;;; INFINITE-ERROR-PROTECT is used by ERROR and friends to keep us out of
+;;; hyperspace.
+(defmacro infinite-error-protect (&rest forms)
+ `(unless (infinite-error-protector)
+ (let ((*current-error-depth* (1+ *current-error-depth*)))
+ ,@forms)))
+
+;;; a helper function for INFINITE-ERROR-PROTECT
+(defun infinite-error-protector ()
+ (cond ((not *cold-init-complete-p*)
+ (%primitive print "Argh! error in cold init, halting")
+ (%primitive sb!c:halt))
+ ((or (not (boundp '*current-error-depth*))
+ (not (realp *current-error-depth*))
+ (not (boundp '*maximum-error-depth*))
+ (not (realp *maximum-error-depth*)))
+ (%primitive print "Argh! corrupted error depth, halting")
+ (%primitive sb!c:halt))
+ ((> *current-error-depth* *maximum-error-depth*)
+ (/show0 "in INFINITE-ERROR-PROTECTOR, calling ERROR-ERROR")
+ (error-error "Help! "
+ *current-error-depth*
+ " nested errors. "
+ "KERNEL:*MAXIMUM-ERROR-DEPTH* exceeded.")
+ t)
+ (t
+ nil)))
+
+;;; FIXME: I had a badly broken version of INFINITE-ERROR-PROTECTOR at
+;;; one point (shown below), and SBCL cross-compiled it without
+;;; warning about FORMS being undefined. Check whether that problem
+;;; (missing warning) is repeatable in the final system and if so, fix
+;;; it.
+#|
+(defun infinite-error-protector ()
+ `(cond ((not *cold-init-complete-p*)
+ (%primitive print "Argh! error in cold init, halting")
+ (%primitive sb!c:halt))
+ ((or (not (boundp '*current-error-depth*))
+ (not (realp *current-error-depth*))
+ (not (boundp '*maximum-error-depth*))
+ (not (realp *maximum-error-depth*)))
+ (%primitive print "Argh! corrupted error depth, halting")
+ (%primitive sb!c:halt))
+ ((> *current-error-depth* *maximum-error-depth*)
+ (/show0 "in INFINITE-ERROR-PROTECTOR, calling ERROR-ERROR")
+ (error-error "Help! "
+ *current-error-depth*
+ " nested errors. "
+ "KERNEL:*MAXIMUM-ERROR-DEPTH* exceeded.")
+ (progn ,@forms)
+ t)
+ (t
+ (/show0 "in INFINITE-ERROR-PROTECTOR, returning normally")
+ nil)))
+|#
+\f
+;;;; miscellaneous external functions
+
+#!-mp ; The multi-processing version is defined in multi-proc.lisp.
+(defun sleep (n)
+ #!+sb-doc
+ "This function causes execution to be suspended for N seconds. N may
+ be any non-negative, non-complex number."
+ (when (or (not (realp n))
+ (minusp n))
+ (error "Invalid argument to SLEEP: ~S.~%~
+ Must be a non-negative, non-complex number."
+ n))
+ (multiple-value-bind (sec usec)
+ (if (integerp n)
+ (values n 0)
+ (multiple-value-bind (sec frac)
+ (truncate n)
+ (values sec(truncate frac 1e-6))))
+ (sb!unix:unix-select 0 0 0 0 sec usec))
+ nil)
+\f
+;;;; SCRUB-CONTROL-STACK
+
+(defconstant bytes-per-scrub-unit 2048)
+
+(defun scrub-control-stack ()
+ #!+sb-doc
+ "Zero the unused portion of the control stack so that old objects are not
+ kept alive because of uninitialized stack variables."
+ ;; FIXME: Why do we need to do this instead of just letting GC read
+ ;; the stack pointer and avoid messing with the unused portion of
+ ;; the control stack? (Is this a multithreading thing where there's
+ ;; one control stack and stack pointer per thread, and it might not
+ ;; be easy to tell what a thread's stack pointer value is when
+ ;; looking in from another thread?)
+ (declare (optimize (speed 3) (safety 0))
+ (values (unsigned-byte 20))) ; FIXME: DECLARE VALUES?
+
+ #!-x86 ; machines where stack grows upwards (I guess) -- WHN 19990906
+ (labels
+ ((scrub (ptr offset count)
+ (declare (type system-area-pointer ptr)
+ (type (unsigned-byte 16) offset)
+ (type (unsigned-byte 20) count)
+ (values (unsigned-byte 20)))
+ (cond ((= offset bytes-per-scrub-unit)
+ (look (sap+ ptr bytes-per-scrub-unit) 0 count))
+ (t
+ (setf (sap-ref-32 ptr offset) 0)
+ (scrub ptr (+ offset sb!vm:word-bytes) count))))
+ (look (ptr offset count)
+ (declare (type system-area-pointer ptr)
+ (type (unsigned-byte 16) offset)
+ (type (unsigned-byte 20) count)
+ (values (unsigned-byte 20)))
+ (cond ((= offset bytes-per-scrub-unit)
+ count)
+ ((zerop (sap-ref-32 ptr offset))
+ (look ptr (+ offset sb!vm:word-bytes) count))
+ (t
+ (scrub ptr offset (+ count sb!vm:word-bytes))))))
+ (let* ((csp (sap-int (sb!c::control-stack-pointer-sap)))
+ (initial-offset (logand csp (1- bytes-per-scrub-unit))))
+ (declare (type (unsigned-byte 32) csp))
+ (scrub (int-sap (- csp initial-offset))
+ (* (floor initial-offset sb!vm:word-bytes) sb!vm:word-bytes)
+ 0)))
+
+ #!+x86 ;; (Stack grows downwards.)
+ (labels
+ ((scrub (ptr offset count)
+ (declare (type system-area-pointer ptr)
+ (type (unsigned-byte 16) offset)
+ (type (unsigned-byte 20) count)
+ (values (unsigned-byte 20)))
+ (let ((loc (int-sap (- (sap-int ptr) (+ offset sb!vm:word-bytes)))))
+ (cond ((= offset bytes-per-scrub-unit)
+ (look (int-sap (- (sap-int ptr) bytes-per-scrub-unit))
+ 0 count))
+ (t ;; need to fix bug in %SET-STACK-REF
+ (setf (sap-ref-32 loc 0) 0)
+ (scrub ptr (+ offset sb!vm:word-bytes) count)))))
+ (look (ptr offset count)
+ (declare (type system-area-pointer ptr)
+ (type (unsigned-byte 16) offset)
+ (type (unsigned-byte 20) count)
+ (values (unsigned-byte 20)))
+ (let ((loc (int-sap (- (sap-int ptr) offset))))
+ (cond ((= offset bytes-per-scrub-unit)
+ count)
+ ((zerop (sb!kernel::get-lisp-obj-address (stack-ref loc 0)))
+ (look ptr (+ offset sb!vm:word-bytes) count))
+ (t
+ (scrub ptr offset (+ count sb!vm:word-bytes)))))))
+ (let* ((csp (sap-int (sb!c::control-stack-pointer-sap)))
+ (initial-offset (logand csp (1- bytes-per-scrub-unit))))
+ (declare (type (unsigned-byte 32) csp))
+ (scrub (int-sap (+ csp initial-offset))
+ (* (floor initial-offset sb!vm:word-bytes) sb!vm:word-bytes)
+ 0))))
+\f
+;;;; the default TOPLEVEL function
+
+(defvar / nil
+ #!+sb-doc
+ "a list of all the values returned by the most recent top-level EVAL")
+(defvar // nil #!+sb-doc "the previous value of /")
+(defvar /// nil #!+sb-doc "the previous value of //")
+(defvar * nil #!+sb-doc "the value of the most recent top-level EVAL")
+(defvar ** nil #!+sb-doc "the previous value of *")
+(defvar *** nil #!+sb-doc "the previous value of **")
+(defvar + nil #!+sb-doc "the value of the most recent top-level READ")
+(defvar ++ nil #!+sb-doc "the previous value of +")
+(defvar +++ nil #!+sb-doc "the previous value of ++")
+(defvar - nil #!+sb-doc "the form currently being evaluated")
+(defvar *prompt* "* "
+ #!+sb-doc
+ "The top-level prompt string. This also may be a function of no arguments
+ that returns a simple-string.")
+(defvar *in-top-level-catcher* nil
+ #!+sb-doc
+ "Are we within the Top-Level-Catcher? This is used by interrupt
+ handlers to see whether it is OK to throw.")
+
+(defun interactive-eval (form)
+ "Evaluate FORM, returning whatever it returns and adjusting ***, **, *,
+ +++, ++, +, ///, //, /, and -."
+ (setf - form)
+ (let ((results (multiple-value-list (eval form))))
+ (setf /// //
+ // /
+ / results
+ *** **
+ ** *
+ * (car results)))
+ (setf +++ ++
+ ++ +
+ + -)
+ (unless (boundp '*)
+ ;; The bogon returned an unbound marker.
+ ;; FIXME: It would be safer to check every one of the values in RESULTS,
+ ;; instead of just the first one.
+ (setf * nil)
+ (cerror "Go on with * set to NIL."
+ "EVAL returned an unbound marker."))
+ (values-list /))
+
+;;; Flush anything waiting on one of the ANSI Common Lisp standard
+;;; output streams before proceeding.
+(defun flush-standard-output-streams ()
+ (dolist (name '(*debug-io*
+ *error-output*
+ *query-io*
+ *standard-output*
+ *trace-output*))
+ (finish-output (symbol-value name)))
+ (values))
+
+;;; the default system top-level function
+(defun toplevel ()
+
+ (/show0 "entering TOPLEVEL")
+
+ (let ((sysinit nil) ; value of --sysinit option
+ (userinit nil) ; value of --userinit option
+ (evals nil) ; values of --eval options (in reverse order)
+ (noprint nil) ; Has a --noprint option been seen?
+ (noprogrammer nil) ; Has a --noprogammer option been seen?
+ (options (rest *posix-argv*))) ; skipping program name
+
+ (/show0 "done with outer LET in TOPLEVEL")
+
+ ;; FIXME: There are lots of ways for errors to happen around here (e.g. bad
+ ;; command line syntax, or READ-ERROR while trying to READ an --eval
+ ;; string). Make sure that they're handled reasonably.
+
+ ;; Parse command line options.
+ (loop while options do
+ (/show0 "at head of LOOP WHILE OPTIONS DO in TOPLEVEL")
+ (let ((option (first options)))
+ (flet ((pop-option ()
+ (if options
+ (pop options)
+ (error "unexpected end of command line options"))))
+ (cond ((string= option "--sysinit")
+ (pop-option)
+ (if sysinit
+ (error "multiple --sysinit options")
+ (setf sysinit (pop-option))))
+ ((string= option "--userinit")
+ (pop-option)
+ (if userinit
+ (error "multiple --userinit options")
+ (setf userinit (pop-option))))
+ ((string= option "--eval")
+ (pop-option)
+ (let ((eval-as-string (pop-option)))
+ (with-input-from-string (eval-stream eval-as-string)
+ (let* ((eof-marker (cons :eof :eof))
+ (eval (read eval-stream nil eof-marker))
+ (eof (read eval-stream nil eof-marker)))
+ (cond ((eq eval eof-marker)
+ (error "unable to parse ~S"
+ eval-as-string))
+ ((not (eq eof eof-marker))
+ (error "more than one expression in ~S"
+ eval-as-string))
+ (t
+ (push eval evals)))))))
+ ((string= option "--noprint")
+ (pop-option)
+ (setf noprint t))
+ ((string= option "--noprogrammer")
+ (pop-option)
+ (setf noprogrammer t))
+ ((string= option "--end-toplevel-options")
+ (pop-option)
+ (return))
+ (t
+ ;; Anything we don't recognize as a toplevel
+ ;; option must be the start of user-level
+ ;; options.. except that if we encounter
+ ;; "--end-toplevel-options" after we gave up
+ ;; because we didn't recognize an option as a
+ ;; toplevel option, then the option we gave up on
+ ;; must have been an error. (E.g. in
+ ;; sbcl --eval '(a)' --evl '(b)' --end-toplevel-options
+ ;; this test will let us detect that "--evl" is
+ ;; an error.)
+ (if (find "--end-toplevel-options" options
+ :test #'string=)
+ (error "bad toplevel option: ~S" (first options))
+ (return)))))))
+ (/show0 "done with LOOP WHILE OPTIONS DO in TOPLEVEL")
+
+ ;; Excise all the options that we processed, so that only user-level
+ ;; options are left visible to user code.
+ (setf (rest *posix-argv*) options)
+
+ ;; FIXME: Verify that errors in init files and/or --eval operations
+ ;; lead to reasonable behavior.
+
+ ;; Handle initialization files.
+ (/show0 "handling initialization files in TOPLEVEL")
+ (flet (;; If any of POSSIBLE-INIT-FILE-NAMES names a real file,
+ ;; return its truename.
+ (probe-init-files (&rest possible-init-file-names)
+ (/show0 "entering PROBE-INIT-FILES")
+ (prog1
+ (find-if (lambda (x)
+ (and (stringp x) (probe-file x)))
+ possible-init-file-names)
+ (/show0 "leaving PROBE-INIT-FILES"))))
+ (let* ((sbcl-home (posix-getenv "SBCL_HOME"))
+ #!+sb-show(ignore1 (progn
+ (/show0 "SBCL-HOME=..")
+ (if sbcl-home
+ (%primitive print sbcl-home)
+ (%primitive print "NIL"))))
+ (sysinit-truename (if sbcl-home
+ (probe-init-files sysinit
+ (concatenate
+ 'string
+ sbcl-home
+ "/sbclrc"))
+ (probe-init-files sysinit
+ "/etc/sbclrc"
+ "/usr/local/etc/sbclrc")))
+ (user-home (or (posix-getenv "HOME")
+ (error "The HOME environment variable is unbound, ~
+ so user init file can't be found.")))
+ #!+sb-show(ignore2 (progn
+ (/show0 "USER-HOME=..")
+ (%primitive print user-home)))
+ (userinit-truename (probe-init-files userinit
+ (concatenate
+ 'string
+ user-home
+ "/.sbclrc"))))
+ (/show0 "assigned SYSINIT-TRUENAME and USERINIT-TRUENAME")
+ (when sysinit-truename
+ (/show0 "SYSINIT-TRUENAME=..")
+ #!+sb-show (%primitive print sysinit-truename)
+ (unless (load sysinit-truename)
+ (error "~S was not successfully loaded." sysinit-truename))
+ (flush-standard-output-streams))
+ (/show0 "loaded SYSINIT-TRUENAME")
+ (when userinit-truename
+ (/show0 "USERINIT-TRUENAME=..")
+ #!+sb-show (%primitive print userinit-truename)
+ (unless (load userinit-truename)
+ (error "~S was not successfully loaded." userinit-truename))
+ (flush-standard-output-streams))
+ (/show0 "loaded USERINIT-TRUENAME")))
+
+ ;; Handle --eval options.
+ (/show0 "handling --eval options in TOPLEVEL")
+ (dolist (eval (reverse evals))
+ (/show0 "handling one --eval option in TOPLEVEL")
+ (eval eval)
+ (flush-standard-output-streams))
+
+ ;; Handle stream binding controlled by --noprogrammer option.
+ ;;
+ ;; FIXME: When we do actually implement this, shouldn't it go
+ ;; earlier in the sequence, so that its stream bindings will
+ ;; affect the behavior of init files and --eval options?
+ (/show0 "handling --noprogrammer option in TOPLEVEL")
+ (when noprogrammer
+ (warn "stub: --noprogrammer option unimplemented")) ; FIXME
+
+ (/show0 "falling into TOPLEVEL-REPL from TOPLEVEL")
+ (toplevel-repl noprint)))
+
+;;; read-eval-print loop for the default system toplevel
+(defun toplevel-repl (noprint)
+ (/show0 "entering TOPLEVEL-REPL")
+ (let ((* nil) (** nil) (*** nil)
+ (- nil)
+ (+ nil) (++ nil) (+++ nil)
+ (/// nil) (// nil) (/ nil)
+ (eof-marker (cons :eof nil)))
+ (loop
+ ;; FIXME: This seems to be the source of one of the basic debugger
+ ;; choices in
+ ;; Restarts:
+ ;; 0: [CONTINUE] Return from BREAK.
+ ;; 1: [ABORT ] Return to toplevel.
+ ;; (The "Return from BREAK" choice is defined in BREAK.) I'd like to add
+ ;; another choice,
+ ;; 2: [TERMINATE] Terminate the current Lisp.
+ ;; That way, a user hitting ^C could get out of Lisp without knowing
+ ;; enough about the system to run (SB-EXT:QUIT).
+ ;;
+ ;; If I understand the documentation of WITH-SIMPLE-RESTART correctly,
+ ;; it shows how to replace this WITH-SIMPLE-RESTART with a RESTART-CASE
+ ;; with two choices (ABORT and QUIT). Or perhaps ABORT should be renamed
+ ;; TOPLEVEL?
+ ;; Restarts:
+ ;; 0: [CONTINUE ] Return from BREAK, continuing calculation
+ ;; as though nothing happened.
+ ;; 1: [TOPLEVEL ] Transfer control to toplevel read/eval/print
+ ;; loop, aborting current calculation.
+ ;; 2: [TERMINATE] Terminate the current Lisp (equivalent to
+ ;; executing (SB-EXT:QUIT)).
+ (/show0 "at head of outer LOOP in TOPLEVEL-REPL")
+ (with-simple-restart (abort "Return to toplevel.")
+ (catch 'top-level-catcher
+ (sb!unix:unix-sigsetmask 0) ; FIXME: What is this for?
+ (let ((*in-top-level-catcher* t))
+ (/show0 "about to enter inner LOOP in TOPLEVEL-REPL")
+ (loop ; FIXME: Do we need this inner LOOP?
+ ;; FIXME: It seems bad to have GC behavior depend on scrubbing
+ ;; the control stack before each interactive command. Isn't
+ ;; there some way we can convince the GC to just ignore
+ ;; dead areas of the control stack, so that we don't need to
+ ;; rely on this half-measure?
+ (scrub-control-stack)
+ (unless noprint
+ (fresh-line)
+ (princ (if (functionp *prompt*)
+ (funcall *prompt*)
+ *prompt*))
+ (flush-standard-output-streams))
+ (let ((form (read *standard-input* nil eof-marker)))
+ (if (eq form eof-marker)
+ (quit)
+ (let ((results
+ (multiple-value-list (interactive-eval form))))
+ (unless noprint
+ (dolist (result results)
+ (fresh-line)
+ (prin1 result)))))))))))))
+\f
+;;; a convenient way to get into the assembly-level debugger
+(defun %halt ()
+ (%primitive sb!c:halt))
--- /dev/null
+;;;; stuff related to the TYPE-CLASS structure
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!KERNEL")
+
+(file-comment
+ "$Header$")
+
+(!begin-collecting-cold-init-forms)
+
+(defvar *type-classes*)
+(!cold-init-forms
+ (unless (boundp '*type-classes*) ; FIXME: How could this be bound?
+ (setq *type-classes* (make-hash-table :test 'eq))))
+
+(defun type-class-or-lose (name)
+ (or (gethash name *type-classes*)
+ (error "~S is not a defined type class." name)))
+
+(defun must-supply-this (&rest foo)
+ (error "missing type method for ~S" foo))
+
+;;; A TYPE-CLASS object represents the "kind" of a type. It mainly contains
+;;; functions which are methods on that kind of type, but is also used in EQ
+;;; comparisons to determined if two types have the "same kind".
+(def!struct (type-class
+ #-no-ansi-print-object
+ (:print-object (lambda (x stream)
+ (print-unreadable-object (x stream :type t)
+ (prin1 (type-class-name x) stream)))))
+ ;; the name of this type class (used to resolve references at load time)
+ (name nil :type symbol) ; FIXME: should perhaps be REQUIRED-ARGUMENT?
+ ;; Dyadic type methods. If the classes of the two types are EQ, then
+ ;; we call the SIMPLE-xxx method. If the classes are not EQ, and
+ ;; either type's class has a COMPLEX-xxx method, then we call it.
+ ;;
+ ;; Although it is undefined which method will get precedence when
+ ;; both types have a complex method, the complex method can assume
+ ;; that the second arg always is in its class, and the first always
+ ;; is not. The arguments to commutative operations will be swapped
+ ;; if the first argument has a complex method.
+ ;;
+ ;; Since SUBTYPEP is not commutative, we have two complex methods.
+ ;; The ARG1 method is only called when the first argument is in its
+ ;; class, and the ARG2 method is only called when called when the
+ ;; second type is. If either is specified, both must be.
+ (simple-subtypep #'must-supply-this :type function)
+ (complex-subtypep-arg1 nil :type (or function null))
+ (complex-subtypep-arg2 nil :type (or function null))
+ ;; SIMPLE-UNION combines two types of the same class into a single
+ ;; type of that class. If the result is a two-type union, then
+ ;; return NIL. VANILLA-UNION returns whichever argument is a
+ ;; supertype of the other, or NIL.
+ (simple-union #'vanilla-union :type function)
+ (complex-union nil :type (or function null))
+ ;; The default intersection methods assume that if one type is a
+ ;; subtype of the other, then that type is the intersection.
+ (simple-intersection #'vanilla-intersection :type function)
+ (complex-intersection nil :type (or function null))
+ (simple-= #'must-supply-this :type function)
+ (complex-= nil :type (or function null))
+ ;; a function which returns a Common Lisp type specifier
+ ;; representing this type
+ (unparse #'must-supply-this :type function)
+
+ #|
+ Not used, and not really right. Probably we want a TYPE= alist for the
+ unary operations, since there are lots of interesting unary predicates that
+ aren't equivalent to an entire class
+ ;; Names of functions used for testing the type of objects in this type
+ ;; class. UNARY-PREDICATE takes just the object, whereas PREDICATE gets
+ ;; passed both the object and the CTYPE. Normally one or the other will be
+ ;; supplied for any type that can be passed to TYPEP; there is no point in
+ ;; supplying both.
+ (unary-typep nil :type (or symbol null))
+ (typep nil :type (or symbol null))
+ ;; Like TYPEP, UNARY-TYPEP except these functions coerce objects to this
+ ;; type.
+ (unary-coerce nil :type (or symbol null))
+ (coerce :type (or symbol null))
+ |#
+ )
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+
+;;; Copy TYPE-CLASS object X, using only operations which will work early in
+;;; cold load. (COPY-STRUCTURE won't work early in cold load, because it needs
+;;; RAW-INDEX and RAW-LENGTH information from LAYOUT-INFO, and LAYOUT-INFO
+;;; isn't initialized early in cold load.)
+;;;
+;;; FIXME: It's nasty having to maintain this hand-written copy function. And
+;;; it seems intrinsically dain-bramaged to have RAW-INDEX and RAW-LENGTH in
+;;; LAYOUT-INFO instead of directly in LAYOUT. We should fix this: * Move
+;;; RAW-INDEX and RAW-LENGTH slots into LAYOUT itself. * Rewrite the various
+;;; CHECK-LAYOUT-related functions so that they check RAW-INDEX and RAW-LENGTH
+;;; too. * Remove this special hacked copy function, just use COPY-STRUCTURE
+;;; instead. (For even more improvement, it'd be good to move the raw slots
+;;; into the same object as the ordinary slots, instead of having the
+;;; unfortunate extra level of indirection. But that'd probably require a lot
+;;; of work, including updating the garbage collector to understand it.)
+(declaim (ftype (function (type-class) type-class) copy-type-class-coldly))
+(defun copy-type-class-coldly (x)
+ ;; KLUDGE: If the slots of TYPE-CLASS ever change, the slots here will have
+ ;; to be hand-tweaked to match. -- WHN 19991021
+ (make-type-class :name (type-class-name x)
+ :simple-subtypep (type-class-simple-subtypep x)
+ :complex-subtypep-arg1 (type-class-complex-subtypep-arg1 x)
+ :complex-subtypep-arg2 (type-class-complex-subtypep-arg2 x)
+ :simple-union (type-class-simple-union x)
+ :complex-union (type-class-complex-union x)
+ :simple-intersection (type-class-simple-intersection x)
+ :complex-intersection (type-class-complex-intersection x)
+ :simple-= (type-class-simple-= x)
+ :complex-= (type-class-complex-= x)
+ :unparse (type-class-unparse x)))
+
+;;; KLUDGE: If the slots of TYPE-CLASS ever change, the slots here will have to
+;;; be tweaked to match. -- WHN 19991021
+(defconstant type-class-function-slots
+ '((:simple-subtypep . type-class-simple-subtypep)
+ (:complex-subtypep-arg1 . type-class-complex-subtypep-arg1)
+ (:complex-subtypep-arg2 . type-class-complex-subtypep-arg2)
+ (:simple-union . type-class-simple-union)
+ (:complex-union . type-class-complex-union)
+ (:simple-intersection . type-class-simple-intersection)
+ (:complex-intersection . type-class-complex-intersection)
+ (:simple-= . type-class-simple-=)
+ (:complex-= . type-class-complex-=)
+ (:unparse . type-class-unparse)))
+
+(defun class-function-slot-or-lose (name)
+ (or (cdr (assoc name type-class-function-slots))
+ (error "~S is not a defined type class method." name)))
+;;; FIXME: This seems to be called at runtime by cold init code.
+;;; Make sure that it's not being called at runtime anywhere but
+;;; one-time toplevel initialization code.
+
+) ; EVAL-WHEN
+
+(defmacro define-type-method ((class method &rest more-methods)
+ lambda-list &body body)
+ #!+sb-doc
+ "DEFINE-TYPE-METHOD (Class-Name Method-Name+) Lambda-List Form*"
+ (let ((name (symbolicate CLASS "-" method "-TYPE-METHOD")))
+ `(progn
+ (defun ,name ,lambda-list ,@body)
+ (!cold-init-forms
+ ,@(mapcar #'(lambda (method)
+ `(setf (,(class-function-slot-or-lose method)
+ (type-class-or-lose ',class))
+ #',name))
+ (cons method more-methods)))
+ ',name)))
+
+(defmacro define-type-class (name &key inherits)
+ `(!cold-init-forms
+ ,(once-only ((n-class (if inherits
+ `(copy-type-class-coldly (type-class-or-lose
+ ',inherits))
+ '(make-type-class))))
+ `(progn
+ (setf (type-class-name ,n-class) ',name)
+ (setf (gethash ',name *type-classes*) ,n-class)
+ ',name))))
+
+;;; Invoke a type method on TYPE1 and TYPE2. If the two types have the same
+;;; class, invoke the simple method. Otherwise, invoke any complex method. If
+;;; there isn't a distinct COMPLEX-ARG1 method, then swap the arguments when
+;;; calling TYPE1's method. If no applicable method, return DEFAULT.
+(defmacro invoke-type-method (simple complex-arg2 type1 type2 &key
+ (default '(values nil t))
+ (complex-arg1 :foo complex-arg1-p))
+ (declare (type keyword simple complex-arg1 complex-arg2))
+ `(multiple-value-bind (result-a result-b valid-p)
+ (%invoke-type-method ',(class-function-slot-or-lose simple)
+ ',(class-function-slot-or-lose
+ (if complex-arg1-p
+ complex-arg1
+ complex-arg2))
+ ',(class-function-slot-or-lose complex-arg2)
+ ,complex-arg1-p
+ ,type1
+ ,type2)
+ (if valid-p
+ (values result-a result-b)
+ ,default)))
+
+;;; most of the implementation of INVOKE-TYPE-METHOD
+;;;
+;;; KLUDGE: This function must be INLINE in order for cold init to work,
+;;; because the first three arguments are TYPE-CLASS structure accessor
+;;; functions whose calls have to be compiled inline in order to work in calls
+;;; to this function early in cold init. So don't conditionalize this INLINE
+;;; declaration with #!+SB-FLUID or anything, unless you also rearrange things
+;;; to cause the full function definitions of the relevant structure accessors
+;;; to be available sufficiently early in cold init. -- WHN 19991015
+#!-sb-fluid (declaim (inline %invoke-type-method))
+(defun %invoke-type-method (simple cslot1 cslot2 complex-arg1-p type1 type2)
+ (declare (type symbol simple cslot1 cslot2))
+ (multiple-value-bind (result-a result-b)
+ (let ((class1 (type-class-info type1))
+ (class2 (type-class-info type2)))
+ (if (eq class1 class2)
+ (funcall (funcall simple class1) type1 type2)
+ (let ((complex2 (funcall cslot2 class2)))
+ (if complex2
+ (funcall complex2 type1 type2)
+ (let ((complex1 (funcall cslot1 class1)))
+ (if complex1
+ (if complex-arg1-p
+ (funcall complex1 type1 type2)
+ (funcall complex1 type2 type1))
+ ;; No meaningful result was found: the caller should use the
+ ;; default value instead.
+ (return-from %invoke-type-method (values nil nil nil))))))))
+ ;; If we get to here (without breaking out by calling RETURN-FROM) then
+ ;; a meaningful result was found, and we return it.
+ (values result-a result-b t)))
+
+(!defun-from-collected-cold-init-forms !type-class-cold-init)
--- /dev/null
+;;;; When this file's top-level forms are run, it precomputes the
+;;;; translations for commonly used type specifiers. This stuff is
+;;;; split off from the other type stuff to get around problems with
+;;;; everything needing to be loaded before everything else. This is
+;;;; the first file which really exercises the type stuff. This stuff
+;;;; is also somewhat implementation-dependent in that implementations
+;;;; may want to precompute other types which are important to them.
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!KERNEL")
+
+(file-comment
+ "$Header$")
+
+;;; built-in classes
+(/show0 "beginning type-init.lisp")
+(dolist (x *built-in-classes*)
+ (destructuring-bind (name &key (translation nil trans-p) &allow-other-keys)
+ x
+ #+sb-show (progn
+ (/show0 "doing class with name=..")
+ #+sb-xc-host (/show0 name)
+ #-sb-xc-host (%primitive print (symbol-name name)))
+ (when trans-p
+ (/show0 "in TRANS-P case")
+ (let ((class (class-cell-class (find-class-cell name)))
+ (type (specifier-type translation)))
+ (setf (built-in-class-translation class) type)
+ (setf (info :type :builtin name) type)))))
+
+;;; numeric types
+(/show0 "precomputing numeric types")
+(precompute-types '((mod 2) (mod 4) (mod 16) (mod #x100) (mod #x10000)
+ (mod #x100000000)
+ (unsigned-byte 1) (unsigned-byte 2) (unsigned-byte 4)
+ (unsigned-byte 8) (unsigned-byte 16) (unsigned-byte 32)
+ (signed-byte 8) (signed-byte 16) (signed-byte 32)))
+
+;;; built-in symbol type specifiers
+(/show0 "precomputing built-in symbol type specifiers")
+(precompute-types *standard-type-names*)
+
+;;; FIXME: It should be possible to do this in the cross-compiler,
+;;; but currently the cross-compiler's type system is too dain-bramaged to
+;;; handle it. (Various consistency checks are disabled when this flag
+;;; is false, and the cross-compiler's type system can't pass these
+;;; checks. Some of the problems are quite severe, e.g. mismatch between
+;;; LAYOUTs generated by DEF!STRUCT and LAYOUTs generated by real
+;;; DEFSTRUCT due to DEF!STRUCT not understanding raw slots -- it's
+;;; actually somewhat remarkable that the system works..)
+; #+sb-xc-host (setf *type-system-initialized* t)
+
+(/show0 "done with type-init.lisp")
--- /dev/null
+;;;; This file contains the definition of the CTYPE (Compiler TYPE)
+;;;; structure and related macros used for manipulating it. This is
+;;;; sort of a mini object system with rather odd dispatching rules.
+;;;; Other compile-time definitions needed by multiple files are also
+;;;; here.
+;;;;
+;;;; FIXME: The comment above about what's in this file is no longer so
+;;;; true now that I've split off type-class.lisp. Perhaps we should
+;;;; split off CTYPE into the same file as type-class.lisp, rename that
+;;;; file to ctype.lisp, move the current comment to the head of that file,
+;;;; and write a new comment for this file saying how this file holds
+;;;; concrete types.
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!KERNEL")
+
+(file-comment
+ "$Header$")
+
+(!begin-collecting-cold-init-forms)
+
+;;; Define the translation from a type-specifier to a type structure for
+;;; some particular type. Syntax is identical to DEFTYPE.
+(defmacro def-type-translator (name arglist &body body)
+ (check-type name symbol)
+ ;; FIXME: Now that the T%CL hack is ancient history and we just use CL
+ ;; instead, we can probably return to using PARSE-DEFMACRO here.
+ ;;
+ ;; was:
+ ;; This song and dance more or less emulates PARSE-DEFMACRO. The reason for
+ ;; doing this emulation instead of just calling PARSE-DEFMACRO is just that
+ ;; at cross-compile time PARSE-DEFMACRO expects lambda-list keywords in the
+ ;; T%CL package, which is not what we have here. Maybe there's a tidier
+ ;; solution.. (Other than wishing that ANSI had used symbols in the KEYWORD
+ ;; package as lambda list keywords, rather than using symbols in the LISP
+ ;; package!)
+ (multiple-value-bind (whole wholeless-arglist)
+ (if (eq '&whole (car arglist))
+ (values (cadr arglist) (cddr arglist))
+ (values (gensym) arglist))
+ (multiple-value-bind (forms decls) (parse-body body nil)
+ `(progn
+ (!cold-init-forms
+ (setf (info :type :translator ',name)
+ (lambda (,whole)
+ (block ,name
+ (destructuring-bind ,wholeless-arglist
+ (rest ,whole) ; discarding NAME
+ ,@decls
+ ,@forms)))))
+ ',name))))
+
+;;; DEFVARs for these come later, after we have enough stuff defined.
+(declaim (special *wild-type* *universal-type* *empty-type*))
+\f
+;;; The XXX-Type structures include the CTYPE structure for some slots that
+;;; apply to all types.
+(def!struct (ctype (:conc-name type-)
+ (:constructor nil)
+ (:make-load-form-fun make-type-load-form)
+ #-sb-xc-host (:pure t))
+ ;; The class of this type.
+ ;;
+ ;; FIXME: It's unnecessarily confusing to have a structure accessor
+ ;; named TYPE-CLASS-INFO which is an accessor for the CTYPE structure
+ ;; even though the TYPE-CLASS structure also exists in the system.
+ ;; Rename this slot: TYPE-CLASS or ASSOCIATED-TYPE-CLASS or something.
+ (class-info (required-argument) :type type-class)
+ ;; True if this type has a fixed number of members, and as such could
+ ;; possibly be completely specified in a MEMBER type. This is used by the
+ ;; MEMBER type methods.
+ (enumerable nil :type (member t nil) :read-only t)
+ ;; an arbitrary hash code used in EQ-style hashing of identity (since EQ
+ ;; hashing can't be done portably)
+ (hash-value (random (1+ most-positive-fixnum))
+ :type (and fixnum unsigned-byte)
+ :read-only t))
+(def!method print-object ((ctype ctype) stream)
+ (print-unreadable-object (ctype stream :type t)
+ (prin1 (type-specifier ctype) stream)))
+
+;;; Just dump it as a specifier. (We'll convert it back upon loading.)
+(defun make-type-load-form (type)
+ (declare (type ctype type))
+ `(specifier-type ',(type-specifier type)))
+\f
+;;;; utilities
+
+;;; Like ANY and EVERY, except that we handle two-arg uncertain predicates.
+;;; If the result is uncertain, then we return Default from the block PUNT.
+;;; If LIST-FIRST is true, then the list element is the first arg, otherwise
+;;; the second.
+(defmacro any-type-op (op thing list &key (default '(values nil nil))
+ list-first)
+ (let ((n-this (gensym))
+ (n-thing (gensym))
+ (n-val (gensym))
+ (n-win (gensym))
+ (n-uncertain (gensym)))
+ `(let ((,n-thing ,thing)
+ (,n-uncertain nil))
+ (dolist (,n-this ,list
+ (if ,n-uncertain
+ (return-from PUNT ,default)
+ nil))
+ (multiple-value-bind (,n-val ,n-win)
+ ,(if list-first
+ `(,op ,n-this ,n-thing)
+ `(,op ,n-thing ,n-this))
+ (unless ,n-win (setq ,n-uncertain t))
+ (when ,n-val (return t)))))))
+(defmacro every-type-op (op thing list &key (default '(values nil nil))
+ list-first)
+ (let ((n-this (gensym))
+ (n-thing (gensym))
+ (n-val (gensym))
+ (n-win (gensym)))
+ `(let ((,n-thing ,thing))
+ (dolist (,n-this ,list t)
+ (multiple-value-bind (,n-val ,n-win)
+ ,(if list-first
+ `(,op ,n-this ,n-thing)
+ `(,op ,n-thing ,n-this))
+ (unless ,n-win (return-from PUNT ,default))
+ (unless ,n-val (return nil)))))))
+
+;;; Compute the intersection for types that intersect only when one is a
+;;; hierarchical subtype of the other.
+(defun vanilla-intersection (type1 type2)
+ (multiple-value-bind (stp1 win1) (csubtypep type1 type2)
+ (multiple-value-bind (stp2 win2) (csubtypep type2 type1)
+ (cond (stp1 (values type1 t))
+ (stp2 (values type2 t))
+ ((and win1 win2) (values *empty-type* t))
+ (t
+ (values type1 nil))))))
+
+(defun vanilla-union (type1 type2)
+ (cond ((csubtypep type1 type2) type2)
+ ((csubtypep type2 type1) type1)
+ (t nil)))
+
+;;; Hash two things (types) down to 8 bits. In CMU CL this was an EQ hash, but
+;;; since it now needs to run in vanilla ANSI Common Lisp at cross-compile
+;;; time, it's now based on the CTYPE-HASH-VALUE field instead.
+;;;
+;;; FIXME: This was a macro in CMU CL, and is now an INLINE function. Is
+;;; it important for it to be INLINE, or could be become an ordinary
+;;; function without significant loss? -- WHN 19990413
+#!-sb-fluid (declaim (inline type-cache-hash))
+(declaim (ftype (function (ctype ctype) (unsigned-byte 8)) type-cache-hash))
+(defun type-cache-hash (type1 type2)
+ (logand (logxor (ash (type-hash-value type1) -3)
+ (type-hash-value type2))
+ #xFF))
+\f
+;;;; cold loading initializations
+
+(!defun-from-collected-cold-init-forms !typedefs-cold-init)
--- /dev/null
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!KERNEL")
+
+(file-comment
+ "$Header$")
+
+;;; The actual TYPEP engine. The compiler only generates calls to this
+;;; function when it can't figure out anything more intelligent to do.
+(defun %typep (object specifier)
+ (%%typep object
+ (if (ctype-p specifier)
+ specifier
+ (specifier-type specifier))))
+(defun %%typep (object type)
+ (declare (type ctype type))
+ (etypecase type
+ (named-type
+ (ecase (named-type-name type)
+ ((* t) t)
+ ((nil) nil)))
+ (numeric-type
+ (and (numberp object)
+ (let ((num (if (complexp object) (realpart object) object)))
+ (ecase (numeric-type-class type)
+ (integer (integerp num))
+ (rational (rationalp num))
+ (float
+ (ecase (numeric-type-format type)
+ (short-float (typep num 'short-float))
+ (single-float (typep num 'single-float))
+ (double-float (typep num 'double-float))
+ (long-float (typep num 'long-float))
+ ((nil) (floatp num))))
+ ((nil) t)))
+ #!-negative-zero-is-not-zero
+ (flet ((bound-test (val)
+ (let ((low (numeric-type-low type))
+ (high (numeric-type-high type)))
+ (and (cond ((null low) t)
+ ((listp low) (> val (car low)))
+ (t (>= val low)))
+ (cond ((null high) t)
+ ((listp high) (< val (car high)))
+ (t (<= val high)))))))
+ (ecase (numeric-type-complexp type)
+ ((nil) t)
+ (:complex
+ (and (complexp object)
+ (bound-test (realpart object))
+ (bound-test (imagpart object))))
+ (:real
+ (and (not (complexp object))
+ (bound-test object)))))
+ #!+negative-zero-is-not-zero
+ (labels ((signed-> (x y)
+ (if (and (zerop x) (zerop y) (floatp x) (floatp y))
+ (> (float-sign x) (float-sign y))
+ (> x y)))
+ (signed->= (x y)
+ (if (and (zerop x) (zerop y) (floatp x) (floatp y))
+ (>= (float-sign x) (float-sign y))
+ (>= x y)))
+ (bound-test (val)
+ (let ((low (numeric-type-low type))
+ (high (numeric-type-high type)))
+ (and (cond ((null low) t)
+ ((listp low)
+ (signed-> val (car low)))
+ (t
+ (signed->= val low)))
+ (cond ((null high) t)
+ ((listp high)
+ (signed-> (car high) val))
+ (t
+ (signed->= high val)))))))
+ (ecase (numeric-type-complexp type)
+ ((nil) t)
+ (:complex
+ (and (complexp object)
+ (bound-test (realpart object))
+ (bound-test (imagpart object))))
+ (:real
+ (and (not (complexp object))
+ (bound-test object)))))))
+ (array-type
+ (and (arrayp object)
+ (ecase (array-type-complexp type)
+ ((t) (not (typep object 'simple-array)))
+ ((nil) (typep object 'simple-array))
+ ((:maybe) t))
+ (or (eq (array-type-dimensions type) '*)
+ (do ((want (array-type-dimensions type) (cdr want))
+ (got (array-dimensions object) (cdr got)))
+ ((and (null want) (null got)) t)
+ (unless (and want got
+ (or (eq (car want) '*)
+ (= (car want) (car got))))
+ (return nil))))
+ (or (eq (array-type-element-type type) *wild-type*)
+ (values (type= (array-type-specialized-element-type type)
+ (specifier-type (array-element-type
+ object)))))))
+ (member-type
+ (if (member object (member-type-members type)) t))
+ (sb!xc:class
+ #+sb-xc-host (ctypep object type)
+ #-sb-xc-host (class-typep (layout-of object) type object))
+ (union-type
+ (dolist (type (union-type-types type))
+ (when (%%typep object type)
+ (return t))))
+ (unknown-type
+ ;; dunno how to do this ANSIly -- WHN 19990413
+ #+sb-xc-host (error "stub: %%TYPEP UNKNOWN-TYPE in xcompilation host")
+ ;; Parse it again to make sure it's really undefined.
+ (let ((reparse (specifier-type (unknown-type-specifier type))))
+ (if (typep reparse 'unknown-type)
+ (error "unknown type specifier: ~S"
+ (unknown-type-specifier reparse))
+ (%%typep object reparse))))
+ (hairy-type
+ ;; Now the tricky stuff.
+ (let* ((hairy-spec (hairy-type-specifier type))
+ (symbol (if (consp hairy-spec) (car hairy-spec) hairy-spec)))
+ (ecase symbol
+ (and
+ (or (atom hairy-spec)
+ (dolist (spec (cdr hairy-spec) t)
+ (unless (%%typep object (specifier-type spec))
+ (return nil)))))
+ (not
+ (unless (proper-list-of-length-p hairy-spec 2)
+ (error "invalid type specifier: ~S" hairy-spec))
+ (not (%%typep object (specifier-type (cadr hairy-spec)))))
+ (satisfies
+ (unless (proper-list-of-length-p hairy-spec 2)
+ (error "invalid type specifier: ~S" hairy-spec))
+ (let ((fn (cadr hairy-spec)))
+ (if (funcall (typecase fn
+ (function fn)
+ (symbol (symbol-function fn))
+ (t
+ (coerce fn 'function)))
+ object)
+ t
+ nil))))))
+ (alien-type-type
+ (sb!alien-internals:alien-typep object (alien-type-type-alien-type type)))
+ (function-type
+ (error "Function types are not a legal argument to TYPEP:~% ~S"
+ (type-specifier type)))))
+
+;;; Do type test from a class cell, allowing forward reference and
+;;; redefinition.
+(defun class-cell-typep (obj-layout cell object)
+ (let ((class (class-cell-class cell)))
+ (unless class
+ (error "The class ~S has not yet been defined." (class-cell-name cell)))
+ (class-typep obj-layout class object)))
+
+;;; Test whether Obj-Layout is from an instance of Class.
+(defun class-typep (obj-layout class object)
+ (declare (optimize speed))
+ (when (layout-invalid obj-layout)
+ (if (and (typep (sb!xc:class-of object) 'sb!xc:standard-class) object)
+ (setq obj-layout (pcl-check-wrapper-validity-hook object))
+ (error "TYPEP was called on an obsolete object (was class ~S)."
+ (class-proper-name (layout-class obj-layout)))))
+ (let ((layout (class-layout class))
+ (obj-inherits (layout-inherits obj-layout)))
+ (when (layout-invalid layout)
+ (error "The class ~S is currently invalid." class))
+ (or (eq obj-layout layout)
+ (dotimes (i (length obj-inherits) nil)
+ (when (eq (svref obj-inherits i) layout)
+ (return t))))))
+
+;;; to be redefined as PCL::CHECK-WRAPPER-VALIDITY when PCL is loaded
+;;;
+;;; FIXME: should probably be renamed SB!PCL:CHECK-WRAPPER-VALIDITY
+(defun pcl-check-wrapper-validity-hook (object)
+ object)
--- /dev/null
+;;;; converting symbols from SB-XC::FOO to COMMON-LISP::FOO when
+;;;; cross-compiling (so that we can maintain distinct SB!XC versions
+;;;; of fundamental COMMON-LISP things like PROCLAIM and CLASS and
+;;;; ARRAY-RANK-LIMIT, so that we don't trash the cross-compilation
+;;;; host when defining the cross-compiler, but the distinctions go
+;;;; away in the target system)
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!INT")
+
+;;;; $Header$
+
+;;; In the target system's compiler, uncrossing is just identity.
+#-sb-xc-host
+(progn
+ #!-sb-fluid (declaim (inline uncross))
+ (defun uncross (x) x))
+;;; In the cross-compiler, uncrossing is slightly less trivial.
+
+;;; This condition is only a STYLE-WARNING because generally it isn't important
+;;; in practice to recurse through anything except CONSes anyway.
+#|
+#!+sb-show
+(define-condition uncross-rcr-failure (style-warning)
+ ((form :initarg :form :reader uncross-rcr-failure-form))
+ (:report (lambda (c s)
+ (format s
+ "UNCROSS couldn't recurse through ~S~%~
+ (which is OK as long as there are no SB-XC symbols ~
+ down there)"
+ (uncross-rcr-failure-form c)))))
+|#
+
+;;; When cross-compiling, EVAL-WHEN :COMPILE-TOPLEVEL code is executed in the
+;;; host Common Lisp, not the target. A certain amount of dancing around is
+;;; required in order for this to work more or less correctly. (Fortunately,
+;;; more or less correctly is good enough -- it only needs to work on the
+;;; EVAL-WHEN expressions found in the SBCL sources themselves, and we can
+;;; exercise self-control to keep them from including anything which too
+;;; strongly resembles a language lawyer's test case.)
+;;;
+;;; In order to make the dancing happen, we need to make a distinction between
+;;; SB!XC and COMMON-LISP when we're executing a form at compile time (i.e.
+;;; within EVAL-WHEN :COMPILE-TOPLEVEL) but we need to treat SB!XC as
+;;; synonymous with COMMON-LISP otherwise. This can't be done by making SB!XC a
+;;; nickname of COMMON-LISP, because the reader processes things before
+;;; EVAL-WHEN, so by the time EVAL-WHEN :COMPILE-TOPLEVEL saw a form, the
+;;; distinction it needs would be lost. Instead, we read forms preserving this
+;;; distinction (treating SB!XC as a separate package), and only when we're
+;;; about to process them (for any situation other than
+;;; EVAL-WHEN (:COMPILE-TOPLEVEL)) do we call UNCROSS on them to obliterate the
+;;; distinction.
+#+sb-xc-host
+(defun uncross (form)
+ (let ((;; KLUDGE: We don't currently try to handle circular program
+ ;; structure, but we do at least detect it and complain about it..
+ inside? (make-hash-table)))
+ (labels ((uncross-symbol (symbol)
+ (let ((old-symbol-package (symbol-package symbol)))
+ (if (and old-symbol-package
+ (string= (package-name old-symbol-package) "SB-XC"))
+ (values (intern (symbol-name symbol) "COMMON-LISP"))
+ symbol)))
+ (rcr (form)
+ (cond ((symbolp form)
+ (uncross-symbol form))
+ ((or (numberp form)
+ (characterp form)
+ (stringp form))
+ form)
+ (t
+ ;; If we reach here, FORM is something with internal
+ ;; structure which could include symbols in the SB-XC
+ ;; package.
+ (when (gethash form inside?)
+ (let ((*print-circle* t))
+ ;; This code could probably be generalized to work on
+ ;; circular structure, but it seems easier just to
+ ;; avoid putting any circular structure into the
+ ;; bootstrap code.
+ (error "circular structure in ~S" form)))
+ (setf (gethash form inside?) t)
+ (unwind-protect
+ (typecase form
+ (cons (rcr-cons form))
+ ;; Note: This function was originally intended to
+ ;; search through structures other than CONS, but
+ ;; it got into trouble with LAYOUT-CLASS and
+ ;; CLASS-LAYOUT circular structure. After some
+ ;; messing around, it turned out that recursing
+ ;; through CONS is all that's needed in practice.)
+ ;; FIXME: This leaves a lot of stale code here
+ ;; (already commented/NILed out) for us to delete.
+ #+nil ; only searching through CONS
+ (simple-vector (rcr-simple-vector form))
+ #+nil ; only searching through CONS
+ (structure!object
+ (rcr-structure!object form))
+ (t
+ ;; KLUDGE: I know that UNCROSS is far from
+ ;; perfect, but it's good enough to cross-compile
+ ;; the current sources, and getting hundreds of
+ ;; warnings about individual cases it can't
+ ;; recurse through, so the warning here has been
+ ;; turned off. Eventually it would be nice either
+ ;; to set up a cleaner way of cross-compiling
+ ;; which didn't have this problem, or to make
+ ;; an industrial-strength version of UNCROSS
+ ;; which didn't fail this way. -- WHN 20000201
+ #+nil (warn 'uncross-rcr-failure :form form)
+ form))
+ (remhash form inside?)))))
+ (rcr-cons (form)
+ (declare (type cons form))
+ (let* ((car (car form))
+ (rcr-car (rcr car))
+ (cdr (cdr form))
+ (rcr-cdr (rcr cdr)))
+ (if (and (eq rcr-car car) (eq rcr-cdr cdr))
+ form
+ (cons rcr-car rcr-cdr))))
+ #+nil ; only searching through CONS in this version
+ (rcr-simple-vector (form)
+ (declare (type simple-vector form))
+ (dotimes (i (length form))
+ (let* ((aref (aref form i))
+ (rcr-aref (rcr aref)))
+ (unless (eq rcr-aref aref)
+ (return (map 'vector #'rcr form))))
+ form))
+ #+nil ; only searching through CONS in this version
+ (rcr-structure!object (form)
+ (declare (type structure!object form))
+ ;; Note: We skip the zeroth slot because it's used for LAYOUT,
+ ;; which shouldn't require any translation and which is
+ ;; complicated to think about anyway.
+ (do ((i 1 (1+ i)))
+ ((>= i (%instance-length form)) form)
+ (let* ((instance-ref (%instance-ref form i))
+ (rcr-instance-ref (rcr instance-ref)))
+ (unless (eq rcr-instance-ref instance-ref)
+ (return (rcr!-structure!object
+ (copy-structure form)))))))
+ #+nil ; only searching through CONS in this version
+ (rcr!-structure!object (form)
+ (declare (type structure!object form))
+ ;; As in RCR-STRUCTURE!OBJECT, we skip the zeroth slot.
+ (do ((i 1 (1+ i)))
+ ((>= i (%instance-length form)))
+ (let* ((instance-ref (%instance-ref form i))
+ (rcr-instance-ref (rcr instance-ref)))
+ ;; (By only calling SETF when strictly necessary,
+ ;; we avoid bombing out unnecessarily when the
+ ;; I-th slot happens to be read-only.)
+ (unless (eq rcr-instance-ref instance-ref)
+ (setf (%instance-ref form i)
+ rcr-instance-ref))))))
+ (rcr form))))
--- /dev/null
+;;;; This file contains Unix support that SBCL needs to implement itself. It's
+;;;; derived from Peter Van Eynde's unix-glibc2.lisp for CMU CL, which was
+;;;; derived from CMU CL unix.lisp 1.56. But those files aspired to be complete
+;;;; Unix interfaces exported to the end user, while this file aims to be as
+;;;; simple as possible and is not intended for the end user.
+;;;;
+;;;; FIXME: The old CMU CL unix.lisp code was implemented as hand
+;;;; transcriptions from Unix headers into Lisp. It appears that this was as
+;;;; unmaintainable in practice as you'd expect in theory, so I really really
+;;;; don't want to do that. It'd be good to implement the various system calls
+;;;; as C code implemented using the Unix header files, and have their
+;;;; interface back to SBCL code be characterized by things like "32-bit-wide
+;;;; int" which are already in the interface between the runtime
+;;;; executable and the SBCL lisp code.
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!UNIX")
+
+(file-comment
+ "$Header$")
+
+(/show0 "unix.lisp 21")
+
+;;;; common machine-independent structures
+
+(eval-when (:compile-toplevel :execute)
+
+(defparameter *compiler-unix-errors* nil)
+
+(/show0 "unix.lisp 29")
+
+(sb!xc:defmacro def-unix-error (name number description)
+ `(progn
+ (eval-when (:compile-toplevel :execute)
+ (push (cons ,number ,description) *compiler-unix-errors*))
+ (eval-when (:compile-toplevel :load-toplevel :execute)
+ (defconstant ,name ,number ,description))))
+
+(sb!xc:defmacro emit-unix-errors ()
+ (let* ((max (apply #'max (mapcar #'car *compiler-unix-errors*)))
+ (array (make-array (1+ max) :initial-element nil)))
+ (dolist (error *compiler-unix-errors*)
+ (setf (svref array (car error)) (cdr error)))
+ `(progn
+ (defvar *unix-errors* ',array)
+ (proclaim '(simple-vector *unix-errors*)))))
+
+) ; EVAL-WHEN
+
+(defvar *unix-errors*)
+
+(/show0 "unix.lisp 52")
+
+(defmacro def-enum (inc cur &rest names)
+ (flet ((defform (name)
+ (prog1 (when name `(defconstant ,name ,cur))
+ (setf cur (funcall inc cur 1)))))
+ `(progn ,@(mapcar #'defform names))))
+\f
+;;;; Lisp types used by syscalls
+
+(deftype unix-pathname () 'simple-string)
+(deftype unix-fd () `(integer 0 ,most-positive-fixnum))
+
+(deftype unix-file-mode () '(unsigned-byte 32))
+(deftype unix-pid () '(unsigned-byte 32))
+(deftype unix-uid () '(unsigned-byte 32))
+(deftype unix-gid () '(unsigned-byte 32))
+\f
+;;;; system calls
+
+(def-alien-routine ("os_get_errno" get-errno) integer
+ "Return the value of the C library pseudo-variable named \"errno\".")
+
+(/show0 "unix.lisp 74")
+
+(defun get-unix-error-msg (&optional (error-number (get-errno)))
+ #!+sb-doc
+ "Returns a string describing the error number which was returned by a
+ UNIX system call."
+ (declare (type integer error-number))
+ (if (array-in-bounds-p *unix-errors* error-number)
+ (svref *unix-errors* error-number)
+ (format nil "unknown error [~D]" error-number)))
+
+;;; FIXME: The various FOO-SYSCALL-BAR macros, and perhaps some other
+;;; macros in this file, are only used in this file, and could be
+;;; implemented using SB!XC:DEFMACRO wrapped in EVAL-WHEN.
+
+(defmacro syscall ((name &rest arg-types) success-form &rest args)
+ `(let ((result (alien-funcall (extern-alien ,name (function int ,@arg-types))
+ ,@args)))
+ (if (minusp result)
+ (values nil (get-errno))
+ ,success-form)))
+
+;;; Like SYSCALL, but if it fails, signal an error instead of returning error
+;;; codes. Should only be used for syscalls that will never really get an
+;;; error.
+(defmacro syscall* ((name &rest arg-types) success-form &rest args)
+ `(let ((result (alien-funcall (extern-alien ,name (function int ,@arg-types))
+ ,@args)))
+ (if (minusp result)
+ (error "Syscall ~A failed: ~A" ,name (get-unix-error-msg))
+ ,success-form)))
+
+(/show0 "unix.lisp 109")
+
+(defmacro void-syscall ((name &rest arg-types) &rest args)
+ `(syscall (,name ,@arg-types) (values t 0) ,@args))
+
+(defmacro int-syscall ((name &rest arg-types) &rest args)
+ `(syscall (,name ,@arg-types) (values result 0) ,@args))
+\f
+;;; from stdio.h
+
+(/show0 "unix.lisp 124")
+
+(defun unix-rename (name1 name2)
+ #!+sb-doc
+ "Unix-rename renames the file with string name1 to the string
+ name2. NIL and an error code is returned if an error occurs."
+ (declare (type unix-pathname name1 name2))
+ (void-syscall ("rename" c-string c-string) name1 name2))
+\f
+;;; from stdlib.h
+
+(def-alien-routine ("getenv" posix-getenv) c-string
+ "Return the environment string \"name=value\" which corresponds to NAME, or
+ NIL if there is none."
+ (name c-string))
+\f
+;;; from sys/types.h and gnu/types.h
+
+(/show0 "unix.lisp 144")
+
+(defconstant +max-s-long+ 2147483647)
+(defconstant +max-u-long+ 4294967295)
+
+;;; FIXME: Isn't there some way to use a C wrapper to avoid this hand-copying?
+(def-alien-type quad-t #+nil long-long #-nil (array long 2))
+(def-alien-type uquad-t #+nil unsigned-long-long
+ #-nil (array unsigned-long 2))
+(def-alien-type qaddr-t (* quad-t))
+(def-alien-type daddr-t int)
+(def-alien-type caddr-t (* char))
+(def-alien-type swblk-t long)
+(def-alien-type size-t unsigned-int)
+(def-alien-type time-t long)
+(def-alien-type clock-t
+ #!+linux long
+ #!+bsd unsigned-long)
+(def-alien-type uid-t unsigned-int)
+(def-alien-type ssize-t int)
+
+(/show0 "unix.lisp 163")
+
+;;; FIXME: We shouldn't hand-copy types from header files into Lisp like this
+;;; unless we have extreme provocation. Reading directories is not extreme
+;;; enough, since it doesn't need to be blindingly fast: we can just implement
+;;; those functions in C as a wrapper layer.
+(def-alien-type fd-mask unsigned-long)
+(/show0 "unix.lisp 171")
+
+;;; FIXME: Isn't there some way to use a C wrapper to avoid this hand-copying?
+(def-alien-type dev-t
+ #!+linux uquad-t
+ #!+bsd unsigned-int)
+(def-alien-type uid-t unsigned-int)
+(def-alien-type gid-t unsigned-int)
+(def-alien-type ino-t
+ #!+linux unsigned-long
+ #!+bsd unsigned-int)
+(def-alien-type mode-t
+ #!+linux unsigned-int
+ #!+bsd unsigned-short)
+(def-alien-type nlink-t
+ #!+linux unsigned-int
+ #!+bsd unsigned-short)
+(/show0 "unix.lisp 190")
+
+;;; FIXME: We shouldn't hand-copy types from header files into Lisp like this
+;;; unless we have extreme provocation. Reading directories is not extreme
+;;; enough, since it doesn't need to be blindingly fast: we can just implement
+;;; those functions in C as a wrapper layer.
+
+(def-alien-type off-t
+ #!+linux long
+ #!+bsd quad-t)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (/show0 "unix.lisp 215")
+ (defconstant fd-setsize 1024))
+(/show0 "unix.lisp 217")
+
+(def-alien-type nil
+ (struct fd-set
+ (fds-bits (array fd-mask #.(/ fd-setsize 32)))))
+
+(/show0 "unix.lisp 223")
+\f
+;;;; direntry.h
+
+(def-alien-type nil
+ (struct direct
+ (d-ino long); inode number of entry
+ (d-off off-t) ; offset of next disk directory entry
+ (d-reclen unsigned-short) ; length of this record
+ (d_type unsigned-char)
+ (d-name (array char 256)))) ; name must be no longer than this
+(/show0 "unix.lisp 241")
+\f
+;;;; dirent.h
+
+;;; operations on Unix directories
+
+;;;; FIXME: It might be really nice to implement these in C, so that
+;;;; we don't need to do horrible things like hand-copying the
+;;;; direntry struct slot types into an alien struct.
+
+;;; FIXME: DIRECTORY is an external symbol of package CL, so we should use some
+;;; other name for this low-level implementation type.
+(defstruct directory
+ name
+ (dir-struct (required-argument) :type system-area-pointer))
+(/show0 "unix.lisp 258")
+
+(def!method print-object ((dir directory) stream)
+ (print-unreadable-object (dir stream :type t)
+ (prin1 (directory-name dir) stream)))
+
+(/show0 "unix.lisp 264")
+(defun open-dir (pathname)
+ (declare (type unix-pathname pathname))
+ (when (string= pathname "")
+ (setf pathname "."))
+ (let ((kind (unix-file-kind pathname)))
+ (case kind
+ (:directory
+ (let ((dir-struct
+ (alien-funcall (extern-alien "opendir"
+ (function system-area-pointer
+ c-string))
+ pathname)))
+ (if (zerop (sap-int dir-struct))
+ (values nil (get-errno))
+ (make-directory :name pathname :dir-struct dir-struct))))
+ ((nil)
+ (values nil enoent))
+ (t
+ (values nil enotdir)))))
+(/show0 "unix.lisp 286")
+
+(defun read-dir (dir)
+ (declare (type directory dir))
+ (let ((daddr (alien-funcall (extern-alien "readdir"
+ (function system-area-pointer
+ system-area-pointer))
+ (directory-dir-struct dir))))
+ (declare (type system-area-pointer daddr))
+ (if (zerop (sap-int daddr))
+ nil
+ (with-alien ((direct (* (struct direct)) daddr))
+ (values (cast (slot direct 'd-name) c-string)
+ (slot direct 'd-ino))))))
+
+(/show0 "unix.lisp 301")
+(defun close-dir (dir)
+ (declare (type directory dir))
+ (alien-funcall (extern-alien "closedir"
+ (function void system-area-pointer))
+ (directory-dir-struct dir))
+ nil)
+
+;;; dlfcn.h -> in foreign.lisp
+
+;;; fcntl.h
+;;;
+;;; POSIX Standard: 6.5 File Control Operations <fcntl.h>
+
+(/show0 "unix.lisp 318")
+(defconstant r_ok 4 #!+sb-doc "Test for read permission")
+(defconstant w_ok 2 #!+sb-doc "Test for write permission")
+(defconstant x_ok 1 #!+sb-doc "Test for execute permission")
+(defconstant f_ok 0 #!+sb-doc "Test for presence of file")
+
+(/show0 "unix.lisp 352")
+(defun unix-open (path flags mode)
+ #!+sb-doc
+ "Unix-open opens the file whose pathname is specified by path
+ for reading and/or writing as specified by the flags argument.
+ The flags argument can be:
+
+ o_rdonly Read-only flag.
+ o_wronly Write-only flag.
+ o_rdwr Read-and-write flag.
+ o_append Append flag.
+ o_creat Create-if-nonexistent flag.
+ o_trunc Truncate-to-size-0 flag.
+ o_excl Error if the file allready exists
+ o_noctty Don't assign controlling tty
+ o_ndelay Non-blocking I/O
+ o_sync Synchronous I/O
+ o_async Asynchronous I/O
+
+ If the o_creat flag is specified, then the file is created with
+ a permission of argument mode if the file doesn't exist. An
+ integer file descriptor is returned by unix-open."
+ (declare (type unix-pathname path)
+ (type fixnum flags)
+ (type unix-file-mode mode))
+ (int-syscall ("open" c-string int int) path flags mode))
+
+;;; UNIX-CLOSE accepts a file descriptor and attempts to close the file
+;;; associated with it.
+(/show0 "unix.lisp 391")
+(defun unix-close (fd)
+ #!+sb-doc
+ "Unix-close takes an integer file descriptor as an argument and
+ closes the file associated with it. T is returned upon successful
+ completion, otherwise NIL and an error number."
+ (declare (type unix-fd fd))
+ (void-syscall ("close" int) fd))
+\f
+;;; fcntlbits.h
+(eval-when (:compile-toplevel :load-toplevel :execute)
+
+(/show0 "unix.lisp 337")
+(defconstant o_rdonly 0) ; read-only flag
+(defconstant o_wronly 1) ; write-only flag
+(defconstant o_rdwr 2) ; read/write flag
+(defconstant o_accmode 3) ; access mode mask
+(defconstant o_creat ; create-if-nonexistent flag (not fcntl)
+ #!+linux #o100
+ #!+bsd #x0200)
+(/show0 "unix.lisp 345")
+(defconstant o_excl ; error if already exists (not fcntl)
+ #!+linux #o200
+ #!+bsd #x0800)
+(defconstant o_noctty ; Don't assign controlling tty. (not fcntl)
+ #!+linux #o400
+ #!+bsd #x8000)
+(defconstant o_trunc ; truncation flag (not fcntl)
+ #!+linux #o1000
+ #!+bsd #x0400)
+(defconstant o_append ; append flag
+ #!+linux #o2000
+ #!+bsd #x0008)
+(/show0 "unix.lisp 361")
+) ; EVAL-WHEN
+\f
+;;;; timebits.h
+
+;; A time value that is accurate to the nearest
+;; microsecond but also has a range of years.
+(def-alien-type nil
+ (struct timeval
+ (tv-sec time-t) ; seconds
+ (tv-usec time-t))) ; and microseconds
+\f
+;;;; resourcebits.h
+
+(defconstant rusage_self 0 #!+sb-doc "The calling process.")
+(defconstant rusage_children -1 #!+sb-doc "Terminated child processes.")
+(defconstant rusage_both -2)
+
+(def-alien-type nil
+ (struct rusage
+ (ru-utime (struct timeval)) ; user time used
+ (ru-stime (struct timeval)) ; system time used.
+ (ru-maxrss long) ; Maximum resident set size (in kilobytes)
+ (ru-ixrss long) ; integral shared memory size
+ (ru-idrss long) ; integral unshared data size
+ (ru-isrss long) ; integral unshared stack size
+ (ru-minflt long) ; page reclaims
+ (ru-majflt long) ; page faults
+ (ru-nswap long) ; swaps
+ (ru-inblock long) ; block input operations
+ (ru-oublock long) ; block output operations
+ (ru-msgsnd long) ; messages sent
+ (ru-msgrcv long) ; messages received
+ (ru-nsignals long) ; signals received
+ (ru-nvcsw long) ; voluntary context switches
+ (ru-nivcsw long))) ; involuntary context switches
+\f
+;;;; statbuf.h
+
+;;; FIXME: This should go into C code so that we don't need to hand-copy
+;;; it from header files.
+#!+Linux
+(def-alien-type nil
+ (struct stat
+ (st-dev dev-t)
+ (st-pad1 unsigned-short)
+ (st-ino ino-t)
+ (st-mode mode-t)
+ (st-nlink nlink-t)
+ (st-uid uid-t)
+ (st-gid gid-t)
+ (st-rdev dev-t)
+ (st-pad2 unsigned-short)
+ (st-size off-t)
+ (st-blksize unsigned-long)
+ (st-blocks unsigned-long)
+ (st-atime time-t)
+ (unused-1 unsigned-long)
+ (st-mtime time-t)
+ (unused-2 unsigned-long)
+ (st-ctime time-t)
+ (unused-3 unsigned-long)
+ (unused-4 unsigned-long)
+ (unused-5 unsigned-long)))
+
+#!+bsd
+(def-alien-type nil
+ (struct timespec-t
+ (tv-sec long)
+ (tv-nsec long)))
+
+#!+bsd
+(def-alien-type nil
+ (struct stat
+ (st-dev dev-t)
+ (st-ino ino-t)
+ (st-mode mode-t)
+ (st-nlink nlink-t)
+ (st-uid uid-t)
+ (st-gid gid-t)
+ (st-rdev dev-t)
+ (st-atime (struct timespec-t))
+ (st-mtime (struct timespec-t))
+ (st-ctime (struct timespec-t))
+ (st-size unsigned-long) ; really quad
+ (st-sizeh unsigned-long) ;
+ (st-blocks unsigned-long) ; really quad
+ (st-blocksh unsigned-long)
+ (st-blksize unsigned-long)
+ (st-flags unsigned-long)
+ (st-gen unsigned-long)
+ (st-lspare long)
+ (st-qspare (array long 4))
+ ))
+
+;; encoding of the file mode
+
+(defconstant s-ifmt #o0170000 #!+sb-doc "These bits determine file type.")
+
+;; file types
+(defconstant s-ififo #o0010000 #!+sb-doc "FIFO")
+(defconstant s-ifchr #o0020000 #!+sb-doc "Character device")
+(defconstant s-ifdir #o0040000 #!+sb-doc "Directory")
+(defconstant s-ifblk #o0060000 #!+sb-doc "Block device")
+(defconstant s-ifreg #o0100000 #!+sb-doc "Regular file")
+
+;; These don't actually exist on System V, but having them doesn't hurt.
+(defconstant s-iflnk #o0120000 #!+sb-doc "Symbolic link.")
+(defconstant s-ifsock #o0140000 #!+sb-doc "Socket.")
+\f
+;;;; unistd.h
+
+;;; values for the second argument to access
+(defun unix-access (path mode)
+ #!+sb-doc
+ "Given a file path (a string) and one of four constant modes,
+ UNIX-ACCESS returns T if the file is accessible with that
+ mode and NIL if not. It also returns an errno value with
+ NIL which determines why the file was not accessible.
+
+ The access modes are:
+ r_ok Read permission.
+ w_ok Write permission.
+ x_ok Execute permission.
+ f_ok Presence of file."
+ (declare (type unix-pathname path)
+ (type (mod 8) mode))
+ (void-syscall ("access" c-string int) path mode))
+
+(defconstant l_set 0 #!+sb-doc "set the file pointer")
+(defconstant l_incr 1 #!+sb-doc "increment the file pointer")
+(defconstant l_xtnd 2 #!+sb-doc "extend the file size")
+
+(defun unix-lseek (fd offset whence)
+ #!+sb-doc
+ "Unix-lseek accepts a file descriptor and moves the file pointer ahead
+ a certain offset for that file. Whence can be any of the following:
+
+ l_set Set the file pointer.
+ l_incr Increment the file pointer.
+ l_xtnd Extend the file size.
+ "
+ (declare (type unix-fd fd)
+ (type (unsigned-byte 32) offset)
+ (type (integer 0 2) whence))
+ #!-(and x86 bsd)
+ (int-syscall ("lseek" int off-t int) fd offset whence)
+ ;; Need a 64-bit return value type for this. TBD. For now,
+ ;; don't use this with any 2G+ partitions.
+ #!+(and x86 bsd)
+ (int-syscall ("lseek" int unsigned-long unsigned-long int)
+ fd offset 0 whence))
+
+;;; UNIX-READ accepts a file descriptor, a buffer, and the length to read.
+;;; It attempts to read len bytes from the device associated with fd
+;;; and store them into the buffer. It returns the actual number of
+;;; bytes read.
+(defun unix-read (fd buf len)
+ #!+sb-doc
+ "Unix-read attempts to read from the file described by fd into
+ the buffer buf until it is full. Len is the length of the buffer.
+ The number of bytes actually read is returned or NIL and an error
+ number if an error occurred."
+ (declare (type unix-fd fd)
+ (type (unsigned-byte 32) len))
+
+ (int-syscall ("read" int (* char) int) fd buf len))
+
+;;; UNIX-WRITE accepts a file descriptor, a buffer, an offset, and the
+;;; length to write. It attempts to write len bytes to the device
+;;; associated with fd from the the buffer starting at offset. It returns
+;;; the actual number of bytes written.
+(defun unix-write (fd buf offset len)
+ #!+sb-doc
+ "Unix-write attempts to write a character buffer (buf) of length
+ len to the file described by the file descriptor fd. NIL and an
+ error is returned if the call is unsuccessful."
+ (declare (type unix-fd fd)
+ (type (unsigned-byte 32) offset len))
+ (int-syscall ("write" int (* char) int)
+ fd
+ (with-alien ((ptr (* char) (etypecase buf
+ ((simple-array * (*))
+ (vector-sap buf))
+ (system-area-pointer
+ buf))))
+ (addr (deref ptr offset)))
+ len))
+
+;;; UNIX-CHDIR accepts a directory name and makes that the
+;;; current working directory.
+(defun unix-chdir (path)
+ #!+sb-doc
+ "Given a file path string, unix-chdir changes the current working
+ directory to the one specified."
+ (declare (type unix-pathname path))
+ (void-syscall ("chdir" c-string) path))
+
+(defun unix-current-directory ()
+ #!+sb-doc
+ "Return the current directory as a SIMPLE-STRING."
+ ;; FIXME: Gcc justifiably complains that getwd is dangerous and should
+ ;; not be used; especially with a hardwired 1024 buffer size, yecch.
+ ;; This should be rewritten to use getcwd(3), perhaps by writing
+ ;; a C service routine to do the actual call to getcwd(3) and check
+ ;; of return values.
+ (with-alien ((buf (array char 1024)))
+ (values (not (zerop (alien-funcall (extern-alien "getwd"
+ (function int (* char)))
+ (cast buf (* char)))))
+ (cast buf c-string))))
+
+;;; UNIX-EXIT terminates a program.
+(defun unix-exit (&optional (code 0))
+ #!+sb-doc
+ "Unix-exit terminates the current process with an optional
+ error code. If successful, the call doesn't return. If
+ unsuccessful, the call returns NIL and an error number."
+ (declare (type (signed-byte 32) code))
+ (void-syscall ("exit" int) code))
+
+(def-alien-routine ("getpid" unix-getpid) int
+ #!+sb-doc
+ "Unix-getpid returns the process-id of the current process.")
+
+(def-alien-routine ("getuid" unix-getuid) int
+ #!+sb-doc
+ "Unix-getuid returns the real user-id associated with the
+ current process.")
+
+(defun unix-readlink (path)
+ #!+sb-doc
+ "Unix-readlink invokes the readlink system call on the file name
+ specified by the simple string path. It returns up to two values:
+ the contents of the symbolic link if the call is successful, or
+ NIL and the Unix error number."
+ (declare (type unix-pathname path))
+ (with-alien ((buf (array char 1024)))
+ (syscall ("readlink" c-string (* char) int)
+ (let ((string (make-string result)))
+ (sb!kernel:copy-from-system-area
+ (alien-sap buf) 0
+ string (* sb!vm:vector-data-offset sb!vm:word-bits)
+ (* result sb!vm:byte-bits))
+ string)
+ path (cast buf (* char)) 1024)))
+
+;;; UNIX-UNLINK accepts a name and deletes the directory entry for that
+;;; name and the file if this is the last link.
+(defun unix-unlink (name)
+ #!+sb-doc
+ "Unix-unlink removes the directory entry for the named file.
+ NIL and an error code is returned if the call fails."
+ (declare (type unix-pathname name))
+ (void-syscall ("unlink" c-string) name))
+
+(defun %set-tty-process-group (pgrp &optional fd)
+ #!+sb-doc
+ "Set the tty-process-group for the unix file-descriptor FD to PGRP. If not
+ supplied, FD defaults to /dev/tty."
+ (let ((old-sigs (unix-sigblock (sigmask :sigttou
+ :sigttin
+ :sigtstp
+ :sigchld))))
+ (declare (type (unsigned-byte 32) old-sigs))
+ (unwind-protect
+ (if fd
+ (tcsetpgrp fd pgrp)
+ (multiple-value-bind (tty-fd errno) (unix-open "/dev/tty" o_rdwr 0)
+ (cond (tty-fd
+ (multiple-value-prog1
+ (tcsetpgrp tty-fd pgrp)
+ (unix-close tty-fd)))
+ (t
+ (values nil errno)))))
+ (unix-sigsetmask old-sigs))))
+
+(defun unix-gethostname ()
+ #!+sb-doc
+ "Unix-gethostname returns the name of the host machine as a string."
+ (with-alien ((buf (array char 256)))
+ (syscall ("gethostname" (* char) int)
+ (cast buf c-string)
+ (cast buf (* char)) 256)))
+
+;;; Unix-fsync writes the core-image of the file described by "fd" to
+;;; permanent storage (i.e. disk).
+
+(defun unix-fsync (fd)
+ #!+sb-doc
+ "Unix-fsync writes the core image of the file described by
+ fd to disk."
+ (declare (type unix-fd fd))
+ (void-syscall ("fsync" int) fd))
+\f
+;;;; sys/resource.h
+
+;;; FIXME: All we seem to need is the RUSAGE_SELF version of this.
+#!-sb-fluid (declaim (inline unix-fast-getrusage))
+(defun unix-fast-getrusage (who)
+ #!+sb-doc
+ "Like call getrusage, but return only the system and user time, and returns
+ the seconds and microseconds as separate values."
+ (declare (values (member t)
+ (unsigned-byte 31) (mod 1000000)
+ (unsigned-byte 31) (mod 1000000)))
+ (with-alien ((usage (struct rusage)))
+ (syscall* ("getrusage" int (* (struct rusage)))
+ (values t
+ (slot (slot usage 'ru-utime) 'tv-sec)
+ (slot (slot usage 'ru-utime) 'tv-usec)
+ (slot (slot usage 'ru-stime) 'tv-sec)
+ (slot (slot usage 'ru-stime) 'tv-usec))
+ who (addr usage))))
+
+(defun unix-getrusage (who)
+ #!+sb-doc
+ "Unix-getrusage returns information about the resource usage
+ of the process specified by who. Who can be either the
+ current process (rusage_self) or all of the terminated
+ child processes (rusage_children). NIL and an error number
+ is returned if the call fails."
+ (with-alien ((usage (struct rusage)))
+ (syscall ("getrusage" int (* (struct rusage)))
+ (values t
+ (+ (* (slot (slot usage 'ru-utime) 'tv-sec) 1000000)
+ (slot (slot usage 'ru-utime) 'tv-usec))
+ (+ (* (slot (slot usage 'ru-stime) 'tv-sec) 1000000)
+ (slot (slot usage 'ru-stime) 'tv-usec))
+ (slot usage 'ru-maxrss)
+ (slot usage 'ru-ixrss)
+ (slot usage 'ru-idrss)
+ (slot usage 'ru-isrss)
+ (slot usage 'ru-minflt)
+ (slot usage 'ru-majflt)
+ (slot usage 'ru-nswap)
+ (slot usage 'ru-inblock)
+ (slot usage 'ru-oublock)
+ (slot usage 'ru-msgsnd)
+ (slot usage 'ru-msgrcv)
+ (slot usage 'ru-nsignals)
+ (slot usage 'ru-nvcsw)
+ (slot usage 'ru-nivcsw))
+ who (addr usage))))
+
+\f
+;;;; sys/select.h
+
+(defmacro unix-fast-select (num-descriptors
+ read-fds write-fds exception-fds
+ timeout-secs &optional (timeout-usecs 0))
+ #!+sb-doc
+ "Perform the UNIX select(2) system call."
+ (declare (type (integer 0 #.FD-SETSIZE) num-descriptors)
+ (type (or (alien (* (struct fd-set))) null)
+ read-fds write-fds exception-fds)
+ (type (or null (unsigned-byte 31)) timeout-secs)
+ (type (unsigned-byte 31) timeout-usecs) )
+ ;; FIXME: CMU CL had
+ ;; (optimize (speed 3) (safety 0) (inhibit-warnings 3))
+ ;; in the declarations above. If they're important, they should
+ ;; be in a declaration inside the LET expansion, not in the
+ ;; macro compile-time code.
+ `(let ((timeout-secs ,timeout-secs))
+ (with-alien ((tv (struct timeval)))
+ (when timeout-secs
+ (setf (slot tv 'tv-sec) timeout-secs)
+ (setf (slot tv 'tv-usec) ,timeout-usecs))
+ (int-syscall ("select" int (* (struct fd-set)) (* (struct fd-set))
+ (* (struct fd-set)) (* (struct timeval)))
+ ,num-descriptors ,read-fds ,write-fds ,exception-fds
+ (if timeout-secs (alien-sap (addr tv)) (int-sap 0))))))
+
+;;; Unix-select accepts sets of file descriptors and waits for an event
+;;; to happen on one of them or to time out.
+
+(defmacro num-to-fd-set (fdset num)
+ `(if (fixnump ,num)
+ (progn
+ (setf (deref (slot ,fdset 'fds-bits) 0) ,num)
+ ,@(loop for index upfrom 1 below (/ fd-setsize 32)
+ collect `(setf (deref (slot ,fdset 'fds-bits) ,index) 0)))
+ (progn
+ ,@(loop for index upfrom 0 below (/ fd-setsize 32)
+ collect `(setf (deref (slot ,fdset 'fds-bits) ,index)
+ (ldb (byte 32 ,(* index 32)) ,num))))))
+
+(defmacro fd-set-to-num (nfds fdset)
+ `(if (<= ,nfds 32)
+ (deref (slot ,fdset 'fds-bits) 0)
+ (+ ,@(loop for index upfrom 0 below (/ fd-setsize 32)
+ collect `(ash (deref (slot ,fdset 'fds-bits) ,index)
+ ,(* index 32))))))
+
+(defun unix-select (nfds rdfds wrfds xpfds to-secs &optional (to-usecs 0))
+ #!+sb-doc
+ "Unix-select examines the sets of descriptors passed as arguments
+ to see whether they are ready for reading and writing. See the UNIX
+ Programmers Manual for more information."
+ (declare (type (integer 0 #.FD-SETSIZE) nfds)
+ (type unsigned-byte rdfds wrfds xpfds)
+ (type (or (unsigned-byte 31) null) to-secs)
+ (type (unsigned-byte 31) to-usecs)
+ (optimize (speed 3) (safety 0) (inhibit-warnings 3)))
+ (with-alien ((tv (struct timeval))
+ (rdf (struct fd-set))
+ (wrf (struct fd-set))
+ (xpf (struct fd-set)))
+ (when to-secs
+ (setf (slot tv 'tv-sec) to-secs)
+ (setf (slot tv 'tv-usec) to-usecs))
+ (num-to-fd-set rdf rdfds)
+ (num-to-fd-set wrf wrfds)
+ (num-to-fd-set xpf xpfds)
+ (macrolet ((frob (lispvar alienvar)
+ `(if (zerop ,lispvar)
+ (int-sap 0)
+ (alien-sap (addr ,alienvar)))))
+ (syscall ("select" int (* (struct fd-set)) (* (struct fd-set))
+ (* (struct fd-set)) (* (struct timeval)))
+ (values result
+ (fd-set-to-num nfds rdf)
+ (fd-set-to-num nfds wrf)
+ (fd-set-to-num nfds xpf))
+ nfds (frob rdfds rdf) (frob wrfds wrf) (frob xpfds xpf)
+ (if to-secs (alien-sap (addr tv)) (int-sap 0))))))
+\f
+;;;; sys/stat.h
+
+;;; FIXME: This is only used in this file, and needn't be in target Lisp
+;;; runtime. It's also unclear why it needs to be a macro instead of a
+;;; function. Perhaps it should become a FLET.
+(defmacro extract-stat-results (buf)
+ `(values T
+ #!+bsd
+ (slot ,buf 'st-dev)
+ #!+linux
+ (+ (deref (slot ,buf 'st-dev) 0)
+ (* (+ +max-u-long+ 1)
+ (deref (slot ,buf 'st-dev) 1))) ;;; let's hope this works..
+ (slot ,buf 'st-ino)
+ (slot ,buf 'st-mode)
+ (slot ,buf 'st-nlink)
+ (slot ,buf 'st-uid)
+ (slot ,buf 'st-gid)
+ #!+bsd
+ (slot ,buf 'st-rdev)
+ #!+linux
+ (+ (deref (slot ,buf 'st-rdev) 0)
+ (* (+ +max-u-long+ 1)
+ (deref (slot ,buf 'st-rdev) 1))) ;;; let's hope this works..
+ #!+linux (slot ,buf 'st-size)
+ #!+bsd
+ (+ (slot ,buf 'st-size)
+ (* (+ +max-u-long+ 1)
+ (slot ,buf 'st-sizeh)))
+ #!+linux (slot ,buf 'st-atime)
+ #!+bsd (slot (slot ,buf 'st-atime) 'tv-sec)
+ #!+linux (slot ,buf 'st-mtime)
+ #!+bsd (slot (slot ,buf 'st-mtime) 'tv-sec)
+ #!+linux (slot ,buf 'st-ctime)
+ #!+bsd (slot (slot ,buf 'st-ctime) 'tv-sec)
+ (slot ,buf 'st-blksize)
+ #!+linux (slot ,buf 'st-blocks)
+ #!+bsd
+ (+ (slot ,buf 'st-blocks)
+ (* (+ +max-u-long+ 1)
+ (slot ,buf 'st-blocksh)))
+ ))
+
+(defun unix-stat (name)
+ #!+sb-doc
+ "Unix-stat retrieves information about the specified
+ file returning them in the form of multiple values.
+ See the UNIX Programmer's Manual for a description
+ of the values returned. If the call fails, then NIL
+ and an error number is returned instead."
+ (declare (type unix-pathname name))
+ (when (string= name "")
+ (setf name "."))
+ (with-alien ((buf (struct stat)))
+ (syscall ("stat" c-string (* (struct stat)))
+ (extract-stat-results buf)
+ name (addr buf))))
+
+(defun unix-fstat (fd)
+ #!+sb-doc
+ "Unix-fstat is similar to unix-stat except the file is specified
+ by the file descriptor fd."
+ (declare (type unix-fd fd))
+ (with-alien ((buf (struct stat)))
+ (syscall ("fstat" int (* (struct stat)))
+ (extract-stat-results buf)
+ fd (addr buf))))
+
+(defun unix-lstat (name)
+ #!+sb-doc
+ "Unix-lstat is similar to unix-stat except the specified
+ file must be a symbolic link."
+ (declare (type unix-pathname name))
+ (with-alien ((buf (struct stat)))
+ (syscall ("lstat" c-string (* (struct stat)))
+ (extract-stat-results buf)
+ name (addr buf))))
+
+;;; UNIX-MKDIR accepts a name and a mode and attempts to create the
+;;; corresponding directory with mode mode.
+(defun unix-mkdir (name mode)
+ #!+sb-doc
+ "Unix-mkdir creates a new directory with the specified name and mode.
+ (Same as those for unix-fchmod.) It returns T upon success, otherwise
+ NIL and an error number."
+ (declare (type unix-pathname name)
+ (type unix-file-mode mode))
+ (void-syscall ("mkdir" c-string int) name mode))
+\f
+;;;; time.h
+
+;; POSIX.4 structure for a time value. This is like a `struct timeval' but
+;; has nanoseconds instead of microseconds.
+
+(def-alien-type nil
+ (struct timespec
+ (tv-sec long) ;Seconds
+ (tv-nsec long))) ;Nanoseconds
+
+;; Used by other time functions.
+(def-alien-type nil
+ (struct tm
+ (tm-sec int) ; Seconds. [0-60] (1 leap second)
+ (tm-min int) ; Minutes. [0-59]
+ (tm-hour int) ; Hours. [0-23]
+ (tm-mday int) ; Day. [1-31]
+ (tm-mon int) ; Month. [0-11]
+ (tm-year int) ; Year - 1900.
+ (tm-wday int) ; Day of week. [0-6]
+ (tm-yday int) ; Days in year.[0-365]
+ (tm-isdst int) ; DST. [-1/0/1]
+ (tm-gmtoff long) ; Seconds east of UTC.
+ (tm-zone c-string))) ; Timezone abbreviation.
+
+(def-alien-variable ("tzname" unix-tzname) (array c-string 2))
+
+(def-alien-routine get-timezone sb!c-call:void
+ (when sb!c-call:long :in)
+ (minutes-west sb!c-call:int :out)
+ (daylight-savings-p sb!alien:boolean :out))
+
+(defun unix-get-minutes-west (secs)
+ (multiple-value-bind (ignore minutes dst) (get-timezone secs)
+ (declare (ignore ignore) (ignore dst))
+ (values minutes)))
+
+(defun unix-get-timezone (secs)
+ (multiple-value-bind (ignore minutes dst) (get-timezone secs)
+ (declare (ignore ignore) (ignore minutes))
+ (values (deref unix-tzname (if dst 1 0)))))
+\f
+;;;; sys/time.h
+
+;;; Structure crudely representing a timezone. KLUDGE: This is
+;;; obsolete and should never be used.
+(def-alien-type nil
+ (struct timezone
+ (tz-minuteswest int) ; minutes west of Greenwich
+ (tz-dsttime int))) ; type of dst correction
+
+#!-sb-fluid (declaim (inline unix-gettimeofday))
+(defun unix-gettimeofday ()
+ #!+sb-doc
+ "If it works, unix-gettimeofday returns 5 values: T, the seconds and
+ microseconds of the current time of day, the timezone (in minutes west
+ of Greenwich), and a daylight-savings flag. If it doesn't work, it
+ returns NIL and the errno."
+ (with-alien ((tv (struct timeval))
+ (tz (struct timezone)))
+ (syscall* ("gettimeofday" (* (struct timeval))
+ (* (struct timezone)))
+ (values T
+ (slot tv 'tv-sec)
+ (slot tv 'tv-usec)
+ (slot tz 'tz-minuteswest)
+ (slot tz 'tz-dsttime))
+ (addr tv)
+ (addr tz))))
+\f
+;;;; asm/errno.h
+
+#|
+(def-unix-error ESUCCESS 0 "Successful")
+(def-unix-error EPERM 1 "Operation not permitted")
+|#
+(def-unix-error ENOENT 2 "No such file or directory")
+#|
+(def-unix-error ESRCH 3 "No such process")
+(def-unix-error EINTR 4 "Interrupted system call")
+(def-unix-error EIO 5 "I/O error")
+(def-unix-error ENXIO 6 "No such device or address")
+(def-unix-error E2BIG 7 "Arg list too long")
+(def-unix-error ENOEXEC 8 "Exec format error")
+(def-unix-error EBADF 9 "Bad file number")
+(def-unix-error ECHILD 10 "No children")
+(def-unix-error EAGAIN 11 "Try again")
+(def-unix-error ENOMEM 12 "Out of memory")
+|#
+(def-unix-error EACCES 13 "Permission denied")
+#|
+(def-unix-error EFAULT 14 "Bad address")
+(def-unix-error ENOTBLK 15 "Block device required")
+(def-unix-error EBUSY 16 "Device or resource busy")
+|#
+(def-unix-error EEXIST 17 "File exists")
+#|
+(def-unix-error EXDEV 18 "Cross-device link")
+(def-unix-error ENODEV 19 "No such device")
+|#
+(def-unix-error ENOTDIR 20 "Not a directory")
+#|
+(def-unix-error EISDIR 21 "Is a directory")
+(def-unix-error EINVAL 22 "Invalid argument")
+(def-unix-error ENFILE 23 "File table overflow")
+(def-unix-error EMFILE 24 "Too many open files")
+(def-unix-error ENOTTY 25 "Not a typewriter")
+(def-unix-error ETXTBSY 26 "Text file busy")
+(def-unix-error EFBIG 27 "File too large")
+(def-unix-error ENOSPC 28 "No space left on device")
+|#
+(def-unix-error ESPIPE 29 "Illegal seek")
+#|
+(def-unix-error EROFS 30 "Read-only file system")
+(def-unix-error EMLINK 31 "Too many links")
+(def-unix-error EPIPE 32 "Broken pipe")
+|#
+
+#|
+;;; Math
+(def-unix-error EDOM 33 "Math argument out of domain")
+(def-unix-error ERANGE 34 "Math result not representable")
+(def-unix-error EDEADLK 35 "Resource deadlock would occur")
+(def-unix-error ENAMETOOLONG 36 "File name too long")
+(def-unix-error ENOLCK 37 "No record locks available")
+(def-unix-error ENOSYS 38 "Function not implemented")
+(def-unix-error ENOTEMPTY 39 "Directory not empty")
+(def-unix-error ELOOP 40 "Too many symbolic links encountered")
+|#
+(def-unix-error EWOULDBLOCK 11 "Operation would block")
+(/show0 "unix.lisp 3192")
+#|
+(def-unix-error ENOMSG 42 "No message of desired type")
+(def-unix-error EIDRM 43 "Identifier removed")
+(def-unix-error ECHRNG 44 "Channel number out of range")
+(def-unix-error EL2NSYNC 45 "Level 2 not synchronized")
+(def-unix-error EL3HLT 46 "Level 3 halted")
+(def-unix-error EL3RST 47 "Level 3 reset")
+(def-unix-error ELNRNG 48 "Link number out of range")
+(def-unix-error EUNATCH 49 "Protocol driver not attached")
+(def-unix-error ENOCSI 50 "No CSI structure available")
+(def-unix-error EL2HLT 51 "Level 2 halted")
+(def-unix-error EBADE 52 "Invalid exchange")
+(def-unix-error EBADR 53 "Invalid request descriptor")
+(def-unix-error EXFULL 54 "Exchange full")
+(def-unix-error ENOANO 55 "No anode")
+(def-unix-error EBADRQC 56 "Invalid request code")
+(def-unix-error EBADSLT 57 "Invalid slot")
+(def-unix-error EDEADLOCK EDEADLK "File locking deadlock error")
+(def-unix-error EBFONT 59 "Bad font file format")
+(def-unix-error ENOSTR 60 "Device not a stream")
+(def-unix-error ENODATA 61 "No data available")
+(def-unix-error ETIME 62 "Timer expired")
+(def-unix-error ENOSR 63 "Out of streams resources")
+(def-unix-error ENONET 64 "Machine is not on the network")
+(def-unix-error ENOPKG 65 "Package not installed")
+(def-unix-error EREMOTE 66 "Object is remote")
+(def-unix-error ENOLINK 67 "Link has been severed")
+(def-unix-error EADV 68 "Advertise error")
+(def-unix-error ESRMNT 69 "Srmount error")
+(def-unix-error ECOMM 70 "Communication error on send")
+(def-unix-error EPROTO 71 "Protocol error")
+(def-unix-error EMULTIHOP 72 "Multihop attempted")
+(def-unix-error EDOTDOT 73 "RFS specific error")
+(def-unix-error EBADMSG 74 "Not a data message")
+(def-unix-error EOVERFLOW 75 "Value too large for defined data type")
+(def-unix-error ENOTUNIQ 76 "Name not unique on network")
+(def-unix-error EBADFD 77 "File descriptor in bad state")
+(def-unix-error EREMCHG 78 "Remote address changed")
+(def-unix-error ELIBACC 79 "Can not access a needed shared library")
+(def-unix-error ELIBBAD 80 "Accessing a corrupted shared library")
+(def-unix-error ELIBSCN 81 ".lib section in a.out corrupted")
+(def-unix-error ELIBMAX 82 "Attempting to link in too many shared libraries")
+(def-unix-error ELIBEXEC 83 "Cannot exec a shared library directly")
+(def-unix-error EILSEQ 84 "Illegal byte sequence")
+(def-unix-error ERESTART 85 "Interrupted system call should be restarted ")
+(def-unix-error ESTRPIPE 86 "Streams pipe error")
+(def-unix-error EUSERS 87 "Too many users")
+(def-unix-error ENOTSOCK 88 "Socket operation on non-socket")
+(def-unix-error EDESTADDRREQ 89 "Destination address required")
+(def-unix-error EMSGSIZE 90 "Message too long")
+(def-unix-error EPROTOTYPE 91 "Protocol wrong type for socket")
+(def-unix-error ENOPROTOOPT 92 "Protocol not available")
+(def-unix-error EPROTONOSUPPORT 93 "Protocol not supported")
+(def-unix-error ESOCKTNOSUPPORT 94 "Socket type not supported")
+(def-unix-error EOPNOTSUPP 95 "Operation not supported on transport endpoint")
+(def-unix-error EPFNOSUPPORT 96 "Protocol family not supported")
+(def-unix-error EAFNOSUPPORT 97 "Address family not supported by protocol")
+(def-unix-error EADDRINUSE 98 "Address already in use")
+(def-unix-error EADDRNOTAVAIL 99 "Cannot assign requested address")
+(def-unix-error ENETDOWN 100 "Network is down")
+(def-unix-error ENETUNREACH 101 "Network is unreachable")
+(def-unix-error ENETRESET 102 "Network dropped connection because of reset")
+(def-unix-error ECONNABORTED 103 "Software caused connection abort")
+(def-unix-error ECONNRESET 104 "Connection reset by peer")
+(def-unix-error ENOBUFS 105 "No buffer space available")
+(def-unix-error EISCONN 106 "Transport endpoint is already connected")
+(def-unix-error ENOTCONN 107 "Transport endpoint is not connected")
+(def-unix-error ESHUTDOWN 108 "Cannot send after transport endpoint shutdown")
+(def-unix-error ETOOMANYREFS 109 "Too many references: cannot splice")
+(def-unix-error ETIMEDOUT 110 "Connection timed out")
+(def-unix-error ECONNREFUSED 111 "Connection refused")
+(def-unix-error EHOSTDOWN 112 "Host is down")
+(def-unix-error EHOSTUNREACH 113 "No route to host")
+(def-unix-error EALREADY 114 "Operation already in progress")
+(def-unix-error EINPROGRESS 115 "Operation now in progress")
+(def-unix-error ESTALE 116 "Stale NFS file handle")
+(def-unix-error EUCLEAN 117 "Structure needs cleaning")
+(def-unix-error ENOTNAM 118 "Not a XENIX named type file")
+(def-unix-error ENAVAIL 119 "No XENIX semaphores available")
+(def-unix-error EISNAM 120 "Is a named type file")
+(def-unix-error EREMOTEIO 121 "Remote I/O error")
+(def-unix-error EDQUOT 122 "Quota exceeded")
+|#
+
+;;; And now for something completely different ...
+(emit-unix-errors)
+\f
+;;;; support routines for dealing with unix pathnames
+
+(defun unix-file-kind (name &optional check-for-links)
+ #!+sb-doc
+ "Return either :FILE, :DIRECTORY, :LINK, :SPECIAL, or NIL."
+ (declare (simple-string name))
+ (multiple-value-bind (res dev ino mode)
+ (if check-for-links (unix-lstat name) (unix-stat name))
+ (declare (type (or fixnum null) mode)
+ (ignore dev ino))
+ (when res
+ (let ((kind (logand mode s-ifmt)))
+ (cond ((eql kind s-ifdir) :directory)
+ ((eql kind s-ifreg) :file)
+ ((eql kind s-iflnk) :link)
+ (t :special))))))
+
+(defun unix-maybe-prepend-current-directory (name)
+ (declare (simple-string name))
+ (if (and (> (length name) 0) (char= (schar name 0) #\/))
+ name
+ (multiple-value-bind (win dir) (unix-current-directory)
+ (if win
+ (concatenate 'simple-string dir "/" name)
+ name))))
+
+(defun unix-resolve-links (pathname)
+ #!+sb-doc
+ "Returns the pathname with all symbolic links resolved."
+ (declare (simple-string pathname))
+ (let ((len (length pathname))
+ (pending pathname))
+ (declare (fixnum len) (simple-string pending))
+ (if (zerop len)
+ pathname
+ (let ((result (make-string 1024 :initial-element (code-char 0)))
+ (fill-ptr 0)
+ (name-start 0))
+ (loop
+ (let* ((name-end (or (position #\/ pending :start name-start) len))
+ (new-fill-ptr (+ fill-ptr (- name-end name-start))))
+ (replace result pending
+ :start1 fill-ptr
+ :end1 new-fill-ptr
+ :start2 name-start
+ :end2 name-end)
+ (let ((kind (unix-file-kind (if (zerop name-end) "/" result) t)))
+ (unless kind (return nil))
+ (cond ((eq kind :link)
+ (multiple-value-bind (link err) (unix-readlink result)
+ (unless link
+ (error "error reading link ~S: ~S"
+ (subseq result 0 fill-ptr)
+ (get-unix-error-msg err)))
+ (cond ((or (zerop (length link))
+ (char/= (schar link 0) #\/))
+ ;; It's a relative link.
+ (fill result (code-char 0)
+ :start fill-ptr
+ :end new-fill-ptr))
+ ((string= result "/../" :end1 4)
+ ;; It's across the super-root.
+ (let ((slash (or (position #\/ result :start 4)
+ 0)))
+ (fill result (code-char 0)
+ :start slash
+ :end new-fill-ptr)
+ (setf fill-ptr slash)))
+ (t
+ ;; It's absolute.
+ (and (> (length link) 0)
+ (char= (schar link 0) #\/))
+ (fill result (code-char 0) :end new-fill-ptr)
+ (setf fill-ptr 0)))
+ (setf pending
+ (if (= name-end len)
+ link
+ (concatenate 'simple-string
+ link
+ (subseq pending name-end))))
+ (setf len (length pending))
+ (setf name-start 0)))
+ ((= name-end len)
+ (return (subseq result 0 new-fill-ptr)))
+ ((eq kind :directory)
+ (setf (schar result new-fill-ptr) #\/)
+ (setf fill-ptr (1+ new-fill-ptr))
+ (setf name-start (1+ name-end)))
+ (t
+ (return nil))))))))))
+
+(defun unix-simplify-pathname (src)
+ (declare (simple-string src))
+ (let* ((src-len (length src))
+ (dst (make-string src-len))
+ (dst-len 0)
+ (dots 0)
+ (last-slash nil))
+ (macrolet ((deposit (char)
+ `(progn
+ (setf (schar dst dst-len) ,char)
+ (incf dst-len))))
+ (dotimes (src-index src-len)
+ (let ((char (schar src src-index)))
+ (cond ((char= char #\.)
+ (when dots
+ (incf dots))
+ (deposit char))
+ ((char= char #\/)
+ (case dots
+ (0
+ ;; Either ``/...' or ``...//...'
+ (unless last-slash
+ (setf last-slash dst-len)
+ (deposit char)))
+ (1
+ ;; Either ``./...'' or ``..././...''
+ (decf dst-len))
+ (2
+ ;; We've found ..
+ (cond
+ ((and last-slash (not (zerop last-slash)))
+ ;; There is something before this ..
+ (let ((prev-prev-slash
+ (position #\/ dst :end last-slash :from-end t)))
+ (cond ((and (= (+ (or prev-prev-slash 0) 2)
+ last-slash)
+ (char= (schar dst (- last-slash 2)) #\.)
+ (char= (schar dst (1- last-slash)) #\.))
+ ;; The something before this .. is another ..
+ (deposit char)
+ (setf last-slash dst-len))
+ (t
+ ;; The something is some directory or other.
+ (setf dst-len
+ (if prev-prev-slash
+ (1+ prev-prev-slash)
+ 0))
+ (setf last-slash prev-prev-slash)))))
+ (t
+ ;; There is nothing before this .., so we need to keep it
+ (setf last-slash dst-len)
+ (deposit char))))
+ (t
+ ;; Something other than a dot between slashes.
+ (setf last-slash dst-len)
+ (deposit char)))
+ (setf dots 0))
+ (t
+ (setf dots nil)
+ (setf (schar dst dst-len) char)
+ (incf dst-len))))))
+ (when (and last-slash (not (zerop last-slash)))
+ (case dots
+ (1
+ ;; We've got ``foobar/.''
+ (decf dst-len))
+ (2
+ ;; We've got ``foobar/..''
+ (unless (and (>= last-slash 2)
+ (char= (schar dst (1- last-slash)) #\.)
+ (char= (schar dst (- last-slash 2)) #\.)
+ (or (= last-slash 2)
+ (char= (schar dst (- last-slash 3)) #\/)))
+ (let ((prev-prev-slash
+ (position #\/ dst :end last-slash :from-end t)))
+ (if prev-prev-slash
+ (setf dst-len (1+ prev-prev-slash))
+ (return-from unix-simplify-pathname "./")))))))
+ (cond ((zerop dst-len)
+ "./")
+ ((= dst-len src-len)
+ dst)
+ (t
+ (subseq dst 0 dst-len)))))
+\f
+;;;; stuff not yet found in the header files
+;;;;
+;;;; Abandon all hope who enters here...
+
+;;; not checked for linux...
+(defmacro fd-set (offset fd-set)
+ (let ((word (gensym))
+ (bit (gensym)))
+ `(multiple-value-bind (,word ,bit) (floor ,offset 32)
+ (setf (deref (slot ,fd-set 'fds-bits) ,word)
+ (logior (truly-the (unsigned-byte 32) (ash 1 ,bit))
+ (deref (slot ,fd-set 'fds-bits) ,word))))))
+
+;;; not checked for linux...
+(defmacro fd-clr (offset fd-set)
+ (let ((word (gensym))
+ (bit (gensym)))
+ `(multiple-value-bind (,word ,bit) (floor ,offset 32)
+ (setf (deref (slot ,fd-set 'fds-bits) ,word)
+ (logand (deref (slot ,fd-set 'fds-bits) ,word)
+ (sb!kernel:32bit-logical-not
+ (truly-the (unsigned-byte 32) (ash 1 ,bit))))))))
+
+;;; not checked for linux...
+(defmacro fd-isset (offset fd-set)
+ (let ((word (gensym))
+ (bit (gensym)))
+ `(multiple-value-bind (,word ,bit) (floor ,offset 32)
+ (logbitp ,bit (deref (slot ,fd-set 'fds-bits) ,word)))))
+
+;;; not checked for linux...
+(defmacro fd-zero (fd-set)
+ `(progn
+ ,@(loop for index upfrom 0 below (/ fd-setsize 32)
+ collect `(setf (deref (slot ,fd-set 'fds-bits) ,index) 0))))
+
+(/show0 "unix.lisp 3555")
--- /dev/null
+;;;; weak pointer support
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!EXT")
+
+(file-comment
+ "$Header$")
+
+(defun make-weak-pointer (object)
+ #!+sb-doc
+ "Allocates and returns a weak pointer which points to OBJECT."
+ (declare (values weak-pointer))
+ (make-weak-pointer object))
+
+#!-sb-fluid (declaim (inline weak-pointer-value))
+(defun weak-pointer-value (weak-pointer)
+ #!+sb-doc
+ "If WEAK-POINTER is valid, returns the value of WEAK-POINTER and T.
+ If the referent of WEAK-POINTER has been garbage collected, returns
+ the values NIL and NIL."
+ (declare (type weak-pointer weak-pointer)
+ (values t (member t nil)))
+ ;; We don't need to wrap this with a without-gcing, because once we have
+ ;; extracted the value, our reference to it will keep the weak pointer
+ ;; from becoming broken. We just have to make sure the compiler won't
+ ;; reorder these primitives.
+ (let ((value (sb!c::%weak-pointer-value weak-pointer))
+ (broken (sb!c::%weak-pointer-broken weak-pointer)))
+ (values value (not broken))))
--- /dev/null
+;;;; X86-specific runtime stuff
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!VM")
+
+(file-comment
+ "$Header$")
+\f
+;;;; OS-CONTEXT-T
+
+;;; a POSIX signal context, i.e. the type passed as the third
+;;; argument to an SA_SIGACTION-style signal handler
+;;;
+;;; The real type does have slots, but at Lisp level, we never
+;;; access them, or care about the size of the object. Instead, we
+;;; always refer to these objects by pointers handed to us by the C
+;;; runtime library, and ask the runtime library any time we need
+;;; information about the contents of one of these objects. Thus, it
+;;; works to represent this as an object with no slots.
+;;;
+;;; KLUDGE: It would be nice to have a type definition analogous to
+;;; C's "struct os_context_t;", for an incompletely specified object
+;;; which can only be referred to by reference, but I don't know how
+;;; to do that in the FFI, so instead we just this bogus no-slots
+;;; representation. -- WHN 20000730
+;;;
+;;; FIXME: Since SBCL, unlike CMU CL, uses this as an opaque type,
+;;; it's no longer architecture-dependent, and probably belongs in
+;;; some other package, perhaps SB-KERNEL.
+(def-alien-type os-context-t (struct os-context-t-struct))
+\f
+;;;; MACHINE-TYPE and MACHINE-VERSION
+
+(defun machine-type ()
+ #!+sb-doc
+ "Returns a string describing the type of the local machine."
+ "X86")
+
+(defun machine-version ()
+ #!+sb-doc
+ "Returns a string describing the version of the local machine."
+ "X86")
+\f
+;;;; :CODE-OBJECT fixups
+
+;;; a counter to measure the storage overhead of these fixups
+(defvar *num-fixups* 0)
+;;; FIXME: When the system runs, it'd be interesting to see what this is.
+
+;;; This gets called by LOAD to resolve newly positioned objects
+;;; with things (like code instructions) that have to refer to them.
+;;;
+;;; Add a fixup offset to the vector of fixup offsets for the given
+;;; code object.
+(defun fixup-code-object (code offset fixup kind)
+ (declare (type index offset))
+ (flet ((add-fixup (code offset)
+ ;; Although this could check for and ignore fixups for code
+ ;; objects in the read-only and static spaces, this should
+ ;; only be the case when *enable-dynamic-space-code* is
+ ;; True.
+ (when sb!impl::*enable-dynamic-space-code*
+ (incf *num-fixups*)
+ (let ((fixups (code-header-ref code code-constants-offset)))
+ (cond ((typep fixups '(simple-array (unsigned-byte 32) (*)))
+ (let ((new-fixups
+ (adjust-array fixups (1+ (length fixups))
+ :element-type '(unsigned-byte 32))))
+ (setf (aref new-fixups (length fixups)) offset)
+ (setf (code-header-ref code code-constants-offset)
+ new-fixups)))
+ (t
+ (unless (or (eq (get-type fixups)
+ sb!vm:unbound-marker-type)
+ (zerop fixups))
+ (format t "** Init. code FU = ~S~%" fixups)) ; FIXME
+ (setf (code-header-ref code code-constants-offset)
+ (make-specializable-array
+ 1
+ :element-type '(unsigned-byte 32)
+ :initial-element offset))))))))
+ (sb!sys:without-gcing
+ (let* ((sap (truly-the system-area-pointer
+ (sb!kernel:code-instructions code)))
+ (obj-start-addr (logand (sb!kernel:get-lisp-obj-address code)
+ #xfffffff8))
+ #+nil (const-start-addr (+ obj-start-addr (* 5 4)))
+ (code-start-addr (sb!sys:sap-int (sb!kernel:code-instructions
+ code)))
+ (ncode-words (sb!kernel:code-header-ref code 1))
+ (code-end-addr (+ code-start-addr (* ncode-words 4))))
+ (unless (member kind '(:absolute :relative))
+ (error "Unknown code-object-fixup kind ~S." kind))
+ (ecase kind
+ (:absolute
+ ;; Word at sap + offset contains a value to be replaced by
+ ;; adding that value to fixup.
+ (setf (sap-ref-32 sap offset) (+ fixup (sap-ref-32 sap offset)))
+ ;; Record absolute fixups that point within the code object.
+ (when (> code-end-addr (sap-ref-32 sap offset) obj-start-addr)
+ (add-fixup code offset)))
+ (:relative
+ ;; Fixup is the actual address wanted.
+ ;;
+ ;; Record relative fixups that point outside the code
+ ;; object.
+ (when (or (< fixup obj-start-addr) (> fixup code-end-addr))
+ (add-fixup code offset))
+ ;; Replace word with value to add to that loc to get there.
+ (let* ((loc-sap (+ (sap-int sap) offset))
+ (rel-val (- fixup loc-sap 4)))
+ (declare (type (unsigned-byte 32) loc-sap)
+ (type (signed-byte 32) rel-val))
+ (setf (signed-sap-ref-32 sap offset) rel-val))))))
+ nil))
+
+;;; Add a code fixup to a code object generated by GENESIS. The fixup has
+;;; already been applied, it's just a matter of placing the fixup in the code's
+;;; fixup vector if necessary.
+;;;
+;;; KLUDGE: I'd like a good explanation of why this has to be done at
+;;; load time instead of in GENESIS. It's probably simple, I just haven't
+;;; figured it out, or found it written down anywhere. -- WHN 19990908
+#!+gencgc
+(defun do-load-time-code-fixup (code offset fixup kind)
+ (flet ((add-load-time-code-fixup (code offset)
+ (let ((fixups (code-header-ref code sb!vm:code-constants-offset)))
+ (cond ((typep fixups '(simple-array (unsigned-byte 32) (*)))
+ (let ((new-fixups
+ (adjust-array fixups (1+ (length fixups))
+ :element-type '(unsigned-byte 32))))
+ (setf (aref new-fixups (length fixups)) offset)
+ (setf (code-header-ref code sb!vm:code-constants-offset)
+ new-fixups)))
+ (t
+ ;; FIXME: This doesn't look like production code, and
+ ;; should be a fatal error, not just a print.
+ (unless (or (eq (get-type fixups)
+ sb!vm:unbound-marker-type)
+ (zerop fixups))
+ (%primitive print "** Init. code FU"))
+ (setf (code-header-ref code sb!vm:code-constants-offset)
+ (make-specializable-array
+ 1
+ :element-type '(unsigned-byte 32)
+ :initial-element offset)))))))
+ (let* ((sap (truly-the system-area-pointer
+ (sb!kernel:code-instructions code)))
+ (obj-start-addr
+ ;; FIXME: looks like (LOGANDC2 foo typebits)
+ (logand (sb!kernel:get-lisp-obj-address code) #xfffffff8))
+ (code-start-addr (sb!sys:sap-int (sb!kernel:code-instructions
+ code)))
+ (ncode-words (sb!kernel:code-header-ref code 1))
+ (code-end-addr (+ code-start-addr (* ncode-words 4))))
+ (ecase kind
+ (:absolute
+ ;; Record absolute fixups that point within the code object.
+ (when (> code-end-addr (sap-ref-32 sap offset) obj-start-addr)
+ (add-load-time-code-fixup code offset)))
+ (:relative
+ ;; Record relative fixups that point outside the code object.
+ (when (or (< fixup obj-start-addr) (> fixup code-end-addr))
+ (add-load-time-code-fixup code offset)))))))
+\f
+;;;; low-level signal context access functions
+;;;;
+;;;; Note: In CMU CL, similar functions were hardwired to access
+;;;; BSD-style sigcontext structures defined as alien objects. Our
+;;;; approach is different in two ways:
+;;;; 1. We use POSIX SA_SIGACTION-style signals, so our context is
+;;;; whatever the void pointer in the sigaction handler dereferences
+;;;; to, not necessarily a sigcontext.
+;;;; 2. We don't try to maintain alien definitions of the context
+;;;; structure at Lisp level, but instead call alien C functions
+;;;; which take care of access for us. (Since the C functions can
+;;;; be defined in terms of system standard header files, they
+;;;; should be easier to maintain; and since Lisp code uses signal
+;;;; contexts only in interactive or exception code (like the debugger
+;;;; and internal error handling) the extra runtime cost should be
+;;;; negligible.
+
+(def-alien-routine ("os_context_pc_addr" context-pc-addr) (* int)
+ (context (* os-context-t)))
+
+(defun context-pc (context)
+ (declare (type (alien (* os-context-t)) context))
+ (int-sap (deref (context-pc-addr context))))
+
+(def-alien-routine ("os_context_register_addr" context-register-addr) (* int)
+ (context (* os-context-t))
+ (index int))
+
+(defun context-register (context index)
+ (declare (type (alien (* os-context-t)) context))
+ (deref (context-register-addr context index)))
+
+(defun %set-context-register (context index new)
+ (declare (type (alien (* os-context-t)) context))
+ (setf (deref (context-register-addr context index))
+ new))
+
+;;; Like CONTEXT-REGISTER, but returns the value of a float register.
+;;; FORMAT is the type of float to return.
+;;;
+;;; As of sbcl-0.6.7, there is no working code which calls this code,
+;;; so it's stubbed out. Someday, in order to make the debugger work
+;;; better, it may be necessary to unstubify it.
+(defun context-float-register (context index format)
+ (declare (ignore context index format))
+ (warn "stub CONTEXT-FLOAT-REGISTER")
+ (coerce 0.0 'format))
+(defun %set-context-float-register (context index format new-value)
+ (declare (ignore context index format))
+ (warn "stub %SET-CONTEXT-FLOAT-REGISTER")
+ (coerce new-value 'format))
+
+;;; Given a signal context, return the floating point modes word in
+;;; the same format as returned by FLOATING-POINT-MODES.
+(defun context-floating-point-modes (context)
+ ;; FIXME: As of sbcl-0.6.7 and the big rewrite of signal handling for
+ ;; POSIXness and (at the Lisp level) opaque signal contexts,
+ ;; this is stubified. It needs to be rewritten as an
+ ;; alien function.
+ (warn "stub CONTEXT-FLOATING-POINT-MODES")
+
+ ;; old code for Linux:
+ #+nil
+ (let ((cw (slot (deref (slot context 'fpstate) 0) 'cw))
+ (sw (slot (deref (slot context 'fpstate) 0) 'sw)))
+ ;;(format t "cw = ~4X~%sw = ~4X~%" cw sw)
+ ;; NOT TESTED -- Clear sticky bits to clear interrupt condition.
+ (setf (slot (deref (slot context 'fpstate) 0) 'sw) (logandc2 sw #x3f))
+ ;;(format t "new sw = ~X~%" (slot (deref (slot context 'fpstate) 0) 'sw))
+ ;; Simulate floating-point-modes VOP.
+ (logior (ash (logand sw #xffff) 16) (logxor (logand cw #xffff) #x3f)))
+
+ 0)
+\f
+;;;; INTERNAL-ERROR-ARGUMENTS
+
+;;; Given a (POSIX) signal context, extract the internal error
+;;; arguments from the instruction stream.
+(defun internal-error-arguments (context)
+ (declare (type (alien (* os-context-t)) context))
+ (let ((pc (context-pc context)))
+ (declare (type system-area-pointer pc))
+ ;; using INT3 the pc is .. INT3 <here> code length bytes...
+ (let* ((length (sap-ref-8 pc 1))
+ (vector (make-specializable-array
+ length
+ :element-type '(unsigned-byte 8))))
+ (declare (type (unsigned-byte 8) length)
+ (type (simple-array (unsigned-byte 8) (*)) vector))
+ (copy-from-system-area pc (* sb!vm:byte-bits 2)
+ vector (* sb!vm:word-bits
+ sb!vm:vector-data-offset)
+ (* length sb!vm:byte-bits))
+ (let* ((index 0)
+ (error-number (sb!c::read-var-integer vector index)))
+ (collect ((sc-offsets))
+ (loop
+ (when (>= index length)
+ (return))
+ (sc-offsets (sb!c::read-var-integer vector index)))
+ (values error-number (sc-offsets)))))))
+\f
+;;; Do whatever is necessary to make the given code component
+;;; executable. (This is a no-op on the x86.)
+(defun sanctify-for-execution (component)
+ (declare (ignore component))
+ nil)
+
+;;; FLOAT-WAIT
+;;;
+;;; This is used in error.lisp to insure that floating-point exceptions
+;;; are properly trapped. The compiler translates this to a VOP.
+(defun float-wait ()
+ (float-wait))
+
+;;; FLOAT CONSTANTS
+;;;
+;;; These are used by the FP MOVE-FROM-{SINGLE|DOUBLE} VOPs rather than the
+;;; i387 load constant instructions to avoid consing in some cases. Note these
+;;; are initialized by GENESIS as they are needed early.
+(defvar *fp-constant-0s0*)
+(defvar *fp-constant-1s0*)
+(defvar *fp-constant-0d0*)
+(defvar *fp-constant-1d0*)
+;;; The long-float constants.
+(defvar *fp-constant-0l0*)
+(defvar *fp-constant-1l0*)
+(defvar *fp-constant-pi*)
+(defvar *fp-constant-l2t*)
+(defvar *fp-constant-l2e*)
+(defvar *fp-constant-lg2*)
+(defvar *fp-constant-ln2*)
+
+;;; Enable/disable scavenging of the read-only space.
+(defvar *scavenge-read-only-space* nil)
+;;; FIXME: should be *SCAVENGE-READ-ONLY-SPACE-P*
+
+;;; The current alien stack pointer; saved/restored for non-local exits.
+(defvar *alien-stack*)
+
+(defun sb!kernel::%instance-set-conditional (object slot test-value new-value)
+ (declare (type instance object)
+ (type index slot))
+ #!+sb-doc
+ "Atomically compare object's slot value to test-value and if EQ store
+ new-value in the slot. The original value of the slot is returned."
+ (sb!kernel::%instance-set-conditional object slot test-value new-value))
+
+;;; Support for the MT19937 random number generator. The update
+;;; function is implemented as an assembly routine. This definition is
+;;; transformed to a call to the assembly routine allowing its use in byte
+;;; compiled code.
+(defun random-mt19937 (state)
+ (declare (type (simple-array (unsigned-byte 32) (627)) state))
+ (random-mt19937 state))
--- /dev/null
+;;;; patches to hide some implementation idiosyncrasies in our
+;;;; cross-compilation host
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+;;;; $Header$
+
+#+clisp
+(locally
+
+ (in-package "COMMON-LISP")
+
+ ;; no longer needed in CLISP 1999-01-08, hurrah!
+ #|
+ ;; ANSI specifies that package LISP defines the type BOOLEAN, and the CMU CL
+ ;; compiler uses it a lot. This should be trivial to patch in CLISP, except
+ ;; that CLISP defines FFI:BOOLEAN, which conflicts. Gads.. Here we try to fix
+ ;; it with some package hacking. (Please do not take this as an example of
+ ;; good package hacking, I just messed with it until it seemed to work well
+ ;; enough to bootstrap CMU CL, because I'm highly unmotivated to make elegant
+ ;; fixes for nonstandard behavior. -- WHN)
+ (shadow 'ffi:boolean "FFI")
+ (deftype cl::boolean () '(member t nil))
+ (export 'boolean "LISP")
+ |#
+
+ ;; I gave up on using CLISP-1999-01-08 as a cross-compilation host because of
+ ;; problems that I don't have workarounds for:
+ (error "can't use CLISP -- no MAKE-LOAD-FORM")
+ (error "can't use CLISP -- no (FUNCTION (SETF SYMBOL-FUNCTION))")
+ )
+
+;;; CMU CL, at least as of 18b, doesn't support PRINT-OBJECT. In particular, it
+;;; refuses to compile :PRINT-OBJECT options to DEFSTRUCT, so we need to
+;;; conditionalize such options on the :NO-ANSI-PRINT-OBJECT feature in order
+;;; to get the code to compile. (It also fails to do anything useful with
+;;; DEFMETHOD PRINT-OBJECT, but that doesn't matter much, since it doesn't stop
+;;; the cross-compiler from working.)
+;;;
+;;; FIXME: SBCL 0.5.0 doesn't support PRINT-OBJECT either. SBCL 0.6.0 will,
+;;; at which time this conditional should go away.
+#+cmu
+(progn
+ (warn "CMU CL doesn't support the :PRINT-OBJECT option to DEFSTRUCT.~%")
+ (pushnew :no-ansi-print-object *features*))
+
+;;; KLUDGE: In CMU CL, at least as of 18b, READ-SEQUENCE is somewhat
+;;; dain-bramaged. Running
+;;; (defvar *buffer* (make-array (expt 10 6) :element-type 'character))
+;;; (with-open-file (s "/tmp/long-file.tmp")
+;;; (/show (read-sequence *buffer* s :start 0 :end 3000))
+;;; (/show (read-sequence *buffer* s :start 0 :end 15000))
+;;; (/show (read-sequence *buffer* s :start 0 :end 15000)))
+;;; on a large test file gives
+;;; /(READ-SEQUENCE *BUFFER* S :START 0 :END 3000)=3000
+;;; /(READ-SEQUENCE *BUFFER* S :START 0 :END 15000)=1096
+;;; /(READ-SEQUENCE *BUFFER* S :START 0 :END 15000)=0
+#+cmu ; FIXME: Remove SBCL once we've patched READ-SEQUENCE.
+(progn
+ (warn "CMU CL has a broken implementation of READ-SEQUENCE.")
+ (pushnew :no-ansi-read-sequence *features*))
+
+;;; Do the exports of COMMON-LISP conform to the standard? If not, try to make
+;;; them conform. (Of course, ANSI says that bashing symbols in the COMMON-LISP
+;;; package like this is undefined, but then if the host Common Lisp were ANSI,
+;;; we wouldn't be doing this, now would we? "One dirty unportable hack
+;;; deserves another.":-)
+(let ((standard-ht (make-hash-table :test 'equal))
+ (host-ht (make-hash-table :test 'equal))
+ (cl (find-package "COMMON-LISP")))
+ (do-external-symbols (i cl)
+ (setf (gethash (symbol-name i) host-ht) t))
+ (dolist (i (read-from-file "common-lisp-exports.lisp-expr"))
+ (setf (gethash i standard-ht) t))
+ (maphash (lambda (key value)
+ (declare (ignore value))
+ (unless (gethash key standard-ht)
+ (warn "removing non-ANSI export from package CL: ~S" key)
+ (unexport (intern key cl) cl)))
+ host-ht)
+ (maphash (lambda (key value)
+ (declare (ignore value))
+ (unless (gethash key host-ht)
+ (warn "adding required-by-ANSI export to package CL: ~S" key)
+ (export (intern key cl) cl))
+ ;; FIXME: My righteous indignation below was misplaced. ANSI sez
+ ;; (in 11.1.2.1, "The COMMON-LISP Package") that it's OK for
+ ;; COMMON-LISP things to have their home packages elsewhere.
+ ;; For now, the hack below works, but it's not good to rely
+ ;; on this nonstandardness. Ergo, I should fix things so that even
+ ;; when the cross-compilation host COMMON-LISP package has
+ ;; symbols with home packages elsewhere, genesis dumps out
+ ;; the correct stuff. (For each symbol dumped, check whether it's
+ ;; exported from COMMON-LISP, and if so, dump it as though its
+ ;; home package is COMMON-LISP regardless of whether it actually
+ ;; is. I think..)
+ ;;
+ ;; X CMU CL, at least the Debian versions ca. 2.4.9 that I'm
+ ;; X using as I write this, plays a sneaky trick on us by
+ ;; X putting DEBUG and FLOATING-POINT-INEXACT in the
+ ;; X EXTENSIONS package, then IMPORTing them into
+ ;; X COMMON-LISP, then reEXPORTing them from COMMON-LISP.
+ ;; X This leaves their home packages bogusly set to
+ ;; X EXTENSIONS, which confuses genesis into thinking that
+ ;; X the CMU CL EXTENSIONS package has to be dumped into the
+ ;; X target SBCL. (perhaps a last-ditch survival strategy
+ ;; X for the CMU CL "nooo! don't bootstrap from scratch!"
+ ;; X meme?) As far as I can see, there's no even slightly
+ ;; X portable way to undo the damage, so we'll play the "one
+ ;; X dirty unportable hack deserves another" game, only even
+ ;; X dirtierly and more unportably than before..
+ #+cmu
+ (let ((symbol (intern key cl)))
+ (unless (eq (symbol-package symbol) cl)
+ (warn "using low-level hack to move ~S from ~S to ~S"
+ symbol
+ (symbol-package symbol)
+ cl)
+ (kernel:%set-symbol-package symbol cl))))
+ standard-ht))
--- /dev/null
+;;;; This file is not used cold load time. Instead, it can be loaded
+;;;; into an initialized SBCL to get it into a nostalgic frame of
+;;;; mind, remembering the way things were in cold init, so that it
+;;;; can READ code which is ordinarily read only when bootstrapping.
+;;;; (This can be useful when debugging the system, since the debugger
+;;;; likes to be able to read the source for the code. It can also be
+;;;; useful when experimenting with patches on a running system.)
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(defpackage "SB-COLD"
+ (:use "CL"))
+(in-package "SB-COLD")
+
+;;; We need the #! readtable modifications.
+(load "src/cold/shebang.lisp")
+
+;;; #!+ and #!- now refer to *FEATURES* values (as opposed to the way
+;;; that they referred to special target-only *SHEBANG-FEATURES* values
+;;; during cold init).
+(setf sb-cold:*shebang-features* *features*)
+
+;;; The nickname SB!XC now refers to the CL package.
+(rename-package "COMMON-LISP"
+ "COMMON-LISP"
+ (cons "SB!XC" (package-nicknames "CL")))
+
+;;; Any other name SB!FOO refers to the package now called SB-FOO.
+(dolist (package (list-all-packages))
+ (let ((name (package-name package))
+ (nicknames (package-nicknames package))
+ (warm-name-prefix "SB-")
+ (cold-name-prefix "SB!"))
+ (when (string= name warm-name-prefix :end1 (length warm-name-prefix))
+ (let* ((stem (subseq name (length cold-name-prefix)))
+ (cold-name (concatenate 'simple-string cold-name-prefix stem)))
+ (rename-package package name (cons cold-name nicknames))))))
--- /dev/null
+;;;; Compile the fundamental system sources (not CLOS, and possibly
+;;;; not some other warm-load-only stuff like DESCRIBE) to produce
+;;;; object files. Also set *TARGET-OBJECT-FILES* to all of their
+;;;; names.
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB-COLD")
+
+;;;; $Header$
+
+(defvar *target-object-file-names*)
+
+;;; KLUDGE..
+;;;
+;;; CMU CL (as of 2.4.6 for Debian, anyway) issues warnings (and not just
+;;; STYLE-WARNINGs, either, alas) when it tries to interpret code containing
+;;; references to undefined functions. The most common problem is that
+;;; macroexpanded code refers to this function, which isn't defined until late.
+;;;
+;;; This
+;;; #+cmu (defun sb!kernel::do-arg-count-error (&rest rest)
+;;; (error "stub version of do-arg-count-error, rest=~S" rest))
+;;; doesn't work, with or without this
+;;; (compile 'sb!kernel::do-arg-count-error))
+;;; so perhaps I should try
+;;; (declaim (ftype ..) ..)
+;;; instead?
+(declaim (ftype (function (&rest t) nil) sb!kernel::do-arg-count-error))
+
+(let ((reversed-target-object-file-names nil))
+ (for-stems-and-flags (stem flags)
+ (unless (find :not-target flags)
+ ;; FIXME: Remove these GC calls after fixing the problem of ridiculous
+ ;; bootstrap memory bloat.
+ (push (target-compile-stem stem
+ :assem-p (find :assem flags)
+ :ignore-failure-p (find :ignore-failure-p
+ flags))
+ reversed-target-object-file-names)
+ #!+sb-show (warn-when-cl-snapshot-diff *cl-snapshot*)))
+ (setf *target-object-file-names*
+ (nreverse reversed-target-object-file-names)))
--- /dev/null
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB-COLD")
+
+;;;; $Header$
+
+;;; Either load or compile-then-load the cross-compiler into the
+;;; cross-compilation host Common Lisp.
+(defun load-or-cload-xcompiler (load-or-cload-stem)
+
+ ;; The running-in-the-host-Lisp Python cross-compiler defines its
+ ;; own versions of a number of functions which should not overwrite
+ ;; host-Lisp functions. Instead we put them in a special package.
+ ;;
+ ;; The common theme of the functions, macros, constants, and so
+ ;; forth in this package is that they run in the host and affect the
+ ;; compilation of the target.
+ (let ((package-name "SB-XC"))
+ (make-package package-name :use nil :nicknames nil)
+ (dolist (name '("*COMPILE-FILE-PATHNAME*"
+ "*COMPILE-FILE-TRUENAME*"
+ "*COMPILE-PRINT*"
+ "*COMPILE-VERBOSE*"
+ "ARRAY-RANK-LIMIT"
+ "ARRAY-DIMENSION-LIMIT"
+ "ARRAY-TOTAL-SIZE-LIMIT"
+ "BUILT-IN-CLASS"
+ "CLASS" "CLASS-NAME" "CLASS-OF"
+ "COMPILE-FILE"
+ "COMPILE-FILE-PATHNAME"
+ "COMPILER-MACRO-FUNCTION"
+ "CONSTANTP"
+ "DEFCONSTANT"
+ "DEFINE-MODIFY-MACRO"
+ "DEFINE-SETF-EXPANDER"
+ "DEFMACRO" "DEFSETF" "DEFSTRUCT" "DEFTYPE"
+ "FBOUNDP" "FDEFINITION" "FMAKUNBOUND"
+ "FIND-CLASS"
+ "GET-SETF-EXPANSION"
+ "LAMBDA-LIST-KEYWORDS"
+ "LISP-IMPLEMENTATION-TYPE" "LISP-IMPLEMENTATION-VERSION"
+ "MACRO-FUNCTION"
+ "MACROEXPAND" "MACROEXPAND-1" "*MACROEXPAND-HOOK*"
+ "MAKE-LOAD-FORM"
+ "PACKAGE" "PACKAGEP"
+ "PROCLAIM"
+ "SPECIAL-OPERATOR-P"
+ "STANDARD-CLASS"
+ "STRUCTURE-CLASS"
+ "SUBTYPEP"
+ "TYPE-OF" "TYPEP"
+ "WITH-COMPILATION-UNIT"))
+ (export (intern name package-name) package-name)))
+
+ ;; Build a version of Python to run in the host Common Lisp, to be
+ ;; used only in cross-compilation.
+ ;;
+ ;; Note that files which are marked :ASSEM, to cause them to be
+ ;; processed with SB!C:ASSEMBLE-FILE when we're running under the
+ ;; cross-compiler or the target lisp, are still processed here, just
+ ;; with the ordinary Lisp compiler, and this is intentional, in
+ ;; order to make the compiler aware of the definitions of assembly
+ ;; routines.
+ (for-stems-and-flags (stem flags)
+ (unless (find :not-host flags)
+ (funcall load-or-cload-stem
+ stem
+ :ignore-failure-p (find :ignore-failure-p flags))
+ #!+sb-show (warn-when-cl-snapshot-diff *cl-snapshot*)))
+
+ ;; If the cross-compilation host is SBCL itself, we can use the
+ ;; PURIFY extension to freeze everything in place, reducing the
+ ;; amount of work done on future GCs. In machines with limited
+ ;; memory, this could help, by reducing the amount of memory which
+ ;; needs to be juggled in a full GC. And it can hardly hurt, since
+ ;; (in the ordinary build procedure anyway) essentially everything
+ ;; which is reachable at this point will remain reachable for the
+ ;; entire run.
+ #+sbcl (sb-ext:purify)
+
+ (values))
--- /dev/null
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB-COLD")
+
+;;;; $Header$
+
+;;; Return an expression read from the file named PATHNAME-DESIGNATOR.
+(export 'read-from-file)
+(defun read-from-file (pathname-designator)
+ (with-open-file (s pathname-designator)
+ (let* ((result (read s))
+ (eof-result (cons nil nil))
+ (after-result (read s nil eof-result)))
+ (unless (eq after-result eof-result)
+ (error "more than one expression in file ~S" pathname-designator))
+ result)))
+(compile 'read-from-file)
--- /dev/null
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB-COLD")
+
+;;;; $Header$
+
+;;; RENAME-PACKAGE in two steps in order to avoid the possibility of undefined
+;;; behavior when one of the new names is the same as one of the old names.
+;;; (ANSI on RENAME-PACKAGE: "The consequences are undefined if new-name or any
+;;; new-nickname conflicts with any existing package names.")
+(defun rename-package-carefully (package-designator
+ new-name
+ &optional new-nicknames)
+ (let ((package (find-package package-designator))
+ (unused-name "UNUSED-PACKAGE-NAME"))
+ (assert (not (find-package unused-name)))
+ (assert (not (string= unused-name new-name)))
+ (assert (not (find unused-name new-nicknames :test #'string=)))
+ (assert (not (find new-name new-nicknames :test #'string=)))
+ (rename-package package unused-name)
+ (rename-package package new-name new-nicknames)))
+(compile 'rename-package-carefully)
--- /dev/null
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB-COLD")
+
+;;;; $Header$
+
+;;; an entry in the table which describes the non-standard part (i.e. not
+;;; CL/CL-USER/KEYWORD) of the package structure of the SBCL system
+;;;
+;;; We make no attempt to be fully general; our table doesn't need to be
+;;; able to express features which we don't happen to use.
+(export '(package-data
+ package-data-name
+ package-data-nicknames
+ package-data-export
+ package-data-reexport
+ package-data-import-from
+ package-data-use))
+(defstruct package-data
+ ;; a string designator for the package name
+ (name (error "missing PACKAGE-DATA-NAME datum"))
+ ;; a doc string
+ (doc (error "missing PACKAGE-DOC datum"))
+ ;; a list of string designators for package nicknames
+ nicknames
+ ;; a tree containing names for exported symbols which'll be set up at package
+ ;; creation time, and NILs, which are ignored. (This is a tree in order to
+ ;; allow constructs like '("ENOSPC" #!+LINUX ("EDQUOT" "EISNAM" "ENAVAIL"
+ ;; "EREMOTEIO")) to be used in initialization. NIL entries in the tree are
+ ;; ignored for the same reason of notational convenience.)
+ export
+ ;; a list of string designators for exported symbols which don't necessarily
+ ;; originate in this package (so their EXPORT operations should be handled
+ ;; after USE operations have been done, so that duplicates aren't created)
+ reexport
+ ;; a list of sublists describing imports. Each sublist has the format as an
+ ;; IMPORT-FROM list in DEFPACKAGE: the first element is the name of the
+ ;; package to import from, and the remaining elements are the names of
+ ;; symbols to import.
+ import-from
+ ;; a tree of string designators for package names of other packages
+ ;; which this package uses
+ use)
+
+(let ((package-data-list (read-from-file "package-data-list.lisp-expr")))
+
+ ;; Build all packages that we need, and initialize them as far as we
+ ;; can without referring to any other packages.
+ (dolist (package-data package-data-list)
+ (let* ((package (make-package
+ (package-data-name package-data)
+ :nicknames (package-data-nicknames package-data)
+ :use nil)))
+ #!+sb-doc (setf (documentation package t)
+ (package-data-doc package-data))
+ ;; Walk the tree of exported names, exporting each name.
+ (labels ((recurse (tree)
+ (etypecase tree
+ ;; FIXME: The comments above say the structure is a tree,
+ ;; but here we're sleazily treating it as though
+ ;; dotted lists never occur. Replace this LIST case
+ ;; with separate NULL and CONS cases to fix this.
+ (list (mapc #'recurse tree))
+ (string (export (intern tree package) package)))))
+ (recurse (package-data-export package-data)))))
+
+ ;; Now that all packages exist, we can set up package-package
+ ;; references.
+ (dolist (package-data package-data-list)
+ (use-package (package-data-use package-data)
+ (package-data-name package-data))
+ (dolist (sublist (package-data-import-from package-data))
+ (let* ((from-package (first sublist))
+ (symbol-names (rest sublist))
+ (symbols (mapcar (lambda (name)
+ ;; old way, broke for importing symbols
+ ;; like SB!C::DEBUG-SOURCE-FORM into
+ ;; SB!DI -- WHN 19990714
+ #+nil
+ (let ((s (find-symbol name from-package)))
+ (unless s
+ (error "can't find ~S in ~S"
+ name
+ from-package))
+ s)
+ ;; new way, works for SB!DI stuff
+ ;; -- WHN 19990714
+ (intern name from-package))
+ symbol-names)))
+ (import symbols (package-data-name package-data)))))
+
+ ;; Now that all package-package references exist, we can handle
+ ;; REEXPORT operations. (We have to wait until now because they
+ ;; interact with USE operations.) KLUDGE: This code doesn't detect
+ ;; dependencies and do exports in proper order to work around them, so
+ ;; it could break randomly (with build-time errors, not with silent
+ ;; errors or runtime errors) if multiple levels of re-exportation are
+ ;; used, e.g. package A exports X, package B uses A and reexports X,
+ ;; and package C uses B and reexports X. That doesn't seem to be an
+ ;; issue in the current code, and it's hard to see why anyone would
+ ;; want to do it, and it should be straightforward (though tedious) to
+ ;; extend the code here to deal with that if it ever becomes necessary.
+ (dolist (package-data package-data-list)
+ (let ((package (find-package (package-data-name package-data))))
+ (dolist (symbol-name (package-data-reexport package-data))
+ (multiple-value-bind (symbol status)
+ (find-symbol symbol-name package)
+ (unless status
+ (error "No symbol named ~S is accessible in ~S."
+ symbol-name
+ package))
+ (when (eq (symbol-package symbol) package)
+ (error "~S is not inherited/imported, but native to ~S."
+ symbol-name
+ package))
+ (export symbol package))))))
--- /dev/null
+;;;; stuff which is not specific to any particular build phase, but
+;;;; used by most of them
+;;;;
+;;;; Note: It's specifically not used when bootstrapping PCL, because
+;;;; we do SAVE-LISP after that, and we don't want to save extraneous
+;;;; bootstrapping machinery into the frozen image which will
+;;;; subsequently be used as the mother of all Lisp sessions.
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+;;;; $Header$
+
+;;; TO DO: Might it be possible to increase the efficiency of CMU CL's garbage
+;;; collection on my large (256Mb) machine by doing larger incremental GC steps
+;;; than the default 2 Mb of CMU CL 2.4.9? A quick test 19990729, setting this
+;;; to 5E6 showed no significant improvement, but it's possible that more
+;;; cleverness might help..
+;#+cmu (setf ext:*bytes-consed-between-gcs* (* 5 (expt 10 6)))
+
+;;; FIXME: I'm now inclined to make all the bootstrap stuff run in CL-USER
+;;; instead of SB-COLD. If I do so, I should first take care to
+;;; UNINTERN any old stuff in CL-USER, since ANSI says (11.1.2.2, "The
+;;; COMMON-LISP-USER Package") that CL-USER can have arbitrary symbols in
+;;; it. (And of course I should set the USE list to only CL.)
+(defpackage "SB-COLD" (:use "CL"))
+(in-package "SB-COLD")
+
+;;; prefix for source filename stems when cross-compiling
+(defvar *src-prefix* "src/")
+;;; (We don't bother to specify the source suffix here because ".lisp" is such
+;;; a good default value that we never have to specify it explicitly.)
+
+;;; prefixes for filename stems when cross-compiling. These are quite arbitrary
+;;; (although of course they shouldn't collide with anything we don't want to
+;;; write over). In particular, they can be either relative path names (e.g.
+;;; "host-objects/" or absolute pathnames (e.g. "/tmp/sbcl-xc-host-objects/").
+;;;
+;;; The cross-compilation process will force the creation of these directories
+;;; by executing CL:ENSURE-DIRECTORIES-EXIST (on the host Common Lisp).
+(defvar *host-obj-prefix*)
+(defvar *target-obj-prefix*)
+
+;;; suffixes for filename stems when cross-compiling. Everything should work
+;;; fine for any arbitrary string values here. With more work maybe we
+;;; could cause these automatically to become the traditional extensions for
+;;; whatever host and target architectures (e.g. ".x86f" or ".axpf") we're
+;;; currently doing. That would make it easier for a human looking at the
+;;; temporary files to figure out what they're for, but it's not necessary for
+;;; the compilation process to work, so we haven't bothered.
+(defvar *host-obj-suffix* ".lisp-obj")
+(defvar *target-obj-suffix* ".lisp-obj")
+
+;;; a function of one functional argument, which calls its functional argument
+;;; in an environment suitable for compiling the target. (This environment
+;;; includes e.g. a suitable *FEATURES* value.)
+(defvar *in-target-compilation-mode-fn*)
+
+;;; designator for a function with the same calling convention as
+;;; CL:COMPILE-FILE, to be used to translate ordinary Lisp source files into
+;;; target object files
+(defvar *target-compile-file*)
+
+;;; designator for a function with the same calling convention as
+;;; SB-C:ASSEMBLE-FILE, to be used to translate assembly files into target
+;;; object files
+(defvar *target-assemble-file*)
+\f
+;;;; some tools
+
+;;; Take the file named X and make it into a file named Y. Sorta like UNIX, and
+;;; unlike Common Lisp's bare RENAME-FILE, we don't allow information
+;;; from the original filename to influence the final filename. (The reason
+;;; that it's only sorta like UNIX is that in UNIX "mv foo bar/" will work,
+;;; but the analogous (RENAME-FILE-A-LA-UNIX "foo" "bar/") should fail.)
+;;;
+;;; (This is a workaround for the weird behavior of Debian CMU CL 2.4.6, where
+;;; (RENAME-FILE "dir/x" "dir/y") tries to create a file called "dir/dir/y".
+;;; If that behavior goes away, then we should be able to get rid of this
+;;; function and use plain RENAME-FILE in the COMPILE-STEM function
+;;; above. -- WHN 19990321
+(defun rename-file-a-la-unix (x y)
+ (rename-file x
+ ;; (Note that the TRUENAME expression here is lifted from an
+ ;; example in the ANSI spec for TRUENAME.)
+ (with-open-file (stream y :direction :output)
+ (close stream)
+ ;; From the ANSI spec: "In this case, the file is closed
+ ;; when the truename is tried, so the truename
+ ;; information is reliable."
+ (truename stream))))
+(compile 'rename-file-a-la-unix)
+
+;;; a wrapper for compilation/assembly, used mostly to centralize
+;;; the procedure for finding full filenames from "stems"
+;;;
+;;; Compile the source file whose basic name is STEM, using some
+;;; standard-for-the-SBCL-build-process procedures to generate the full
+;;; pathnames of source file and object file. Return the pathname of the object
+;;; file for STEM. Several keyword arguments are accepted:
+;;; SRC-PREFIX, SRC-SUFFIX =
+;;; strings to be concatenated to STEM to produce source filename
+;;; OBJ-PREFIX, OBJ-SUFFIX =
+;;; strings to be concatenated to STEM to produce object filename
+;;; TMP-OBJ-SUFFIX-SUFFIX
+;;; string to be appended to the name of an object file to produce the
+;;; name of a temporary object file
+;;; COMPILE-FILE, IGNORE-FAILURE-P =
+;;; COMPILE-FILE is a function to use for compiling the file (with the
+;;; same calling conventions as ANSI CL:COMPILE-FILE). If the third
+;;; return value (FAILURE-P) of this function is true, a continuable
+;;; error will be signalled, unless IGNORE-FAILURE-P is set, in which
+;;; case only a warning will be signalled.
+(defun compile-stem (stem
+ &key
+ (obj-prefix "")
+ (obj-suffix (error "missing OBJ-SUFFIX"))
+ (tmp-obj-suffix-suffix "-tmp")
+ (src-prefix "")
+ (src-suffix ".lisp")
+ (compile-file #'compile-file)
+ ignore-failure-p)
+
+ (let* (;; KLUDGE: Note that this CONCATENATE 'STRING stuff is not The Common
+ ;; Lisp Way, although it works just fine for common UNIX environments.
+ ;; Should it come to pass that the system is ported to environments
+ ;; where version numbers and so forth become an issue, it might become
+ ;; urgent to rewrite this using the fancy Common Lisp PATHNAME
+ ;; machinery instead of just using strings. In the absence of such a
+ ;; port, it might or might be a good idea to do the rewrite.
+ ;; -- WHN 19990815
+ (src (concatenate 'string src-prefix stem src-suffix))
+ (obj (concatenate 'string obj-prefix stem obj-suffix))
+ (tmp-obj (concatenate 'string obj tmp-obj-suffix-suffix)))
+
+ (ensure-directories-exist obj :verbose t)
+
+ ;; We're about to set about building a new object file. First, we
+ ;; delete any preexisting object file in order to avoid confusing
+ ;; ourselves later should we happen to bail out of compilation with an
+ ;; error.
+ (when (probe-file obj)
+ (delete-file obj))
+
+ ;; Work around a bug in CLISP 1999-01-08 #'COMPILE-FILE: CLISP mangles
+ ;; relative pathnames passed as :OUTPUT-FILE arguments, but works OK
+ ;; with absolute pathnames.
+ #+clisp
+ (setf tmp-obj
+ ;; (Note that this idiom is taken from the ANSI documentation
+ ;; for TRUENAME.)
+ (with-open-file (stream tmp-obj :direction :output)
+ (close stream)
+ (truename stream)))
+
+ ;; Try to use the compiler to generate a new temporary object file.
+ (multiple-value-bind (output-truename warnings-p failure-p)
+ (funcall compile-file src :output-file tmp-obj)
+ (declare (ignore warnings-p))
+ (cond ((not output-truename)
+ (error "couldn't compile ~S" src))
+ (failure-p
+ (if ignore-failure-p
+ (warn "ignoring FAILURE-P return value from compilation of ~S"
+ src)
+ (unwind-protect
+ (progn
+ ;; FIXME: This should have another option, redoing
+ ;; compilation.
+ (cerror "Continue, using possibly-bogus ~S."
+ "FAILURE-P was set when creating ~S."
+ obj)
+ (setf failure-p nil))
+ ;; Don't leave failed object files lying around.
+ (when (and failure-p (probe-file tmp-obj))
+ (delete-file tmp-obj)
+ (format t "~&deleted ~S~%" tmp-obj)))))
+ ;; Otherwise: success, just fall through.
+ (t nil)))
+
+ ;; If we get to here, compilation succeeded, so it's OK to rename the
+ ;; temporary output file to the permanent object file.
+ (rename-file-a-la-unix tmp-obj obj)
+
+ ;; nice friendly traditional return value
+ (pathname obj)))
+(compile 'compile-stem)
+
+;;; basic tool for building other tools
+#+nil
+(defun tool-cload-stem (stem)
+ (load (compile-stem stem
+ :src-prefix *src-prefix*
+ :obj-prefix *host-obj-prefix*
+ :obj-suffix *host-obj-suffix*
+ :compile-file #'compile-file))
+ (values))
+#+nil (compile 'tool-cload-stem)
+
+;;; other miscellaneous tools
+(load "src/cold/read-from-file.lisp")
+(load "src/cold/rename-package-carefully.lisp")
+(load "src/cold/with-stuff.lisp")
+
+;;; Try to minimize/conceal any non-standardness of the host Common Lisp.
+(load "src/cold/ansify.lisp")
+\f
+;;;; special read-macros for building the cold system (and even for
+;;;; building some of our tools for building the cold system)
+
+(load "src/cold/shebang.lisp")
+
+;;; When cross-compiling, the *FEATURES* set for the target Lisp is
+;;; not in general the same as the *FEATURES* set for the host Lisp.
+;;; In order to refer to target features specifically, we refer to
+;;; *SHEBANG-FEATURES* instead of *FEATURES*, and use the #!+ and #!-
+;;; readmacros instead of the ordinary #+ and #- readmacros.
+(setf *shebang-features*
+ (append (read-from-file "base-target-features.lisp-expr")
+ (read-from-file "local-target-features.lisp-expr")))
+\f
+;;;; cold-init-related PACKAGE and SYMBOL tools
+
+;;; Once we're done with possibly ANSIfying the COMMON-LISP package,
+;;; it's probably a mistake if we change it (beyond changing the
+;;; values of special variables such as *** and +, anyway). Set up
+;;; machinery to warn us when/if we change it.
+;;;
+;;; FIXME: All this machinery should probably be conditional on
+;;; #!+SB-SHOW, i.e. we should be able to wrap #!+SB-SHOW around both
+;;; the LOAD and the DEFVAR here.
+(load "src/cold/snapshot.lisp")
+(defvar *cl-snapshot* (take-snapshot "COMMON-LISP"))
+\f
+;;;; master list of source files and their properties
+
+;;; flags which can be used to describe properties of source files
+(defparameter
+ *expected-stem-flags*
+ '(;; meaning: This file is not to be compiled when building the
+ ;; cross-compiler which runs on the host ANSI Lisp.
+ :not-host
+ ;; meaning: This file is not to be compiled as part of the target
+ ;; SBCL.
+ :not-target
+ ;; meaning: This file is to be processed with the SBCL assembler,
+ ;; not COMPILE-FILE. (Note that this doesn't make sense unless
+ ;; :NOT-HOST is also set, since the SBCL assembler doesn't exist
+ ;; while the cross-compiler is being built in the host ANSI Lisp.)
+ :assem
+ ;; meaning: The COMPILE-STEM keyword argument called
+ ;; IGNORE-FAILURE-P should be true. (This is a KLUDGE: I'd like to
+ ;; get rid of it. For now, it exists so that compilation can
+ ;; proceed through the legacy warnings in
+ ;; src/compiler/x86/array.lisp, which I've never figured out but
+ ;; which were apparently acceptable in CMU CL. Eventually, it
+ ;; would be great to just get rid of all warnings and remove
+ ;; support for this flag. -- WHN 19990323)
+ :ignore-failure-p))
+
+(defparameter *stems-and-flags* (read-from-file "stems-and-flags.lisp-expr"))
+
+(defmacro for-stems-and-flags ((stem flags) &body body)
+ (let ((stem-and-flags (gensym "STEM-AND-FLAGS-")))
+ `(dolist (,stem-and-flags *stems-and-flags*)
+ (let ((,stem (first ,stem-and-flags))
+ (,flags (rest ,stem-and-flags)))
+ ,@body))))
+
+;;; Check for stupid typos in FLAGS list keywords.
+(let ((stems (make-hash-table :test #'equal)))
+ (for-stems-and-flags (stem flags)
+ (if (gethash stem stems)
+ (error "duplicate stem ~S in stems-and-flags data" stem)
+ (setf (gethash stem stems) t))
+ (let ((set-difference (set-difference flags *expected-stem-flags*)))
+ (when set-difference
+ (error "found unexpected flag(s) in *STEMS-AND-FLAGS*: ~S"
+ set-difference)))))
+\f
+;;;; compiling SBCL sources to create the cross-compiler
+
+;;; Execute function FN in an environment appropriate for compiling the
+;;; cross-compiler's source code in the cross-compilation host.
+(defun in-host-compilation-mode (fn)
+ (let ((*features* (cons :sb-xc-host *features*)))
+ (with-additional-nickname ("SB-XC" "SB!XC")
+ (funcall fn))))
+(compile 'in-host-compilation-mode)
+
+;;; Process a file as source code for the cross-compiler, compiling it
+;;; (if necessary) in the appropriate environment, then loading it
+;;; into the cross-compilation host Common lisp.
+(defun host-cload-stem (stem &key ignore-failure-p)
+ (load (in-host-compilation-mode
+ (lambda ()
+ (compile-stem stem
+ :src-prefix *src-prefix*
+ :obj-prefix *host-obj-prefix*
+ :obj-suffix *host-obj-suffix*
+ :compile-file #'cl:compile-file
+ :ignore-failure-p ignore-failure-p)))))
+(compile 'host-cload-stem)
+
+;;; Like HOST-CLOAD-STEM, except that we don't bother to compile.
+(defun host-load-stem (stem &key ignore-failure-p)
+ (declare (ignore ignore-failure-p)) ; (It's only relevant when
+ ;; compiling.) KLUDGE: It's untidy to have the knowledge of how to
+ ;; construct complete filenames from stems in here as well as in
+ ;; COMPILE-STEM. It should probably be factored out somehow. -- WHN
+ ;; 19990815
+ (load (concatenate 'simple-string *host-obj-prefix* stem *host-obj-suffix*)))
+(compile 'host-load-stem)
+\f
+;;;; compiling SBCL sources to create object files which will be used
+;;;; to create the target SBCL .core file
+
+;;; Run the cross-compiler on a file in the source directory tree to
+;;; produce a corresponding file in the target object directory tree.
+(defun target-compile-stem (stem &key assem-p ignore-failure-p)
+ (funcall *in-target-compilation-mode-fn*
+ (lambda ()
+ (compile-stem stem
+ :src-prefix *src-prefix*
+ :obj-prefix *target-obj-prefix*
+ :obj-suffix *target-obj-suffix*
+ :ignore-failure-p ignore-failure-p
+ :compile-file (if assem-p
+ *target-assemble-file*
+ *target-compile-file*)))))
+(compile 'target-compile-stem)
+
+;;; (This function is not used by the build process, but is intended
+;;; for interactive use when experimenting with the system. It runs
+;;; the cross-compiler on test files with arbitrary filenames, not
+;;; necessarily in the source tree, e.g. in "/tmp/".)
+(defun target-compile-file (filename)
+ (funcall *in-target-compilation-mode-fn*
+ (lambda ()
+ (funcall *target-compile-file* filename))))
+(compile 'target-compile-file)
--- /dev/null
+;;;; cold-boot-only readmacro syntax
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB-COLD")
+
+;;;; $Header$
+\f
+;;;; definition of #!+ and #!- as a mechanism analogous to #+/#-,
+;;;; but redirectable to any list of features. (This is handy when
+;;;; cross-compiling for making a distinction between features of the
+;;;; host Common Lisp and features of the target SBCL.)
+
+;;; the feature list for the target system
+(export '*shebang-features*)
+(declaim (type symbol *shebang-features*))
+(defvar *shebang-features*)
+
+(defun feature-in-list-p (feature list)
+ (etypecase feature
+ (symbol (member feature list :test #'eq))
+ (cons (flet ((subfeature-in-list-p (subfeature)
+ (feature-in-list-p subfeature list)))
+ (ecase (first feature)
+ (:or (some #'subfeature-in-list-p (rest feature)))
+ (:and (every #'subfeature-in-list-p (rest feature)))
+ (:not (let ((rest (cdr feature)))
+ (if (or (null (car rest)) (cdr rest))
+ (error "wrong number of terms in compound feature ~S"
+ feature)
+ (not (subfeature-in-list-p (second feature)))))))))))
+(compile 'feature-in-list-p)
+
+(defun shebang-reader (stream sub-character infix-parameter)
+ (declare (ignore sub-character))
+ (when infix-parameter
+ (error "illegal read syntax: #~DT" infix-parameter))
+ (let ((next-char (read-char stream)))
+ (unless (find next-char "+-")
+ (error "illegal read syntax: #!~C" next-char))
+ ;; When test is not satisfied
+ ;; FIXME: clearer if order of NOT-P and (NOT NOT-P) were reversed? then
+ ;; would become "unless test is satisfied"..
+ (when (let* ((*package* (find-package "KEYWORD"))
+ (*read-suppress* nil)
+ (not-p (char= next-char #\-))
+ (feature (read stream)))
+ (if (feature-in-list-p feature *shebang-features*)
+ not-p
+ (not not-p)))
+ ;; Read (and discard) a form from input.
+ (let ((*read-suppress* t))
+ (read stream t nil t))))
+ (values))
+(compile 'shebang-reader)
+
+(set-dispatch-macro-character #\# #\! #'shebang-reader)
+\f
+;;;; FIXME: Would it be worth implementing this?
+#|
+;;;; readmacro syntax to remove spaces from FORMAT strings at compile time
+;;;; instead of leaving them to be skipped over at runtime
+
+;;; a counter of the number of bytes that we think we've avoided having to
+;;; compile into the system by virtue of doing compile-time processing
+(defvar *shebang-double-quote--approx-bytes-saved* 0)
+
+;;; Read a string, strip out any #\~ #\NEWLINE whitespace sequence,
+;;; and return the result. (This is a subset of the processing performed
+;;; by FORMAT, but we perform it at compile time instead of postponing
+;;; it until run-time.
+(defun shebang-double-quote (stream)
+ (labels ((rc () (read-char stream))
+ (white-p (char)
+ ;; Putting non-standard characters in the compiler source is
+ ;; generally a bad idea, since we'd like to be really portable.
+ ;; It's specifically a bad idea in strings intended to be
+ ;; processed by SHEBANG-DOUBLE-QUOTE, because there seems to be no
+ ;; portable way to test a non-STANDARD-CHAR for whitespaceness.
+ ;; (The most common problem would be to put a #\TAB -- which is
+ ;; not a STANDARD-CHAR -- into the string. If this is part of the
+ ;; to-be-skipped-over whitespace after a #\~ #\NEWLINE sequence in
+ ;; the string, it won't work, because it won't be recognized as
+ ;; whitespace.)
+ (unless (typep char 'standard-char)
+ (warn "non-STANDARD-CHAR in #!\": ~C" result))
+ (or (char= char #\newline)
+ (char= char #\space)))
+ (skip-white ()
+ (do ((char (rc) (rc))
+ (count 0 (1+ count)))
+ ((not (white-p char))
+ (unread-char char stream)
+ count))))
+ (do ((adj-string (make-array 0 :element-type 'char :adjustable t))
+ (char (rc) (rc)))
+ ((char= char #\") (coerce adj-string 'simple-string))
+ (cond ((char= char #\~)
+ (let ((next-char (read-char stream)))
+ (cond ((char= next-char #\newline)
+ (incf *shebang-double-quote--approx-bytes-saved*
+ (+ 2 (skip-white))))
+ (t
+ (vector-push-extend char adj-string)
+ (vector-push-extend next-char adj-string)))))
+ ((char= char #\\)
+ (vector-push-extend char adj-string)
+ (vector-push-extend (rc) adj-string))
+ (t (vector-push-extend char adj-string))))))
+
+(setf (gethash #\" *shebang-dispatch*)
+ #'shebang-double-quote)
+|#
\ No newline at end of file
--- /dev/null
+;;;; code to detect whether a package has changed
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB-COLD")
+
+;;;; $Header$
+
+(defstruct snapshot
+ (hash-table (make-hash-table :test 'eq)
+ :type hash-table
+ :read-only t))
+
+;;; Return a SNAPSHOT object representing the current state of the
+;;; package associated with PACKAGE-DESIGNATOR.
+;;;
+;;; This could be made more sensitive, checking for more things, such as
+;;; type definitions and documentation strings.
+(defun take-snapshot (package-designator)
+ (let ((package (find-package package-designator))
+ (result (make-snapshot)))
+ (unless package
+ (error "can't find package ~S" package-designator))
+ (do-symbols (symbol package)
+ (multiple-value-bind (symbol-ignore status)
+ (find-symbol (symbol-name symbol) package)
+ (declare (ignore symbol-ignore))
+ (let ((symbol-properties nil))
+ (ecase status
+ (:inherited
+ (values))
+ ((:internal :external)
+ (when (boundp symbol)
+ (push (cons :symbol-value (symbol-value symbol))
+ symbol-properties))
+ (when (fboundp symbol)
+ (push (cons :symbol-function (symbol-function symbol))
+ symbol-properties))
+ (when (macro-function symbol)
+ (push (cons :macro-function (macro-function symbol))
+ symbol-properties))
+ (when (special-operator-p symbol)
+ (push :special-operator
+ symbol-properties))))
+ (push status symbol-properties)
+ (setf (gethash symbol (snapshot-hash-table result))
+ symbol-properties))))
+ result))
+(compile 'take-snapshot)
+
+(defun snapshot-diff (x y)
+ (let ((xh (snapshot-hash-table x))
+ (yh (snapshot-hash-table y))
+ (result nil))
+ (flet ((1way (ah bh)
+ (maphash (lambda (key avalue)
+ (declare (ignore avalue))
+ (multiple-value-bind (bvalue bvalue?) (gethash key bh)
+ (declare (ignore bvalue))
+ (unless bvalue?
+ (push (list key ah)
+ result))))
+ ah)))
+ (1way xh yh)
+ (1way yh xh))
+ (maphash (lambda (key xvalue)
+ (multiple-value-bind (yvalue yvalue?) (gethash key yh)
+ (when yvalue?
+ (unless (equalp xvalue yvalue)
+ (push (list key xvalue yvalue)
+ result)))))
+ xh)
+ result))
+(compile 'snapshot-diff)
+
+;;;; symbols in package COMMON-LISP which change regularly in the course of
+;;;; execution even if we don't mess with them, so that reporting changes
+;;;; would be more confusing than useful
+(defparameter
+ *cl-ignorable-diffs*
+ (let ((result (make-hash-table :test 'eq)))
+ (dolist (symbol `(;; These change regularly:
+ * ** ***
+ / // ///
+ + ++ +++
+ -
+ *gensym-counter*
+ ;; These are bound when compiling and/or loading:
+ *package*
+ *compile-file-truename*
+ *compile-file-pathname*
+ *load-truename*
+ *load-pathname*
+ ;; These change because CMU CL uses them as internal
+ ;; variables:
+ ,@'
+ #-cmu nil
+ #+cmu (cl::*gc-trigger*
+ cl::inch-ptr
+ cl::*internal-symbol-output-function*
+ cl::ouch-ptr
+ cl::*previous-case*
+ cl::read-buffer
+ cl::read-buffer-length
+ cl::*string-output-streams*
+ cl::*available-buffers*
+ cl::*current-unwind-protect-block*
+ cl::*load-depth*
+ cl::*free-fop-tables*
+ ;; These two are changed by PURIFY.
+ cl::*static-space-free-pointer*
+ cl::*static-space-end-pointer*)
+ ))
+ (setf (gethash symbol result) t))
+ result))
+
+;;; specialized version of SNAPSHOT-DIFF to check on the COMMON-LISP package,
+;;; throwing away reports of differences in variables which are known to change
+;;; regularly
+;;;
+;;; Note: The warnings from this code were somewhat useful when first setting
+;;; up the cross-compilation system, have a rather low signal/noise ratio in
+;;; the mature system. They can generally be safely ignored.
+#!+sb-show
+(progn
+ (defun cl-snapshot-diff (cl-snapshot)
+ (remove-if (lambda (entry)
+ (gethash (first entry) *cl-ignorable-diffs*))
+ (snapshot-diff cl-snapshot (take-snapshot :common-lisp))))
+ (defun warn-when-cl-snapshot-diff (cl-snapshot)
+ (let ((cl-snapshot-diff (cl-snapshot-diff cl-snapshot)))
+ (when cl-snapshot-diff
+ (let ((*print-length* 30)
+ (*print-circle* t))
+ (warn "CL snapshot differs:")
+ (print cl-snapshot-diff *error-output*)))))
+ (compile 'cl-snapshot-diff)
+ (compile 'warn-when-cl-snapshot-diff))
--- /dev/null
+;;;; "warm initialization": initialization which comes after cold init
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "COMMON-LISP-USER")
+
+;;;; $Header$
+\f
+;;;; general warm init compilation policy
+
+(proclaim '(optimize (compilation-speed 1)
+ (debug #+sb-show 2 #-sb-show 1)
+ (inhibit-warnings 2)
+ (safety 1)
+ (space 1)
+ (speed 2)))
+\f
+;;;; KLUDGE: Compile and load files which really belong in cold load but are
+;;;; here for various unsound reasons. We handle them here, before the package
+;;;; hacking below, because they use the SB!FOO cold package name convention
+;;;; instead of the SB-FOO final package name convention (since they really
+;;;; do belong in cold load and will hopefully make it back there reasonably
+;;;; soon). -- WHN 19991207
+
+(dolist (stem '(;; FIXME: The files here from outside the src/pcl/ directory
+ ;; probably belong in cold load instead of warm load. They
+ ;; ended up here as a quick hack to work around the
+ ;; consequences of my misunderstanding how ASSEMBLE-FILE works
+ ;; when I wrote the cold build code. The cold build code
+ ;; expects only one FASL filename per source file, when it
+ ;; turns out we really need one FASL file for ASSEMBLE-FILE
+ ;; output and another for COMPILE-FILE output. It would
+ ;; probably be good to redo the cold build code so that the
+ ;; COMPILE-FILE stuff generated here can be loaded at the same
+ ;; time as the ASSEMBLE-FILE stuff generated there.
+ "src/assembly/target/assem-rtns"
+ "src/assembly/target/array"
+ "src/assembly/target/arith"
+ "src/assembly/target/alloc"))
+ ;; KLUDGE: Cut-and-paste programming, the sign of a true professional.:-|
+ ;; (Hopefully this will go away as we move the files above into cold load.)
+ ;; -- WHN 19991214
+ (let ((fullname (concatenate 'string stem ".lisp")))
+ (sb!int:/show "about to compile" fullname)
+ (multiple-value-bind
+ (compiled-truename compilation-warnings-p compilation-failure-p)
+ (compile-file fullname)
+ (declare (ignore compilation-warnings-p))
+ (sb!int:/show "done compiling" fullname)
+ (if compilation-failure-p
+ (error "COMPILE-FILE of ~S failed." fullname)
+ (unless (load compiled-truename)
+ (error "LOAD of ~S failed." compiled-truename))))))
+\f
+;;;; package hacking
+
+;;; Our cross-compilation host is out of the picture now, so we no longer need
+;;; to worry about collisions between our package names and cross-compilation
+;;; host package names, so now is a good time to rename any package with a
+;;; bootstrap-only name SB!FOO to its permanent name SB-FOO.
+;;;
+;;; (In principle it might be tidier to do this when dumping the cold image in
+;;; genesis, but in practice the logic might be a little messier because
+;;; genesis dumps both symbols and packages, and we'd need to make that dumped
+;;; symbols were renamed in the same way as dumped packages. Or we could do it
+;;; in cold init, but it's easier to experiment with and debug things here in
+;;; warm init than in cold init, so we do it here instead.)
+(let ((boot-prefix "SB!")
+ (perm-prefix "SB-"))
+ (dolist (package (list-all-packages))
+ (let ((old-package-name (package-name package)))
+ (when (and (>= (length old-package-name) (length boot-prefix))
+ (string= boot-prefix old-package-name
+ :end2 (length boot-prefix)))
+ (let ((new-package-name (concatenate 'string
+ perm-prefix
+ (subseq old-package-name
+ (length boot-prefix)))))
+ (rename-package package
+ new-package-name
+ (package-nicknames package)))))))
+
+;;; KLUDGE: This is created here (instead of in package-data-list.lisp-expr)
+;;; because it doesn't have any symbols in it, so even if it's
+;;; present at cold load time, genesis thinks it's unimportant
+;;; and doesn't dump it. There's gotta be a better way, but for now
+;;; I'll just do it here. (As noted below, I'd just as soon have this
+;;; go away entirely, so I'm disinclined to fiddle with it too much.)
+;;; -- WHN 19991206
+;;;
+;;; FIXME: Why do slot accessor names need to be interned anywhere? For
+;;; low-level debugging? Perhaps this should go away, or at least
+;;; be optional, controlled by SB-SHOW or something.
+(defpackage "SB-SLOT-ACCESSOR-NAME"
+ (:use))
+\f
+;;;; compiling and loading more of the system
+
+;;; KLUDGE: In SBCL, almost all in-the-flow-of-control package hacking has
+;;; gone away in favor of package setup controlled by tables. However, that
+;;; mechanism isn't smart enough to handle shadowing, and since this shadowing
+;;; is inherently a non-ANSI KLUDGE anyway (i.e. there ought to be no
+;;; difference between e.g. CL:CLASS and SB-PCL:CLASS) there's not much
+;;; point in trying to polish it by implementing a non-KLUDGEy way of
+;;; setting it up. -- WHN 19991203
+(let ((*package* (the package (find-package "SB-PCL"))))
+ (shadow '(;; CLASS itself and operations thereon
+ "CLASS" "CLASS-NAME" "CLASS-OF" "FIND-CLASS"
+ ;; some system classes
+ "BUILT-IN-CLASS" "STANDARD-CLASS" "STRUCTURE-CLASS"))
+ ;; Of the shadowing symbols above, these are external symbols in CMU CL ca.
+ ;; 19991203. I'm not sure what's the basis of the decision to export some and
+ ;; not others; we'll just follow along..
+ (export (mapcar #'intern '("CLASS-NAME" "CLASS-OF" "FIND-CLASS"))))
+
+;;; FIXME: CMU CL's pclcom.lisp had extra optional stuff wrapped around
+;;; COMPILE-PCL, at least some of which we should probably have too:
+;;;
+;;; (with-compilation-unit
+;;; (:optimize '(optimize (debug #+(and (not high-security) small) .5
+;;; #-(or high-security small) 2
+;;; #+high-security 3)
+;;; (speed 2) (safety #+(and (not high-security) small) 0
+;;; #-(or high-security small) 2
+;;; #+high-security 3)
+;;; (inhibit-warnings 2))
+;;; :optimize-interface '(optimize-interface #+(and (not high-security) small)
+;;; (safety 1)
+;;; #+high-security (safety 3))
+;;; :context-declarations
+;;; '((:external (declare (optimize-interface (safety #-high-security 2 #+high-
+;;; security 3)
+;;; (debug #-high-security 1 #+high-s
+;;; ecurity 3))))
+;;; ((:or :macro (:match "$EARLY-") (:match "$BOOT-"))
+;;; (declare (optimize (speed 0))))))
+;;;
+;;; FIXME: This has mutated into a hack which crudely duplicates
+;;; functionality from the existing mechanism to load files from
+;;; stems-and-flags.lisp-expr, without being quite parallel. (E.g.
+;;; object files end up alongside the source files instead of ending
+;;; up in parallel directory trees.) Maybe we could merge the
+;;; filenames here into stems-and-flags.lisp-expr with some new flag
+;;; (perhaps :WARM) to indicate that the files should be handled not
+;;; in cold load but afterwards. Alternatively, we could call
+(dolist (stem '(
+ ;; CLOS, derived from the PCL reference implementation
+ ;;
+ ;; This PCL build order is based on a particular
+ ;; linearization of the declared build order
+ ;; dependencies from the old PCL defsys.lisp
+ ;; dependency database.
+ "src/pcl/walk"
+ "src/pcl/iterate"
+ "src/pcl/early-low"
+ "src/pcl/macros"
+ "src/pcl/low"
+ "src/pcl/fin"
+ "src/pcl/defclass"
+ "src/pcl/defs"
+ "src/pcl/fngen"
+ "src/pcl/cache"
+ "src/pcl/dlisp"
+ "src/pcl/dlisp2"
+ "src/pcl/boot"
+ "src/pcl/vector"
+ "src/pcl/slots-boot"
+ "src/pcl/combin"
+ "src/pcl/dfun"
+ "src/pcl/fast-init"
+ "src/pcl/braid"
+ "src/pcl/dlisp3"
+ "src/pcl/generic-functions"
+ "src/pcl/slots"
+ "src/pcl/init"
+ "src/pcl/std-class"
+ "src/pcl/cpl"
+ "src/pcl/fsc"
+ "src/pcl/methods"
+ "src/pcl/fixup"
+ "src/pcl/defcombin"
+ "src/pcl/ctypes"
+ "src/pcl/construct"
+ "src/pcl/env"
+ "src/pcl/documentation"
+ "src/pcl/print-object"
+ "src/pcl/precom1"
+ "src/pcl/precom2"
+ ;; functionality which depends on CLOS
+ "src/code/force-delayed-defbangmethods"
+ ;; other functionality not needed for cold init, moved
+ ;; to warm init to reduce peak memory requirement in
+ ;; cold init
+ "src/code/describe" ; FIXME: should be byte compiled
+ "src/code/inspect" ; FIXME: should be byte compiled
+ "src/code/profile"
+ "src/code/ntrace"
+ #+nil "src/code/run-program" ; not working as of 0.6.7
+ "src/code/foreign"
+ ;; Code derived from PCL's pre-ANSI DESCRIBE-OBJECT
+ ;; facility is still used in our ANSI DESCRIBE
+ ;; facility, and should be compiled and loaded after
+ ;; our DESCRIBE facility is compiled and loaded.
+ "src/pcl/describe" ; FIXME: should probably be byte compiled
+ ;; FIXME: What about Gray streams? e.g. "gray-streams.lisp"
+ ;; and "gray-streams-class.lisp"?
+ ))
+ (let ((fullname (concatenate 'string stem ".lisp")))
+ (sb-int:/show "about to compile" fullname)
+ (multiple-value-bind
+ (compiled-truename compilation-warnings-p compilation-failure-p)
+ (compile-file fullname)
+ (declare (ignore compilation-warnings-p))
+ (sb-int:/show "done compiling" fullname)
+ (cond (compilation-failure-p
+ (error "COMPILE-FILE of ~S failed." fullname))
+ (t
+ (unless (load compiled-truename)
+ (error "LOAD of ~S failed." compiled-truename))
+ (sb-int:/show "done loading" compiled-truename))))))
+\f
+;;;; setting package documentation
+
+;;; While we were running on the cross-compilation host, we tried to
+;;; be portable and not overwrite the doc strings for the standard
+;;; packages. But now the cross-compilation host is only a receding
+;;; memory, and we can have our way with the doc strings.
+(sb-int:/show "setting package documentation")
+#+sb-doc (setf (documentation (find-package "COMMON-LISP") t)
+"public: home of symbols defined by the ANSI language specification")
+#+sb-doc (setf (documentation (find-package "COMMON-LISP-USER") t)
+ "public: the default package for user code and data")
+#+sb-doc (setf (documentation (find-package "KEYWORD") t)
+ "public: home of keywords")
+
+;;; KLUDGE: It'd be nicer to do this in the table with the other
+;;; non-standard packages. -- WHN 19991206
+#+sb-doc (setf (documentation (find-package "SB-SLOT-ACCESSOR-NAME") t)
+ "private: home of CLOS slot accessor internal names")
+
+;;; FIXME: There doesn't seem to be any easy way to get package doc strings
+;;; through the cold boot process. They need to be set somewhere. Maybe the
+;;; easiest thing to do is to read them out of package-data-list.lisp-expr
+;;; now?
+\f
+;;;; restoring compilation policy to neutral values in preparation for
+;;;; SAVE-LISP-AND-DIE as final SBCL core
+
+(sb-int:/show "setting compilation policy to neutral values")
+(proclaim '(optimize (compilation-speed 1)
+ (debug 1)
+ (inhibit-warnings 1)
+ (safety 1)
+ (space 1)
+ (speed 1)))
+\f
+;;; FIXME: It would be good to unintern stuff we will no longer need
+;;; before we go on to PURIFY. E.g.
+;;; * various PCL stuff like INITIAL-CLASSES-AND-WRAPPERS; and
+;;; * *BUILT-IN-CLASSES* (which can't actually be freed by UNINTERN at
+;;; this point, since it passed through another PURIFY earlier
+;;; at cold init time).
--- /dev/null
+;;;; code to tweak compilation environment, used to set up
+;;;; for different phases of cross-compilation
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB-COLD")
+
+;;;; $Header$
+
+;;; a helper macro for WITH-ADDITIONAL-NICKNAME and WITHOUT-SOME-NICKNAME
+(defmacro with-given-nicknames ((package-designator nicknames) &body body)
+ (let ((p (gensym "P"))
+ (n (gensym "N"))
+ (o (gensym "O")))
+ `(let* ((,p ,package-designator) ; PACKAGE-DESIGNATOR, evaluated only once
+ (,n ,nicknames) ; NICKNAMES, evaluated only once
+ (,o (package-nicknames ,p))) ; old package nicknames
+ (rename-package-carefully ,p (package-name ,p) ,n)
+ (unwind-protect
+ (progn ,@body)
+ (unless (nicknames= ,n (package-nicknames ,p))
+ ;; This probably didn't happen on purpose, and it's not clear anyway
+ ;; what we should do when it did happen, so die noisily:
+ (error "package nicknames changed within WITH-GIVEN-NICKNAMES: ~
+ expected ~S, found ~S"
+ ,n
+ (package-nicknames ,p)))
+ (rename-package-carefully ,p (package-name ,p) ,o)))))
+
+;;; Execute BODY with NICKNAME added as a nickname for PACKAGE-DESIGNATOR.
+(defmacro with-additional-nickname ((package-designator nickname) &body body)
+ (let ((p (gensym "P"))
+ (n (gensym "N")))
+ `(let* ((,p ,package-designator) ; PACKAGE-DESIGNATOR, evaluated only once
+ (,n ,nickname)) ; NICKNAME, evaluated only once
+ (if (find-package ,n)
+ (error "~S is already a package name." ,n)
+ (with-given-nicknames (,p (cons ,n (package-nicknames ,p)))
+ ,@body)))))
+
+;;; Execute BODY with NICKNAME removed as a nickname for PACKAGE-DESIGNATOR.
+(defmacro without-given-nickname ((package-designator nickname) &body body)
+ (let ((p (gensym "P"))
+ (n (gensym "N"))
+ (o (gensym "O")))
+ `(let* ((,p ,package-designator) ; PACKAGE-DESIGNATOR, evaluated only once
+ (,n ,nickname) ; NICKNAME, evaluated only once
+ (,o (package-nicknames ,p))) ; old package nicknames
+ (if (find ,n ,o :test #'string=)
+ (with-given-nicknames (,p (remove ,n ,o :test #'string=))
+ ,@body)
+ (error "~S is not a nickname for ~S." ,n ,p)))))
+
+;;; a helper function for WITH-NICKNAME: Are two collections of package
+;;; nicknames the same?
+(defun nicknames= (x y)
+ (equal (sort (mapcar #'string x) #'string<)
+ (sort (mapcar #'string y) #'string<)))
+(compile 'nicknames=)
+
+;;; helper functions for WITH-ADDITIONAL-NICKNAMES and WITHOUT-GIVEN-NICKNAMES
+(defun %with-additional-nickname (package-designator nickname body-fn)
+ (with-additional-nickname (package-designator nickname)
+ (funcall body-fn)))
+(defun %without-given-nickname (package-designator nickname body-fn)
+ (without-given-nickname (package-designator nickname)
+ (funcall body-fn)))
+(defun %multi-nickname-magic (nd-list single-nn-fn body-fn)
+ (labels ((multi-nd (nd-list body-fn) ; multiple nickname descriptors
+ (if (null nd-list)
+ (funcall body-fn)
+ (single-nd (first nd-list)
+ (lambda ()
+ (multi-nd (rest nd-list) body-fn)))))
+ (single-nd (nd body-fn) ; single nickname descriptor
+ (destructuring-bind (package-descriptor nickname-list) nd
+ (multi-nn package-descriptor nickname-list body-fn)))
+ (multi-nn (nn-list package-descriptor body-fn) ; multiple nicknames
+ (if (null nn-list)
+ (funcall body-fn)
+ (funcall single-nn-fn
+ (first nn-list)
+ package-descriptor
+ (lambda ()
+ (multi-nn package-descriptor
+ (rest nn-list)
+ body-fn))))))
+ (multi-nd nd-list body-fn)))
+(compile '%with-additional-nickname)
+(compile '%without-given-nickname)
+(compile '%multi-nickname-magic)
+
+;;; Like WITH-ADDITIONAL-NICKNAME and WITHOUT-GIVEN-NICKNAMES, except
+;;; working on arbitrary lists of nickname descriptors instead of
+;;; single nickname/package pairs.
+;;;
+;;; A nickname descriptor is a list of the form
+;;; PACKAGE-DESIGNATOR NICKNAME*
+(defmacro with-additional-nicknames (nickname-descriptor-list &body body)
+ `(%multi-nickname-magic ,nickname-descriptor-list
+ #'%with-additional-nickname
+ (lambda () ,@body)))
+(defmacro without-given-nicknames (nickname-descriptor-list &body body)
+ `(%multi-nickname-magic ,nickname-descriptor-list
+ #'%without-additional-nickname
+ (lambda () ,@body)))
--- /dev/null
+;;;; transforms and other stuff used to compile ALIEN operations
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!C")
+
+(file-comment
+ "$Header$")
+\f
+;;;; DEFKNOWNs
+
+(defknown %sap-alien (system-area-pointer alien-type) alien-value
+ (flushable movable))
+(defknown alien-sap (alien-value) system-area-pointer
+ (flushable movable))
+
+(defknown slot (alien-value symbol) t
+ (flushable recursive))
+(defknown %set-slot (alien-value symbol t) t
+ (recursive))
+(defknown %slot-addr (alien-value symbol) (alien (* t))
+ (flushable movable recursive))
+
+(defknown deref (alien-value &rest index) t
+ (flushable))
+(defknown %set-deref (alien-value t &rest index) t
+ ())
+(defknown %deref-addr (alien-value &rest index) (alien (* t))
+ (flushable movable))
+
+(defknown %heap-alien (heap-alien-info) t
+ (flushable))
+(defknown %set-heap-alien (heap-alien-info t) t
+ ())
+(defknown %heap-alien-addr (heap-alien-info) (alien (* t))
+ (flushable movable))
+
+(defknown make-local-alien (local-alien-info) t
+ ())
+(defknown note-local-alien-type (local-alien-info t) null
+ ())
+(defknown local-alien (local-alien-info t) t
+ (flushable))
+(defknown %local-alien-forced-to-memory-p (local-alien-info) (member t nil)
+ (movable))
+(defknown %set-local-alien (local-alien-info t t) t
+ ())
+(defknown %local-alien-addr (local-alien-info t) (alien (* t))
+ (flushable movable))
+(defknown dispose-local-alien (local-alien-info t) t
+ ())
+
+(defknown %cast (alien-value alien-type) alien
+ (flushable movable))
+
+(defknown naturalize (t alien-type) alien
+ (flushable movable))
+(defknown deport (alien alien-type) t
+ (flushable movable))
+(defknown extract-alien-value (system-area-pointer index alien-type) t
+ (flushable))
+(defknown deposit-alien-value (system-area-pointer index alien-type t) t
+ ())
+
+(defknown alien-funcall (alien-value &rest *) *
+ (any recursive))
+(defknown %alien-funcall (system-area-pointer alien-type &rest *) *)
+\f
+;;;; cosmetic transforms
+
+(deftransform slot ((object slot)
+ ((alien (* t)) symbol))
+ '(slot (deref object) slot))
+
+(deftransform %set-slot ((object slot value)
+ ((alien (* t)) symbol t))
+ '(%set-slot (deref object) slot value))
+
+(deftransform %slot-addr ((object slot)
+ ((alien (* t)) symbol))
+ '(%slot-addr (deref object) slot))
+\f
+;;;; SLOT support
+
+(defun find-slot-offset-and-type (alien slot)
+ (unless (constant-continuation-p slot)
+ (give-up-ir1-transform
+ "The slot is not constant, so access cannot be open coded."))
+ (let ((type (continuation-type alien)))
+ (unless (alien-type-type-p type)
+ (give-up-ir1-transform))
+ (let ((alien-type (alien-type-type-alien-type type)))
+ (unless (alien-record-type-p alien-type)
+ (give-up-ir1-transform))
+ (let* ((slot-name (continuation-value slot))
+ (field (find slot-name (alien-record-type-fields alien-type)
+ :key #'alien-record-field-name)))
+ (unless field
+ (abort-ir1-transform "~S doesn't have a slot named ~S"
+ alien
+ slot-name))
+ (values (alien-record-field-offset field)
+ (alien-record-field-type field))))))
+
+#+nil ;; Shouldn't be necessary.
+(defoptimizer (slot derive-type) ((alien slot))
+ (block nil
+ (catch 'give-up-ir1-transform
+ (multiple-value-bind (slot-offset slot-type)
+ (find-slot-offset-and-type alien slot)
+ (declare (ignore slot-offset))
+ (return (make-alien-type-type slot-type))))
+ *wild-type*))
+
+(deftransform slot ((alien slot) * * :important t)
+ (multiple-value-bind (slot-offset slot-type)
+ (find-slot-offset-and-type alien slot)
+ `(extract-alien-value (alien-sap alien)
+ ,slot-offset
+ ',slot-type)))
+
+#+nil ;; ### But what about coercions?
+(defoptimizer (%set-slot derive-type) ((alien slot value))
+ (block nil
+ (catch 'give-up-ir1-transform
+ (multiple-value-bind (slot-offset slot-type)
+ (find-slot-offset-and-type alien slot)
+ (declare (ignore slot-offset))
+ (let ((type (make-alien-type-type slot-type)))
+ (assert-continuation-type value type)
+ (return type))))
+ *wild-type*))
+
+(deftransform %set-slot ((alien slot value) * * :important t)
+ (multiple-value-bind (slot-offset slot-type)
+ (find-slot-offset-and-type alien slot)
+ `(deposit-alien-value (alien-sap alien)
+ ,slot-offset
+ ',slot-type
+ value)))
+
+(defoptimizer (%slot-addr derive-type) ((alien slot))
+ (block nil
+ (catch 'give-up-ir1-transform
+ (multiple-value-bind (slot-offset slot-type)
+ (find-slot-offset-and-type alien slot)
+ (declare (ignore slot-offset))
+ (return (make-alien-type-type
+ (make-alien-pointer-type :to slot-type)))))
+ *wild-type*))
+
+(deftransform %slot-addr ((alien slot) * * :important t)
+ (multiple-value-bind (slot-offset slot-type)
+ (find-slot-offset-and-type alien slot)
+ (/noshow "in DEFTRANSFORM %SLOT-ADDR, creating %SAP-ALIEN")
+ `(%sap-alien (sap+ (alien-sap alien) (/ ,slot-offset sb!vm:byte-bits))
+ ',(make-alien-pointer-type :to slot-type))))
+\f
+;;;; DEREF support
+
+(defun find-deref-alien-type (alien)
+ (let ((alien-type (continuation-type alien)))
+ (unless (alien-type-type-p alien-type)
+ (give-up-ir1-transform))
+ (let ((alien-type (alien-type-type-alien-type alien-type)))
+ (if (alien-type-p alien-type)
+ alien-type
+ (give-up-ir1-transform)))))
+
+(defun find-deref-element-type (alien)
+ (let ((alien-type (find-deref-alien-type alien)))
+ (typecase alien-type
+ (alien-pointer-type
+ (alien-pointer-type-to alien-type))
+ (alien-array-type
+ (alien-array-type-element-type alien-type))
+ (t
+ (give-up-ir1-transform)))))
+
+(defun compute-deref-guts (alien indices)
+ (let ((alien-type (find-deref-alien-type alien)))
+ (typecase alien-type
+ (alien-pointer-type
+ (when (cdr indices)
+ (abort-ir1-transform "too many indices for pointer deref: ~D"
+ (length indices)))
+ (let ((element-type (alien-pointer-type-to alien-type)))
+ (if indices
+ (let ((bits (alien-type-bits element-type))
+ (alignment (alien-type-alignment element-type)))
+ (unless bits
+ (abort-ir1-transform "unknown element size"))
+ (unless alignment
+ (abort-ir1-transform "unknown element alignment"))
+ (values '(offset)
+ `(* offset
+ ,(align-offset bits alignment))
+ element-type))
+ (values nil 0 element-type))))
+ (alien-array-type
+ (let* ((element-type (alien-array-type-element-type alien-type))
+ (bits (alien-type-bits element-type))
+ (alignment (alien-type-alignment element-type))
+ (dims (alien-array-type-dimensions alien-type)))
+ (unless (= (length indices) (length dims))
+ (give-up-ir1-transform "incorrect number of indices"))
+ (unless bits
+ (give-up-ir1-transform "Element size is unknown."))
+ (unless alignment
+ (give-up-ir1-transform "Element alignment is unknown."))
+ (if (null dims)
+ (values nil 0 element-type)
+ (let* ((arg (gensym))
+ (args (list arg))
+ (offsetexpr arg))
+ (dolist (dim (cdr dims))
+ (let ((arg (gensym)))
+ (push arg args)
+ (setf offsetexpr `(+ (* ,offsetexpr ,dim) ,arg))))
+ (values (reverse args)
+ `(* ,offsetexpr
+ ,(align-offset bits alignment))
+ element-type)))))
+ (t
+ (abort-ir1-transform "~S not either a pointer or array type."
+ alien-type)))))
+
+#+nil ;; Shouldn't be necessary.
+(defoptimizer (deref derive-type) ((alien &rest noise))
+ (declare (ignore noise))
+ (block nil
+ (catch 'give-up-ir1-transform
+ (return (make-alien-type-type (find-deref-element-type alien))))
+ *wild-type*))
+
+(deftransform deref ((alien &rest indices) * * :important t)
+ (multiple-value-bind (indices-args offset-expr element-type)
+ (compute-deref-guts alien indices)
+ `(lambda (alien ,@indices-args)
+ (extract-alien-value (alien-sap alien)
+ ,offset-expr
+ ',element-type))))
+
+#+nil ;; ### Again, the value might be coerced.
+(defoptimizer (%set-deref derive-type) ((alien value &rest noise))
+ (declare (ignore noise))
+ (block nil
+ (catch 'give-up-ir1-transform
+ (let ((type (make-alien-type-type
+ (make-alien-pointer-type
+ :to (find-deref-element-type alien)))))
+ (assert-continuation-type value type)
+ (return type)))
+ *wild-type*))
+
+(deftransform %set-deref ((alien value &rest indices) * * :important t)
+ (multiple-value-bind (indices-args offset-expr element-type)
+ (compute-deref-guts alien indices)
+ `(lambda (alien value ,@indices-args)
+ (deposit-alien-value (alien-sap alien)
+ ,offset-expr
+ ',element-type
+ value))))
+
+(defoptimizer (%deref-addr derive-type) ((alien &rest noise))
+ (declare (ignore noise))
+ (block nil
+ (catch 'give-up-ir1-transform
+ (return (make-alien-type-type
+ (make-alien-pointer-type
+ :to (find-deref-element-type alien)))))
+ *wild-type*))
+
+(deftransform %deref-addr ((alien &rest indices) * * :important t)
+ (multiple-value-bind (indices-args offset-expr element-type)
+ (compute-deref-guts alien indices)
+ (/noshow "in DEFTRANSFORM %DEREF-ADDR, creating (LAMBDA .. %SAP-ALIEN)")
+ `(lambda (alien ,@indices-args)
+ (%sap-alien (sap+ (alien-sap alien) (/ ,offset-expr sb!vm:byte-bits))
+ ',(make-alien-pointer-type :to element-type)))))
+\f
+;;;; support for aliens on the heap
+
+(defun heap-alien-sap-and-type (info)
+ (unless (constant-continuation-p info)
+ (give-up-ir1-transform "info not constant; can't open code"))
+ (let ((info (continuation-value info)))
+ (values (heap-alien-info-sap-form info)
+ (heap-alien-info-type info))))
+
+#+nil ; shouldn't be necessary
+(defoptimizer (%heap-alien derive-type) ((info))
+ (block nil
+ (catch 'give-up
+ (multiple-value-bind (sap type) (heap-alien-sap-and-type info)
+ (declare (ignore sap))
+ (return (make-alien-type-type type))))
+ *wild-type*))
+
+(deftransform %heap-alien ((info) * * :important t)
+ (multiple-value-bind (sap type) (heap-alien-sap-and-type info)
+ `(extract-alien-value ,sap 0 ',type)))
+
+#+nil ;; ### Again, deposit value might change the type.
+(defoptimizer (%set-heap-alien derive-type) ((info value))
+ (block nil
+ (catch 'give-up-ir1-transform
+ (multiple-value-bind (sap type) (heap-alien-sap-and-type info)
+ (declare (ignore sap))
+ (let ((type (make-alien-type-type type)))
+ (assert-continuation-type value type)
+ (return type))))
+ *wild-type*))
+
+(deftransform %set-heap-alien ((info value) (heap-alien-info *) * :important t)
+ (multiple-value-bind (sap type) (heap-alien-sap-and-type info)
+ `(deposit-alien-value ,sap 0 ',type value)))
+
+(defoptimizer (%heap-alien-addr derive-type) ((info))
+ (block nil
+ (catch 'give-up-ir1-transform
+ (multiple-value-bind (sap type) (heap-alien-sap-and-type info)
+ (declare (ignore sap))
+ (return (make-alien-type-type (make-alien-pointer-type :to type)))))
+ *wild-type*))
+
+(deftransform %heap-alien-addr ((info) * * :important t)
+ (multiple-value-bind (sap type) (heap-alien-sap-and-type info)
+ (/noshow "in DEFTRANSFORM %HEAP-ALIEN-ADDR, creating %SAP-ALIEN")
+ `(%sap-alien ,sap ',type)))
+\f
+;;;; support for local (stack or register) aliens
+
+(deftransform make-local-alien ((info) * * :important t)
+ (unless (constant-continuation-p info)
+ (abort-ir1-transform "Local alien info isn't constant?"))
+ (let* ((info (continuation-value info))
+ (alien-type (local-alien-info-type info))
+ (bits (alien-type-bits alien-type)))
+ (unless bits
+ (abort-ir1-transform "unknown size: ~S" (unparse-alien-type alien-type)))
+ (/noshow "in DEFTRANSFORM MAKE-LOCAL-ALIEN" info)
+ (/noshow (local-alien-info-force-to-memory-p info))
+ (/noshow alien-type (unparse-alien-type alien-type) (alien-type-bits alien-type))
+ (if (local-alien-info-force-to-memory-p info)
+ #!+x86 `(truly-the system-area-pointer
+ (%primitive alloc-alien-stack-space
+ ,(ceiling (alien-type-bits alien-type)
+ sb!vm:byte-bits)))
+ #!-x86 `(truly-the system-area-pointer
+ (%primitive alloc-number-stack-space
+ ,(ceiling (alien-type-bits alien-type)
+ sb!vm:byte-bits)))
+ (let* ((alien-rep-type-spec (compute-alien-rep-type alien-type))
+ (alien-rep-type (specifier-type alien-rep-type-spec)))
+ (cond ((csubtypep (specifier-type 'system-area-pointer)
+ alien-rep-type)
+ '(int-sap 0))
+ ((ctypep 0 alien-rep-type) 0)
+ ((ctypep 0.0f0 alien-rep-type) 0.0f0)
+ ((ctypep 0.0d0 alien-rep-type) 0.0d0)
+ (t
+ (compiler-error
+ "Aliens of type ~S cannot be represented immediately."
+ (unparse-alien-type alien-type))))))))
+
+(deftransform note-local-alien-type ((info var) * * :important t)
+ ;; FIXME: This test and error occur about a zillion times. They
+ ;; could be factored into a function.
+ (unless (constant-continuation-p info)
+ (abort-ir1-transform "Local alien info isn't constant?"))
+ (let ((info (continuation-value info)))
+ (/noshow "in DEFTRANSFORM NOTE-LOCAL-ALIEN-TYPE" info)
+ (/noshow (local-alien-info-force-to-memory-p info))
+ (unless (local-alien-info-force-to-memory-p info)
+ (let ((var-node (continuation-use var)))
+ (/noshow var-node (ref-p var-node))
+ (when (ref-p var-node)
+ (propagate-to-refs (ref-leaf var-node)
+ (specifier-type
+ (compute-alien-rep-type
+ (local-alien-info-type info))))))))
+ 'nil)
+
+(deftransform local-alien ((info var) * * :important t)
+ (unless (constant-continuation-p info)
+ (abort-ir1-transform "Local alien info isn't constant?"))
+ (let* ((info (continuation-value info))
+ (alien-type (local-alien-info-type info)))
+ (/noshow "in DEFTRANSFORM LOCAL-ALIEN" info alien-type)
+ (/noshow (local-alien-info-force-to-memory-p info))
+ (if (local-alien-info-force-to-memory-p info)
+ `(extract-alien-value var 0 ',alien-type)
+ `(naturalize var ',alien-type))))
+
+(deftransform %local-alien-forced-to-memory-p ((info) * * :important t)
+ (unless (constant-continuation-p info)
+ (abort-ir1-transform "Local alien info isn't constant?"))
+ (let ((info (continuation-value info)))
+ (local-alien-info-force-to-memory-p info)))
+
+(deftransform %set-local-alien ((info var value) * * :important t)
+ (unless (constant-continuation-p info)
+ (abort-ir1-transform "Local alien info isn't constant?"))
+ (let* ((info (continuation-value info))
+ (alien-type (local-alien-info-type info)))
+ (if (local-alien-info-force-to-memory-p info)
+ `(deposit-alien-value var 0 ',alien-type value)
+ '(error "This should be eliminated as dead code."))))
+
+(defoptimizer (%local-alien-addr derive-type) ((info var))
+ (if (constant-continuation-p info)
+ (let* ((info (continuation-value info))
+ (alien-type (local-alien-info-type info)))
+ (make-alien-type-type (make-alien-pointer-type :to alien-type)))
+ *wild-type*))
+
+(deftransform %local-alien-addr ((info var) * * :important t)
+ (unless (constant-continuation-p info)
+ (abort-ir1-transform "Local alien info isn't constant?"))
+ (let* ((info (continuation-value info))
+ (alien-type (local-alien-info-type info)))
+ (/noshow "in DEFTRANSFORM %LOCAL-ALIEN-ADDR, creating %SAP-ALIEN")
+ (if (local-alien-info-force-to-memory-p info)
+ `(%sap-alien var ',(make-alien-pointer-type :to alien-type))
+ (error "This shouldn't happen."))))
+
+(deftransform dispose-local-alien ((info var) * * :important t)
+ (unless (constant-continuation-p info)
+ (abort-ir1-transform "Local alien info isn't constant?"))
+ (let* ((info (continuation-value info))
+ (alien-type (local-alien-info-type info)))
+ (if (local-alien-info-force-to-memory-p info)
+ #!+x86 `(%primitive dealloc-alien-stack-space
+ ,(ceiling (alien-type-bits alien-type)
+ sb!vm:byte-bits))
+ #!-x86 `(%primitive dealloc-number-stack-space
+ ,(ceiling (alien-type-bits alien-type)
+ sb!vm:byte-bits))
+ nil)))
+\f
+;;;; %CAST
+
+(defoptimizer (%cast derive-type) ((alien type))
+ (or (when (constant-continuation-p type)
+ (let ((alien-type (continuation-value type)))
+ (when (alien-type-p alien-type)
+ (make-alien-type-type alien-type))))
+ *wild-type*))
+
+(deftransform %cast ((alien target-type) * * :important t)
+ (unless (constant-continuation-p target-type)
+ (give-up-ir1-transform
+ "The alien type is not constant, so access cannot be open coded."))
+ (let ((target-type (continuation-value target-type)))
+ (cond ((or (alien-pointer-type-p target-type)
+ (alien-array-type-p target-type)
+ (alien-function-type-p target-type))
+ `(naturalize (alien-sap alien) ',target-type))
+ (t
+ (abort-ir1-transform "cannot cast to alien type ~S" target-type)))))
+\f
+;;;; ALIEN-SAP, %SAP-ALIEN, %ADDR, etc.
+
+(deftransform alien-sap ((alien) * * :important t)
+ (let ((alien-node (continuation-use alien)))
+ (typecase alien-node
+ (combination
+ (extract-function-args alien '%sap-alien 2)
+ '(lambda (sap type)
+ (declare (ignore type))
+ sap))
+ (t
+ (give-up-ir1-transform)))))
+
+(defoptimizer (%sap-alien derive-type) ((sap type))
+ (declare (ignore sap))
+ (if (constant-continuation-p type)
+ (make-alien-type-type (continuation-value type))
+ *wild-type*))
+
+(deftransform %sap-alien ((sap type) * * :important t)
+ (give-up-ir1-transform
+ "could not optimize away %SAP-ALIEN: forced to do runtime ~@
+ allocation of alien-value structure"))
+\f
+;;;; NATURALIZE/DEPORT/EXTRACT/DEPOSIT magic
+
+(flet ((%computed-lambda (compute-lambda type)
+ (declare (type function compute-lambda))
+ (unless (constant-continuation-p type)
+ (give-up-ir1-transform
+ "The type is not constant at compile time; can't open code."))
+ (handler-case
+ (let ((result (funcall compute-lambda (continuation-value type))))
+ (/noshow "in %COMPUTED-LAMBDA" (continuation-value type) result)
+ result)
+ (error (condition)
+ (compiler-error "~A" condition)))))
+ (deftransform naturalize ((object type) * * :important t)
+ (%computed-lambda #'compute-naturalize-lambda type))
+ (deftransform deport ((alien type) * * :important t)
+ (%computed-lambda #'compute-deport-lambda type))
+ (deftransform extract-alien-value ((sap offset type) * * :important t)
+ (%computed-lambda #'compute-extract-lambda type))
+ (deftransform deposit-alien-value ((sap offset type value) * * :important t)
+ (%computed-lambda #'compute-deposit-lambda type)))
+\f
+;;;; a hack to clean up divisions
+
+(defun count-low-order-zeros (thing)
+ (typecase thing
+ (continuation
+ (if (constant-continuation-p thing)
+ (count-low-order-zeros (continuation-value thing))
+ (count-low-order-zeros (continuation-use thing))))
+ (combination
+ (case (continuation-function-name (combination-fun thing))
+ ((+ -)
+ (let ((min most-positive-fixnum)
+ (itype (specifier-type 'integer)))
+ (dolist (arg (combination-args thing) min)
+ (if (csubtypep (continuation-type arg) itype)
+ (setf min (min min (count-low-order-zeros arg)))
+ (return 0)))))
+ (*
+ (let ((result 0)
+ (itype (specifier-type 'integer)))
+ (dolist (arg (combination-args thing) result)
+ (if (csubtypep (continuation-type arg) itype)
+ (setf result (+ result (count-low-order-zeros arg)))
+ (return 0)))))
+ (ash
+ (let ((args (combination-args thing)))
+ (if (= (length args) 2)
+ (let ((amount (second args)))
+ (if (constant-continuation-p amount)
+ (max (+ (count-low-order-zeros (first args))
+ (continuation-value amount))
+ 0)
+ 0))
+ 0)))
+ (t
+ 0)))
+ (integer
+ (if (zerop thing)
+ most-positive-fixnum
+ (do ((result 0 (1+ result))
+ (num thing (ash num -1)))
+ ((logbitp 0 num) result))))
+ (t
+ 0)))
+
+(deftransform / ((numerator denominator) (integer integer))
+ (unless (constant-continuation-p denominator)
+ (give-up-ir1-transform))
+ (let* ((denominator (continuation-value denominator))
+ (bits (1- (integer-length denominator))))
+ (unless (= (ash 1 bits) denominator)
+ (give-up-ir1-transform))
+ (let ((alignment (count-low-order-zeros numerator)))
+ (unless (>= alignment bits)
+ (give-up-ir1-transform))
+ `(ash numerator ,(- bits)))))
+
+(deftransform ash ((value amount))
+ (let ((value-node (continuation-use value)))
+ (unless (and (combination-p value-node)
+ (eq (continuation-function-name (combination-fun value-node))
+ 'ash))
+ (give-up-ir1-transform))
+ (let ((inside-args (combination-args value-node)))
+ (unless (= (length inside-args) 2)
+ (give-up-ir1-transform))
+ (let ((inside-amount (second inside-args)))
+ (unless (and (constant-continuation-p inside-amount)
+ (not (minusp (continuation-value inside-amount))))
+ (give-up-ir1-transform)))))
+ (extract-function-args value 'ash 2)
+ '(lambda (value amount1 amount2)
+ (ash value (+ amount1 amount2))))
+\f
+;;;; ALIEN-FUNCALL support
+
+(deftransform alien-funcall ((function &rest args)
+ ((alien (* t)) &rest *) *
+ :important t)
+ (let ((names (loop repeat (length args) collect (gensym))))
+ (/noshow "entering first DEFTRANSFORM ALIEN-FUNCALL" function args)
+ `(lambda (function ,@names)
+ (alien-funcall (deref function) ,@names))))
+
+(deftransform alien-funcall ((function &rest args) * * :important t)
+ (let ((type (continuation-type function)))
+ (unless (alien-type-type-p type)
+ (give-up-ir1-transform "can't tell function type at compile time"))
+ (/noshow "entering second DEFTRANSFORM ALIEN-FUNCALL" function)
+ (let ((alien-type (alien-type-type-alien-type type)))
+ (unless (alien-function-type-p alien-type)
+ (give-up-ir1-transform))
+ (let ((arg-types (alien-function-type-arg-types alien-type)))
+ (unless (= (length args) (length arg-types))
+ (abort-ir1-transform
+ "wrong number of arguments; expected ~D, got ~D"
+ (length arg-types)
+ (length args)))
+ (collect ((params) (deports))
+ (dolist (arg-type arg-types)
+ (let ((param (gensym)))
+ (params param)
+ (deports `(deport ,param ',arg-type))))
+ (let ((return-type (alien-function-type-result-type alien-type))
+ (body `(%alien-funcall (deport function ',alien-type)
+ ',alien-type
+ ,@(deports))))
+ (if (alien-values-type-p return-type)
+ (collect ((temps) (results))
+ (dolist (type (alien-values-type-values return-type))
+ (let ((temp (gensym)))
+ (temps temp)
+ (results `(naturalize ,temp ',type))))
+ (setf body
+ `(multiple-value-bind ,(temps) ,body
+ (values ,@(results)))))
+ (setf body `(naturalize ,body ',return-type)))
+ (/noshow "returning from DEFTRANSFORM ALIEN-FUNCALL" (params) body)
+ `(lambda (function ,@(params))
+ ,body)))))))
+
+(defoptimizer (%alien-funcall derive-type) ((function type &rest args))
+ (declare (ignore function args))
+ (unless (constant-continuation-p type)
+ (error "Something is broken."))
+ (let ((type (continuation-value type)))
+ (unless (alien-function-type-p type)
+ (error "Something is broken."))
+ (specifier-type
+ (compute-alien-rep-type
+ (alien-function-type-result-type type)))))
+
+(defoptimizer (%alien-funcall ltn-annotate)
+ ((function type &rest args) node policy)
+ (setf (basic-combination-info node) :funny)
+ (setf (node-tail-p node) nil)
+ (annotate-ordinary-continuation function policy)
+ (dolist (arg args)
+ (annotate-ordinary-continuation arg policy)))
+
+(defoptimizer (%alien-funcall ir2-convert)
+ ((function type &rest args) call block)
+ (let ((type (if (constant-continuation-p type)
+ (continuation-value type)
+ (error "Something is broken.")))
+ (cont (node-cont call))
+ (args args))
+ (multiple-value-bind (nsp stack-frame-size arg-tns result-tns)
+ (make-call-out-tns type)
+ (vop alloc-number-stack-space call block stack-frame-size nsp)
+ (dolist (tn arg-tns)
+ (let* ((arg (pop args))
+ (sc (tn-sc tn))
+ (scn (sc-number sc))
+ #!-x86 (temp-tn (make-representation-tn (tn-primitive-type tn)
+ scn))
+ (move-arg-vops (svref (sc-move-arg-vops sc) scn)))
+ (assert arg)
+ (assert (= (length move-arg-vops) 1) ()
+ "no unique move-arg-vop for moves in SC ~S"
+ (sc-name sc))
+ #!+x86 (emit-move-arg-template call
+ block
+ (first move-arg-vops)
+ (continuation-tn call block arg)
+ nsp
+ tn)
+ #!-x86 (progn
+ (emit-move call
+ block
+ (continuation-tn call block arg)
+ temp-tn)
+ (emit-move-arg-template call
+ block
+ (first move-arg-vops)
+ temp-tn
+ nsp
+ tn))))
+ (assert (null args))
+ (unless (listp result-tns)
+ (setf result-tns (list result-tns)))
+ (vop* call-out call block
+ ((continuation-tn call block function)
+ (reference-tn-list arg-tns nil))
+ ((reference-tn-list result-tns t)))
+ (vop dealloc-number-stack-space call block stack-frame-size)
+ (move-continuation-result call block result-tns cont))))
--- /dev/null
+;;;; array-specific optimizers and transforms
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!C")
+
+(file-comment
+ "$Header$")
+\f
+;;;; Derive-Type Optimizers
+
+;;; Array operations that use a specific number of indices implicitly assert
+;;; that the array is of that rank.
+(defun assert-array-rank (array rank)
+ (assert-continuation-type
+ array
+ (specifier-type `(array * ,(make-list rank :initial-element '*)))))
+
+;;; Array access functions return an object from the array, hence its
+;;; type will be asserted to be array element type.
+(defun extract-element-type (array)
+ (let ((type (continuation-type array)))
+ (if (array-type-p type)
+ (array-type-element-type type)
+ *universal-type*)))
+
+;;; Array access functions return an object from the array, hence its
+;;; type is going to be the array upgraded element type.
+(defun extract-upgraded-element-type (array)
+ (let ((type (continuation-type array)))
+ (if (array-type-p type)
+ (array-type-specialized-element-type type)
+ *universal-type*)))
+
+;;; The ``new-value'' for array setters must fit in the array, and the
+;;; return type is going to be the same as the new-value for SETF
+;;; functions.
+(defun assert-new-value-type (new-value array)
+ (let ((type (continuation-type array)))
+ (when (array-type-p type)
+ (assert-continuation-type new-value (array-type-element-type type))))
+ (continuation-type new-value))
+
+;;; Return true if Arg is NIL, or is a constant-continuation whose value is
+;;; NIL, false otherwise.
+(defun unsupplied-or-nil (arg)
+ (declare (type (or continuation null) arg))
+ (or (not arg)
+ (and (constant-continuation-p arg)
+ (not (continuation-value arg)))))
+
+(defoptimizer (array-in-bounds-p derive-type) ((array &rest indices))
+ (assert-array-rank array (length indices))
+ *universal-type*)
+
+(defoptimizer (aref derive-type) ((array &rest indices) node)
+ (assert-array-rank array (length indices))
+ ;; If the node continuation has a single use then assert its type.
+ (let ((cont (node-cont node)))
+ (when (= (length (find-uses cont)) 1)
+ (assert-continuation-type cont (extract-element-type array))))
+ (extract-upgraded-element-type array))
+
+(defoptimizer (%aset derive-type) ((array &rest stuff))
+ (assert-array-rank array (1- (length stuff)))
+ (assert-new-value-type (car (last stuff)) array))
+
+(defoptimizer (hairy-data-vector-ref derive-type) ((array index))
+ (extract-upgraded-element-type array))
+(defoptimizer (data-vector-ref derive-type) ((array index))
+ (extract-upgraded-element-type array))
+
+(defoptimizer (data-vector-set derive-type) ((array index new-value))
+ (assert-new-value-type new-value array))
+(defoptimizer (hairy-data-vector-set derive-type) ((array index new-value))
+ (assert-new-value-type new-value array))
+
+;;; Figure out the type of the data vector if we know the argument element
+;;; type.
+(defoptimizer (%with-array-data derive-type) ((array start end))
+ (let ((atype (continuation-type array)))
+ (when (array-type-p atype)
+ (values-specifier-type
+ `(values (simple-array ,(type-specifier
+ (array-type-element-type atype))
+ (*))
+ index index index)))))
+
+(defoptimizer (array-row-major-index derive-type) ((array &rest indices))
+ (assert-array-rank array (length indices))
+ *universal-type*)
+
+(defoptimizer (row-major-aref derive-type) ((array index))
+ (extract-upgraded-element-type array))
+
+(defoptimizer (%set-row-major-aref derive-type) ((array index new-value))
+ (assert-new-value-type new-value array))
+
+(defoptimizer (make-array derive-type)
+ ((dims &key initial-element element-type initial-contents
+ adjustable fill-pointer displaced-index-offset displaced-to))
+ (let ((simple (and (unsupplied-or-nil adjustable)
+ (unsupplied-or-nil displaced-to)
+ (unsupplied-or-nil fill-pointer))))
+ (specifier-type
+ `(,(if simple 'simple-array 'array)
+ ,(cond ((not element-type) 't)
+ ((constant-continuation-p element-type)
+ (continuation-value element-type))
+ (t
+ '*))
+ ,(cond ((not simple)
+ '*)
+ ((constant-continuation-p dims)
+ (let ((val (continuation-value dims)))
+ (if (listp val) val (list val))))
+ ((csubtypep (continuation-type dims)
+ (specifier-type 'integer))
+ '(*))
+ (t
+ '*))))))
+\f
+;;;; constructors
+
+;;; Convert VECTOR into a MAKE-ARRAY followed by SETFs of all the
+;;; elements.
+(def-source-transform vector (&rest elements)
+ (if (byte-compiling)
+ (values nil t)
+ (let ((len (length elements))
+ (n -1))
+ (once-only ((n-vec `(make-array ,len)))
+ `(progn
+ ,@(mapcar #'(lambda (el)
+ (once-only ((n-val el))
+ `(locally (declare (optimize (safety 0)))
+ (setf (svref ,n-vec ,(incf n))
+ ,n-val))))
+ elements)
+ ,n-vec)))))
+
+;;; Just convert it into a MAKE-ARRAY.
+(def-source-transform make-string (length &key
+ (element-type ''base-char)
+ (initial-element default-init-char))
+ (if (byte-compiling)
+ (values nil t)
+ `(make-array (the index ,length)
+ :element-type ,element-type
+ :initial-element ,initial-element)))
+
+(defparameter *array-info*
+ #((base-char #.default-init-char 8 sb!vm:simple-string-type)
+ (single-float 0.0s0 32 sb!vm:simple-array-single-float-type)
+ (double-float 0.0d0 64 sb!vm:simple-array-double-float-type)
+ #!+long-float (long-float 0.0l0 #!+x86 96 #!+sparc 128
+ sb!vm:simple-array-long-float-type)
+ (bit 0 1 sb!vm:simple-bit-vector-type)
+ ((unsigned-byte 2) 0 2 sb!vm:simple-array-unsigned-byte-2-type)
+ ((unsigned-byte 4) 0 4 sb!vm:simple-array-unsigned-byte-4-type)
+ ((unsigned-byte 8) 0 8 sb!vm:simple-array-unsigned-byte-8-type)
+ ((unsigned-byte 16) 0 16 sb!vm:simple-array-unsigned-byte-16-type)
+ ((unsigned-byte 32) 0 32 sb!vm:simple-array-unsigned-byte-32-type)
+ ((signed-byte 8) 0 8 sb!vm:simple-array-signed-byte-8-type)
+ ((signed-byte 16) 0 16 sb!vm:simple-array-signed-byte-16-type)
+ ((signed-byte 30) 0 32 sb!vm:simple-array-signed-byte-30-type)
+ ((signed-byte 32) 0 32 sb!vm:simple-array-signed-byte-32-type)
+ ((complex single-float) #C(0.0s0 0.0s0) 64
+ sb!vm:simple-array-complex-single-float-type)
+ ((complex double-float) #C(0.0d0 0.0d0) 128
+ sb!vm:simple-array-complex-double-float-type)
+ #!+long-float
+ ((complex long-float) #C(0.0l0 0.0l0) #!+x86 192 #!+sparc 256
+ sb!vm:simple-array-complex-long-float-type)
+ (t 0 32 sb!vm:simple-vector-type)))
+
+;;; The integer type restriction on the length ensures that it will be
+;;; a vector. The lack of adjustable, fill-pointer, and displaced-to
+;;; keywords ensures that it will be simple.
+(deftransform make-array ((length &key initial-element element-type)
+ (integer &rest *))
+ (let* ((eltype (cond ((not element-type) t)
+ ((not (constant-continuation-p element-type))
+ (give-up-ir1-transform
+ "ELEMENT-TYPE is not constant."))
+ (t
+ (continuation-value element-type))))
+ (len (if (constant-continuation-p length)
+ (continuation-value length)
+ '*))
+ (spec `(simple-array ,eltype (,len)))
+ (eltype-type (specifier-type eltype)))
+ (multiple-value-bind (default-initial-element element-size typecode)
+ (dovector (info *array-info*
+ (give-up-ir1-transform
+ "cannot open-code creation of ~S" spec))
+ (when (csubtypep eltype-type (specifier-type (car info)))
+ (return (values-list (cdr info)))))
+ (let* ((nwords-form
+ (if (>= element-size sb!vm:word-bits)
+ `(* length ,(/ element-size sb!vm:word-bits))
+ (let ((elements-per-word (/ 32 element-size)))
+ `(truncate (+ length
+ ,(if (eq 'sb!vm:simple-string-type typecode)
+ ;; (Simple strings are stored with an
+ ;; extra trailing null for convenience
+ ;; in calling out to C.)
+ elements-per-word
+ (1- elements-per-word)))
+ ,elements-per-word))))
+ (constructor
+ `(truly-the ,spec
+ (allocate-vector ,typecode length ,nwords-form))))
+ (values
+ (cond ((and default-initial-element
+ (or (null initial-element)
+ (and (constant-continuation-p initial-element)
+ (eql (continuation-value initial-element)
+ default-initial-element))))
+ (unless (csubtypep (ctype-of default-initial-element)
+ eltype-type)
+ ;; This situation arises e.g. in
+ ;; (MAKE-ARRAY 4 :ELEMENT-TYPE '(INTEGER 1 5))
+ ;; ANSI's definition of MAKE-ARRAY says "If
+ ;; INITIAL-ELEMENT is not supplied, the consequences
+ ;; of later reading an uninitialized element of
+ ;; new-array are undefined," so this could be legal
+ ;; code as long as the user plans to write before he
+ ;; reads, and if he doesn't we're free to do
+ ;; anything we like. But in case the user doesn't
+ ;; know to write before he reads, we'll signal a
+ ;; STYLE-WARNING in case he didn't realize this.
+ ;;
+ ;; FIXME: should be STYLE-WARNING, not note
+ (compiler-note "The default initial element ~S is not a ~S."
+ default-initial-element
+ eltype))
+ constructor)
+ (t
+ `(truly-the ,spec (fill ,constructor initial-element))))
+ '((declare (type index length))))))))
+
+;;; The list type restriction does not ensure that the result will be a
+;;; multi-dimensional array. But the lack of adjustable, fill-pointer,
+;;; and displaced-to keywords ensures that it will be simple.
+(deftransform make-array ((dims &key initial-element element-type)
+ (list &rest *))
+ (unless (or (null element-type) (constant-continuation-p element-type))
+ (give-up-ir1-transform
+ "The element-type is not constant; cannot open code array creation."))
+ (unless (constant-continuation-p dims)
+ (give-up-ir1-transform
+ "The dimension list is not constant; cannot open code array creation."))
+ (let ((dims (continuation-value dims)))
+ (unless (every #'integerp dims)
+ (give-up-ir1-transform
+ "The dimension list contains something other than an integer: ~S"
+ dims))
+ (if (= (length dims) 1)
+ `(make-array ',(car dims)
+ ,@(when initial-element
+ '(:initial-element initial-element))
+ ,@(when element-type
+ '(:element-type element-type)))
+ (let* ((total-size (reduce #'* dims))
+ (rank (length dims))
+ (spec `(simple-array
+ ,(cond ((null element-type) t)
+ ((constant-continuation-p element-type)
+ (continuation-value element-type))
+ (t '*))
+ ,(make-list rank :initial-element '*))))
+ `(let ((header (make-array-header sb!vm:simple-array-type ,rank)))
+ (setf (%array-fill-pointer header) ,total-size)
+ (setf (%array-fill-pointer-p header) nil)
+ (setf (%array-available-elements header) ,total-size)
+ (setf (%array-data-vector header)
+ (make-array ,total-size
+ ,@(when element-type
+ '(:element-type element-type))
+ ,@(when initial-element
+ '(:initial-element initial-element))))
+ (setf (%array-displaced-p header) nil)
+ ,@(let ((axis -1))
+ (mapcar #'(lambda (dim)
+ `(setf (%array-dimension header ,(incf axis))
+ ,dim))
+ dims))
+ (truly-the ,spec header))))))
+\f
+;;;; miscellaneous properties of arrays
+
+;;; Transforms for various array properties. If the property is know
+;;; at compile time because of a type spec, use that constant value.
+
+;;; If we can tell the rank from the type info, use it instead.
+(deftransform array-rank ((array))
+ (let ((array-type (continuation-type array)))
+ (unless (array-type-p array-type)
+ (give-up-ir1-transform))
+ (let ((dims (array-type-dimensions array-type)))
+ (if (not (listp dims))
+ (give-up-ir1-transform
+ "The array rank is not known at compile time: ~S"
+ dims)
+ (length dims)))))
+
+;;; If we know the dimensions at compile time, just use it. Otherwise,
+;;; if we can tell that the axis is in bounds, convert to
+;;; %ARRAY-DIMENSION (which just indirects the array header) or length
+;;; (if it's simple and a vector).
+(deftransform array-dimension ((array axis)
+ (array index))
+ (unless (constant-continuation-p axis)
+ (give-up-ir1-transform "The axis is not constant."))
+ (let ((array-type (continuation-type array))
+ (axis (continuation-value axis)))
+ (unless (array-type-p array-type)
+ (give-up-ir1-transform))
+ (let ((dims (array-type-dimensions array-type)))
+ (unless (listp dims)
+ (give-up-ir1-transform
+ "The array dimensions are unknown; must call ARRAY-DIMENSION at runtime."))
+ (unless (> (length dims) axis)
+ (abort-ir1-transform "The array has dimensions ~S, ~D is too large."
+ dims
+ axis))
+ (let ((dim (nth axis dims)))
+ (cond ((integerp dim)
+ dim)
+ ((= (length dims) 1)
+ (ecase (array-type-complexp array-type)
+ ((t)
+ '(%array-dimension array 0))
+ ((nil)
+ '(length array))
+ ((:maybe)
+ (give-up-ir1-transform
+ "can't tell whether array is simple"))))
+ (t
+ '(%array-dimension array axis)))))))
+
+;;; If the length has been declared and it's simple, just return it.
+(deftransform length ((vector)
+ ((simple-array * (*))))
+ (let ((type (continuation-type vector)))
+ (unless (array-type-p type)
+ (give-up-ir1-transform))
+ (let ((dims (array-type-dimensions type)))
+ (unless (and (listp dims) (integerp (car dims)))
+ (give-up-ir1-transform
+ "Vector length is unknown, must call LENGTH at runtime."))
+ (car dims))))
+
+;;; All vectors can get their length by using VECTOR-LENGTH. If it's
+;;; simple, it will extract the length slot from the vector. It it's
+;;; complex, it will extract the fill pointer slot from the array
+;;; header.
+(deftransform length ((vector) (vector))
+ '(vector-length vector))
+
+;;; If a simple array with known dimensions, then VECTOR-LENGTH is a
+;;; compile-time constant.
+(deftransform vector-length ((vector) ((simple-array * (*))))
+ (let ((vtype (continuation-type vector)))
+ (if (array-type-p vtype)
+ (let ((dim (first (array-type-dimensions vtype))))
+ (when (eq dim '*) (give-up-ir1-transform))
+ dim)
+ (give-up-ir1-transform))))
+
+;;; Again, if we can tell the results from the type, just use it.
+;;; Otherwise, if we know the rank, convert into a computation based
+;;; on array-dimension. We can wrap a TRULY-THE INDEX around the
+;;; multiplications because we know that the total size must be an
+;;; INDEX.
+(deftransform array-total-size ((array)
+ (array))
+ (let ((array-type (continuation-type array)))
+ (unless (array-type-p array-type)
+ (give-up-ir1-transform))
+ (let ((dims (array-type-dimensions array-type)))
+ (unless (listp dims)
+ (give-up-ir1-transform "can't tell the rank at compile time"))
+ (if (member '* dims)
+ (do ((form 1 `(truly-the index
+ (* (array-dimension array ,i) ,form)))
+ (i 0 (1+ i)))
+ ((= i (length dims)) form))
+ (reduce #'* dims)))))
+
+;;; Only complex vectors have fill pointers.
+(deftransform array-has-fill-pointer-p ((array))
+ (let ((array-type (continuation-type array)))
+ (unless (array-type-p array-type)
+ (give-up-ir1-transform))
+ (let ((dims (array-type-dimensions array-type)))
+ (if (and (listp dims) (not (= (length dims) 1)))
+ nil
+ (ecase (array-type-complexp array-type)
+ ((t)
+ t)
+ ((nil)
+ nil)
+ ((:maybe)
+ (give-up-ir1-transform
+ "The array type is ambiguous; must call ~
+ array-has-fill-pointer-p at runtime.")))))))
+
+;;; Primitive used to verify indices into arrays. If we can tell at
+;;; compile-time or we are generating unsafe code, don't bother with
+;;; the VOP.
+(deftransform %check-bound ((array dimension index))
+ (unless (constant-continuation-p dimension)
+ (give-up-ir1-transform))
+ (let ((dim (continuation-value dimension)))
+ `(the (integer 0 ,dim) index)))
+(deftransform %check-bound ((array dimension index) * *
+ :policy (and (> speed safety) (= safety 0)))
+ 'index)
+\f
+;;;; array accessors
+
+;;; SVREF, %SVSET, SCHAR, %SCHARSET, CHAR,
+;;; %CHARSET, SBIT, %SBITSET, BIT, %BITSET
+;;; -- source transforms.
+;;;
+;;; We convert all typed array accessors into aref and %aset with type
+;;; assertions on the array.
+(macrolet ((define-frob (reffer setter type)
+ `(progn
+ (def-source-transform ,reffer (a &rest i)
+ (if (byte-compiling)
+ (values nil t)
+ `(aref (the ,',type ,a) ,@i)))
+ (def-source-transform ,setter (a &rest i)
+ (if (byte-compiling)
+ (values nil t)
+ `(%aset (the ,',type ,a) ,@i))))))
+ (define-frob svref %svset simple-vector)
+ (define-frob schar %scharset simple-string)
+ (define-frob char %charset string)
+ (define-frob sbit %sbitset (simple-array bit))
+ (define-frob bit %bitset (array bit)))
+
+(macrolet (;; This is a handy macro for computing the row-major index
+ ;; given a set of indices. We wrap each index with a call
+ ;; to %CHECK-BOUND to ensure that everything works out
+ ;; correctly. We can wrap all the interior arithmetic with
+ ;; TRULY-THE INDEX because we know the the resultant
+ ;; row-major index must be an index.
+ (with-row-major-index ((array indices index &optional new-value)
+ &rest body)
+ `(let (n-indices dims)
+ (dotimes (i (length ,indices))
+ (push (make-symbol (format nil "INDEX-~D" i)) n-indices)
+ (push (make-symbol (format nil "DIM-~D" i)) dims))
+ (setf n-indices (nreverse n-indices))
+ (setf dims (nreverse dims))
+ `(lambda (,',array ,@n-indices
+ ,@',(when new-value (list new-value)))
+ (let* (,@(let ((,index -1))
+ (mapcar #'(lambda (name)
+ `(,name (array-dimension
+ ,',array
+ ,(incf ,index))))
+ dims))
+ (,',index
+ ,(if (null dims)
+ 0
+ (do* ((dims dims (cdr dims))
+ (indices n-indices (cdr indices))
+ (last-dim nil (car dims))
+ (form `(%check-bound ,',array
+ ,(car dims)
+ ,(car indices))
+ `(truly-the
+ index
+ (+ (truly-the index
+ (* ,form
+ ,last-dim))
+ (%check-bound
+ ,',array
+ ,(car dims)
+ ,(car indices))))))
+ ((null (cdr dims)) form)))))
+ ,',@body)))))
+
+ ;; Just return the index after computing it.
+ (deftransform array-row-major-index ((array &rest indices))
+ (with-row-major-index (array indices index)
+ index))
+
+ ;; Convert AREF and %ASET into a HAIRY-DATA-VECTOR-REF (or
+ ;; HAIRY-DATA-VECTOR-SET) with the set of indices replaced with the an
+ ;; expression for the row major index.
+ (deftransform aref ((array &rest indices))
+ (with-row-major-index (array indices index)
+ (hairy-data-vector-ref array index)))
+ (deftransform %aset ((array &rest stuff))
+ (let ((indices (butlast stuff)))
+ (with-row-major-index (array indices index new-value)
+ (hairy-data-vector-set array index new-value)))))
+
+;;; Just convert into a HAIRY-DATA-VECTOR-REF (or
+;;; HAIRY-DATA-VECTOR-SET) after checking that the index is inside the
+;;; array total size.
+(deftransform row-major-aref ((array index))
+ `(hairy-data-vector-ref array
+ (%check-bound array (array-total-size array) index)))
+(deftransform %set-row-major-aref ((array index new-value))
+ `(hairy-data-vector-set array
+ (%check-bound array (array-total-size array) index)
+ new-value))
+\f
+;;;; bit-vector array operation canonicalization
+;;;;
+;;;; We convert all bit-vector operations to have the result array
+;;;; specified. This allows any result allocation to be open-coded,
+;;;; and eliminates the need for any VM-dependent transforms to handle
+;;;; these cases.
+
+(dolist (fun '(bit-and bit-ior bit-xor bit-eqv bit-nand bit-nor bit-andc1
+ bit-andc2 bit-orc1 bit-orc2))
+ ;; Make a result array if result is NIL or unsupplied.
+ (deftransform fun ((bit-array-1 bit-array-2 &optional result-bit-array)
+ '(bit-vector bit-vector &optional null) '*
+ :eval-name t
+ :policy (>= speed space))
+ `(,fun bit-array-1 bit-array-2
+ (make-array (length bit-array-1) :element-type 'bit)))
+ ;; If result is T, make it the first arg.
+ (deftransform fun ((bit-array-1 bit-array-2 result-bit-array)
+ '(bit-vector bit-vector (member t)) '*
+ :eval-name t)
+ `(,fun bit-array-1 bit-array-2 bit-array-1)))
+
+;;; Similar for BIT-NOT, but there is only one arg...
+(deftransform bit-not ((bit-array-1 &optional result-bit-array)
+ (bit-vector &optional null) *
+ :policy (>= speed space))
+ '(bit-not bit-array-1
+ (make-array (length bit-array-1) :element-type 'bit)))
+(deftransform bit-not ((bit-array-1 result-bit-array)
+ (bit-vector (constant-argument t)))
+ '(bit-not bit-array-1 bit-array-1))
+;;; FIXME: What does (CONSTANT-ARGUMENT T) mean? Is it the same thing
+;;; as (CONSTANT-ARGUMENT (MEMBER T)), or does it mean any constant
+;;; value?
+\f
+;;; Pick off some constant cases.
+(deftransform array-header-p ((array) (array))
+ (let ((type (continuation-type array)))
+ (declare (optimize (safety 3)))
+ (unless (array-type-p type)
+ (give-up-ir1-transform))
+ (let ((dims (array-type-dimensions type)))
+ (cond ((csubtypep type (specifier-type '(simple-array * (*))))
+ ;; No array header.
+ nil)
+ ((and (listp dims) (> (length dims) 1))
+ ;; Multi-dimensional array, will have a header.
+ t)
+ (t
+ (give-up-ir1-transform))))))
--- /dev/null
+;;;; scheduling assembler
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!ASSEM")
+
+(sb!int:file-comment
+ "$Header$")
+\f
+;;;; assembly control parameters
+
+(defvar *assem-scheduler-p* nil)
+(declaim (type boolean *assem-scheduler-p*))
+
+(defvar *assem-instructions* (make-hash-table :test 'equal))
+(declaim (type hash-table *assem-instructions*))
+
+(defvar *assem-max-locations* 0)
+(declaim (type index *assem-max-locations*))
+\f
+;;;; the SEGMENT structure
+
+;;; This structure holds the state of the assembler.
+(defstruct segment
+ ;; the name of this segment (for debugging output and stuff)
+ (name "Unnamed" :type simple-base-string)
+ ;; Ordinarily this is a vector where instructions are written. If the segment
+ ;; is made invalid (e.g. by APPEND-SEGMENT) then the vector can be
+ ;; replaced by NIL.
+ (buffer (make-array 0
+ :fill-pointer 0
+ :adjustable t
+ :element-type 'assembly-unit)
+ :type (or null (vector assembly-unit)))
+ ;; whether or not to run the scheduler. Note: if the instruction definitions
+ ;; were not compiled with the scheduler turned on, this has no effect.
+ (run-scheduler nil)
+ ;; If a function, then this is funcalled for each inst emitted with the
+ ;; segment, the VOP, the name of the inst (as a string), and the inst
+ ;; arguments.
+ (inst-hook nil :type (or function null))
+ ;; what position does this correspond to? Initially, positions and indexes
+ ;; are the same, but after we start collapsing choosers, positions can change
+ ;; while indexes stay the same.
+ (current-posn 0 :type posn)
+ ;; a list of all the annotations that have been output to this segment
+ (annotations nil :type list)
+ ;; a pointer to the last cons cell in the annotations list. This is
+ ;; so we can quickly add things to the end of the annotations list.
+ (last-annotation nil :type list)
+ ;; the number of bits of alignment at the last time we synchronized
+ (alignment max-alignment :type alignment)
+ ;; the position the last time we synchronized
+ (sync-posn 0 :type posn)
+ ;; The posn and index everything ends at. This is not maintained while the
+ ;; data is being generated, but is filled in after. Basically, we copy
+ ;; current-posn and current-index so that we can trash them while processing
+ ;; choosers and back-patches.
+ (final-posn 0 :type posn)
+ (final-index 0 :type index)
+ ;; *** State used by the scheduler during instruction queueing.
+ ;;
+ ;; a list of postits. These are accumulated between instructions.
+ (postits nil :type list)
+ ;; ``Number'' for last instruction queued. Used only to supply insts
+ ;; with unique sset-element-number's.
+ (inst-number 0 :type index)
+ ;; SIMPLE-VECTORs mapping locations to the instruction that reads them and
+ ;; instructions that write them
+ (readers (make-array *assem-max-locations* :initial-element nil)
+ :type simple-vector)
+ (writers (make-array *assem-max-locations* :initial-element nil)
+ :type simple-vector)
+ ;; The number of additional cycles before the next control transfer, or NIL
+ ;; if a control transfer hasn't been queued. When a delayed branch is
+ ;; queued, this slot is set to the delay count.
+ (branch-countdown nil :type (or null (and fixnum unsigned-byte)))
+ ;; *** These two slots are used both by the queuing noise and the
+ ;; scheduling noise.
+ ;;
+ ;; All the instructions that are pending and don't have any unresolved
+ ;; dependents. We don't list branches here even if they would otherwise
+ ;; qualify. They are listed above.
+ (emittable-insts-sset (make-sset) :type sset)
+ ;; list of queued branches. We handle these specially, because they have to
+ ;; be emitted at a specific place (e.g. one slot before the end of the
+ ;; block).
+ (queued-branches nil :type list)
+ ;; *** state used by the scheduler during instruction scheduling.
+ ;;
+ ;; the instructions who would have had a read dependent removed if it were
+ ;; not for a delay slot. This is a list of lists. Each element in the
+ ;; top level list corresponds to yet another cycle of delay. Each element
+ ;; in the second level lists is a dotted pair, holding the dependency
+ ;; instruction and the dependent to remove.
+ (delayed nil :type list)
+ ;; The emittable insts again, except this time as a list sorted by depth.
+ (emittable-insts-queue nil :type list)
+ ;; Whether or not to collect dynamic statistics. This is just the same as
+ ;; *COLLECT-DYNAMIC-STATISTICS* but is faster to reference.
+ #!+sb-dyncount
+ (collect-dynamic-statistics nil))
+(sb!c::defprinter (segment)
+ name)
+
+;;; where the next byte of output goes
+#!-sb-fluid (declaim (inline segment-current-index))
+(defun segment-current-index (segment)
+ (fill-pointer (segment-buffer segment)))
+(defun (setf segment-current-index) (new-value segment)
+ (let ((buffer (segment-buffer segment)))
+ ;; Make sure that the array is big enough.
+ (do ()
+ ((>= (array-dimension buffer 0) new-value))
+ ;; When we have to increase the size of the array, we want to roughly
+ ;; double the vector length: that way growing the array to size N conses
+ ;; only O(N) bytes in total. But just doubling the length would leave a
+ ;; zero-length vector unchanged. Hence, take the MAX with 1..
+ (adjust-array buffer (max 1 (* 2 (array-dimension buffer 0)))))
+ ;; Now that the array has the intended next free byte, we can point to it.
+ (setf (fill-pointer buffer) new-value)))
+\f
+;;;; structures/types used by the scheduler
+
+(sb!c:def-boolean-attribute instruction
+ ;; This attribute is set if the scheduler can freely flush this instruction
+ ;; if it thinks it is not needed. Examples are NOP and instructions that
+ ;; have no side effect not described by the writes.
+ flushable
+ ;; This attribute is set when an instruction can cause a control transfer.
+ ;; For test instructions, the delay is used to determine how many
+ ;; instructions follow the branch.
+ branch
+ ;; This attribute indicates that this ``instruction'' can be variable length,
+ ;; and therefore better never be used in a branch delay slot.
+ variable-length)
+
+(defstruct (instruction
+ (:include sset-element)
+ (:conc-name inst-)
+ (:constructor make-instruction (number emitter attributes delay)))
+ ;; The function to envoke to actually emit this instruction. Gets called
+ ;; with the segment as its one argument.
+ (emitter (required-argument) :type (or null function))
+ ;; The attributes of this instruction.
+ (attributes (instruction-attributes) :type sb!c:attributes)
+ ;; Number of instructions or cycles of delay before additional instructions
+ ;; can read our writes.
+ (delay 0 :type (and fixnum unsigned-byte))
+ ;; the maximum number of instructions in the longest dependency chain from
+ ;; this instruction to one of the independent instructions. This is used
+ ;; as a heuristic at to which instructions should be scheduled first.
+ (depth nil :type (or null (and fixnum unsigned-byte)))
+ ;; ** When trying remember which of the next four is which, note that the
+ ;; ``read'' or ``write'' always refers to the dependent (second)
+ ;; instruction.
+ ;;
+ ;; instructions whose writes this instruction tries to read
+ (read-dependencies (make-sset) :type sset)
+ ;; instructions whose writes or reads are overwritten by this instruction
+ (write-dependencies (make-sset) :type sset)
+ ;; instructions which write what we read or write
+ (write-dependents (make-sset) :type sset)
+ ;; instructions which read what we write
+ (read-dependents (make-sset) :type sset))
+#!+sb-show-assem (defvar *inst-ids* (make-hash-table :test 'eq))
+#!+sb-show-assem (defvar *next-inst-id* 0)
+(sb!int:def!method print-object ((inst instruction) stream)
+ (print-unreadable-object (inst stream :type t :identity t)
+ #!+sb-show-assem
+ (princ (or (gethash inst *inst-ids*)
+ (setf (gethash inst *inst-ids*)
+ (incf *next-inst-id*)))
+ stream)
+ (format stream
+ #!+sb-show-assem " emitter=~S" #!-sb-show-assem "emitter=~S"
+ (let ((emitter (inst-emitter inst)))
+ (if emitter
+ (multiple-value-bind (lambda lexenv-p name)
+ (function-lambda-expression emitter)
+ (declare (ignore lambda lexenv-p))
+ name)
+ '<flushed>)))
+ (when (inst-depth inst)
+ (format stream ", depth=~D" (inst-depth inst)))))
+
+#!+sb-show-assem
+(defun reset-inst-ids ()
+ (clrhash *inst-ids*)
+ (setf *next-inst-id* 0))
+\f
+;;;; the scheduler itself
+
+(defmacro without-scheduling ((&optional (segment '**current-segment**))
+ &body body)
+ #!+sb-doc
+ "Execute BODY (as a PROGN) without scheduling any of the instructions
+ generated inside it. This is not protected by UNWIND-PROTECT, so
+ DO NOT use THROW or RETURN-FROM to escape from it."
+ ;; FIXME: Why not just use UNWIND-PROTECT? Or is there some other
+ ;; reason why we shouldn't use THROW or RETURN-FROM?
+ (let ((var (gensym))
+ (seg (gensym)))
+ `(let* ((,seg ,segment)
+ (,var (segment-run-scheduler ,seg)))
+ (when ,var
+ (schedule-pending-instructions ,seg)
+ (setf (segment-run-scheduler ,seg) nil))
+ ,@body
+ (setf (segment-run-scheduler ,seg) ,var))))
+
+(defmacro note-dependencies ((segment inst) &body body)
+ (sb!int:once-only ((segment segment) (inst inst))
+ `(macrolet ((reads (loc) `(note-read-dependency ,',segment ,',inst ,loc))
+ (writes (loc &rest keys)
+ `(note-write-dependency ,',segment ,',inst ,loc ,@keys)))
+ ,@body)))
+
+(defun note-read-dependency (segment inst read)
+ (multiple-value-bind (loc-num size)
+ (sb!c:location-number read)
+ #!+sb-show-assem (format *trace-output*
+ "~&~S reads ~S[~D for ~D]~%"
+ inst read loc-num size)
+ (when loc-num
+ ;; Iterate over all the locations for this TN.
+ (do ((index loc-num (1+ index))
+ (end-loc (+ loc-num (or size 1))))
+ ((>= index end-loc))
+ (declare (type (mod 2048) index end-loc))
+ (let ((writers (svref (segment-writers segment) index)))
+ (when writers
+ ;; The inst that wrote the value we want to read must have
+ ;; completed.
+ (let ((writer (car writers)))
+ (sset-adjoin writer (inst-read-dependencies inst))
+ (sset-adjoin inst (inst-read-dependents writer))
+ (sset-delete writer (segment-emittable-insts-sset segment))
+ ;; And it must have been completed *after* all other
+ ;; writes to that location. Actually, that isn't quite
+ ;; true. Each of the earlier writes could be done
+ ;; either before this last write, or after the read, but
+ ;; we have no way of representing that.
+ (dolist (other-writer (cdr writers))
+ (sset-adjoin other-writer (inst-write-dependencies writer))
+ (sset-adjoin writer (inst-write-dependents other-writer))
+ (sset-delete other-writer
+ (segment-emittable-insts-sset segment))))
+ ;; And we don't need to remember about earlier writes any
+ ;; more. Shortening the writers list means that we won't
+ ;; bother generating as many explicit arcs in the graph.
+ (setf (cdr writers) nil)))
+ (push inst (svref (segment-readers segment) index)))))
+ (values))
+
+(defun note-write-dependency (segment inst write &key partially)
+ (multiple-value-bind (loc-num size)
+ (sb!c:location-number write)
+ #!+sb-show-assem (format *trace-output*
+ "~&~S writes ~S[~D for ~D]~%"
+ inst write loc-num size)
+ (when loc-num
+ ;; Iterate over all the locations for this TN.
+ (do ((index loc-num (1+ index))
+ (end-loc (+ loc-num (or size 1))))
+ ((>= index end-loc))
+ (declare (type (mod 2048) index end-loc))
+ ;; All previous reads of this location must have completed.
+ (dolist (prev-inst (svref (segment-readers segment) index))
+ (unless (eq prev-inst inst)
+ (sset-adjoin prev-inst (inst-write-dependencies inst))
+ (sset-adjoin inst (inst-write-dependents prev-inst))
+ (sset-delete prev-inst (segment-emittable-insts-sset segment))))
+ (when partially
+ ;; All previous writes to the location must have completed.
+ (dolist (prev-inst (svref (segment-writers segment) index))
+ (sset-adjoin prev-inst (inst-write-dependencies inst))
+ (sset-adjoin inst (inst-write-dependents prev-inst))
+ (sset-delete prev-inst (segment-emittable-insts-sset segment)))
+ ;; And we can forget about remembering them, because
+ ;; depending on us is as good as depending on them.
+ (setf (svref (segment-writers segment) index) nil))
+ (push inst (svref (segment-writers segment) index)))))
+ (values))
+
+;;; This routine is called by due to uses of the INST macro when the scheduler
+;;; is turned on. The change to the dependency graph has already been computed,
+;;; so we just have to check to see whether the basic block is terminated.
+(defun queue-inst (segment inst)
+ #!+sb-show-assem (format *trace-output* "~&queuing ~S~%" inst)
+ #!+sb-show-assem (format *trace-output*
+ " reads ~S~% writes ~S~%"
+ (sb!int:collect ((reads))
+ (do-sset-elements (read
+ (inst-read-dependencies inst))
+ (reads read))
+ (reads))
+ (sb!int:collect ((writes))
+ (do-sset-elements (write
+ (inst-write-dependencies inst))
+ (writes write))
+ (writes)))
+ (assert (segment-run-scheduler segment))
+ (let ((countdown (segment-branch-countdown segment)))
+ (when countdown
+ (decf countdown)
+ (assert (not (instruction-attributep (inst-attributes inst)
+ variable-length))))
+ (cond ((instruction-attributep (inst-attributes inst) branch)
+ (unless countdown
+ (setf countdown (inst-delay inst)))
+ (push (cons countdown inst)
+ (segment-queued-branches segment)))
+ (t
+ (sset-adjoin inst (segment-emittable-insts-sset segment))))
+ (when countdown
+ (setf (segment-branch-countdown segment) countdown)
+ (when (zerop countdown)
+ (schedule-pending-instructions segment))))
+ (values))
+
+;;; Emit all the pending instructions, and reset any state. This is called
+;;; whenever we hit a label (i.e. an entry point of some kind) and when the
+;;; user turns the scheduler off (otherwise, the queued instructions would
+;;; sit there until the scheduler was turned back on, and emitted in the
+;;; wrong place).
+(defun schedule-pending-instructions (segment)
+ (assert (segment-run-scheduler segment))
+
+ ;; Quick blow-out if nothing to do.
+ (when (and (sset-empty (segment-emittable-insts-sset segment))
+ (null (segment-queued-branches segment)))
+ (return-from schedule-pending-instructions
+ (values)))
+
+ #!+sb-show-assem (format *trace-output*
+ "~&scheduling pending instructions..~%")
+
+ ;; Note that any values live at the end of the block have to be computed
+ ;; last.
+ (let ((emittable-insts (segment-emittable-insts-sset segment))
+ (writers (segment-writers segment)))
+ (dotimes (index (length writers))
+ (let* ((writer (svref writers index))
+ (inst (car writer))
+ (overwritten (cdr writer)))
+ (when writer
+ (when overwritten
+ (let ((write-dependencies (inst-write-dependencies inst)))
+ (dolist (other-inst overwritten)
+ (sset-adjoin inst (inst-write-dependents other-inst))
+ (sset-adjoin other-inst write-dependencies)
+ (sset-delete other-inst emittable-insts))))
+ ;; If the value is live at the end of the block, we can't flush it.
+ (setf (instruction-attributep (inst-attributes inst) flushable)
+ nil)))))
+
+ ;; Grovel through the entire graph in the forward direction finding all
+ ;; the leaf instructions.
+ (labels ((grovel-inst (inst)
+ (let ((max 0))
+ (do-sset-elements (dep (inst-write-dependencies inst))
+ (let ((dep-depth (or (inst-depth dep) (grovel-inst dep))))
+ (when (> dep-depth max)
+ (setf max dep-depth))))
+ (do-sset-elements (dep (inst-read-dependencies inst))
+ (let ((dep-depth
+ (+ (or (inst-depth dep) (grovel-inst dep))
+ (inst-delay dep))))
+ (when (> dep-depth max)
+ (setf max dep-depth))))
+ (cond ((and (sset-empty (inst-read-dependents inst))
+ (instruction-attributep (inst-attributes inst)
+ flushable))
+ #!+sb-show-assem (format *trace-output*
+ "flushing ~S~%"
+ inst)
+ (setf (inst-emitter inst) nil)
+ (setf (inst-depth inst) max))
+ (t
+ (setf (inst-depth inst) max))))))
+ (let ((emittable-insts nil)
+ (delayed nil))
+ (do-sset-elements (inst (segment-emittable-insts-sset segment))
+ (grovel-inst inst)
+ (if (zerop (inst-delay inst))
+ (push inst emittable-insts)
+ (setf delayed
+ (add-to-nth-list delayed inst (1- (inst-delay inst))))))
+ (setf (segment-emittable-insts-queue segment)
+ (sort emittable-insts #'> :key #'inst-depth))
+ (setf (segment-delayed segment) delayed))
+ (dolist (branch (segment-queued-branches segment))
+ (grovel-inst (cdr branch))))
+ #!+sb-show-assem (format *trace-output*
+ "queued branches: ~S~%"
+ (segment-queued-branches segment))
+ #!+sb-show-assem (format *trace-output*
+ "initially emittable: ~S~%"
+ (segment-emittable-insts-queue segment))
+ #!+sb-show-assem (format *trace-output*
+ "initially delayed: ~S~%"
+ (segment-delayed segment))
+
+ ;; Accumulate the results in reverse order. Well, actually, this list will
+ ;; be in forward order, because we are generating the reverse order in
+ ;; reverse.
+ (let ((results nil))
+
+ ;; Schedule all the branches in their exact locations.
+ (let ((insts-from-end (segment-branch-countdown segment)))
+ (dolist (branch (segment-queued-branches segment))
+ (let ((inst (cdr branch)))
+ (dotimes (i (- (car branch) insts-from-end))
+ ;; Each time through this loop we need to emit another instruction.
+ ;; First, we check to see whether there is any instruction that
+ ;; must be emitted before (i.e. must come after) the branch inst.
+ ;; If so, emit it. Otherwise, just pick one of the emittable
+ ;; insts. If there is nothing to do, then emit a nop.
+ ;; ### Note: despite the fact that this is a loop, it really won't
+ ;; work for repetitions other then zero and one. For example, if
+ ;; the branch has two dependents and one of them dpends on the
+ ;; other, then the stuff that grabs a dependent could easily
+ ;; grab the wrong one. But I don't feel like fixing this because
+ ;; it doesn't matter for any of the architectures we are using
+ ;; or plan on using.
+ (flet ((maybe-schedule-dependent (dependents)
+ (do-sset-elements (inst dependents)
+ ;; If do-sset-elements enters the body, then there is a
+ ;; dependent. Emit it.
+ (note-resolved-dependencies segment inst)
+ ;; Remove it from the emittable insts.
+ (setf (segment-emittable-insts-queue segment)
+ (delete inst
+ (segment-emittable-insts-queue segment)
+ :test #'eq))
+ ;; And if it was delayed, removed it from the delayed
+ ;; list. This can happen if there is a load in a
+ ;; branch delay slot.
+ (block scan-delayed
+ (do ((delayed (segment-delayed segment)
+ (cdr delayed)))
+ ((null delayed))
+ (do ((prev nil cons)
+ (cons (car delayed) (cdr cons)))
+ ((null cons))
+ (when (eq (car cons) inst)
+ (if prev
+ (setf (cdr prev) (cdr cons))
+ (setf (car delayed) (cdr cons)))
+ (return-from scan-delayed nil)))))
+ ;; And return it.
+ (return inst))))
+ (let ((fill (or (maybe-schedule-dependent
+ (inst-read-dependents inst))
+ (maybe-schedule-dependent
+ (inst-write-dependents inst))
+ (schedule-one-inst segment t)
+ :nop)))
+ #!+sb-show-assem (format *trace-output*
+ "filling branch delay slot with ~S~%"
+ fill)
+ (push fill results)))
+ (advance-one-inst segment)
+ (incf insts-from-end))
+ (note-resolved-dependencies segment inst)
+ (push inst results)
+ #!+sb-show-assem (format *trace-output* "emitting ~S~%" inst)
+ (advance-one-inst segment))))
+
+ ;; Keep scheduling stuff until we run out.
+ (loop
+ (let ((inst (schedule-one-inst segment nil)))
+ (unless inst
+ (return))
+ (push inst results)
+ (advance-one-inst segment)))
+
+ ;; Now call the emitters, but turn the scheduler off for the duration.
+ (setf (segment-run-scheduler segment) nil)
+ (dolist (inst results)
+ (if (eq inst :nop)
+ (sb!c:emit-nop segment)
+ (funcall (inst-emitter inst) segment)))
+ (setf (segment-run-scheduler segment) t))
+
+ ;; Clear out any residue left over.
+ (setf (segment-inst-number segment) 0)
+ (setf (segment-queued-branches segment) nil)
+ (setf (segment-branch-countdown segment) nil)
+ (setf (segment-emittable-insts-sset segment) (make-sset))
+ (fill (segment-readers segment) nil)
+ (fill (segment-writers segment) nil)
+
+ ;; That's all, folks.
+ (values))
+
+;;; Utility for maintaining the segment-delayed list. We cdr down list
+;;; n times (extending it if necessary) and then push thing on into the car
+;;; of that cons cell.
+(defun add-to-nth-list (list thing n)
+ (do ((cell (or list (setf list (list nil)))
+ (or (cdr cell) (setf (cdr cell) (list nil))))
+ (i n (1- i)))
+ ((zerop i)
+ (push thing (car cell))
+ list)))
+
+;;; Find the next instruction to schedule and return it after updating
+;;; any dependency information. If we can't do anything useful right
+;;; now, but there is more work to be done, return :NOP to indicate that
+;;; a nop must be emitted. If we are all done, return NIL.
+(defun schedule-one-inst (segment delay-slot-p)
+ (do ((prev nil remaining)
+ (remaining (segment-emittable-insts-queue segment) (cdr remaining)))
+ ((null remaining))
+ (let ((inst (car remaining)))
+ (unless (and delay-slot-p
+ (instruction-attributep (inst-attributes inst)
+ variable-length))
+ ;; We've got us a live one here. Go for it.
+ #!+sb-show-assem (format *trace-output* "emitting ~S~%" inst)
+ ;; Delete it from the list of insts.
+ (if prev
+ (setf (cdr prev) (cdr remaining))
+ (setf (segment-emittable-insts-queue segment)
+ (cdr remaining)))
+ ;; Note that this inst has been emitted.
+ (note-resolved-dependencies segment inst)
+ ;; And return.
+ (return-from schedule-one-inst
+ ;; Are we wanting to flush this instruction?
+ (if (inst-emitter inst)
+ ;; Nope, it's still a go. So return it.
+ inst
+ ;; Yes, so pick a new one. We have to start over,
+ ;; because note-resolved-dependencies might have
+ ;; changed the emittable-insts-queue.
+ (schedule-one-inst segment delay-slot-p))))))
+ ;; Nothing to do, so make something up.
+ (cond ((segment-delayed segment)
+ ;; No emittable instructions, but we have more work to do. Emit
+ ;; a NOP to fill in a delay slot.
+ #!+sb-show-assem (format *trace-output* "emitting a NOP~%")
+ :nop)
+ (t
+ ;; All done.
+ nil)))
+
+;;; This function is called whenever an instruction has been scheduled, and we
+;;; want to know what possibilities that opens up. So look at all the
+;;; instructions that this one depends on, and remove this instruction from
+;;; their dependents list. If we were the last dependent, then that
+;;; dependency can be emitted now.
+(defun note-resolved-dependencies (segment inst)
+ (assert (sset-empty (inst-read-dependents inst)))
+ (assert (sset-empty (inst-write-dependents inst)))
+ (do-sset-elements (dep (inst-write-dependencies inst))
+ ;; These are the instructions who have to be completed before our
+ ;; write fires. Doesn't matter how far before, just before.
+ (let ((dependents (inst-write-dependents dep)))
+ (sset-delete inst dependents)
+ (when (and (sset-empty dependents)
+ (sset-empty (inst-read-dependents dep)))
+ (insert-emittable-inst segment dep))))
+ (do-sset-elements (dep (inst-read-dependencies inst))
+ ;; These are the instructions who write values we read. If there
+ ;; is no delay, then just remove us from the dependent list.
+ ;; Otherwise, record the fact that in n cycles, we should be
+ ;; removed.
+ (if (zerop (inst-delay dep))
+ (let ((dependents (inst-read-dependents dep)))
+ (sset-delete inst dependents)
+ (when (and (sset-empty dependents)
+ (sset-empty (inst-write-dependents dep)))
+ (insert-emittable-inst segment dep)))
+ (setf (segment-delayed segment)
+ (add-to-nth-list (segment-delayed segment)
+ (cons dep inst)
+ (inst-delay dep)))))
+ (values))
+
+;;; Process the next entry in segment-delayed. This is called whenever anyone
+;;; emits an instruction.
+(defun advance-one-inst (segment)
+ (let ((delayed-stuff (pop (segment-delayed segment))))
+ (dolist (stuff delayed-stuff)
+ (if (consp stuff)
+ (let* ((dependency (car stuff))
+ (dependent (cdr stuff))
+ (dependents (inst-read-dependents dependency)))
+ (sset-delete dependent dependents)
+ (when (and (sset-empty dependents)
+ (sset-empty (inst-write-dependents dependency)))
+ (insert-emittable-inst segment dependency)))
+ (insert-emittable-inst segment stuff)))))
+
+;;; Note that inst is emittable by sticking it in the SEGMENT-EMITTABLE-INSTS-
+;;; QUEUE list. We keep the emittable-insts sorted with the largest ``depths''
+;;; first. Except that if INST is a branch, don't bother. It will be handled
+;;; correctly by the branch emitting code in SCHEDULE-PENDING-INSTRUCTIONS.
+(defun insert-emittable-inst (segment inst)
+ (unless (instruction-attributep (inst-attributes inst) branch)
+ #!+sb-show-assem (format *trace-output* "now emittable: ~S~%" inst)
+ (do ((my-depth (inst-depth inst))
+ (remaining (segment-emittable-insts-queue segment) (cdr remaining))
+ (prev nil remaining))
+ ((or (null remaining) (> my-depth (inst-depth (car remaining))))
+ (if prev
+ (setf (cdr prev) (cons inst remaining))
+ (setf (segment-emittable-insts-queue segment)
+ (cons inst remaining))))))
+ (values))
+\f
+;;;; structure used during output emission
+
+;;; common supertype for all the different kinds of annotations
+(defstruct (annotation (:constructor nil))
+ ;; Where in the raw output stream was this annotation emitted.
+ (index 0 :type index)
+ ;; What position does that correspond to.
+ (posn nil :type (or index null)))
+
+(defstruct (label (:include annotation)
+ (:constructor gen-label ()))
+ ;; (doesn't need any additional information beyond what is in the
+ ;; annotation structure)
+ )
+(sb!int:def!method print-object ((label label) stream)
+ (if (or *print-escape* *print-readably*)
+ (print-unreadable-object (label stream :type t)
+ (prin1 (sb!c:label-id label) stream))
+ (format stream "L~D" (sb!c:label-id label))))
+
+;;; a constraint on how the output stream must be aligned
+(defstruct (alignment-note
+ (:include annotation)
+ (:conc-name alignment-)
+ (:predicate alignment-p)
+ (:constructor make-alignment (bits size fill-byte)))
+ ;; The minimum number of low-order bits that must be zero.
+ (bits 0 :type alignment)
+ ;; The amount of filler we are assuming this alignment op will take.
+ (size 0 :type (integer 0 #.(1- (ash 1 max-alignment))))
+ ;; The byte used as filling.
+ (fill-byte 0 :type (or assembly-unit (signed-byte #.assembly-unit-bits))))
+
+;;; a reference to someplace that needs to be back-patched when
+;;; we actually know what label positions, etc. are
+(defstruct (back-patch
+ (:include annotation)
+ (:constructor make-back-patch (size function)))
+ ;; The area effected by this back-patch.
+ (size 0 :type index)
+ ;; The function to use to generate the real data
+ (function nil :type function))
+
+;;; This is similar to a BACK-PATCH, but also an indication that the amount
+;;; of stuff output depends on label-positions, etc. Back-patches can't change
+;;; their mind about how much stuff to emit, but choosers can.
+(defstruct (chooser
+ (:include annotation)
+ (:constructor make-chooser
+ (size alignment maybe-shrink worst-case-fun)))
+ ;; the worst case size for this chooser. There is this much space allocated
+ ;; in the output buffer.
+ (size 0 :type index)
+ ;; the worst case alignment this chooser is guaranteed to preserve
+ (alignment 0 :type alignment)
+ ;; the function to call to determine of we can use a shorter sequence. It
+ ;; returns NIL if nothing shorter can be used, or emits that sequence and
+ ;; returns T.
+ (maybe-shrink nil :type function)
+ ;; the function to call to generate the worst case sequence. This is used
+ ;; when nothing else can be condensed.
+ (worst-case-fun nil :type function))
+
+;;; This is used internally when we figure out a chooser or alignment doesn't
+;;; really need as much space as we initially gave it.
+(defstruct (filler
+ (:include annotation)
+ (:constructor make-filler (bytes)))
+ ;; the number of bytes of filler here
+ (bytes 0 :type index))
+\f
+;;;; output functions
+
+;;; interface: Emit the supplied BYTE to SEGMENT, growing SEGMENT if necessary.
+(defun emit-byte (segment byte)
+ (declare (type segment segment))
+ ;; We could use DECLARE instead of CHECK-TYPE here, but (1) CMU CL's inspired
+ ;; decision to treat DECLARE as ASSERT by default has not been copied by
+ ;; other compilers, and this code runs in the cross-compilation host Common
+ ;; Lisp, not just CMU CL, and (2) classic CMU CL allowed more things here
+ ;; than this, and I haven't tried to proof-read all the calls to EMIT-BYTE to
+ ;; ensure that they're passing appropriate. -- WHN 19990323
+ (check-type byte possibly-signed-assembly-unit)
+ (vector-push-extend (logand byte assembly-unit-mask)
+ (segment-buffer segment))
+ (incf (segment-current-posn segment))
+ (values))
+
+;;; interface: Output AMOUNT copies of FILL-BYTE to SEGMENT.
+(defun emit-skip (segment amount &optional (fill-byte 0))
+ (declare (type segment segment)
+ (type index amount))
+ (dotimes (i amount)
+ (emit-byte segment fill-byte))
+ (values))
+
+;;; Used to handle the common parts of annotation emision. We just
+;;; assign the posn and index of the note and tack it on to the end
+;;; of the segment's annotations list.
+(defun emit-annotation (segment note)
+ (declare (type segment segment)
+ (type annotation note))
+ (when (annotation-posn note)
+ (error "attempt to emit ~S a second time"))
+ (setf (annotation-posn note) (segment-current-posn segment))
+ (setf (annotation-index note) (segment-current-index segment))
+ (let ((last (segment-last-annotation segment))
+ (new (list note)))
+ (setf (segment-last-annotation segment)
+ (if last
+ (setf (cdr last) new)
+ (setf (segment-annotations segment) new))))
+ (values))
+
+(defun emit-back-patch (segment size function)
+ #!+sb-doc
+ "Note that the instruction stream has to be back-patched when label positions
+ are finally known. SIZE bytes are reserved in SEGMENT, and function will
+ be called with two arguments: the segment and the position. The function
+ should look at the position and the position of any labels it wants to
+ and emit the correct sequence. (And it better be the same size as SIZE).
+ SIZE can be zero, which is useful if you just want to find out where things
+ ended up."
+ (emit-annotation segment (make-back-patch size function))
+ (emit-skip segment size))
+
+(defun emit-chooser (segment size alignment maybe-shrink worst-case-fun)
+ #!+sb-doc
+ "Note that the instruction stream here depends on the actual positions of
+ various labels, so can't be output until label positions are known. Space
+ is made in SEGMENT for at least SIZE bytes. When all output has been
+ generated, the MAYBE-SHRINK functions for all choosers are called with
+ three arguments: the segment, the position, and a magic value. The MAYBE-
+ SHRINK decides if it can use a shorter sequence, and if so, emits that
+ sequence to the segment and returns T. If it can't do better than the
+ worst case, it should return NIL (without emitting anything). When calling
+ LABEL-POSITION, it should pass it the position and the magic-value it was
+ passed so that LABEL-POSITION can return the correct result. If the chooser
+ never decides to use a shorter sequence, the WORST-CASE-FUN will be called,
+ just like a BACK-PATCH. (See EMIT-BACK-PATCH.)"
+ (declare (type segment segment) (type index size) (type alignment alignment)
+ (type function maybe-shrink worst-case-fun))
+ (let ((chooser (make-chooser size alignment maybe-shrink worst-case-fun)))
+ (emit-annotation segment chooser)
+ (emit-skip segment size)
+ (adjust-alignment-after-chooser segment chooser)))
+
+;;; Called in EMIT-CHOOSER and COMPRESS-SEGMENT in order to recompute the
+;;; current alignment information in light of this chooser. If the alignment
+;;; guaranteed byte the chooser is less then the segments current alignment,
+;;; we have to adjust the segments notion of the current alignment.
+;;;
+;;; The hard part is recomputing the sync posn, because it's not just the
+;;; choosers posn. Consider a chooser that emits either one or three words.
+;;; It preserves 8-byte (3 bit) alignments, because the difference between
+;;; the two choices is 8 bytes.
+(defun adjust-alignment-after-chooser (segment chooser)
+ (declare (type segment segment) (type chooser chooser))
+ (let ((alignment (chooser-alignment chooser))
+ (seg-alignment (segment-alignment segment)))
+ (when (< alignment seg-alignment)
+ ;; The chooser might change the alignment of the output. So we have
+ ;; to figure out what the worst case alignment could be.
+ (setf (segment-alignment segment) alignment)
+ (let* ((posn (chooser-posn chooser))
+ (sync-posn (segment-sync-posn segment))
+ (offset (- posn sync-posn))
+ (delta (logand offset (1- (ash 1 alignment)))))
+ (setf (segment-sync-posn segment) (- posn delta)))))
+ (values))
+
+;;; Used internally whenever a chooser or alignment decides it doesn't need
+;;; as much space as it originally thought.
+(defun emit-filler (segment bytes)
+ (let ((last (segment-last-annotation segment)))
+ (cond ((and last (filler-p (car last)))
+ (incf (filler-bytes (car last)) bytes))
+ (t
+ (emit-annotation segment (make-filler bytes)))))
+ (incf (segment-current-index segment) bytes)
+ (values))
+
+;;; EMIT-LABEL (the interface) basically just expands into this, supplying
+;;; the segment and vop.
+(defun %emit-label (segment vop label)
+ (when (segment-run-scheduler segment)
+ (schedule-pending-instructions segment))
+ (let ((postits (segment-postits segment)))
+ (setf (segment-postits segment) nil)
+ (dolist (postit postits)
+ (emit-back-patch segment 0 postit)))
+ (let ((hook (segment-inst-hook segment)))
+ (when hook
+ (funcall hook segment vop :label label)))
+ (emit-annotation segment label))
+
+;;; Called by the ALIGN macro to emit an alignment note. We check to see
+;;; if we can guarantee the alignment restriction by just outputting a fixed
+;;; number of bytes. If so, we do so. Otherwise, we create and emit
+;;; an alignment note.
+(defun emit-alignment (segment vop bits &optional (fill-byte 0))
+ (when (segment-run-scheduler segment)
+ (schedule-pending-instructions segment))
+ (let ((hook (segment-inst-hook segment)))
+ (when hook
+ (funcall hook segment vop :align bits)))
+ (let ((alignment (segment-alignment segment))
+ (offset (- (segment-current-posn segment)
+ (segment-sync-posn segment))))
+ (cond ((> bits alignment)
+ ;; We need more bits of alignment. First emit enough noise
+ ;; to get back in sync with alignment, and then emit an alignment
+ ;; note to cover the rest.
+ (let ((slop (logand offset (1- (ash 1 alignment)))))
+ (unless (zerop slop)
+ (emit-skip segment (- (ash 1 alignment) slop) fill-byte)))
+ (let ((size (logand (1- (ash 1 bits))
+ (lognot (1- (ash 1 alignment))))))
+ (assert (> size 0))
+ (emit-annotation segment (make-alignment bits size fill-byte))
+ (emit-skip segment size fill-byte))
+ (setf (segment-alignment segment) bits)
+ (setf (segment-sync-posn segment) (segment-current-posn segment)))
+ (t
+ ;; The last alignment was more restrictive then this one.
+ ;; So we can just figure out how much noise to emit assuming
+ ;; the last alignment was met.
+ (let* ((mask (1- (ash 1 bits)))
+ (new-offset (logand (+ offset mask) (lognot mask))))
+ (emit-skip segment (- new-offset offset) fill-byte))
+ ;; But we emit an alignment with size=0 so we can verify
+ ;; that everything works.
+ (emit-annotation segment (make-alignment bits 0 fill-byte)))))
+ (values))
+
+;;; Used to find how ``aligned'' different offsets are. Returns the number
+;;; of low-order 0 bits, up to MAX-ALIGNMENT.
+(defun find-alignment (offset)
+ (dotimes (i max-alignment max-alignment)
+ (when (logbitp i offset)
+ (return i))))
+
+;;; Emit a postit. The function will be called as a back-patch with the
+;;; position the following instruction is finally emitted. Postits do not
+;;; interfere at all with scheduling.
+(defun %emit-postit (segment function)
+ (push function (segment-postits segment))
+ (values))
+\f
+;;;; output compression/position assignment stuff
+
+;;; Grovel though all the annotations looking for choosers. When we find
+;;; a chooser, invoke the maybe-shrink function. If it returns T, it output
+;;; some other byte sequence.
+(defun compress-output (segment)
+ (dotimes (i 5) ; it better not take more than one or two passes.
+ (let ((delta 0))
+ (setf (segment-alignment segment) max-alignment)
+ (setf (segment-sync-posn segment) 0)
+ (do* ((prev nil)
+ (remaining (segment-annotations segment) next)
+ (next (cdr remaining) (cdr remaining)))
+ ((null remaining))
+ (let* ((note (car remaining))
+ (posn (annotation-posn note)))
+ (unless (zerop delta)
+ (decf posn delta)
+ (setf (annotation-posn note) posn))
+ (cond
+ ((chooser-p note)
+ (setf (segment-current-index segment) (chooser-index note))
+ (setf (segment-current-posn segment) posn)
+ (setf (segment-last-annotation segment) prev)
+ (cond
+ ((funcall (chooser-maybe-shrink note) segment posn delta)
+ ;; It emitted some replacement.
+ (let ((new-size (- (segment-current-index segment)
+ (chooser-index note)))
+ (old-size (chooser-size note)))
+ (when (> new-size old-size)
+ (error "~S emitted ~D bytes, but claimed its max was ~D."
+ note new-size old-size))
+ (let ((additional-delta (- old-size new-size)))
+ (when (< (find-alignment additional-delta)
+ (chooser-alignment note))
+ (error "~S shrunk by ~D bytes, but claimed that it ~
+ preserve ~D bits of alignment."
+ note additional-delta (chooser-alignment note)))
+ (incf delta additional-delta)
+ (emit-filler segment additional-delta))
+ (setf prev (segment-last-annotation segment))
+ (if prev
+ (setf (cdr prev) (cdr remaining))
+ (setf (segment-annotations segment)
+ (cdr remaining)))))
+ (t
+ ;; The chooser passed on shrinking. Make sure it didn't emit
+ ;; anything.
+ (unless (= (segment-current-index segment) (chooser-index note))
+ (error "Chooser ~S passed, but not before emitting ~D bytes."
+ note
+ (- (segment-current-index segment)
+ (chooser-index note))))
+ ;; Act like we just emitted this chooser.
+ (let ((size (chooser-size note)))
+ (incf (segment-current-index segment) size)
+ (incf (segment-current-posn segment) size))
+ ;; Adjust the alignment accordingly.
+ (adjust-alignment-after-chooser segment note)
+ ;; And keep this chooser for next time around.
+ (setf prev remaining))))
+ ((alignment-p note)
+ (unless (zerop (alignment-size note))
+ ;; Re-emit the alignment, letting it collapse if we know anything
+ ;; more about the alignment guarantees of the segment.
+ (let ((index (alignment-index note)))
+ (setf (segment-current-index segment) index)
+ (setf (segment-current-posn segment) posn)
+ (setf (segment-last-annotation segment) prev)
+ (emit-alignment segment nil (alignment-bits note)
+ (alignment-fill-byte note))
+ (let* ((new-index (segment-current-index segment))
+ (size (- new-index index))
+ (old-size (alignment-size note))
+ (additional-delta (- old-size size)))
+ (when (minusp additional-delta)
+ (error "Alignment ~S needs more space now? It was ~D, ~
+ and is ~D now."
+ note old-size size))
+ (when (plusp additional-delta)
+ (emit-filler segment additional-delta)
+ (incf delta additional-delta)))
+ (setf prev (segment-last-annotation segment))
+ (if prev
+ (setf (cdr prev) (cdr remaining))
+ (setf (segment-annotations segment)
+ (cdr remaining))))))
+ (t
+ (setf prev remaining)))))
+ (when (zerop delta)
+ (return))
+ (decf (segment-final-posn segment) delta)))
+ (values))
+
+;;; We have run all the choosers we can, so now we have to figure out exactly
+;;; how much space each alignment note needs.
+(defun finalize-positions (segment)
+ (let ((delta 0))
+ (do* ((prev nil)
+ (remaining (segment-annotations segment) next)
+ (next (cdr remaining) (cdr remaining)))
+ ((null remaining))
+ (let* ((note (car remaining))
+ (posn (- (annotation-posn note) delta)))
+ (cond
+ ((alignment-p note)
+ (let* ((bits (alignment-bits note))
+ (mask (1- (ash 1 bits)))
+ (new-posn (logand (+ posn mask) (lognot mask)))
+ (size (- new-posn posn))
+ (old-size (alignment-size note))
+ (additional-delta (- old-size size)))
+ (assert (<= 0 size old-size))
+ (unless (zerop additional-delta)
+ (setf (segment-last-annotation segment) prev)
+ (incf delta additional-delta)
+ (setf (segment-current-index segment) (alignment-index note))
+ (setf (segment-current-posn segment) posn)
+ (emit-filler segment additional-delta)
+ (setf prev (segment-last-annotation segment)))
+ (if prev
+ (setf (cdr prev) next)
+ (setf (segment-annotations segment) next))))
+ (t
+ (setf (annotation-posn note) posn)
+ (setf prev remaining)
+ (setf next (cdr remaining))))))
+ (unless (zerop delta)
+ (decf (segment-final-posn segment) delta)))
+ (values))
+
+;;; Grovel over segment, filling in any backpatches. If any choosers are left
+;;; over, we need to emit their worst case varient.
+(defun process-back-patches (segment)
+ (do* ((prev nil)
+ (remaining (segment-annotations segment) next)
+ (next (cdr remaining) (cdr remaining)))
+ ((null remaining))
+ (let ((note (car remaining)))
+ (flet ((fill-in (function old-size)
+ (let ((index (annotation-index note))
+ (posn (annotation-posn note)))
+ (setf (segment-current-index segment) index)
+ (setf (segment-current-posn segment) posn)
+ (setf (segment-last-annotation segment) prev)
+ (funcall function segment posn)
+ (let ((new-size (- (segment-current-index segment) index)))
+ (unless (= new-size old-size)
+ (error "~S emitted ~D bytes, but claimed it was ~D."
+ note new-size old-size)))
+ (let ((tail (segment-last-annotation segment)))
+ (if tail
+ (setf (cdr tail) next)
+ (setf (segment-annotations segment) next)))
+ (setf next (cdr prev)))))
+ (cond ((back-patch-p note)
+ (fill-in (back-patch-function note)
+ (back-patch-size note)))
+ ((chooser-p note)
+ (fill-in (chooser-worst-case-fun note)
+ (chooser-size note)))
+ (t
+ (setf prev remaining)))))))
+\f
+;;;; interface to the rest of the compiler
+
+;;; This holds the current segment while assembling. Use ASSEMBLE to change
+;;; it.
+;;;
+;;; The double asterisks in the name are intended to suggest that this
+;;; isn't just any old special variable, it's an extra-special variable,
+;;; because sometimes MACROLET is used to bind it. So be careful out there..
+(defvar **current-segment**)
+
+;;; Just like **CURRENT-SEGMENT**, except this holds the current vop. Used only
+;;; to keep track of which vops emit which insts.
+;;;
+;;; The double asterisks in the name are intended to suggest that this
+;;; isn't just any old special variable, it's an extra-special variable,
+;;; because sometimes MACROLET is used to bind it. So be careful out there..
+(defvar **current-vop** nil)
+
+;;; We also symbol-macrolet **CURRENT-SEGMENT** to a local holding the segment
+;;; so uses of **CURRENT-SEGMENT** inside the body don't have to keep
+;;; dereferencing the symbol. Given that ASSEMBLE is the only interface to
+;;; **CURRENT-SEGMENT**, we don't have to worry about the special value
+;;; becomming out of sync with the lexical value. Unless some bozo closes over
+;;; it, but nobody does anything like that...
+;;;
+;;; FIXME: The way this macro uses MACROEXPAND internally breaks my old
+;;; assumptions about macros which are needed both in the host and the target.
+;;; (This is more or less the same way that PUSH-IN, DELETEF-IN, and
+;;; DEF-BOOLEAN-ATTRIBUTE break my old assumptions, except that they used
+;;; GET-SETF-EXPANSION instead of MACROEXPAND to do the dirty deed.) The
+;;; quick and dirty "solution" here is the same as there: use cut and
+;;; paste to duplicate the defmacro in a
+;;; (SB!INT:DEF!MACRO FOO (..) .. CL:MACROEXPAND ..)
+;;; #+SB-XC-HOST
+;;; (DEFMACRO FOO (..) .. SB!XC:MACROEXPAND ..)
+;;; idiom. This is disgusting and unmaintainable, and there are obviously
+;;; better solutions and maybe even good solutions, but I'm disinclined to
+;;; hunt for good solutions until the system works and I can test them
+;;; in isolation.
+(sb!int:def!macro assemble ((&optional segment vop &key labels) &body body
+ &environment env)
+ #!+sb-doc
+ "Execute BODY (as a progn) with SEGMENT as the current segment."
+ (flet ((label-name-p (thing)
+ (and thing (symbolp thing))))
+ (let* ((seg-var (gensym "SEGMENT-"))
+ (vop-var (gensym "VOP-"))
+ (visible-labels (remove-if-not #'label-name-p body))
+ (inherited-labels
+ (multiple-value-bind (expansion expanded)
+ (macroexpand '..inherited-labels.. env)
+ (if expanded expansion nil)))
+ (new-labels (append labels
+ (set-difference visible-labels
+ inherited-labels)))
+ (nested-labels (set-difference (append inherited-labels new-labels)
+ visible-labels)))
+ (when (intersection labels inherited-labels)
+ (error "duplicate nested labels: ~S"
+ (intersection labels inherited-labels)))
+ `(let* ((,seg-var ,(or segment '**current-segment**))
+ (,vop-var ,(or vop '**current-vop**))
+ ,@(when segment
+ `((**current-segment** ,seg-var)))
+ ,@(when vop
+ `((**current-vop** ,vop-var)))
+ ,@(mapcar #'(lambda (name)
+ `(,name (gen-label)))
+ new-labels))
+ (symbol-macrolet ((**current-segment** ,seg-var)
+ (**current-vop** ,vop-var)
+ ,@(when (or inherited-labels nested-labels)
+ `((..inherited-labels.. ,nested-labels))))
+ ,@(mapcar #'(lambda (form)
+ (if (label-name-p form)
+ `(emit-label ,form)
+ form))
+ body))))))
+#+sb-xc-host
+(sb!xc:defmacro assemble ((&optional segment vop &key labels)
+ &body body
+ &environment env)
+ #!+sb-doc
+ "Execute BODY (as a progn) with SEGMENT as the current segment."
+ (flet ((label-name-p (thing)
+ (and thing (symbolp thing))))
+ (let* ((seg-var (gensym "SEGMENT-"))
+ (vop-var (gensym "VOP-"))
+ (visible-labels (remove-if-not #'label-name-p body))
+ (inherited-labels
+ (multiple-value-bind
+ (expansion expanded)
+ (sb!xc:macroexpand '..inherited-labels.. env)
+ (if expanded expansion nil)))
+ (new-labels (append labels
+ (set-difference visible-labels
+ inherited-labels)))
+ (nested-labels (set-difference (append inherited-labels new-labels)
+ visible-labels)))
+ (when (intersection labels inherited-labels)
+ (error "duplicate nested labels: ~S"
+ (intersection labels inherited-labels)))
+ `(let* ((,seg-var ,(or segment '**current-segment**))
+ (,vop-var ,(or vop '**current-vop**))
+ ,@(when segment
+ `((**current-segment** ,seg-var)))
+ ,@(when vop
+ `((**current-vop** ,vop-var)))
+ ,@(mapcar #'(lambda (name)
+ `(,name (gen-label)))
+ new-labels))
+ (symbol-macrolet ((**current-segment** ,seg-var)
+ (**current-vop** ,vop-var)
+ ,@(when (or inherited-labels nested-labels)
+ `((..inherited-labels.. ,nested-labels))))
+ ,@(mapcar #'(lambda (form)
+ (if (label-name-p form)
+ `(emit-label ,form)
+ form))
+ body))))))
+
+(defmacro inst (&whole whole instruction &rest args &environment env)
+ #!+sb-doc
+ "Emit the specified instruction to the current segment."
+ (let ((inst (gethash (symbol-name instruction) *assem-instructions*)))
+ (cond ((null inst)
+ (error "unknown instruction: ~S" instruction))
+ ((functionp inst)
+ (funcall inst (cdr whole) env))
+ (t
+ `(,inst **current-segment** **current-vop** ,@args)))))
+
+;;; Note: The need to capture SYMBOL-MACROLET bindings of **CURRENT-SEGMENT*
+;;; and **CURRENT-VOP** prevents this from being an ordinary function.
+(defmacro emit-label (label)
+ #!+sb-doc
+ "Emit LABEL at this location in the current segment."
+ `(%emit-label **current-segment** **current-vop** ,label))
+
+;;; Note: The need to capture SYMBOL-MACROLET bindings of **CURRENT-SEGMENT*
+;;; prevents this from being an ordinary function.
+(defmacro emit-postit (function)
+ `(%emit-postit **current-segment** ,function))
+
+;;; Note: The need to capture SYMBOL-MACROLET bindings of **CURRENT-SEGMENT*
+;;; and **CURRENT-VOP** prevents this from being an ordinary function.
+(defmacro align (bits &optional (fill-byte 0))
+ #!+sb-doc
+ "Emit an alignment restriction to the current segment."
+ `(emit-alignment **current-segment** **current-vop** ,bits ,fill-byte))
+;;; FIXME: By analogy with EMIT-LABEL and EMIT-POSTIT, this should be
+;;; called EMIT-ALIGNMENT, and the function that it calls should be
+;;; called %EMIT-ALIGNMENT.
+
+(defun label-position (label &optional if-after delta)
+ #!+sb-doc
+ "Return the current position for LABEL. Chooser maybe-shrink functions
+ should supply IF-AFTER and DELTA in order to ensure correct results."
+ (let ((posn (label-posn label)))
+ (if (and if-after (> posn if-after))
+ (- posn delta)
+ posn)))
+
+(defun append-segment (segment other-segment)
+ #!+sb-doc
+ "Append OTHER-SEGMENT to the end of SEGMENT. Don't use OTHER-SEGMENT
+ for anything after this."
+ (when (segment-run-scheduler segment)
+ (schedule-pending-instructions segment))
+ (let ((postits (segment-postits segment)))
+ (setf (segment-postits segment) (segment-postits other-segment))
+ (dolist (postit postits)
+ (emit-back-patch segment 0 postit)))
+ #!-x86 (emit-alignment segment nil max-alignment)
+ #!+x86 (emit-alignment segment nil max-alignment #x90)
+ (let ((segment-current-index-0 (segment-current-index segment))
+ (segment-current-posn-0 (segment-current-posn segment)))
+ (incf (segment-current-index segment)
+ (segment-current-index other-segment))
+ (replace (segment-buffer segment)
+ (segment-buffer other-segment)
+ :start1 segment-current-index-0)
+ (setf (segment-buffer other-segment) nil) ; to prevent accidental reuse
+ (incf (segment-current-posn segment)
+ (segment-current-posn other-segment))
+ (let ((other-annotations (segment-annotations other-segment)))
+ (when other-annotations
+ (dolist (note other-annotations)
+ (incf (annotation-index note) segment-current-index-0)
+ (incf (annotation-posn note) segment-current-posn-0))
+ ;; This SEGMENT-LAST-ANNOTATION code is confusing. Is it really
+ ;; worth enough in efficiency to justify it? -- WHN 19990322
+ (let ((last (segment-last-annotation segment)))
+ (if last
+ (setf (cdr last) other-annotations)
+ (setf (segment-annotations segment) other-annotations)))
+ (setf (segment-last-annotation segment)
+ (segment-last-annotation other-segment)))))
+ (values))
+
+(defun finalize-segment (segment)
+ #!+sb-doc
+ "Do any final processing of SEGMENT and return the total number of bytes
+ covered by this segment."
+ (when (segment-run-scheduler segment)
+ (schedule-pending-instructions segment))
+ (setf (segment-run-scheduler segment) nil)
+ (let ((postits (segment-postits segment)))
+ (setf (segment-postits segment) nil)
+ (dolist (postit postits)
+ (emit-back-patch segment 0 postit)))
+ (setf (segment-final-index segment) (segment-current-index segment))
+ (setf (segment-final-posn segment) (segment-current-posn segment))
+ (setf (segment-inst-hook segment) nil)
+ (compress-output segment)
+ (finalize-positions segment)
+ (process-back-patches segment)
+ (segment-final-posn segment))
+
+;;; Call FUNCTION on all the stuff accumulated in SEGMENT. FUNCTION should
+;;; accept a single vector argument. It will be called zero or more times
+;;; on vectors of the appropriate byte type. The concatenation of the
+;;; vector arguments from all the calls is the contents of SEGMENT.
+;;;
+;;; KLUDGE: This implementation is sort of slow and gross, calling FUNCTION
+;;; repeatedly and consing a fresh vector for its argument each time. It might
+;;; be possible to make a more efficient version by making FINALIZE-SEGMENT do
+;;; all the compacting currently done by this function: then this function
+;;; could become trivial and fast, calling FUNCTION once on the entire
+;;; compacted segment buffer. -- WHN 19990322
+(defun on-segment-contents-vectorly (segment function)
+ (let ((buffer (segment-buffer segment))
+ (i0 0))
+ (flet ((frob (i0 i1)
+ (when (< i0 i1)
+ (funcall function (subseq buffer i0 i1)))))
+ (dolist (note (segment-annotations segment))
+ (when (filler-p note)
+ (let ((i1 (filler-index note)))
+ (frob i0 i1)
+ (setf i0 (+ i1 (filler-bytes note))))))
+ (frob i0 (segment-final-index segment))))
+ (values))
+
+;;; Write the code accumulated in SEGMENT to STREAM, and return the number of
+;;; bytes written.
+(defun write-segment-contents (segment stream)
+ (let ((result 0))
+ (declare (type index result))
+ (on-segment-contents-vectorly segment
+ (lambda (v)
+ (declare (type (vector assembly-unit) v))
+ (incf result (length v))
+ (write-sequence v stream)))
+ result))
+\f
+;;;; interface to the instruction set definition
+
+;;; Define a function named NAME that merges its arguments into a single
+;;; integer and then emits the bytes of that integer in the correct order
+;;; based on the endianness of the target-backend.
+(defmacro define-bitfield-emitter (name total-bits &rest byte-specs)
+ (sb!int:collect ((arg-names) (arg-types))
+ (let* ((total-bits (eval total-bits))
+ (overall-mask (ash -1 total-bits))
+ (num-bytes (multiple-value-bind (quo rem)
+ (truncate total-bits assembly-unit-bits)
+ (unless (zerop rem)
+ (error "~D isn't an even multiple of ~D."
+ total-bits assembly-unit-bits))
+ quo))
+ (bytes (make-array num-bytes :initial-element nil))
+ (segment-arg (gensym "SEGMENT-")))
+ (dolist (byte-spec-expr byte-specs)
+ (let* ((byte-spec (eval byte-spec-expr))
+ (byte-size (byte-size byte-spec))
+ (byte-posn (byte-position byte-spec))
+ (arg (gensym (format nil "~:@(ARG-FOR-~S-~)" byte-spec-expr))))
+ (when (ldb-test (byte byte-size byte-posn) overall-mask)
+ (error "The byte spec ~S either overlaps another byte spec, or ~
+ extends past the end."
+ byte-spec-expr))
+ (setf (ldb byte-spec overall-mask) -1)
+ (arg-names arg)
+ (arg-types `(type (integer ,(ash -1 (1- byte-size))
+ ,(1- (ash 1 byte-size)))
+ ,arg))
+ (multiple-value-bind (start-byte offset)
+ (floor byte-posn assembly-unit-bits)
+ (let ((end-byte (floor (1- (+ byte-posn byte-size))
+ assembly-unit-bits)))
+ (flet ((maybe-ash (expr offset)
+ (if (zerop offset)
+ expr
+ `(ash ,expr ,offset))))
+ (declare (inline maybe-ash))
+ (cond ((zerop byte-size))
+ ((= start-byte end-byte)
+ (push (maybe-ash `(ldb (byte ,byte-size 0) ,arg)
+ offset)
+ (svref bytes start-byte)))
+ (t
+ (push (maybe-ash
+ `(ldb (byte ,(- assembly-unit-bits offset) 0)
+ ,arg)
+ offset)
+ (svref bytes start-byte))
+ (do ((index (1+ start-byte) (1+ index)))
+ ((>= index end-byte))
+ (push
+ `(ldb (byte ,assembly-unit-bits
+ ,(- (* assembly-unit-bits
+ (- index start-byte))
+ offset))
+ ,arg)
+ (svref bytes index)))
+ (let ((len (rem (+ byte-size offset)
+ assembly-unit-bits)))
+ (push
+ `(ldb (byte ,(if (zerop len)
+ assembly-unit-bits
+ len)
+ ,(- (* assembly-unit-bits
+ (- end-byte start-byte))
+ offset))
+ ,arg)
+ (svref bytes end-byte))))))))))
+ (unless (= overall-mask -1)
+ (error "There are holes."))
+ (let ((forms nil))
+ (dotimes (i num-bytes)
+ (let ((pieces (svref bytes i)))
+ (assert pieces)
+ (push `(emit-byte ,segment-arg
+ ,(if (cdr pieces)
+ `(logior ,@pieces)
+ (car pieces)))
+ forms)))
+ `(defun ,name (,segment-arg ,@(arg-names))
+ (declare (type segment ,segment-arg) ,@(arg-types))
+ ,@(ecase sb!c:*backend-byte-order*
+ (:little-endian (nreverse forms))
+ (:big-endian forms))
+ ',name)))))
+
+(defun grovel-lambda-list (lambda-list vop-var)
+ (let ((segment-name (car lambda-list))
+ (vop-var (or vop-var (gensym "VOP-"))))
+ (sb!int:collect ((new-lambda-list))
+ (new-lambda-list segment-name)
+ (new-lambda-list vop-var)
+ (labels
+ ((grovel (state lambda-list)
+ (when lambda-list
+ (let ((param (car lambda-list)))
+ (cond
+ ((member param lambda-list-keywords)
+ (new-lambda-list param)
+ (grovel param (cdr lambda-list)))
+ (t
+ (ecase state
+ ((nil)
+ (new-lambda-list param)
+ `(cons ,param ,(grovel state (cdr lambda-list))))
+ (&optional
+ (multiple-value-bind (name default supplied-p)
+ (if (consp param)
+ (values (first param)
+ (second param)
+ (or (third param)
+ (gensym "SUPPLIED-P-")))
+ (values param nil (gensym "SUPPLIED-P-")))
+ (new-lambda-list (list name default supplied-p))
+ `(and ,supplied-p
+ (cons ,(if (consp name)
+ (second name)
+ name)
+ ,(grovel state (cdr lambda-list))))))
+ (&key
+ (multiple-value-bind (name default supplied-p)
+ (if (consp param)
+ (values (first param)
+ (second param)
+ (or (third param)
+ (gensym "SUPPLIED-P-")))
+ (values param nil (gensym "SUPPLIED-P-")))
+ (new-lambda-list (list name default supplied-p))
+ (multiple-value-bind (key var)
+ (if (consp name)
+ (values (first name) (second name))
+ (values (intern (symbol-name name) :keyword)
+ name))
+ `(append (and ,supplied-p (list ',key ,var))
+ ,(grovel state (cdr lambda-list))))))
+ (&rest
+ (new-lambda-list param)
+ (grovel state (cdr lambda-list))
+ param))))))))
+ (let ((reconstructor (grovel nil (cdr lambda-list))))
+ (values (new-lambda-list)
+ segment-name
+ vop-var
+ reconstructor))))))
+
+(defun extract-nths (index glue list-of-lists-of-lists)
+ (mapcar #'(lambda (list-of-lists)
+ (cons glue
+ (mapcar #'(lambda (list)
+ (nth index list))
+ list-of-lists)))
+ list-of-lists-of-lists))
+
+(defmacro define-instruction (name lambda-list &rest options)
+ (let* ((sym-name (symbol-name name))
+ (defun-name (sb!int:symbolicate sym-name "-INST-EMITTER"))
+ (vop-var nil)
+ (postits (gensym "POSTITS-"))
+ (emitter nil)
+ (decls nil)
+ (attributes nil)
+ (cost nil)
+ (dependencies nil)
+ (delay nil)
+ (pinned nil)
+ (pdefs nil))
+ (sb!int:/noshow "entering DEFINE-INSTRUCTION" name lambda-list options)
+ (dolist (option-spec options)
+ (sb!int:/noshow option-spec)
+ (multiple-value-bind (option args)
+ (if (consp option-spec)
+ (values (car option-spec) (cdr option-spec))
+ (values option-spec nil))
+ (sb!int:/noshow option args)
+ (case option
+ (:emitter
+ (when emitter
+ (error "You can only specify :EMITTER once per instruction."))
+ (setf emitter args))
+ (:declare
+ (setf decls (append decls args)))
+ (:attributes
+ (setf attributes (append attributes args)))
+ (:cost
+ (setf cost (first args)))
+ (:dependencies
+ (setf dependencies (append dependencies args)))
+ (:delay
+ (when delay
+ (error "You can only specify :DELAY once per instruction."))
+ (setf delay args))
+ (:pinned
+ (setf pinned t))
+ (:vop-var
+ (if vop-var
+ (error "You can only specify :VOP-VAR once per instruction.")
+ (setf vop-var (car args))))
+ (:printer
+ (push (eval `(list (multiple-value-list
+ ,(sb!disassem:gen-printer-def-forms-def-form
+ name
+ (cdr option-spec)))))
+ pdefs))
+ (:printer-list
+ ;; same as :PRINTER, but is EVALed first, and is a list of printers
+ (push
+ (eval
+ `(eval
+ `(list ,@(mapcar #'(lambda (printer)
+ `(multiple-value-list
+ ,(sb!disassem:gen-printer-def-forms-def-form
+ ',name printer nil)))
+ ,(cadr option-spec)))))
+ pdefs))
+ (t
+ (error "unknown option: ~S" option)))))
+ (sb!int:/noshow "done processing options")
+ (setf pdefs (nreverse pdefs))
+ (multiple-value-bind
+ (new-lambda-list segment-name vop-name arg-reconstructor)
+ (grovel-lambda-list lambda-list vop-var)
+ (sb!int:/noshow new-lambda-list segment-name vop-name arg-reconstructor)
+ (push `(let ((hook (segment-inst-hook ,segment-name)))
+ (when hook
+ (funcall hook ,segment-name ,vop-name ,sym-name
+ ,arg-reconstructor)))
+ emitter)
+ (push `(dolist (postit ,postits)
+ (emit-back-patch ,segment-name 0 postit))
+ emitter)
+ (unless cost (setf cost 1))
+ #!+sb-dyncount
+ (push `(when (segment-collect-dynamic-statistics ,segment-name)
+ (let* ((info (sb!c:ir2-component-dyncount-info
+ (sb!c:component-info
+ sb!c:*component-being-compiled*)))
+ (costs (sb!c:dyncount-info-costs info))
+ (block-number (sb!c:block-number
+ (sb!c:ir2-block-block
+ (sb!c:vop-block ,vop-name)))))
+ (incf (aref costs block-number) ,cost)))
+ emitter)
+ (when *assem-scheduler-p*
+ (if pinned
+ (setf emitter
+ `((when (segment-run-scheduler ,segment-name)
+ (schedule-pending-instructions ,segment-name))
+ ,@emitter))
+ (let ((flet-name
+ (gensym (concatenate 'string "EMIT-" sym-name "-INST-")))
+ (inst-name (gensym "INST-")))
+ (setf emitter `((flet ((,flet-name (,segment-name)
+ ,@emitter))
+ (if (segment-run-scheduler ,segment-name)
+ (let ((,inst-name
+ (make-instruction
+ (incf (segment-inst-number
+ ,segment-name))
+ #',flet-name
+ (instruction-attributes
+ ,@attributes)
+ (progn ,@delay))))
+ ,@(when dependencies
+ `((note-dependencies
+ (,segment-name ,inst-name)
+ ,@dependencies)))
+ (queue-inst ,segment-name ,inst-name))
+ (,flet-name ,segment-name))))))))
+ `(progn
+ (defun ,defun-name ,new-lambda-list
+ ,@(when decls
+ `((declare ,@decls)))
+ (let ((,postits (segment-postits ,segment-name)))
+ (setf (segment-postits ,segment-name) nil)
+ (symbol-macrolet
+ (;; Apparently this binding is intended to keep anyone from
+ ;; accidentally using **CURRENT-SEGMENT** within the body
+ ;; of the emitter. The error message sorta suggests that
+ ;; this can happen accidentally by including one emitter
+ ;; inside another. But I dunno.. -- WHN 19990323
+ (**current-segment**
+ ;; FIXME: I can't see why we have to use
+ ;; (MACROLET ((LOSE () (ERROR ..))) (LOSE))
+ ;; instead of just (ERROR "..") here.
+ (macrolet ((lose ()
+ (error "You can't use INST without an ~
+ ASSEMBLE inside emitters.")))
+ (lose))))
+ ,@emitter))
+ (values))
+ (eval-when (:compile-toplevel :load-toplevel :execute)
+ (%define-instruction ,sym-name ',defun-name))
+ ,@(extract-nths 1 'progn pdefs)
+ ,@(when pdefs
+ `((sb!disassem:install-inst-flavors
+ ',name
+ (append ,@(extract-nths 0 'list pdefs)))))))))
+
+(defmacro define-instruction-macro (name lambda-list &body body)
+ (let ((whole (gensym "WHOLE-"))
+ (env (gensym "ENV-")))
+ (multiple-value-bind (body local-defs)
+ (sb!kernel:parse-defmacro lambda-list
+ whole
+ body
+ name
+ 'instruction-macro
+ :environment env)
+ `(eval-when (:compile-toplevel :load-toplevel :execute)
+ (%define-instruction ,(symbol-name name)
+ #'(lambda (,whole ,env)
+ ,@local-defs
+ (block ,name
+ ,body)))))))
+
+(defun %define-instruction (name defun)
+ (setf (gethash name *assem-instructions*) defun)
+ name)
--- /dev/null
+;;;; This file contains backend-specific data. The original intent, in
+;;;; CMU CL, was to allow compilation using different backends, as a
+;;;; way of mutating a running CMU CL into a hybrid system which could
+;;;; emit code for a different architecture. In SBCL, this is not
+;;;; needed, since we have a cross-compiler which runs as an ordinary
+;;;; Lisp program under SBCL or other Lisps. However, it still seems
+;;;; reasonable to have all backendish things here in a single file.
+;;;;
+;;;; FIXME: Perhaps someday the vmdef.lisp and/or meta-vmdef.lisp stuff can
+;;;; merged into this file, and/or the metaness can go away or at least be
+;;;; radically simplified.
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!C")
+
+(file-comment
+ "$Header$")
+\f
+;;;; miscellaneous backend properties
+
+;;; the conventional file extension for fasl files on this architecture,
+;;; e.g. "x86f"
+(defvar *backend-fasl-file-type* nil)
+(declaim (type (or simple-string null) *backend-fasl-file-type*))
+
+;;; implementation and version of fasl files used
+(defvar *backend-fasl-file-implementation* nil)
+(defvar *backend-fasl-file-version* nil)
+(declaim (type (or keyword null) *backend-fasl-file-implementation*))
+(declaim (type (or index null) *backend-fasl-file-version*))
+
+;;; the number of references that a TN must have to offset the overhead of
+;;; saving the TN across a call
+(defvar *backend-register-save-penalty* 0)
+(declaim (type index *backend-register-save-penalty*))
+
+;;; the byte order of the target machine. :BIG-ENDIAN has the MSB first (e.g.
+;;; IBM RT), :LITTLE-ENDIAN has the MSB last (e.g. DEC VAX).
+;;;
+;;; KLUDGE: In a sort of pun, this is also used as the value of
+;;; BACKEND-BYTE-FASL-FILE-IMPLEMENTATION. -- WHN 20000302
+(defvar *backend-byte-order* nil)
+(declaim (type (member nil :little-endian :big-endian) *backend-byte-order*))
+
+;;; translation from SC numbers to SC info structures. SC numbers are always
+;;; used instead of names at run time, so changing this vector changes all the
+;;; references.
+(defvar *backend-sc-numbers* (make-array sc-number-limit :initial-element nil))
+(declaim (type sc-vector *backend-sc-numbers*))
+
+;;; a list of all the SBs defined, so that we can easily iterate over them
+(defvar *backend-sb-list* ())
+(declaim (type list *backend-sb-list*))
+
+;;; translation from template names to template structures
+(defvar *backend-template-names* (make-hash-table :test 'eq))
+(declaim (type hash-table *backend-template-names*))
+
+;;; hashtables mapping from SC and SB names to the corresponding structures
+;;;
+;;; CMU CL comment:
+;;; The META versions are only used at meta-compile and load times,
+;;; so the defining macros can change these at meta-compile time
+;;; without breaking the compiler.
+;;; FIXME: Couldn't the META versions go away in SBCL now that we don't
+;;; have to worry about metacompiling and breaking the compiler?
+(defvar *backend-sc-names* (make-hash-table :test 'eq))
+(defvar *backend-sb-names* (make-hash-table :test 'eq))
+(defvar *backend-meta-sc-names* (make-hash-table :test 'eq))
+(defvar *backend-meta-sb-names* (make-hash-table :test 'eq))
+(declaim (type hash-table
+ *backend-sc-names*
+ *backend-sb-names*
+ *backend-meta-sc-names*
+ *backend-meta-sb-names*))
+
+
+;;; like *SC-NUMBERS*, but updated at meta-compile time
+;;;
+;;; FIXME: As per *BACKEND-META-SC-NAMES* and *BACKEND-META-SB-NAMES*,
+;;; couldn't we get rid of this in SBCL?
+(defvar *backend-meta-sc-numbers*
+ (make-array sc-number-limit :initial-element nil))
+(declaim (type sc-vector *backend-meta-sc-numbers*))
+
+;;; translations from primitive type names to the corresponding
+;;; primitive-type structure.
+(defvar *backend-primitive-type-names*
+ (make-hash-table :test 'eq))
+(declaim (type hash-table *backend-primitive-type-names*))
+
+;;; This establishes a convenient handle on primitive type unions, or
+;;; whatever. These names can only be used as the :ARG-TYPES or
+;;; :RESULT-TYPES for VOPs and can map to anything else that can be
+;;; used as :ARG-TYPES or :RESULT-TYPES (e.g. :OR, :CONSTANT).
+(defvar *backend-primitive-type-aliases* (make-hash-table :test 'eq))
+(declaim (type hash-table *backend-primitive-type-aliases*))
+
+;;; meta-compile time translation from names to primitive types
+;;;
+;;; FIXME: As per *BACKEND-META-SC-NAMES* and *BACKEND-META-SB-NAMES*,
+;;; couldn't we get rid of this in SBCL?
+(defvar *backend-meta-primitive-type-names* (make-hash-table :test 'eq))
+(declaim (type hash-table *meta-primitive-type-names*))
+
+;;; The primitive type T is somewhat magical, in that it is the only
+;;; primitive type that overlaps with other primitive types. An object
+;;; of primitive-type T is in the canonical descriptor (boxed or pointer)
+;;; representation.
+;;;
+;;; The T primitive-type is kept in this variable so that people who
+;;; have to special-case it can get at it conveniently. This variable
+;;; has to be set by the machine-specific VM definition, since the
+;;; DEF-PRIMITIVE-TYPE for T must specify the SCs that boxed objects
+;;; can be allocated in.
+(defvar *backend-t-primitive-type*)
+(declaim (type primitive-type *backend-t-primitive-type*))
+
+;;; a hashtable translating from VOP names to the corresponding VOP-Parse
+;;; structures. This information is only used at meta-compile time.
+(defvar *backend-parsed-vops* (make-hash-table :test 'eq))
+(declaim (type hash-table *backend-parsed-vops*))
+
+;;; the backend-specific aspects of the info environment
+(defvar *backend-info-environment* nil)
+(declaim (type list *backend-info-environment*))
+
+;;; support for the assembler
+(defvar *backend-instruction-formats* (make-hash-table :test 'eq))
+(defvar *backend-instruction-flavors* (make-hash-table :test 'equal))
+(defvar *backend-special-arg-types* (make-hash-table :test 'eq))
+(declaim (type hash-table
+ *backend-instruction-formats*
+ *backend-instruction-flavors*
+ *backend-special-arg-types*))
+
+;;; mappings between CTYPE structures and the corresponding predicate.
+;;; The type->predicate mapping is implemented as an alist because
+;;; there is no such thing as a TYPE= hash table.
+(defvar *backend-predicate-types* (make-hash-table :test 'eq))
+(defvar *backend-type-predicates* nil)
+(declaim (type hash-table *backend-predicate-types*))
+(declaim (type list *backend-type-predicates*))
+
+;;; a vector of the internal errors defined for this backend, or NIL if
+;;; they haven't been installed yet
+(defvar *backend-internal-errors* nil)
+(declaim (type (or simple-vector null) *backend-internal-errors*))
+
+;;; the maximum number of bytes per page on this system (used by GENESIS)
+(defvar *backend-page-size* 0)
+(declaim (type index *backend-page-size*))
+\f
+;;;; VM support routines
+
+;;; FIXME: Do we need this kind of indirection for the VM support
+;;; routines any more?
+
+;;; forward declaration
+(defvar *backend-support-routines*)
+
+(macrolet ((def-vm-support-routines (&rest routines)
+ `(progn
+ (eval-when (:compile-toplevel :load-toplevel :execute)
+ (defparameter *vm-support-routines* ',routines))
+ (defstruct vm-support-routines
+ ,@(mapcar #'(lambda (routine)
+ `(,routine nil :type (or function null)))
+ routines))
+ ,@(mapcar
+ #'(lambda (name)
+ `(defun ,name (&rest args)
+ (apply (or (,(symbolicate "VM-SUPPORT-ROUTINES-"
+ name)
+ *backend-support-routines*)
+ (error "machine-specific support ~S ~
+ routine undefined"
+ ',name))
+ args)))
+ routines))))
+
+ (def-vm-support-routines
+
+ ;; from vm.lisp
+ immediate-constant-sc
+ location-print-name
+
+ ;; from primtype.lisp
+ primitive-type-of
+ primitive-type
+
+ ;; from c-call.lisp
+ make-call-out-tns
+
+ ;; from call.lisp
+ standard-argument-location
+ make-return-pc-passing-location
+ make-old-fp-passing-location
+ make-old-fp-save-location
+ make-return-pc-save-location
+ make-argument-count-location
+ make-nfp-tn
+ make-stack-pointer-tn
+ make-number-stack-pointer-tn
+ make-unknown-values-locations
+ select-component-format
+
+ ;; from nlx.lisp
+ make-nlx-sp-tn
+ make-dynamic-state-tns
+ make-nlx-entry-argument-start-location
+
+ ;; from support.lisp
+ generate-call-sequence
+ generate-return-sequence
+
+ ;; for use with scheduler
+ emit-nop
+ location-number))
+
+(defprinter (vm-support-routines))
+
+(defmacro def-vm-support-routine (name ll &body body)
+ (unless (member (intern (string name) (find-package "SB!C"))
+ *vm-support-routines*)
+ (warn "unknown VM support routine: ~A" name))
+ (let ((local-name (symbolicate "IMPL-OF-VM-SUPPORT-ROUTINE-" name)))
+ `(progn
+ (defun ,local-name ,ll ,@body)
+ (setf (,(intern (concatenate 'simple-string
+ "VM-SUPPORT-ROUTINES-"
+ (string name))
+ (find-package "SB!C"))
+ *backend-support-routines*)
+ #',local-name))))
+
+;;; the VM support routines
+(defvar *backend-support-routines* (make-vm-support-routines))
+(declaim (type vm-support-routines *backend-support-routines*))
+\f
+;;;; utilities
+
+(defun backend-byte-fasl-file-implementation ()
+ *backend-byte-order*)
+
+(defun backend-byte-fasl-file-type ()
+ (ecase *backend-byte-order*
+ (:big-endian "bytef")
+ (:little-endian "lbytef")))
--- /dev/null
+;;;; bit-vector hacking utilities, potentially implementation-dependent
+;;;; for speed
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!C")
+
+(file-comment
+ "$Header$")
+
+#!-sb-fluid
+(declaim (inline clear-bit-vector set-bit-vector bit-vector-replace
+ bit-vector-copy))
+
+;;; Clear a SIMPLE-BIT-VECTOR to zeros.
+(defun clear-bit-vector (vec)
+ (declare (type simple-bit-vector vec))
+ (bit-xor vec vec t))
+
+;;; The old (pre-1999) code had a more-efficient-looking, but also
+;;; less-portable implementation of CLEAR-BIT-VECTOR:
+;;; (do ((i sb!vm:vector-data-offset (1+ i))
+;;; (end (+ sb!vm:vector-data-offset
+;;; (ash (+ (length vec) (1- sb!vm:word-bits))
+;;; (- (1- (integer-length sb!vm:word-bits)))))))
+;;; ((= i end) vec)
+;;; (setf (sb!kernel:%raw-bits vec i) 0)))
+;;; We could use this in the target SBCL if the new version turns out to be a
+;;; bottleneck. I (WHN 19990321) will stick to the portable version for now.
+;;; And by the way, if we do revisit this file with efficiency on our mind, it
+;;; might be good to check whether it's really that helpful to implement
+;;; all these functions as INLINE. (How expensive can it be to call a
+;;; 1-argument function? How expensive is it to fill up our cache with
+;;; a bunch of redundant loop expansions?)
+;;;
+;;; FIXME: Perhaps do simple benchmarks against CMU CL to check this.
+
+;;; Fill a bit vector with ones.
+(defun set-bit-vector (vec)
+ (declare (type simple-bit-vector vec))
+ (bit-orc2 vec vec t))
+
+;;; Replace the bits in To with the bits in From.
+(defun bit-vector-replace (to from)
+ (declare (type simple-bit-vector to from))
+ (bit-ior from from to))
+
+;;; Copy a bit-vector.
+(defun bit-vector-copy (vec)
+ (declare (type simple-bit-vector vec))
+ (bit-ior vec vec (make-array (length vec) :element-type 'bit)))
--- /dev/null
+;;;; that part of the byte compiler which exists not only in the
+;;;; target Lisp, but also in the cross-compilation host Lisp
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!C")
+
+(file-comment
+ "$Header$")
+
+;;;; the fasl file format that we use
+(defconstant byte-fasl-file-version 1)
+
+;;; ### remaining work:
+;;;
+;;; - add more inline operations.
+;;; - Breakpoints/debugging info.
+\f
+;;;; stuff to emit noise
+
+;;; Note: We use the regular assembler, but we don't use any
+;;; ``instructions'' because there is no way to keep our byte-code
+;;; instructions separate from the instructions used by the native
+;;; backend. Besides, we don't want to do any scheduling or anything
+;;; like that, anyway.
+
+#!-sb-fluid (declaim (inline output-byte))
+(defun output-byte (segment byte)
+ (declare (type sb!assem:segment segment)
+ (type (unsigned-byte 8) byte))
+ (sb!assem:emit-byte segment byte))
+
+;;; Output OPERAND as 1 or 4 bytes, using #xFF as the extend code.
+(defun output-extended-operand (segment operand)
+ (declare (type (unsigned-byte 24) operand))
+ (cond ((<= operand 254)
+ (output-byte segment operand))
+ (t
+ (output-byte segment #xFF)
+ (output-byte segment (ldb (byte 8 16) operand))
+ (output-byte segment (ldb (byte 8 8) operand))
+ (output-byte segment (ldb (byte 8 0) operand)))))
+
+;;; Output a byte, logior'ing in a 4 bit immediate constant. If that
+;;; immediate won't fit, then emit it as the next 1-4 bytes.
+(defun output-byte-with-operand (segment byte operand)
+ (declare (type sb!assem:segment segment)
+ (type (unsigned-byte 8) byte)
+ (type (unsigned-byte 24) operand))
+ (cond ((<= operand 14)
+ (output-byte segment (logior byte operand)))
+ (t
+ (output-byte segment (logior byte 15))
+ (output-extended-operand segment operand)))
+ (values))
+
+(defun output-label (segment label)
+ (declare (type sb!assem:segment segment)
+ (type sb!assem:label label))
+ (sb!assem:assemble (segment)
+ (sb!assem:emit-label label)))
+
+;;; Output a reference to LABEL.
+(defun output-reference (segment label)
+ (declare (type sb!assem:segment segment)
+ (type sb!assem:label label))
+ (sb!assem:emit-back-patch
+ segment
+ 3
+ #'(lambda (segment posn)
+ (declare (type sb!assem:segment segment)
+ (ignore posn))
+ (let ((target (sb!assem:label-position label)))
+ (assert (<= 0 target (1- (ash 1 24))))
+ (output-byte segment (ldb (byte 8 16) target))
+ (output-byte segment (ldb (byte 8 8) target))
+ (output-byte segment (ldb (byte 8 0) target))))))
+
+;;; Output some branch byte-sequence.
+(defun output-branch (segment kind label)
+ (declare (type sb!assem:segment segment)
+ (type (unsigned-byte 8) kind)
+ (type sb!assem:label label))
+ (sb!assem:emit-chooser
+ segment 4 1
+ #'(lambda (segment posn delta)
+ (when (<= (- (ash 1 7))
+ (- (sb!assem:label-position label posn delta) posn 2)
+ (1- (ash 1 7)))
+ (sb!assem:emit-chooser
+ segment 2 1
+ #'(lambda (segment posn delta)
+ (declare (ignore segment) (type index posn delta))
+ (when (zerop (- (sb!assem:label-position label posn delta)
+ posn 2))
+ ;; Don't emit anything, because the branch is to the following
+ ;; instruction.
+ t))
+ #'(lambda (segment posn)
+ ;; We know that we fit in one byte.
+ (declare (type sb!assem:segment segment)
+ (type index posn))
+ (output-byte segment (logior kind 1))
+ (output-byte segment
+ (ldb (byte 8 0)
+ (- (sb!assem:label-position label) posn 2)))))
+ t))
+ #'(lambda (segment posn)
+ (declare (type sb!assem:segment segment)
+ (ignore posn))
+ (let ((target (sb!assem:label-position label)))
+ (assert (<= 0 target (1- (ash 1 24))))
+ (output-byte segment kind)
+ (output-byte segment (ldb (byte 8 16) target))
+ (output-byte segment (ldb (byte 8 8) target))
+ (output-byte segment (ldb (byte 8 0) target))))))
+\f
+;;;; system constants, Xops, and inline functions
+
+;;; If (%FDEFINITION-MARKER% . NAME) is a key in the table, then the
+;;; corresponding value is the byte code fdefinition.
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defvar *system-constant-codes* (make-hash-table :test 'equal)))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (flet ((def-system-constant (index form)
+ (setf (gethash form *system-constant-codes*) index)))
+ (def-system-constant 0 nil)
+ (def-system-constant 1 t)
+ (def-system-constant 2 :start)
+ (def-system-constant 3 :end)
+ (def-system-constant 4 :test)
+ (def-system-constant 5 :count)
+ (def-system-constant 6 :test-not)
+ (def-system-constant 7 :key)
+ (def-system-constant 8 :from-end)
+ (def-system-constant 9 :type)
+ (def-system-constant 10 '(%fdefinition-marker% . error))
+ (def-system-constant 11 '(%fdefinition-marker% . format))
+ (def-system-constant 12 '(%fdefinition-marker% . %typep))
+ (def-system-constant 13 '(%fdefinition-marker% . eql))
+ (def-system-constant 14 '(%fdefinition-marker% . %negate))
+ (def-system-constant 15 '(%fdefinition-marker% . %%defun))
+ (def-system-constant 16 '(%fdefinition-marker% . %%defmacro))
+ (def-system-constant 17 '(%fdefinition-marker% . %%defconstant))
+ (def-system-constant 18 '(%fdefinition-marker% . length))
+ (def-system-constant 19 '(%fdefinition-marker% . equal))
+ (def-system-constant 20 '(%fdefinition-marker% . append))
+ (def-system-constant 21 '(%fdefinition-marker% . reverse))
+ (def-system-constant 22 '(%fdefinition-marker% . nreverse))
+ (def-system-constant 23 '(%fdefinition-marker% . nconc))
+ (def-system-constant 24 '(%fdefinition-marker% . list))
+ (def-system-constant 25 '(%fdefinition-marker% . list*))
+ (def-system-constant 26 '(%fdefinition-marker% . %coerce-name-to-function))
+ (def-system-constant 27 '(%fdefinition-marker% . values-list))))
+
+(eval-when (#+sb-xc :compile-toplevel :load-toplevel :execute)
+
+(defparameter *xop-names*
+ '(breakpoint; 0
+ dup; 1
+ type-check; 2
+ fdefn-function-or-lose; 3
+ default-unknown-values; 4
+ push-n-under; 5
+ xop6
+ xop7
+ merge-unknown-values
+ make-closure
+ throw
+ catch
+ breakup
+ return-from
+ tagbody
+ go
+ unwind-protect))
+
+(defun xop-index-or-lose (name)
+ (or (position name *xop-names* :test #'eq)
+ (error "unknown XOP ~S" name)))
+
+) ; EVAL-WHEN
+
+;;; FIXME: The hardwired 32 here (found also in (MOD 32) above, and in
+;;; the number of bits tested in EXPAND-INTO-INLINES, and perhaps
+;;; elsewhere) is ugly. There should be some symbolic constant for the
+;;; number of bits devoted to coding byte-inline functions.
+(eval-when (:compile-toplevel :load-toplevel :execute)
+
+ (defstruct inline-function-info
+ ;; the name of the function that we convert into calls to this
+ (function (required-argument) :type symbol)
+ ;; the name of the function that the interpreter should call to
+ ;; implement this. This may not be the same as the FUNCTION slot
+ ;; value if extra safety checks are required.
+ (interpreter-function (required-argument) :type symbol)
+ ;; the inline operation number, i.e. the byte value actually
+ ;; written into byte-compiled code
+ (number (required-argument) :type (mod 32))
+ ;; the type that calls must satisfy
+ (type (required-argument) :type function-type)
+ ;; Can we skip type checking of the arguments?
+ (safe (required-argument) :type boolean))
+
+ (defparameter *inline-functions* (make-array 32 :initial-element nil))
+ (defparameter *inline-function-table* (make-hash-table :test 'eq))
+ (let ((number 0))
+ (dolist (stuff
+ '((+ (fixnum fixnum) fixnum)
+ (- (fixnum fixnum) fixnum)
+ (make-value-cell (t) t)
+ (value-cell-ref (t) t)
+ (value-cell-setf (t t) (values))
+ (symbol-value (symbol) t
+ :interpreter-function %byte-symbol-value)
+ (setf-symbol-value (t symbol) (values))
+ (%byte-special-bind (t symbol) (values))
+ (%byte-special-unbind () (values))
+ (cons-unique-tag () t) ; obsolete...
+ (%negate (fixnum) fixnum)
+ (< (fixnum fixnum) t)
+ (> (fixnum fixnum) t)
+ (car (t) t :interpreter-function %byte-car :safe t)
+ (cdr (t) t :interpreter-function %byte-cdr :safe t)
+ (length (list) t)
+ (cons (t t) t)
+ (list (t t) t)
+ (list* (t t t) t)
+ (%instance-ref (t t) t)
+ (%setf-instance-ref (t t t) (values))))
+ (destructuring-bind
+ (name arg-types result-type
+ &key (interpreter-function name) alias safe)
+ stuff
+ (let ((info
+ (make-inline-function-info
+ :function name
+ :number number
+ :interpreter-function interpreter-function
+ :type (specifier-type `(function ,arg-types ,result-type))
+ :safe safe)))
+ (setf (svref *inline-functions* number) info)
+ (setf (gethash name *inline-function-table*) info))
+ (unless alias (incf number))))))
+
+(defun inline-function-number-or-lose (function)
+ (let ((info (gethash function *inline-function-table*)))
+ (if info
+ (inline-function-info-number info)
+ (error "unknown inline function: ~S" function))))
+\f
+;;;; transforms which are specific to byte code
+
+;;; It appears that the idea here is that in byte code, EQ is more
+;;; efficient than CHAR=. -- WHN 199910
+
+(deftransform eql ((x y) ((or fixnum character) (or fixnum character))
+ * :when :byte)
+ '(eq x y))
+
+(deftransform char= ((x y) * * :when :byte)
+ '(eq x y))
+\f
+;;;; annotations hung off the IR1 while compiling
+
+(defstruct byte-component-info
+ (constants (make-array 10 :adjustable t :fill-pointer 0)))
+
+(defstruct byte-lambda-info
+ (label nil :type (or null label))
+ (stack-size 0 :type index)
+ ;; FIXME: should be INTERESTING-P T :TYPE BOOLEAN
+ (interesting t :type (member t nil)))
+
+(defun block-interesting (block)
+ (byte-lambda-info-interesting (lambda-info (block-home-lambda block))))
+
+(defstruct byte-lambda-var-info
+ (argp nil :type (member t nil))
+ (offset 0 :type index))
+
+(defstruct byte-nlx-info
+ (stack-slot nil :type (or null index))
+ (label (sb!assem:gen-label) :type sb!assem:label)
+ (duplicate nil :type (member t nil)))
+
+(defstruct (byte-block-info
+ (:include block-annotation)
+ (:constructor make-byte-block-info
+ (block &key produces produces-sset consumes
+ total-consumes nlx-entries nlx-entry-p)))
+ (label (sb!assem:gen-label) :type sb!assem:label)
+ ;; A list of the CONTINUATIONs describing values that this block
+ ;; pushes onto the stack. Note: PRODUCES and CONSUMES can contain
+ ;; the keyword :NLX-ENTRY marking the place on the stack where a
+ ;; non-local-exit frame is added or removed. Since breaking up a NLX
+ ;; restores the stack, we don't have to about (and in fact must not)
+ ;; discard values underneath a :NLX-ENTRY marker evern though they
+ ;; appear to be dead (since they might not be.)
+ (produces nil :type list)
+ ;; An SSET of the produces for faster set manipulations. The
+ ;; elements are the BYTE-CONTINUATION-INFO objects. :NLX-ENTRY
+ ;; markers are not represented.
+ (produces-sset (make-sset) :type sset)
+ ;; A list of the continuations that this block pops from the stack.
+ ;; See PRODUCES.
+ (consumes nil :type list)
+ ;; The transitive closure of what this block and all its successors
+ ;; consume. After stack-analysis, that is.
+ (total-consumes (make-sset) :type sset)
+ ;; Set to T whenever the consumes lists of a successor changes and
+ ;; the block is queued for re-analysis so we can easily avoid
+ ;; queueing the same block several times.
+ (already-queued nil :type (member t nil))
+ ;; The continuations and :NLX-ENTRY markers on the stack (in order)
+ ;; when this block starts.
+ (start-stack :unknown :type (or (member :unknown) list))
+ ;; The continuations and :NLX-ENTRY markers on the stack (in order)
+ ;; when this block ends.
+ (end-stack nil :type list)
+ ;; List of ((nlx-info*) produces consumes) for each ENTRY in this
+ ;; block that is a NLX target.
+ (nlx-entries nil :type list)
+ ;; T if this is an %nlx-entry point, and we shouldn't just assume we
+ ;; know what is going to be on the stack.
+ (nlx-entry-p nil :type (member t nil)))
+
+(defprinter (byte-block-info)
+ block)
+
+(defstruct (byte-continuation-info
+ (:include sset-element)
+ (:constructor make-byte-continuation-info
+ (continuation results placeholders)))
+ (continuation (required-argument) :type continuation)
+ (results (required-argument)
+ :type (or (member :fdefinition :eq-test :unknown) index))
+ ;; If the DEST is a local non-MV call, then we may need to push some
+ ;; number of placeholder args corresponding to deleted
+ ;; (unreferenced) args. If PLACEHOLDERS /= 0, then RESULTS is
+ ;; PLACEHOLDERS + 1.
+ (placeholders (required-argument) :type index))
+
+(defprinter (byte-continuation-info)
+ continuation
+ results
+ (placeholders :test (/= placeholders 0)))
+\f
+;;;; Annotate the IR1.
+
+(defun annotate-continuation (cont results &optional (placeholders 0))
+ ;; For some reason, DO-NODES does the same return node multiple
+ ;; times, which causes ANNOTATE-CONTINUATION to be called multiple
+ ;; times on the same continuation. So we can't assert that we
+ ;; haven't done it.
+ #+nil
+ (assert (null (continuation-info cont)))
+ (setf (continuation-info cont)
+ (make-byte-continuation-info cont results placeholders))
+ (values))
+
+(defun annotate-set (set)
+ ;; Annotate the value for one value.
+ (annotate-continuation (set-value set) 1))
+
+;;; We do different stack magic for non-MV and MV calls to figure out
+;;; how many values should be pushed during compilation of each arg.
+;;;
+;;; Since byte functions are directly caller by the interpreter (there
+;;; is no XEP), and it doesn't know which args are actually used, byte
+;;; functions must allow unused args to be passed. But this creates a
+;;; problem with local calls, because these unused args would not
+;;; otherwise be pushed (since the continuation has been deleted.) So,
+;;; in this function, we count up placeholders for any unused args
+;;; contiguously preceding this one. These placeholders are inserted
+;;; under the referenced arg by CHECKED-CANONICALIZE-VALUES.
+;;;
+;;; With MV calls, we try to figure out how many values are actually
+;;; generated. We allow initial args to supply a fixed number of
+;;; values, but everything after the first :unknown arg must also be
+;;; unknown. This picks off most of the standard uses (i.e. calls to
+;;; apply), but still is easy to implement.
+(defun annotate-basic-combination-args (call)
+ (declare (type basic-combination call))
+ (etypecase call
+ (combination
+ (if (and (eq (basic-combination-kind call) :local)
+ (member (functional-kind (combination-lambda call))
+ '(nil :optional :cleanup)))
+ (let ((placeholders 0))
+ (declare (type index placeholders))
+ (dolist (arg (combination-args call))
+ (cond (arg
+ (annotate-continuation arg (1+ placeholders) placeholders)
+ (setq placeholders 0))
+ (t
+ (incf placeholders)))))
+ (dolist (arg (combination-args call))
+ (when arg
+ (annotate-continuation arg 1)))))
+ (mv-combination
+ (labels
+ ((allow-fixed (remaining)
+ (when remaining
+ (let* ((cont (car remaining))
+ (values (nth-value 1
+ (values-types
+ (continuation-derived-type cont)))))
+ (cond ((eq values :unknown)
+ (force-to-unknown remaining))
+ (t
+ (annotate-continuation cont values)
+ (allow-fixed (cdr remaining)))))))
+ (force-to-unknown (remaining)
+ (when remaining
+ (let ((cont (car remaining)))
+ (when cont
+ (annotate-continuation cont :unknown)))
+ (force-to-unknown (cdr remaining)))))
+ (allow-fixed (mv-combination-args call)))))
+ (values))
+
+(defun annotate-local-call (call)
+ (cond ((mv-combination-p call)
+ (annotate-continuation
+ (first (basic-combination-args call))
+ (length (lambda-vars (combination-lambda call)))))
+ (t
+ (annotate-basic-combination-args call)
+ (when (member (functional-kind (combination-lambda call))
+ '(nil :optional :cleanup))
+ (dolist (arg (basic-combination-args call))
+ (when arg
+ (setf (continuation-%type-check arg) nil))))))
+ (annotate-continuation (basic-combination-fun call) 0)
+ (when (node-tail-p call)
+ (set-tail-local-call-successor call)))
+
+;;; Annotate the values for any :full combination. This includes
+;;; inline functions, multiple value calls & throw. If a real full
+;;; call or a safe inline operation, then clear any type-check
+;;; annotations. When we are done, remove jump to return for tail
+;;; calls.
+;;;
+;;; Also, we annotate slot accessors as inline if no type check is
+;;; needed and (for setters) no value needs to be left on the stack.
+(defun annotate-full-call (call)
+ (let* ((fun (basic-combination-fun call))
+ (args (basic-combination-args call))
+ (name (continuation-function-name fun))
+ (info (gethash name *inline-function-table*)))
+ (flet ((annotate-args ()
+ (annotate-basic-combination-args call)
+ (dolist (arg args)
+ (when (continuation-type-check arg)
+ (setf (continuation-%type-check arg) :deleted)))
+ (annotate-continuation
+ fun
+ (if (continuation-function-name fun) :fdefinition 1))))
+ (cond ((mv-combination-p call)
+ (cond ((eq name '%throw)
+ (assert (= (length args) 2))
+ (annotate-continuation (first args) 1)
+ (annotate-continuation (second args) :unknown)
+ (setf (node-tail-p call) nil)
+ (annotate-continuation fun 0))
+ (t
+ (annotate-args))))
+ ((and info
+ (valid-function-use call (inline-function-info-type info)))
+ (annotate-basic-combination-args call)
+ (setf (node-tail-p call) nil)
+ (setf (basic-combination-info call) info)
+ (annotate-continuation fun 0)
+ (when (inline-function-info-safe info)
+ (dolist (arg args)
+ (when (continuation-type-check arg)
+ (setf (continuation-%type-check arg) :deleted)))))
+ ((and name
+ (let ((leaf (ref-leaf (continuation-use fun))))
+ (and (slot-accessor-p leaf)
+ (or (policy call (zerop safety))
+ (not (find 't args
+ :key #'continuation-type-check)))
+ (if (consp name)
+ (not (continuation-dest (node-cont call)))
+ t))))
+ (setf (basic-combination-info call)
+ (gethash (if (consp name) '%setf-instance-ref '%instance-ref)
+ *inline-function-table*))
+ (setf (node-tail-p call) nil)
+ (annotate-continuation fun 0)
+ (annotate-basic-combination-args call))
+ (t
+ (annotate-args)))))
+
+ ;; If this is (still) a tail-call, then blow away the return.
+ (when (node-tail-p call)
+ (node-ends-block call)
+ (let ((block (node-block call)))
+ (unlink-blocks block (first (block-succ block)))
+ (link-blocks block (component-tail (block-component block)))))
+
+ (values))
+
+(defun annotate-known-call (call)
+ (annotate-basic-combination-args call)
+ (setf (node-tail-p call) nil)
+ (annotate-continuation (basic-combination-fun call) 0)
+ t)
+
+(defun annotate-basic-combination (call)
+ ;; Annotate the function.
+ (let ((kind (basic-combination-kind call)))
+ (case kind
+ (:local
+ (annotate-local-call call))
+ (:full
+ (annotate-full-call call))
+ (:error
+ (setf (basic-combination-kind call) :full)
+ (annotate-full-call call))
+ (t
+ (unless (and (function-info-byte-compile kind)
+ (funcall (or (function-info-byte-annotate kind)
+ #'annotate-known-call)
+ call))
+ (setf (basic-combination-kind call) :full)
+ (annotate-full-call call)))))
+
+ (values))
+
+(defun annotate-if (if)
+ ;; Annotate the test.
+ (let* ((cont (if-test if))
+ (use (continuation-use cont)))
+ (annotate-continuation
+ cont
+ (if (and (combination-p use)
+ (eq (continuation-function-name (combination-fun use)) 'eq)
+ (= (length (combination-args use)) 2))
+ ;; If the test is a call to EQ, then we can use branch-if-eq
+ ;; so don't need to actually funcall the test.
+ :eq-test
+ ;; Otherwise, funcall the test for 1 value.
+ 1))))
+
+(defun annotate-return (return)
+ (let ((cont (return-result return)))
+ (annotate-continuation
+ cont
+ (nth-value 1 (values-types (continuation-derived-type cont))))))
+
+(defun annotate-exit (exit)
+ (let ((cont (exit-value exit)))
+ (when cont
+ (annotate-continuation cont :unknown))))
+
+(defun annotate-block (block)
+ (do-nodes (node cont block)
+ (etypecase node
+ (bind)
+ (ref)
+ (cset (annotate-set node))
+ (basic-combination (annotate-basic-combination node))
+ (cif (annotate-if node))
+ (creturn (annotate-return node))
+ (entry)
+ (exit (annotate-exit node))))
+ (values))
+
+(defun annotate-ir1 (component)
+ (do-blocks (block component)
+ (when (block-interesting block)
+ (annotate-block block)))
+ (values))
+\f
+;;;; stack analysis
+
+(defvar *byte-continuation-counter*)
+
+;;; Scan the nodes in BLOCK and compute the information that we will
+;;; need to do flow analysis and our stack simulation walk. We simulate
+;;; the stack within the block, reducing it to ordered lists
+;;; representing the values we remove from the top of the stack and
+;;; place on the stack (not considering values that are produced and
+;;; consumed within the block.) A NLX entry point is considered to
+;;; push a :NLX-ENTRY marker (can be though of as the run-time catch
+;;; frame.)
+(defun compute-produces-and-consumes (block)
+ (let ((stack nil)
+ (consumes nil)
+ (total-consumes (make-sset))
+ (nlx-entries nil)
+ (nlx-entry-p nil))
+ (labels ((interesting (cont)
+ (and cont
+ (let ((info (continuation-info cont)))
+ (and info
+ (not (member (byte-continuation-info-results info)
+ '(0 :eq-test)))))))
+ (consume (cont)
+ (cond ((not (or (eq cont :nlx-entry) (interesting cont))))
+ (stack
+ (assert (eq (car stack) cont))
+ (pop stack))
+ (t
+ (adjoin-cont cont total-consumes)
+ (push cont consumes))))
+ (adjoin-cont (cont sset)
+ (unless (eq cont :nlx-entry)
+ (let ((info (continuation-info cont)))
+ (unless (byte-continuation-info-number info)
+ (setf (byte-continuation-info-number info)
+ (incf *byte-continuation-counter*)))
+ (sset-adjoin info sset)))))
+ (do-nodes (node cont block)
+ (etypecase node
+ (bind)
+ (ref)
+ (cset
+ (consume (set-value node)))
+ (basic-combination
+ (dolist (arg (reverse (basic-combination-args node)))
+ (when arg
+ (consume arg)))
+ (consume (basic-combination-fun node))
+ (case (continuation-function-name (basic-combination-fun node))
+ (%nlx-entry
+ (let ((nlx-info (continuation-value
+ (first (basic-combination-args node)))))
+ (ecase (cleanup-kind (nlx-info-cleanup nlx-info))
+ ((:catch :unwind-protect)
+ (consume :nlx-entry))
+ ;; If for a lexical exit, we will see a breakup later, so
+ ;; don't consume :NLX-ENTRY now.
+ (:tagbody)
+ (:block
+ (let ((cont (nlx-info-continuation nlx-info)))
+ (when (interesting cont)
+ (push cont stack))))))
+ (setf nlx-entry-p t))
+ (%lexical-exit-breakup
+ (unless (byte-nlx-info-duplicate
+ (nlx-info-info
+ (continuation-value
+ (first (basic-combination-args node)))))
+ (consume :nlx-entry)))
+ ((%catch-breakup %unwind-protect-breakup)
+ (consume :nlx-entry))))
+ (cif
+ (consume (if-test node)))
+ (creturn
+ (consume (return-result node)))
+ (entry
+ (let* ((cup (entry-cleanup node))
+ (nlx-info (cleanup-nlx-info cup)))
+ (when nlx-info
+ (push :nlx-entry stack)
+ (push (list nlx-info stack (reverse consumes))
+ nlx-entries))))
+ (exit
+ (when (exit-value node)
+ (consume (exit-value node)))))
+ (when (and (not (exit-p node)) (interesting cont))
+ (push cont stack)))
+
+ (setf (block-info block)
+ (make-byte-block-info
+ block
+ :produces stack
+ :produces-sset (let ((res (make-sset)))
+ (dolist (product stack)
+ (adjoin-cont product res))
+ res)
+ :consumes (reverse consumes)
+ :total-consumes total-consumes
+ :nlx-entries nlx-entries
+ :nlx-entry-p nlx-entry-p))))
+
+ (values))
+
+(defun walk-successors (block stack)
+ (let ((tail (component-tail (block-component block))))
+ (dolist (succ (block-succ block))
+ (unless (or (eq succ tail)
+ (not (block-interesting succ))
+ (byte-block-info-nlx-entry-p (block-info succ)))
+ (walk-block succ block stack)))))
+
+;;; Take a stack and a consumes list, and remove the appropriate
+;;; stuff. When we consume a :NLX-ENTRY, we just remove the top
+;;; marker, and leave any values on top intact. This represents the
+;;; desired effect of %CATCH-BREAKUP, etc., which don't affect any
+;;; values on the stack.
+(defun consume-stuff (stack stuff)
+ (let ((new-stack stack))
+ (dolist (cont stuff)
+ (cond ((eq cont :nlx-entry)
+ (assert (find :nlx-entry new-stack))
+ (setq new-stack (remove :nlx-entry new-stack :count 1)))
+ (t
+ (assert (eq (car new-stack) cont))
+ (pop new-stack))))
+ new-stack))
+
+;;; NLX-INFOS is the list of NLX-INFO structures for this ENTRY note.
+;;; CONSUME and PRODUCE are the values from outside this block that
+;;; were consumed and produced by this block before the ENTRY node.
+;;; STACK is the globally simulated stack at the start of this block.
+(defun walk-nlx-entry (nlx-infos stack produce consume)
+ (let ((stack (consume-stuff stack consume)))
+ (dolist (nlx-info nlx-infos)
+ (walk-block (nlx-info-target nlx-info) nil (append produce stack))))
+ (values))
+
+;;; Simulate the stack across block boundaries, discarding any values
+;;; that are dead. A :NLX-ENTRY marker prevents values live at a NLX
+;;; entry point from being discarded prematurely.
+(defun walk-block (block pred stack)
+ ;; Pop everything off of stack that isn't live.
+ (let* ((info (block-info block))
+ (live (byte-block-info-total-consumes info)))
+ (collect ((pops))
+ (let ((fixed 0))
+ (flet ((flush-fixed ()
+ (unless (zerop fixed)
+ (pops `(%byte-pop-stack ,fixed))
+ (setf fixed 0))))
+ (loop
+ (unless stack
+ (return))
+ (let ((cont (car stack)))
+ (when (or (eq cont :nlx-entry)
+ (sset-member (continuation-info cont) live))
+ (return))
+ (pop stack)
+ (let ((results
+ (byte-continuation-info-results
+ (continuation-info cont))))
+ (case results
+ (:unknown
+ (flush-fixed)
+ (pops `(%byte-pop-stack 0)))
+ (:fdefinition
+ (incf fixed))
+ (t
+ (incf fixed results))))))
+ (flush-fixed)))
+ (when (pops)
+ (assert pred)
+ (let ((cleanup-block
+ (insert-cleanup-code pred block
+ (continuation-next (block-start block))
+ `(progn ,@(pops)))))
+ (annotate-block cleanup-block))))
+
+ (cond ((eq (byte-block-info-start-stack info) :unknown)
+ ;; Record what the stack looked like at the start of this block.
+ (setf (byte-block-info-start-stack info) stack)
+ ;; Process any nlx entries that build off of our stack.
+ (dolist (stuff (byte-block-info-nlx-entries info))
+ (walk-nlx-entry (first stuff) stack (second stuff) (third stuff)))
+ ;; Remove whatever we consume.
+ (setq stack (consume-stuff stack (byte-block-info-consumes info)))
+ ;; Add whatever we produce.
+ (setf stack (append (byte-block-info-produces info) stack))
+ (setf (byte-block-info-end-stack info) stack)
+ ;; Pass that on to all our successors.
+ (walk-successors block stack))
+ (t
+ ;; We have already processed the successors of this block. Just
+ ;; make sure we thing the stack is the same now as before.
+ (assert (equal (byte-block-info-start-stack info) stack)))))
+ (values))
+
+;;; Do lifetime flow analysis on values pushed on the stack, then call
+;;; do the stack simulation walk to discard dead values. In addition
+;;; to considering the obvious inputs from a block's successors, we
+;;; must also consider %NLX-ENTRY targets to be successors in order to
+;;; ensure that any values only used in the NLX entry stay alive until
+;;; we reach the mess-up node. After then, we can keep the values from
+;;; being discarded by placing a marker on the simulated stack.
+(defun byte-stack-analyze (component)
+ (let ((head nil))
+ (let ((*byte-continuation-counter* 0))
+ (do-blocks (block component)
+ (when (block-interesting block)
+ (compute-produces-and-consumes block)
+ (push block head)
+ (setf (byte-block-info-already-queued (block-info block)) t))))
+ (let ((tail (last head)))
+ (labels ((maybe-enqueue (block)
+ (when (block-interesting block)
+ (let ((info (block-info block)))
+ (unless (byte-block-info-already-queued info)
+ (setf (byte-block-info-already-queued info) t)
+ (let ((new (list block)))
+ (if head
+ (setf (cdr tail) new)
+ (setf head new))
+ (setf tail new))))))
+ (maybe-enqueue-predecessors (block)
+ (when (byte-block-info-nlx-entry-p (block-info block))
+ (maybe-enqueue
+ (node-block
+ (cleanup-mess-up
+ (nlx-info-cleanup
+ (find block
+ (environment-nlx-info (block-environment block))
+ :key #'nlx-info-target))))))
+
+ (dolist (pred (block-pred block))
+ (unless (eq pred (component-head (block-component block)))
+ (maybe-enqueue pred)))))
+ (loop
+ (unless head
+ (return))
+ (let* ((block (pop head))
+ (info (block-info block))
+ (total-consumes (byte-block-info-total-consumes info))
+ (produces-sset (byte-block-info-produces-sset info))
+ (did-anything nil))
+ (setf (byte-block-info-already-queued info) nil)
+ (dolist (succ (block-succ block))
+ (unless (eq succ (component-tail component))
+ (let ((succ-info (block-info succ)))
+ (when (sset-union-of-difference
+ total-consumes
+ (byte-block-info-total-consumes succ-info)
+ produces-sset)
+ (setf did-anything t)))))
+ (dolist (nlx-list (byte-block-info-nlx-entries info))
+ (dolist (nlx-info (first nlx-list))
+ (when (sset-union-of-difference
+ total-consumes
+ (byte-block-info-total-consumes
+ (block-info
+ (nlx-info-target nlx-info)))
+ produces-sset)
+ (setf did-anything t))))
+ (when did-anything
+ (maybe-enqueue-predecessors block)))))))
+
+ (walk-successors (component-head component) nil)
+ (values))
+\f
+;;;; Actually generate the byte code.
+
+(defvar *byte-component-info*)
+
+(eval-when (#+sb-xc :compile-toplevel :load-toplevel :execute)
+ (defconstant byte-push-local #b00000000)
+ (defconstant byte-push-arg #b00010000)
+ (defconstant byte-push-constant #b00100000)
+ (defconstant byte-push-system-constant #b00110000)
+ (defconstant byte-push-int #b01000000)
+ (defconstant byte-push-neg-int #b01010000)
+ (defconstant byte-pop-local #b01100000)
+ (defconstant byte-pop-n #b01110000)
+ (defconstant byte-call #b10000000)
+ (defconstant byte-tail-call #b10010000)
+ (defconstant byte-multiple-call #b10100000)
+ (defconstant byte-named #b00001000)
+ (defconstant byte-local-call #b10110000)
+ (defconstant byte-local-tail-call #b10111000)
+ (defconstant byte-local-multiple-call #b11000000)
+ (defconstant byte-return #b11001000)
+ (defconstant byte-branch-always #b11010000)
+ (defconstant byte-branch-if-true #b11010010)
+ (defconstant byte-branch-if-false #b11010100)
+ (defconstant byte-branch-if-eq #b11010110)
+ (defconstant byte-xop #b11011000)
+ (defconstant byte-inline-function #b11100000))
+
+(defun output-push-int (segment int)
+ (declare (type sb!assem:segment segment)
+ (type (integer #.(- (ash 1 24)) #.(1- (ash 1 24)))))
+ (if (minusp int)
+ (output-byte-with-operand segment byte-push-neg-int (- (1+ int)))
+ (output-byte-with-operand segment byte-push-int int)))
+
+(defun output-push-constant-leaf (segment constant)
+ (declare (type sb!assem:segment segment)
+ (type constant constant))
+ (let ((info (constant-info constant)))
+ (if info
+ (output-byte-with-operand segment
+ (ecase (car info)
+ (:system-constant
+ byte-push-system-constant)
+ (:local-constant
+ byte-push-constant))
+ (cdr info))
+ (let ((const (constant-value constant)))
+ (if (and (integerp const) (< (- (ash 1 24)) const (ash 1 24)))
+ ;; It can be represented as an immediate.
+ (output-push-int segment const)
+ ;; We need to store it in the constants pool.
+ (let* ((posn
+ (unless (and (consp const)
+ (eq (car const) '%fdefinition-marker%))
+ (gethash const *system-constant-codes*)))
+ (new-info (if posn
+ (cons :system-constant posn)
+ (cons :local-constant
+ (vector-push-extend
+ constant
+ (byte-component-info-constants
+ *byte-component-info*))))))
+ (setf (constant-info constant) new-info)
+ (output-push-constant-leaf segment constant)))))))
+
+(defun output-push-constant (segment value)
+ (if (and (integerp value)
+ (< (- (ash 1 24)) value (ash 1 24)))
+ (output-push-int segment value)
+ (output-push-constant-leaf segment (find-constant value))))
+
+;;; Return the offset of a load-time constant in the constant pool,
+;;; adding it if absent.
+(defun byte-load-time-constant-index (kind datum)
+ (let ((constants (byte-component-info-constants *byte-component-info*)))
+ (or (position-if #'(lambda (x)
+ (and (consp x)
+ (eq (car x) kind)
+ (typecase datum
+ (cons (equal (cdr x) datum))
+ (ctype (type= (cdr x) datum))
+ (t
+ (eq (cdr x) datum)))))
+ constants)
+ (vector-push-extend (cons kind datum) constants))))
+
+(defun output-push-load-time-constant (segment kind datum)
+ (output-byte-with-operand segment byte-push-constant
+ (byte-load-time-constant-index kind datum))
+ (values))
+
+(defun output-do-inline-function (segment function)
+ ;; Note: we don't annotate this as a call site, because it is used
+ ;; for internal stuff. Functions that get inlined have code
+ ;; locations added byte generate-byte-code-for-full-call below.
+ (output-byte segment
+ (logior byte-inline-function
+ (inline-function-number-or-lose function))))
+
+(defun output-do-xop (segment xop)
+ (let ((index (xop-index-or-lose xop)))
+ (cond ((< index 7)
+ (output-byte segment (logior byte-xop index)))
+ (t
+ (output-byte segment (logior byte-xop 7))
+ (output-byte segment index)))))
+
+(defun closure-position (var env)
+ (or (position var (environment-closure env))
+ (error "Can't find ~S" var)))
+
+(defun output-ref-lambda-var (segment var env
+ &optional (indirect-value-cells t))
+ (declare (type sb!assem:segment segment)
+ (type lambda-var var)
+ (type environment env))
+ (if (eq (lambda-environment (lambda-var-home var)) env)
+ (let ((info (leaf-info var)))
+ (output-byte-with-operand segment
+ (if (byte-lambda-var-info-argp info)
+ byte-push-arg
+ byte-push-local)
+ (byte-lambda-var-info-offset info)))
+ (output-byte-with-operand segment
+ byte-push-arg
+ (closure-position var env)))
+ (when (and indirect-value-cells (lambda-var-indirect var))
+ (output-do-inline-function segment 'value-cell-ref)))
+
+(defun output-ref-nlx-info (segment info env)
+ (if (eq (node-environment (cleanup-mess-up (nlx-info-cleanup info))) env)
+ (output-byte-with-operand segment
+ byte-push-local
+ (byte-nlx-info-stack-slot
+ (nlx-info-info info)))
+ (output-byte-with-operand segment
+ byte-push-arg
+ (closure-position info env))))
+
+(defun output-set-lambda-var (segment var env &optional make-value-cells)
+ (declare (type sb!assem:segment segment)
+ (type lambda-var var)
+ (type environment env))
+ (let ((indirect (lambda-var-indirect var)))
+ (cond ((not (eq (lambda-environment (lambda-var-home var)) env))
+ ;; This is not this guy's home environment. So we need to
+ ;; get it the value cell out of the closure, and fill it in.
+ (assert indirect)
+ (assert (not make-value-cells))
+ (output-byte-with-operand segment byte-push-arg
+ (closure-position var env))
+ (output-do-inline-function segment 'value-cell-setf))
+ (t
+ (let* ((pushp (and indirect (not make-value-cells)))
+ (byte-code (if pushp byte-push-local byte-pop-local))
+ (info (leaf-info var)))
+ (assert (not (byte-lambda-var-info-argp info)))
+ (when (and indirect make-value-cells)
+ ;; Replace the stack top with a value cell holding the
+ ;; stack top.
+ (output-do-inline-function segment 'make-value-cell))
+ (output-byte-with-operand segment byte-code
+ (byte-lambda-var-info-offset info))
+ (when pushp
+ (output-do-inline-function segment 'value-cell-setf)))))))
+
+;;; Output whatever noise is necessary to canonicalize the values on
+;;; the top of the stack. DESIRED is the number we want, and SUPPLIED
+;;; is the number we have. Either push NIL or pop-n to make them
+;;; balanced. Note: either desired or supplied can be :unknown, in
+;;; which case it means use the ``unknown-values'' convention (which
+;;; is the stack values followed by the number of values).
+(defun canonicalize-values (segment desired supplied)
+ (declare (type sb!assem:segment segment)
+ (type (or (member :unknown) index) desired supplied))
+ (cond ((eq desired :unknown)
+ (unless (eq supplied :unknown)
+ (output-byte-with-operand segment byte-push-int supplied)))
+ ((eq supplied :unknown)
+ (unless (eq desired :unknown)
+ (output-push-int segment desired)
+ (output-do-xop segment 'default-unknown-values)))
+ ((< supplied desired)
+ (dotimes (i (- desired supplied))
+ (output-push-constant segment nil)))
+ ((> supplied desired)
+ (output-byte-with-operand segment byte-pop-n (- supplied desired))))
+ (values))
+
+(defparameter *byte-type-weakenings*
+ (mapcar #'specifier-type
+ '(fixnum single-float double-float simple-vector simple-bit-vector
+ bit-vector)))
+
+;;; Emit byte code to check that the value on top of the stack is of
+;;; the specified TYPE. NODE is used for policy information. We weaken
+;;; or entirely omit the type check whether speed is more important
+;;; than safety.
+(defun byte-generate-type-check (segment type node)
+ (declare (type ctype type) (type node node))
+ (unless (or (policy node (zerop safety))
+ (csubtypep *universal-type* type))
+ (let ((type (if (policy node (> speed safety))
+ (dolist (super *byte-type-weakenings* type)
+ (when (csubtypep type super) (return super)))
+ type)))
+ (output-do-xop segment 'type-check)
+ (output-extended-operand
+ segment
+ (byte-load-time-constant-index :type-predicate type)))))
+
+;;; This function is used when we are generating code which delivers
+;;; values to a continuation. If this continuation needs a type check,
+;;; and has a single value, then we do a type check. We also
+;;; CANONICALIZE-VALUES for the continuation's desired number of
+;;; values (w/o the placeholders.)
+;;;
+;;; Somewhat unrelatedly, we also push placeholders for deleted
+;;; arguments to local calls. Although we check first, the actual
+;;; PUSH-N-UNDER is done afterward, since then the single value we
+;;; want is stack top.
+(defun checked-canonicalize-values (segment cont supplied)
+ (let ((info (continuation-info cont)))
+ (if info
+ (let ((desired (byte-continuation-info-results info))
+ (placeholders (byte-continuation-info-placeholders info)))
+ (unless (zerop placeholders)
+ (assert (eql desired (1+ placeholders)))
+ (setq desired 1))
+
+ (flet ((do-check ()
+ (byte-generate-type-check
+ segment
+ (single-value-type (continuation-asserted-type cont))
+ (continuation-dest cont))))
+ (cond
+ ((member (continuation-type-check cont) '(nil :deleted))
+ (canonicalize-values segment desired supplied))
+ ((eql supplied 1)
+ (do-check)
+ (canonicalize-values segment desired supplied))
+ ((eql desired 1)
+ (canonicalize-values segment desired supplied)
+ (do-check))
+ (t
+ (canonicalize-values segment desired supplied))))
+
+ (unless (zerop placeholders)
+ (output-do-xop segment 'push-n-under)
+ (output-extended-operand segment placeholders)))
+
+ (canonicalize-values segment 0 supplied))))
+
+;;; Emit prologue for non-LET functions. Assigned arguments must be
+;;; copied into locals, and argument type checking may need to be done.
+(defun generate-byte-code-for-bind (segment bind cont)
+ (declare (type sb!assem:segment segment) (type bind bind)
+ (ignore cont))
+ (let ((lambda (bind-lambda bind))
+ (env (node-environment bind)))
+ (ecase (lambda-kind lambda)
+ ((nil :top-level :escape :cleanup :optional)
+ (let* ((info (lambda-info lambda))
+ (type-check (policy (lambda-bind lambda) (not (zerop safety))))
+ (frame-size (byte-lambda-info-stack-size info)))
+ (cond ((< frame-size (* 255 2))
+ (output-byte segment (ceiling frame-size 2)))
+ (t
+ (output-byte segment 255)
+ (output-byte segment (ldb (byte 8 16) frame-size))
+ (output-byte segment (ldb (byte 8 8) frame-size))
+ (output-byte segment (ldb (byte 8 0) frame-size))))
+
+ (do ((argnum (1- (+ (length (lambda-vars lambda))
+ (length (environment-closure
+ (lambda-environment lambda)))))
+ (1- argnum))
+ (vars (lambda-vars lambda) (cdr vars))
+ (pops 0))
+ ((null vars)
+ (unless (zerop pops)
+ (output-byte-with-operand segment byte-pop-n pops)))
+ (declare (fixnum argnum pops))
+ (let* ((var (car vars))
+ (info (lambda-var-info var))
+ (type (leaf-type var)))
+ (cond ((not info))
+ ((byte-lambda-var-info-argp info)
+ (when (and type-check
+ (not (csubtypep *universal-type* type)))
+ (output-byte-with-operand segment byte-push-arg argnum)
+ (byte-generate-type-check segment type bind)
+ (incf pops)))
+ (t
+ (output-byte-with-operand segment byte-push-arg argnum)
+ (when type-check
+ (byte-generate-type-check segment type bind))
+ (output-set-lambda-var segment var env t)))))))
+
+ ;; Everything has been taken care of in the combination node.
+ ((:let :mv-let :assignment))))
+ (values))
+
+;;; This hashtable translates from n-ary function names to the
+;;; two-arg-specific versions which we call to avoid &REST-arg consing.
+(defvar *two-arg-functions* (make-hash-table :test 'eq))
+
+(dolist (fun '((sb!kernel:two-arg-ior logior)
+ (sb!kernel:two-arg-* *)
+ (sb!kernel:two-arg-+ +)
+ (sb!kernel:two-arg-/ /)
+ (sb!kernel:two-arg-- -)
+ (sb!kernel:two-arg-> >)
+ (sb!kernel:two-arg-< <)
+ (sb!kernel:two-arg-= =)
+ (sb!kernel:two-arg-lcm lcm)
+ (sb!kernel:two-arg-and logand)
+ (sb!kernel:two-arg-gcd gcd)
+ (sb!kernel:two-arg-xor logxor)
+
+ (two-arg-char= char=)
+ (two-arg-char< char<)
+ (two-arg-char> char>)
+ (two-arg-char-equal char-equal)
+ (two-arg-char-lessp char-lessp)
+ (two-arg-char-greaterp char-greaterp)
+ (two-arg-string= string=)
+ (two-arg-string< string<)
+ (two-arg-string> string>)))
+
+ (setf (gethash (second fun) *two-arg-functions*) (first fun)))
+
+;;; If a system constant, push that, otherwise use a load-time constant.
+(defun output-push-fdefinition (segment name)
+ (let ((offset (gethash `(%fdefinition-marker% . ,name)
+ *system-constant-codes*)))
+ (if offset
+ (output-byte-with-operand segment byte-push-system-constant
+ offset)
+ (output-push-load-time-constant segment :fdefinition name))))
+
+(defun generate-byte-code-for-ref (segment ref cont)
+ (declare (type sb!assem:segment segment) (type ref ref)
+ (type continuation cont))
+ (let ((info (continuation-info cont)))
+ ;; If there is no info, then nobody wants the result.
+ (when info
+ (let ((values (byte-continuation-info-results info))
+ (leaf (ref-leaf ref)))
+ (cond
+ ((eq values :fdefinition)
+ (assert (and (global-var-p leaf)
+ (eq (global-var-kind leaf)
+ :global-function)))
+ (let* ((name (global-var-name leaf))
+ (found (gethash name *two-arg-functions*)))
+ (output-push-fdefinition
+ segment
+ (if (and found
+ (= (length (combination-args (continuation-dest cont)))
+ 2))
+ found
+ name))))
+ ((eql values 0)
+ ;; Real easy!
+ nil)
+ (t
+ (etypecase leaf
+ (constant
+ (output-push-constant-leaf segment leaf))
+ (clambda
+ (let* ((refered-env (lambda-environment leaf))
+ (closure (environment-closure refered-env)))
+ (if (null closure)
+ (output-push-load-time-constant segment :entry leaf)
+ (let ((my-env (node-environment ref)))
+ (output-push-load-time-constant segment :entry leaf)
+ (dolist (thing closure)
+ (etypecase thing
+ (lambda-var
+ (output-ref-lambda-var segment thing my-env nil))
+ (nlx-info
+ (output-ref-nlx-info segment thing my-env))))
+ (output-push-int segment (length closure))
+ (output-do-xop segment 'make-closure)))))
+ (functional
+ (output-push-load-time-constant segment :entry leaf))
+ (lambda-var
+ (output-ref-lambda-var segment leaf (node-environment ref)))
+ (global-var
+ (ecase (global-var-kind leaf)
+ ((:special :global :constant)
+ (output-push-constant segment (global-var-name leaf))
+ (output-do-inline-function segment 'symbol-value))
+ (:global-function
+ (output-push-fdefinition segment (global-var-name leaf))
+ (output-do-xop segment 'fdefn-function-or-lose)))))
+ (checked-canonicalize-values segment cont 1))))))
+ (values))
+
+(defun generate-byte-code-for-set (segment set cont)
+ (declare (type sb!assem:segment segment) (type cset set)
+ (type continuation cont))
+ (let* ((leaf (set-var set))
+ (info (continuation-info cont))
+ (values (if info
+ (byte-continuation-info-results info)
+ 0)))
+ (unless (eql values 0)
+ ;; Someone wants the value, so copy it.
+ (output-do-xop segment 'dup))
+ (etypecase leaf
+ (global-var
+ (ecase (global-var-kind leaf)
+ ((:special :global)
+ (output-push-constant segment (global-var-name leaf))
+ (output-do-inline-function segment 'setf-symbol-value))))
+ (lambda-var
+ (output-set-lambda-var segment leaf (node-environment set))))
+ (unless (eql values 0)
+ (checked-canonicalize-values segment cont 1)))
+ (values))
+
+(defun generate-byte-code-for-local-call (segment call cont num-args)
+ (let* ((lambda (combination-lambda call))
+ (vars (lambda-vars lambda))
+ (env (lambda-environment lambda)))
+ (ecase (functional-kind lambda)
+ ((:let :assignment)
+ (dolist (var (reverse vars))
+ (when (lambda-var-refs var)
+ (output-set-lambda-var segment var env t))))
+ (:mv-let
+ (let ((do-check (member (continuation-type-check
+ (first (basic-combination-args call)))
+ '(t :error))))
+ (dolist (var (reverse vars))
+ (when do-check
+ (byte-generate-type-check segment (leaf-type var) call))
+ (output-set-lambda-var segment var env t))))
+ ((nil :optional :cleanup)
+ ;; We got us a local call.
+ (assert (not (eq num-args :unknown)))
+ ;; Push any trailing placeholder args...
+ (dolist (x (reverse (basic-combination-args call)))
+ (when x (return))
+ (output-push-int segment 0))
+ ;; Then push closure vars.
+ (let ((closure (environment-closure env)))
+ (when closure
+ (let ((my-env (node-environment call)))
+ (dolist (thing (reverse closure))
+ (etypecase thing
+ (lambda-var
+ (output-ref-lambda-var segment thing my-env nil))
+ (nlx-info
+ (output-ref-nlx-info segment thing my-env)))))
+ (incf num-args (length closure))))
+ (let ((results
+ (let ((info (continuation-info cont)))
+ (if info
+ (byte-continuation-info-results info)
+ 0))))
+ ;; Emit the op for whatever flavor of call we are using.
+ (let ((operand
+ (cond ((> num-args 6)
+ (output-push-int segment num-args)
+ 7)
+ (t
+ num-args))))
+ (multiple-value-bind (opcode ret-vals)
+ (cond ((node-tail-p call)
+ (values byte-local-tail-call 0))
+ ((member results '(0 1))
+ (values byte-local-call 1))
+ (t
+ (values byte-local-multiple-call :unknown)))
+ ;; ### :call-site
+ (output-byte segment (logior opcode operand))
+ ;; Emit a reference to the label.
+ (output-reference segment
+ (byte-lambda-info-label (lambda-info lambda)))
+ ;; ### :unknown-return
+ ;; Fix up the results.
+ (unless (node-tail-p call)
+ (checked-canonicalize-values segment cont ret-vals))))))))
+ (values))
+
+(defun generate-byte-code-for-full-call (segment call cont num-args)
+ (let ((info (basic-combination-info call))
+ (results
+ (let ((info (continuation-info cont)))
+ (if info
+ (byte-continuation-info-results info)
+ 0))))
+ (cond
+ (info
+ ;; It's an inline function.
+ (assert (not (node-tail-p call)))
+ (let* ((type (inline-function-info-type info))
+ (desired-args (function-type-nargs type))
+ (supplied-results
+ (nth-value 1
+ (values-types (function-type-returns type))))
+ (leaf (ref-leaf (continuation-use (basic-combination-fun call)))))
+ (cond ((slot-accessor-p leaf)
+ (assert (= num-args (1- desired-args)))
+ (output-push-int segment (dsd-index (slot-accessor-slot leaf))))
+ (t
+ (canonicalize-values segment desired-args num-args)))
+ ;; ### :call-site
+ (output-byte segment (logior byte-inline-function
+ (inline-function-info-number info)))
+ ;; ### :known-return
+ (checked-canonicalize-values segment cont supplied-results)))
+ (t
+ (let ((operand
+ (cond ((eq num-args :unknown)
+ 7)
+ ((> num-args 6)
+ (output-push-int segment num-args)
+ 7)
+ (t
+ num-args))))
+ (when (eq (byte-continuation-info-results
+ (continuation-info
+ (basic-combination-fun call)))
+ :fdefinition)
+ (setf operand (logior operand byte-named)))
+ ;; ### :call-site
+ (cond
+ ((node-tail-p call)
+ (output-byte segment (logior byte-tail-call operand)))
+ (t
+ (multiple-value-bind (opcode ret-vals)
+ (case results
+ (:unknown (values byte-multiple-call :unknown))
+ ((0 1) (values byte-call 1))
+ (t (values byte-multiple-call :unknown)))
+ (output-byte segment (logior opcode operand))
+ ;; ### :unknown-return
+ (checked-canonicalize-values segment cont ret-vals)))))))))
+
+(defun generate-byte-code-for-known-call (segment call cont num-args)
+ (block nil
+ (catch 'give-up-ir1-transform
+ (funcall (function-info-byte-compile (basic-combination-kind call)) call
+ (let ((info (continuation-info cont)))
+ (if info
+ (byte-continuation-info-results info)
+ 0))
+ num-args segment)
+ (return))
+ (assert (member (byte-continuation-info-results
+ (continuation-info
+ (basic-combination-fun call)))
+ '(1 :fdefinition)))
+ (generate-byte-code-for-full-call segment call cont num-args))
+ (values))
+
+(defun generate-byte-code-for-generic-combination (segment call cont)
+ (declare (type sb!assem:segment segment) (type basic-combination call)
+ (type continuation cont))
+ (labels ((examine (args num-fixed)
+ (cond
+ ((null args)
+ ;; None of the arugments supply :UNKNOWN values, so
+ ;; we know exactly how many there are.
+ num-fixed)
+ (t
+ (let* ((vals
+ (byte-continuation-info-results
+ (continuation-info (car args)))))
+ (cond
+ ((eq vals :unknown)
+ (unless (null (cdr args))
+ ;; There are (LENGTH ARGS) :UNKNOWN value blocks on
+ ;; the top of the stack. We need to combine them.
+ (output-push-int segment (length args))
+ (output-do-xop segment 'merge-unknown-values))
+ (unless (zerop num-fixed)
+ ;; There are num-fixed fixed args above the unknown
+ ;; values block that want in on the action also.
+ ;; So add num-fixed to the count.
+ (output-push-int segment num-fixed)
+ (output-do-inline-function segment '+))
+ :unknown)
+ (t
+ (examine (cdr args) (+ num-fixed vals)))))))))
+ (let* ((args (basic-combination-args call))
+ (kind (basic-combination-kind call))
+ (num-args (if (and (eq kind :local)
+ (combination-p call))
+ (length args)
+ (examine args 0))))
+ (case kind
+ (:local
+ (generate-byte-code-for-local-call segment call cont num-args))
+ (:full
+ (generate-byte-code-for-full-call segment call cont num-args))
+ (t
+ (generate-byte-code-for-known-call segment call cont num-args))))))
+
+(defun generate-byte-code-for-basic-combination (segment call cont)
+ (cond ((and (mv-combination-p call)
+ (eq (continuation-function-name (basic-combination-fun call))
+ '%throw))
+ ;; ### :internal-error
+ (output-do-xop segment 'throw))
+ (t
+ (generate-byte-code-for-generic-combination segment call cont))))
+
+(defun generate-byte-code-for-if (segment if cont)
+ (declare (type sb!assem:segment segment) (type cif if)
+ (ignore cont))
+ (let* ((next-info (byte-block-info-next (block-info (node-block if))))
+ (consequent-info (block-info (if-consequent if)))
+ (alternate-info (block-info (if-alternative if))))
+ (cond ((eq (byte-continuation-info-results
+ (continuation-info (if-test if)))
+ :eq-test)
+ (output-branch segment
+ byte-branch-if-eq
+ (byte-block-info-label consequent-info))
+ (unless (eq next-info alternate-info)
+ (output-branch segment
+ byte-branch-always
+ (byte-block-info-label alternate-info))))
+ ((eq next-info consequent-info)
+ (output-branch segment
+ byte-branch-if-false
+ (byte-block-info-label alternate-info)))
+ (t
+ (output-branch segment
+ byte-branch-if-true
+ (byte-block-info-label consequent-info))
+ (unless (eq next-info alternate-info)
+ (output-branch segment
+ byte-branch-always
+ (byte-block-info-label alternate-info)))))))
+
+(defun generate-byte-code-for-return (segment return cont)
+ (declare (type sb!assem:segment segment) (type creturn return)
+ (ignore cont))
+ (let* ((result (return-result return))
+ (info (continuation-info result))
+ (results (byte-continuation-info-results info)))
+ (cond ((eq results :unknown)
+ (setf results 7))
+ ((> results 6)
+ (output-byte-with-operand segment byte-push-int results)
+ (setf results 7)))
+ (output-byte segment (logior byte-return results)))
+ (values))
+
+(defun generate-byte-code-for-entry (segment entry cont)
+ (declare (type sb!assem:segment segment) (type entry entry)
+ (ignore cont))
+ (dolist (exit (entry-exits entry))
+ (let ((nlx-info (find-nlx-info entry (node-cont exit))))
+ (when nlx-info
+ (let ((kind (cleanup-kind (nlx-info-cleanup nlx-info))))
+ (when (member kind '(:block :tagbody))
+ ;; Generate a unique tag.
+ (output-push-constant
+ segment
+ (format nil
+ "tag for ~A"
+ (component-name *component-being-compiled*)))
+ (output-push-constant segment nil)
+ (output-do-inline-function segment 'cons)
+ ;; Save it so people can close over it.
+ (output-do-xop segment 'dup)
+ (output-byte-with-operand segment
+ byte-pop-local
+ (byte-nlx-info-stack-slot
+ (nlx-info-info nlx-info)))
+ ;; Now do the actual XOP.
+ (ecase kind
+ (:block
+ (output-do-xop segment 'catch)
+ (output-reference segment
+ (byte-nlx-info-label
+ (nlx-info-info nlx-info))))
+ (:tagbody
+ (output-do-xop segment 'tagbody)))
+ (return))))))
+ (values))
+
+(defun generate-byte-code-for-exit (segment exit cont)
+ (declare (ignore cont))
+ (let ((nlx-info (find-nlx-info (exit-entry exit) (node-cont exit))))
+ (output-byte-with-operand segment
+ byte-push-arg
+ (closure-position nlx-info
+ (node-environment exit)))
+ (ecase (cleanup-kind (nlx-info-cleanup nlx-info))
+ (:block
+ ;; ### :internal-error
+ (output-do-xop segment 'return-from))
+ (:tagbody
+ ;; ### :internal-error
+ (output-do-xop segment 'go)
+ (output-reference segment
+ (byte-nlx-info-label (nlx-info-info nlx-info)))))))
+
+(defun generate-byte-code (segment component)
+ (let ((*byte-component-info* (component-info component)))
+ (do* ((info (byte-block-info-next (block-info (component-head component)))
+ next)
+ (block (byte-block-info-block info) (byte-block-info-block info))
+ (next (byte-block-info-next info) (byte-block-info-next info)))
+ ((eq block (component-tail component)))
+ (when (block-interesting block)
+ (output-label segment (byte-block-info-label info))
+ (do-nodes (node cont block)
+ (etypecase node
+ (bind (generate-byte-code-for-bind segment node cont))
+ (ref (generate-byte-code-for-ref segment node cont))
+ (cset (generate-byte-code-for-set segment node cont))
+ (basic-combination
+ (generate-byte-code-for-basic-combination
+ segment node cont))
+ (cif (generate-byte-code-for-if segment node cont))
+ (creturn (generate-byte-code-for-return segment node cont))
+ (entry (generate-byte-code-for-entry segment node cont))
+ (exit
+ (when (exit-entry node)
+ (generate-byte-code-for-exit segment node cont)))))
+ (let* ((succ (block-succ block))
+ (first-succ (car succ))
+ (last (block-last block)))
+ (unless (or (cdr succ)
+ (eq (byte-block-info-block next) first-succ)
+ (eq (component-tail component) first-succ)
+ (and (basic-combination-p last)
+ (node-tail-p last)
+ ;; Tail local calls that have been
+ ;; converted to an assignment need the
+ ;; branch.
+ (not (and (eq (basic-combination-kind last) :local)
+ (member (functional-kind
+ (combination-lambda last))
+ '(:let :assignment))))))
+ (output-branch segment
+ byte-branch-always
+ (byte-block-info-label
+ (block-info first-succ))))))))
+ (values))
+\f
+;;;; special purpose annotate/compile optimizers
+
+(defoptimizer (eq byte-annotate) ((this that) node)
+ (declare (ignore this that))
+ (when (if-p (continuation-dest (node-cont node)))
+ (annotate-known-call node)
+ t))
+
+(defoptimizer (eq byte-compile) ((this that) call results num-args segment)
+ (progn segment) ; ignorable.
+ ;; We don't have to do anything, because everything is handled by
+ ;; the IF byte-generator.
+ (assert (eq results :eq-test))
+ (assert (eql num-args 2))
+ (values))
+
+(defoptimizer (values byte-compile)
+ ((&rest values) node results num-args segment)
+ (canonicalize-values segment results num-args))
+
+(defknown %byte-pop-stack (index) (values))
+
+(defoptimizer (%byte-pop-stack byte-annotate) ((count) node)
+ (assert (constant-continuation-p count))
+ (annotate-continuation count 0)
+ (annotate-continuation (basic-combination-fun node) 0)
+ (setf (node-tail-p node) nil)
+ t)
+
+(defoptimizer (%byte-pop-stack byte-compile)
+ ((count) node results num-args segment)
+ (assert (and (zerop num-args) (zerop results)))
+ (output-byte-with-operand segment byte-pop-n (continuation-value count)))
+
+(defoptimizer (%special-bind byte-annotate) ((var value) node)
+ (annotate-continuation var 0)
+ (annotate-continuation value 1)
+ (annotate-continuation (basic-combination-fun node) 0)
+ (setf (node-tail-p node) nil)
+ t)
+
+(defoptimizer (%special-bind byte-compile)
+ ((var value) node results num-args segment)
+ (assert (and (eql num-args 1) (zerop results)))
+ (output-push-constant segment (leaf-name (continuation-value var)))
+ (output-do-inline-function segment '%byte-special-bind))
+
+(defoptimizer (%special-unbind byte-annotate) ((var) node)
+ (annotate-continuation var 0)
+ (annotate-continuation (basic-combination-fun node) 0)
+ (setf (node-tail-p node) nil)
+ t)
+
+(defoptimizer (%special-unbind byte-compile)
+ ((var) node results num-args segment)
+ (assert (and (zerop num-args) (zerop results)))
+ (output-do-inline-function segment '%byte-special-unbind))
+
+(defoptimizer (%catch byte-annotate) ((nlx-info tag) node)
+ (annotate-continuation nlx-info 0)
+ (annotate-continuation tag 1)
+ (annotate-continuation (basic-combination-fun node) 0)
+ (setf (node-tail-p node) nil)
+ t)
+
+(defoptimizer (%catch byte-compile)
+ ((nlx-info tag) node results num-args segment)
+ (progn node) ; ignore
+ (assert (and (= num-args 1) (zerop results)))
+ (output-do-xop segment 'catch)
+ (let ((info (nlx-info-info (continuation-value nlx-info))))
+ (output-reference segment (byte-nlx-info-label info))))
+
+(defoptimizer (%cleanup-point byte-compile) (() node results num-args segment)
+ (progn node segment) ; ignore
+ (assert (and (zerop num-args) (zerop results))))
+
+(defoptimizer (%catch-breakup byte-compile) (() node results num-args segment)
+ (progn node) ; ignore
+ (assert (and (zerop num-args) (zerop results)))
+ (output-do-xop segment 'breakup))
+
+(defoptimizer (%lexical-exit-breakup byte-annotate) ((nlx-info) node)
+ (annotate-continuation nlx-info 0)
+ (annotate-continuation (basic-combination-fun node) 0)
+ (setf (node-tail-p node) nil)
+ t)
+
+(defoptimizer (%lexical-exit-breakup byte-compile)
+ ((nlx-info) node results num-args segment)
+ (assert (and (zerop num-args) (zerop results)))
+ (let ((nlx-info (continuation-value nlx-info)))
+ (when (ecase (cleanup-kind (nlx-info-cleanup nlx-info))
+ (:block
+ ;; We only want to do this for the fall-though case.
+ (not (eq (car (block-pred (node-block node)))
+ (nlx-info-target nlx-info))))
+ (:tagbody
+ ;; Only want to do it once per tagbody.
+ (not (byte-nlx-info-duplicate (nlx-info-info nlx-info)))))
+ (output-do-xop segment 'breakup))))
+
+(defoptimizer (%nlx-entry byte-annotate) ((nlx-info) node)
+ (annotate-continuation nlx-info 0)
+ (annotate-continuation (basic-combination-fun node) 0)
+ (setf (node-tail-p node) nil)
+ t)
+
+(defoptimizer (%nlx-entry byte-compile)
+ ((nlx-info) node results num-args segment)
+ (progn node results) ; ignore
+ (assert (eql num-args 0))
+ (let* ((info (continuation-value nlx-info))
+ (byte-info (nlx-info-info info)))
+ (output-label segment (byte-nlx-info-label byte-info))
+ ;; ### :non-local-entry
+ (ecase (cleanup-kind (nlx-info-cleanup info))
+ ((:catch :block)
+ (checked-canonicalize-values segment
+ (nlx-info-continuation info)
+ :unknown))
+ ((:tagbody :unwind-protect)))))
+
+(defoptimizer (%unwind-protect byte-annotate)
+ ((nlx-info cleanup-fun) node)
+ (annotate-continuation nlx-info 0)
+ (annotate-continuation cleanup-fun 0)
+ (annotate-continuation (basic-combination-fun node) 0)
+ (setf (node-tail-p node) nil)
+ t)
+
+(defoptimizer (%unwind-protect byte-compile)
+ ((nlx-info cleanup-fun) node results num-args segment)
+ (assert (and (zerop num-args) (zerop results)))
+ (output-do-xop segment 'unwind-protect)
+ (output-reference segment
+ (byte-nlx-info-label
+ (nlx-info-info
+ (continuation-value nlx-info)))))
+
+(defoptimizer (%unwind-protect-breakup byte-compile)
+ (() node results num-args segment)
+ (progn node) ; ignore
+ (assert (and (zerop num-args) (zerop results)))
+ (output-do-xop segment 'breakup))
+
+(defoptimizer (%continue-unwind byte-annotate) ((a b c) node)
+ (annotate-continuation a 0)
+ (annotate-continuation b 0)
+ (annotate-continuation c 0)
+ (annotate-continuation (basic-combination-fun node) 0)
+ (setf (node-tail-p node) nil)
+ t)
+
+(defoptimizer (%continue-unwind byte-compile)
+ ((a b c) node results num-args segment)
+ (progn node) ; ignore
+ (assert (member results '(0 nil)))
+ (assert (eql num-args 0))
+ (output-do-xop segment 'breakup))
+
+(defoptimizer (%load-time-value byte-annotate) ((handle) node)
+ (annotate-continuation handle 0)
+ (annotate-continuation (basic-combination-fun node) 0)
+ (setf (node-tail-p node) nil)
+ t)
+
+(defoptimizer (%load-time-value byte-compile)
+ ((handle) node results num-args segment)
+ (progn node) ; ignore
+ (assert (zerop num-args))
+ (output-push-load-time-constant segment :load-time-value
+ (continuation-value handle))
+ (canonicalize-values segment results 1))
+\f
+;;; Make a byte-function for LAMBDA.
+(defun make-xep-for (lambda)
+ (flet ((entry-point-for (entry)
+ (let ((info (lambda-info entry)))
+ (assert (byte-lambda-info-interesting info))
+ (sb!assem:label-position (byte-lambda-info-label info)))))
+ (let ((entry (lambda-entry-function lambda)))
+ (etypecase entry
+ (optional-dispatch
+ (let ((rest-arg-p nil)
+ (num-more 0))
+ (declare (type index num-more))
+ (collect ((keywords))
+ (dolist (var (nthcdr (optional-dispatch-max-args entry)
+ (optional-dispatch-arglist entry)))
+ (let ((arg-info (lambda-var-arg-info var)))
+ (assert arg-info)
+ (ecase (arg-info-kind arg-info)
+ (:rest
+ (assert (not rest-arg-p))
+ (incf num-more)
+ (setf rest-arg-p t))
+ (:keyword
+ (let ((s-p (arg-info-supplied-p arg-info))
+ (default (arg-info-default arg-info)))
+ (incf num-more (if s-p 2 1))
+ (keywords (list (arg-info-keyword arg-info)
+ (if (constantp default)
+ (eval default)
+ nil)
+ (if s-p t nil))))))))
+ (make-hairy-byte-function
+ :name (leaf-name entry)
+ :min-args (optional-dispatch-min-args entry)
+ :max-args (optional-dispatch-max-args entry)
+ :entry-points
+ (mapcar #'entry-point-for (optional-dispatch-entry-points entry))
+ :more-args-entry-point
+ (entry-point-for (optional-dispatch-main-entry entry))
+ :num-more-args num-more
+ :rest-arg-p rest-arg-p
+ :keywords-p
+ (if (optional-dispatch-keyp entry)
+ (if (optional-dispatch-allowp entry)
+ :allow-others t))
+ :keywords (keywords)))))
+ (clambda
+ (let ((args (length (lambda-vars entry))))
+ (make-simple-byte-function
+ :name (leaf-name entry)
+ :num-args args
+ :entry-point (entry-point-for entry))))))))
+
+(defun generate-xeps (component)
+ (let ((xeps nil))
+ (dolist (lambda (component-lambdas component))
+ (when (member (lambda-kind lambda) '(:external :top-level))
+ (push (cons lambda (make-xep-for lambda)) xeps)))
+ xeps))
+\f
+;;;; noise to actually do the compile
+
+(defun assign-locals (component)
+ ;; Process all of the lambdas in component, and assign stack frame
+ ;; locations for all the locals.
+ (dolist (lambda (component-lambdas component))
+ ;; We don't generate any code for :external lambdas, so we don't need
+ ;; to allocate stack space. Also, we don't use the ``more'' entry,
+ ;; so we don't need code for it.
+ (cond
+ ((or (eq (lambda-kind lambda) :external)
+ (and (eq (lambda-kind lambda) :optional)
+ (eq (optional-dispatch-more-entry
+ (lambda-optional-dispatch lambda))
+ lambda)))
+ (setf (lambda-info lambda)
+ (make-byte-lambda-info :interesting nil)))
+ (t
+ (let ((num-locals 0))
+ (let* ((vars (lambda-vars lambda))
+ (arg-num (+ (length vars)
+ (length (environment-closure
+ (lambda-environment lambda))))))
+ (dolist (var vars)
+ (decf arg-num)
+ (cond ((or (lambda-var-sets var) (lambda-var-indirect var))
+ (setf (leaf-info var)
+ (make-byte-lambda-var-info :offset num-locals))
+ (incf num-locals))
+ ((leaf-refs var)
+ (setf (leaf-info var)
+ (make-byte-lambda-var-info :argp t
+ :offset arg-num))))))
+ (dolist (let (lambda-lets lambda))
+ (dolist (var (lambda-vars let))
+ (setf (leaf-info var)
+ (make-byte-lambda-var-info :offset num-locals))
+ (incf num-locals)))
+ (let ((entry-nodes-already-done nil))
+ (dolist (nlx-info (environment-nlx-info (lambda-environment lambda)))
+ (ecase (cleanup-kind (nlx-info-cleanup nlx-info))
+ (:block
+ (setf (nlx-info-info nlx-info)
+ (make-byte-nlx-info :stack-slot num-locals))
+ (incf num-locals))
+ (:tagbody
+ (let* ((entry (cleanup-mess-up (nlx-info-cleanup nlx-info)))
+ (cruft (assoc entry entry-nodes-already-done)))
+ (cond (cruft
+ (setf (nlx-info-info nlx-info)
+ (make-byte-nlx-info :stack-slot (cdr cruft)
+ :duplicate t)))
+ (t
+ (push (cons entry num-locals) entry-nodes-already-done)
+ (setf (nlx-info-info nlx-info)
+ (make-byte-nlx-info :stack-slot num-locals))
+ (incf num-locals)))))
+ ((:catch :unwind-protect)
+ (setf (nlx-info-info nlx-info) (make-byte-nlx-info))))))
+ (setf (lambda-info lambda)
+ (make-byte-lambda-info :stack-size num-locals))))))
+
+ (values))
+
+(defun byte-compile-component (component)
+ (setf (component-info component) (make-byte-component-info))
+ (maybe-mumble "ByteAnn ")
+
+ ;; Assign offsets for all the locals, and figure out which args can
+ ;; stay in the argument area and which need to be moved into locals.
+ (assign-locals component)
+
+ ;; Annotate every continuation with information about how we want the
+ ;; values.
+ (annotate-ir1 component)
+
+ ;; Determine what stack values are dead, and emit cleanup code to pop
+ ;; them.
+ (byte-stack-analyze component)
+
+ ;; Make sure any newly added blocks have a block-number.
+ (dfo-as-needed component)
+
+ ;; Assign an ordering of the blocks.
+ (control-analyze component #'make-byte-block-info)
+
+ ;; Find the start labels for the lambdas.
+ (dolist (lambda (component-lambdas component))
+ (let ((info (lambda-info lambda)))
+ (when (byte-lambda-info-interesting info)
+ (setf (byte-lambda-info-label info)
+ (byte-block-info-label
+ (block-info (node-block (lambda-bind lambda))))))))
+
+ ;; Delete any blocks that we are not going to emit from the emit order.
+ (do-blocks (block component)
+ (unless (block-interesting block)
+ (let* ((info (block-info block))
+ (prev (byte-block-info-prev info))
+ (next (byte-block-info-next info)))
+ (setf (byte-block-info-next prev) next)
+ (setf (byte-block-info-prev next) prev))))
+
+ (maybe-mumble "ByteGen ")
+ (let ((segment nil))
+ (unwind-protect
+ (progn
+ (setf segment (sb!assem:make-segment :name "Byte Output"))
+ (generate-byte-code segment component)
+ (let ((code-length (sb!assem:finalize-segment segment))
+ (xeps (generate-xeps component))
+ (constants (byte-component-info-constants
+ (component-info component))))
+ #!+sb-show
+ (when *compiler-trace-output*
+ (describe-component component *compiler-trace-output*)
+ (describe-byte-component component xeps segment
+ *compiler-trace-output*))
+ (etypecase *compile-object*
+ (fasl-file
+ (maybe-mumble "FASL")
+ (fasl-dump-byte-component segment code-length constants xeps
+ *compile-object*))
+ (core-object
+ (maybe-mumble "Core")
+ (make-core-byte-component segment code-length constants xeps
+ *compile-object*))
+ (null))))))
+ (values))
+\f
+;;;; extra stuff for debugging
+
+#!+sb-show
+(defun dump-stack-info (component)
+ (do-blocks (block component)
+ (when (block-interesting block)
+ (print-nodes block)
+ (let ((info (block-info block)))
+ (cond
+ (info
+ (format t
+ "start-stack ~S~%consume ~S~%produce ~S~%end-stack ~S~%~
+ total-consume ~S~%~@[nlx-entries ~S~%~]~@[nlx-entry-p ~S~%~]"
+ (byte-block-info-start-stack info)
+ (byte-block-info-consumes info)
+ (byte-block-info-produces info)
+ (byte-block-info-end-stack info)
+ (byte-block-info-total-consumes info)
+ (byte-block-info-nlx-entries info)
+ (byte-block-info-nlx-entry-p info)))
+ (t
+ (format t "no info~%")))))))
--- /dev/null
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/eval.lisp
+05-Feb-90 20:45:20, Edit by Ram.
+ Fixed MAKE-INTERPRETED-FUNCTION to specify the LAMBDA slot when creating the
+ function so that it is avaliable to INTERPRETED-FUNCTION-LAMBDA-EXPRESSION.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/sset.lisp
+05-Feb-90 12:07:12, Edit by Ram.
+ Fixed a problem in SSET-UNION-OF-DIFFERENCE. It was using (>= num2 num3) in
+ two places where it should have been using <=. Probably due to incorrect
+ modification of the original SSET-DIFFERENCE code into this function. The
+ original function had the inner loop over the second arg, rather than the
+ first. This effectively resulted in the difference aspect usually not
+ happening, so the KILL set in constraint propagation never took effect,
+ resulting in some over-zealous type propagation.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/srctran.lisp
+04-Feb-90 10:11:51, Edit by Ram.
+ Oops... Fixed * transform so that multiplication by 8 doesn't really
+ multiply by 256, etc.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/main.lisp
+04-Feb-90 09:48:09, Edit by Ram.
+ Wrote CLOSE-SOURCE-INFO, and made COMPILE-FILE, ADVANCE-SOURCE-FILE and
+ COMPILE-FROM-STREAM call it.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/fndb.lisp
+04-Feb-90 08:09:06, Edit by Ram.
+ Added definition for %SP-STRING-COMPARE.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/seqtran.lisp
+04-Feb-90 08:01:21, Edit by Ram.
+ Fixed STRING<>=-BODY a bit. In addition to some query replace lossage, there
+ was also a genuine ancestral bug in computation of the result in the = case
+ of = ops.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ctype.lisp
+03-Feb-90 20:44:39, Edit by Ram.
+ Made VALID-FUNCTION-USE and VALID-APPROXIMATE-TYPE return NIL, NIL when
+ uncertainty is encountered, rather than T, NIL. Everybody was expecting this
+ to be a conservative test (and only looking at the first value.) This caused
+ spurious transforms to happen.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/srctran.lisp
+02-Feb-90 14:08:09, Edit by Ram.
+ Added NTH, NTHCDR transforms for the constant index case. Added * transform
+ for the power-of-2 case.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/seqtran.lisp
+02-Feb-90 13:00:15, Edit by Ram.
+ Added string transforms, derived from CLC sources.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/srctran.lisp
+02-Feb-90 13:25:40, Edit by Ram.
+ Added FORMAT transform derived from CLC sources.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/type.lisp
+02-Feb-90 11:23:26, Edit by Ram.
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1opt.lisp
+02-Feb-90 11:23:15, Edit by Ram.
+ Defined TYPE/= and made the "anything changed" tests use it instead of TYPE=
+ so as to be conservative in the presence of hairy types.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1opt.lisp
+02-Feb-90 10:29:54, Edit by Ram.
+ Changed REOPTIMIZE-CONTINUATION to set BLOCK-TYPE-CHECK in the use blocks so
+ that new derived-type information will also cause type checking to be redone.
+ This mainly handles the case where new type information causes us to want to
+ negate a check that was previously simple.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1opt.lisp
+02-Feb-90 10:12:24, Edit by Ram.
+ Fixed CONTINUATION-%DERIVED-TYPE to call CONTINUATION-%TYPE-CHECK instead of
+ CONTINUATION-TYPE-CHECK so that it won't recurse indefinitely.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/globaldb.lisp
+01-Feb-90 14:46:13, Edit by Ram.
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1tran.lisp
+01-Feb-90 14:43:26, Edit by Ram.
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/knownfun.lisp
+01-Feb-90 14:40:22, Edit by Ram.
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1opt.lisp
+01-Feb-90 14:42:19, Edit by Ram.
+ Flushed *FUNCTION-INFO* in favor of (INFO FUNCTION INFO ...). Added
+ FUNCTION-INFO-PREDICATE-TYPE slot.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1opt.lisp
+01-Feb-90 14:09:42, Edit by Ram.
+ Changed ASSERT-CONTINUATION-TYPE to set BLOCK-TYPE-ASSERTED in the use
+ blocks. Also, moved fixed the setting of BLOCK-TYPE-CHECK to be on the use
+ blocks rather than the CONTINUATION-BLOCK, since type check generation uses
+ DO-NODES, and thus ignores the BLOCK-START.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/node.lisp
+01-Feb-90 13:37:14, Edit by Ram.
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/checkgen.lisp
+01-Feb-90 13:41:46, Edit by Ram.
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1opt.lisp
+01-Feb-90 13:41:48, Edit by Ram.
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1tran.lisp
+01-Feb-90 13:42:05, Edit by Ram.
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1util.lisp
+01-Feb-90 13:42:29, Edit by Ram.
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ltn.lisp
+01-Feb-90 13:43:07, Edit by Ram.
+ Renamed the CONTINUATION TYPE-CHECK slot to %TYPE-CHECK, which is filtered by
+ the new CONTINUATION-TYPE-CHECK function to make sure that it has been
+ computed recently. Changed setters of TYPE-CHECK to %TYPE-CHECK, and flushed
+ the now unnecessary calls to CONTINUATION-DERIVED-TYPE (which explicitly did
+ the recomputation.)
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1opt.lisp
+01-Feb-90 12:56:50, Edit by Ram.
+ Changed %CONTINUATION-DERIVED-TYPE to not set TYPE-CHECK when the assertion
+ is T or there is no DEST. In the first case, this just avoids waste motion.
+ In the second case, this prevents constraint analysis from being tricked into
+ believing such a check will be done, when in fact no checks are done on
+ unused values.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1util.lisp
+01-Feb-90 12:51:41, Edit by Ram.
+ Made DELETE-CONTINUATION, FLUSH-DEST, NODE-ENDS-BLOCK and UNLINK-NODE set the
+ BLOCK-TYPE-ASSERTED and BLOCK-TEST-CHANGED flags. At least for the former,
+ this has to be done in more places than I thought, and also must be done for
+ correctness, rather than just to ensure new assertions are seen. This is
+ because if a block is split, or code needing an assertion is deleted, then we
+ must recompute the block's set of constraints or it will contain incorrect
+ constraints.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/sset.lisp
+01-Feb-90 11:33:28, Edit by Ram.
+ Fixed SSET-INTERSECTION to blow away any extra elements in SET1 that are
+ larger than the greatest element in SET2.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/node.lisp
+01-Feb-90 10:34:17, Edit by Ram.
+ Changed initial values for TYPE-ASSERTED and TEST-MODIFIED to be T rather
+ than NIL.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/vop.lisp
+30-Jan-90 16:10:06, Edit by Ram.
+ Added IR2-ENVIRONMENT-KEEP-AROUND-TNS and IR2-COMPONENT-PRE-PACKED-SAVE-TNS
+ so that we won't have to recompile to add these features later on.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/eval.lisp
+30-Jan-90 14:54:58, Edit by Ram.
+ Added the MAKE-INTERPRETED-FUNCTION interface which allows lazy conversion of
+ functions and features bounded IR1 memory usage through a LRU cache that is
+ partially flushed on GC. Added INTERPRETED-FUNCTION-NAME,
+ INTERPRETED-FUNCTION-ARGLIST and setf functions.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1tran.lisp
+30-Jan-90 10:08:19, Edit by Ram.
+ Now that %DEFMACRO is passed #'(lambda ... for benefit for the interpreter,
+ we don't want to unquote the definition using EVAL. Use SECOND instead.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1util.lisp
+29-Jan-90 14:17:06, Edit by Ram.
+ Changed FIND-COMPONENT-NAME to bind *PRINT-LEVEL* and *PRINT-PRETTY* so as to
+ prevent huge component names.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/life.lisp
+29-Jan-90 13:43:23, Edit by Ram.
+ Fixed CONFLICT-ANALYZE-BLOCK in the dead read case to do FROB-MORE-TNS on
+ NOTE-CONFLICTS as well as the addition to the live set. This was the fix to
+ the long-procrastinated-about :MORE TN bug (first noticed in fall 88.) Also,
+ changed FROB-MORE-TNS to return whether it did anything, rather than sleazily
+ hacking on the loop variable to get the loop to exit. I must have been
+ having a Pascal flashback when I wrote that code...
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/eval.lisp
+29-Jan-90 13:24:23, Edit by Ram.
+ Fixed LEAF-VALUE to use FDEFINITION rather than SYMBOL-FUNCTION when the name
+ isn't a symbol.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/main.lisp
+29-Jan-90 10:46:23, Edit by Ram.
+ Changed COMPILE-FIX-FUNCTION-NAME to substitute for old uses of the name so
+ that recursive calls get converted.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1tran.lisp
+29-Jan-90 10:13:18, Edit by Ram.
+ But for the want of a single character... So that's why no functions were
+ being inline expanded! In %DEFUN the ir1 translator, I was looking at the
+ INLINEP value for the NAME in the same LET that was eval'ing the name to
+ unquote it.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/debug-dump.lisp
+27-Jan-90 18:05:15, Edit by Ram.
+ Made DEBUG-SOURCE-FOR-INFO handle the incremental compilation cases.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/main.lisp
+27-Jan-90 17:46:09, Edit by Ram.
+ Wrote COMPILE and UNCOMPILE.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/eval.lisp
+27-Jan-90 17:07:17, Edit by Ram.
+ Added the interfaces INTERPRETED-FUNCTION-LAMBDA-EXPRESSION and
+ INTERPRETED-FUNCTION-CLOSURE. These use the new FIND-IF-IN-CLOSURE operation
+ pick apart the closure that is an interpreted function.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/main.lisp
+26-Jan-90 16:35:51, Edit by Ram.
+ Moved a bunch of stuff from COMPILE-FILE to SUB-COMPILE-FILE. Wrote
+ MAKE-LISP-SOURCE-INFO and MAKE-STREAM-SOURCE-INFO. Wrote
+ COMPILE-FROM-STREAM, and added appropriate uses of the in-core compilation
+ interface to various functions.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/globaldb.lisp
+26-Jan-90 16:09:30, Edit by Ram.
+ Made the CACHE-NAME slot be duplicated in both kinds of environment rather
+ than inherited from INFO-ENV so that the inline type checks for the slot
+ access will win, allowing bootstrapping to work.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/eval-comp.lisp
+26-Jan-90 13:12:09, Edit by Ram.
+ Changed COMPILE-FOR-EVAL to call the new MAKE-LISP-SOURCE-INFO, rather than
+ rolling its own.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/globaldb.lisp
+26-Jan-90 11:59:58, Edit by Ram.
+ Added code to cache the last name looked up, since we commonly consecutively
+ look up several types of info for the same name. [Maybe even some types more
+ than once!]
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1tran.lisp
+26-Jan-90 09:30:59, Edit by Ram.
+ Fixed PROCESS-TYPE-PROCLAMATION to not try to call TYPES-INTERSECT on
+ function types so that we don't flame out. This was probably what I was
+ really trying to fix in the last change to PROCESS-TYPE-DECLARATION. Really
+ both were broken.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/srctran.lisp
+25-Jan-90 10:58:43, Edit by Ram.
+ Added transform for ARRAY-DIMENSION that converts to LENGTH when possible.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/typetran.lisp
+25-Jan-90 10:46:00, Edit by Ram.
+ Moved array typep code here from vm-type-tran, since it turned out not to be
+ VM dependent after all.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/typetran.lisp
+23-Jan-90 15:31:32, Edit by Ram.
+ Transformed array type tests to %ARRAY-TYPEP so that clever
+ implementation-dependent things can be done.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1tran.lisp
+23-Jan-90 18:45:14, Edit by Ram.
+ Fixed up some messed up backquote stuff in DO-MACROLET-STUFF where it was
+ trying to coerce the lambda to a function.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/envanal.lisp
+23-Jan-90 13:06:41, Edit by Ram.
+ Don't annotate as TAIL-P nodes whose DERIVED-TYPE is NIL, so that we don't
+ tail-call functions such as ERROR.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1tran.lisp
+23-Jan-90 12:44:28, Edit by Ram.
+ Fixed %DEFUN translator to record an inline expansion when the INLINEP value
+ is :MAYBE-INLINE as well as :INLINE.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1util.lisp
+23-Jan-90 08:49:50, Edit by Ram.
+ Changed PUSH-IN and DELETEF-IN to only call FOO-GET-SETF-METHOD when
+ CLC::*IN-THE-COMPILER* is true, so that we can still use these macros in the
+ old compiler.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/seqtran.lisp
+22-Jan-90 16:11:28, Edit by Ram.
+ Added a transform for MEMBER where the list is a constant argument (primarily
+ to help MEMBER type tests.)
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/eval.lisp
+22-Jan-90 15:20:27, Edit by Ram.
+ Replaced all uses of COMBINATION- accessors with BASIC-COMBINATION- accessors
+ so that MV combinations will work.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/eval.lisp
+22-Jan-90 15:08:07, Edit by Ram.
+ Put a couple of macros in EVAL-WHEN (COMPILE LOAD EVAL) so that they are
+ avaliable to SETF in the bootstrap environment. Also, changed %SP-[UN]BIND
+ to the appropriate %PRIMITIVE calls.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/fndb.lisp
+20-Jan-90 20:21:34, Edit by Ram.
+ Fixed up FBOUNDP & stuff to correspond to the FUNCTION-NAME cleanup. Now
+ FBOUNDP can take a list as well as a symbol.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1tran.lisp
+20-Jan-90 09:56:43, Edit by Ram.
+ In #+NEW-COMPILER, made DO-MACROLET-STUFF coerce the lambda expression to a
+ function.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/eval-comp.lisp
+20-Jan-90 09:52:20, Edit by Ram.
+ Added bind of *FENV* to () in COMPILE-FOR-EVAL.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1tran.lisp
+20-Jan-90 09:50:59, Edit by Ram.
+ And made IR1-TOP-LEVEL *not* bind *FENV* to () so that top-level MACROLETs
+ will be recognized...
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/main.lisp
+20-Jan-90 09:47:19, Edit by Ram.
+ Added binding of *FENV* to () in SUB-COMPILE-FILE so that MACROLET processing
+ won't flame out.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/macros.lisp
+19-Jan-90 22:25:15, Edit by Ram.
+ Made WITH-IR1-ENVIRONMENT bind a bunch more variables. *fenv*, etc. Wrote
+ WITH-IR1-NAMESPACE, which allocates the gloabal namespace hashtables.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/eval-comp.lisp
+19-Jan-90 22:35:44, Edit by Ram.
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1tran.lisp
+19-Jan-90 22:34:20, Edit by Ram.
+ Flushed IR1-TOP-LEVEL-FOR-EVAL and changed IR1-TOP-LEVEL to take a FOR-VALUE
+ flag so that it can do the same thing. Added use of WITH-IR1-NAMESPACE.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/main.lisp
+19-Jan-90 21:43:20, Edit by Ram.
+ Made SUB-COMPILE-FILE bind *CURRENT-COOKIE* so that people can randomly call
+ (POLICY NIL ...) to get at the current policy, and will never see any
+ leftover local policy from a dynamically enclosing IR1 conversion.
+ ### Maybe this should really be bound somewhere else, like COMPILE-COMPONENT.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1util.lisp
+19-Jan-90 22:00:35, Edit by Ram.
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/node.lisp
+19-Jan-90 22:01:47, Edit by Ram.
+ Added a keyword constructor for CBLOCK, and changed all MAKE-BLOCK calls
+ outside of IR1 conversion to use this new constructor, specifying all the
+ values that would otherwise be defaulted from specials. This is necessary to
+ make stuff properly reentrant.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1tran.lisp
+19-Jan-90 17:26:17, Edit by Ram.
+ In FIND-FREE-VARIABLE, flushed the assertion that non-constant variables
+ never have constant values. This isn't really right, but it is better.
+ ### Really, the implementation of "constant but value unknown" variables
+ should be either flushed or redone.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/eval-comp.lisp
+19-Jan-90 15:31:33, Edit by Ram.
+ New file from Chiles.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/eval.lisp
+19-Jan-90 15:30:03, Edit by Ram.
+ New file from chiles. Changed MY-EVAL to INTERNAL-EVAL and made it frob
+ *ALREADY-EVALED-THIS*.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1tran.lisp
+19-Jan-90 14:53:28, Edit by Ram.
+ Made IR1 conversion reentrant by having IR1-TOP-LEVEL bind all of the state
+ variables. Removed DEFVAR initial values for variables that should never be
+ referenced outside of IR1 conversion. Rather than always making four new
+ hashtables every time, I kept around the global values, allowing them to be
+ used on the outermost call.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1opt.lisp
+19-Jan-90 11:06:50, Edit by Ram.
+ Changed PROPAGATE-TO-REFS to do nothing when the variable type is a function
+ type so that we don't lose specific function type information, and also so
+ that TYPE-INTERSECTION doesn't gag.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1tran.lisp
+19-Jan-90 11:24:07, Edit by Ram.
+ Changed PROCESS-TYPE-DECLARATION to quietly set the var type when either the
+ old or new type is a function type, rather than losing trying to do
+ TYPE-INTERSECTION.
+ ### Someday when we have a incompatible-redefinition detection capability, we
+ might want to hook it in here.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1tran.lisp
+18-Jan-90 16:45:20, Edit by Ram.
+ In %DEFMACRO IR1 convert, when #+NEW-COMPILER, coerce the expander to a
+ function before sticking it in the MACRO-FUNCTION.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1tran.lisp
+18-Jan-90 14:11:44, Edit by Ram.
+ Changed %DEFUN translator to dump an inline expanion when appropriate.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/fndb.lisp
+18-Jan-90 12:33:17, Edit by Ram.
+ Added %STANDARD-CHAR-P and %STRING-CHAR-P to the imports list.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/globaldb.lisp
+18-Jan-90 12:24:34, Edit by Ram.
+ In #+NEW-COMPILER, added info type defaults that get information from the
+ environment. This only affected functions and constant values, since
+ everything else is already stored in the global database.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/main.lisp
+18-Jan-90 11:51:45, Edit by Ram.
+ In COMPILE-FILE, fixed FROB to always pathnamify the thing so that
+ OPEN-FASL-FILE won't choke. Also, this way any syntax error always happens
+ in COMPILE-FILE.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/life.lisp
+18-Jan-90 10:44:11, Edit by Ram.
+ And also in NOTE-CONFLICTS, fixed the declaration for Live-List to be
+ (OR TN NULL) rather than TN.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/life.lisp
+18-Jan-90 10:39:41, Edit by Ram.
+ In NOTE-CONFLICTS, fixed the type for Live-Bits to be LOCAL-TN-BIT-VECTOR,
+ not SC-BIT-VECTOR.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir2tran.lisp
+17-Jan-90 20:47:37, Edit by Ram.
+ Fixed IR2-CONVERT-NORMAL-LOCAL-CALL to set up the argument pointer. It
+ seems this was only happening in tail calls, so stack arguments did not in
+ general work in local calls.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ltn.lisp
+17-Jan-90 16:20:28, Edit by Ram.
+ Changed FIND-TEMPLATE to guard the unsafe policy "trusting" result test by a
+ check for any non-null value of TYPE-CHECK, rather than just T or :ERROR.
+ This since the value might have also been :NO-CHECK, this was usually
+ preventing us from believing the assertion.
+
+ This was resulting in the rather baffling efficiency note that output type
+ assertions can't be trusted in a safe policy, when the policy wasn't safe...
+ I added an assertion that the policy really is safe when we emit that note.
+ Although it should always be the case, lossage in either VALID-FUNCTION-USE
+ or template selection could cause us to end up in that branch.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/globaldb.lisp
+16-Jan-90 21:25:42, Edit by Ram.
+ Renamed the types ENTRY-INFO and ENTRIES-INDEX to be COMPACT-INFO-ENTRY and
+ COMPACT-INFO-ENTRIES-INDEX. We already had a structure called ENTRY-INFO.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/proclaim.lisp
+16-Jan-90 11:23:51, Edit by Ram.
+ Set the symbol-function of PROCLAIM to the definition of %PROCLAIM.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1tran.lisp
+16-Jan-90 11:15:56, Edit by Ram.
+ Fixed DEFMACRO ir1 convert to unquote the original arglist before setting the
+ FUNCTIONAL-ARG-DOCUMENTATION.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/codegen.lisp
+15-Jan-90 13:04:59, Edit by Ram.
+ Oops... I seem to have broken codegen when I changed to it give each block a
+ label, sometimes emitting a label more than once.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1util.lisp
+13-Jan-90 13:09:05, Edit by Ram.
+ Changed DELETEF-IN and PUSH-IN to use FOO-GET-SETF-METHOD rather than
+ GET-SETF-METHOD so that they will expand correctly in the bootstrapping
+ environment.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1tran.lisp
+13-Jan-90 12:27:12, Edit by Ram.
+ Fixed a CDR circularity detection in FIND-SOURCE-PATHS a bit.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/globaldb.lisp
+13-Jan-90 11:49:48, Edit by Ram.
+ In addition to initializing *INFO-CLASSES* in GLOBALDB-INIT for benefit of
+ bootstrapping, we must also init *TYPE-COUNTER* and *TYPE-NUMBERS*.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/globaldb.lisp
+12-Jan-90 16:15:25, Edit by Ram.
+ Changed to use a special FIND-TYPE-INFO function instead of FIND, since the
+ slot accessor TYPE-INFO-NAME isn't avaliable for use as a funarg before
+ top-level forms run.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/globaldb.lisp
+11-Jan-90 11:14:44, Edit by Ram.
+ I'm sooo embarrassed... I got the rehashing algorithm wrong in compact
+ environments. The second hash could be 0, resulting in infinite looping.
+ [b.t.w., this is a new largely rewritten version of globaldb that uses
+ special hashtables instead of standard hashtables. There are two kinds of
+ environments: volatile and compact. Volatile environments can be modified,
+ but are not especially compact (comparable to the old hashtable
+ implementation, but faster.) Compact environments are not modifiable, but
+ reduce memory usage by at least half.]
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1tran.lisp
+10-Jan-90 12:04:33, Edit by Ram.
+ Rather than asserting that (INFO FUNCTION WHERE-FROM <name>) is :ASSUMED
+ whenever the LEAF-WHERE-FROM is assumed, we just quietly skip the unknown
+ function warning code when the name no longer names an assumed function.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/main.lisp
+10-Jan-90 11:27:03, Edit by Ram.
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1tran.lisp
+10-Jan-90 11:24:07, Edit by Ram.
+ Added special-case top-level form processing of EVAL-WHEN, PROGN and MACROLET
+ so that we don't get huge compilations when these forms enclose lots of code
+ at top-level. To do this, I split off the environment manipulation code in
+ EVAL-WHEN and MACROLET.
+ ### Probably should expand macros to see if they turn into a magic form
+ ### before just compiling the thing.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir2tran.lisp
+09-Jan-90 13:23:41, Edit by Ram.
+ Wrote a version of PROGV. This IR1 translator is in IR2tran because it goes
+ directly from syntax to shallow-binding primitives.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1tran.lisp
+08-Jan-90 14:39:46, Edit by Ram.
+ Made FIND-SOURCE-PATHS hack circular source code. CAR circularities are
+ detected by noticing that the cons is already in the source paths hashtable.
+ CDR circularities are detected using the two-phase trailing pointer hack.
+ This support is necessary as long as circular constants are allowed (which is
+ strongly implied by the presence of the #=/## read syntax.) Of course if
+ there is circular evaluated code, bad things will still happen...
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/main.lisp
+08-Jan-90 13:36:03, Edit by Ram.
+ Made PRINT-SUMMARY print information about compilation units that were
+ aborted, and inhibited printing of unknown function warnings when the warning
+ compilation unit is unwound.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/main.lisp
+08-Jan-90 10:58:02, Edit by Ram.
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1tran.lisp
+08-Jan-90 10:49:04, Edit by Ram.
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/node.lisp
+08-Jan-90 10:28:23, Edit by Ram.
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1final.lisp
+08-Jan-90 10:40:20, Edit by Ram.
+ Changed *UNKNOWN-FUNCTIONS* a bit. Now it is a list of UNKNOWN-FUNCTION
+ structures. This was done primarily to allow the number of warnings to be
+ limited in IR1-CONVERT-OK-COMBINATION-FER-SHER rather than in PRINT-SUMMARY.
+ It turns out that recording hundreds of error locations for tents of
+ functions can suck down a large amount of memory.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/main.lisp
+05-Jan-90 16:24:40, Edit by Ram.
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1tran.lisp
+05-Jan-90 15:58:34, Edit by Ram.
+ Changed *UNKNOWN-FUNCTIONS* to be an alist with one entry for each name, with
+ the value being a list of all the error contexts for the calls. Made
+ PRINT-SUMMARY print the undefined function warnings sorted by name, limiting
+ the number of warnings per function to *UNKNOWN-FUNCTION-WARNING-LIMIT*.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/main.lisp
+05-Jan-90 15:51:31, Edit by Ram.
+ Changed PRINT-SUMMARY to print a warning for each unknown function.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1tran.lisp
+05-Jan-90 15:46:02, Edit by Ram.
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1final.lisp
+05-Jan-90 15:45:49, Edit by Ram.
+ Moved detection of unknown function calls to
+ IR1-CONVERT-OK-COMBINATION-FER-SHER so that we can conveniently note the
+ error context each time around. *UNKNOWN-FUNCTIONS* is now a list of conses
+ (Name . Compiler-Error-Context), with entries for each call to an unknown
+ function.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1util.lisp
+05-Jan-90 15:22:04, Edit by Ram.
+ Split off error context determination from error printing by introducing the
+ COMPILER-ERROR-CONTEXT structure. The current error context can now be saved
+ for future use by calling FIND-ERROR-CONTEXT.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/debug-dump.lisp
+04-Jan-90 10:56:42, Edit by Ram.
+ New file.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/main.lisp
+04-Jan-90 10:39:31, Edit by Ram.
+ Put in hooks for dumping debug info.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/entry.lisp
+03-Jan-90 15:04:07, Edit by Ram.
+ Added code to dump the arg documentation. For now, we do pretty much what
+ the old compiler did, i.e. printing it to a string.
+ ### Eventually, we may want to put in code to flush package qualifiers on the
+ variable names and omit complex default forms.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/node.lisp
+03-Jan-90 14:44:54, Edit by Ram.
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1tran.lisp
+03-Jan-90 14:50:15, Edit by Ram.
+ Added FUNCTIONAL-ARG-DOCUMENTATION slot and made IR1 conversion set it.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/node.lisp
+03-Jan-90 14:34:44, Edit by Ram.
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1tran.lisp
+03-Jan-90 14:34:27, Edit by Ram.
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/debug.lisp
+03-Jan-90 14:40:06, Edit by Ram.
+ Added LAMBDA-OPTIONAL-DISPATCH and made IR1 conversion set it in :OPTIONAL
+ lambdas. Made consistency checker allow this.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1util.lisp
+03-Jan-90 14:07:30, Edit by Ram.
+ In DELETE-OPTIONAL-DISPATCH, don't clear the ENTRY-FUNCTION in the :OPTIONAL
+ lambdas. This info is now kept in the LAMBDA-OPTIONAL-DISPATCH slot, and is
+ not cleared when the lambda stops being an entry point.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/dfo.lisp
+03-Jan-90 10:35:50, Edit by Ram.
+ But we still want to compute the component name in such components...
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/dfo.lisp
+03-Jan-90 09:27:51, Edit by Ram.
+ Changed FIND-INITIAL-DFO to move all components containing a top-level lambda
+ to the end of the compilation order, even if there are XEPs. This does a
+ better job of ensuring that environment analysis is done before we compile
+ the top-level component which does cross-component references.
+ ### This probably still loses in some pathological case.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/main.lisp
+02-Jan-90 17:01:46, Edit by Ram.
+ Fixed CLEAR-IR2-INFO to check whether there is a tail set before attempting
+ to clear its INFO.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir2tran.lisp
+02-Jan-90 14:51:46, Edit by Ram.
+ Changed IR2-CONVERT-CLOSURE to not use the IR2-ENVIRONMENT-ENVIRONMENT, since
+ this is now blown away after the component is compiled. Instead we use the
+ ENVIRONMENT-CLOSURE, which is just as good. Actually, this should only
+ happen with references in XEPs, since that is the only kind of function that
+ can reference functions across component boundaries.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/main.lisp
+17-Dec-89 15:30:10, Edit by Ram.
+ Wrote CLEAR-IR2-INFO and made COMPILE-TOP-LEVEL call it after it was done
+ with the IR2 for each component. This should allow the IR2 data structures
+ to be reclaimed after each component is compiled, even in a multi-component
+ compilation.
+
+ ### Eventually it should be possible for the IR1 to be reclaimed after the
+ component is compiled, but there currently cross-component links that inhibit
+ this. It would also cause problems with IR1 consistency checking, since we
+ currently need to check all components together.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1tran.lisp
+15-Dec-89 13:33:44, Edit by Ram.
+ In IR1-CONVERT-VARIABLE, when we find a CT-A-VAL, we convert an ALIEN-VALUE
+ form rather than referencing the CT-A-VAL as a leaf.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1final.lisp
+13-Dec-89 13:38:51, Edit by Ram.
+ In NOTE-FAILED-OPTIMIZATION, also inhibit any attempt to give a note if the
+ combination is no longer a known call.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/gtn.lisp
+12-Dec-89 12:25:57, Edit by Ram.
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir2tran.lisp
+12-Dec-89 12:36:38, Edit by Ram.
+ To avoid having to fix this right right now, changed all passing locations to
+ be *ANY-PRIMITIVE-TYPE* and added code to do necessary coercions to/from the
+ actual variable representation.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/type.lisp
+12-Dec-89 10:21:15, Edit by Ram.
+ Fixed a bunch of declarations that were calling things TYPEs instead of
+ CTYPEs.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/main.lisp
+11-Dec-89 10:11:31, Edit by Ram.
+ Changed default fasl file extension from "fasl" to "nfasl", at least for now.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/fndb.lisp
+11-Dec-89 08:15:47, Edit by Ram.
+ Changed most uses of the FUNCTION type to CALLABLE, now that FUNCTION doesn't
+ encompass SYMBOL but we can still call them. Also fixed some lossage where
+ someone believed that the SUBSTITUTE/NSUBSTITUTE family of functions had the
+ same arguments as the DELETE/REMOVE family.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/srctran.lisp
+10-Dec-89 20:33:05, Edit by Ram.
+ Oops... (fifth x) /==> (nth 5 x), is really (nth 4 x). So that's why
+ PACKAGE-INIT was losing...
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/macros.lisp
+10-Dec-89 09:23:47, Edit by Ram.
+ Fixed DO-NODES-BACKWARDS to work when the current node is deleted now that
+ UNLINK-NODE blasts the PREV. Also fixed two bugs in this macro that seem not
+ to have affected the sole use in FLUSH-DEAD-CODE. One was that it randomly
+ referenced the variable CONT in one place, rather than commaing in the
+ appropriate argument. The other was that it did an extra iteration binding
+ CONT to the block start and NODE to whatever its USE was (often NIL.)
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1util.lisp
+09-Dec-89 13:31:24, Edit by Ram.
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1final.lisp
+09-Dec-89 13:30:52, Edit by Ram.
+ Wrote NODE-DELETED and made NOTE-FAILED-OPTIMIZATION call it so that we won't
+ gag trying to look at deleted code. This also prevents bogus efficiency
+ notes about code that was actually optimized away.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1util.lisp
+09-Dec-89 13:22:39, Edit by Ram.
+ Made UNLINK-NODE set the NODE-PREV of the deleted node to NIL so that we can
+ recognize deleted nodes. Also, fixed the degenerate exit branch to add a use
+ by EXIT rather than NODE.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/checkgen.lisp
+08-Dec-89 11:28:54, Edit by Ram.
+ Changed CONVERT-TYPE-CHECK to call LOCAL-CALL-ANALYZE now that this is not
+ being done in COMPILE-COMPONENT.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1opt.lisp
+08-Dec-89 11:24:13, Edit by Ram.
+ Fixed PROPAGATE-FUNCTION-CHANGE to call MAYBE-LET-CONVERT in addition to
+ COMVERT-CALL-IF-POSSIBLE so that IR1 optimize will let convert calls that it
+ discovers can be local.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/vop.lisp
+08-Dec-89 10:58:23, Edit by Ram.
+ Looks like when I made OLD-CONT and RETURN-PC environment TNs (and requiring
+ the IR2-ENVIRONMENT-SLOTS to be initialized after the environment was
+ created), I modified the wrong slots to allow NIL. Only detected now because
+ I was running with safe defstruct accessors.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/debug.lisp
+08-Dec-89 09:58:33, Edit by Ram.
+ IR1 invariants now a bit different: :DELETED continuations can only be
+ received by blocks with DELETE-P set, and blocks with DELETE-P set can have
+ no successors.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/locall.lisp
+08-Dec-89 09:51:24, Edit by Ram.
+ Don't attempt to let-convert when the REF is in a block with DELETE-P set
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1opt.lisp
+08-Dec-89 09:50:13, Edit by Ram.
+ Don't attempt to do IR1 optimizations when the block has DELETE-P set, just
+ delete it instead.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1util.lisp
+08-Dec-89 09:46:20, Edit by Ram.
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/node.lisp
+08-Dec-89 09:51:26, Edit by Ram.
+ Added BLOCK-DELETE-P and made DELETE-CONTINUATION set it in the DEST block
+ and its predecessors. Changed most uses of DELETE-CONTINUATION to assert
+ that there isn't a DEST.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1opt.lisp
+07-Dec-89 22:08:35, Edit by Ram.
+ In IR1-OPTIMIZE-IF, set COMPONENT-REANALYZE before UNLINK-NODE so that there
+ is still a component in the block.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1tran.lisp
+07-Dec-89 21:17:43, Edit by Ram.
+ In IR1-CONVERT-OK-COMBINATION-FER-SHER, set the CONTINUATION-%DERIVED-TYPE
+ and CONTINUATION-TYPE-CHECK of the fun cont in addition to setting
+ CONTINUATION-REOPTIMIZE.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/srctran.lisp
+07-Dec-89 21:08:09, Edit by Ram.
+ Moved definitions of the arithmetic & logic functions %LDB et al. here from
+ eval.lisp, since we need them in the bootstrapping environment.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1tran.lisp
+07-Dec-89 19:17:48, Edit by Ram.
+ Changed USE-CONTINUATION not to set the CONTINUATION-%DERIVED-TYPE, as this
+ inhibits CONTINUATION-DERIVED-TYPE from seeing whether the assertion needs to
+ be intersected, etc.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1opt.lisp
+07-Dec-89 18:55:32, Edit by Ram.
+ Changed IR1-OPTIMIZE to more explicitly ignore a block when it is directly
+ deleted due to :DELETED kind or no predecessors. The old code should have
+ realized not to optimize a deleted block, but in a rather obscure way.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/main.lisp
+07-Dec-89 13:25:38, Edit by Ram.
+ Changed IR1-OPTIMIZE-UNTIL-DONE to count the number of iterations that didn't
+ introduce any new code (set COMPONENT-REANALYZE) rather than just the total
+ number of iterations. Reduced MAX-OPTIMIZE-ITERATIONS to 3, since we now
+ don't have to worry so much about the results of transforms being adequately
+ optimized. Changed IR1-PHASES to call GENERATE-TYPE-CHECKS where it was
+ calling CHECK-TYPES. Flushed old call to GENERATE-TYPE-CHECKS in
+ COMPILE-COMPONENT.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1opt.lisp
+07-Dec-89 13:24:20, Edit by Ram.
+ Changed IR1-OPTIMIZE-IF to set COMPONENT-REANALYZE if it does anything.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/checkgen.lisp
+07-Dec-89 12:56:18, Edit by Ram.
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1opt.lisp
+07-Dec-89 12:28:19, Edit by Ram.
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ltn.lisp
+07-Dec-89 13:01:31, Edit by Ram.
+ Changed type checking around a bunch, fixing some bugs and inefficiencies.
+ The old CHECK-TYPES phase is gone. The determination of
+ CONTINUATION-TYPE-CHECK is now done on the fly by CONTINUATION-DERIVED-TYPE.
+ The compile-time type error detection has been moved into type check
+ generation. Type check generation is now driven by BLOCK-TYPE-CHECK, so it
+ doesn't have to look at everything on repeat iterations. Made
+ ASSERT-CONTINUATION-TYPE set BLOCK-TYPE-CHECK when there is a new assertion.
+
+ There are two new values of TYPE-CHECK: :ERROR and :NO-CHECK. These are used
+ by check generation to comminicate with itself and the back end. :ERROR
+ indicates a compile-time type error, which always causes a type check to be
+ emitted, regardless of policy. :NO-CHECK indicates that a check is needed,
+ but expected not to be generated due to policy or a safe implementation.
+ This inhibits LTN from choosing an unsafe implementation based on results of
+ new type information from the post-type-check optimization pass.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/type.lisp
+07-Dec-89 10:01:23, Edit by Ram.
+ Yep, that combined with a bug in how I hooked CTYPEP into TYPES-INTERSECT.
+ That function should return (VALUES T NIL) in the uncertain case, not
+ (VALUES NIL NIL).
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/type.lisp
+07-Dec-89 09:54:44, Edit by Ram.
+ Fixed CTYPEP to return the second value T when it calls TYPEP. Is this what
+ is causing all hell to break loose? It shouldn't, since it should just
+ result in increased type uncertainty.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/proclaim.lisp
+06-Dec-89 21:24:00, Edit by Ram.
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/macros.lisp
+06-Dec-89 21:26:24, Edit by Ram.
+ Added support for the DEBUG-INFO optimization quality (DEBUG for short).
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/type.lisp
+06-Dec-89 11:25:36, Edit by Ram.
+ Made CTYPEP return a second value indicating whether it was able to determine
+ the relationship. Made all callers look at the second value and propagate
+ the uncertainty.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/proclaim.lisp
+06-Dec-89 11:11:06, Edit by Ram.
+ Moved the actual establishing of the type definition to %%COMPILER-DEFSTRUCT
+ from %DEFSTRUCT. Part of this was actually duplicated both places. Now it
+ is only here. Hopefully this won't cause any initialization problems. Also,
+ made structure redefinition preserve the INCLUDED-BY list so that existing
+ structures won't suddenly be broken when the supertype is compiled.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1tran.lisp
+06-Dec-89 10:43:21, Edit by Ram.
+ Changed PROCESS-TYPE-PROCLAMATION to call SINGLE-VALUE-TYPE so that we don't
+ try to call TYPE-INTERSECTION on a hairy function type (or make the type of a
+ variable, for all that matter.)
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/main.lisp
+05-Dec-89 13:42:19, Edit by Ram.
+ Made NCOMPILE-FILE frob *DEFAULT-COOKIE* so as to make optimize proclamations
+ affect only the file that they appear in (and any compilations dynamically
+ enclosed in that file.)
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1tran.lisp
+04-Dec-89 09:38:18, Edit by Ram.
+ Flushed :SEMI-INLINE and :ALWAYS-INLINE values for INLINEP. Added
+ :MAYBE-INLINE, which is interpreted in a more advisory manner. Changed
+ IR1-CONVERT-GLOBAL-INLINE so that it does something like the old
+ :SEMI-INLINE case for all inline calls so that recursive functions can be
+ INLINE.
+
+ Fixed this code so that you really can have recursive inline functions. This
+ was supposedly supported for :SEMI-INLINE functions, but did not in fact
+ work. We do a hack similar to LABELS: we enter a dummy FUNCTIONAL in the
+ *FREE-FUNCTIONS* to prevent repeated attempts to convert the expansion.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/srctran.lisp
+03-Dec-89 15:03:48, Edit by Ram.
+ Defined SAME-LEAF-REF-P and made transforms for EQ, EQL, < and > use it to
+ see if both args are references to the same variable or functional or
+ whatever. Also use the EQ transform for CHAR= and EQUAL.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/main.lisp
+02-Dec-89 09:26:12, Edit by Ram.
+ Made MAX-OPTIMIZE-ITERATIONS be a ceiling on the number of times that
+ IR1-OPTIMIZE-UNTIL-DONE will iterate. If exceeded, we clear a bunch of
+ REOPTIMIZE flags and punt. This was made necessary by the addition of type
+ inference on set variables, which may take arbitrarily long to converge.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1opt.lisp
+01-Dec-89 14:05:10, Edit by Ram.
+ Added code to compute the type of set LET variables as the union of the types
+ of the initial value and the set values.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/checkgen.lisp
+01-Dec-89 12:11:57, Edit by Ram.
+ Added code to check to see if it is cheaper to check against the difference
+ between the proven type and the assertion. If so, emit a check against the
+ negation of this difference.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/srctran.lisp
+01-Dec-89 09:04:37, Edit by Ram.
+ Wrote IR1 transforms for < and > that attempt to statically determine the
+ relationship using type information.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/type.lisp
+01-Dec-89 10:06:56, Edit by Ram.
+ Wrote TYPE-DIFFERENCE.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir2tran.lisp
+30-Nov-89 12:04:24, Edit by Ram.
+ Marked the error signalling funny functions as not returning by using
+ TRULY-THE NIL. Formerly this was subverting type inference, since the
+ primitive was considered to return *.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1util.lisp
+30-Nov-89 11:52:27, Edit by Ram.
+ Made SUBSTITUTE-CONTINUATION-USES do a REOPTIMIZE-CONTINUATION on the New
+ continuation so that we realize we need to recompute its type, etc. This was
+ seriously crippling type inference. It probably came unglued in let
+ conversion when we changed over to using the general substitute function.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1tran.lisp
+30-Nov-89 11:31:00, Edit by Ram.
+ Changed FIND-FREE-VARIABLE to find the type of constants having values with
+ CTYPE-OF, rather than using INFO VARIABLE TYPE. This way we find a good type
+ for all constants, without interacting with the vagaries of environment query.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1opt.lisp
+30-Nov-89 10:50:37, Edit by Ram.
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/locall.lisp
+29-Nov-89 13:14:40, Edit by Ram.
+ Moved merging of tail sets from CONVERT-CALL to IR1-OPTIMIZE-RETURN. The old
+ code wasn't working because IR1 optimizations (such as deleting local EXITs)
+ could cause a local call to be tail-recursive yet the function would never
+ get added to the tail set because it had already been converted.
+
+ Inaccurate computation of the tail sets resulted in bad code problems, since
+ functions were returning in ways not expected by their callers.
+
+ ### This code still isn't quite right, since IR1 optimization is supposed to
+ be optional. One possible fix would be to do tail annotation in IR1
+ optimization, but then you would have to run IR1 optimize to get proper tail
+ recursion. This might not be much of an issue, since we will probably always
+ want to do at least some IR1 optimization.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/srctran.lisp
+27-Nov-89 12:35:17, Edit by Ram.
+ Fixed a braino in mask computation in the %DPB, %MASK-FIELD and
+ %DEPOSIT-FIELD transforms.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/fndb.lisp
+26-Nov-89 15:28:27, Edit by Ram.
+ Fixed MACRO-FUNCTION def to specify a result type of (OR FUNCTION NULL),
+ rather than just FUNCTION. This was disabling the use of this function as a
+ predicate to test whether a symbol names a macro. Also fixed the argument
+ order to REPLACE.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/srctran.lisp
+25-Nov-89 22:44:32, Edit by Ram.
+ Fixed RPLACx transforms to return the right value.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/type.lisp
+22-Nov-89 19:27:58, Edit by Ram.
+ Fixed the definition of STRING-CHAR so that it wouldn't seem to be a subtype
+ of STANDARD-CHAR.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/seqtran.lisp
+22-Nov-89 14:31:40, Edit by Ram.
+ In MAPPER-TRANSFORM, I seem to have inverted the sense of the exit test when
+ converting from CONSP to ENDP.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/main.lisp
+21-Nov-89 16:51:31, Edit by Ram.
+ Moved GTN before control analysis so that the IR2-Environment is allocated by
+ the time that control analysis runs.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/control.lisp
+21-Nov-89 16:38:24, Edit by Ram.
+ Moved to ADD-TO-EMIT-ORDER the adding of IR2-Blocks to the
+ IR2-ENVIRONMENT-BLOCKS. This way, overflow blocks created by conflict
+ analysis will appear in this list. TNs only live in overflow blocks were
+ being considered not to conflict with :ENVIRONMENT TNs.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/stack.lisp
+21-Nov-89 16:34:05, Edit by Ram.
+ Made DISCARD-UNUSED-VALUES make an IR2 block for the cleanup block and call
+ ADD-TO-EMIT-ORDER on it. I think that if this code ever ran, it would have
+ died. This code was tested at one point, so it was probably broken by the
+ move of control analysis to before all the other IR2 pre-passes.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/tn.lisp
+21-Nov-89 14:43:29, Edit by Ram.
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/gtn.lisp
+21-Nov-89 14:51:36, Edit by Ram.
+ Wrote MAKE-WIRED-ENVIRONMENT-TN so that the save TNs for old-cont and
+ return-pc could be made environment-live. Made ASSIGN-IR2-ENVIRONMENT pass
+ the environment to MAKE-xxx-SAVE-TN so that they could make environment-live
+ TNs.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/assembler.lisp
+20-Nov-89 08:58:31, Edit by Ram.
+ In NEW-LOGIOR-ARGUMENT, added code to check that the SB for :REGISTER
+ operands is really REGISTERS.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir2tran.lisp
+20-Nov-89 08:29:42, Edit by Ram.
+ In EMIT-MOVE, added code to emit a type error when moving between
+ incompatible TNs. It seems that this can happen with functions (especially
+ funny functions) that don't return. This seems like a good fix until we can
+ figure out how to hack the flow graph when there is a non-returning function.
+ [Incompatible moves may also happen if there is a compile-time type error and
+ the check is deleted due to unsafe policy, etc.]
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/fndb.lisp
+17-Nov-89 15:06:51, Edit by Ram.
+ Changed %PUT's IR1 attributes from (FLUSHABLE) to (UNSAFE).
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/srctran.lisp
+17-Nov-89 10:12:48, Edit by Ram.
+ Fixed some missing commas in SOURCE-TRANSFORM-TRANSITIVE that only affected
+ LOGEQV. Good thing nobody uses it...
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/vmdef.lisp
+16-Nov-89 09:42:37, Edit by Ram.
+ Fixed previous fix to work when there is a more result.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/vmdef.lisp
+15-Nov-89 13:57:36, Edit by Ram.
+ In TEMPLATE-TYPE-SPECIFIER, if we use a values type for the result, make it
+ &REST T to represent the vagueness of values count matching.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/srctran.lisp
+15-Nov-89 09:57:48, Edit by Ram.
+ Added missing source transform for LOGEQV, which was missed in the previous
+ pass. This required changing SOURCE-TRANSFORM-TRANSTIVE, since that was
+ already a source transform for LOGEQV. It's a good thing I left in *both*
+ checks for broken interpreter stubs.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/srctran.lisp
+14-Nov-89 10:41:51, Edit by Ram.
+ Added source transforms for zillions of trivial logic operations that were
+ missing.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1tran.lisp
+14-Nov-89 10:43:24, Edit by Ram.
+ In %DEFUN, added the presence of an IR2-CONVERT methods to the list of things
+ that inhibits substitution of the actual definition for existing references.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/srctran.lisp
+13-Nov-89 12:21:52, Edit by Ram.
+ Added source transforms for RPLACA, RPLACD.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1opt.lisp
+13-Nov-89 12:17:32, Edit by Ram.
+ Moved the test of NODE-REOPTIMIZE out of FIND-RESULT-TYPE and into
+ IR1-OPTIMIZE-RETURN. This fixes a bug that was introduced when the clearing
+ of NODE-REOPTIMIZE was moved to the start of the loop in IR1-OPTIMIZE-BLOCK.
+ We were never recomputing the RETURN-RESULT-TYPE, since REOPTIMIZE was never
+ set when we got to IR1-OPTIMIZE-RETURN. With this fix, the previous change
+ should detect broken interpreter stubs.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1final.lisp
+12-Nov-89 13:05:49, Edit by Ram.
+ Made CHECK-FREE-FUNCTION give a note when it sees a function that doesn't
+ return (return type is NIL.) I thought that this would detect broken
+ interpreter stubs. It turns out not to, but still seems like a useful
+ feature.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ltn.lisp
+13-Nov-89 11:47:30, Edit by Ram.
+ Made LTN-ANALYZE-KNOWN-CALL give a warning when we are unable to find a
+ template for a known call where there call is to the current function. This
+ should tell result in a warning when we compile an interpreter stub for a
+ function that the code sources assume is implemented primitively, but the
+ compiler doesn't recognize.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir2tran.lisp
+12-Nov-89 10:54:25, Edit by Ram.
+ Oops... When doing unsafe global function references, use
+ FAST-SYMBOL-FUNCTION, not FAST-SYMBOL-VALUE.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/main.lisp
+10-Nov-89 13:37:15, Edit by Ram.
+ Oops... Have to dump package frobbing forms specially for cold load. This
+ might want to be on a switch someday. Instead of actually compiling them, we
+ dump them as lists so that Genesis can eval them. The normal top-level form
+ compilation must be suppressed, since the package system isn't initialized at
+ the time that top-level forms run.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/dfo.lisp
+05-Nov-89 13:45:11, Edit by Ram.
+ Changed FIND-INITIAL-DFO to return top-level components at the end of the
+ list so that in a block compilation all the functions will be compiled before
+ we compile any of the top-level references to them.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/envanal.lisp
+01-Nov-89 11:57:58, Edit by Ram.
+ Changed Find-Non-Local-Exits back to a loop over all the blocks in the
+ component, rather than trying to find the exits from the Lambda-Entries.
+ Unfortunately, the latter is not possible, since the exit continuation may
+ become deleted if it isn't used. A possible way to avoid this search would
+ be to make the Entry node have a list of all the Exit nodes, rather than the
+ continuations.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/vop.lisp
+31-Oct-89 12:45:20, Edit by Ram.
+ Allow (SETF xxx) for the Entry-Info-Name, in addition to strings and symbols.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1util.lisp
+31-Oct-89 12:53:37, Edit by Ram.
+ In Find-Source-Context, only take the car of list first args to DEFxxx forms
+ when the form name is in a special list. This list initially only contains
+ DEFSTRUCT.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1tran.lisp
+31-Oct-89 12:23:57, Edit by Ram.
+ In Convert-More-Entry, made the temporaries for the keyword and value
+ ignorable so that we don't get "defined but never read" warnings when there
+ aren't any keywords specified.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1tran.lisp
+31-Oct-89 12:11:24, Edit by Ram.
+ Fixed Process-Declarations to correctly deal with pervasive special
+ declarations. Previously, a warning would be given if the varible was only
+ locally declared, and not globally known. Also an assertion failure would
+ have resulted (rather than a Compiler-Error) when a constant was declared
+ pervasively special.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1tran.lisp
+31-Oct-89 11:39:54, Edit by Ram.
+ Changed Reference-Constant so that it doesn't call Reference-Leaf anymore,
+ and made the source be an explicit argument. Changed Reference-Leaf to just
+ use the Leaf-Name as source, rather than (sometime incorrectly) inferring the
+ source for constants.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir2tran.lisp
+20-Oct-89 15:56:56, Edit by Ram.
+ In the :UNKNOWN and :UNUSED cases of CONTINUATION-RESULT-TNS, always return
+ TNs of the specified result types, rather than sometimes returing T TNs.
+ This is some sort of compensation for our new belief that VOPS returining
+ non-T results need not be prepared to accept T TNs. How many other places
+ does this need to be fixed?
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/stack.lisp
+17-Oct-89 12:36:38, Edit by Ram.
+ In FIND-PUSHED-CONTINUATIONS, fix the check for pushes coming before pops.
+ You can compare nodes and continuations all day without finding any that are
+ EQ.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/macros.lisp
+17-Oct-89 11:44:40, Edit by Ram.
+ Flushed the code in DEFTRANSFORM that was creating a THE out of the CONT's
+ asserted type. This should be unnecessary, and was made incorrect by the
+ continuation representation change. If the node was the last in a block and
+ the value wasn't used, then the value would be asserted to be of the NIL
+ type, resulting in a warning.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1util.lisp
+17-Oct-89 10:51:27, Edit by Ram.
+ Changed Compiler-Mumble to tell whether an error message precedes from
+ *last-format-string*, rather than *last-source-context*, since the last
+ message might not have had a source context. Made *compiler-error-output* be
+ globally bound to a synonym stream for *error-output* so that calls to
+ Compiler-Error outside of the compiler will more or less work.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/checkgen.lisp
+16-Oct-89 15:23:13, Edit by Ram.
+ In Convert-Type-Check, set the start & end cleanups of the new block to the
+ *start* cleanup of the Dest's block, and not the end cleanup. Not sure this
+ is really more correct, but it fixes one case.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/pack.lisp
+12-Oct-89 14:05:43, Edit by Ram.
+ Added a before-GC hook that flushes the per-SB conflict data structure
+ whenever they aren't being used. This should prevent megabyte-plus conflicts
+ information from persisting after it is needed, and also reduce the cost of
+ Init-SB-Vectors, since the vectors will stay smaller.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1opt.lisp
+11-Oct-89 11:37:16, Edit by Ram.
+ Made Propagate-Function-Change ignore references that are :Notinline.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1util.lisp
+10-Oct-89 23:28:33, Edit by Ram.
+ In Print-Error-Message, use the *Current-Form* as the source form whenever if
+ is non-NIL, even if there is a node in *Compiler-Error-Context*. This way,
+ messages during IR1 conversion of a transform will be more useful.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1util.lisp
+10-Oct-89 22:47:56, Edit by Ram.
+ Now Delete-Optional-Dispatch must be prepared for the main entry to be a let
+ rather than just being deleted or a normal function, since let conversion is
+ being triggered here.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/locall.lisp
+09-Oct-89 17:56:35, Edit by Ram.
+ Fixed Convert-Call to change the combination kind before changing the ref
+ leaf so that the call will appear local at that time. This allows let
+ conversion to happen when we replace a optional dispatch with one of its EPs.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1util.lisp
+09-Oct-89 17:34:42, Edit by Ram.
+ Fixed Delete-Optional-Dispatch to call Maybe-Let-Convert if we notice that a
+ former EP lambda has exactly one reference.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1opt.lisp
+04-Oct-89 19:05:16, Edit by Ram.
+ In IR1-Optimize-Combination, we must be prepared for the derive-type method
+ to return NIL. This will happen if the arglist is incompatible with the
+ call (and if the optimizer explicitly returns NIL.)
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/macros.lisp
+04-Oct-89 19:22:17, Edit by Ram.
+ Check-Transform-Keys and Check-Keywords-Constant were checking the second
+ (value) part of the key/value pair, so optimizers would never run if any
+ keywords were supplied.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1opt.lisp
+04-Oct-89 15:39:27, Edit by Ram.
+ When I changed Propagate-Local-Call-Args to clear the Continuation-Reoptimize
+ flags, I forgot that a local call continuation can be NIL (for an unused
+ argument.)
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1opt.lisp
+04-Oct-89 11:05:48, Edit by Ram.
+ Oops... In Propagate-Function-Change, we have to use
+ Continuation-Derived-Type rather than Continuation-Type now that the latter
+ changes function types to FUNCTION.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/globaldb.lisp
+27-Sep-89 14:24:04, Edit by Ram.
+ Exported basic interface (but not environment vars, pending some abstract
+ interface to environment manipulation.) Changed class and type names to be
+ represented as strings at run time to avoid package lossage. Changed names
+ to be arbitrary equal objects (to allow setf functions).
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir2tran.lisp
+21-Sep-89 10:12:38, Edit by Ram.
+ Changed OK-Result-TN to indicate need for a coercion if the result is unboxed
+ and the TN is boxed. This prevents load-TN packing from getting confused due
+ to there being no intersection between the SC restriction and the types
+ allowed by the SC. This would happen when the result was restricted to a
+ non-descriptor SC.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ltn.lisp
+21-Sep-89 10:39:04, Edit by Ram.
+ Changed Restrict-Descriptor-Args to restrict the argument only when a
+ coercion was required. This allows immediate objects to be passed to
+ templates in unboxed registers.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1util.lisp
+30-Aug-89 14:37:36, Edit by Ram.
+ Changed Change-Leaf-Ref (and hence Substitute-Leaf) to use Derive-Node-Type
+ on the Ref with the Leaf-Type so that substituting a variable causes the new
+ type to be noticed.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1opt.lisp
+30-Aug-89 14:30:44, Edit by Ram.
+ Changed IR1-Optimize-Block and all the combination optimization code to clear
+ optimize flags *before* optimizing rather than after, so that a node will be
+ reoptimized if necessary.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/vmdef.lisp
+29-Aug-89 09:20:18, Edit by Ram.
+ Made Template-Type-Specifier hack *'s in operand type restrictions.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ltn.lisp
+24-Aug-89 13:55:04, Edit by Ram.
+ In LTN-Analyze-MV-Call, have to annotate the continuations in reverse order,
+ now that the IR2-Block-Popped isn't built in reverse order.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ltn.lisp
+24-Aug-89 13:25:14, Edit by Ram.
+ In LTN-Analyze, eliminated assertion that the block containing the use of a
+ unknown-values continuation is not already in the
+ IR2-Component-Values-Generators. It is possible for a single block to
+ contain uses of several MV continuations that have their DEST in a different
+ block.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/dfo.lisp
+22-Aug-89 12:12:49, Edit by Ram.
+ Made Find-Initial-DFO-Aux call Walk-Home-Call-Graph on each block before
+ walking the successors. Walk-Home-Call-Graph is a new function that looks at
+ the current block's home lambda's bind block to see if it is in a different
+ component. We need to do this to ensure that all code in a given environment
+ ends up in the same component, since any successor might be a non-local exit
+ (into a different environment.)
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1tran.lisp
+18-Aug-89 15:46:51, Edit by Ram.
+ Flushed the (locally (declare (optimize (safety 0))) ...) around the body of
+ Unwind-Protect's expansion. I think that this was trying to suppress some
+ type checking of the MV-Bind, but it was also causing unsafe compilation of
+ the protected form. If we really need this, it must be but back some other
+ way.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir2tran.lisp
+18-Aug-89 15:11:13, Edit by Ram.
+ Oops... We can't use Label-Offset in the generators for Make-Catch-Block,
+ &c. Instead, we use a :Label load-time constant. The target argument to the
+ VOPs is now a normal integer argument, rather than a label in the
+ codegen-info.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ltn.lisp
+18-Aug-89 14:13:51, Edit by Ram.
+ In LTN-Analyze-Return, don't annotate NLX continuations as :Unused so that
+ the NLX entry code doesn't have to worry about this case.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1opt.lisp
+18-Aug-89 13:45:19, Edit by Ram.
+ In Reoptimize-Continuation, don't do anything if the continuation is deleted.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1util.lisp
+17-Aug-89 11:17:13, Edit by Ram.
+ Oops... In Node-Ends-Block, have to set the Block-Start-Uses, now that it is
+ always supposed to hold the uses of block starts.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ltn.lisp
+10-Aug-89 10:49:01, Edit by Ram.
+ Changed Find-Template to intersect the Node-Derived-Type with the
+ Continuation-Asserted-Type rather than using the Continuation-Derived-Type in
+ the case where we are allowed to use the result type assertion. This works
+ better when the continuation has multiple uses.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/typetran.lisp
+24-Jul-89 14:25:09, Edit by Ram.
+ Fixed Source-Transform-Union-Typep to check that there really is a MEMBER
+ type in the union, instead of assuming there is whenever LIST is a subtype.
+ This was losing on (OR SYMBOL CONS).
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/assembler.lisp
+19-Jul-89 14:36:10, Edit by Ram.
+ Made Init-Assembler nil out the Info slots in all the fixups so that the
+ fixup freelist doesn't hold onto the entire IR. More storage allocation
+ lossage has been caused by the explicit freelists in the assembler than
+ anything else.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/macros.lisp
+12-Jul-89 15:34:09, Edit by Ram.
+ Changed defining macros to stick the actual function object into the
+ Function-Info &c to be compatible with the new definition of the Function
+ type.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir2tran.lisp
+12-Jul-89 12:57:24, Edit by Ram.
+ Fixed goof in IR2-Convert-Local-Unknown call, where it was converting the
+ result TN list to TN-refs twice. For some reason, this was dying with a
+ highly mysterious error in Reference-TN-List. Perhaps this file was last
+ compiled with an unsafe policy?
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/life.lisp
+11-Jul-89 19:29:05, Edit by Ram.
+ In Propagate-Live-TNs, when we convert a :Read-Only conflict to :Live, we
+ null the entry in the local TNs to represent the elimination of local
+ conflict information.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1tran.lisp
+11-Jul-89 18:46:17, Edit by Ram.
+ Changed %Defun to only substitute the functional when it isn't notinline and
+ isn't known to have any templates or transforms. The latter constraint fixes
+ big problems with interpreter stubs.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1tran.lisp
+05-Jul-89 22:11:10, Edit by Ram.
+ In Return-From, put back code that made Cont start a block so that Cont will
+ have a block assigned before IR1-Convert. So that's why that was there.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ltn.lisp
+05-Jul-89 18:07:48, Edit by Ram.
+ In Annotate-Unknown-Values-Continuation, make a safety note when we delete a
+ check and the policy is safe.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir1opt.lisp
+05-Jul-89 17:43:18, Edit by Ram.
+ In IR1-Optimize-Exit, don't propagate Cont's type to the Value, since this
+ moves checking of the assertion to the Exit, which is a bad place.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir2tran.lisp
+05-Jul-89 15:10:34, Edit by Ram.
+ In Emit-Return-For-Locs, changed the test for when to use known return
+ convention from External-Entry-Point-P to *not* External-Entry-Point-P.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ir2tran.lisp
+05-Jul-89 14:41:55, Edit by Ram.
+ Oops... We need a UWP-Entry VOP for Unwind-Protect entries to force random
+ live TNs onto the stack. It doesn't actually do anything, but specifies the
+ passing locations as results so that they aren't forced to the stack.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/ltn.lisp
+03-Jul-89 16:46:09, Edit by Ram.
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/stack.lisp
+03-Jul-89 16:39:53, Edit by Ram.
+ Changed unknown values hackery to ignore non-local exits. We don't record
+ NLX uses of unknown-values continuations as generators, and we stop
+ our graph walk when we hit the component root. These changes were
+ necessitated by the decision to make %NLX-Entry no longer use the values
+ continuation.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/pack.lisp
+03-Jul-89 11:31:36, Edit by Ram.
+ Fixed one-off error in Pack-Wired-TN's determination of when we have to grow
+ the SB, and fixed it to handle SC-Element-Size /= 1 while I was at it.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/locall.lisp
+29-Jun-89 12:02:16, Edit by Ram.
+ In Local-Call-Analyze-1, moved the test for the reference being by the
+ Basic-Combination-Fun to around the entire branch that attempts to convert,
+ rather than immediately around the call to Convert-Call-If-Possible. Before,
+ a closure arg to a local function wouldn't get an XEP.
+
+ Also, changed Reference-Entry-Point to ignore references to :Cleanup and
+ :Escape functions.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/envanal.lisp
+28-Jun-89 16:57:12, Edit by Ram.
+ In Emit-Cleanups, if we find there is no cleanup code, then do nothing,
+ instead of inserting a cleanup block holding NIL. This was causing blocks
+ with no non-local uses to inhibit tail-recursion.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/checkgen.lisp
+28-Jun-89 14:03:45, Edit by Ram.
+ It finally happened. A paren error that resulted in mysterious lossage. In
+ this case, the body of the loop in Make-Type-Check-Form was moved out of the
+ loop, and always executed once. The meant that only one value would ever be
+ checked or propagated on to the original receiver.
+
+/afs/cs.cmu.edu/project/clisp/new-compiler/compiler/pack.lisp
+28-Jun-89 13:20:59, Edit by Ram.
+ Oops... I introduced a bug in the previously correct argument case of
+ Load-TN-Conflicts-In-SB. We terminate the loop when we reach the first
+ reference, not the first argument. This caused conflicts with temporaries
+ with lives beginning at :Load to be ignored.
+
+/usr1/lisp/compiler/pack.lisp, 23-Jun-89 15:54:32, Edit by Ram.
+ Fixed logic in Load-TN-Conflicts-In-SB. We weren't recognizing conflicts
+ with other argument/result TNs that had already been packed. This bug would
+ only show up with multiple result load TNs. The argument case was actually
+ correct, but was asymmetrical with the result case, and only worked becase
+ argument load TNs were packed in evaluation order.
+
+/usr1/lisp/compiler/locall.lisp, 20-Jun-89 14:53:51, Edit by Ram.
+ In Merge-Tail-Sets, quietly do nothing if the called function has no tail set
+ (doesn't return), rather than dying.
+
+/usr1/lisp/compiler/globaldb.lisp, 14-Jun-89 10:14:04, Edit by Ram.
+ Flushed Top-Level-P attribute.
+
+/usr1/lisp/compiler/macros.lisp, 14-Jun-89 10:14:03, Edit by Ram.
+ Allow a doc string in Def-IR1-Translator (made the FUNCTION documentation).
+ Removed support for Top-Level-P attribute.
+
+/usr1/lisp/compiler/ir1opt.lisp, 22-May-89 15:30:59, Edit by Ram.
+/usr1/lisp/compiler/ir1util.lisp, 22-May-89 15:22:17, Edit by Ram.
+ Undid last change to Node-Ends-Block and Join-Blocks. This was fucking up
+ big time, since it messed with the continuation even when it was a block
+ start.
+
+/usr1/lisp/compiler/locall.lisp, 22-May-89 13:24:48, Edit by Ram.
+ Changed Local-Call-Analyze to maintain the Component-New-Functions exactly up
+ to date, only popping a function off exactly as it analyzes it. This way, a
+ lambda is always referenced either in the Lambdas or New-Functions (except
+ during a brief window), so we can do consistency checking during local call
+ analysis.
+
+/usr1/lisp/compiler/ir1util.lisp, 19-May-89 10:05:28, Edit by Ram.
+/usr1/lisp/compiler/ir1opt.lisp, 19-May-89 10:05:27, Edit by Ram.
+ In Flush-Dest and Reoptimize-Continuation, take care not to assume that the
+ Continuation-Block is an undeleted block. Instead, we pick up the component
+ to reoptimize from the uses or Dest.
+
+/usr1/lisp/compiler/ir2tran.lisp, 17-May-89 12:48:35, Edit by Ram.
+ In Move-Results-Coerced and Move-Results-Checked, subtract Nsrc from Ndest,
+ rather than the other way around.
+
+/usr1/lisp/compiler/control.lisp, 15-May-89 11:53:36, Edit by Ram.
+ Made Control-Analyze walk XEPs first to eliminate the idiocy of never getting
+ the drop-through in components with only one EP.
+
+/usr1/lisp/compiler/ir1util.lisp, 13-May-89 15:23:28, Edit by Ram.
+ And similarly, in Node-Ends-Block, move the last continuation to the new
+ block when its block is the old block.
+
+/usr1/lisp/compiler/ir1opt.lisp, 13-May-89 15:02:31, Edit by Ram.
+ In Join-Blocks, move the Cont of the Last to Block1 when it's block is
+ currently Block2. This way, the continuation isn't left pointing at some
+ random deleted block.
+
+/usr1/lisp/compiler/ir1util.lisp, 14-Mar-89 10:12:04, Edit by Ram.
+ Also, in Delete-Block, when we delete a bind, call Delete-Lambda, rather
+ than trying to roll our own.
+
+/usr1/lisp/compiler/ir1util.lisp, 14-Mar-89 10:07:01, Edit by Ram.
+ In Delete-Lambda, we must remove a let from its home's lets.
+
+/usr1/lisp/compiler/ir1util.lisp, 14-Mar-89 09:34:54, Edit by Ram.
+ In Unlink-Node, the assertion that the start and end cleanups are the same
+ must use Find-Enclosing-Cleanup, rather than just comparing the values
+ directly.
+
+/usr1/lisp/compiler/ir2tran.lisp, 14-Mar-89 08:26:04, Edit by Ram.
+ Wrote Flush-Tail-Transfer and made people who do TR stuff use it. This
+ function deletes the link between the blocks for a TR node and the block
+ containing the return node. We have to do this so that lifetime analysis
+ doesn't get confused when there are TNs live at the return node, but some
+ predecessors of the return don't write the TNs because the return some other
+ way.
+
+/usr1/lisp/compiler/srctran.lisp, 10-Mar-89 19:11:51, Edit by Ram.
+ Made the transforms into %typep always pass until we do type predicates for
+ real.
+
+/usr1/lisp/compiler/assembler.lisp, 10-Mar-89 18:56:45, Edit by Ram.
+ Fixed Macrolet of Emit-Label in Def-Branch to have a paren in the right
+ place. As written, it expanded into its argument, and didn't enclose any
+ code anyway. But I think this would only affect instructions that both were
+ a branch and had a load-time fixup.
+
+/usr1/lisp/compiler/assembler.lisp, 10-Mar-89 18:47:50, Edit by Ram.
+ Added code to Def-Branch in the choose function that calls
+ Undefined-Label-Error when the the label isn't defined. This function uses
+ the *assembler-nodes* source info and the branch instruction location to
+ print the source node responsible for generating the bogus branch.
+
+/usr1/lisp/compiler/assembler.lisp, 10-Mar-89 17:59:51, Edit by Ram.
+ Made Gen-Label initalize the Elsewhere-P slot to :Undecided. Also made
+ Merge-Code-Vectors ignore labels whose Elsewhere-P is undecided. The theory
+ is that it should be o.k. to make labels that aren't emitted as long as you
+ don't reference them. Of course, I will probably find that the losing labels
+ are referenced. Renamed the Location slot in Label to %Location, and defined
+ Label-Location to filter out undefined labels.
+
+/usr1/lisp/compiler/ltn.lisp, 10-Mar-89 17:43:39, Edit by Ram.
+ In LTN-Analyze-Return, we must check for the Return-Info-Count being :Unknown
+ rather than null when we want to know if a fixed number of values are
+ returned.
+
+/usr1/lisp/compiler/ir2tran.lisp, 07-Mar-89 18:13:12, Edit by Ram.
+ In the Values-List IR2 convert method, we must also handle :Unused
+ continuations, only punting when the continuation is :Fixed. When called
+ with a TR result continuation, we have to emit the unknown-values return
+ ourself. Otherwise, there isn't any way to write the Values-List function.
+
+/usr1/lisp/compiler/ir2tran.lisp, 06-Mar-89 21:25:12, Edit by Ram.
+ Make-Closure takes the number of closure vars and the function-entry, rather
+ than the other way around.
+
+/usr1/lisp/compiler/ir2tran.lisp, 06-Mar-89 20:48:29, Edit by Ram.
+ And always pass 1 as the number of symbols to Unbind, rather than 0.
+
+/usr1/lisp/compiler/ir2tran.lisp, 06-Mar-89 20:43:47, Edit by Ram.
+ Args to the Bind miscop are (Value, Symbol), and not the other way around.
+
+/usr1/lisp/compiler/ir2tran.lisp, 06-Mar-89 19:09:16, Edit by Ram.
+ In IR2-Convert-IF, we have to negate the sense of the test when using an EQ
+ NIL check. Made IR2-Convert-Conditional take an additional not-p argument.
+
+/usr1/lisp/compiler/ctype.lisp, 06-Mar-89 17:22:40, Edit by Ram.
+ In Definition-Type, when we make the Function-Type, include the list of
+ keyword info that we have built.
+
+/usr1/lisp/compiler/ir2tran.lisp, 02-Mar-89 18:16:40, Edit by Ram.
+ In Init-XEP-Environment, when we are checking for whether there is a more
+ arg, look at the entry-function rather than the XEP.
+
+/usr1/lisp/compiler/main.lisp, 01-Mar-89 15:58:32, Edit by Ram.
+ Made Clear-Stuff clear the Finite-SB-Live-TNs in all SBs. Maybe this will
+ nuke some garbage.
+
+/usr1/lisp/compiler/pack.lisp, 01-Mar-89 15:50:41, Edit by Ram.
+ In Grow-SC, fill the Finite-SB-Live-TNs vector with NILs before we lose it so
+ that if it is statically allocated, it won't hold onto garbage. But this
+ shouldn't make any difference, since we never use the Live-TNs in unbounded
+ SBs.
+
+/usr1/lisp/compiler/locall.lisp, 01-Mar-89 01:15:22, Edit by Ram.
+ In Make-XEP-Lambda, in the lambda case, we now include an ignore declaration
+ for the nargs var when policy suppresses the argument count check.
+
+/usr1/lisp/compiler/ir1util.lisp, 28-Feb-89 19:39:56, Edit by Ram.
+ Also clear :Optional kind for the Main-Entry in Delete-Optional-Dispatch.
+
+/usr1/lisp/compiler/locall.lisp, 28-Feb-89 19:31:07, Edit by Ram.
+ Changed Local-Call-Analyze so that it pushes new lambdas on the
+ Component-Lambdas before it does any call analysis or let conversion. This
+ gets the normal consistency maintenance code to handle removal of deleted
+ and let lambdas. Before, there was a local list of new lambdas that could
+ become inconsistent.
+
+/usr1/lisp/compiler/ir1tran.lisp, 28-Feb-89 18:12:15, Edit by Ram.
+ Instead of trying to set the :Optional kind everywhere that hairy lambda
+ conversion creates a lambda, we wait until we are done and set the kind only
+ the lambdas that are actually e-ps. This was causing internal lambdas that
+ weren't e-ps to be marked as optional. The fix is also clearer, and causes
+ less complication in the already-hairy code.
+
+/usr1/lisp/compiler/ir1tran.lisp, 24-Feb-89 15:26:29, Edit by Ram.
+ Changed Optional-Dispatch stuff to set the Functional-Entry-Function of the
+ :Optional lambdas to the result Optional-Dispatch structure.
+
+/usr1/lisp/compiler/ir1opt.lisp, 24-Feb-89 14:46:57, Edit by Ram.
+ In IR1-Optimize, changed test for being in a deleted lambda to just look at
+ the block-lambda, rather than at it's home. The result should be the same.
+
+/usr1/lisp/compiler/entry.lisp, 24-Feb-89 14:30:37, Edit by Ram.
+ Changed Compute-Entry-Info to use the XEP's environment to determine whether
+ the function is a closure. The result should be the same, but is more easily
+ obtained.
+
+/usr1/lisp/compiler/ir1util.lisp, 24-Feb-89 14:26:58, Edit by Ram.
+ Deleted definition of Find-XEP-Call, since this doesn't make sense anymore.
+
+/usr1/lisp/compiler/debug.lisp, 24-Feb-89 14:21:09, Edit by Ram.
+ Flushed permission of random wired live TNs at the start of an XEP.
+
+/usr1/lisp/compiler/debug.lisp, 24-Feb-89 14:18:01, Edit by Ram.
+ In Check-Block-Successors, flushed permission of random successor count in
+ XEPs.
+
+/usr1/lisp/compiler/ir2tran.lisp, 24-Feb-89 14:14:12, Edit by Ram.
+ Flushed check for being the bind block for an XEP that inhibited emission of
+ a block-finishing branch in Finish-IR2-Block. Control flow is now normal in
+ XEPs, so we don't want to randomly flush branches.
+
+/usr1/lisp/compiler/ir1opt.lisp, 24-Feb-89 14:07:52, Edit by Ram.
+ Flushed check for being in an XEP in Join-Successor-If-Possible. Now that
+ argument count dispatching is done explicitly, there is no need to force the
+ call to a block boundry (for easy location). Also, we are getting more
+ complex code in the XEP, making block merging a desirable optimization.
+
+/usr1/lisp/compiler/ir1util.lisp, 24-Feb-89 14:03:35, Edit by Ram.
+ Fixed code in Delete-Lambda that was trying to notice when we are deleting
+ the the XEP for an optional dispatch. The test was right, but the action was
+ wrong: it was setting the Functional-Entry-Function for all the e-p's to NIL,
+ yet they were already NIL. Instead, we call Delete-Optional-Dispatch, which
+ deletes the unreferenced e-p's.
+
+/usr1/lisp/compiler/ir1tran.lisp, 23-Feb-89 20:17:21, Edit by Ram.
+ Wrapped a (locally (declare (optimize (safety 0))) ...) around the body of
+ the loop created in Convert-More-Entry so that no type checking is done on
+ the fixnum arithmetic.
+
+/usr1/lisp/compiler/ir2tran.lisp, 23-Feb-89 14:34:49, Edit by Ram.
+ Flushed most of the hair associated with the %Function-Entry funny function.
+ What remains is now in Init-XEP-Environment, which is called by
+ IR2-Convert-Bind when the lambda is an XEP.
+
+/usr1/lisp/compiler/gtn.lisp, 23-Feb-89 14:24:20, Edit by Ram.
+ Flushed some special-casing of XEPs that is no longer needed now that XEP's
+ have args. Also, allocation of argument passing locations in XEPs is now
+ more similar to the non-XEP case: we don't allocate passing locations for
+ unused arguments.
+
+/usr1/lisp/compiler/locall.lisp, 22-Feb-89 15:26:50, Edit by Ram.
+ Change handling of XEPs. Most of the action in XEPs is now represented by
+ explicit IR1 in the XEP: argument dispatching is done by a COND, etc.
+ Instead of using funny functions such as %XEP-ARG to access the passed
+ arguments, NARGS and all the positional arguments are passed as arguments to
+ the XEP (with garbage defaults for unsupplied args). The code in the XEP
+ just references these variables.
+
+ This simplifies creation of the XEP, since we can just cons up a lambda form
+ and convert it, instead of creating each XEP call by hand. It also moves
+ complexity out of IR2 conversion, since argument dispatching has already been
+ implemented.
+
+/usr1/lisp/compiler/ir2tran.lisp, 16-Feb-89 15:12:17, Edit by Ram.
+ Fixed %XEP-Arg to use Move-Argument rather than just Move.
+
+/usr1/lisp/compiler/node.lisp, 15-Feb-89 00:36:30, Edit by Ram.
+ Made Functional specify :Defined and Function as the defaults for the
+ Where-From and Type slots so that we know defined functions are in fact
+ functions.
+
+/usr1/lisp/compiler/ir1tran.lisp, 14-Feb-89 23:48:37, Edit by Ram.
+ In %Defun translator, fixed the test for being at top level (and thus o.k. to
+ substitute). The sense was negated, but it was also broken so that it was
+ always false, so the normal top-level thing happened anyway.
+
+/usr1/lisp/compiler/ir1tran.lisp, 14-Feb-89 15:02:14, Edit by Ram.
+ Wrote Leaf-Inlinep and changed uses to (cdr (assoc leaf *inlines*)) with the
+ new function. This means that global declarations will now affect function
+ references.
+
+/usr1/lisp/compiler/main.lisp, 13-Feb-89 12:19:39, Edit by Ram.
+ Call Init-Assembler *before* Entry-Analyze so that we don't emit labels when
+ the assembler isn't initialized.
+
+/usr1/lisp/compiler/ltn.lisp, 02-Feb-89 15:41:40, Edit by Ram.
+ Changed Annotate-Function-Continuation not to clear Type-Check unless the
+ policy is unsafe. Changed LTN-Default-Call to take a policy argument and
+ pass it through.
+
+/usr1/lisp/compiler/ir1tran.lisp, 02-Feb-89 15:16:32, Edit by Ram.
+ Changed IR1-Convert-Combination-Args and the translator for
+ Multiple-Value-Call to assert that the function continuation yeilds a value
+ of type Function.
+
+/usr1/lisp/compiler/assembler.lisp, 31-Jan-89 14:13:54, Edit by Ram.
+/usr1/lisp/compiler/codegen.lisp, 31-Jan-89 14:13:53, Edit by Ram.
+ Added a function version of Emit-Label that can be called outside of
+ Assemble. Used this in Generate-Code so that we don't have to worry about
+ faking the current node for Assemble, when we aren't emitting any code
+ anyway.
+
+/usr1/lisp/compiler/assembler.lisp, 31-Jan-89 13:56:08, Edit by Ram.
+ In Init-Assembler, Null out the Assembler-Node-Names in *Assembler-Nodes* so
+ that we don't hold onto old garbage. Also zero the code vectors so that
+ unitialized bytes always come up zero.
+
+/usr1/lisp/compiler/ir2tran.lisp, 31-Jan-89 12:37:21, Edit by Ram.
+ Fixed IR2-Convert-Local-Unknown-Call to use Standard-Value-TNs to get the
+ result TNs, rather than calling incorrectly calling Make-Standard-Value-TNs
+ on a continuation.
+
+/usr1/lisp/compiler/ir1opt.lisp, 30-Jan-89 23:28:08, Edit by Ram.
+ Changed Check-Types to not set Type-Check when the asserted type is T and the
+ derived type is *.
+
+/usr1/lisp/compiler/ir1util.lisp, 30-Jan-89 19:36:09, Edit by Ram.
+ Changed Delete-Ref not to call Delete-Lambda or Delete-Optional-Dispatch when
+ the functional is already deleted.
+
+/usr1/lisp/compiler/locall.lisp, 30-Jan-89 19:23:26, Edit by Ram.
+ Convert-MV-Call must add the ep to the Lambda-Calls for the home lambda (as
+ in Convert-Call) so that DFO can detect the control transfer implicit in
+ local call.
+
+/usr1/lisp/compiler/ir1util.lisp, 30-Jan-89 18:30:27, Edit by Ram.
+ Changed Delete-Optional-Dispatch to call Delete-Lambda on all entry points
+ with no references.
+
+/usr1/lisp/compiler/ir1util.lisp, 30-Jan-89 17:04:33, Edit by Ram.
+ Changed Delete-Lambda to mark the Lambda's lets as :Deleted as well,
+ guaranteeing that all code in the environment of a deleted lambda is deleted
+ (without having to do flow analysis).
+
+/usr1/lisp/compiler/locall.lisp, 30-Jan-89 16:37:31, Edit by Ram.
+ Changed Convert-MV-Call not to call Let-Convert, since the last entry may
+ have spurious references due to optional defaulting code that hasn't been
+ deleted yet. Changed Maybe-Let-Convert to set the Functional-Kind of the
+ lambda to :Let or :MV-Let, depending on the combination type.
+
+/usr1/lisp/compiler/locall.lisp, 30-Jan-89 15:35:52, Edit by Ram.
+ Changed Merge-Cleanups-And-Lets to use Find-Enclosing-Cleanup to determine
+ whether there is any cleanup in effect at the call site, rather than directly
+ using the Block-End-Cleanup.
+
+/usr1/lisp/compiler/ir1util.lisp, 30-Jan-89 15:12:51, Edit by Ram.
+ Changed Node-Ends-Block to set the start and end cleanups of the *new* block
+ (not the old) to the ending cleanup of the old block. This is clearly more
+ right, but may not be totally right.
+
+/usr1/lisp/compiler/life.lisp, 27-Jan-89 17:09:01, Edit by Ram.
+ Make Clear-Lifetime-Info always set the TN-Local slot for local TNs, using
+ some other referencing block when there there are global conflicts.
+
+/usr1/lisp/compiler/pack.lisp, 10-Jan-89 15:27:21, Edit by Ram.
+ Fixed Select-Location not to infinite loop when Finite-Sb-Last-Offset is 0.
+
+/usr0/ram/compiler/ir2tran.lisp, 30-Jun-88 13:57:12, Edit by Ram.
+ Fixed IR2-Convert-Bind to ignore vars with no Refs.
+
+/usr0/ram/compiler/gtn.lisp, 30-Jun-88 13:54:51, Edit by Ram.
+ Fixed Assign-Lambda-Var-TNs and Assign-IR2-Environment to ignore vars with no
+ Refs.
+
+/usr0/ram/compiler/life.lisp, 02-Mar-88 17:06:18, Edit by Ram.
+ Aaaargh! When clearing the Packed-TN-Local in Clear-Lifetime-Info, iterate
+ up to Local-TN-Limit, not SC-Number-Limit.
+
+/usr0/ram/compiler/ir1util.lisp, 20-Feb-88 22:00:37, Edit by Ram.
+ Made Substitute-Leaf and Change-Ref-Leaf do an Up-Tick-Node on the changed
+ Refs.
+
+/usr0/ram/compiler/ltn.lisp, 20-Feb-88 16:25:11, Edit by Ram.
+ Changed Find-Template to deal with output assertions correctly once again.
+ Instead of assuming that the Node-Derived-Type is true, we look at the
+ Type-Check flag in the continuation. If the continuation type is being
+ checked, then we only use a template when it doesn't have an output
+ restriction.
+
+ In Find-Template-For-Policy, use safe templates as a last resort, even when
+ policy is :Small or :Fast. A safe template is surely faster and smaller than
+ a full call.
+
+ In Ltn-Analyze, clear the Type-Check flags on all continuations when our
+ policy is unsafe.
+
+/usr0/ram/compiler/debug.lisp, 18-Feb-88 17:17:19, Edit by Ram.
+ And fixed Check-VOP-Refs to ensure that the temporary write comes before
+ (which is after in the reversed VOP-Refs) the read, rather than vice-versa...
+
+/usr0/ram/compiler/vmdef.lisp, 18-Feb-88 17:10:35, Edit by Ram.
+ Fixed Compute-Reference-Order to begin temporary lifetimes with the write
+ rather than the read.
+
+/usr0/ram/compiler/gtn.lisp, 18-Feb-88 16:06:41, Edit by Ram.
+ Have to fetch the Equated-Returns inside the loop in Find-Equivalence
+ classes, since Equate-Return-Info will change the returns for the current
+ environment. This used to work, since Equate-Return-Info used to be
+ destructive.
+
+/usr0/ram/compiler/ir1opt.lisp, 14-Feb-88 14:30:47, Edit by Ram.
+ Oops. Fixed the test in Propagate-From-Calls for being a call to the
+ function concerned. Now that this optimization can actually happen, who
+ knows?
+
+/usr0/ram/compiler/ltn.lisp, 11-Feb-88 18:01:38, Edit by Ram.
+ Made Annotate-1-Value-Continuation delay global function references to
+ functions that aren't notinline. Made LTN-Default-Call,
+ LTN-Analyze-Full-Call and LTN-Analyze-MV-Call annotate their function
+ continuation.
+
+/usr0/ram/compiler/flowsimp.lisp, 11-Feb-88 16:44:48, Edit by Ram.
+ Now that returns aren't being picked off in flow-graph-simplify, we have to
+ fix join-block-if-possible not to attempt to join the XEP return to the
+ component tail...
+
+/usr0/ram/compiler/ir1util.lisp, 11-Feb-88 16:14:52, Edit by Ram.
+ Made Delete-Ref call Maybe-Let-Convert when deleting the second-to-last
+ reference to a lambda.
+
+/usr0/ram/compiler/flowsimp.lisp, 10-Feb-88 16:46:56, Edit by Ram.
+/usr0/ram/compiler/locall.lisp, 11-Feb-88 13:24:04, Edit by Ram.
+ Moved let-conversion to locall from flowsimp, and made it be triggered by
+ Maybe-Let-Convert. This is called on each new lambda after local call
+ analysis, and can also be called whenever there is some reason to believe
+ that a lambda might be eligible for let-conversion. We clear any :Optional
+ function kinds since the entry functions can be treated as normal functions
+ after local call analysis.
+
+ This change was made to solve problems with lambdas not being let-converted
+ when the return node was deleted due to being unreachable. This is important
+ now that being a let has major environment significance. Originally let
+ conversion was regarded as a way to delete a return, and thus made some kind
+ of sense to have it be a flow graph optimization. Now that a let can have
+ only one reference, we can trigger let conversion by noticing when references
+ are deleted.
+
+/usr0/ram/compiler/node.lisp, 11-Feb-88 13:12:38, Edit by Ram.
+/usr0/ram/compiler/ir1tran.lisp, 11-Feb-88 13:12:47, Edit by Ram.
+ Added :Optional Functional-Kind that is initially specified for the
+ entry-point lambdas in optional-dispatches so that we know there may be
+ references to the function through the optional dispatch.
+
+/usr0/ram/compiler/ir1util.lisp, 11-Feb-88 12:23:11, Edit by Ram.
+ Changed assertion in Control-Equate to allow an existing value-equate to the
+ same continuation.
+
+/usr0/ram/compiler/ir1tran.lisp, 25-Jan-88 19:27:57, Edit by Ram.
+ Changed the default policy to be all 1's, and modified calls to Policy in all
+ files so that they do "the right thing" when compared qualities are equal.
+ The default action should be chosen so as to minimize mystification and
+ annoyance to non-wizards. In general, the default should be chosen according
+ to the ordering: safety > brevity > speed > space > cspeed. Checks for 0 and
+ 3 meaning "totally unimportant" and "ultimately important" are also o.k.
+
+/usr0/ram/compiler/gtn.lisp, 24-Jan-88 11:20:37, Edit by Ram.
+ Changed Equate-Return-Info so that it effectively ignores the Count and Types
+ in :Unused continuations, yet still combines the Entry-P and Tail-P values.
+
+/usr0/ram/compiler/locall.lisp, 23-Jan-88 21:41:28, Edit by Ram.
+ Make Convert-XEP-Call set the Return-Point too...
+
+/usr0/ram/compiler/ir1util.lisp, 22-Jan-88 16:17:38, Edit by Ram.
+ Made Immediately-Used-P special-case local calls by using
+ Basic-Combination-Return-Point.
+
+/usr0/ram/compiler/locall.lisp, 22-Jan-88 16:13:32, Edit by Ram.
+/usr0/ram/compiler/node.lisp, 22-Jan-88 16:12:03, Edit by Ram.
+ Added a Basic-Combination-Return-Point slot so that local calls can rebember
+ where they are supposed to return to.
+
+/usr0/ram/compiler/gtn.lisp, 22-Jan-88 10:03:37, Edit by Ram.
+ Fixed Assign-Lambda-Vars to set the TN-Leaf.
+
+/usr0/ram/compiler/flowsimp.lisp, 22-Jan-88 10:22:53, Edit by Ram.
+ Made Convert-To-Let do an Intersect-Continuation-Asserted-Type on the actual
+ continuation with the dummy's assertion when the let call is the only use of
+ the actual continuation.
+
+/usr0/ram/compiler/ir1tran.lisp, 22-Jan-88 09:42:49, Edit by Ram.
+ Tack NIL on the end of the forms that we convert so that no top-level form is
+ in a for-value context.
+
+/usr0/ram/compiler/ir1opt.lisp, 21-Jan-88 17:50:52, Edit by Ram.
+ Made Check-Types intersect the new type with the Node-Derived-Type for all
+ the continuation uses so that IR1Opt doesn't go and change the type right
+ back.
+
+/usr0/ram/compiler/main.lisp, 21-Jan-88 17:31:57, Edit by Ram.
+/usr0/ram/compiler/ir1opt.lisp, 21-Jan-88 17:30:31, Edit by Ram.
+ Type checking was being done wrong. We need to check types even if IR1Opt
+ doesn't do anything, and we need to give IR1Opt a second chance if type check
+ does anything. Made Check-Types return whether it did anything.
+
+/usr0/ram/compiler/ir1tran.lisp, 21-Jan-88 17:14:13, Edit by Ram.
+ Fixed IR1 translator for THE to use Find-Uses to find whether the
+ continuation is used, rather than incorrectly doing it itself (using an old
+ interpretation of Continuation-Use).
+
+/usr0/ram/compiler/ir1tran.lisp, 16-Nov-87 15:58:39, Edit by Ram.
+ Made %proclaim (and hence proclaim) return (undefined-value) rather than
+ arbitrary randomness.
+
+/usr1/ram/compiler/flowsimp.lisp, 23-Aug-87 22:00:39, Edit by Ram
+ Changed Flow-Graph-Simplify not to merge blocks unless the cleanups for the
+ two blocks are identical. The is a sub-optimal (but conservative) way to
+ ensure that cleanups are only done on block boundaries.
+
+/usr1/ram/compiler/ir1opt.lisp, 23-Aug-87 21:26:53, Edit by Ram
+ Just look for the :Let functional kind in Top-Down-Optimize, instead of
+ figuring out from first principles.
+
+/usr1/ram/compiler/ir1util.lisp, 20-Aug-87 22:12:45, Edit by Ram
+ The only worthwhile use for the functional nesting was in Delete-Ref, where
+ it would walk all the inferiors, marking them as deleted as well. But I
+ think that just marking the outer function as deleted will eventually cause
+ all the inner functions to be deleted. As it stands, Delete-Ref is a lot
+ simpler. If there are problems with deleted-but-somehow-undeletable
+ references holding onto functions, we may want to look at all references in
+ Delete-Ref and see if some enclosing function is deleted.
+
+/usr1/ram/compiler/ir1tran.lisp, 22-Aug-87 15:38:50, Edit by Ram
+ Changed stuff to use the new Functional and Cleanup structures. Mostly
+ involves flushing stuff.
+
+/usr1/ram/compiler/locall.lisp, 21-Aug-87 14:24:32, Edit by Ram
+/usr1/ram/compiler/ir1opt.lisp, 20-Aug-87 22:05:33, Edit by Ram
+ Changed Local-Call-Analyze to just take a component and analyze the
+ New-Functions. This simplifies (and optimizes) the late uses in IR1
+ optimize. Also changed convert-call-if-possible to know to try to convert
+ the call to the real function rather than the XEP.
+
+/usr1/ram/compiler/node.lisp, 23-Aug-87 20:12:58, Edit by Ram
+ Flushed bogus hierarchical information in the Functional, Environment and
+ Cleanup structures. Now that I've taken a stab at implementing the IR2
+ conversion passes, it is obvious that this information is useless and
+ difficult to maintain.
+
+ We do need a way to iterate over all the functions in a component, but doing
+ a tree walk is bogus. Instead, we have a list of all the lambdas in each
+ component. When functions are initially converted, they are placed on the
+ component New-Functions list. Local call analysis moves analyzed lambdas
+ into the Lambdas list. We don't bother to remove lambdas from this list when
+ they are deleted.
+
+ A change needed in the cleanup stuff to make it work is to have continuations
+ with no immediately enclosing cleanup point have their lambda as the cleanup.
+ Then when we convert the lambda to a let, we set the Cleanup slot in the
+ lambda to any cleanup enclosing the call so that we realize stuff needs to be
+ cleaned up.
+
+/usr1/ram/compiler/flowsimp.lisp, 23-Aug-87 20:49:36, Edit by Ram
+ Changed Find-Initial-DFO to build the Lambdas lists for the components. At
+ the same time, we also use XEP references to (correctly) merge components
+ with potential environment inter-dependencies, rather than attempting to use
+ the lambda nesting. Changed Join-Components to combine the Lambdas and
+ New-Functions lists.
+
+ Changed Delete-Return to convert to a let only when there is a single call,
+ and also to mark the lambda with the :Let functional kind. This makes
+ let-calls exactly correspond to the functions that IR1 optimize can
+ substitute for. This also solves problems with cleanups, since it is
+ trivially true that all calls are in the same dynamic environment.
+
+/usr1/ram/compiler/ir1tran.lisp, 18-Aug-87 15:25:18, Edit by Ram
+ In IR1-Convert, if the function is not a symbol, but doesn't look even
+ vaguely like a lambda, then complain about an illegal function call,
+ rather than having IR1-Convert-Lambda say it is an illegal lambda.
+
+/usr1/ram/compiler/numacs.lisp, 16-Aug-87 13:48:11, Edit by Ram
+ Added a Defvar that doesn't use OR (and create a LET and freak out IR1
+ conversion.)
+
+/usr1/ram/compiler/ir1util.lisp, 16-Aug-87 18:14:10, Edit by Ram
+/usr1/ram/compiler/debug.lisp, 16-Aug-87 15:19:47, Edit by Ram
+/usr1/ram/compiler/flowsimp.lisp, 16-Aug-87 15:19:13, Edit by Ram
+/usr1/ram/compiler/ir1opt.lisp, 16-Aug-87 15:18:47, Edit by Ram
+/usr1/ram/compiler/node.lisp, 16-Aug-87 19:58:30, Edit by Ram
+/usr1/ram/compiler/ir1tran.lisp, 16-Aug-87 20:29:36, Edit by Ram
+/usr1/ram/compiler/locall.lisp, 16-Aug-87 20:22:28, Edit by Ram
+ Changed stuff for new explicit external entry point concept. The external
+ entry point is now a real function containing local calls to the entry
+ points. This represents reality better, making lots of things previously
+ special-cased automatically happen in our favor. We really needed this for
+ environment analysis and IR2 conversion to work.
+
+ Functional-Entry-Kind is replaced by Functional-Kind and
+ Functional-Entry-Function. The Kind is kind of like the old Entry-Kind. The
+ Entry-Function is the XEP (or a back-pointer in an XEP). Uses of Entry-Kind
+ were replaced with Kind or Entry-Function or flushed, as appropriate.
+
+ Note-Entry-Point has been flushed. %Defun doesn't need to do anything to
+ cause the function to be an entry point. The top-level lambda is no longer
+ a real entry-point: instead we just directly link it to the component head
+ and tail.
+
+ The more-arg XEP creates a more-arg cleanup. The local-call case still needs
+ to be fixed.
+
+/usr1/ram/compiler/fndb.lisp, 16-Aug-87 20:37:28, Edit by Ram
+ Added some definitions for %mumble magic compiler functions.
+
+/usr1/ram/compiler/ir1tran.lisp, 16-Aug-87 20:29:36, Edit by Ram
+ Changed uses of the two-arg Arg for more-arg hackery into %More-Arg, since
+ this isn't the user-level functionality we will ultimately want for
+ more-args.
+
+/usr1/ram/compiler/main.lisp, 16-Aug-87 18:35:29, Edit by Ram
+ Changed Compile-Component not to do any IR1 passes on the top-level component
+ except for Type-Check. These optimizations are unlikely to have any useful
+ effect on top-level code, and they might want to inject illegal stuff into
+ the top-level component.
+
+/usr1/ram/compiler/macros.lisp, 16-Aug-87 18:26:19, Edit by Ram
+ Changed With-IR1-Environment to bind *Converting-Top-Level*. Currently you'd
+ better not use this on top-level code unless you are sure you won't emit
+ anything that can't go in top-level, since IR1-Convert-Lambda will bogue out
+ because there is no *Initial-Component* to switch to.
+
+/usr1/ram/compiler/macros.lisp, 13-Aug-87 20:16:47, Edit by Ram
+/usr1/ram/compiler/node.lisp, 13-Aug-87 22:24:30, Edit by Ram
+/usr1/ram/compiler/main.lisp, 13-Aug-87 22:35:11, Edit by Ram
+/usr1/ram/compiler/globaldb.lisp, 13-Aug-87 20:21:12, Edit by Ram
+/usr1/ram/compiler/locall.lisp, 13-Aug-87 22:57:54, Edit by Ram
+/usr1/ram/compiler/flowsimp.lisp, 13-Aug-87 22:52:01, Edit by Ram
+/usr1/ram/compiler/ir1opt.lisp, 13-Aug-87 22:59:11, Edit by Ram
+/usr1/ram/compiler/ir1tran.lisp, 13-Aug-87 23:06:03, Edit by Ram
+ Changed stuff to support having separate top-level and initial components.
+ Whenver we see a lambda or anything hairy, we switch over to the initial
+ component. Hairyness of special-forms is determined by the :Top-Level-P
+ keyword to Def-IR1-Translator.
+
+ We make appropriate special forms hairy to guarantee that the top-level
+ component doesn't contain any stuff that would make life hard for IR2
+ conversion. In particular, it contains no variables, no functions other than
+ the top-level lambda and no non-local exit targets.
+
+ Local call analysis refuses to convert calls appearing in the top-level
+ component. In other files, stuff related to Functional-Top-Level-P was
+ ripped out.
+
+/usr1/ram/compiler/ir1opt.lisp, 13-Aug-87 17:58:37, Edit by Ram
+ Changed propagate-from-calls to punt if any use is a mv-combination. Changed
+ Top-Down-Optimize not to Substitute-Let-Vars unless the only use is not a
+ MV-Combination. Un-commented-out the substituion of functionals for non-set
+ let vars.
+
+/usr1/ram/compiler/locall.lisp, 13-Aug-87 18:31:24, Edit by Ram
+ Frobbed Find-Top-Level-Code to recognize DEFUNs with no calls as
+ non-top-level. The entire concept is probably wrong, though.
+
+/usr1/ram/compiler/ir1tran.lisp, 13-Aug-87 19:07:22, Edit by Ram
+ Changed IR1-Convert-OK-Combination to look at the leaf-type of the leaf
+ rather than the derived type for the function continuation. This allows
+ known calls to be recognized again (I'm sure that worked at one point.
+ Perhaps before they were becoming known later on somehow?). This is all not
+ really right anyway, given the broken interpretation of function types
+ currently used in IR1.
+
+/usr/ram/compiler/ir1tran.slisp, 12-Jan-87 11:48:32, Edit by Ram
+ Fixed Find-Source-Paths to use a DO with ATOM test rather than a dolist, so
+ that it won't blow up on dotted lists.
+
+/usr/ram/compiler/ir1util.slisp, 12-Jan-87 10:28:07, Edit by Ram
+ Fixed Delete-Block to null out the DEST for the continuations belonging to
+ each node as we delete the node, so we don't try to deliver a result to a
+ node that doesn't exist anymore.
--- /dev/null
+;;;; This file implements type check generation. This is a phase that
+;;;; runs at the very end of IR1. If a type check is too complex for
+;;;; the back end to directly emit in-line, then we transform the check
+;;;; into an explicit conditional using TYPEP.
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!C")
+
+(file-comment
+ "$Header$")
+\f
+;;;; cost estimation
+
+;;; Return some sort of guess about the cost of a call to a function.
+;;; If the function has some templates, we return the cost of the
+;;; cheapest one, otherwise we return the cost of CALL-NAMED. Calling
+;;; this with functions that have transforms can result in relatively
+;;; meaningless results (exaggerated costs.)
+;;;
+;;; We special-case NULL, since it does have a source tranform and is
+;;; interesting to us.
+(defun function-cost (name)
+ (declare (symbol name))
+ (let ((info (info :function :info name))
+ (call-cost (template-cost (template-or-lose 'call-named))))
+ (if info
+ (let ((templates (function-info-templates info)))
+ (if templates
+ (template-cost (first templates))
+ (case name
+ (null (template-cost (template-or-lose 'if-eq)))
+ (t call-cost))))
+ call-cost)))
+
+;;; Return some sort of guess for the cost of doing a test against TYPE.
+;;; The result need not be precise as long as it isn't way out in space. The
+;;; units are based on the costs specified for various templates in the VM
+;;; definition.
+(defun type-test-cost (type)
+ (declare (type ctype type))
+ (or (let ((check (type-check-template type)))
+ (if check
+ (template-cost check)
+ (let ((found (cdr (assoc type *backend-type-predicates*
+ :test #'type=))))
+ (if found
+ (+ (function-cost found) (function-cost 'eq))
+ nil))))
+ (typecase type
+ (union-type
+ (collect ((res 0 +))
+ (dolist (mem (union-type-types type))
+ (res (type-test-cost mem)))
+ (res)))
+ (member-type
+ (* (length (member-type-members type))
+ (function-cost 'eq)))
+ (numeric-type
+ (* (if (numeric-type-complexp type) 2 1)
+ (function-cost
+ (if (csubtypep type (specifier-type 'fixnum)) 'fixnump 'numberp))
+ (+ 1
+ (if (numeric-type-low type) 1 0)
+ (if (numeric-type-high type) 1 0))))
+ (t
+ (function-cost 'typep)))))
+\f
+;;;; checking strategy determination
+
+;;; Return the type we should test for when we really want to check for
+;;; Type. If speed, space or compilation speed is more important than safety,
+;;; then we return a weaker type if it is easier to check. First we try the
+;;; defined type weakenings, then look for any predicate that is cheaper.
+;;;
+;;; If the supertype is equal in cost to the type, we prefer the supertype.
+;;; This produces a closer approximation of the right thing in the presence of
+;;; poor cost info.
+(defun maybe-weaken-check (type cont)
+ (declare (type ctype type) (type continuation cont))
+ (cond ((policy (continuation-dest cont)
+ (<= speed safety) (<= space safety) (<= cspeed safety))
+ type)
+ (t
+ (let ((min-cost (type-test-cost type))
+ (min-type type)
+ (found-super nil))
+ (dolist (x *backend-type-predicates*)
+ (let ((stype (car x)))
+ (when (and (csubtypep type stype)
+ (not (union-type-p stype)))
+ (let ((stype-cost (type-test-cost stype)))
+ (when (or (< stype-cost min-cost)
+ (type= stype type))
+ (setq found-super t)
+ (setq min-type stype min-cost stype-cost))))))
+ (if found-super
+ min-type
+ *universal-type*)))))
+
+;;; Like VALUES-TYPES, only mash any complex function types to FUNCTION.
+(defun no-function-values-types (type)
+ (declare (type ctype type))
+ (multiple-value-bind (res count) (values-types type)
+ (values (mapcar #'(lambda (type)
+ (if (function-type-p type)
+ (specifier-type 'function)
+ type))
+ res)
+ count)))
+
+;;; Switch to disable check complementing, for evaluation.
+(defvar *complement-type-checks* t)
+
+;;; Cont is a continuation we are doing a type check on and Types is a list
+;;; of types that we are checking its values against. If we have proven
+;;; that Cont generates a fixed number of values, then for each value, we check
+;;; whether it is cheaper to then difference between the proven type and
+;;; the corresponding type in Types. If so, we opt for a :HAIRY check with
+;;; that test negated. Otherwise, we try to do a simple test, and if that is
+;;; impossible, we do a hairy test with non-negated types. If true,
+;;; Force-Hairy forces a hairy type check.
+;;;
+;;; When doing a non-negated check, we call MAYBE-WEAKEN-CHECK to weaken the
+;;; test to a convenient supertype (conditional on policy.) If debug-info is
+;;; not particularly important (debug <= 1) or speed is 3, then we allow
+;;; weakened checks to be simple, resulting in less informative error messages,
+;;; but saving space and possibly time.
+(defun maybe-negate-check (cont types force-hairy)
+ (declare (type continuation cont) (list types))
+ (multiple-value-bind (ptypes count)
+ (no-function-values-types (continuation-proven-type cont))
+ (if (eq count :unknown)
+ (if (and (every #'type-check-template types) (not force-hairy))
+ (values :simple types)
+ (values :hairy
+ (mapcar #'(lambda (x)
+ (list nil (maybe-weaken-check x cont) x))
+ types)))
+ (let ((res (mapcar #'(lambda (p c)
+ (let ((diff (type-difference p c))
+ (weak (maybe-weaken-check c cont)))
+ (if (and diff
+ (< (type-test-cost diff)
+ (type-test-cost weak))
+ *complement-type-checks*)
+ (list t diff c)
+ (list nil weak c))))
+ ptypes types)))
+ (cond ((or force-hairy (find-if #'first res))
+ (values :hairy res))
+ ((every #'type-check-template types)
+ (values :simple types))
+ ((policy (continuation-dest cont)
+ (or (<= debug 1) (and (= speed 3) (/= debug 3))))
+ (let ((weakened (mapcar #'second res)))
+ (if (every #'type-check-template weakened)
+ (values :simple weakened)
+ (values :hairy res))))
+ (t
+ (values :hairy res)))))))
+
+;;; Determines whether Cont's assertion is:
+;;; -- Checkable by the back end (:SIMPLE), or
+;;; -- Not checkable by the back end, but checkable via an explicit test in
+;;; type check conversion (:HAIRY), or
+;;; -- not reasonably checkable at all (:TOO-HAIRY).
+;;;
+;;; A type is checkable if it either represents a fixed number of values (as
+;;; determined by VALUES-TYPES), or it is the assertion for an MV-Bind. A type
+;;; is simply checkable if all the type assertions have a TYPE-CHECK-TEMPLATE.
+;;; In this :SIMPLE case, the second value is a list of the type restrictions
+;;; specified for the leading positional values.
+;;;
+;;; We force a check to be hairy even when there are fixed values if we are in
+;;; a context where we may be forced to use the unknown values convention
+;;; anyway. This is because IR2tran can't generate type checks for unknown
+;;; values continuations but people could still be depending on the check being
+;;; done. We only care about EXIT and RETURN (not MV-COMBINATION) since these
+;;; are the only contexts where the ultimate values receiver
+;;;
+;;; In the :HAIRY case, the second value is a list of triples of the form:
+;;; (Not-P Type Original-Type)
+;;;
+;;; If true, the Not-P flag indicates a test that the corresponding value is
+;;; *not* of the specified Type. Original-Type is the type asserted on this
+;;; value in the continuation, for use in error messages. When Not-P is true,
+;;; this will be different from Type.
+;;;
+;;; This allows us to take what has been proven about Cont's type into
+;;; consideration. If it is cheaper to test for the difference between the
+;;; derived type and the asserted type, then we check for the negation of this
+;;; type instead.
+(defun continuation-check-types (cont)
+ (declare (type continuation cont))
+ (let ((type (continuation-asserted-type cont))
+ (dest (continuation-dest cont)))
+ (assert (not (eq type *wild-type*)))
+ (multiple-value-bind (types count) (no-function-values-types type)
+ (cond ((not (eq count :unknown))
+ (if (or (exit-p dest)
+ (and (return-p dest)
+ (multiple-value-bind (ignore count)
+ (values-types (return-result-type dest))
+ (declare (ignore ignore))
+ (eq count :unknown))))
+ (maybe-negate-check cont types t)
+ (maybe-negate-check cont types nil)))
+ ((and (mv-combination-p dest)
+ (eq (basic-combination-kind dest) :local))
+ (assert (values-type-p type))
+ (maybe-negate-check cont (args-type-optional type) nil))
+ (t
+ (values :too-hairy nil))))))
+
+;;; Return true if Cont is a continuation whose type the back end is likely
+;;; to want to check. Since we don't know what template the back end is going
+;;; to choose to implement the continuation's DEST, we use a heuristic. We
+;;; always return T unless:
+;;; -- Nobody uses the value, or
+;;; -- Safety is totally unimportant, or
+;;; -- the continuation is an argument to an unknown function, or
+;;; -- the continuation is an argument to a known function that has no
+;;; IR2-Convert method or :fast-safe templates that are compatible with the
+;;; call's type.
+;;;
+;;; We must only return nil when it is *certain* that a check will not be done,
+;;; since if we pass up this chance to do the check, it will be too late. The
+;;; penalty for being too conservative is duplicated type checks.
+;;;
+;;; If there is a compile-time type error, then we always return true unless
+;;; the DEST is a full call. With a full call, the theory is that the type
+;;; error is probably from a declaration in (or on) the callee, so the callee
+;;; should be able to do the check. We want to let the callee do the check,
+;;; because it is possible that the error is really in the callee, not the
+;;; caller. We don't want to make people recompile all calls to a function
+;;; when they were originally compiled with a bad declaration (or an old type
+;;; assertion derived from a definition appearing after the call.)
+(defun probable-type-check-p (cont)
+ (declare (type continuation cont))
+ (let ((dest (continuation-dest cont)))
+ (cond ((eq (continuation-type-check cont) :error)
+ (if (and (combination-p dest) (eq (combination-kind dest) :error))
+ nil
+ t))
+ ((or (not dest)
+ (policy dest (zerop safety)))
+ nil)
+ ((basic-combination-p dest)
+ (let ((kind (basic-combination-kind dest)))
+ (cond ((eq cont (basic-combination-fun dest)) t)
+ ((eq kind :local) t)
+ ((member kind '(:full :error)) nil)
+ ((function-info-ir2-convert kind) t)
+ (t
+ (dolist (template (function-info-templates kind) nil)
+ (when (eq (template-policy template) :fast-safe)
+ (multiple-value-bind (val win)
+ (valid-function-use dest (template-type template))
+ (when (or val (not win)) (return t)))))))))
+ (t t))))
+
+;;; Return a form that we can convert to do a hairy type check of the
+;;; specified Types. Types is a list of the format returned by
+;;; Continuation-Check-Types in the :HAIRY case. In place of the actual
+;;; value(s) we are to check, we use 'DUMMY. This constant reference is later
+;;; replaced with the actual values continuation.
+;;;
+;;; Note that we don't attempt to check for required values being unsupplied.
+;;; Such checking is impossible to efficiently do at the source level because
+;;; our fixed-values conventions are optimized for the common MV-Bind case.
+;;;
+;;; We can always use Multiple-Value-Bind, since the macro is clever about
+;;; binding a single variable.
+(defun make-type-check-form (types)
+ (collect ((temps))
+ (dotimes (i (length types))
+ (temps (gensym)))
+
+ `(multiple-value-bind ,(temps)
+ 'dummy
+ ,@(mapcar #'(lambda (temp type)
+ (let* ((spec
+ (let ((*unparse-function-type-simplify* t))
+ (type-specifier (second type))))
+ (test (if (first type) `(not ,spec) spec)))
+ `(unless (typep ,temp ',test)
+ (%type-check-error
+ ,temp
+ ',(type-specifier (third type))))))
+ (temps) types)
+ (values ,@(temps)))))
+
+;;; Splice in explicit type check code immediately before the node which is
+;;; Cont's Dest. This code receives the value(s) that were being passed to
+;;; Cont, checks the type(s) of the value(s), then passes them on to Cont.
+(defun convert-type-check (cont types)
+ (declare (type continuation cont) (type list types))
+ (with-ir1-environment (continuation-dest cont)
+
+ ;; Ensuring that CONT starts a block lets us freely manipulate its uses.
+ (ensure-block-start cont)
+
+ ;; Make a new continuation and move CONT's uses to it.
+ (let* ((new-start (make-continuation))
+ (dest (continuation-dest cont))
+ (prev (node-prev dest)))
+ (continuation-starts-block new-start)
+ (substitute-continuation-uses new-start cont)
+
+ ;; Setting TYPE-CHECK in CONT to :DELETED indicates that the check has
+ ;; been done.
+ (setf (continuation-%type-check cont) :deleted)
+
+ ;; Make the DEST node start its block so that we can splice in the
+ ;; type check code.
+ (when (continuation-use prev)
+ (node-ends-block (continuation-use prev)))
+
+ (let* ((prev-block (continuation-block prev))
+ (new-block (continuation-block new-start))
+ (dummy (make-continuation)))
+
+ ;; Splice in the new block before DEST, giving the new block all of
+ ;; DEST's predecessors.
+ (dolist (block (block-pred prev-block))
+ (change-block-successor block prev-block new-block))
+
+ ;; Convert the check form, using the new block start as START and a
+ ;; dummy continuation as CONT.
+ (ir1-convert new-start dummy (make-type-check-form types))
+
+ ;; TO DO: Why should this be true? -- WHN 19990601
+ (assert (eq (continuation-block dummy) new-block))
+
+ ;; KLUDGE: Comments at the head of this function in CMU CL said that
+ ;; somewhere in here we
+ ;; Set the new block's start and end cleanups to the *start*
+ ;; cleanup of PREV's block. This overrides the incorrect
+ ;; default from WITH-IR1-ENVIRONMENT.
+ ;; Unfortunately I can't find any code which corresponds to this.
+ ;; Perhaps it was a stale comment? Or perhaps I just don't
+ ;; understand.. -- WHN 19990521
+
+ (let ((node (continuation-use dummy)))
+ (setf (block-last new-block) node)
+ ;; Change the use to a use of CONT. (We need to use the dummy
+ ;; continuation to get the control transfer right, because we want to
+ ;; go to PREV's block, not CONT's.)
+ (delete-continuation-use node)
+ (add-continuation-use node cont))
+ ;; Link the new block to PREV's block.
+ (link-blocks new-block prev-block))
+
+ ;; MAKE-TYPE-CHECK-FORM generated a form which checked the type of
+ ;; 'DUMMY, not a real form. At this point we convert to the real form by
+ ;; finding 'DUMMY and overwriting it with the new continuation. (We can
+ ;; find 'DUMMY because no LET conversion has been done yet.) The
+ ;; [mv-]combination code from the mv-bind in the check form will be the
+ ;; use of the new check continuation. We substitute for the first
+ ;; argument of this node.
+ (let* ((node (continuation-use cont))
+ (args (basic-combination-args node))
+ (victim (first args)))
+ (assert (and (= (length args) 1)
+ (eq (constant-value
+ (ref-leaf
+ (continuation-use victim)))
+ 'dummy)))
+ (substitute-continuation new-start victim)))
+
+ ;; Invoking local call analysis converts this call to a LET.
+ (local-call-analyze *current-component*))
+
+ (values))
+
+;;; Emit a type warning for Node. If the value of node is being used for a
+;;; variable binding, we figure out which one for source context. If the value
+;;; is a constant, we print it specially. We ignore nodes whose type is NIL,
+;;; since they are supposed to never return.
+(defun do-type-warning (node)
+ (declare (type node node))
+ (let* ((*compiler-error-context* node)
+ (cont (node-cont node))
+ (atype-spec (type-specifier (continuation-asserted-type cont)))
+ (dtype (node-derived-type node))
+ (dest (continuation-dest cont))
+ (what (when (and (combination-p dest)
+ (eq (combination-kind dest) :local))
+ (let ((lambda (combination-lambda dest))
+ (pos (position-or-lose cont (combination-args dest))))
+ (format nil "~:[A possible~;The~] binding of ~S"
+ (and (continuation-use cont)
+ (eq (functional-kind lambda) :let))
+ (leaf-name (elt (lambda-vars lambda) pos)))))))
+ (cond ((eq dtype *empty-type*))
+ ((and (ref-p node) (constant-p (ref-leaf node)))
+ (compiler-warning "~:[This~;~:*~A~] is not a ~<~%~9T~:;~S:~>~% ~S"
+ what atype-spec (constant-value (ref-leaf node))))
+ (t
+ (compiler-warning
+ "~:[Result~;~:*~A~] is a ~S, ~<~%~9T~:;not a ~S.~>"
+ what (type-specifier dtype) atype-spec))))
+ (values))
+
+;;; Mark Cont as being a continuation with a manifest type error. We set
+;;; the kind to :ERROR, and clear any FUNCTION-INFO if the continuation is an
+;;; argument to a known call. The last is done so that the back end doesn't
+;;; have to worry about type errors in arguments to known functions. This
+;;; clearing is inhibited for things with IR2-CONVERT methods, since we can't
+;;; do a full call to funny functions.
+(defun mark-error-continuation (cont)
+ (declare (type continuation cont))
+ (setf (continuation-%type-check cont) :error)
+ (let ((dest (continuation-dest cont)))
+ (when (and (combination-p dest)
+ (let ((kind (basic-combination-kind dest)))
+ (or (eq kind :full)
+ (and (function-info-p kind)
+ (not (function-info-ir2-convert kind))))))
+ (setf (basic-combination-kind dest) :error)))
+ (values))
+
+;;; Loop over all blocks in Component that have TYPE-CHECK set, looking for
+;;; continuations with TYPE-CHECK T. We do two mostly unrelated things: detect
+;;; compile-time type errors and determine if and how to do run-time type
+;;; checks.
+;;;
+;;; If there is a compile-time type error, then we mark the continuation and
+;;; emit a warning if appropriate. This part loops over all the uses of the
+;;; continuation, since after we convert the check, the :DELETED kind will
+;;; inhibit warnings about the types of other uses.
+;;;
+;;; If a continuation is too complex to be checked by the back end, or is
+;;; better checked with explicit code, then convert to an explicit test.
+;;; Assertions that can checked by the back end are passed through. Assertions
+;;; that can't be tested are flamed about and marked as not needing to be
+;;; checked.
+;;;
+;;; If we determine that a type check won't be done, then we set TYPE-CHECK
+;;; to :NO-CHECK. In the non-hairy cases, this is just to prevent us from
+;;; wasting time coming to the same conclusion again on a later iteration. In
+;;; the hairy case, we must indicate to LTN that it must choose a safe
+;;; implementation, since IR2 conversion will choke on the check.
+;;;
+;;; The generation of the type checks is delayed until all the type
+;;; check decisions have been made because the generation of the type
+;;; checks creates new nodes whose derived types aren't always updated
+;;; which may lead to inappropriate template choices due to the
+;;; modification of argument types.
+(defun generate-type-checks (component)
+ (collect ((conts))
+ (do-blocks (block component)
+ (when (block-type-check block)
+ (do-nodes (node cont block)
+ (let ((type-check (continuation-type-check cont)))
+ (unless (member type-check '(nil :error :deleted))
+ (let ((atype (continuation-asserted-type cont)))
+ (do-uses (use cont)
+ (unless (values-types-intersect (node-derived-type use)
+ atype)
+ (mark-error-continuation cont)
+ (unless (policy node (= brevity 3))
+ (do-type-warning use))))))
+ (when (and (eq type-check t)
+ (not *byte-compiling*))
+ (cond ((probable-type-check-p cont)
+ (conts cont))
+ (t
+ (setf (continuation-%type-check cont) :no-check))))))
+ (setf (block-type-check block) nil)))
+ (dolist (cont (conts))
+ (multiple-value-bind (check types) (continuation-check-types cont)
+ (ecase check
+ (:simple)
+ (:hairy
+ (convert-type-check cont types))
+ (:too-hairy
+ (let* ((context (continuation-dest cont))
+ (*compiler-error-context* context))
+ (when (policy context (>= safety brevity))
+ (compiler-note
+ "type assertion too complex to check:~% ~S."
+ (type-specifier (continuation-asserted-type cont)))))
+ (setf (continuation-%type-check cont) :deleted))))))
+ (values))
--- /dev/null
+;;;; the implementation-independent parts of the code generator. We use
+;;;; functions and information provided by the VM definition to convert
+;;;; IR2 into assembly code. After emitting code, we finish the
+;;;; assembly and then do the post-assembly phase.
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!C")
+
+(file-comment
+ "$Header$")
+\f
+;;;; utilities used during code generation
+
+(defun component-header-length (&optional
+ (component *component-being-compiled*))
+ #!+sb-doc
+ "Returns the number of bytes used by the code object header."
+ (let* ((2comp (component-info component))
+ (constants (ir2-component-constants 2comp))
+ (num-consts (length constants)))
+ (ash (logandc2 (1+ num-consts) 1) sb!vm:word-shift)))
+
+(defun sb-allocated-size (name)
+ #!+sb-doc
+ "The size of the Name'd SB in the currently compiled component. Useful
+ mainly for finding the size for allocating stack frames."
+ (finite-sb-current-size (sb-or-lose name)))
+
+(defun current-nfp-tn (vop)
+ #!+sb-doc
+ "Return the TN that is used to hold the number stack frame-pointer in VOP's
+ function. Returns NIL if no number stack frame was allocated."
+ (unless (zerop (sb-allocated-size 'non-descriptor-stack))
+ (let ((block (ir2-block-block (vop-block vop))))
+ (when (ir2-environment-number-stack-p
+ (environment-info
+ (block-environment block)))
+ (ir2-component-nfp (component-info (block-component block)))))))
+
+(defun callee-nfp-tn (2env)
+ #!+sb-doc
+ "Return the TN that is used to hold the number stack frame-pointer in the
+ function designated by 2env. Returns NIL if no number stack frame was
+ allocated."
+ (unless (zerop (sb-allocated-size 'non-descriptor-stack))
+ (when (ir2-environment-number-stack-p 2env)
+ (ir2-component-nfp (component-info *component-being-compiled*)))))
+
+(defun callee-return-pc-tn (2env)
+ #!+sb-doc
+ "Return the TN used for passing the return PC in a local call to the function
+ designated by 2env."
+ (ir2-environment-return-pc-pass 2env))
+\f
+;;;; specials used during code generation
+
+(defvar *trace-table-info*)
+(defvar *code-segment* nil)
+(defvar *elsewhere* nil)
+(defvar *elsewhere-label* nil)
+\f
+;;;; noise to emit an instruction trace
+
+(defvar *prev-segment*)
+(defvar *prev-vop*)
+
+#!+sb-show
+(defun trace-instruction (segment vop inst args)
+ (let ((*standard-output* *compiler-trace-output*))
+ (unless (eq *prev-segment* segment)
+ (format t "in the ~A segment:~%" (sb!assem:segment-name segment))
+ (setf *prev-segment* segment))
+ (unless (eq *prev-vop* vop)
+ (when vop
+ (format t "~%VOP ")
+ (if (vop-p vop)
+ (print-vop vop)
+ (format *compiler-trace-output* "~S~%" vop)))
+ (terpri)
+ (setf *prev-vop* vop))
+ (case inst
+ (:label
+ (format t "~A:~%" args))
+ (:align
+ (format t "~0,8T.align~0,8T~A~%" args))
+ (t
+ (format t "~0,8T~A~@[~0,8T~{~A~^, ~}~]~%" inst args))))
+ (values))
+\f
+;;;; GENERATE-CODE and support routines
+
+;;; standard defaults for slots of SEGMENT objects
+(defun default-segment-run-scheduler ()
+ (and *assembly-optimize*
+ (policy (lambda-bind
+ (block-home-lambda
+ (block-next (component-head *component-being-compiled*))))
+ (or (> speed cspeed) (> space cspeed)))))
+(defun default-segment-inst-hook ()
+ #!+sb-show
+ (and *compiler-trace-output* #'trace-instruction))
+
+(defun init-assembler ()
+ (setf *code-segment*
+ (sb!assem:make-segment :name "regular"
+ :run-scheduler (default-segment-run-scheduler)
+ :inst-hook (default-segment-inst-hook)))
+ #!+sb-dyncount
+ (setf (sb!assem:segment-collect-dynamic-statistics *code-segment*)
+ *collect-dynamic-statistics*)
+ (setf *elsewhere*
+ (sb!assem:make-segment :name "elsewhere"
+ :run-scheduler (default-segment-run-scheduler)
+ :inst-hook (default-segment-inst-hook)))
+ (values))
+
+(defun generate-code (component)
+ #!+sb-show
+ (when *compiler-trace-output*
+ (format *compiler-trace-output*
+ "~|~%assembly code for ~S~2%"
+ component))
+ (let ((prev-env nil)
+ (*trace-table-info* nil)
+ (*prev-segment* nil)
+ (*prev-vop* nil)
+ (*fixups* nil))
+ (let ((label (sb!assem:gen-label)))
+ (setf *elsewhere-label* label)
+ (sb!assem:assemble (*elsewhere*)
+ (sb!assem:emit-label label)))
+ (do-ir2-blocks (block component)
+ (let ((1block (ir2-block-block block)))
+ (when (and (eq (block-info 1block) block)
+ (block-start 1block))
+ (sb!assem:assemble (*code-segment*)
+ (sb!assem:emit-label (block-label 1block)))
+ (let ((env (block-environment 1block)))
+ (unless (eq env prev-env)
+ (let ((lab (gen-label)))
+ (setf (ir2-environment-elsewhere-start (environment-info env))
+ lab)
+ (emit-label-elsewhere lab))
+ (setq prev-env env)))))
+ (do ((vop (ir2-block-start-vop block) (vop-next vop)))
+ ((null vop))
+ (let ((gen (vop-info-generator-function (vop-info vop))))
+ (if gen
+ (funcall gen vop)
+ (format t
+ "missing generator for ~S~%"
+ (template-name (vop-info vop)))))))
+ (sb!assem:append-segment *code-segment* *elsewhere*)
+ (setf *elsewhere* nil)
+ (values (sb!assem:finalize-segment *code-segment*)
+ (nreverse *trace-table-info*)
+ *fixups*)))
+
+(defun emit-label-elsewhere (label)
+ (sb!assem:assemble (*elsewhere*)
+ (sb!assem:emit-label label)))
+
+(defun label-elsewhere-p (label-or-posn)
+ (<= (label-position *elsewhere-label*)
+ (etypecase label-or-posn
+ (label
+ (label-position label-or-posn))
+ (index
+ label-or-posn))))
--- /dev/null
+;;;; that part of DEFTYPE which runs within the compiler itself
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!IMPL")
+
+(file-comment "$Header$")
+
+(defun %compiler-deftype (name expander &optional doc)
+ (ecase (info :type :kind name)
+ (:primitive
+ (when *type-system-initialized*
+ (error "illegal to redefine standard type: ~S" name)))
+ (:instance
+ (warn "The class ~S is being redefined to be a DEFTYPE." name)
+ (undefine-structure (layout-info (class-layout (sb!xc:find-class name))))
+ (setf (class-cell-class (find-class-cell name)) nil)
+ (setf (info :type :compiler-layout name) nil)
+ (setf (info :type :kind name) :defined))
+ (:defined
+ ;; Note: It would be nice to warn here when a type is being
+ ;; incompatibly redefined, but it's hard to tell, since type
+ ;; expanders are often function objects which can't easily be
+ ;; compared for equivalence. And just warning on redefinition
+ ;; isn't good, since DEFTYPE necessarily does its thing once at
+ ;; compile time and again at load time, so that it's very common
+ ;; and normal for types to be defined twice. So since there
+ ;; doesn't seem to be anything simple and obvious to do, and
+ ;; since mistakenly redefining a type isn't a common error
+ ;; anyway, we just don't worry about trying to warn about it.
+ )
+ ((nil)
+ (setf (info :type :kind name) :defined)))
+ (setf (info :type :expander name) expander)
+ (when doc
+ (setf (fdocumentation name 'type) doc))
+ ;; ### Bootstrap hack -- we need to define types before %NOTE-TYPE-DEFINED
+ ;; is defined. (FIXME: Do we still need to do this? -- WHN 19990310)
+ (if (fboundp 'sb!c::%note-type-defined)
+ (sb!c::%note-type-defined name)
+ (warn "defining type before %NOTE-TYPE-DEFINED is defined"))
+ name)
--- /dev/null
+;;;; the bare essentials of compiler error handling (FIXME: to be
+;;;; moved to early-c.lisp when stable)
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!C")
+
+(file-comment
+ "$Header$")
+
+;;; a function that is called to unwind out of COMPILER-ERROR
+(declaim (type (function () nil) *compiler-error-bailout*))
+(defvar *compiler-error-bailout*
+ (lambda () (error "COMPILER-ERROR with no bailout")))
+
+;;; We have a separate COMPILER-ERROR condition to allow us to
+;;; distinguish internal compiler errors from user errors.
+;;; Non-compiler errors put us in the debugger.
+(define-condition compiler-error (simple-error) ())
+
+;;; Signal the appropriate condition. COMPILER-ERROR calls the bailout
+;;; function so that it never returns (but compilation continues).
+;;; COMPILER-ABORT falls through to the default error handling, so
+;;; compilation terminates.
+(declaim (ftype (function (string &rest t) nil) compiler-error compiler-abort))
+(declaim (ftype (function (string &rest t) (values))
+ compiler-warning compiler-style-warning))
+(defun compiler-abort (format-string &rest format-args)
+ (error 'compiler-error
+ :format-control format-string
+ :format-arguments format-args))
+(defun compiler-error (format-string &rest format-args)
+ (cerror "Replace form with call to ERROR."
+ 'compiler-error
+ :format-control format-string
+ :format-arguments format-args)
+ (funcall *compiler-error-bailout*)
+ ;; FIXME: It might be nice to define a BUG or OOPS function for "shouldn't
+ ;; happen" cases like this.
+ (error "internal error, control returned from *COMPILER-ERROR-BAILOUT*"))
+(defun compiler-warning (format-string &rest format-args)
+ (apply #'warn format-string format-args)
+ (values))
+(defun compiler-style-warning (format-string &rest format-args)
+ (apply #'style-warn format-string format-args)
+ (values))
--- /dev/null
+;;;; This file implements the constraint propagation phase of the
+;;;; compiler, which uses global flow analysis to obtain dynamic type
+;;;; information.
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!C")
+
+(file-comment
+ "$Header$")
+
+(defstruct (constraint
+ (:include sset-element)
+ (:constructor make-constraint (number kind x y not-p)))
+ ;; The kind of constraint we have:
+ ;;
+ ;; TYPEP
+ ;; X is a LAMBDA-VAR and Y is a CTYPE. The value of X is
+ ;; constrained to be of type Y.
+ ;;
+ ;; >, <
+ ;; X is a lambda-var and Y is a CTYPE. The relation holds
+ ;; between X and some object of type Y.
+ ;;
+ ;; EQL
+ ;; X is a LAMBDA-VAR Y is a LAMBDA-VAR or a CONSTANT. The
+ ;; relation is asserted to hold.
+ (kind nil :type (member typep < > eql))
+ ;; The operands to the relation.
+ (x nil :type lambda-var)
+ (y nil :type (or ctype lambda-var constant))
+ ;; If true, negates the sense of the constraint, so the relation
+ ;; does *not* hold.
+ (not-p nil :type boolean))
+
+(defvar *constraint-number*)
+
+;;; Return a constraint for the specified arguments. We only create a
+;;; new constraint if there isn't already an equivalent old one,
+;;; guaranteeing that all equivalent constraints are EQ. This
+;;; shouldn't be called on LAMBDA-VARs with no CONSTRAINTS set.
+(defun find-constraint (kind x y not-p)
+ (declare (type lambda-var x) (type (or constant lambda-var ctype) y)
+ (type boolean not-p))
+ (or (etypecase y
+ (ctype
+ (do-sset-elements (con (lambda-var-constraints x) nil)
+ (when (and (eq (constraint-kind con) kind)
+ (eq (constraint-not-p con) not-p)
+ (type= (constraint-y con) y))
+ (return con))))
+ (constant
+ (do-sset-elements (con (lambda-var-constraints x) nil)
+ (when (and (eq (constraint-kind con) kind)
+ (eq (constraint-not-p con) not-p)
+ (eq (constraint-y con) y))
+ (return con))))
+ (lambda-var
+ (do-sset-elements (con (lambda-var-constraints x) nil)
+ (when (and (eq (constraint-kind con) kind)
+ (eq (constraint-not-p con) not-p)
+ (let ((cx (constraint-x con)))
+ (eq (if (eq cx x)
+ (constraint-y con)
+ cx)
+ y)))
+ (return con)))))
+ (let ((new (make-constraint (incf *constraint-number*) kind x y not-p)))
+ (sset-adjoin new (lambda-var-constraints x))
+ (when (lambda-var-p y)
+ (sset-adjoin new (lambda-var-constraints y)))
+ new)))
+
+;;; If REF is to a LAMBDA-VAR with CONSTRAINTs (i.e. we can do flow
+;;; analysis on it), then return the LAMBDA-VAR, otherwise NIL.
+#!-sb-fluid (declaim (inline ok-ref-lambda-var))
+(defun ok-ref-lambda-var (ref)
+ (declare (type ref ref))
+ (let ((leaf (ref-leaf ref)))
+ (when (and (lambda-var-p leaf)
+ (lambda-var-constraints leaf))
+ leaf)))
+
+;;; If CONT's USE is a REF, then return OK-REF-LAMBDA-VAR of the USE,
+;;; otherwise NIL.
+#!-sb-fluid (declaim (inline ok-cont-lambda-var))
+(defun ok-cont-lambda-var (cont)
+ (declare (type continuation cont))
+ (let ((use (continuation-use cont)))
+ (when (ref-p use)
+ (ok-ref-lambda-var use))))
+
+;;; Add the indicated test constraint to BLOCK, marking the block as
+;;; having a new assertion when the constriant was not already
+;;; present. We don't add the constraint if the block has multiple
+;;; predecessors, since it only holds on this particular path.
+(defun add-test-constraint (block fun x y not-p)
+ (unless (rest (block-pred block))
+ (let ((con (find-constraint fun x y not-p))
+ (old (or (block-test-constraint block)
+ (setf (block-test-constraint block) (make-sset)))))
+ (when (sset-adjoin con old)
+ (setf (block-type-asserted block) t))))
+ (values))
+
+;;; Add complementary constraints to the consequent and alternative
+;;; blocks of IF. We do nothing if X is NIL.
+#!-sb-fluid (declaim (inline add-complement-constraints))
+(defun add-complement-constraints (if fun x y not-p)
+ (when x
+ (add-test-constraint (if-consequent if) fun x y not-p)
+ (add-test-constraint (if-alternative if) fun x y (not not-p)))
+ (values))
+
+;;; Add test constraints to the consequent and alternative blocks of
+;;; the test represented by USE.
+(defun add-test-constraints (use if)
+ (declare (type node use) (type cif if))
+ (typecase use
+ (ref
+ (add-complement-constraints if 'typep (ok-ref-lambda-var use)
+ (specifier-type 'null) t))
+ (combination
+ (let ((name (continuation-function-name
+ (basic-combination-fun use)))
+ (args (basic-combination-args use)))
+ (case name
+ ((%typep %instance-typep)
+ (let ((type (second args)))
+ (when (constant-continuation-p type)
+ (let ((val (continuation-value type)))
+ (add-complement-constraints if 'typep
+ (ok-cont-lambda-var (first args))
+ (if (ctype-p val)
+ val
+ (specifier-type val))
+ nil)))))
+ ((eq eql)
+ (let* ((var1 (ok-cont-lambda-var (first args)))
+ (arg2 (second args))
+ (var2 (ok-cont-lambda-var arg2)))
+ (cond ((not var1))
+ (var2
+ (add-complement-constraints if 'eql var1 var2 nil))
+ ((constant-continuation-p arg2)
+ (add-complement-constraints if 'eql var1
+ (ref-leaf
+ (continuation-use arg2))
+ nil)))))
+ ((< >)
+ (let* ((arg1 (first args))
+ (var1 (ok-cont-lambda-var arg1))
+ (arg2 (second args))
+ (var2 (ok-cont-lambda-var arg2)))
+ (when var1
+ (add-complement-constraints if name var1 (continuation-type arg2)
+ nil))
+ (when var2
+ (add-complement-constraints if (if (eq name '<) '> '<)
+ var2 (continuation-type arg1)
+ nil))))
+ (t
+ (let ((ptype (gethash name *backend-predicate-types*)))
+ (when ptype
+ (add-complement-constraints if 'typep
+ (ok-cont-lambda-var (first args))
+ ptype nil))))))))
+ (values))
+
+;;; Set the TEST-CONSTRAINT in the successors of BLOCK according to
+;;; the condition it tests.
+(defun find-test-constraints (block)
+ (declare (type cblock block))
+ (let ((last (block-last block)))
+ (when (if-p last)
+ (let ((use (continuation-use (if-test last))))
+ (when use
+ (add-test-constraints use last)))))
+
+ (setf (block-test-modified block) nil)
+ (values))
+
+;;; Compute the initial flow analysis sets for BLOCK:
+;;; -- For any lambda-var ref with a type check, add that constraint.
+;;; -- For any lambda-var set, delete all constraints on that var, and add
+;;; those constraints to the set nuked by this block.
+(defun find-block-type-constraints (block)
+ (declare (type cblock block))
+ (let ((gen (make-sset)))
+ (collect ((kill nil adjoin))
+
+ (let ((test (block-test-constraint block)))
+ (when test
+ (sset-union gen test)))
+
+ (do-nodes (node cont block)
+ (typecase node
+ (ref
+ (when (continuation-type-check cont)
+ (let ((var (ok-ref-lambda-var node)))
+ (when var
+ (let* ((atype (continuation-derived-type cont))
+ (con (find-constraint 'typep var atype nil)))
+ (sset-adjoin con gen))))))
+ (cset
+ (let ((var (set-var node)))
+ (when (lambda-var-p var)
+ (kill var)
+ (let ((cons (lambda-var-constraints var)))
+ (when cons
+ (sset-difference gen cons))))))))
+
+ (setf (block-in block) nil)
+ (setf (block-gen block) gen)
+ (setf (block-kill block) (kill))
+ (setf (block-out block) (copy-sset gen))
+ (setf (block-type-asserted block) nil)
+ (values))))
+
+;;; Return true if X is an integer NUMERIC-TYPE.
+(defun integer-type-p (x)
+ (declare (type ctype x))
+ (and (numeric-type-p x)
+ (eq (numeric-type-class x) 'integer)
+ (eq (numeric-type-complexp x) :real)))
+
+;;; Given that an inequality holds on values of type X and Y, return a
+;;; new type for X. If GREATER is true, then X was greater than Y,
+;;; otherwise less. If OR-EQUAL is true, then the inequality was
+;;; inclusive, i.e. >=.
+;;;
+;;; If GREATER (or not), then we max (or min) in Y's lower (or upper)
+;;; bound into X and return that result. If not OR-EQUAL, we can go
+;;; one greater (less) than Y's bound.
+(defun constrain-integer-type (x y greater or-equal)
+ (declare (type numeric-type x y))
+ (flet ((exclude (x)
+ (cond ((not x) nil)
+ (or-equal x)
+ (greater (1+ x))
+ (t (1- x))))
+ (bound (x)
+ (if greater (numeric-type-low x) (numeric-type-high x)))
+ (validate (x)
+ (if (and (numeric-type-low x) (numeric-type-high x)
+ (> (numeric-type-low x) (numeric-type-high x)))
+ *empty-type*
+ x)))
+ (let* ((x-bound (bound x))
+ (y-bound (exclude (bound y)))
+ (new-bound (cond ((not x-bound) y-bound)
+ ((not y-bound) x-bound)
+ (greater (max x-bound y-bound))
+ (t (min x-bound y-bound))))
+ (res (copy-numeric-type x)))
+ (if greater
+ (setf (numeric-type-low res) new-bound)
+ (setf (numeric-type-high res) new-bound))
+ (validate res))))
+
+;;; Return true if X is a float NUMERIC-TYPE.
+(defun float-type-p (x)
+ (declare (type ctype x))
+ (and (numeric-type-p x)
+ (eq (numeric-type-class x) 'float)
+ (eq (numeric-type-complexp x) :real)))
+
+;;; Exactly the same as CONSTRAIN-INTEGER-TYPE, but for float numbers.
+(defun constrain-float-type (x y greater or-equal)
+ (declare (type numeric-type x y))
+ ;; Unless :PROPAGATE-FLOAT-TYPE is in target features, then
+ ;; SB!C::BOUND-VALUE (used in the code below) is not defined, so we
+ ;; just return X without trying to calculate additional constraints.
+ #!-propagate-float-type (declare (ignore y greater or-equal))
+ #!-propagate-float-type x
+ #!+propagate-float-type
+ (labels ((exclude (x)
+ (cond ((not x) nil)
+ (or-equal x)
+ (greater
+ (if (consp x)
+ (car x)
+ x))
+ (t
+ (if (consp x)
+ x
+ (list x)))))
+ (bound (x)
+ (if greater (numeric-type-low x) (numeric-type-high x)))
+ (max-lower-bound (x y)
+ ;; Both x and y are not null. Find the max.
+ (let ((res (max (bound-value x) (bound-value y))))
+ ;; An open lower bound is greater than a close
+ ;; lower bound because the open bound doesn't
+ ;; contain the bound, so choose an open lower
+ ;; bound.
+ (set-bound res (or (consp x) (consp y)))))
+ (min-upper-bound (x y)
+ ;; Same as above, but for the min of upper bounds
+ ;; Both x and y are not null. Find the min.
+ (let ((res (min (bound-value x) (bound-value y))))
+ ;; An open upper bound is less than a closed
+ ;; upper bound because the open bound doesn't
+ ;; contain the bound, so choose an open lower
+ ;; bound.
+ (set-bound res (or (consp x) (consp y)))))
+ (validate (x)
+ (let ((x-lo (numeric-type-low x))
+ (x-hi (numeric-type-high x)))
+ (if (and x-lo x-hi (> (bound-value x-lo) (bound-value x-hi)))
+ *empty-type*
+ x))))
+ (let* ((x-bound (bound x))
+ (y-bound (exclude (bound y)))
+ (new-bound (cond ((not x-bound)
+ y-bound)
+ ((not y-bound)
+ x-bound)
+ (greater
+ (max-lower-bound x-bound y-bound))
+ (t
+ (min-upper-bound x-bound y-bound))))
+ (res (copy-numeric-type x)))
+ (if greater
+ (setf (numeric-type-low res) new-bound)
+ (setf (numeric-type-high res) new-bound))
+ (validate res))))
+
+;;; Given the set of CONSTRAINTS for a variable and the current set of
+;;; restrictions from flow analysis IN, set the type for REF
+;;; accordingly.
+(defun constrain-ref-type (ref constraints in)
+ (declare (type ref ref) (type sset constraints in))
+ (let ((var-cons (copy-sset constraints)))
+ (sset-intersection var-cons in)
+ (let ((res (single-value-type (node-derived-type ref)))
+ (not-res *empty-type*)
+ (leaf (ref-leaf ref)))
+ (do-sset-elements (con var-cons)
+ (let* ((x (constraint-x con))
+ (y (constraint-y con))
+ (not-p (constraint-not-p con))
+ (other (if (eq x leaf) y x))
+ (kind (constraint-kind con)))
+ (case kind
+ (typep
+ (if not-p
+ (setq not-res (type-union not-res other))
+ (setq res (type-intersection res other))))
+ (eql
+ (let ((other-type (leaf-type other)))
+ (if not-p
+ (when (and (constant-p other)
+ (member-type-p other-type))
+ (setq not-res (type-union not-res other-type)))
+ (let ((leaf-type (leaf-type leaf)))
+ (when (or (constant-p other)
+ (and (csubtypep other-type leaf-type)
+ (not (type= other-type leaf-type))))
+ (change-ref-leaf ref other)
+ (when (constant-p other) (return)))))))
+ ((< >)
+ (cond ((and (integer-type-p res) (integer-type-p y))
+ (let ((greater (eq kind '>)))
+ (let ((greater (if not-p (not greater) greater)))
+ (setq res
+ (constrain-integer-type res y greater not-p)))))
+ #!+constrain-float-type
+ ((and (float-type-p res) (float-type-p y))
+ (let ((greater (eq kind '>)))
+ (let ((greater (if not-p (not greater) greater)))
+ (setq res
+ (constrain-float-type res y greater not-p)))))
+ )))))
+
+ (let* ((cont (node-cont ref))
+ (dest (continuation-dest cont)))
+ (cond ((and (if-p dest)
+ (csubtypep (specifier-type 'null) not-res)
+ (eq (continuation-asserted-type cont) *wild-type*))
+ (setf (node-derived-type ref) *wild-type*)
+ (change-ref-leaf ref (find-constant 't)))
+ (t
+ (derive-node-type ref (or (type-difference res not-res)
+ res)))))))
+
+ (values))
+
+;;; Deliver the results of constraint propagation to REFs in BLOCK.
+;;; During this pass, we also do local constraint propagation by
+;;; adding in constraints as we seem them during the pass through the
+;;; block.
+(defun use-result-constraints (block)
+ (declare (type cblock block))
+ (let ((in (block-in block)))
+
+ (let ((test (block-test-constraint block)))
+ (when test
+ (sset-union in test)))
+
+ (do-nodes (node cont block)
+ (typecase node
+ (ref
+ (let ((var (ref-leaf node)))
+ (when (lambda-var-p var)
+ (let ((con (lambda-var-constraints var)))
+ (when con
+ (constrain-ref-type node con in)
+ (when (continuation-type-check cont)
+ (sset-adjoin
+ (find-constraint 'typep var
+ (continuation-asserted-type cont)
+ nil)
+ in)))))))
+ (cset
+ (let ((var (set-var node)))
+ (when (lambda-var-p var)
+ (let ((cons (lambda-var-constraints var)))
+ (when cons
+ (sset-difference in cons))))))))))
+
+;;; Return true if VAR would have to be closed over if environment
+;;; analysis ran now (i.e. if there are any uses that have a different
+;;; home lambda than VAR's home.)
+(defun closure-var-p (var)
+ (declare (type lambda-var var))
+ (let ((home (lambda-home (lambda-var-home var))))
+ (flet ((frob (l)
+ (dolist (node l nil)
+ (unless (eq (node-home-lambda node) home)
+ (return t)))))
+ (or (frob (leaf-refs var))
+ (frob (basic-var-sets var))))))
+
+;;; Give an empty constraints set to any var that doesn't have one and
+;;; isn't a set closure var. Since a var that we previously rejected
+;;; looks identical to one that is new, so we optimistically keep
+;;; hoping that vars stop being closed over or lose their sets.
+(defun init-var-constraints (component)
+ (declare (type component component))
+ (dolist (fun (component-lambdas component))
+ (flet ((frob (x)
+ (dolist (var (lambda-vars x))
+ (unless (lambda-var-constraints var)
+ (when (or (null (lambda-var-sets var))
+ (not (closure-var-p var)))
+ (setf (lambda-var-constraints var) (make-sset)))))))
+ (frob fun)
+ (dolist (let (lambda-lets fun))
+ (frob let)))))
+
+;;; BLOCK-IN becomes the intersection of the OUT of the prececessors.
+;;; Our OUT is:
+;;; out U (in - kill)
+;;;
+;;; BLOCK-KILL is just a list of the lambda-vars killed, so we must
+;;; compute the kill set when there are any vars killed. We bum this a
+;;; bit by special-casing when only one var is killed, and just using
+;;; that var's constraints as the kill set. This set could possibly be
+;;; precomputed, but it would have to be invalidated whenever any
+;;; constraint is added, which would be a pain.
+(defun flow-propagate-constraints (block)
+ (let* ((pred (block-pred block))
+ (in (cond (pred
+ (let ((res (copy-sset (block-out (first pred)))))
+ (dolist (b (rest pred))
+ (sset-intersection res (block-out b)))
+ res))
+ (t
+ (when *check-consistency*
+ (let ((*compiler-error-context* (block-last block)))
+ (compiler-warning
+ "*** Unreachable code in constraint ~
+ propagation... Bug?")))
+ (make-sset))))
+ (kill (block-kill block))
+ (out (block-out block)))
+
+ (setf (block-in block) in)
+ (cond ((null kill)
+ (sset-union (block-out block) in))
+ ((null (rest kill))
+ (let ((con (lambda-var-constraints (first kill))))
+ (if con
+ (sset-union-of-difference out in con)
+ (sset-union out in))))
+ (t
+ (let ((kill-set (make-sset)))
+ (dolist (var kill)
+ (let ((con (lambda-var-constraints var)))
+ (when con
+ (sset-union kill-set con))))
+ (sset-union-of-difference (block-out block) in kill-set))))))
+
+(defun constraint-propagate (component)
+ (declare (type component component))
+ (init-var-constraints component)
+
+ (do-blocks (block component)
+ (when (block-test-modified block)
+ (find-test-constraints block)))
+
+ (do-blocks (block component)
+ (cond ((block-type-asserted block)
+ (find-block-type-constraints block))
+ (t
+ (setf (block-in block) nil)
+ (setf (block-out block) (copy-sset (block-gen block))))))
+
+ (setf (block-out (component-head component)) (make-sset))
+
+ (let ((did-something nil))
+ (loop
+ (do-blocks (block component)
+ (when (flow-propagate-constraints block)
+ (setq did-something t)))
+
+ (unless did-something (return))
+ (setq did-something nil)))
+
+ (do-blocks (block component)
+ (use-result-constraints block))
+
+ (values))
+
--- /dev/null
+;;;; This file contains the control analysis pass in the compiler. This
+;;;; pass determines the order in which the IR2 blocks are to be
+;;;; emitted, attempting to minimize the associated branching costs.
+;;;;
+;;;; At this point, we commit to generating IR2 (and ultimately
+;;;; assembler) for reachable blocks. Before this phase there might be
+;;;; blocks that are unreachable but still appear in the DFO, due in
+;;;; inadequate optimization, etc.
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!C")
+
+(file-comment
+ "$Header$")
+
+;;; Insert Block in the emission order after the block After.
+(defun add-to-emit-order (block after)
+ (declare (type block-annotation block after))
+ (let ((next (block-annotation-next after)))
+ (setf (block-annotation-next after) block)
+ (setf (block-annotation-prev block) after)
+ (setf (block-annotation-next block) next)
+ (setf (block-annotation-prev next) block))
+ (values))
+
+;;; If Block looks like the head of a loop, then attempt to rotate it.
+;;; A block looks like a loop head if the number of some predecessor
+;;; is less than the block's number. Since blocks are numbered in
+;;; reverse DFN, this will identify loop heads in a reducible flow
+;;; graph.
+;;;
+;;; When we find a suspected loop head, we scan back from the tail to
+;;; find an alternate loop head. This substitution preserves the
+;;; correctness of the walk, since the old head can be reached from
+;;; the new head. We determine the new head by scanning as far back as
+;;; we can find increasing block numbers. Beats me if this is in
+;;; general optimal, but it works in simple cases.
+;;;
+;;; This optimization is inhibited in functions with NLX EPs, since it
+;;; is hard to do this without possibly messing up the special-case
+;;; walking from NLX EPs described in CONTROL-ANALYZE-1-FUN. We also
+;;; suppress rotation of loop heads which are the start of a function
+;;; (i.e. tail calls), as the debugger wants functions to start at the
+;;; start.
+(defun find-rotated-loop-head (block)
+ (declare (type cblock block))
+ (let* ((num (block-number block))
+ (env (block-environment block))
+ (pred (dolist (pred (block-pred block) nil)
+ (when (and (not (block-flag pred))
+ (eq (block-environment pred) env)
+ (< (block-number pred) num))
+ (return pred)))))
+ (cond
+ ((and pred
+ (not (environment-nlx-info env))
+ (not (eq (node-block (lambda-bind (block-home-lambda block)))
+ block)))
+ (let ((current pred)
+ (current-num (block-number pred)))
+ (block DONE
+ (loop
+ (dolist (pred (block-pred current) (return-from DONE))
+ (when (eq pred block)
+ (return-from DONE))
+ (when (and (not (block-flag pred))
+ (eq (block-environment pred) env)
+ (> (block-number pred) current-num))
+ (setq current pred current-num (block-number pred))
+ (return)))))
+ (assert (not (block-flag current)))
+ current))
+ (t
+ block))))
+
+;;; Do a graph walk linking blocks into the emit order as we go. We call
+;;; FIND-ROTATED-LOOP-HEAD to do while-loop optimization.
+;;;
+;;; We treat blocks ending in tail local calls to other environments
+;;; specially. We can't walked the called function immediately, since it is in
+;;; a different function and we must keep the code for a function contiguous.
+;;; Instead, we return the function that we want to call so that it can be
+;;; walked as soon as possible, which is hopefully immediately.
+;;;
+;;; If any of the recursive calls ends in a tail local call, then we return
+;;; the last such function, since it is the only one we can possibly drop
+;;; through to. (But it doesn't have to be from the last block walked, since
+;;; that call might not have added anything.)
+;;;
+;;; We defer walking successors whose successor is the component tail (end
+;;; in an error, NLX or tail full call.) This is to discourage making error
+;;; code the drop-through.
+(defun control-analyze-block (block tail block-info-constructor)
+ (declare (type cblock block) (type block-annotation tail))
+ (unless (block-flag block)
+ (let ((block (find-rotated-loop-head block)))
+ (setf (block-flag block) t)
+ (assert (and (block-component block) (not (block-delete-p block))))
+ (add-to-emit-order (or (block-info block)
+ (setf (block-info block)
+ (funcall block-info-constructor block)))
+ (block-annotation-prev tail))
+
+ (let ((last (block-last block)))
+ (cond ((and (combination-p last) (node-tail-p last)
+ (eq (basic-combination-kind last) :local)
+ (not (eq (node-environment last)
+ (lambda-environment (combination-lambda last)))))
+ (combination-lambda last))
+ (t
+ (let ((component-tail (component-tail (block-component block)))
+ (block-succ (block-succ block))
+ (fun nil))
+ (dolist (succ block-succ)
+ (unless (eq (first (block-succ succ)) component-tail)
+ (let ((res (control-analyze-block
+ succ tail block-info-constructor)))
+ (when res (setq fun res)))))
+ (dolist (succ block-succ)
+ (control-analyze-block succ tail block-info-constructor))
+ fun)))))))
+
+;;; Analyze all of the NLX EPs first to ensure that code reachable only from
+;;; a NLX is emitted contiguously with the code reachable from the Bind. Code
+;;; reachable from the Bind is inserted *before* the NLX code so that the Bind
+;;; marks the beginning of the code for the function. If the walks from NLX
+;;; EPs reach the bind block, then we just move it to the beginning.
+;;;
+;;; If the walk from the bind node encountered a tail local call, then we
+;;; start over again there to help the call drop through. Of course, it will
+;;; never get a drop-through if either function has NLX code.
+(defun control-analyze-1-fun (fun component block-info-constructor)
+ (declare (type clambda fun) (type component component))
+ (let* ((tail-block (block-info (component-tail component)))
+ (prev-block (block-annotation-prev tail-block))
+ (bind-block (node-block (lambda-bind fun))))
+ (unless (block-flag bind-block)
+ (dolist (nlx (environment-nlx-info (lambda-environment fun)))
+ (control-analyze-block (nlx-info-target nlx) tail-block
+ block-info-constructor))
+ (cond
+ ((block-flag bind-block)
+ (let* ((block-note (block-info bind-block))
+ (prev (block-annotation-prev block-note))
+ (next (block-annotation-next block-note)))
+ (setf (block-annotation-prev next) prev)
+ (setf (block-annotation-next prev) next)
+ (add-to-emit-order block-note prev-block)))
+ (t
+ (let ((new-fun (control-analyze-block bind-block
+ (block-annotation-next
+ prev-block)
+ block-info-constructor)))
+ (when new-fun
+ (control-analyze-1-fun new-fun component
+ block-info-constructor)))))))
+ (values))
+
+;;; Do control analysis on Component, finding the emit order. Our only
+;;; cleverness here is that we walk XEP's first to increase the probability
+;;; that the tail call will be a drop-through.
+;;;
+;;; When we are done, we delete blocks that weren't reached by the walk.
+;;; Some return blocks are made unreachable by LTN without setting
+;;; COMPONENT-REANALYZE. We remove all deleted blocks from the IR2-COMPONENT
+;;; VALUES-RECEIVERS to keep stack analysis from getting confused.
+(defevent control-deleted-block "control analysis deleted dead block")
+(defun control-analyze (component block-info-constructor)
+ (declare (type component component)
+ (type function block-info-constructor))
+ (let* ((head (component-head component))
+ (head-block (funcall block-info-constructor head))
+ (tail (component-tail component))
+ (tail-block (funcall block-info-constructor tail)))
+ (setf (block-info head) head-block)
+ (setf (block-info tail) tail-block)
+ (setf (block-annotation-prev tail-block) head-block)
+ (setf (block-annotation-next head-block) tail-block)
+
+ (clear-flags component)
+
+ (dolist (fun (component-lambdas component))
+ (when (external-entry-point-p fun)
+ (control-analyze-1-fun fun component block-info-constructor)))
+
+ (dolist (fun (component-lambdas component))
+ (control-analyze-1-fun fun component block-info-constructor))
+
+ (do-blocks (block component)
+ (unless (block-flag block)
+ (event control-deleted-block (continuation-next (block-start block)))
+ (delete-block block))))
+
+ (let ((2comp (component-info component)))
+ (when (ir2-component-p 2comp)
+ ;; If it's not an ir2-component, don't worry about it.
+ (setf (ir2-component-values-receivers 2comp)
+ (delete-if-not #'block-component
+ (ir2-component-values-receivers 2comp)))))
+
+ (values))
--- /dev/null
+;;;; This file implements the copy propagation phase of the compiler,
+;;;; which uses global flow analysis to eliminate unnecessary copying
+;;;; of variables.
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!C")
+
+(file-comment
+ "$Header$")
+
+;;; In copy propagation, we manipulate sets of TNs. We only consider TNs whose
+;;; sole write is by a MOVE VOP. This allows us to use a degenerate version of
+;;; reaching definitions: since each such TN has only one definition, the TN
+;;; can stand for the definition. We can get away with this simplification,
+;;; since the TNs that would be subject to copy propagation are nearly always
+;;; single-writer (mostly temps allocated to ensure evaluation order is
+;;; perserved). Only TNs written by MOVEs are interesting, since all we do
+;;; with this information is delete spurious MOVEs.
+;;;
+;;; There are additional semantic constraints on whether a TN can be considered
+;;; to be a copy. See TN-IS-A-COPY-OF.
+;;;
+;;; If a TN is in the IN set for a block, that TN is a copy of a TN which still
+;;; has the same value it had at the time the move was done. Any reference
+;;; to a TN in the IN set can be replaced with a reference to the TN moved
+;;; from. When we delete all reads of such a TN, we can delete the MOVE VOP.
+;;; IN is computed as the intersection of OUT for all the predecessor blocks.
+;;;
+;;; In this flow analysis scheme, the KILL set is the set of all interesting
+;;; TNs where the copied TN is modified by the block (in any way.)
+;;;
+;;; GEN is the set of all interesting TNs that are copied in the block (whose
+;;; write appears in the block.)
+;;;
+;;; OUT is (union (difference IN KILL) GEN)
+
+;;; If TN is subject to copy propagation, then return the TN it is a copy
+;;; of, otherwise NIL.
+;;;
+;;; We also only consider TNs where neither the TN nor the copied TN are wired
+;;; or restricted. If we extended the life of a wired or restricted TN,
+;;; register allocation might fail, and we can't substitute arbitrary things
+;;; for references to wired or restricted TNs, since the reader may be
+;;; expencting the argument to be in a particular place (as in a passing
+;;; location.)
+;;;
+;;; The TN must be a :NORMAL TN. Other TNs might have hidden references or be
+;;; otherwise bizarre.
+;;;
+;;; A TN is also inelegible if it has interned name, policy is such that we
+;;; would dump it in the debug vars, and speed is not 3.
+;;;
+;;; The SCs of the TN's primitive types is a subset of the SCs of the copied
+;;; TN. Moves between TNs of different primitive type SCs may need to be
+;;; changed into coercions, so we can't squeeze them out. The reason for
+;;; testing for subset of the SCs instead of the same primitive type is
+;;; that this test lets T be substituted for LIST, POSITIVE-FIXNUM for FIXNUM,
+;;; etc. Note that more SCs implies fewer possible values, or a subtype
+;;; relationship, since more SCs implies more possible representations.
+(defun tn-is-copy-of (tn)
+ (declare (type tn tn))
+ (declare (inline subsetp))
+ (let ((writes (tn-writes tn)))
+ (and (eq (tn-kind tn) :normal)
+ (not (tn-sc tn)) ; Not wired or restricted.
+ (and writes (null (tn-ref-next writes)))
+ (let ((vop (tn-ref-vop writes)))
+ (and (eq (vop-info-name (vop-info vop)) 'move)
+ (let ((arg-tn (tn-ref-tn (vop-args vop))))
+ (and (or (not (tn-sc arg-tn))
+ (eq (tn-kind arg-tn) :constant))
+ (subsetp (primitive-type-scs
+ (tn-primitive-type tn))
+ (primitive-type-scs
+ (tn-primitive-type arg-tn)))
+ (let ((leaf (tn-leaf tn)))
+ (or (not leaf)
+ (not (symbol-package (leaf-name leaf)))
+ (policy (vop-node vop)
+ (or (= speed 3) (< debug 2)))))
+ arg-tn)))))))
+
+;;; Init the sets in Block for copy propagation. To find Gen, we just look
+;;; for MOVE vops, and then see whether the result is a eligible copy TN. To
+;;; find Kill, we must look at all VOP results, seeing whether any of the
+;;; reads of the written TN are copies for eligible TNs.
+(defun init-copy-sets (block)
+ (declare (type cblock block))
+ (let ((kill (make-sset))
+ (gen (make-sset)))
+ (do ((vop (ir2-block-start-vop (block-info block)) (vop-next vop)))
+ ((null vop))
+ (unless (and (eq (vop-info-name (vop-info vop)) 'move)
+ (let ((y (tn-ref-tn (vop-results vop))))
+ (when (tn-is-copy-of y)
+ (sset-adjoin y gen)
+ t)))
+ (do ((res (vop-results vop) (tn-ref-across res)))
+ ((null res))
+ (let ((res-tn (tn-ref-tn res)))
+ (do ((read (tn-reads res-tn) (tn-ref-next read)))
+ ((null read))
+ (let ((read-vop (tn-ref-vop read)))
+ (when (eq (vop-info-name (vop-info read-vop)) 'move)
+ (let ((y (tn-ref-tn (vop-results read-vop))))
+ (when (tn-is-copy-of y)
+ (sset-delete y gen)
+ (sset-adjoin y kill))))))))))
+
+ (setf (block-out block) (copy-sset gen))
+ (setf (block-kill block) kill)
+ (setf (block-gen block) gen))
+ (values))
+
+;;; Do the flow analysis step for copy propagation on Block. We rely on OUT
+;;; being initialized to GEN, and use SSET-UNION-OF-DIFFERENCE to incrementally
+;;; build the union in OUT, rather than replacing OUT each time.
+(defun copy-flow-analysis (block)
+ (declare (type cblock block))
+ (let* ((pred (block-pred block))
+ (in (copy-sset (block-out (first pred)))))
+ (dolist (pred-block (rest pred))
+ (sset-intersection in (block-out pred-block)))
+ (setf (block-in block) in)
+ (sset-union-of-difference (block-out block) in (block-kill block))))
+
+(defevent copy-deleted-move "Copy propagation deleted a move.")
+
+;;; Return true if Arg is a reference to a TN that we can copy propagate to.
+;;; In addition to dealing with copy chains (as discussed below), we also throw
+;;; out references that are arguments to a local call, since IR2tran introduces
+;;; tempes in that context to preserve parallel assignment semantics.
+(defun ok-copy-ref (vop arg in original-copy-of)
+ (declare (type vop vop) (type tn arg) (type sset in)
+ (type hash-table original-copy-of))
+ (and (sset-member arg in)
+ (do ((original (gethash arg original-copy-of)
+ (gethash original original-copy-of)))
+ ((not original) t)
+ (unless (sset-member original in)
+ (return nil)))
+ (let ((info (vop-info vop)))
+ (not (and (eq (vop-info-move-args info) :local-call)
+ (>= (or (position-in #'tn-ref-across arg (vop-args vop)
+ :key #'tn-ref-tn)
+ (error "Couldn't find REF?"))
+ (length (template-arg-types info))))))))
+
+;;; Make use of the result of flow analysis to eliminate copies. We scan
+;;; the VOPs in block, propagating copies and keeping our IN set in sync.
+;;;
+;;; Original-Copy-Of is an EQ hash table that we use to keep track of
+;;; renamings when there are copy chains, i.e. copies of copies. When we see
+;;; copy of a copy, we enter the first copy in the table with the second copy
+;;; as a key. When we see a reference to a TN in a copy chain, we can only
+;;; substitute the first copied TN for the reference when all intervening
+;;; copies in the copy chain are also available. Otherwise, we just leave the
+;;; reference alone. It is possible that we might have been able to reference
+;;; one of the intermediate copies instead, but that copy might have already
+;;; been deleted, since we delete the move immediately when the references go
+;;; to zero.
+;;;
+;;; To understand why we always can to the substitution when the copy chain
+;;; recorded in the Original-Copy-Of table hits NIL, note that we make an entry
+;;; in the table iff we change the arg of a copy. If an entry is not in the
+;;; table, it must be that we hit a move which *originally* referenced our
+;;; Copy-Of TN. If all the intervening copies reach our reference, then
+;;; Copy-Of must reach the reference.
+;;;
+;;; Note that due to our restricting copies to single-writer TNs, it will
+;;; always be the case that when the first copy in a chain reaches the
+;;; reference, all intervening copies reach also reach the reference. We
+;;; don't exploit this, since we have to work backward from the last copy.
+;;;
+;;; In this discussion, we are really only playing with the tail of the true
+;;; copy chain for which all of the copies have already had PROPAGATE-COPIES
+;;; done on them. But, because we do this pass in DFO, it is virtually always
+;;; the case that we will process earlier copies before later ones. In
+;;; perverse cases (non-reducible flow graphs), we just miss some optimization
+;;; opportinities.
+(defun propagate-copies (block original-copy-of)
+ (declare (type cblock block) (type hash-table original-copy-of))
+ (let ((in (block-in block)))
+ (do ((vop (ir2-block-start-vop (block-info block)) (vop-next vop)))
+ ((null vop))
+ (let ((this-copy (and (eq (vop-info-name (vop-info vop)) 'move)
+ (let ((y (tn-ref-tn (vop-results vop))))
+ (when (tn-is-copy-of y) y)))))
+ ;; Substitute copied TN for copy when we find a reference to a copy.
+ ;; If the copy is left with no reads, delete the move to the copy.
+ (do ((arg-ref (vop-args vop) (tn-ref-across arg-ref)))
+ ((null arg-ref))
+ (let* ((arg (tn-ref-tn arg-ref))
+ (copy-of (tn-is-copy-of arg)))
+ (when (and copy-of (ok-copy-ref vop arg in original-copy-of))
+ (when this-copy
+ (setf (gethash this-copy original-copy-of) arg))
+ (change-tn-ref-tn arg-ref copy-of)
+ (when (null (tn-reads arg))
+ (event copy-deleted-move)
+ (delete-vop (tn-ref-vop (tn-writes arg)))))))
+ ;; Kill any elements in IN that are copies of a TN we are clobbering.
+ (do ((res-ref (vop-results vop) (tn-ref-across res-ref)))
+ ((null res-ref))
+ (do-sset-elements (tn in)
+ (when (eq (tn-is-copy-of tn) (tn-ref-tn res-ref))
+ (sset-delete tn in))))
+ ;; If this VOP is a copy, add the copy TN to IN.
+ (when this-copy (sset-adjoin this-copy in)))))
+
+ (values))
+
+;;; Do copy propagation on Component by initializing the flow analysis sets,
+;;; doing flow analysis, and then propagating copies using the results.
+(defun copy-propagate (component)
+ (setf (block-out (component-head component)) (make-sset))
+ (do-blocks (block component)
+ (init-copy-sets block))
+
+ (loop
+ (let ((did-something nil))
+ (do-blocks (block component)
+ (when (copy-flow-analysis block)
+ (setq did-something t)))
+ (unless did-something (return))))
+
+ (let ((original-copies (make-hash-table :test 'eq)))
+ (do-blocks (block component)
+ (propagate-copies block original-copies)))
+
+ (values))
--- /dev/null
+;;;; This file contains code which knows about both the type
+;;;; representation and the compiler IR1 representation. This stuff is
+;;;; used for doing type checking.
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!C")
+
+(file-comment
+ "$Header$")
+
+;;; These are the functions that are to be called when a problem is
+;;; detected. They are passed format arguments. If null, we don't do
+;;; anything. The error function is called when something is
+;;; definitely incorrect. The warning function is called when it is
+;;; somehow impossible to tell whether the call is correct.
+(defvar *error-function*)
+(defvar *warning-function*)
+
+;;; The function that we use for type checking. The derived type is
+;;; the first argument and the type we are testing against is the
+;;; second argument. The function should return values like CSUBTYPEP.
+(defvar *test-function*)
+;;; FIXME: Why is this a variable? Explain.
+
+(declaim (type (or function null) *error-function* *warning-function
+ *test-function*))
+
+;;; *LOSSAGE-DETECTED* is set when a definite incompatibility is
+;;; detected. *SLIME-DETECTED* is set when we can't tell whether the
+;;; call is compatible or not.
+(defvar *lossage-detected*)
+(defvar *slime-detected*)
+;;; FIXME: SLIME is vivid and concise, but "DEFINITE-CALL-LOSSAGE" and
+;;; "POSSIBLE-CALL-LOSSAGE" would be more mnemonic.
+
+;;; Signal a warning if appropriate and set *LOSSAGE-DETECTED*.
+(declaim (ftype (function (string &rest t) (values)) note-lossage note-slime))
+(defun note-lossage (format-string &rest format-args)
+ (setq *lossage-detected* t)
+ (when *error-function*
+ (apply *error-function* format-string format-args))
+ (values))
+(defun note-slime (format-string &rest format-args)
+ (setq *slime-detected* t)
+ (when *warning-function*
+ (apply *warning-function* format-string format-args))
+ (values))
+
+(declaim (special *compiler-error-context*))
+\f
+;;;; stuff for checking a call against a function type
+;;;;
+;;;; FIXME: This is stuff to look at when I get around to fixing
+;;;; function type inference and declarations.
+
+;;; A dummy version of SUBTYPEP useful when we want a functional like
+;;; subtypep that always returns true.
+(defun always-subtypep (type1 type2)
+ (declare (ignore type1 type2))
+ (values t t))
+
+;;; Determine whether a use of a function is consistent with its type.
+;;; These values are returned:
+;;; T, T: the call is definitely valid.
+;;; NIL, T: the call is definitely invalid.
+;;; NIL, NIL: unable to determine whether the call is valid.
+;;;
+;;; The Argument-Test function is used to determine whether an
+;;; argument type matches the type we are checking against. Similarly,
+;;; the Result-Test is used to determine whether the result type
+;;; matches the specified result.
+;;;
+;;; Unlike the argument test, the result test may be called on values
+;;; or function types. If Strict-Result is true and safety is
+;;; non-zero, then the Node-Derived-Type is always used. Otherwise, if
+;;; Cont's Type-Check is true, then the Node-Derived-Type is
+;;; intersected with the Cont's Asserted-Type.
+;;;
+;;; The error and warning functions are functions that are called to
+;;; explain the result. We bind *compiler-error-context* to the
+;;; combination node so that Compiler-Warning and related functions
+;;; will do the right thing if they are supplied.
+(defun valid-function-use (call type &key
+ ((:argument-test *test-function*) #'csubtypep)
+ (result-test #'values-subtypep)
+ (strict-result nil)
+ ((:error-function *error-function*))
+ ((:warning-function *warning-function*)))
+ (declare (type function result-test) (type combination call)
+ (type function-type type))
+ (let* ((*lossage-detected* nil)
+ (*slime-detected* nil)
+ (*compiler-error-context* call)
+ (args (combination-args call))
+ (nargs (length args))
+ (required (function-type-required type))
+ (min-args (length required))
+ (optional (function-type-optional type))
+ (max-args (+ min-args (length optional)))
+ (rest (function-type-rest type))
+ (keyp (function-type-keyp type)))
+
+ (cond
+ ((function-type-wild-args type)
+ (do ((i 1 (1+ i))
+ (arg args (cdr arg)))
+ ((null arg))
+ (check-arg-type (car arg) *wild-type* i)))
+ ((not (or optional keyp rest))
+ (if (/= nargs min-args)
+ (note-lossage
+ "The function was called with ~R argument~:P, but wants exactly ~R."
+ nargs min-args)
+ (check-fixed-and-rest args required nil)))
+ ((< nargs min-args)
+ (note-lossage
+ "The function was called with ~R argument~:P, but wants at least ~R."
+ nargs min-args))
+ ((<= nargs max-args)
+ (check-fixed-and-rest args (append required optional) rest))
+ ((not (or keyp rest))
+ (note-lossage
+ "The function was called with ~R argument~:P, but wants at most ~R."
+ nargs max-args))
+ ((and keyp (oddp (- nargs max-args)))
+ (note-lossage
+ "The function has an odd number of arguments in the keyword portion."))
+ (t
+ (check-fixed-and-rest args (append required optional) rest)
+ (when keyp
+ (check-keywords args max-args type))))
+
+ (let* ((dtype (node-derived-type call))
+ (return-type (function-type-returns type))
+ (cont (node-cont call))
+ (out-type
+ (if (or (not (continuation-type-check cont))
+ (and strict-result (policy call (/= safety 0))))
+ dtype
+ (values-type-intersection (continuation-asserted-type cont)
+ dtype))))
+ (multiple-value-bind (int win) (funcall result-test out-type return-type)
+ (cond ((not win)
+ (note-slime "can't tell whether the result is a ~S"
+ (type-specifier return-type)))
+ ((not int)
+ (note-lossage "The result is a ~S, not a ~S."
+ (type-specifier out-type)
+ (type-specifier return-type))))))
+
+ (cond (*lossage-detected* (values nil t))
+ (*slime-detected* (values nil nil))
+ (t (values t t)))))
+
+;;; Check that the derived type of the continuation Cont is compatible
+;;; with Type. N is the arg number, for error message purposes. We
+;;; return true if arg is definitely o.k. If the type is a magic
+;;; CONSTANT-TYPE, then we check for the argument being a constant
+;;; value of the specified type. If there is a manifest type error
+;;; (DERIVED-TYPE = NIL), then we flame about the asserted type even
+;;; when our type is satisfied under the test.
+(defun check-arg-type (cont type n)
+ (declare (type continuation cont) (type ctype type) (type index n))
+ (cond
+ ((not (constant-type-p type))
+ (let ((ctype (continuation-type cont)))
+ (multiple-value-bind (int win) (funcall *test-function* ctype type)
+ (cond ((not win)
+ (note-slime "can't tell whether the ~:R argument is a ~S" n
+ (type-specifier type))
+ nil)
+ ((not int)
+ (note-lossage "The ~:R argument is a ~S, not a ~S." n
+ (type-specifier ctype)
+ (type-specifier type))
+ nil)
+ ((eq ctype *empty-type*)
+ (note-slime "The ~:R argument never returns a value." n)
+ nil)
+ (t t)))))
+ ((not (constant-continuation-p cont))
+ (note-slime "The ~:R argument is not a constant." n)
+ nil)
+ (t
+ (let ((val (continuation-value cont))
+ (type (constant-type-type type)))
+ (multiple-value-bind (res win) (ctypep val type)
+ (cond ((not win)
+ (note-slime "can't tell whether the ~:R argument is a ~
+ constant ~S:~% ~S"
+ n (type-specifier type) val)
+ nil)
+ ((not res)
+ (note-lossage "The ~:R argument is not a constant ~S:~% ~S"
+ n (type-specifier type) val)
+ nil)
+ (t t)))))))
+
+;;; Check that each of the type of each supplied argument intersects
+;;; with the type specified for that argument. If we can't tell, then
+;;; we complain about the slime.
+(declaim (ftype (function (list list (or ctype null)) (values)) check-fixed-and-rest))
+(defun check-fixed-and-rest (args types rest)
+ (do ((arg args (cdr arg))
+ (type types (cdr type))
+ (n 1 (1+ n)))
+ ((or (null type) (null arg))
+ (when rest
+ (dolist (arg arg)
+ (check-arg-type arg rest n)
+ (incf n))))
+ (declare (fixnum n))
+ (check-arg-type (car arg) (car type) n))
+ (values))
+
+;;; Check that the keyword args are of the correct type. Each keyword
+;;; should be known and the corresponding argument should be of the
+;;; correct type. If the keyword isn't a constant, then we can't tell,
+;;; so we note slime.
+(declaim (ftype (function (list fixnum function-type) (values)) check-keywords))
+(defun check-keywords (args pre-key type)
+ (do ((key (nthcdr pre-key args) (cddr key))
+ (n (1+ pre-key) (+ n 2)))
+ ((null key))
+ (declare (fixnum n))
+ (let ((k (car key)))
+ (cond
+ ((not (check-arg-type k (specifier-type 'symbol) n)))
+ ((not (constant-continuation-p k))
+ (note-slime "The ~:R argument (in keyword position) is not a constant."
+ n))
+ (t
+ (let* ((name (continuation-value k))
+ (info (find name (function-type-keywords type)
+ :key #'key-info-name)))
+ (cond ((not info)
+ (unless (function-type-allowp type)
+ (note-lossage "~S is not a known argument keyword."
+ name)))
+ (t
+ (check-arg-type (second key) (key-info-type info)
+ (1+ n)))))))))
+ (values))
+
+;;; Construct a function type from a definition.
+;;;
+;;; Due to the lack of a (LIST X) type specifier, we can't reconstruct
+;;; the &REST type.
+(declaim (ftype (function (functional) function-type) definition-type))
+(defun definition-type (functional)
+ (if (lambda-p functional)
+ (make-function-type
+ :required (mapcar #'leaf-type (lambda-vars functional))
+ :returns (tail-set-type (lambda-tail-set functional)))
+ (let ((rest nil))
+ (collect ((req)
+ (opt)
+ (keys))
+ (dolist (arg (optional-dispatch-arglist functional))
+ (let ((info (lambda-var-arg-info arg))
+ (type (leaf-type arg)))
+ (if info
+ (ecase (arg-info-kind info)
+ (:required (req type))
+ (:optional (opt type))
+ (:keyword
+ (keys (make-key-info :name (arg-info-keyword info)
+ :type type)))
+ ((:rest :more-context)
+ (setq rest *universal-type*))
+ (:more-count))
+ (req type))))
+
+ (make-function-type
+ :required (req)
+ :optional (opt)
+ :rest rest
+ :keywords (keys)
+ :keyp (optional-dispatch-keyp functional)
+ :allowp (optional-dispatch-allowp functional)
+ :returns (tail-set-type
+ (lambda-tail-set
+ (optional-dispatch-main-entry functional))))))))
+\f
+;;;; approximate function types
+;;;;
+;;;; FIXME: This is stuff to look at when I get around to fixing function
+;;;; type inference and declarations.
+;;;;
+;;;; Approximate function types provide a condensed representation of all the
+;;;; different ways that a function has been used. If we have no declared or
+;;;; defined type for a function, then we build an approximate function type by
+;;;; examining each use of the function. When we encounter a definition or
+;;;; proclamation, we can check the actual type for compatibity with the
+;;;; previous uses.
+
+(defstruct (approximate-function-type)
+ ;; The smallest and largest numbers of arguments that this function has been
+ ;; called with.
+ (min-args call-arguments-limit :type fixnum)
+ (max-args 0 :type fixnum)
+ ;; A list of lists of the all the types that have been used in each argument
+ ;; position.
+ (types () :type list)
+ ;; A list of the Approximate-Key-Info structures describing all the things
+ ;; that looked like keyword arguments. There are distinct structures
+ ;; describing each argument position in which the keyword appeared.
+ (keys () :type list))
+
+(defstruct (approximate-key-info)
+ ;; The keyword name of this argument. Although keyword names don't have to
+ ;; be keywords, we only match on keywords when figuring an approximate type.
+ (name (required-argument) :type keyword)
+ ;; The position at which this keyword appeared. 0 if it appeared as the
+ ;; first argument, etc.
+ (position (required-argument) :type fixnum)
+ ;; A list of all the argument types that have been used with this keyword.
+ (types nil :type list)
+ ;; True if this keyword has appeared only in calls with an obvious
+ ;; :allow-other-keys.
+ (allowp nil :type (member t nil)))
+
+;;; Return an Approximate-Function-Type representing the context of
+;;; Call. If Type is supplied and not null, then we merge the
+;;; information into the information already accumulated in Type.
+(declaim (ftype (function (combination
+ &optional (or approximate-function-type null))
+ approximate-function-type)
+ note-function-use))
+(defun note-function-use (call &optional type)
+ (let* ((type (or type (make-approximate-function-type)))
+ (types (approximate-function-type-types type))
+ (args (combination-args call))
+ (nargs (length args))
+ (allowp (some #'(lambda (x)
+ (and (constant-continuation-p x)
+ (eq (continuation-value x) :allow-other-keys)))
+ args)))
+
+ (setf (approximate-function-type-min-args type)
+ (min (approximate-function-type-min-args type) nargs))
+ (setf (approximate-function-type-max-args type)
+ (max (approximate-function-type-max-args type) nargs))
+
+ (do ((old types (cdr old))
+ (arg args (cdr arg)))
+ ((null old)
+ (setf (approximate-function-type-types type)
+ (nconc types
+ (mapcar #'(lambda (x)
+ (list (continuation-type x)))
+ arg))))
+ (when (null arg) (return))
+ (pushnew (continuation-type (car arg))
+ (car old)
+ :test #'type=))
+
+ (collect ((keys (approximate-function-type-keys type) cons))
+ (do ((arg args (cdr arg))
+ (pos 0 (1+ pos)))
+ ((or (null arg) (null (cdr arg)))
+ (setf (approximate-function-type-keys type) (keys)))
+ (let ((key (first arg))
+ (val (second arg)))
+ (when (constant-continuation-p key)
+ (let ((name (continuation-value key)))
+ (when (keywordp name)
+ (let ((old (find-if
+ #'(lambda (x)
+ (and (eq (approximate-key-info-name x) name)
+ (= (approximate-key-info-position x)
+ pos)))
+ (keys)))
+ (val-type (continuation-type val)))
+ (cond (old
+ (pushnew val-type
+ (approximate-key-info-types old)
+ :test #'type=)
+ (unless allowp
+ (setf (approximate-key-info-allowp old) nil)))
+ (t
+ (keys (make-approximate-key-info
+ :name name
+ :position pos
+ :allowp allowp
+ :types (list val-type))))))))))))
+ type))
+
+;;; Similar to Valid-Function-Use, but checks an
+;;; Approximate-Function-Type against a real function type.
+(declaim (ftype (function (approximate-function-type function-type
+ &optional function function function)
+ (values boolean boolean))
+ valid-approximate-type))
+(defun valid-approximate-type (call-type type &optional
+ (*test-function* #'types-intersect)
+ (*error-function* #'compiler-warning)
+ (*warning-function* #'compiler-note))
+ (let* ((*lossage-detected* nil)
+ (*slime-detected* nil)
+ (required (function-type-required type))
+ (min-args (length required))
+ (optional (function-type-optional type))
+ (max-args (+ min-args (length optional)))
+ (rest (function-type-rest type))
+ (keyp (function-type-keyp type)))
+
+ (when (function-type-wild-args type)
+ (return-from valid-approximate-type (values t t)))
+
+ (let ((call-min (approximate-function-type-min-args call-type)))
+ (when (< call-min min-args)
+ (note-lossage
+ "Function previously called with ~R argument~:P, but wants at least ~R."
+ call-min min-args)))
+
+ (let ((call-max (approximate-function-type-max-args call-type)))
+ (cond ((<= call-max max-args))
+ ((not (or keyp rest))
+ (note-lossage
+ "Function previously called with ~R argument~:P, but wants at most ~R."
+ call-max max-args))
+ ((and keyp (oddp (- call-max max-args)))
+ (note-lossage
+ "Function previously called with an odd number of arguments in ~
+ the keyword portion.")))
+
+ (when (and keyp (> call-max max-args))
+ (check-approximate-keywords call-type max-args type)))
+
+ (check-approximate-fixed-and-rest call-type (append required optional)
+ rest)
+
+ (cond (*lossage-detected* (values nil t))
+ (*slime-detected* (values nil nil))
+ (t (values t t)))))
+
+;;; Check that each of the types used at each arg position is
+;;; compatible with the actual type.
+(declaim (ftype (function (approximate-function-type list (or ctype null))
+ (values))
+ check-approximate-fixed-and-rest))
+(defun check-approximate-fixed-and-rest (call-type fixed rest)
+ (do ((types (approximate-function-type-types call-type) (cdr types))
+ (n 1 (1+ n))
+ (arg fixed (cdr arg)))
+ ((null types))
+ (let ((decl-type (or (car arg) rest)))
+ (unless decl-type (return))
+ (check-approximate-arg-type (car types) decl-type "~:R" n)))
+ (values))
+
+;;; Check that each of the call-types is compatible with Decl-Type,
+;;; complaining if not or if we can't tell.
+(declaim (ftype (function (list ctype string &rest t) (values))
+ check-approximate-arg-type))
+(defun check-approximate-arg-type (call-types decl-type context &rest args)
+ (let ((losers *empty-type*))
+ (dolist (ctype call-types)
+ (multiple-value-bind (int win) (funcall *test-function* ctype decl-type)
+ (cond
+ ((not win)
+ (note-slime "can't tell whether previous ~? argument type ~S is a ~S"
+ context args (type-specifier ctype) (type-specifier decl-type)))
+ ((not int)
+ (setq losers (type-union ctype losers))))))
+
+ (unless (eq losers *empty-type*)
+ (note-lossage "~:(~?~) argument should be a ~S but was a ~S in a previous call."
+ context args (type-specifier decl-type) (type-specifier losers))))
+ (values))
+
+;;; Check the types of each manifest keyword that appears in a keyword
+;;; argument position. Check the validity of all keys that appeared in
+;;; valid keyword positions.
+;;;
+;;; ### We could check the Approximate-Function-Type-Types to make
+;;; sure that all arguments in keyword positions were manifest
+;;; keywords.
+(defun check-approximate-keywords (call-type max-args type)
+ (let ((call-keys (approximate-function-type-keys call-type))
+ (keys (function-type-keywords type)))
+ (dolist (key keys)
+ (let ((name (key-info-name key)))
+ (collect ((types nil append))
+ (dolist (call-key call-keys)
+ (let ((pos (approximate-key-info-position call-key)))
+ (when (and (eq (approximate-key-info-name call-key) name)
+ (> pos max-args) (evenp (- pos max-args)))
+ (types (approximate-key-info-types call-key)))))
+ (check-approximate-arg-type (types) (key-info-type key) "~S" name))))
+
+ (unless (function-type-allowp type)
+ (collect ((names () adjoin))
+ (dolist (call-key call-keys)
+ (let ((pos (approximate-key-info-position call-key)))
+ (when (and (> pos max-args) (evenp (- pos max-args))
+ (not (approximate-key-info-allowp call-key)))
+ (names (approximate-key-info-name call-key)))))
+
+ (dolist (name (names))
+ (unless (find name keys :key #'key-info-name)
+ (note-lossage "Function previously called with unknown argument keyword ~S."
+ name)))))))
+\f
+;;;; ASSERT-DEFINITION-TYPE
+
+;;; Intersect Lambda's var types with Types, giving a warning if there
+;;; is a mismatch. If all intersections are non-null, we return lists
+;;; of the variables and intersections, otherwise we return NIL, NIL.
+(defun try-type-intersections (vars types where)
+ (declare (list vars types) (string where))
+ (collect ((res))
+ (mapc #'(lambda (var type)
+ (let* ((vtype (leaf-type var))
+ (int (type-intersection vtype type)))
+ (cond
+ ((eq int *empty-type*)
+ (note-lossage
+ "Definition's declared type for variable ~A:~% ~S~@
+ conflicts with this type from ~A:~% ~S"
+ (leaf-name var) (type-specifier vtype)
+ where (type-specifier type))
+ (return-from try-type-intersections (values nil nil)))
+ (t
+ (res int)))))
+ vars types)
+ (values vars (res))))
+
+;;; Check that the optional-dispatch OD conforms to Type. We return
+;;; the values of TRY-TYPE-INTERSECTIONS if there are no syntax
+;;; problems, otherwise NIL, NIL.
+;;;
+;;; Note that the variables in the returned list are the actual
+;;; original variables (extracted from the optional dispatch arglist),
+;;; rather than the variables that are arguments to the main entry.
+;;; This difference is significant only for keyword args with hairy
+;;; defaults. Returning the actual vars allows us to use the right
+;;; variable name in warnings.
+;;;
+;;; A slightly subtle point: with keywords and optionals, the type in
+;;; the function type is only an assertion on calls --- it doesn't
+;;; constrain the type of default values. So we have to union in the
+;;; type of the default. With optionals, we can't do any assertion
+;;; unless the default is constant.
+;;;
+;;; With keywords, we exploit our knowledge about how hairy keyword
+;;; defaulting is done when computing the type assertion to put on the
+;;; main-entry argument. In the case of hairy keywords, the default
+;;; has been clobbered with NIL, which is the value of the main-entry
+;;; arg in the unsupplied case, whatever the actual default value is.
+;;; So we can just assume the default is constant, effectively
+;;; unioning in NULL, and not totally blow off doing any type
+;;; assertion.
+(defun find-optional-dispatch-types (od type where)
+ (declare (type optional-dispatch od) (type function-type type)
+ (string where))
+ (let* ((min (optional-dispatch-min-args od))
+ (req (function-type-required type))
+ (opt (function-type-optional type)))
+ (flet ((frob (x y what)
+ (unless (= x y)
+ (note-lossage
+ "Definition has ~R ~A arg~P, but ~A has ~R."
+ x what x where y))))
+ (frob min (length req) "fixed")
+ (frob (- (optional-dispatch-max-args od) min) (length opt) "optional"))
+ (flet ((frob (x y what)
+ (unless (eq x y)
+ (note-lossage
+ "Definition ~:[doesn't have~;has~] ~A, but ~
+ ~A ~:[doesn't~;does~]."
+ x what where y))))
+ (frob (optional-dispatch-keyp od) (function-type-keyp type)
+ "keyword args")
+ (unless (optional-dispatch-keyp od)
+ (frob (not (null (optional-dispatch-more-entry od)))
+ (not (null (function-type-rest type)))
+ "rest args"))
+ (frob (optional-dispatch-allowp od) (function-type-allowp type)
+ "&allow-other-keys"))
+
+ (when *lossage-detected*
+ (return-from find-optional-dispatch-types (values nil nil)))
+
+ (collect ((res)
+ (vars))
+ (let ((keys (function-type-keywords type))
+ (arglist (optional-dispatch-arglist od)))
+ (dolist (arg arglist)
+ (cond
+ ((lambda-var-arg-info arg)
+ (let* ((info (lambda-var-arg-info arg))
+ (default (arg-info-default info))
+ (def-type (when (constantp default)
+ (ctype-of (eval default)))))
+ (ecase (arg-info-kind info)
+ (:keyword
+ (let* ((key (arg-info-keyword info))
+ (kinfo (find key keys :key #'key-info-name)))
+ (cond
+ (kinfo
+ (res (type-union (key-info-type kinfo)
+ (or def-type (specifier-type 'null)))))
+ (t
+ (note-lossage
+ "Defining a ~S keyword not present in ~A."
+ key where)
+ (res *universal-type*)))))
+ (:required (res (pop req)))
+ (:optional
+ (res (type-union (pop opt) (or def-type *universal-type*))))
+ (:rest
+ (when (function-type-rest type)
+ (res (specifier-type 'list))))
+ (:more-context
+ (when (function-type-rest type)
+ (res *universal-type*)))
+ (:more-count
+ (when (function-type-rest type)
+ (res (specifier-type 'fixnum)))))
+ (vars arg)
+ (when (arg-info-supplied-p info)
+ (res *universal-type*)
+ (vars (arg-info-supplied-p info)))))
+ (t
+ (res (pop req))
+ (vars arg))))
+
+ (dolist (key keys)
+ (unless (find (key-info-name key) arglist
+ :key #'(lambda (x)
+ (let ((info (lambda-var-arg-info x)))
+ (when info
+ (arg-info-keyword info)))))
+ (note-lossage
+ "Definition lacks the ~S keyword present in ~A."
+ (key-info-name key) where))))
+
+ (try-type-intersections (vars) (res) where))))
+
+;;; Check that Type doesn't specify any funny args, and do the
+;;; intersection.
+(defun find-lambda-types (lambda type where)
+ (declare (type clambda lambda) (type function-type type) (string where))
+ (flet ((frob (x what)
+ (when x
+ (note-lossage
+ "Definition has no ~A, but the ~A did."
+ what where))))
+ (frob (function-type-optional type) "optional args")
+ (frob (function-type-keyp type) "keyword args")
+ (frob (function-type-rest type) "rest arg"))
+ (let* ((vars (lambda-vars lambda))
+ (nvars (length vars))
+ (req (function-type-required type))
+ (nreq (length req)))
+ (unless (= nvars nreq)
+ (note-lossage "Definition has ~R arg~:P, but the ~A has ~R."
+ nvars where nreq))
+ (if *lossage-detected*
+ (values nil nil)
+ (try-type-intersections vars req where))))
+
+;;; Check for syntactic and type conformance between the definition
+;;; Functional and the specified Function-Type. If they are compatible
+;;; and Really-Assert is T, then add type assertions to the definition
+;;; from the Function-Type.
+;;;
+;;; If there is a syntactic or type problem, then we call
+;;; Error-Function with an error message using Where as context
+;;; describing where Function-Type came from.
+;;;
+;;; If there is no problem, we return T (even if Really-Assert was
+;;; false). If there was a problem, we return NIL.
+(defun assert-definition-type
+ (functional type &key (really-assert t)
+ ((:error-function *error-function*) #'compiler-warning)
+ warning-function
+ (where "previous declaration"))
+ (declare (type functional functional)
+ (type function *error-function*)
+ (string where))
+ (unless (function-type-p type) (return-from assert-definition-type t))
+ (let ((*lossage-detected* nil))
+ (multiple-value-bind (vars types)
+ (if (function-type-wild-args type)
+ (values nil nil)
+ (etypecase functional
+ (optional-dispatch
+ (find-optional-dispatch-types functional type where))
+ (clambda
+ (find-lambda-types functional type where))))
+ (let* ((type-returns (function-type-returns type))
+ (return (lambda-return (main-entry functional)))
+ (atype (when return
+ (continuation-asserted-type (return-result return)))))
+ (cond
+ ((and atype (not (values-types-intersect atype type-returns)))
+ (note-lossage
+ "The result type from ~A:~% ~S~@
+ conflicts with the definition's result type assertion:~% ~S"
+ where (type-specifier type-returns) (type-specifier atype))
+ nil)
+ (*lossage-detected* nil)
+ ((not really-assert) t)
+ (t
+ (when atype
+ (assert-continuation-type (return-result return) atype))
+ (loop for var in vars and type in types do
+ (cond ((basic-var-sets var)
+ (when (and warning-function
+ (not (csubtypep (leaf-type var) type)))
+ (funcall warning-function
+ "Assignment to argument: ~S~% ~
+ prevents use of assertion from function ~
+ type ~A:~% ~S~%"
+ (leaf-name var) where (type-specifier type))))
+ (t
+ (setf (leaf-type var) type)
+ (dolist (ref (leaf-refs var))
+ (derive-node-type ref type)))))
+ t))))))
--- /dev/null
+;;;; stuff that creates debugger information from the compiler's
+;;;; internal data structures
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!C")
+
+(file-comment
+ "$Header$")
+
+(deftype byte-buffer () '(vector (unsigned-byte 8)))
+(defvar *byte-buffer*)
+(declaim (type byte-buffer *byte-buffer*))
+\f
+;;;; debug blocks
+
+(deftype location-kind ()
+ '(member :unknown-return :known-return :internal-error :non-local-exit
+ :block-start :call-site :single-value-return :non-local-entry))
+
+;;; The Location-Info structure holds the information what we need about
+;;; locations which code generation decided were "interesting".
+(defstruct (location-info
+ (:constructor make-location-info (kind label vop)))
+ ;; The kind of location noted.
+ (kind nil :type location-kind)
+ ;; The label pointing to the interesting code location.
+ (label nil :type (or label index null))
+ ;; The VOP that emitted this location (for node, save-set, ir2-block, etc.)
+ (vop nil :type vop))
+
+;;; Called during code generation in places where there is an "interesting"
+;;; location: some place where we are likely to end up in the debugger, and
+;;; thus want debug info.
+(defun note-debug-location (vop label kind)
+ (declare (type vop vop) (type (or label null) label)
+ (type location-kind kind))
+ (let ((location (make-location-info kind label vop)))
+ (setf (ir2-block-locations (vop-block vop))
+ (nconc (ir2-block-locations (vop-block vop))
+ (list location)))
+ location))
+
+#!-sb-fluid (declaim (inline ir2-block-environment))
+(defun ir2-block-environment (2block)
+ (declare (type ir2-block 2block))
+ (block-environment (ir2-block-block 2block)))
+
+;;; Given a local conflicts vector and an IR2 block to represent the set of
+;;; live TNs, and the Var-Locs hash-table representing the variables dumped,
+;;; compute a bit-vector representing the set of live variables. If the TN is
+;;; environment-live, we only mark it as live when it is in scope at Node.
+(defun compute-live-vars (live node block var-locs vop)
+ (declare (type ir2-block block) (type local-tn-bit-vector live)
+ (type hash-table var-locs) (type node node)
+ (type (or vop null) vop))
+ (let ((res (make-array (logandc2 (+ (hash-table-count var-locs) 7) 7)
+ :element-type 'bit
+ :initial-element 0))
+ (spilled (gethash vop
+ (ir2-component-spilled-vops
+ (component-info *component-being-compiled*)))))
+ (do-live-tns (tn live block)
+ (let ((leaf (tn-leaf tn)))
+ (when (and (lambda-var-p leaf)
+ (or (not (member (tn-kind tn)
+ '(:environment :debug-environment)))
+ (rassoc leaf (lexenv-variables (node-lexenv node))))
+ (or (null spilled)
+ (not (member tn spilled))))
+ (let ((num (gethash leaf var-locs)))
+ (when num
+ (setf (sbit res num) 1))))))
+ res))
+
+;;; The PC for the location most recently dumped.
+(defvar *previous-location*)
+(declaim (type index *previous-location*))
+
+;;; Dump a compiled debug-location into *BYTE-BUFFER* that describes the
+;;; code/source map and live info. If true, VOP is the VOP associated with
+;;; this location, for use in determining whether TNs are spilled.
+(defun dump-1-location (node block kind tlf-num label live var-locs vop)
+ (declare (type node node) (type ir2-block block)
+ (type local-tn-bit-vector live)
+ (type (or label index) label)
+ (type location-kind kind) (type (or index null) tlf-num)
+ (type hash-table var-locs) (type (or vop null) vop))
+
+ (vector-push-extend
+ (dpb (position-or-lose kind compiled-code-location-kinds)
+ compiled-code-location-kind-byte
+ 0)
+ *byte-buffer*)
+
+ (let ((loc (if (target-fixnump label) label (label-position label))))
+ (write-var-integer (- loc *previous-location*) *byte-buffer*)
+ (setq *previous-location* loc))
+
+ (let ((path (node-source-path node)))
+ (unless tlf-num
+ (write-var-integer (source-path-tlf-number path) *byte-buffer*))
+ (write-var-integer (source-path-form-number path) *byte-buffer*))
+
+ (write-packed-bit-vector (compute-live-vars live node block var-locs vop)
+ *byte-buffer*)
+
+ (values))
+
+;;; Extract context info from a Location-Info structure and use it to dump a
+;;; compiled code-location.
+(defun dump-location-from-info (loc tlf-num var-locs)
+ (declare (type location-info loc) (type (or index null) tlf-num)
+ (type hash-table var-locs))
+ (let ((vop (location-info-vop loc)))
+ (dump-1-location (vop-node vop)
+ (vop-block vop)
+ (location-info-kind loc)
+ tlf-num
+ (location-info-label loc)
+ (vop-save-set vop)
+ var-locs
+ vop))
+ (values))
+
+;;; Scan all the blocks, determining if all locations are in the same TLF,
+;;; and returning it or NIL.
+(defun find-tlf-number (fun)
+ (declare (type clambda fun))
+ (let ((res (source-path-tlf-number (node-source-path (lambda-bind fun)))))
+ (declare (type (or index null) res))
+ (do-environment-ir2-blocks (2block (lambda-environment fun))
+ (let ((block (ir2-block-block 2block)))
+ (when (eq (block-info block) 2block)
+ (unless (eql (source-path-tlf-number
+ (node-source-path
+ (continuation-next
+ (block-start block))))
+ res)
+ (setq res nil)))
+
+ (dolist (loc (ir2-block-locations 2block))
+ (unless (eql (source-path-tlf-number
+ (node-source-path
+ (vop-node (location-info-vop loc))))
+ res)
+ (setq res nil)))))
+ res))
+
+;;; Dump out the number of locations and the locations for Block.
+(defun dump-block-locations (block locations tlf-num var-locs)
+ (declare (type cblock block) (list locations))
+ (if (and locations
+ (eq (location-info-kind (first locations))
+ :non-local-entry))
+ (write-var-integer (length locations) *byte-buffer*)
+ (let ((2block (block-info block)))
+ (write-var-integer (+ (length locations) 1) *byte-buffer*)
+ (dump-1-location (continuation-next (block-start block))
+ 2block :block-start tlf-num
+ (ir2-block-%label 2block)
+ (ir2-block-live-out 2block)
+ var-locs
+ nil)))
+ (dolist (loc locations)
+ (dump-location-from-info loc tlf-num var-locs))
+ (values))
+
+;;; Dump the successors of Block, being careful not to fly into space on
+;;; weird successors.
+(defun dump-block-successors (block env)
+ (declare (type cblock block) (type environment env))
+ (let* ((tail (component-tail (block-component block)))
+ (succ (block-succ block))
+ (valid-succ
+ (if (and succ
+ (or (eq (car succ) tail)
+ (not (eq (block-environment (car succ)) env))))
+ ()
+ succ)))
+ (vector-push-extend
+ (dpb (length valid-succ) compiled-debug-block-nsucc-byte 0)
+ *byte-buffer*)
+ (let ((base (block-number
+ (node-block
+ (lambda-bind (environment-function env))))))
+ (dolist (b valid-succ)
+ (write-var-integer
+ (the index (- (block-number b) base))
+ *byte-buffer*))))
+ (values))
+
+;;; Return a vector and an integer (or null) suitable for use as the BLOCKS
+;;; and TLF-NUMBER in Fun's debug-function. This requires two passes to
+;;; compute:
+;;; -- Scan all blocks, dumping the header and successors followed by all the
+;;; non-elsewhere locations.
+;;; -- Dump the elsewhere block header and all the elsewhere locations (if
+;;; any.)
+(defun compute-debug-blocks (fun var-locs)
+ (declare (type clambda fun) (type hash-table var-locs))
+ (setf (fill-pointer *byte-buffer*) 0)
+ (let ((*previous-location* 0)
+ (tlf-num (find-tlf-number fun))
+ (env (lambda-environment fun))
+ (prev-locs nil)
+ (prev-block nil))
+ (collect ((elsewhere))
+ (do-environment-ir2-blocks (2block env)
+ (let ((block (ir2-block-block 2block)))
+ (when (eq (block-info block) 2block)
+ (when prev-block
+ (dump-block-locations prev-block prev-locs tlf-num var-locs))
+ (setq prev-block block prev-locs ())
+ (dump-block-successors block env)))
+
+ (collect ((here prev-locs))
+ (dolist (loc (ir2-block-locations 2block))
+ (if (label-elsewhere-p (location-info-label loc))
+ (elsewhere loc)
+ (here loc)))
+ (setq prev-locs (here))))
+
+ (dump-block-locations prev-block prev-locs tlf-num var-locs)
+
+ (when (elsewhere)
+ (vector-push-extend compiled-debug-block-elsewhere-p *byte-buffer*)
+ (write-var-integer (length (elsewhere)) *byte-buffer*)
+ (dolist (loc (elsewhere))
+ (dump-location-from-info loc tlf-num var-locs))))
+
+ (values (copy-seq *byte-buffer*) tlf-num)))
+\f
+;;; Return a list of DEBUG-SOURCE structures containing information derived
+;;; from Info. Unless :BYTE-COMPILE T was specified, we always dump the
+;;; Start-Positions, since it is too hard figure out whether we need them or
+;;; not.
+(defun debug-source-for-info (info)
+ (declare (type source-info info))
+ (assert (not (source-info-current-file info)))
+ (mapcar #'(lambda (x)
+ (let ((res (make-debug-source
+ :from :file
+ :comment (file-info-comment x)
+ :created (file-info-write-date x)
+ :compiled (source-info-start-time info)
+ :source-root (file-info-source-root x)
+ :start-positions
+ (unless (eq *byte-compile* 't)
+ (coerce-to-smallest-eltype
+ (file-info-positions x)))))
+ (name (file-info-name x)))
+ (etypecase name
+ ((member :lisp)
+ (setf (debug-source-from res) name)
+ (setf (debug-source-name res)
+ (coerce (file-info-forms x) 'simple-vector)))
+ (pathname
+ (let* ((untruename (file-info-untruename x))
+ (dir (pathname-directory untruename)))
+ (setf (debug-source-name res)
+ (namestring
+ (if (and dir (eq (first dir) :absolute))
+ untruename
+ name))))))
+ res))
+ (source-info-files info)))
+
+;;; Given an arbitrary sequence, coerce it to an unsigned vector if
+;;; possible. Ordinarily we coerce it to the smallest specialized vector
+;;; we can. However, we also have a special hack for cross-compiling at
+;;; bootstrap time, when arbitrarily-specialized aren't fully supported:
+;;; in that case, we coerce it only to a vector whose element size is an
+;;; integer multiple of output byte size.
+(defun coerce-to-smallest-eltype (seq)
+ (let ((maxoid #-sb-xc-host 0
+ ;; An initial value value of 255 prevents us from specializing
+ ;; the array to anything smaller than (UNSIGNED-BYTE 8), which
+ ;; keeps the cross-compiler's portable specialized array output
+ ;; functions happy.
+ #+sb-xc-host 255))
+ (flet ((frob (x)
+ (if (typep x 'unsigned-byte)
+ (when (>= x maxoid)
+ (setf maxoid x))
+ (return-from coerce-to-smallest-eltype
+ (coerce seq 'simple-vector)))))
+ (if (listp seq)
+ (dolist (i seq)
+ (frob i))
+ (dovector (i seq)
+ (frob i)))
+ (coerce seq `(simple-array (integer 0 ,maxoid) (*))))))
+\f
+;;;; variables
+
+;;; Return a SC-OFFSET describing TN's location.
+(defun tn-sc-offset (tn)
+ (declare (type tn tn))
+ (make-sc-offset (sc-number (tn-sc tn))
+ (tn-offset tn)))
+
+;;; Dump info to represent Var's location being TN. ID is an integer that
+;;; makes Var's name unique in the function. Buffer is the vector we stick the
+;;; result in. If Minimal is true, we suppress name dumping, and set the
+;;; minimal flag.
+;;;
+;;; The debug-var is only marked as always-live if the TN is
+;;; environment live and is an argument. If a :debug-environment TN, then we
+;;; also exclude set variables, since the variable is not guaranteed to be live
+;;; everywhere in that case.
+(defun dump-1-variable (fun var tn id minimal buffer)
+ (declare (type lambda-var var) (type (or tn null) tn) (type index id)
+ (type clambda fun))
+ (let* ((name (leaf-name var))
+ (save-tn (and tn (tn-save-tn tn)))
+ (kind (and tn (tn-kind tn)))
+ (flags 0))
+ (declare (type index flags))
+ (when minimal
+ (setq flags (logior flags compiled-debug-var-minimal-p))
+ (unless tn
+ (setq flags (logior flags compiled-debug-var-deleted-p))))
+ (when (and (or (eq kind :environment)
+ (and (eq kind :debug-environment)
+ (null (basic-var-sets var))))
+ (not (gethash tn (ir2-component-spilled-tns
+ (component-info *component-being-compiled*))))
+ (eq (lambda-var-home var) fun))
+ (setq flags (logior flags compiled-debug-var-environment-live)))
+ (when save-tn
+ (setq flags (logior flags compiled-debug-var-save-loc-p)))
+ (unless (or (zerop id) minimal)
+ (setq flags (logior flags compiled-debug-var-id-p)))
+ (vector-push-extend flags buffer)
+ (unless minimal
+ (vector-push-extend name buffer)
+ (unless (zerop id)
+ (vector-push-extend id buffer)))
+ (if tn
+ (vector-push-extend (tn-sc-offset tn) buffer)
+ (assert minimal))
+ (when save-tn
+ (vector-push-extend (tn-sc-offset save-tn) buffer)))
+ (values))
+
+;;; Return a vector suitable for use as the DEBUG-FUNCTION-VARIABLES of FUN.
+;;; LEVEL is the current DEBUG-INFO quality. VAR-LOCS is a hashtable in which
+;;; we enter the translation from LAMBDA-VARS to the relative position of that
+;;; variable's location in the resulting vector.
+(defun compute-variables (fun level var-locs)
+ (declare (type clambda fun) (type hash-table var-locs))
+ (collect ((vars))
+ (labels ((frob-leaf (leaf tn gensym-p)
+ (let ((name (leaf-name leaf)))
+ (when (and name (leaf-refs leaf) (tn-offset tn)
+ (or gensym-p (symbol-package name)))
+ (vars (cons leaf tn)))))
+ (frob-lambda (x gensym-p)
+ (dolist (leaf (lambda-vars x))
+ (frob-leaf leaf (leaf-info leaf) gensym-p))))
+ (frob-lambda fun t)
+ (when (>= level 2)
+ (dolist (x (ir2-environment-environment
+ (environment-info (lambda-environment fun))))
+ (let ((thing (car x)))
+ (when (lambda-var-p thing)
+ (frob-leaf thing (cdr x) (= level 3)))))
+
+ (dolist (let (lambda-lets fun))
+ (frob-lambda let (= level 3)))))
+
+ (let ((sorted (sort (vars) #'string<
+ :key #'(lambda (x)
+ (symbol-name (leaf-name (car x))))))
+ (prev-name nil)
+ (id 0)
+ (i 0)
+ (buffer (make-array 0 :fill-pointer 0 :adjustable t)))
+ (declare (type (or simple-string null) prev-name)
+ (type index id i))
+ (dolist (x sorted)
+ (let* ((var (car x))
+ (name (symbol-name (leaf-name var))))
+ (cond ((and prev-name (string= prev-name name))
+ (incf id))
+ (t
+ (setq id 0 prev-name name)))
+ (dump-1-variable fun var (cdr x) id nil buffer)
+ (setf (gethash var var-locs) i))
+ (incf i))
+ (coerce buffer 'simple-vector))))
+
+;;; Return a vector suitable for use as the DEBUG-FUNCTION-VARIABLES of
+;;; FUN, representing the arguments to FUN in minimal variable format.
+(defun compute-minimal-variables (fun)
+ (declare (type clambda fun))
+ (let ((buffer (make-array 0 :fill-pointer 0 :adjustable t)))
+ (dolist (var (lambda-vars fun))
+ (dump-1-variable fun var (leaf-info var) 0 t buffer))
+ (coerce buffer 'simple-vector)))
+
+;;; Return Var's relative position in the function's variables (determined
+;;; from the Var-Locs hashtable.) If Var is deleted, the return DELETED.
+(defun debug-location-for (var var-locs)
+ (declare (type lambda-var var) (type hash-table var-locs))
+ (let ((res (gethash var var-locs)))
+ (cond (res)
+ (t
+ (assert (or (null (leaf-refs var))
+ (not (tn-offset (leaf-info var)))))
+ 'deleted))))
+\f
+;;;; arguments/returns
+
+;;; Return a vector to be used as the COMPILED-DEBUG-FUNCTION-ARGUMENTS for
+;;; Fun. If fun is the MAIN-ENTRY for an optional dispatch, then look at the
+;;; ARGLIST to determine the syntax, otherwise pretend all arguments are fixed.
+;;;
+;;; ### This assumption breaks down in EPs other than the main-entry, since
+;;; they may or may not have supplied-p vars, etc.
+(defun compute-arguments (fun var-locs)
+ (declare (type clambda fun) (type hash-table var-locs))
+ (collect ((res))
+ (let ((od (lambda-optional-dispatch fun)))
+ (if (and od (eq (optional-dispatch-main-entry od) fun))
+ (let ((actual-vars (lambda-vars fun))
+ (saw-optional nil))
+ (dolist (arg (optional-dispatch-arglist od))
+ (let ((info (lambda-var-arg-info arg))
+ (actual (pop actual-vars)))
+ (cond (info
+ (case (arg-info-kind info)
+ (:keyword
+ (res (arg-info-keyword info)))
+ (:rest
+ (res 'rest-arg))
+ (:more-context
+ (res 'more-arg))
+ (:optional
+ (unless saw-optional
+ (res 'optional-args)
+ (setq saw-optional t))))
+ (res (debug-location-for actual var-locs))
+ (when (arg-info-supplied-p info)
+ (res 'supplied-p)
+ (res (debug-location-for (pop actual-vars) var-locs))))
+ (t
+ (res (debug-location-for actual var-locs)))))))
+ (dolist (var (lambda-vars fun))
+ (res (debug-location-for var var-locs)))))
+
+ (coerce-to-smallest-eltype (res))))
+
+;;; Return a vector of SC offsets describing Fun's return locations. (Must
+;;; be known values return...)
+(defun compute-debug-returns (fun)
+ (coerce-to-smallest-eltype
+ (mapcar #'(lambda (loc)
+ (tn-sc-offset loc))
+ (return-info-locations (tail-set-info (lambda-tail-set fun))))))
+\f
+;;;; debug functions
+
+;;; Return a C-D-F structure with all the mandatory slots filled in.
+(defun dfun-from-fun (fun)
+ (declare (type clambda fun))
+ (let* ((2env (environment-info (lambda-environment fun)))
+ (dispatch (lambda-optional-dispatch fun))
+ (main-p (and dispatch
+ (eq fun (optional-dispatch-main-entry dispatch)))))
+ (make-compiled-debug-function
+ :name (cond ((leaf-name fun))
+ ((let ((ef (functional-entry-function
+ fun)))
+ (and ef (leaf-name ef))))
+ ((and main-p (leaf-name dispatch)))
+ (t
+ (component-name
+ (block-component (node-block (lambda-bind fun))))))
+ :kind (if main-p nil (functional-kind fun))
+ :return-pc (tn-sc-offset (ir2-environment-return-pc 2env))
+ :old-fp (tn-sc-offset (ir2-environment-old-fp 2env))
+ :start-pc (label-position (ir2-environment-environment-start 2env))
+ :elsewhere-pc (label-position (ir2-environment-elsewhere-start 2env)))))
+
+;;; Return a complete C-D-F structure for Fun. This involves determining
+;;; the DEBUG-INFO level and filling in optional slots as appropriate.
+(defun compute-1-debug-function (fun var-locs)
+ (declare (type clambda fun) (type hash-table var-locs))
+ (let* ((dfun (dfun-from-fun fun))
+ (actual-level
+ (cookie-debug (lexenv-cookie (node-lexenv (lambda-bind fun)))))
+ (level (if #!+sb-dyncount *collect-dynamic-statistics*
+ #!-sb-dyncount nil
+ (max actual-level 2)
+ actual-level)))
+ (cond ((zerop level))
+ ((and (<= level 1)
+ (let ((od (lambda-optional-dispatch fun)))
+ (or (not od)
+ (not (eq (optional-dispatch-main-entry od) fun)))))
+ (setf (compiled-debug-function-variables dfun)
+ (compute-minimal-variables fun))
+ (setf (compiled-debug-function-arguments dfun) :minimal))
+ (t
+ (setf (compiled-debug-function-variables dfun)
+ (compute-variables fun level var-locs))
+ (setf (compiled-debug-function-arguments dfun)
+ (compute-arguments fun var-locs))))
+
+ (when (>= level 2)
+ (multiple-value-bind (blocks tlf-num) (compute-debug-blocks fun var-locs)
+ (setf (compiled-debug-function-tlf-number dfun) tlf-num)
+ (setf (compiled-debug-function-blocks dfun) blocks)))
+
+ (if (external-entry-point-p fun)
+ (setf (compiled-debug-function-returns dfun) :standard)
+ (let ((info (tail-set-info (lambda-tail-set fun))))
+ (when info
+ (cond ((eq (return-info-kind info) :unknown)
+ (setf (compiled-debug-function-returns dfun)
+ :standard))
+ ((/= level 0)
+ (setf (compiled-debug-function-returns dfun)
+ (compute-debug-returns fun)))))))
+ dfun))
+\f
+;;;; minimal debug functions
+
+;;; Return true if Dfun can be represented as a minimal debug function.
+;;; Dfun is a cons (<start offset> . C-D-F).
+(defun debug-function-minimal-p (dfun)
+ (declare (type cons dfun))
+ (let ((dfun (cdr dfun)))
+ (and (member (compiled-debug-function-arguments dfun) '(:minimal nil))
+ (null (compiled-debug-function-blocks dfun)))))
+
+;;; Dump a packed binary representation of a Dfun into *byte-buffer*.
+;;; Prev-Start and Start are the byte offsets in the code where the previous
+;;; function started and where this one starts. Prev-Elsewhere is the previous
+;;; function's elsewhere PC.
+(defun dump-1-minimal-dfun (dfun prev-start start prev-elsewhere)
+ (declare (type compiled-debug-function dfun)
+ (type index prev-start start prev-elsewhere))
+ (let* ((name (compiled-debug-function-name dfun))
+ (setf-p (and (consp name) (eq (car name) 'setf)
+ (consp (cdr name)) (symbolp (cadr name))))
+ (base-name (if setf-p (cadr name) name))
+ (pkg (when (symbolp base-name)
+ (symbol-package base-name)))
+ (name-rep
+ (cond ((stringp base-name)
+ minimal-debug-function-name-component)
+ ((not pkg)
+ minimal-debug-function-name-uninterned)
+ ((eq pkg *package*)
+ minimal-debug-function-name-symbol)
+ (t
+ minimal-debug-function-name-packaged))))
+ (assert (or (atom name) setf-p))
+ (let ((options 0))
+ (setf (ldb minimal-debug-function-name-style-byte options) name-rep)
+ (setf (ldb minimal-debug-function-kind-byte options)
+ (position-or-lose (compiled-debug-function-kind dfun)
+ minimal-debug-function-kinds))
+ (setf (ldb minimal-debug-function-returns-byte options)
+ (etypecase (compiled-debug-function-returns dfun)
+ ((member :standard) minimal-debug-function-returns-standard)
+ ((member :fixed) minimal-debug-function-returns-fixed)
+ (vector minimal-debug-function-returns-specified)))
+ (vector-push-extend options *byte-buffer*))
+
+ (let ((flags 0))
+ (when setf-p
+ (setq flags (logior flags minimal-debug-function-setf-bit)))
+ (when (compiled-debug-function-nfp dfun)
+ (setq flags (logior flags minimal-debug-function-nfp-bit)))
+ (when (compiled-debug-function-variables dfun)
+ (setq flags (logior flags minimal-debug-function-variables-bit)))
+ (vector-push-extend flags *byte-buffer*))
+
+ (when (eql name-rep minimal-debug-function-name-packaged)
+ (write-var-string (package-name pkg) *byte-buffer*))
+ (unless (stringp base-name)
+ (write-var-string (symbol-name base-name) *byte-buffer*))
+
+ (let ((vars (compiled-debug-function-variables dfun)))
+ (when vars
+ (let ((len (length vars)))
+ (write-var-integer len *byte-buffer*)
+ (dotimes (i len)
+ (vector-push-extend (aref vars i) *byte-buffer*)))))
+
+ (let ((returns (compiled-debug-function-returns dfun)))
+ (when (vectorp returns)
+ (let ((len (length returns)))
+ (write-var-integer len *byte-buffer*)
+ (dotimes (i len)
+ (write-var-integer (aref returns i) *byte-buffer*)))))
+
+ (write-var-integer (compiled-debug-function-return-pc dfun)
+ *byte-buffer*)
+ (write-var-integer (compiled-debug-function-old-fp dfun)
+ *byte-buffer*)
+ (when (compiled-debug-function-nfp dfun)
+ (write-var-integer (compiled-debug-function-nfp dfun)
+ *byte-buffer*))
+ (write-var-integer (- start prev-start) *byte-buffer*)
+ (write-var-integer (- (compiled-debug-function-start-pc dfun) start)
+ *byte-buffer*)
+ (write-var-integer (- (compiled-debug-function-elsewhere-pc dfun)
+ prev-elsewhere)
+ *byte-buffer*)))
+
+;;; Return a byte-vector holding all the debug functions for a component in
+;;; the packed binary minimal-debug-function format.
+(defun compute-minimal-debug-functions (dfuns)
+ (declare (list dfuns))
+ (setf (fill-pointer *byte-buffer*) 0)
+ (let ((prev-start 0)
+ (prev-elsewhere 0))
+ (dolist (dfun dfuns)
+ (let ((start (car dfun))
+ (elsewhere (compiled-debug-function-elsewhere-pc (cdr dfun))))
+ (dump-1-minimal-dfun (cdr dfun) prev-start start prev-elsewhere)
+ (setq prev-start start prev-elsewhere elsewhere))))
+ (copy-seq *byte-buffer*))
+\f
+;;;; full component dumping
+
+;;; Compute the full form (simple-vector) function map.
+(defun compute-debug-function-map (sorted)
+ (declare (list sorted))
+ (let* ((len (1- (* (length sorted) 2)))
+ (funs-vec (make-array len)))
+ (do ((i -1 (+ i 2))
+ (sorted sorted (cdr sorted)))
+ ((= i len))
+ (declare (fixnum i))
+ (let ((dfun (car sorted)))
+ (unless (minusp i)
+ (setf (svref funs-vec i) (car dfun)))
+ (setf (svref funs-vec (1+ i)) (cdr dfun))))
+ funs-vec))
+
+;;; Return a DEBUG-INFO structure describing COMPONENT. This has to be
+;;; called after assembly so that source map information is available.
+(defun debug-info-for-component (component)
+ (declare (type component component))
+ (collect ((dfuns))
+ (let ((var-locs (make-hash-table :test 'eq))
+ ;; FIXME: What is *BYTE-BUFFER* for? Has it become dead code now that
+ ;; we no longer use minimal-debug-function representation?
+ (*byte-buffer* (make-array 10
+ :element-type '(unsigned-byte 8)
+ :fill-pointer 0
+ :adjustable t)))
+ (dolist (fun (component-lambdas component))
+ (clrhash var-locs)
+ (dfuns (cons (label-position
+ (block-label (node-block (lambda-bind fun))))
+ (compute-1-debug-function fun var-locs))))
+ (let* ((sorted (sort (dfuns) #'< :key #'car))
+ ;; FIXME: CMU CL had
+ ;; (IF (EVERY #'DEBUG-FUNCTION-MINIMAL-P SORTED)
+ ;; (COMPUTE-MINIMAL-DEBUG-FUNCTIONS SORTED)
+ ;; (COMPUTE-DEBUG-FUNCTION-MAP SORTED))
+ ;; here. We've gotten rid of the minimal-debug-function case in
+ ;; SBCL because the minimal representation couldn't be made to
+ ;; transform properly under package renaming. Now that that
+ ;; case is gone, a lot of code is dead, and once everything is
+ ;; known to work, the dead code should be deleted.
+ (function-map (compute-debug-function-map sorted)))
+ (make-compiled-debug-info :name (component-name component)
+ :function-map function-map)))))
+\f
+;;; Write BITS out to BYTE-BUFFER in backend byte order. The length of BITS
+;;; must be evenly divisible by eight.
+(defun write-packed-bit-vector (bits byte-buffer)
+ (declare (type simple-bit-vector bits) (type byte-buffer byte-buffer))
+ (multiple-value-bind (initial step done)
+ (ecase *backend-byte-order*
+ (:little-endian (values 0 1 8))
+ (:big-endian (values 7 -1 -1)))
+ (let ((shift initial)
+ (byte 0))
+ (dotimes (i (length bits))
+ (let ((int (aref bits i)))
+ (setf byte (logior byte (ash int shift)))
+ (incf shift step))
+ (when (= shift done)
+ (vector-push-extend byte byte-buffer)
+ (setf shift initial
+ byte 0)))
+ (unless (= shift initial)
+ (vector-push-extend byte byte-buffer))))
+ (values))
--- /dev/null
+;;;; This file contains utilities for debugging the compiler --
+;;;; currently only stuff for checking the consistency of the IR1.
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!C")
+
+(file-comment
+ "$Header$")
+
+(defvar *args* ()
+ #!+sb-doc
+ "This variable is bound to the format arguments when an error is signalled
+ by BARF or BURP.")
+
+(defvar *ignored-errors* (make-hash-table :test 'equal))
+
+;;; A definite inconsistency has been detected. Signal an error with
+;;; *args* bound to the list of the format args.
+(declaim (ftype (function (string &rest t) (values)) barf))
+(defun barf (string &rest *args*)
+ (unless (gethash string *ignored-errors*)
+ (restart-case
+ (apply #'error string *args*)
+ (continue ()
+ :report "Ignore this error.")
+ (ignore-all ()
+ :report "Ignore this and all future occurrences of this error."
+ (setf (gethash string *ignored-errors*) t))))
+ (values))
+
+(defvar *burp-action* :warn
+ #!+sb-doc
+ "Action taken by the BURP function when a possible compiler bug is detected.
+ One of :WARN, :ERROR or :NONE.")
+(declaim (type (member :warn :error :none) *burp-action*))
+
+;;; Called when something funny but possibly correct is noticed. Otherwise
+;;; similar to Barf.
+(declaim (ftype (function (string &rest t) (values)) burp))
+(defun burp (string &rest *args*)
+ (ecase *burp-action*
+ (:warn (apply #'warn string *args*))
+ (:error (apply #'cerror "press on anyway." string *args*))
+ (:none))
+ (values))
+
+;;; *Seen-Blocks* is a hashtable with true values for all blocks which appear
+;;; in the DFO for one of the specified components.
+(defvar *seen-blocks* (make-hash-table :test 'eq))
+
+;;; *Seen-Functions* is similar, but records all the lambdas we reached by
+;;; recursing on top-level functions.
+(defvar *seen-functions* (make-hash-table :test 'eq))
+
+;;; Barf if Node is in a block which wasn't reached during the graph walk.
+(declaim (ftype (function (node) (values)) check-node-reached))
+(defun check-node-reached (node)
+ (unless (gethash (continuation-block (node-prev node)) *seen-blocks*)
+ (barf "~S was not reached." node))
+ (values))
+
+;;; Check everything that we can think of for consistency. When a definite
+;;; inconsistency is detected, we BARF. Possible problems just cause us to
+;;; BURP. Our argument is a list of components, but we also look at the
+;;; *FREE-VARIABLES*, *FREE-FUNCTIONS* and *CONSTANTS*.
+;;;
+;;; First we do a pre-pass which finds all the blocks and lambdas, testing
+;;; that they are linked together properly and entering them in hashtables.
+;;; Next, we iterate over the blocks again, looking at the actual code and
+;;; control flow. Finally, we scan the global leaf hashtables, looking for
+;;; lossage.
+(declaim (ftype (function (list) (values)) check-ir1-consistency))
+(defun check-ir1-consistency (components)
+ (clrhash *seen-blocks*)
+ (clrhash *seen-functions*)
+ (dolist (c components)
+ (let* ((head (component-head c))
+ (tail (component-tail c)))
+ (unless (and (null (block-pred head)) (null (block-succ tail)))
+ (barf "~S is malformed." c))
+
+ (do ((prev nil block)
+ (block head (block-next block)))
+ ((null block)
+ (unless (eq prev tail)
+ (barf "wrong Tail for DFO, ~S in ~S" prev c)))
+ (setf (gethash block *seen-blocks*) t)
+ (unless (eq (block-prev block) prev)
+ (barf "bad PREV for ~S, should be ~S" block prev))
+ (unless (or (eq block tail)
+ (eq (block-component block) c))
+ (barf "~S is not in ~S." block c)))
+#|
+ (when (or (loop-blocks c) (loop-inferiors c))
+ (do-blocks (block c :both)
+ (setf (block-flag block) nil))
+ (check-loop-consistency c nil)
+ (do-blocks (block c :both)
+ (unless (block-flag block)
+ (barf "~S was not in any loop." block))))
+|#
+ ))
+
+ (check-function-consistency components)
+
+ (dolist (c components)
+ (do ((block (block-next (component-head c)) (block-next block)))
+ ((null (block-next block)))
+ (check-block-consistency block)))
+
+ (maphash #'(lambda (k v)
+ (declare (ignore k))
+ (unless (or (constant-p v)
+ (and (global-var-p v)
+ (member (global-var-kind v)
+ '(:global :special :constant))))
+ (barf "strange *FREE-VARIABLES* entry: ~S" v))
+ (dolist (n (leaf-refs v))
+ (check-node-reached n))
+ (when (basic-var-p v)
+ (dolist (n (basic-var-sets v))
+ (check-node-reached n))))
+ *free-variables*)
+
+ (maphash #'(lambda (k v)
+ (declare (ignore k))
+ (unless (constant-p v)
+ (barf "strange *CONSTANTS* entry: ~S" v))
+ (dolist (n (leaf-refs v))
+ (check-node-reached n)))
+ *constants*)
+
+ (maphash #'(lambda (k v)
+ (declare (ignore k))
+ (unless (or (functional-p v)
+ (and (global-var-p v)
+ (eq (global-var-kind v) :global-function)))
+ (barf "strange *FREE-FUNCTIONS* entry: ~S" v))
+ (dolist (n (leaf-refs v))
+ (check-node-reached n)))
+ *free-functions*)
+ (clrhash *seen-functions*)
+ (clrhash *seen-blocks*)
+ (values))
+\f
+;;;; function consistency checking
+
+(defun observe-functional (x)
+ (declare (type functional x))
+ (when (gethash x *seen-functions*)
+ (barf "~S was seen more than once." x))
+ (unless (eq (functional-kind x) :deleted)
+ (setf (gethash x *seen-functions*) t)))
+
+;;; Check that the specified function has been seen.
+(defun check-function-reached (fun where)
+ (declare (type functional fun))
+ (unless (gethash fun *seen-functions*)
+ (barf "unseen function ~S in ~S" fun where)))
+
+;;; In a lambda, check that the associated nodes are in seen blocks. In an
+;;; optional dispatch, check that the entry points were seen. If the function
+;;; is deleted, ignore it.
+(defun check-function-stuff (functional)
+ (ecase (functional-kind functional)
+ (:external
+ (let ((fun (functional-entry-function functional)))
+ (check-function-reached fun functional)
+ (when (functional-kind fun)
+ (barf "The function for XEP ~S has kind." functional))
+ (unless (eq (functional-entry-function fun) functional)
+ (barf "bad back-pointer in function for XEP ~S" functional))))
+ ((:let :mv-let :assignment)
+ (check-function-reached (lambda-home functional) functional)
+ (when (functional-entry-function functional)
+ (barf "The LET ~S has entry function." functional))
+ (unless (member functional (lambda-lets (lambda-home functional)))
+ (barf "The LET ~S is not in LETs for HOME." functional))
+ (unless (eq (functional-kind functional) :assignment)
+ (when (rest (leaf-refs functional))
+ (barf "The LET ~S has multiple references." functional)))
+ (when (lambda-lets functional)
+ (barf "LETs in a LET: ~S" functional)))
+ (:optional
+ (when (functional-entry-function functional)
+ (barf ":OPTIONAL ~S has an ENTRY-FUNCTION." functional))
+ (let ((ef (lambda-optional-dispatch functional)))
+ (check-function-reached ef functional)
+ (unless (or (member functional (optional-dispatch-entry-points ef))
+ (eq functional (optional-dispatch-more-entry ef))
+ (eq functional (optional-dispatch-main-entry ef)))
+ (barf ":OPTIONAL ~S is not an e-p for its OPTIONAL-DISPATCH ~S."
+ functional ef))))
+ (:top-level
+ (unless (eq (functional-entry-function functional) functional)
+ (barf "The ENTRY-FUNCTION in ~S isn't a self-pointer." functional)))
+ ((nil :escape :cleanup)
+ (let ((ef (functional-entry-function functional)))
+ (when ef
+ (check-function-reached ef functional)
+ (unless (eq (functional-kind ef) :external)
+ (barf "The ENTRY-FUNCTION in ~S isn't an XEP: ~S."
+ functional
+ ef)))))
+ (:deleted
+ (return-from check-function-stuff)))
+
+ (case (functional-kind functional)
+ ((nil :optional :external :top-level :escape :cleanup)
+ (when (lambda-p functional)
+ (dolist (fun (lambda-lets functional))
+ (unless (eq (lambda-home fun) functional)
+ (barf "The home in ~S is not ~S." fun functional))
+ (check-function-reached fun functional))
+ (unless (eq (lambda-home functional) functional)
+ (barf "home not self-pointer in ~S" functional)))))
+
+ (etypecase functional
+ (clambda
+ (when (lambda-bind functional)
+ (check-node-reached (lambda-bind functional)))
+ (when (lambda-return functional)
+ (check-node-reached (lambda-return functional)))
+
+ (dolist (var (lambda-vars functional))
+ (dolist (ref (leaf-refs var))
+ (check-node-reached ref))
+ (dolist (set (basic-var-sets var))
+ (check-node-reached set))
+ (unless (eq (lambda-var-home var) functional)
+ (barf "HOME in ~S should be ~S." var functional))))
+ (optional-dispatch
+ (dolist (ep (optional-dispatch-entry-points functional))
+ (check-function-reached ep functional))
+ (let ((more (optional-dispatch-more-entry functional)))
+ (when more (check-function-reached more functional)))
+ (check-function-reached (optional-dispatch-main-entry functional)
+ functional))))
+
+(defun check-function-consistency (components)
+ (dolist (c components)
+ (dolist (fun (component-new-functions c))
+ (observe-functional fun))
+ (dolist (fun (component-lambdas c))
+ (when (eq (functional-kind fun) :external)
+ (let ((ef (functional-entry-function fun)))
+ (when (optional-dispatch-p ef)
+ (observe-functional ef))))
+ (observe-functional fun)
+ (dolist (let (lambda-lets fun))
+ (observe-functional let))))
+
+ (dolist (c components)
+ (dolist (fun (component-new-functions c))
+ (check-function-stuff fun))
+ (dolist (fun (component-lambdas c))
+ (when (eq (functional-kind fun) :deleted)
+ (barf "deleted lambda ~S in Lambdas for ~S" fun c))
+ (check-function-stuff fun)
+ (dolist (let (lambda-lets fun))
+ (check-function-stuff let)))))
+\f
+;;;; loop consistency checking
+
+#|
+;;; Descend through the loop nesting and check that the tree is well-formed
+;;; and that all blocks in the loops are known blocks. We also mark each block
+;;; that we see so that we can do a check later to detect blocks that weren't
+;;; in any loop.
+(declaim (ftype (function (loop (or loop null)) (values)) check-loop-consistency))
+(defun check-loop-consistency (loop superior)
+ (unless (eq (loop-superior loop) superior)
+ (barf "wrong superior in ~S, should be ~S" loop superior))
+ (when (and superior
+ (/= (loop-depth loop) (1+ (loop-depth superior))))
+ (barf "wrong depth in ~S" loop))
+
+ (dolist (tail (loop-tail loop))
+ (check-loop-block tail loop))
+ (dolist (exit (loop-exits loop))
+ (check-loop-block exit loop))
+ (check-loop-block (loop-head loop) loop)
+ (unless (eq (block-loop (loop-head loop)) loop)
+ (barf "The head of ~S is not directly in the loop." loop))
+
+ (do ((block (loop-blocks loop) (block-loop-next block)))
+ ((null block))
+ (setf (block-flag block) t)
+ (unless (gethash block *seen-blocks*)
+ (barf "unseen block ~S in Blocks for ~S" block loop))
+ (unless (eq (block-loop block) loop)
+ (barf "wrong loop in ~S, should be ~S" block loop)))
+
+ (dolist (inferior (loop-inferiors loop))
+ (check-loop-consistency inferior loop))
+ (values))
+
+;;; Check that Block is either in Loop or an inferior.
+(declaim (ftype (function (block loop) (values)) check-loop-block))
+(defun check-loop-block (block loop)
+ (unless (gethash block *seen-blocks*)
+ (barf "unseen block ~S in loop info for ~S" block loop))
+ (labels ((walk (l)
+ (if (eq (block-loop block) l)
+ t
+ (dolist (inferior (loop-inferiors l) nil)
+ (when (walk inferior) (return t))))))
+ (unless (walk loop)
+ (barf "~S is in loop info for ~S but not in the loop." block loop)))
+ (values))
+
+|#
+
+;;; Check a block for consistency at the general flow-graph level, and call
+;;; Check-Node-Consistency on each node to locally check for semantic
+;;; consistency.
+(declaim (ftype (function (cblock) (values)) check-block-consistency))
+(defun check-block-consistency (block)
+
+ (dolist (pred (block-pred block))
+ (unless (gethash pred *seen-blocks*)
+ (barf "unseen predecessor ~S in ~S" pred block))
+ (unless (member block (block-succ pred))
+ (barf "bad predecessor link ~S in ~S" pred block)))
+
+ (let* ((fun (block-home-lambda block))
+ (fun-deleted (eq (functional-kind fun) :deleted))
+ (this-cont (block-start block))
+ (last (block-last block)))
+ (unless fun-deleted
+ (check-function-reached fun block))
+ (when (not this-cont)
+ (barf "~S has no START." block))
+ (when (not last)
+ (barf "~S has no LAST." block))
+ (unless (eq (continuation-kind this-cont) :block-start)
+ (barf "The START of ~S has the wrong kind." block))
+
+ (let ((use (continuation-use this-cont))
+ (uses (block-start-uses block)))
+ (when (and (null use) (= (length uses) 1))
+ (barf "~S has a unique use, but no USE." this-cont))
+ (dolist (node uses)
+ (unless (eq (node-cont node) this-cont)
+ (barf "The USE ~S for START in ~S has wrong CONT." node block))
+ (check-node-reached node)))
+
+ (let* ((last-cont (node-cont last))
+ (cont-block (continuation-block last-cont))
+ (dest (continuation-dest last-cont)))
+ (ecase (continuation-kind last-cont)
+ (:deleted)
+ (:deleted-block-start
+ (let ((dest (continuation-dest last-cont)))
+ (when dest
+ (check-node-reached dest)))
+ (unless (member last (block-start-uses cont-block))
+ (barf "LAST in ~S is missing from uses of its Cont." block)))
+ (:block-start
+ (check-node-reached (continuation-next last-cont))
+ (unless (member last (block-start-uses cont-block))
+ (barf "LAST in ~S is missing from uses of its Cont." block)))
+ (:inside-block
+ (unless (eq cont-block block)
+ (barf "CONT of LAST in ~S is in a different BLOCK." block))
+ (unless (eq (continuation-use last-cont) last)
+ (barf "USE is not LAST in CONT of LAST in ~S." block))
+ (when (continuation-next last-cont)
+ (barf "CONT of LAST has a NEXT in ~S." block))))
+
+ (when dest
+ (check-node-reached dest)))
+
+ (loop
+ (unless (eq (continuation-block this-cont) block)
+ (barf "BLOCK in ~S should be ~S." this-cont block))
+
+ (let ((dest (continuation-dest this-cont)))
+ (when dest
+ (check-node-reached dest)))
+
+ (let ((node (continuation-next this-cont)))
+ (unless (node-p node)
+ (barf "~S has strange NEXT." this-cont))
+ (unless (eq (node-prev node) this-cont)
+ (barf "PREV in ~S should be ~S." node this-cont))
+
+ (unless fun-deleted
+ (check-node-consistency node))
+
+ (let ((cont (node-cont node)))
+ (when (not cont)
+ (barf "~S has no CONT." node))
+ (when (eq node last) (return))
+ (unless (eq (continuation-kind cont) :inside-block)
+ (barf "The interior continuation ~S in ~S has the wrong kind."
+ cont
+ block))
+ (unless (continuation-next cont)
+ (barf "~S has no NEXT." cont))
+ (unless (eq (continuation-use cont) node)
+ (barf "USE in ~S should be ~S." cont node))
+ (setq this-cont cont))))
+
+ (check-block-successors block))
+ (values))
+
+;;; Check that Block is properly terminated. Each successor must be
+;;; accounted for by the type of the last node.
+(declaim (ftype (function (cblock) (values)) check-block-successors))
+(defun check-block-successors (block)
+ (let ((last (block-last block))
+ (succ (block-succ block)))
+
+ (let* ((comp (block-component block)))
+ (dolist (b succ)
+ (unless (gethash b *seen-blocks*)
+ (barf "unseen successor ~S in ~S" b block))
+ (unless (member block (block-pred b))
+ (barf "bad successor link ~S in ~S" b block))
+ (unless (eq (block-component b) comp)
+ (barf "The successor ~S in ~S is in a different component."
+ b
+ block))))
+
+ (typecase last
+ (cif
+ (unless (proper-list-of-length-p succ 1 2)
+ (barf "~S ends in an IF, but doesn't have one or two succesors."
+ block))
+ (unless (member (if-consequent last) succ)
+ (barf "The CONSEQUENT for ~S isn't in SUCC for ~S." last block))
+ (unless (member (if-alternative last) succ)
+ (barf "The ALTERNATIVE for ~S isn't in SUCC for ~S." last block)))
+ (creturn
+ (unless (if (eq (functional-kind (return-lambda last)) :deleted)
+ (null succ)
+ (and (= (length succ) 1)
+ (eq (first succ)
+ (component-tail (block-component block)))))
+ (barf "strange successors for RETURN in ~S" block)))
+ (exit
+ (unless (proper-list-of-length-p succ 0 1)
+ (barf "EXIT node with strange number of successors: ~S" last)))
+ (t
+ (unless (or (= (length succ) 1) (node-tail-p last)
+ (and (block-delete-p block) (null succ)))
+ (barf "~S ends in normal node, but doesn't have one successor."
+ block)))))
+ (values))
+\f
+;;;; node consistency checking
+
+;;; Check that the Dest for Cont is the specified Node. We also mark the
+;;; block Cont is in as Seen.
+(declaim (ftype (function (continuation node) (values)) check-dest))
+(defun check-dest (cont node)
+ (let ((kind (continuation-kind cont)))
+ (ecase kind
+ (:deleted
+ (unless (block-delete-p (node-block node))
+ (barf "DEST ~S of deleted continuation ~S is not DELETE-P."
+ cont node)))
+ (:deleted-block-start
+ (unless (eq (continuation-dest cont) node)
+ (barf "DEST for ~S should be ~S." cont node)))
+ ((:inside-block :block-start)
+ (unless (gethash (continuation-block cont) *seen-blocks*)
+ (barf "~S receives ~S, which is in an unknown block." node cont))
+ (unless (eq (continuation-dest cont) node)
+ (barf "DEST for ~S should be ~S." cont node)))))
+ (values))
+
+;;; This function deals with checking for consistency the type-dependent
+;;; information in a node.
+(defun check-node-consistency (node)
+ (declare (type node node))
+ (etypecase node
+ (ref
+ (let ((leaf (ref-leaf node)))
+ (when (functional-p leaf)
+ (if (eq (functional-kind leaf) :top-level-xep)
+ (unless (eq (component-kind (block-component (node-block node)))
+ :top-level)
+ (barf ":TOP-LEVEL-XEP ref in non-top-level component: ~S"
+ node))
+ (check-function-reached leaf node)))))
+ (basic-combination
+ (check-dest (basic-combination-fun node) node)
+ (dolist (arg (basic-combination-args node))
+ (cond
+ (arg (check-dest arg node))
+ ((not (and (eq (basic-combination-kind node) :local)
+ (combination-p node)))
+ (barf "flushed arg not in local call: ~S" node))
+ (t
+ (let ((fun (ref-leaf (continuation-use
+ (basic-combination-fun node))))
+ (pos (position arg (basic-combination-args node))))
+ (check-type pos fixnum) ; to suppress warning -- WHN 19990311
+ (when (leaf-refs (elt (lambda-vars fun) pos))
+ (barf "flushed arg for referenced var in ~S" node))))))
+
+ (let ((dest (continuation-dest (node-cont node))))
+ (when (and (return-p dest)
+ (eq (basic-combination-kind node) :local)
+ (not (eq (lambda-tail-set (combination-lambda node))
+ (lambda-tail-set (return-lambda dest)))))
+ (barf "tail local call to function with different tail set:~% ~S"
+ node))))
+ (cif
+ (check-dest (if-test node) node)
+ (unless (eq (block-last (node-block node)) node)
+ (barf "IF not at block end: ~S" node)))
+ (cset
+ (check-dest (set-value node) node))
+ (bind
+ (check-function-reached (bind-lambda node) node))
+ (creturn
+ (check-function-reached (return-lambda node) node)
+ (check-dest (return-result node) node)
+ (unless (eq (block-last (node-block node)) node)
+ (barf "RETURN not at block end: ~S" node)))
+ (entry
+ (unless (member node (lambda-entries (node-home-lambda node)))
+ (barf "~S is not in ENTRIES for its home LAMBDA." node))
+ (dolist (exit (entry-exits node))
+ (unless (node-deleted exit)
+ (check-node-reached node))))
+ (exit
+ (let ((entry (exit-entry node))
+ (value (exit-value node)))
+ (cond (entry
+ (check-node-reached entry)
+ (unless (member node (entry-exits entry))
+ (barf "~S is not in its ENTRY's EXITS." node))
+ (when value
+ (check-dest value node)))
+ (t
+ (when value
+ (barf "~S has VALUE but no ENTRY." node)))))))
+
+ (values))
+\f
+;;;; IR2 consistency checking
+
+;;; Check for some kind of consistency in some Refs linked together by
+;;; TN-Ref-Across. VOP is the VOP that the references are in. Write-P is the
+;;; value of Write-P that should be present. Count is the minimum number of
+;;; operands expected. If More-P is true, then any larger number will also be
+;;; accepted. What is a string describing the kind of operand in error
+;;; messages.
+(defun check-tn-refs (refs vop write-p count more-p what)
+ (let ((vop-refs (vop-refs vop)))
+ (do ((ref refs (tn-ref-across ref))
+ (num 0 (1+ num)))
+ ((null ref)
+ (when (< num count)
+ (barf "There should be at least ~D ~A in ~S, but are only ~D."
+ count what vop num))
+ (when (and (not more-p) (> num count))
+ (barf "There should be ~D ~A in ~S, but are ~D."
+ count what vop num)))
+ (unless (eq (tn-ref-vop ref) vop)
+ (barf "VOP is ~S isn't ~S." ref vop))
+ (unless (eq (tn-ref-write-p ref) write-p)
+ (barf "The WRITE-P in ~S isn't ~S." vop write-p))
+ (unless (find-in #'tn-ref-next-ref ref vop-refs)
+ (barf "~S not found in REFS for ~S" ref vop))
+ (unless (find-in #'tn-ref-next ref
+ (if (tn-ref-write-p ref)
+ (tn-writes (tn-ref-tn ref))
+ (tn-reads (tn-ref-tn ref))))
+ (barf "~S not found in reads/writes for its TN" ref))
+
+ (let ((target (tn-ref-target ref)))
+ (when target
+ (unless (eq (tn-ref-write-p target) (not (tn-ref-write-p ref)))
+ (barf "The target for ~S isn't complementary WRITE-P." ref))
+ (unless (find-in #'tn-ref-next-ref target vop-refs)
+ (barf "The target for ~S isn't in REFS for ~S." ref vop)))))))
+
+;;; Verify the sanity of the VOP-Refs slot in VOP. This involves checking
+;;; that each referenced TN appears as an argument, result or temp, and also
+;;; basic checks for the plausibility of the specified ordering of the refs.
+(defun check-vop-refs (vop)
+ (declare (type vop vop))
+ (do ((ref (vop-refs vop) (tn-ref-next-ref ref)))
+ ((null ref))
+ (cond
+ ((find-in #'tn-ref-across ref (vop-args vop)))
+ ((find-in #'tn-ref-across ref (vop-results vop)))
+ ((not (eq (tn-ref-vop ref) vop))
+ (barf "VOP in ~S isn't ~S." ref vop))
+ ((find-in #'tn-ref-across ref (vop-temps vop)))
+ ((tn-ref-write-p ref)
+ (barf "stray ref that isn't a READ: ~S" ref))
+ (t
+ (let* ((tn (tn-ref-tn ref))
+ (temp (find-in #'tn-ref-across tn (vop-temps vop)
+ :key #'tn-ref-tn)))
+ (unless temp
+ (barf "stray ref with no corresponding temp write: ~S" ref))
+ (unless (find-in #'tn-ref-next-ref temp (tn-ref-next-ref ref))
+ (barf "Read is after write for temp ~S in refs of ~S."
+ tn vop))))))
+ (values))
+
+;;; Check the basic sanity of the VOP linkage, then call some other
+;;; functions to check on the TN-Refs. We grab some info out of the VOP-Info
+;;; to tell us what to expect.
+;;;
+;;; [### Check that operand type restrictions are met?]
+(defun check-ir2-block-consistency (2block)
+ (declare (type ir2-block 2block))
+ (do ((vop (ir2-block-start-vop 2block)
+ (vop-next vop))
+ (prev nil vop))
+ ((null vop)
+ (unless (eq prev (ir2-block-last-vop 2block))
+ (barf "The last VOP in ~S should be ~S." 2block prev)))
+ (unless (eq (vop-prev vop) prev)
+ (barf "PREV in ~S should be ~S." vop prev))
+
+ (unless (eq (vop-block vop) 2block)
+ (barf "BLOCK in ~S should be ~S." vop 2block))
+
+ (check-vop-refs vop)
+
+ (let* ((info (vop-info vop))
+ (atypes (template-arg-types info))
+ (rtypes (template-result-types info)))
+ (check-tn-refs (vop-args vop) vop nil
+ (count-if-not #'(lambda (x)
+ (and (consp x)
+ (eq (car x) :constant)))
+ atypes)
+ (template-more-args-type info) "args")
+ (check-tn-refs (vop-results vop) vop t
+ (if (eq rtypes :conditional) 0 (length rtypes))
+ (template-more-results-type info) "results")
+ (check-tn-refs (vop-temps vop) vop t 0 t "temps")
+ (unless (= (length (vop-codegen-info vop))
+ (template-info-arg-count info))
+ (barf "wrong number of codegen info args in ~S" vop))))
+ (values))
+
+;;; Check stuff about the IR2 representation of Component. This assumes the
+;;; sanity of the basic flow graph.
+;;;
+;;; [### Also grovel global TN data structures? Assume pack not
+;;; done yet? Have separate check-tn-consistency for pre-pack and
+;;; check-pack-consistency for post-pack?]
+(defun check-ir2-consistency (component)
+ (declare (type component component))
+ (do-ir2-blocks (block component)
+ (check-ir2-block-consistency block))
+ (values))
+\f
+;;;; lifetime analysis checking
+
+;;; Dump some info about how many TNs there, and what the conflicts data
+;;; structures are like.
+(defun pre-pack-tn-stats (component &optional (stream *error-output*))
+ (declare (type component component))
+ (let ((wired 0)
+ (global 0)
+ (local 0)
+ (confs 0)
+ (unused 0)
+ (const 0)
+ (temps 0)
+ (environment 0)
+ (comp 0))
+ (do-packed-tns (tn component)
+ (let ((reads (tn-reads tn))
+ (writes (tn-writes tn)))
+ (when (and reads writes
+ (not (tn-ref-next reads)) (not (tn-ref-next writes))
+ (eq (tn-ref-vop reads) (tn-ref-vop writes)))
+ (incf temps)))
+ (when (tn-offset tn)
+ (incf wired))
+ (unless (or (tn-reads tn) (tn-writes tn))
+ (incf unused))
+ (cond ((eq (tn-kind tn) :component)
+ (incf comp))
+ ((tn-global-conflicts tn)
+ (case (tn-kind tn)
+ ((:environment :debug-environment) (incf environment))
+ (t (incf global)))
+ (do ((conf (tn-global-conflicts tn)
+ (global-conflicts-tn-next conf)))
+ ((null conf))
+ (incf confs)))
+ (t
+ (incf local))))
+
+ (do ((tn (ir2-component-constant-tns (component-info component))
+ (tn-next tn)))
+ ((null tn))
+ (incf const))
+
+ (format stream
+ "~%TNs: ~D local, ~D temps, ~D constant, ~D env, ~D comp, ~D global.~@
+ Wired: ~D, Unused: ~D. ~D block~:P, ~D global conflict~:P.~%"
+ local temps const environment comp global wired unused
+ (ir2-block-count component)
+ confs))
+ (values))
+
+;;; If the entry in Local-TNs for TN in Block is :More, then do some checks
+;;; for the validity of the usage.
+(defun check-more-tn-entry (tn block)
+ (let* ((vop (ir2-block-start-vop block))
+ (info (vop-info vop)))
+ (macrolet ((frob (more-p ops)
+ `(and (,more-p info)
+ (find-in #'tn-ref-across tn (,ops vop)
+ :key #'tn-ref-tn))))
+ (unless (and (eq vop (ir2-block-last-vop block))
+ (or (frob template-more-args-type vop-args)
+ (frob template-more-results-type vop-results)))
+ (barf "strange :MORE LTN entry for ~S in ~S" tn block))))
+ (values))
+
+(defun check-tn-conflicts (component)
+ (do-packed-tns (tn component)
+ (unless (or (not (eq (tn-kind tn) :normal))
+ (tn-reads tn)
+ (tn-writes tn))
+ (barf "no references to ~S" tn))
+
+ (unless (tn-sc tn) (barf "~S has no SC." tn))
+
+ (let ((conf (tn-global-conflicts tn))
+ (kind (tn-kind tn)))
+ (cond
+ ((eq kind :component)
+ (unless (member tn (ir2-component-component-tns
+ (component-info component)))
+ (barf "~S not in Component-TNs for ~S" tn component)))
+ (conf
+ (do ((conf conf (global-conflicts-tn-next conf))
+ (prev nil conf))
+ ((null conf))
+ (unless (eq (global-conflicts-tn conf) tn)
+ (barf "TN in ~S should be ~S." conf tn))
+
+ (unless (eq (global-conflicts-kind conf) :live)
+ (let* ((block (global-conflicts-block conf))
+ (ltn (svref (ir2-block-local-tns block)
+ (global-conflicts-number conf))))
+ (cond ((eq ltn tn))
+ ((eq ltn :more) (check-more-tn-entry tn block))
+ (t
+ (barf "~S wrong in LTN map for ~S" conf tn)))))
+
+ (when prev
+ (unless (> (ir2-block-number (global-conflicts-block conf))
+ (ir2-block-number (global-conflicts-block prev)))
+ (barf "~s and ~s out of order" prev conf)))))
+ ((member (tn-kind tn) '(:constant :specified-save)))
+ (t
+ (let ((local (tn-local tn)))
+ (unless local
+ (barf "~S has no global conflicts, but isn't local either." tn))
+ (unless (eq (svref (ir2-block-local-tns local)
+ (tn-local-number tn))
+ tn)
+ (barf "~S wrong in LTN map" tn))
+ (do ((ref (tn-reads tn) (tn-ref-next ref)))
+ ((null ref))
+ (unless (eq (vop-block (tn-ref-vop ref)) local)
+ (barf "~S has references in blocks other than its LOCAL block."
+ tn)))
+ (do ((ref (tn-writes tn) (tn-ref-next ref)))
+ ((null ref))
+ (unless (eq (vop-block (tn-ref-vop ref)) local)
+ (barf "~S has references in blocks other than its LOCAL block."
+ tn))))))))
+ (values))
+
+(defun check-block-conflicts (component)
+ (do-ir2-blocks (block component)
+ (do ((conf (ir2-block-global-tns block)
+ (global-conflicts-next conf))
+ (prev nil conf))
+ ((null conf))
+ (when prev
+ (unless (> (tn-number (global-conflicts-tn conf))
+ (tn-number (global-conflicts-tn prev)))
+ (barf "~S and ~S out of order in ~S" prev conf block)))
+
+ (unless (find-in #'global-conflicts-tn-next
+ conf
+ (tn-global-conflicts
+ (global-conflicts-tn conf)))
+ (barf "~S missing from global conflicts of its TN" conf)))
+
+ (let ((map (ir2-block-local-tns block)))
+ (dotimes (i (ir2-block-local-tn-count block))
+ (let ((tn (svref map i)))
+ (unless (or (eq tn :more)
+ (null tn)
+ (tn-global-conflicts tn)
+ (eq (tn-local tn) block))
+ (barf "strange TN ~S in LTN map for ~S" tn block)))))))
+
+;;; All TNs live at the beginning of an environment must be passing
+;;; locations associated with that environment. We make an exception for wired
+;;; TNs in XEP functions, since we randomly reference wired TNs to access the
+;;; full call passing locations.
+(defun check-environment-lifetimes (component)
+ (dolist (fun (component-lambdas component))
+ (let* ((env (lambda-environment fun))
+ (2env (environment-info env))
+ (vars (lambda-vars fun))
+ (closure (ir2-environment-environment 2env))
+ (pc (ir2-environment-return-pc-pass 2env))
+ (fp (ir2-environment-old-fp 2env))
+ (2block (block-info
+ (node-block
+ (lambda-bind
+ (environment-function env))))))
+ (do ((conf (ir2-block-global-tns 2block)
+ (global-conflicts-next conf)))
+ ((null conf))
+ (let ((tn (global-conflicts-tn conf)))
+ (unless (or (eq (global-conflicts-kind conf) :write)
+ (eq tn pc)
+ (eq tn fp)
+ (and (external-entry-point-p fun)
+ (tn-offset tn))
+ (member (tn-kind tn) '(:environment :debug-environment))
+ (member tn vars :key #'leaf-info)
+ (member tn closure :key #'cdr))
+ (barf "strange TN live at head of ~S: ~S" env tn))))))
+ (values))
+
+;;; Check for some basic sanity in the TN conflict data structures, and also
+;;; check that no TNs are unexpectedly live at environment entry.
+(defun check-life-consistency (component)
+ (check-tn-conflicts component)
+ (check-block-conflicts component)
+ (check-environment-lifetimes component))
+\f
+;;;; pack consistency checking
+
+(defun check-pack-consistency (component)
+ (flet ((check (scs ops)
+ (do ((scs scs (cdr scs))
+ (op ops (tn-ref-across op)))
+ ((null scs))
+ (let ((load-tn (tn-ref-load-tn op)))
+ (unless (eq (svref (car scs)
+ (sc-number
+ (tn-sc
+ (or load-tn (tn-ref-tn op)))))
+ t)
+ (barf "operand restriction not satisfied: ~S" op))))))
+ (do-ir2-blocks (block component)
+ (do ((vop (ir2-block-last-vop block) (vop-prev vop)))
+ ((null vop))
+ (let ((info (vop-info vop)))
+ (check (vop-info-result-load-scs info) (vop-results vop))
+ (check (vop-info-arg-load-scs info) (vop-args vop))))))
+ (values))
+\f
+;;;; data structure dumping routines
+
+;;; When we print Continuations and TNs, we assign them small numeric IDs so
+;;; that we can get a handle on anonymous objects given a printout.
+(macrolet ((def-frob (counter vto vfrom fto ffrom)
+ `(progn
+ (defvar ,vto (make-hash-table :test 'eq))
+ (defvar ,vfrom (make-hash-table :test 'eql))
+ (proclaim '(hash-table ,vto ,vfrom))
+ (defvar ,counter 0)
+ (proclaim '(fixnum ,counter))
+
+ (defun ,fto (x)
+ (or (gethash x ,vto)
+ (let ((num (incf ,counter)))
+ (setf (gethash num ,vfrom) x)
+ (setf (gethash x ,vto) num))))
+
+ (defun ,ffrom (num)
+ (values (gethash num ,vfrom))))))
+ (def-frob *continuation-number* *continuation-numbers* *number-continuations* cont-num num-cont)
+ (def-frob *tn-id* *tn-ids* *id-tns* tn-id id-tn)
+ (def-frob *label-id* *id-labels* *label-ids* label-id id-label))
+
+;;; Print out a terse one-line description of a leaf.
+(defun print-leaf (leaf &optional (stream *standard-output*))
+ (declare (type leaf leaf) (type stream stream))
+ (etypecase leaf
+ (lambda-var (prin1 (leaf-name leaf) stream))
+ (constant (format stream "'~S" (constant-value leaf)))
+ (global-var
+ (format stream "~S {~A}" (leaf-name leaf) (global-var-kind leaf)))
+ (clambda
+ (format stream "lambda ~S ~S" (leaf-name leaf)
+ (mapcar #'leaf-name (lambda-vars leaf))))
+ (optional-dispatch
+ (format stream "optional-dispatch ~S" (leaf-name leaf)))
+ (functional
+ (assert (eq (functional-kind leaf) :top-level-xep))
+ (format stream "TL-XEP ~S"
+ (let ((info (leaf-info leaf)))
+ (etypecase info
+ (entry-info (entry-info-name info))
+ (byte-lambda-info :byte-compiled-entry)))))))
+
+;;; Attempt to find a block given some thing that has to do with it.
+(declaim (ftype (function (t) cblock) block-or-lose))
+(defun block-or-lose (thing)
+ (ctypecase thing
+ (cblock thing)
+ (ir2-block (ir2-block-block thing))
+ (vop (block-or-lose (vop-block thing)))
+ (tn-ref (block-or-lose (tn-ref-vop thing)))
+ (continuation (continuation-block thing))
+ (node (node-block thing))
+ (component (component-head thing))
+#| (cloop (loop-head thing))|#
+ (integer (continuation-block (num-cont thing)))
+ (functional (node-block (lambda-bind (main-entry thing))))
+ (null (error "Bad thing: ~S." thing))
+ (symbol (block-or-lose (gethash thing *free-functions*)))))
+
+;;; Print cN.
+(defun print-continuation (cont)
+ (declare (type continuation cont))
+ (format t " c~D" (cont-num cont))
+ (values))
+
+;;; Print out the nodes in Block in a format oriented toward representing
+;;; what the code does.
+(defun print-nodes (block)
+ (setq block (block-or-lose block))
+ (format t "~%block start c~D" (cont-num (block-start block)))
+
+ (let ((last (block-last block)))
+ (terpri)
+ (do ((cont (block-start block) (node-cont (continuation-next cont))))
+ (())
+ (let ((node (continuation-next cont)))
+ (format t "~3D: " (cont-num (node-cont node)))
+ (etypecase node
+ (ref (print-leaf (ref-leaf node)))
+ (basic-combination
+ (let ((kind (basic-combination-kind node)))
+ (format t "~(~A ~A~) c~D"
+ (if (function-info-p kind) "known" kind)
+ (type-of node)
+ (cont-num (basic-combination-fun node)))
+ (dolist (arg (basic-combination-args node))
+ (if arg
+ (print-continuation arg)
+ (format t " <none>")))))
+ (cset
+ (write-string "set ")
+ (print-leaf (set-var node))
+ (print-continuation (set-value node)))
+ (cif
+ (format t "if c~D" (cont-num (if-test node)))
+ (print-continuation (block-start (if-consequent node)))
+ (print-continuation (block-start (if-alternative node))))
+ (bind
+ (write-string "bind ")
+ (print-leaf (bind-lambda node)))
+ (creturn
+ (format t "return c~D " (cont-num (return-result node)))
+ (print-leaf (return-lambda node)))
+ (entry
+ (format t "entry ~S" (entry-exits node)))
+ (exit
+ (let ((value (exit-value node)))
+ (cond (value
+ (format t "exit c~D" (cont-num value)))
+ ((exit-entry node)
+ (format t "exit <no value>"))
+ (t
+ (format t "exit <degenerate>"))))))
+ (terpri)
+ (when (eq node last) (return)))))
+
+ (let ((succ (block-succ block)))
+ (format t "successors~{ c~D~}~%"
+ (mapcar #'(lambda (x) (cont-num (block-start x))) succ)))
+ (values))
+
+;;; Print a useful representation of a TN. If the TN has a leaf, then do a
+;;; Print-Leaf on that, otherwise print a generated ID.
+(defun print-tn (tn &optional (stream *standard-output*))
+ (declare (type tn tn))
+ (let ((leaf (tn-leaf tn)))
+ (cond (leaf
+ (print-leaf leaf stream)
+ (format stream "!~D" (tn-id tn)))
+ (t
+ (format stream "t~D" (tn-id tn))))
+ (when (and (tn-sc tn) (tn-offset tn))
+ (format stream "[~A]" (location-print-name tn)))))
+
+;;; Print the TN-Refs representing some operands to a VOP, linked by
+;;; TN-Ref-Across.
+(defun print-operands (refs)
+ (declare (type (or tn-ref null) refs))
+ (pprint-logical-block (*standard-output* nil)
+ (do ((ref refs (tn-ref-across ref)))
+ ((null ref))
+ (let ((tn (tn-ref-tn ref))
+ (ltn (tn-ref-load-tn ref)))
+ (cond ((not ltn)
+ (print-tn tn))
+ (t
+ (print-tn tn)
+ (princ (if (tn-ref-write-p ref) #\< #\>))
+ (print-tn ltn)))
+ (princ #\space)
+ (pprint-newline :fill)))))
+
+;;; Print the vop, putting args, info and results on separate lines, if
+;;; necessary.
+(defun print-vop (vop)
+ (pprint-logical-block (*standard-output* nil)
+ (princ (vop-info-name (vop-info vop)))
+ (princ #\space)
+ (pprint-indent :current 0)
+ (print-operands (vop-args vop))
+ (pprint-newline :linear)
+ (when (vop-codegen-info vop)
+ (princ (with-output-to-string (stream)
+ (let ((*print-level* 1)
+ (*print-length* 3))
+ (format stream "{~{~S~^ ~}} " (vop-codegen-info vop)))))
+ (pprint-newline :linear))
+ (when (vop-results vop)
+ (princ "=> ")
+ (print-operands (vop-results vop))))
+ (terpri))
+
+;;; Print the VOPs in the specified IR2 block.
+(defun print-ir2-block (block)
+ (declare (type ir2-block block))
+ (cond
+ ((eq (block-info (ir2-block-block block)) block)
+ (format t "~%IR2 block start c~D~%"
+ (cont-num (block-start (ir2-block-block block))))
+ (let ((label (ir2-block-%label block)))
+ (when label
+ (format t "L~D:~%" (label-id label)))))
+ (t
+ (format t "<overflow>~%")))
+
+ (do ((vop (ir2-block-start-vop block)
+ (vop-next vop))
+ (number 0 (1+ number)))
+ ((null vop))
+ (format t "~D: " number)
+ (print-vop vop)))
+
+;;; Like Print-Nodes, but dumps the IR2 representation of the code in Block.
+(defun print-vops (block)
+ (setq block (block-or-lose block))
+ (let ((2block (block-info block)))
+ (print-ir2-block 2block)
+ (do ((b (ir2-block-next 2block) (ir2-block-next b)))
+ ((not (eq (ir2-block-block b) block)))
+ (print-ir2-block b)))
+ (values))
+
+;;; Scan the IR2 blocks in emission order.
+(defun print-ir2-blocks (thing)
+ (do-ir2-blocks (block (block-component (block-or-lose thing)))
+ (print-ir2-block block))
+ (values))
+
+;;; Do a Print-Nodes on Block and all blocks reachable from it by successor
+;;; links.
+(defun print-blocks (block)
+ (setq block (block-or-lose block))
+ (do-blocks (block (block-component block) :both)
+ (setf (block-flag block) nil))
+ (labels ((walk (block)
+ (unless (block-flag block)
+ (setf (block-flag block) t)
+ (when (block-start block)
+ (print-nodes block))
+ (dolist (block (block-succ block))
+ (walk block)))))
+ (walk block))
+ (values))
+
+;;; Print all blocks in Block's component in DFO.
+(defun print-all-blocks (thing)
+ (do-blocks (block (block-component (block-or-lose thing)))
+ (handler-case (print-nodes block)
+ (error (condition)
+ (format t "~&~A...~%" condition))))
+ (values))
+
+(defvar *list-conflicts-table* (make-hash-table :test 'eq))
+
+;;; Add all Always-Live TNs in Block to the conflicts. TN is ignored when
+;;; it appears in the global conflicts.
+(defun add-always-live-tns (block tn)
+ (declare (type ir2-block block) (type tn tn))
+ (do ((conf (ir2-block-global-tns block)
+ (global-conflicts-next conf)))
+ ((null conf))
+ (when (eq (global-conflicts-kind conf) :live)
+ (let ((btn (global-conflicts-tn conf)))
+ (unless (eq btn tn)
+ (setf (gethash btn *list-conflicts-table*) t)))))
+ (values))
+
+;;; Add all local TNs in block to the conflicts.
+(defun add-all-local-tns (block)
+ (declare (type ir2-block block))
+ (let ((ltns (ir2-block-local-tns block)))
+ (dotimes (i (ir2-block-local-tn-count block))
+ (setf (gethash (svref ltns i) *list-conflicts-table*) t)))
+ (values))
+
+;;; Make a list out of all of the recorded conflicts.
+(defun listify-conflicts-table ()
+ (collect ((res))
+ (maphash #'(lambda (k v)
+ (declare (ignore v))
+ (when k
+ (res k)))
+ *list-conflicts-table*)
+ (clrhash *list-conflicts-table*)
+ (res)))
+
+(defun list-conflicts (tn)
+ #!+sb-doc
+ "Return a list of a the TNs that conflict with TN. Sort of, kind of. For
+ debugging use only. Probably doesn't work on :COMPONENT TNs."
+ (assert (member (tn-kind tn) '(:normal :environment :debug-environment)))
+ (let ((confs (tn-global-conflicts tn)))
+ (cond (confs
+ (clrhash *list-conflicts-table*)
+ (do ((conf confs (global-conflicts-tn-next conf)))
+ ((null conf))
+ (let ((block (global-conflicts-block conf)))
+ (add-always-live-tns block tn)
+ (if (eq (global-conflicts-kind conf) :live)
+ (add-all-local-tns block)
+ (let ((bconf (global-conflicts-conflicts conf))
+ (ltns (ir2-block-local-tns block)))
+ (dotimes (i (ir2-block-local-tn-count block))
+ (when (/= (sbit bconf i) 0)
+ (setf (gethash (svref ltns i) *list-conflicts-table*)
+ t)))))))
+ (listify-conflicts-table))
+ (t
+ (let* ((block (tn-local tn))
+ (ltns (ir2-block-local-tns block))
+ (confs (tn-local-conflicts tn)))
+ (collect ((res))
+ (dotimes (i (ir2-block-local-tn-count block))
+ (when (/= (sbit confs i) 0)
+ (let ((tn (svref ltns i)))
+ (when (and tn (not (eq tn :more))
+ (not (tn-global-conflicts tn)))
+ (res tn)))))
+ (do ((gtn (ir2-block-global-tns block)
+ (global-conflicts-next gtn)))
+ ((null gtn))
+ (when (or (eq (global-conflicts-kind gtn) :live)
+ (/= (sbit confs (global-conflicts-number gtn)) 0))
+ (res (global-conflicts-tn gtn))))
+ (res)))))))
+
+(defun nth-vop (thing n)
+ #!+sb-doc
+ "Return the Nth VOP in the IR2-Block pointed to by Thing."
+ (let ((block (block-info (block-or-lose thing))))
+ (do ((i 0 (1+ i))
+ (vop (ir2-block-start-vop block) (vop-next vop)))
+ ((= i n) vop))))
--- /dev/null
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!IMPL")
+
+(file-comment
+ "$Header$")
+
+(defmacro sb!xc:deftype (name arglist &body body)
+ #!+sb-doc
+ "Define a new type, with syntax like DEFMACRO."
+ (unless (symbolp name)
+ (error "type name not a symbol: ~S" name))
+ (let ((whole (gensym "WHOLE-")))
+ (multiple-value-bind (body local-decs doc)
+ (parse-defmacro arglist whole body name 'deftype :default-default ''*)
+ `(eval-when (:compile-toplevel :load-toplevel :execute)
+ (%compiler-deftype ',name
+ #'(lambda (,whole)
+ ,@local-decs
+ (block ,name ,body))
+ ,@(when doc `(,doc)))))))
--- /dev/null
+;;;; This file contains the code that finds the initial components and
+;;;; DFO, and recomputes the DFO if it is invalidated.
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!C")
+
+(file-comment
+ "$Header$")
+
+;;; Find the DFO for a component, deleting any unreached blocks and
+;;; merging any other components we reach. We repeatedly iterate over
+;;; the entry points, since new ones may show up during the walk.
+(declaim (ftype (function (component) (values)) find-dfo))
+(defun find-dfo (component)
+ (clear-flags component)
+ (setf (component-reanalyze component) nil)
+ (let ((head (component-head component)))
+ (do ()
+ ((dolist (ep (block-succ head) t)
+ (unless (block-flag ep)
+ (find-dfo-aux ep head component)
+ (return nil))))))
+
+ (let ((num 0))
+ (declare (fixnum num))
+ (do-blocks-backwards (block component :both)
+ (if (block-flag block)
+ (setf (block-number block) (incf num))
+ (setf (block-delete-p block) t)))
+ (do-blocks (block component)
+ (unless (block-flag block)
+ (delete-block block))))
+ (values))
+
+;;; Move all the code and entry points from Old to New. The code in
+;;; Old is inserted at the head of New. This is also called during let
+;;; conversion when we are about in insert the body of a let in a
+;;; different component. [A local call can be to a different component
+;;; before FIND-INITIAL-DFO runs.]
+(declaim (ftype (function (component component) (values)) join-components))
+(defun join-components (new old)
+ (assert (eq (component-kind new) (component-kind old)))
+ (let ((old-head (component-head old))
+ (old-tail (component-tail old))
+ (head (component-head new))
+ (tail (component-tail new)))
+
+ (do-blocks (block old)
+ (setf (block-flag block) nil)
+ (setf (block-component block) new))
+
+ (let ((old-next (block-next old-head))
+ (old-last (block-prev old-tail))
+ (next (block-next head)))
+ (unless (eq old-next old-tail)
+ (setf (block-next head) old-next)
+ (setf (block-prev old-next) head)
+
+ (setf (block-prev next) old-last)
+ (setf (block-next old-last) next))
+
+ (setf (block-next old-head) old-tail)
+ (setf (block-prev old-tail) old-head))
+
+ (setf (component-lambdas new)
+ (nconc (component-lambdas old) (component-lambdas new)))
+ (setf (component-lambdas old) ())
+ (setf (component-new-functions new)
+ (nconc (component-new-functions old) (component-new-functions new)))
+ (setf (component-new-functions old) ())
+
+ (dolist (xp (block-pred old-tail))
+ (unlink-blocks xp old-tail)
+ (link-blocks xp tail))
+ (dolist (ep (block-succ old-head))
+ (unlink-blocks old-head ep)
+ (link-blocks head ep)))
+ (values))
+
+;;; Do a depth-first walk from Block, inserting ourself in the DFO
+;;; after Head. If we somehow find ourselves in another component,
+;;; then we join that component to our component.
+(declaim (ftype (function (cblock cblock component) (values)) find-dfo-aux))
+(defun find-dfo-aux (block head component)
+ (unless (eq (block-component block) component)
+ (join-components component (block-component block)))
+
+ (unless (block-flag block)
+ (setf (block-flag block) t)
+ (dolist (succ (block-succ block))
+ (find-dfo-aux succ head component))
+
+ (remove-from-dfo block)
+ (add-to-dfo block head))
+ (values))
+
+;;; This function is called on each block by Find-Initial-DFO-Aux before it
+;;; walks the successors. It looks at the home lambda's bind block to see
+;;; whether that block is in some other component:
+;;; -- If the block is in the initial component, then do DFO-Walk-Call-Graph on
+;;; the home function to move it into component.
+;;; -- If the block is in some other component, join Component into it and
+;;; return that component.
+;;; -- If the home function is deleted, do nothing. Block must eventually be
+;;; discovered to be unreachable as well. This can happen when we have a
+;;; NLX into a function with no references. The escape function still has
+;;; refs (in the deleted function).
+;;;
+;;; This ensures that all the blocks in a given environment will be in the same
+;;; component, even when they might not seem reachable from the environment
+;;; entry. Consider the case of code that is only reachable from a non-local
+;;; exit.
+(defun walk-home-call-graph (block component)
+ (declare (type cblock block) (type component component))
+ (let ((home (block-home-lambda block)))
+ (if (eq (functional-kind home) :deleted)
+ component
+ (let* ((bind-block (node-block (lambda-bind home)))
+ (home-component (block-component bind-block)))
+ (cond ((eq (component-kind home-component) :initial)
+ (dfo-walk-call-graph home component))
+ ((eq home-component component)
+ component)
+ (t
+ (join-components home-component component)
+ home-component))))))
+
+;;; Somewhat similar to Find-DFO-Aux, except that it merges the current
+;;; component with any strange component, rather than the other way around.
+;;; This is more efficient in the common case where the current component
+;;; doesn't have much stuff in it.
+;;;
+;;; We return the current component as a result, allowing the caller to
+;;; detect when the old current component has been merged with another.
+;;;
+;;; We walk blocks in initial components as though they were already in the
+;;; current component, moving them to the current component in the process.
+;;; The blocks are inserted at the head of the current component.
+(defun find-initial-dfo-aux (block component)
+ (declare (type cblock block) (type component component))
+ (let ((this (block-component block)))
+ (cond
+ ((not (or (eq this component)
+ (eq (component-kind this) :initial)))
+ (join-components this component)
+ this)
+ ((block-flag block) component)
+ (t
+ (setf (block-flag block) t)
+ (let ((current (walk-home-call-graph block component)))
+ (dolist (succ (block-succ block))
+ (setq current (find-initial-dfo-aux succ current)))
+
+ (remove-from-dfo block)
+ (add-to-dfo block (component-head current))
+ current)))))
+
+;;; Return a list of all the home lambdas that reference Fun (may contain
+;;; duplications).
+;;;
+;;; References to functions which local call analysis could not (or were
+;;; chosen not) to local call convert will appear as references to XEP lambdas.
+;;; We can ignore references to XEPs that appear in :TOP-LEVEL components,
+;;; since environment analysis goes to special effort to allow closing over of
+;;; values from a separate top-level component. All other references must
+;;; cause components to be joined.
+;;;
+;;; References in deleted functions are also ignored, since this code will be
+;;; deleted eventually.
+(defun find-reference-functions (fun)
+ (collect ((res))
+ (dolist (ref (leaf-refs fun))
+ (let* ((home (node-home-lambda ref))
+ (home-kind (functional-kind home)))
+ (unless (or (and (eq home-kind :top-level)
+ (eq (functional-kind fun) :external))
+ (eq home-kind :deleted))
+ (res home))))
+ (res)))
+
+;;; Move the code for Fun and all functions called by it into Component. If
+;;; Fun is already in Component, then we just return that component.
+;;;
+;;; If the function is in an initial component, then we move its head and
+;;; tail to Component and add it to Component's lambdas. It is harmless to
+;;; move the tail (even though the return might be unreachable) because if the
+;;; return is unreachable it (and its successor link) will be deleted in the
+;;; post-deletion pass.
+;;;
+;;; We then do a Find-DFO-Aux starting at the head of Fun. If this
+;;; flow-graph walk encounters another component (which can only happen due to
+;;; a non-local exit), then we move code into that component instead. We then
+;;; recurse on all functions called from Fun, moving code into whichever
+;;; component the preceding call returned.
+;;;
+;;; If Fun is in the initial component, but the Block-Flag is set in the
+;;; bind block, then we just return Component, since we must have already
+;;; reached this function in the current walk (or the component would have been
+;;; changed).
+;;;
+;;; if the function is an XEP, then we also walk all functions that contain
+;;; references to the XEP. This is done so that environment analysis doesn't
+;;; need to cross component boundaries. This also ensures that conversion of a
+;;; full call to a local call won't result in a need to join components, since
+;;; the components will already be one.
+(defun dfo-walk-call-graph (fun component)
+ (declare (type clambda fun) (type component component))
+ (let* ((bind-block (node-block (lambda-bind fun)))
+ (this (block-component bind-block))
+ (return (lambda-return fun)))
+ (cond
+ ((eq this component) component)
+ ((not (eq (component-kind this) :initial))
+ (join-components this component)
+ this)
+ ((block-flag bind-block)
+ component)
+ (t
+ (push fun (component-lambdas component))
+ (setf (component-lambdas this)
+ (delete fun (component-lambdas this)))
+ (link-blocks (component-head component) bind-block)
+ (unlink-blocks (component-head this) bind-block)
+ (when return
+ (let ((return-block (node-block return)))
+ (link-blocks return-block (component-tail component))
+ (unlink-blocks return-block (component-tail this))))
+ (let ((calls (if (eq (functional-kind fun) :external)
+ (append (find-reference-functions fun)
+ (lambda-calls fun))
+ (lambda-calls fun))))
+ (do ((res (find-initial-dfo-aux bind-block component)
+ (dfo-walk-call-graph (first funs) res))
+ (funs calls (rest funs)))
+ ((null funs) res)
+ (declare (type component res))))))))
+
+;;; Return true if Fun is either an XEP or has EXITS to some of its ENTRIES.
+(defun has-xep-or-nlx (fun)
+ (declare (type clambda fun))
+ (or (eq (functional-kind fun) :external)
+ (let ((entries (lambda-entries fun)))
+ (and entries
+ (find-if #'entry-exits entries)))))
+
+;;; Compute the result of FIND-INITIAL-DFO given the list of all resulting
+;;; components. Components with a :TOP-LEVEL lambda, but no normal XEPs or
+;;; potential non-local exits are marked as :TOP-LEVEL. If there is a
+;;; :TOP-LEVEL lambda, and also a normal XEP, then we treat the component as
+;;; normal, but also return such components in a list as the third value.
+;;; Components with no entry of any sort are deleted.
+(defun find-top-level-components (components)
+ (declare (list components))
+ (collect ((real)
+ (top)
+ (real-top))
+ (dolist (com components)
+ (unless (eq (block-next (component-head com)) (component-tail com))
+ (let* ((funs (component-lambdas com))
+ (has-top (find :top-level funs :key #'functional-kind)))
+ (cond ((or (find-if #'has-xep-or-nlx funs)
+ (and has-top (rest funs)))
+ (setf (component-name com) (find-component-name com))
+ (real com)
+ (when has-top
+ (setf (component-kind com) :complex-top-level)
+ (real-top com)))
+ (has-top
+ (setf (component-kind com) :top-level)
+ (setf (component-name com) "top-level form")
+ (top com))
+ (t
+ (delete-component com))))))
+
+ (values (real) (top) (real-top))))
+
+;;; Given a list of top-level lambdas, return three lists of components
+;;; representing the actual component division:
+;;; 1. the non-top-level components,
+;;; 2. and the second is the top-level components, and
+;;; 3. Components in [1] that also have a top-level lambda.
+;;;
+;;; We assign the DFO for each component, and delete any unreachable blocks.
+;;; We assume that the Flags have already been cleared.
+;;;
+;;; We iterate over the lambdas in each initial component, trying to put
+;;; each function in its own component, but joining it to an existing component
+;;; if we find that there are references between them. Any code that is left
+;;; in an initial component must be unreachable, so we can delete it. Stray
+;;; links to the initial component tail (due NIL function terminated blocks)
+;;; are moved to the appropriate newc component tail.
+;;;
+;;; When we are done, we assign DFNs and call FIND-TOP-LEVEL-COMPONENTS to
+;;; pull out top-level code.
+(defun find-initial-dfo (lambdas)
+ (declare (list lambdas))
+ (collect ((components))
+ (let ((new (make-empty-component)))
+ (dolist (tll lambdas)
+ (let ((component (block-component (node-block (lambda-bind tll)))))
+ (dolist (fun (component-lambdas component))
+ (assert (member (functional-kind fun)
+ '(:optional :external :top-level nil :escape
+ :cleanup)))
+ (let ((res (dfo-walk-call-graph fun new)))
+ (when (eq res new)
+ (components new)
+ (setq new (make-empty-component)))))
+ (when (eq (component-kind component) :initial)
+ (assert (null (component-lambdas component)))
+ (let ((tail (component-tail component)))
+ (dolist (pred (block-pred tail))
+ (let ((pred-component (block-component pred)))
+ (unless (eq pred-component component)
+ (unlink-blocks pred tail)
+ (link-blocks pred (component-tail pred-component))))))
+ (delete-component component)))))
+
+ (dolist (com (components))
+ (let ((num 0))
+ (declare (fixnum num))
+ (do-blocks-backwards (block com :both)
+ (setf (block-number block) (incf num)))))
+
+ (find-top-level-components (components))))
+\f
+;;; Insert the code in LAMBDA at the end of RESULT-LAMBDA.
+(defun merge-1-tl-lambda (result-lambda lambda)
+ (declare (type clambda result-lambda lambda))
+
+ ;; Delete the lambda, and combine the lets and entries.
+ (setf (functional-kind lambda) :deleted)
+ (dolist (let (lambda-lets lambda))
+ (setf (lambda-home let) result-lambda)
+ (setf (lambda-environment let) (lambda-environment result-lambda))
+ (push let (lambda-lets result-lambda)))
+ (setf (lambda-entries result-lambda)
+ (nconc (lambda-entries result-lambda)
+ (lambda-entries lambda)))
+
+ (let* ((bind (lambda-bind lambda))
+ (bind-block (node-block bind))
+ (component (block-component bind-block))
+ (result-component
+ (block-component (node-block (lambda-bind result-lambda))))
+ (result-return-block (node-block (lambda-return result-lambda))))
+
+ ;; Move blocks into the new component, and move any nodes directly in
+ ;; the old lambda into the new one (lets implicitly moved by changing
+ ;; their home.)
+ (do-blocks (block component)
+ (do-nodes (node cont block)
+ (let ((lexenv (node-lexenv node)))
+ (when (eq (lexenv-lambda lexenv) lambda)
+ (setf (lexenv-lambda lexenv) result-lambda))))
+ (setf (block-component block) result-component))
+
+ ;; Splice the blocks into the new DFO, and unlink them from the old
+ ;; component head and tail. Non-return blocks that jump to the tail
+ ;; (NIL returning calls) are switched to go to the new tail.
+ (let* ((head (component-head component))
+ (first (block-next head))
+ (tail (component-tail component))
+ (last (block-prev tail))
+ (prev (block-prev result-return-block)))
+ (setf (block-next prev) first)
+ (setf (block-prev first) prev)
+ (setf (block-next last) result-return-block)
+ (setf (block-prev result-return-block) last)
+ (dolist (succ (block-succ head))
+ (unlink-blocks head succ))
+ (dolist (pred (block-pred tail))
+ (unlink-blocks pred tail)
+ (let ((last (block-last pred)))
+ (unless (return-p last)
+ (assert (basic-combination-p last))
+ (link-blocks pred (component-tail result-component))))))
+
+ (let ((lambdas (component-lambdas component)))
+ (assert (and (null (rest lambdas))
+ (eq (first lambdas) lambda))))
+
+ ;; Switch the end of the code from the return block to the start of
+ ;; the next chunk.
+ (dolist (pred (block-pred result-return-block))
+ (unlink-blocks pred result-return-block)
+ (link-blocks pred bind-block))
+ (unlink-node bind)
+
+ ;; If there is a return, then delete it (making the preceding node the
+ ;; last node) and link the block to the result return. There is always a
+ ;; preceding REF NIL node in top-level lambdas.
+ (let ((return (lambda-return lambda)))
+ (when return
+ (let ((return-block (node-block return))
+ (result (return-result return)))
+ (setf (block-last return-block) (continuation-use result))
+ (flush-dest result)
+ (delete-continuation result)
+ (link-blocks return-block result-return-block))))))
+
+;;; Given a non-empty list of top-level lambdas, smash them into a top-level
+;;; lambda and component, returning these as values. We use the first lambda
+;;; and its component, putting the other code in that component and deleting
+;;; the other lambdas.
+(defun merge-top-level-lambdas (lambdas)
+ (declare (cons lambdas))
+ (let* ((result-lambda (first lambdas))
+ (result-return (lambda-return result-lambda)))
+ (cond
+ (result-return
+
+ ;; Make sure the result's return node starts a block so that we can
+ ;; splice code in before it.
+ (let ((prev (node-prev
+ (continuation-use
+ (return-result result-return)))))
+ (when (continuation-use prev)
+ (node-ends-block (continuation-use prev)))
+ (do-uses (use prev)
+ (let ((new (make-continuation)))
+ (delete-continuation-use use)
+ (add-continuation-use use new))))
+
+ (dolist (lambda (rest lambdas))
+ (merge-1-tl-lambda result-lambda lambda)))
+ (t
+ (dolist (lambda (rest lambdas))
+ (setf (functional-entry-function lambda) nil)
+ (delete-component
+ (block-component
+ (node-block (lambda-bind lambda)))))))
+
+ (values (block-component (node-block (lambda-bind result-lambda)))
+ result-lambda)))
--- /dev/null
+;;;; machine-independent disassembler
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!DISASSEM")
+
+(file-comment
+ "$Header$")
+\f
+;;; types and defaults
+
+(defconstant label-column-width 7)
+
+(deftype text-width () '(integer 0 1000))
+(deftype alignment () '(integer 0 64))
+(deftype offset () '(signed-byte 24))
+(deftype address () '(unsigned-byte 32))
+(deftype length () '(unsigned-byte 24))
+(deftype column () '(integer 0 1000))
+
+(defconstant max-filtered-value-index 32)
+(deftype filtered-value-index ()
+ `(integer 0 ,max-filtered-value-index))
+(deftype filtered-value-vector ()
+ `(simple-array t (,max-filtered-value-index)))
+\f
+;;;; disassembly parameters
+
+;;; instructions
+(defvar *disassem-insts* (make-hash-table :test 'eq))
+(declaim (type hash-table *disassem-insts*))
+
+(defvar *disassem-inst-space* nil)
+(declaim (type (or null inst-space) *disassem-inst-space*))
+
+;;; minimum alignment of instructions, in bytes
+(defvar *disassem-inst-alignment-bytes* sb!vm:word-bytes)
+(declaim (type alignment *disassem-inst-alignment-bytes*))
+
+(defvar *disassem-location-column-width* 8)
+(declaim (type text-width *disassem-location-column-width*))
+
+;;; the width of the column in which instruction-names are printed. A
+;;; value of zero gives the effect of not aligning the arguments at
+;;; all.
+(defvar *disassem-opcode-column-width* 6)
+(declaim (type text-width *disassem-opcode-column-width*))
+
+(defvar *disassem-note-column* 45
+ #!+sb-doc
+ "The column in which end-of-line comments for notes are started.")
+
+;;; the old CMU CL code to set the CMU CL disassembly parameters
+#|
+(defmacro set-disassem-params (&rest args)
+ #!+sb-doc
+ "Specify global disassembler params. Keyword arguments include:
+
+ :INSTRUCTION-ALIGNMENT number
+ Minimum alignment of instructions, in bits.
+
+ :ADDRESS-SIZE number
+ Size of a machine address, in bits.
+
+ :OPCODE-COLUMN-WIDTH
+ Width of the column used for printing the opcode portion of the
+ instruction, or NIL to use the default."
+ (gen-preamble-form args))
+
+(defun gen-preamble-form (args)
+ #!+sb-doc
+ "Generate a form to specify global disassembler params. See the
+ documentation for SET-DISASSEM-PARAMS for more info."
+ (destructuring-bind
+ (&key instruction-alignment
+ address-size
+ (opcode-column-width nil opcode-column-width-p))
+ args
+ `(progn
+ (eval-when (:compile-toplevel :execute)
+ ;; these are not in the params because they only exist at compile time
+ (defparameter ,(format-table-name) (make-hash-table))
+ (defparameter ,(arg-type-table-name) nil)
+ (defparameter ,(function-cache-name) (make-function-cache)))
+ (let ((params
+ (or sb!c:*backend-disassem-params*
+ (setf sb!c:*backend-disassem-params* (make-params)))))
+ (declare (ignorable params))
+ ,(when instruction-alignment
+ `(setf (params-instruction-alignment params)
+ (bits-to-bytes ,instruction-alignment)))
+ ,(when address-size
+ `(setf (params-location-column-width params)
+ (* 2 ,address-size)))
+ ,(when opcode-column-width-p
+ `(setf (params-opcode-column-width params) ,opcode-column-width))
+ 'disassem-params))))
+|#
+\f
+;;;; cached functions
+
+(defstruct function-cache
+ (printers nil :type list)
+ (labellers nil :type list)
+ (prefilters nil :type list))
+
+(defvar *disassem-function-cache* (make-function-cache))
+(declaim (type function-cache *disassem-function-cache*))
+\f
+;;;; A DCHUNK contains the bits we look at to decode an
+;;;; instruction.
+;;;; I tried to keep this abstract so that if using integers > the machine
+;;;; word size conses too much, it can be changed to use bit-vectors or
+;;;; something.
+;;;;
+;;;; KLUDGE: It's not clear that using bit-vectors would be any more efficient.
+;;;; Perhaps the abstraction could go away. -- WHN 19991124
+
+#!-sb-fluid
+(declaim (inline dchunk-or dchunk-and dchunk-clear dchunk-not
+ dchunk-make-mask dchunk-make-field
+ sap-ref-dchunk
+ dchunk-extract
+ dchunk=
+ dchunk-count-bits))
+
+(defconstant dchunk-bits 32)
+
+(deftype dchunk ()
+ `(unsigned-byte ,dchunk-bits))
+(deftype dchunk-index ()
+ `(integer 0 ,dchunk-bits))
+
+(defconstant dchunk-zero 0)
+(defconstant dchunk-one #xFFFFFFFF)
+
+(defun dchunk-extract (from pos)
+ (declare (type dchunk from))
+ (the dchunk (ldb pos (the dchunk from))))
+
+(defmacro dchunk-copy (x)
+ `(the dchunk ,x))
+
+(defun dchunk-or (to from)
+ (declare (type dchunk to from))
+ (the dchunk (logior to from)))
+(defun dchunk-and (to from)
+ (declare (type dchunk to from))
+ (the dchunk (logand to from)))
+(defun dchunk-clear (to from)
+ (declare (type dchunk to from))
+ (the dchunk (logandc2 to from)))
+(defun dchunk-not (from)
+ (declare (type dchunk from))
+ (the dchunk (logand dchunk-one (lognot from))))
+
+(defmacro dchunk-andf (to from)
+ `(setf ,to (dchunk-and ,to ,from)))
+(defmacro dchunk-orf (to from)
+ `(setf ,to (dchunk-or ,to ,from)))
+(defmacro dchunk-clearf (to from)
+ `(setf ,to (dchunk-clear ,to ,from)))
+
+(defun dchunk-make-mask (pos)
+ (the dchunk (mask-field pos -1)))
+(defun dchunk-make-field (pos value)
+ (the dchunk (dpb value pos 0)))
+
+(defmacro make-dchunk (value)
+ `(the dchunk ,value))
+
+(defun sap-ref-dchunk (sap byte-offset byte-order)
+ (declare (type sb!sys:system-area-pointer sap)
+ (type offset byte-offset)
+ (optimize (speed 3) (safety 0)))
+ (the dchunk
+ (if (eq byte-order :big-endian)
+ (+ (ash (sb!sys:sap-ref-8 sap byte-offset) 24)
+ (ash (sb!sys:sap-ref-8 sap (+ 1 byte-offset)) 16)
+ (ash (sb!sys:sap-ref-8 sap (+ 2 byte-offset)) 8)
+ (sb!sys:sap-ref-8 sap (+ 3 byte-offset)))
+ (+ (sb!sys:sap-ref-8 sap byte-offset)
+ (ash (sb!sys:sap-ref-8 sap (+ 1 byte-offset)) 8)
+ (ash (sb!sys:sap-ref-8 sap (+ 2 byte-offset)) 16)
+ (ash (sb!sys:sap-ref-8 sap (+ 3 byte-offset)) 24)))))
+
+(defun dchunk-corrected-extract (from pos unit-bits byte-order)
+ (declare (type dchunk from))
+ (if (eq byte-order :big-endian)
+ (ldb (byte (byte-size pos)
+ (+ (byte-position pos) (- dchunk-bits unit-bits)))
+ (the dchunk from))
+ (ldb pos (the dchunk from))))
+
+(defmacro dchunk-insertf (place pos value)
+ `(setf ,place (the dchunk (dpb ,value ,pos (the dchunk,place)))))
+
+(defun dchunk= (x y)
+ (declare (type dchunk x y))
+ (= x y))
+(defmacro dchunk-zerop (x)
+ `(dchunk= ,x dchunk-zero))
+
+(defun dchunk-strict-superset-p (sup sub)
+ (and (zerop (logandc2 sub sup))
+ (not (zerop (logandc2 sup sub)))))
+
+(defun dchunk-count-bits (x)
+ (declare (type dchunk x))
+ (logcount x))
+\f
+(defstruct (instruction (:conc-name inst-)
+ (:constructor
+ make-instruction (name
+ format-name
+ print-name
+ length
+ mask id
+ printer
+ labeller prefilter control)))
+ (name nil :type (or symbol string))
+ (format-name nil :type (or symbol string))
+
+ (mask dchunk-zero :type dchunk) ; bits in the inst that are constant
+ (id dchunk-zero :type dchunk) ; value of those constant bits
+
+ (length 0 :type length) ; in bytes
+
+ (print-name nil :type symbol)
+
+ ;; disassembly functions
+ (prefilter nil :type (or null function))
+ (labeller nil :type (or null function))
+ (printer (required-argument) :type (or null function))
+ (control nil :type (or null function))
+
+ ;; instructions that are the same as this instruction but with more
+ ;; constraints
+ (specializers nil :type list))
+(def!method print-object ((inst instruction) stream)
+ (print-unreadable-object (inst stream :type t :identity t)
+ (format stream "~A(~A)" (inst-name inst) (inst-format-name inst))))
+\f
+;;;; an instruction space holds all known machine instructions in a form that
+;;;; can be easily searched
+
+(defstruct (inst-space (:conc-name ispace-))
+ (valid-mask dchunk-zero :type dchunk) ; applies to *children*
+ (choices nil :type list))
+(def!method print-object ((ispace inst-space) stream)
+ (print-unreadable-object (ispace stream :type t :identity t)))
+
+(defstruct (inst-space-choice (:conc-name ischoice-))
+ (common-id dchunk-zero :type dchunk) ; applies to *parent's* mask
+ (subspace (required-argument) :type (or inst-space instruction)))
+\f
+;;;; These are the kind of values we can compute for an argument, and
+;;;; how to compute them. The :checker functions make sure that a given
+;;;; argument is compatible with another argument for a given use.
+
+(defvar *arg-form-kinds* nil)
+
+(defstruct arg-form-kind
+ (names nil :type list)
+ (producer (required-argument) :type function)
+ (checker (required-argument) :type function))
+
+(defun arg-form-kind-or-lose (kind)
+ (or (getf *arg-form-kinds* kind)
+ (pd-error "unknown arg-form kind ~S" kind)))
+
+(defun find-arg-form-producer (kind)
+ (arg-form-kind-producer (arg-form-kind-or-lose kind)))
+(defun find-arg-form-checker (kind)
+ (arg-form-kind-checker (arg-form-kind-or-lose kind)))
+
+(defun canonicalize-arg-form-kind (kind)
+ (car (arg-form-kind-names (arg-form-kind-or-lose kind))))
+\f
+;;;; only used during compilation of the instructions for a backend
+;;;;
+;;;; FIXME: If only used then, isn't there some way we could do
+;;;; EVAL-WHEN tricks to keep this stuff from appearing in the target
+;;;; system?
+
+(defvar *disassem-inst-formats* (make-hash-table))
+(defvar *disassem-arg-types* nil)
+(defvar *disassem-function-cache* (make-function-cache))
+
+(defstruct (argument (:conc-name arg-))
+ (name nil :type symbol)
+ (fields nil :type list)
+
+ (value nil :type (or list integer))
+ (sign-extend-p nil :type (member t nil))
+
+ ;; position in a vector of prefiltered values
+ (position 0 :type fixnum)
+
+ ;; functions to use
+ (printer nil)
+ (prefilter nil)
+ (use-label nil))
+
+(defstruct (instruction-format (:conc-name format-))
+ (name nil)
+ (args nil :type list)
+
+ (length 0 :type length) ; in bytes
+
+ (default-printer nil :type list))
+\f
+;;; A FUNSTATE holds the state of any arguments used in a disassembly
+;;; function.
+(defstruct (funstate (:conc-name funstate-) (:constructor %make-funstate))
+ (args nil :type list)
+ (arg-temps nil :type list)) ; See below.
+
+(defun make-funstate (args)
+ ;; give the args a position
+ (let ((i 0))
+ (dolist (arg args)
+ (setf (arg-position arg) i)
+ (incf i)))
+ (%make-funstate :args args))
+
+(defun funstate-compatible-p (funstate args)
+ (every #'(lambda (this-arg-temps)
+ (let* ((old-arg (car this-arg-temps))
+ (new-arg (find (arg-name old-arg) args :key #'arg-name)))
+ (and new-arg
+ (every #'(lambda (this-kind-temps)
+ (funcall (find-arg-form-checker
+ (car this-kind-temps))
+ new-arg
+ old-arg))
+ (cdr this-arg-temps)))))
+ (funstate-arg-temps funstate)))
+
+(defun arg-or-lose (name funstate)
+ (let ((arg (find name (funstate-args funstate) :key #'arg-name)))
+ (when (null arg)
+ (pd-error "unknown argument ~S" name))
+ arg))
+\f
+;;;; Since we can't include some values in compiled output as they are
+;;;; (notably functions), we sometimes use a VALSRC structure to keep track of
+;;;; the source from which they were derived.
+
+(defstruct (valsrc (:constructor %make-valsrc))
+ (value nil)
+ (source nil))
+
+(defun make-valsrc (value source)
+ (cond ((equal value source)
+ source)
+ ((and (listp value) (eq (car value) 'function))
+ value)
+ (t
+ (%make-valsrc :value value :source source))))
+
+;;; machinery to provide more meaningful error messages during compilation
+(defvar *current-instruction-flavor* nil)
+(defun pd-error (fmt &rest args)
+ (if *current-instruction-flavor*
+ (error "~@<in printer-definition for ~S(~S): ~3I~:_~?~:>"
+ (car *current-instruction-flavor*)
+ (cdr *current-instruction-flavor*)
+ fmt args)
+ (apply #'error fmt args)))
+
+;;; FIXME:
+;;; 1. This should become a utility in SB!IMPL.
+;;; 2. Arrays are self-evaluating too.
+(defun self-evaluating-p (x)
+ (typecase x
+ (null t)
+ (keyword t)
+ (symbol (eq x t))
+ (cons nil)
+ (t t)))
+
+(defun maybe-quote (evalp form)
+ (if (or evalp (self-evaluating-p form)) form `',form))
+
+;;; detect things that obviously don't need wrapping, like variable-refs and
+;;; #'function
+(defun doesnt-need-wrapping-p (form)
+ (or (symbolp form)
+ (and (listp form)
+ (eq (car form) 'function)
+ (symbolp (cadr form)))))
+
+(defun make-wrapper (form arg-name funargs prefix)
+ (if (and (listp form)
+ (eq (car form) 'function))
+ ;; a function def
+ (let ((wrapper-name (symbolicate prefix "-" arg-name "-WRAPPER"))
+ (wrapper-args nil))
+ (dotimes (i (length funargs))
+ (push (gensym) wrapper-args))
+ (values `#',wrapper-name
+ `(defun ,wrapper-name ,wrapper-args
+ (funcall ,form ,@wrapper-args))))
+ ;; something else
+ (let ((wrapper-name (symbolicate "*" prefix "-" arg-name "-WRAPPER*")))
+ (values wrapper-name `(defparameter ,wrapper-name ,form)))))
+
+(defun filter-overrides (overrides evalp)
+ (mapcar #'(lambda (override)
+ (list* (car override) (cadr override)
+ (munge-fun-refs (cddr override) evalp)))
+ overrides))
+
+(defparameter *arg-function-params*
+ '((:printer . (value stream dstate))
+ (:use-label . (value dstate))
+ (:prefilter . (value dstate))))
+
+(defun munge-fun-refs (params evalp &optional wrap-defs-p (prefix ""))
+ (let ((params (copy-list params)))
+ (do ((tail params (cdr tail))
+ (wrapper-defs nil))
+ ((null tail)
+ (values params (nreverse wrapper-defs)))
+ (let ((fun-arg (assoc (car tail) *arg-function-params*)))
+ (when fun-arg
+ (let* ((fun-form (cadr tail))
+ (quoted-fun-form `',fun-form))
+ (when (and wrap-defs-p (not (doesnt-need-wrapping-p fun-form)))
+ (multiple-value-bind (access-form wrapper-def-form)
+ (make-wrapper fun-form (car fun-arg) (cdr fun-arg) prefix)
+ (setf quoted-fun-form `',access-form)
+ (push wrapper-def-form wrapper-defs)))
+ (if evalp
+ (setf (cadr tail)
+ `(make-valsrc ,fun-form ,quoted-fun-form))
+ (setf (cadr tail)
+ fun-form))))))))
+
+(defun gen-args-def-form (overrides format-form &optional (evalp t))
+ (let ((args-var (gensym)))
+ `(let ((,args-var (copy-list (format-args ,format-form))))
+ ,@(mapcar #'(lambda (override)
+ (update-args-form args-var
+ `',(car override)
+ (and (cdr override)
+ (cons :value (cdr override)))
+ evalp))
+ overrides)
+ ,args-var)))
+
+(defun gen-printer-def-forms-def-form (name def &optional (evalp t))
+ (destructuring-bind
+ (format-name
+ (&rest field-defs)
+ &optional (printer-form :default)
+ &key ((:print-name print-name-form) `',name) control)
+ def
+ (let ((format-var (gensym))
+ (field-defs (filter-overrides field-defs evalp)))
+ `(let* ((*current-instruction-flavor* ',(cons name format-name))
+ (,format-var (format-or-lose ',format-name))
+ (args ,(gen-args-def-form field-defs format-var evalp))
+ (funcache *disassem-function-cache*))
+ ;; FIXME: This should be SPEED 0 but can't be until we support
+ ;; byte compilation of components of the SBCL system.
+ ;;(declare (optimize (speed 0) (safety 0) (debug 0)))
+ (multiple-value-bind (printer-fun printer-defun)
+ (find-printer-fun ,(if (eq printer-form :default)
+ `(format-default-printer ,format-var)
+ (maybe-quote evalp printer-form))
+ args funcache)
+ (multiple-value-bind (labeller-fun labeller-defun)
+ (find-labeller-fun args funcache)
+ (multiple-value-bind (prefilter-fun prefilter-defun)
+ (find-prefilter-fun args funcache)
+ (multiple-value-bind (mask id)
+ (compute-mask-id args)
+ (values
+ `(make-instruction ',',name
+ ',',format-name
+ ,',print-name-form
+ ,(format-length ,format-var)
+ ,mask
+ ,id
+ ,(and printer-fun `#',printer-fun)
+ ,(and labeller-fun `#',labeller-fun)
+ ,(and prefilter-fun `#',prefilter-fun)
+ ,',control)
+ `(progn
+ ,@(and printer-defun (list printer-defun))
+ ,@(and labeller-defun (list labeller-defun))
+ ,@(and prefilter-defun (list prefilter-defun))))
+ ))))))))
+
+(defun update-args-form (var name-form descrip-forms evalp
+ &optional format-length-form)
+ `(setf ,var
+ ,(if evalp
+ `(modify-or-add-arg ,name-form
+ ,var
+ *disassem-arg-types*
+ ,@(and format-length-form
+ `(:format-length
+ ,format-length-form))
+ ,@descrip-forms)
+ `(apply #'modify-or-add-arg
+ ,name-form
+ ,var
+ *disassem-arg-types*
+ ,@(and format-length-form
+ `(:format-length ,format-length-form))
+ ',descrip-forms))))
+
+(defun format-or-lose (name)
+ (or (gethash name *disassem-inst-formats*)
+ (pd-error "unknown instruction format ~S" name)))
+
+;;; FIXME: needed only at build-the-system time, not in running system
+(defmacro define-instruction-format (header &rest fields)
+ #!+sb-doc
+ "DEFINE-INSTRUCTION-FORMAT (Name Length {Format-Key Value}*) Arg-Def*
+ Define an instruction format NAME for the disassembler's use. LENGTH is
+ the length of the format in bits.
+ Possible FORMAT-KEYs:
+
+ :INCLUDE other-format-name
+ Inherit all arguments and properties of the given format. Any
+ arguments defined in the current format definition will either modify
+ the copy of an existing argument (keeping in the same order with
+ respect to when pre-filter's are called), if it has the same name as
+ one, or be added to the end.
+ :DEFAULT-PRINTER printer-list
+ Use the given PRINTER-LIST as a format to print any instructions of
+ this format when they don't specify something else.
+
+ Each ARG-DEF defines one argument in the format, and is of the form
+ (Arg-Name {Arg-Key Value}*)
+
+ Possible ARG-KEYs (the values are evaluated unless otherwise specified):
+
+ :FIELDS byte-spec-list
+ The argument takes values from these fields in the instruction. If
+ the list is of length one, then the corresponding value is supplied by
+ itself; otherwise it is a list of the values. The list may be NIL.
+ :FIELD byte-spec
+ The same as :FIELDS (list byte-spec).
+
+ :VALUE value
+ If the argument only has one field, this is the value it should have,
+ otherwise it's a list of the values of the individual fields. This can
+ be overridden in an instruction-definition or a format definition
+ including this one by specifying another, or NIL to indicate that it's
+ variable.
+
+ :SIGN-EXTEND boolean
+ If non-NIL, the raw value of this argument is sign-extended,
+ immediately after being extracted from the instruction (before any
+ prefilters are run, for instance). If the argument has multiple
+ fields, they are all sign-extended.
+
+ :TYPE arg-type-name
+ Inherit any properties of the given argument-type.
+
+ :PREFILTER function
+ A function which is called (along with all other prefilters, in the
+ order that their arguments appear in the instruction-format) before
+ any printing is done, to filter the raw value. Any uses of READ-SUFFIX
+ must be done inside a prefilter.
+
+ :PRINTER function-string-or-vector
+ A function, string, or vector which is used to print this argument.
+
+ :USE-LABEL
+ If non-NIL, the value of this argument is used as an address, and if
+ that address occurs inside the disassembled code, it is replaced by a
+ label. If this is a function, it is called to filter the value."
+ (gen-format-def-form header fields))
+
+;;; FIXME: needed only at build-the-system time, not in running system
+(defun gen-format-def-form (header descrips &optional (evalp t))
+ #!+sb-doc
+ "Generate a form to define an instruction format. See
+ DEFINE-INSTRUCTION-FORMAT for more info."
+ (when (atom header)
+ (setf header (list header)))
+ (destructuring-bind (name length &key default-printer include) header
+ (let ((args-var (gensym))
+ (length-var (gensym))
+ (all-wrapper-defs nil)
+ (arg-count 0))
+ (collect ((arg-def-forms))
+ (dolist (descrip descrips)
+ (let ((name (pop descrip)))
+ (multiple-value-bind (descrip wrapper-defs)
+ (munge-fun-refs
+ descrip evalp t (format nil "~:@(~A~)-~D" name arg-count))
+ (arg-def-forms
+ (update-args-form args-var `',name descrip evalp length-var))
+ (setf all-wrapper-defs
+ (nconc wrapper-defs all-wrapper-defs)))
+ (incf arg-count)))
+ `(progn
+ ,@all-wrapper-defs
+ (eval-when (:compile-toplevel :execute)
+ (let ((,length-var ,length)
+ (,args-var
+ ,(and include
+ `(copy-list
+ (format-args
+ (format-or-lose ,include))))))
+ ,@(arg-def-forms)
+ (setf (gethash ',name *disassem-inst-formats*)
+ (make-instruction-format
+ :name ',name
+ :length (bits-to-bytes ,length-var)
+ :default-printer ,(maybe-quote evalp default-printer)
+ :args ,args-var))
+ (eval
+ `(progn
+ ,@(mapcar #'(lambda (arg)
+ (when (arg-fields arg)
+ (gen-arg-access-macro-def-form
+ arg ,args-var ',name)))
+ ,args-var))))))))))
+
+;;; FIXME: old CMU CL version, doesn't work with SBCL bootstrapping
+;;; scheme, kept around for reference until I get the new sbcl-0.6.4
+;;; version to work, then can be deleted
+#|
+(defun gen-format-def-form (header descrips &optional (evalp t))
+ #!+sb-doc
+ "Generate a form to define an instruction format. See
+ DEFINE-INSTRUCTION-FORMAT for more info."
+ (when (atom header)
+ (setf header (list header)))
+ (destructuring-bind (name length &key default-printer include) header
+ (let ((args-var (gensym))
+ (length-var (gensym))
+ (all-wrapper-defs nil)
+ (arg-count 0))
+ (collect ((arg-def-forms))
+ (dolist (descrip descrips)
+ (let ((name (pop descrip)))
+ (multiple-value-bind (descrip wrapper-defs)
+ (munge-fun-refs
+ descrip evalp t (format nil "~:@(~A~)-~D" name arg-count))
+ (arg-def-forms
+ (update-args-form args-var `',name descrip evalp length-var))
+ (setf all-wrapper-defs
+ (nconc wrapper-defs all-wrapper-defs)))
+ (incf arg-count)))
+ `(progn
+ ,@all-wrapper-defs
+ (eval-when (:compile-toplevel :execute)
+ (let ((,length-var ,length)
+ (,args-var
+ ,(and include
+ `(copy-list
+ (format-args
+ (format-or-lose ,include))))))
+ ,@(arg-def-forms)
+ (setf (gethash ',name *disassem-inst-formats*)
+ (make-instruction-format
+ :name ',name
+ :length (bits-to-bytes ,length-var)
+ :default-printer ,(maybe-quote evalp default-printer)
+ :args ,args-var))
+ (eval
+ `(progn
+ ,@(mapcar #'(lambda (arg)
+ (when (arg-fields arg)
+ (gen-arg-access-macro-def-form
+ arg ,args-var ',name)))
+ ,args-var))))))))))
+|#
+
+;;; FIXME: probably needed only at build-the-system time, not in
+;;; final target system
+(defun modify-or-add-arg (arg-name
+ args
+ type-table
+ &key
+ (value nil value-p)
+ (type nil type-p)
+ (prefilter nil prefilter-p)
+ (printer nil printer-p)
+ (sign-extend nil sign-extend-p)
+ (use-label nil use-label-p)
+ (field nil field-p)
+ (fields nil fields-p)
+ format-length)
+ (let* ((arg-pos (position arg-name args :key #'arg-name))
+ (arg
+ (if (null arg-pos)
+ (let ((arg (make-argument :name arg-name)))
+ (if (null args)
+ (setf args (list arg))
+ (push arg (cdr (last args))))
+ arg)
+ (setf (nth arg-pos args) (copy-argument (nth arg-pos args))))))
+ (when (and field-p (not fields-p))
+ (setf fields (list field))
+ (setf fields-p t))
+ (when type-p
+ (set-arg-from-type arg type type-table))
+ (when value-p
+ (setf (arg-value arg) value))
+ (when prefilter-p
+ (setf (arg-prefilter arg) prefilter))
+ (when sign-extend-p
+ (setf (arg-sign-extend-p arg) sign-extend))
+ (when printer-p
+ (setf (arg-printer arg) printer))
+ (when use-label-p
+ (setf (arg-use-label arg) use-label))
+ (when fields-p
+ (when (null format-length)
+ (error
+ "~@<in arg ~S: ~3I~:_~
+ can't specify fields except using DEFINE-INSTRUCTION-FORMAT~:>"
+ arg-name))
+ (setf (arg-fields arg)
+ (mapcar #'(lambda (bytespec)
+ (when (> (+ (byte-position bytespec)
+ (byte-size bytespec))
+ format-length)
+ (error "~@<in arg ~S: ~3I~:_~
+ The field ~S doesn't fit in an ~
+ instruction-format ~D bits wide.~:>"
+ arg-name
+ bytespec
+ format-length))
+ (correct-dchunk-bytespec-for-endianness
+ bytespec
+ format-length
+ sb!c:*backend-byte-order*))
+ fields)))
+ args))
+
+(defun gen-arg-access-macro-def-form (arg args format-name)
+ (let* ((funstate (make-funstate args))
+ (arg-val-form (arg-value-form arg funstate :adjusted))
+ (bindings (make-arg-temp-bindings funstate)))
+ `(sb!xc:defmacro ,(symbolicate format-name "-" (arg-name arg))
+ (chunk dstate)
+ `(let ((chunk ,chunk) (dstate ,dstate))
+ (declare (ignorable chunk dstate))
+ (flet ((local-filtered-value (offset)
+ (declare (type filtered-value-index offset))
+ (aref (dstate-filtered-values dstate) offset))
+ (local-extract (bytespec)
+ (dchunk-extract chunk bytespec)))
+ (declare (ignorable #'local-filtered-value #'local-extract)
+ (inline local-filtered-value local-extract))
+ (let* ,',bindings
+ ,',arg-val-form))))))
+
+(defun arg-value-form (arg funstate
+ &optional
+ (kind :final)
+ (allow-multiple-p (not (eq kind :numeric))))
+ (let ((forms (gen-arg-forms arg kind funstate)))
+ (when (and (not allow-multiple-p)
+ (listp forms)
+ (/= (length forms) 1))
+ (pd-error "~S must not have multiple values." arg))
+ (maybe-listify forms)))
+
+(defun correct-dchunk-bytespec-for-endianness (bs unit-bits byte-order)
+ (if (eq byte-order :big-endian)
+ (byte (byte-size bs) (+ (byte-position bs) (- dchunk-bits unit-bits)))
+ bs))
+
+(defun make-arg-temp-bindings (funstate)
+ ;; (Everything is in reverse order, so we just use PUSH, which
+ ;; results in everything being in the right order at the end.)
+ (let ((bindings nil))
+ (dolist (ats (funstate-arg-temps funstate))
+ (dolist (atk (cdr ats))
+ (cond ((null (cadr atk)))
+ ((atom (cadr atk))
+ (push `(,(cadr atk) ,(cddr atk)) bindings))
+ (t
+ (mapc #'(lambda (var form)
+ (push `(,var ,form) bindings))
+ (cadr atk)
+ (cddr atk))))))
+ bindings))
+
+(defun gen-arg-forms (arg kind funstate)
+ (multiple-value-bind (vars forms)
+ (get-arg-temp arg kind funstate)
+ (when (null forms)
+ (multiple-value-bind (new-forms single-value-p)
+ (funcall (find-arg-form-producer kind) arg funstate)
+ (setq forms new-forms)
+ (cond ((or single-value-p (atom forms))
+ (unless (symbolp forms)
+ (setq vars (gensym))))
+ ((every #'symbolp forms)
+ ;; just use the same as the forms
+ (setq vars nil))
+ (t
+ (setq vars nil)
+ (dotimes (i (length forms))
+ (push (gensym) vars))))
+ (set-arg-temps vars forms arg kind funstate)))
+ (or vars forms)))
+
+(defun maybe-listify (forms)
+ (cond ((atom forms)
+ forms)
+ ((/= (length forms) 1)
+ `(list ,@forms))
+ (t
+ (car forms))))
+\f
+(defun set-arg-from-type (arg type-name table)
+ (let ((type-arg (find type-name table :key #'arg-name)))
+ (when (null type-arg)
+ (pd-error "unknown argument type: ~S" type-name))
+ (setf (arg-printer arg) (arg-printer type-arg))
+ (setf (arg-prefilter arg) (arg-prefilter type-arg))
+ (setf (arg-sign-extend-p arg) (arg-sign-extend-p type-arg))
+ (setf (arg-use-label arg) (arg-use-label type-arg))))
+
+(defun get-arg-temp (arg kind funstate)
+ (let ((this-arg-temps (assoc arg (funstate-arg-temps funstate))))
+ (if this-arg-temps
+ (let ((this-kind-temps
+ (assoc (canonicalize-arg-form-kind kind)
+ (cdr this-arg-temps))))
+ (values (cadr this-kind-temps) (cddr this-kind-temps)))
+ (values nil nil))))
+
+(defun set-arg-temps (vars forms arg kind funstate)
+ (let ((this-arg-temps
+ (or (assoc arg (funstate-arg-temps funstate))
+ (car (push (cons arg nil) (funstate-arg-temps funstate)))))
+ (kind (canonicalize-arg-form-kind kind)))
+ (let ((this-kind-temps
+ (or (assoc kind (cdr this-arg-temps))
+ (car (push (cons kind nil) (cdr this-arg-temps))))))
+ (setf (cdr this-kind-temps) (cons vars forms)))))
+\f
+(defmacro define-argument-type (name &rest args)
+ #!+sb-doc
+ "DEFINE-ARGUMENT-TYPE Name {Key Value}*
+ Define a disassembler argument type NAME (which can then be referenced in
+ another argument definition using the :TYPE keyword argument). Keyword
+ arguments are:
+
+ :SIGN-EXTEND boolean
+ If non-NIL, the raw value of this argument is sign-extended.
+
+ :TYPE arg-type-name
+ Inherit any properties of given argument-type.
+
+ :PREFILTER function
+ A function which is called (along with all other prefilters, in the
+ order that their arguments appear in the instruction- format) before
+ any printing is done, to filter the raw value. Any uses of READ-SUFFIX
+ must be done inside a prefilter.
+
+ :PRINTER function-string-or-vector
+ A function, string, or vector which is used to print an argument of
+ this type.
+
+ :USE-LABEL
+ If non-NIL, the value of an argument of this type is used as an
+ address, and if that address occurs inside the disassembled code, it is
+ replaced by a label. If this is a function, it is called to filter the
+ value."
+ (gen-arg-type-def-form name args))
+
+(defun gen-arg-type-def-form (name args &optional (evalp t))
+ #!+sb-doc
+ "Generate a form to define a disassembler argument type. See
+ DEFINE-ARGUMENT-TYPE for more info."
+ (multiple-value-bind (args wrapper-defs)
+ (munge-fun-refs args evalp t name)
+ `(progn
+ ,@wrapper-defs
+ (eval-when (:compile-toplevel :execute)
+ ,(update-args-form '*disassem-arg-types* `',name args evalp))
+ ',name)))
+\f
+(defmacro def-arg-form-kind ((&rest names) &rest inits)
+ `(let ((kind (make-arg-form-kind :names ',names ,@inits)))
+ ,@(mapcar #'(lambda (name)
+ `(setf (getf *arg-form-kinds* ',name) kind))
+ names)))
+
+(def-arg-form-kind (:raw)
+ :producer #'(lambda (arg funstate)
+ (declare (ignore funstate))
+ (mapcar #'(lambda (bytespec)
+ `(the (unsigned-byte ,(byte-size bytespec))
+ (local-extract ',bytespec)))
+ (arg-fields arg)))
+ :checker #'(lambda (new-arg old-arg)
+ (equal (arg-fields new-arg)
+ (arg-fields old-arg))))
+
+(def-arg-form-kind (:sign-extended :unfiltered)
+ :producer #'(lambda (arg funstate)
+ (let ((raw-forms (gen-arg-forms arg :raw funstate)))
+ (if (and (arg-sign-extend-p arg) (listp raw-forms))
+ (mapcar #'(lambda (form field)
+ `(the (signed-byte ,(byte-size field))
+ (sign-extend ,form
+ ,(byte-size field))))
+ raw-forms
+ (arg-fields arg))
+ raw-forms)))
+ :checker #'(lambda (new-arg old-arg)
+ (equal (arg-sign-extend-p new-arg)
+ (arg-sign-extend-p old-arg))))
+
+(defun valsrc-equal (f1 f2)
+ (if (null f1)
+ (null f2)
+ (equal (value-or-source f1)
+ (value-or-source f2))))
+
+(def-arg-form-kind (:filtering)
+ :producer #'(lambda (arg funstate)
+ (let ((sign-extended-forms
+ (gen-arg-forms arg :sign-extended funstate))
+ (pf (arg-prefilter arg)))
+ (if pf
+ (values
+ `(local-filter ,(maybe-listify sign-extended-forms)
+ ,(source-form pf))
+ t)
+ (values sign-extended-forms nil))))
+ :checker #'(lambda (new-arg old-arg)
+ (valsrc-equal (arg-prefilter new-arg) (arg-prefilter old-arg))))
+
+(def-arg-form-kind (:filtered :unadjusted)
+ :producer #'(lambda (arg funstate)
+ (let ((pf (arg-prefilter arg)))
+ (if pf
+ (values `(local-filtered-value ,(arg-position arg)) t)
+ (gen-arg-forms arg :sign-extended funstate))))
+ :checker #'(lambda (new-arg old-arg)
+ (let ((pf1 (arg-prefilter new-arg))
+ (pf2 (arg-prefilter old-arg)))
+ (if (null pf1)
+ (null pf2)
+ (= (arg-position new-arg)
+ (arg-position old-arg))))))
+
+(def-arg-form-kind (:adjusted :numeric :unlabelled)
+ :producer #'(lambda (arg funstate)
+ (let ((filtered-forms (gen-arg-forms arg :filtered funstate))
+ (use-label (arg-use-label arg)))
+ (if (and use-label (not (eq use-label t)))
+ (list
+ `(adjust-label ,(maybe-listify filtered-forms)
+ ,(source-form use-label)))
+ filtered-forms)))
+ :checker #'(lambda (new-arg old-arg)
+ (valsrc-equal (arg-use-label new-arg) (arg-use-label old-arg))))
+
+(def-arg-form-kind (:labelled :final)
+ :producer #'(lambda (arg funstate)
+ (let ((adjusted-forms
+ (gen-arg-forms arg :adjusted funstate))
+ (use-label (arg-use-label arg)))
+ (if use-label
+ (let ((form (maybe-listify adjusted-forms)))
+ (if (and (not (eq use-label t))
+ (not (atom adjusted-forms))
+ (/= (Length adjusted-forms) 1))
+ (pd-error
+ "cannot label a multiple-field argument ~
+ unless using a function: ~S" arg)
+ `((lookup-label ,form))))
+ adjusted-forms)))
+ :checker #'(lambda (new-arg old-arg)
+ (let ((lf1 (arg-use-label new-arg))
+ (lf2 (arg-use-label old-arg)))
+ (if (null lf1) (null lf2) t))))
+
+;;; This is a bogus kind that's just used to ensure that printers are
+;;; compatible...
+(def-arg-form-kind (:printed)
+ :producer #'(lambda (&rest noise)
+ (declare (ignore noise))
+ (pd-error "bogus! can't use the :printed value of an arg!"))
+ :checker #'(lambda (new-arg old-arg)
+ (valsrc-equal (arg-printer new-arg) (arg-printer old-arg))))
+
+(defun remember-printer-use (arg funstate)
+ (set-arg-temps nil nil arg :printed funstate))
+\f
+;;; Returns a version of THING suitable for including in an evaluable
+;;; position in some form.
+(defun source-form (thing)
+ (cond ((valsrc-p thing)
+ (valsrc-source thing))
+ ((functionp thing)
+ (pd-error
+ "can't dump functions, so function ref form must be quoted: ~S"
+ thing))
+ ((self-evaluating-p thing)
+ thing)
+ ((eq (car thing) 'function)
+ thing)
+ (t
+ `',thing)))
+
+;;; Returns anything but a VALSRC structure.
+(defun value-or-source (thing)
+ (if (valsrc-p thing)
+ (valsrc-value thing)
+ thing))
+\f
+(defstruct (cached-function (:conc-name cached-fun-))
+ (funstate nil :type (or null funstate))
+ (constraint nil :type list)
+ (name nil :type (or null symbol)))
+
+(defun find-cached-function (cached-funs args constraint)
+ (dolist (cached-fun cached-funs nil)
+ (let ((funstate (cached-fun-funstate cached-fun)))
+ (when (and (equal constraint (cached-fun-constraint cached-fun))
+ (or (null funstate)
+ (funstate-compatible-p funstate args)))
+ (return cached-fun)))))
+
+(defmacro with-cached-function ((name-var funstate-var cache cache-slot
+ args &key constraint prefix)
+ &body defun-maker-forms)
+ (let ((cache-var (gensym))
+ (constraint-var (gensym)))
+ `(let* ((,constraint-var ,constraint)
+ (,cache-var (find-cached-function (,cache-slot ,cache)
+ ,args ,constraint-var)))
+ (cond (,cache-var
+ #+nil
+ (Format t "~&; Using cached function ~S~%"
+ (cached-fun-name ,cache-var))
+ (values (cached-fun-name ,cache-var) nil))
+ (t
+ (let* ((,name-var (gensym ,prefix))
+ (,funstate-var (make-funstate ,args))
+ (,cache-var
+ (make-cached-function :name ,name-var
+ :funstate ,funstate-var
+ :constraint ,constraint-var)))
+ #+nil
+ (format t "~&; Making new function ~S~%"
+ (cached-fun-name ,cache-var))
+ (values ,name-var
+ `(progn
+ ,(progn ,@defun-maker-forms)
+ (eval-when (:compile-toplevel :execute)
+ (push ,,cache-var
+ (,',cache-slot ',,cache)))))))))))
+\f
+(defun find-printer-fun (printer-source args cache)
+ (if (null printer-source)
+ (values nil nil)
+ (let ((printer-source (preprocess-printer printer-source args)))
+ (with-cached-function
+ (name funstate cache function-cache-printers args
+ :constraint printer-source
+ :prefix "PRINTER")
+ (make-printer-defun printer-source funstate name)))))
+\f
+;;;; Note that these things are compiled byte compiled to save space.
+
+(defun make-printer-defun (source funstate function-name)
+ (let ((printer-form (compile-printer-list source funstate))
+ (bindings (make-arg-temp-bindings funstate)))
+ `(defun ,function-name (chunk inst stream dstate)
+ (declare (type dchunk chunk)
+ (type instruction inst)
+ (type stream stream)
+ (type disassem-state dstate)
+ ;; FIXME: This should be SPEED 0 but can't be until we support
+ ;; byte compilation of components of the SBCL system.
+ #+nil (optimize (speed 0) (safety 0) (debug 0)))
+ (macrolet ((local-format-arg (arg fmt)
+ `(funcall (formatter ,fmt) stream ,arg)))
+ (flet ((local-tab-to-arg-column ()
+ (tab (dstate-argument-column dstate) stream))
+ (local-print-name ()
+ (princ (inst-print-name inst) stream))
+ (local-write-char (ch)
+ (write-char ch stream))
+ (local-princ (thing)
+ (princ thing stream))
+ (local-princ16 (thing)
+ (princ16 thing stream))
+ (local-call-arg-printer (arg printer)
+ (funcall printer arg stream dstate))
+ (local-call-global-printer (fun)
+ (funcall fun chunk inst stream dstate))
+ (local-filtered-value (offset)
+ (declare (type filtered-value-index offset))
+ (aref (dstate-filtered-values dstate) offset))
+ (local-extract (bytespec)
+ (dchunk-extract chunk bytespec))
+ (lookup-label (lab)
+ (or (gethash lab (dstate-label-hash dstate))
+ lab))
+ (adjust-label (val adjust-fun)
+ (funcall adjust-fun val dstate)))
+ (declare (ignorable #'local-tab-to-arg-column
+ #'local-print-name
+ #'local-princ #'local-princ16
+ #'local-write-char
+ #'local-call-arg-printer
+ #'local-call-global-printer
+ #'local-extract
+ #'local-filtered-value
+ #'lookup-label #'adjust-label)
+ (inline local-tab-to-arg-column
+ local-princ local-princ16
+ local-call-arg-printer local-call-global-printer
+ local-filtered-value local-extract
+ lookup-label adjust-label))
+ (let* ,bindings
+ ,@printer-form))))))
+\f
+(defun preprocess-test (subj form args)
+ (multiple-value-bind (subj test)
+ (if (and (consp form) (symbolp (car form)) (not (keywordp (car form))))
+ (values (car form) (cdr form))
+ (values subj form))
+ (let ((key (if (consp test) (car test) test))
+ (body (if (consp test) (cdr test) nil)))
+ (case key
+ (:constant
+ (if (null body)
+ ;; If no supplied constant values, just any constant is ok, just
+ ;; see whether there's some constant value in the arg.
+ (not
+ (null
+ (arg-value
+ (or (find subj args :key #'arg-name)
+ (pd-error "unknown argument ~S" subj)))))
+ ;; Otherwise, defer to run-time.
+ form))
+ ((:or :and :not)
+ (sharing-cons
+ form
+ subj
+ (sharing-cons
+ test
+ key
+ (sharing-mapcar
+ #'(lambda (sub-test)
+ (preprocess-test subj sub-test args))
+ body))))
+ (t form)))))
+
+(defun preprocess-conditionals (printer args)
+ (if (atom printer)
+ printer
+ (case (car printer)
+ (:unless
+ (preprocess-conditionals
+ `(:cond ((:not ,(nth 1 printer)) ,@(nthcdr 2 printer)))
+ args))
+ (:when
+ (preprocess-conditionals `(:cond (,(cdr printer))) args))
+ (:if
+ (preprocess-conditionals
+ `(:cond (,(nth 1 printer) ,(nth 2 printer))
+ (t ,(nth 3 printer)))
+ args))
+ (:cond
+ (sharing-cons
+ printer
+ :cond
+ (sharing-mapcar
+ #'(lambda (clause)
+ (let ((filtered-body
+ (sharing-mapcar
+ #'(lambda (sub-printer)
+ (preprocess-conditionals sub-printer args))
+ (cdr clause))))
+ (sharing-cons
+ clause
+ (preprocess-test (find-first-field-name filtered-body)
+ (car clause)
+ args)
+ filtered-body)))
+ (cdr printer))))
+ (quote printer)
+ (t
+ (sharing-mapcar
+ #'(lambda (sub-printer)
+ (preprocess-conditionals sub-printer args))
+ printer)))))
+
+(defun preprocess-printer (printer args)
+ #!+sb-doc
+ "Returns a version of the disassembly-template PRINTER with compile-time
+ tests (e.g. :constant without a value), and any :CHOOSE operators resolved
+ properly for the args ARGS. (:CHOOSE Sub*) simply returns the first Sub in
+ which every field reference refers to a valid arg."
+ (preprocess-conditionals (preprocess-chooses printer args) args))
+\f
+(defun find-first-field-name (tree)
+ #!+sb-doc
+ "Returns the first non-keyword symbol in a depth-first search of TREE."
+ (cond ((null tree)
+ nil)
+ ((and (symbolp tree) (not (keywordp tree)))
+ tree)
+ ((atom tree)
+ nil)
+ ((eq (car tree) 'quote)
+ nil)
+ (t
+ (or (find-first-field-name (car tree))
+ (find-first-field-name (cdr tree))))))
+
+(defun preprocess-chooses (printer args)
+ (cond ((atom printer)
+ printer)
+ ((eq (car printer) :choose)
+ (pick-printer-choice (cdr printer) args))
+ (t
+ (sharing-mapcar #'(lambda (sub) (preprocess-chooses sub args))
+ printer))))
+\f
+;;;; some simple functions that help avoid consing when we're just
+;;;; recursively filtering things that usually don't change
+
+(defun sharing-cons (old-cons car cdr)
+ #!+sb-doc
+ "If CAR is eq to the car of OLD-CONS and CDR is eq to the CDR, return
+ OLD-CONS, otherwise return (cons CAR CDR)."
+ (if (and (eq car (car old-cons)) (eq cdr (cdr old-cons)))
+ old-cons
+ (cons car cdr)))
+
+(defun sharing-mapcar (fun list)
+ #!+sb-doc
+ "A simple (one list arg) mapcar that avoids consing up a new list
+ as long as the results of calling FUN on the elements of LIST are
+ eq to the original."
+ (and list
+ (sharing-cons list
+ (funcall fun (car list))
+ (sharing-mapcar fun (cdr list)))))
+\f
+(defun all-arg-refs-relevant-p (printer args)
+ (cond ((or (null printer) (keywordp printer) (eq printer t))
+ t)
+ ((symbolp printer)
+ (find printer args :key #'arg-name))
+ ((listp printer)
+ (every #'(lambda (x) (all-arg-refs-relevant-p x args))
+ printer))
+ (t t)))
+
+(defun pick-printer-choice (choices args)
+ (dolist (choice choices
+ (pd-error "no suitable choice found in ~S" choices))
+ (when (all-arg-refs-relevant-p choice args)
+ (return choice))))
+
+(defun compile-printer-list (sources funstate)
+ (unless (null sources)
+ ;; Coalesce adjacent symbols/strings, and convert to strings if possible,
+ ;; since they require less consing to write.
+ (do ((el (car sources) (car sources))
+ (names nil (cons (strip-quote el) names)))
+ ((not (string-or-qsym-p el))
+ (when names
+ ;; concatenate adjacent strings and symbols
+ (let ((string
+ (apply #'concatenate
+ 'string
+ (mapcar #'string (nreverse names)))))
+ (push (if (some #'alpha-char-p string)
+ `',(make-symbol string) ; Preserve casifying output.
+ string)
+ sources))))
+ (pop sources))
+ (cons (compile-printer-body (car sources) funstate)
+ (compile-printer-list (cdr sources) funstate))))
+
+(defun compile-printer-body (source funstate)
+ (cond ((null source)
+ nil)
+ ((eq source :name)
+ `(local-print-name))
+ ((eq source :tab)
+ `(local-tab-to-arg-column))
+ ((keywordp source)
+ (pd-error "unknown printer element: ~S" source))
+ ((symbolp source)
+ (compile-print source funstate))
+ ((atom source)
+ `(local-princ ',source))
+ ((eq (car source) :using)
+ (unless (or (stringp (cadr source))
+ (and (listp (cadr source))
+ (eq (caadr source) 'function)))
+ (pd-error "The first arg to :USING must be a string or #'function."))
+ (compile-print (caddr source) funstate
+ (cons (eval (cadr source)) (cadr source))))
+ ((eq (car source) :plus-integer)
+ ;; prints the given field proceed with a + or a -
+ (let ((form
+ (arg-value-form (arg-or-lose (cadr source) funstate)
+ funstate
+ :numeric)))
+ `(progn
+ (when (>= ,form 0)
+ (local-write-char #\+))
+ (local-princ ,form))))
+ ((eq (car source) 'quote)
+ `(local-princ ,source))
+ ((eq (car source) 'function)
+ `(local-call-global-printer ,source))
+ ((eq (car source) :cond)
+ `(cond ,@(mapcar #'(lambda (clause)
+ `(,(compile-test (find-first-field-name
+ (cdr clause))
+ (car clause)
+ funstate)
+ ,@(compile-printer-list (cdr clause)
+ funstate)))
+ (cdr source))))
+ ;; :IF, :UNLESS, and :WHEN are replaced by :COND during preprocessing
+ (t
+ `(progn ,@(compile-printer-list source funstate)))))
+
+(defun compile-print (arg-name funstate &optional printer)
+ (let* ((arg (arg-or-lose arg-name funstate))
+ (printer (or printer (arg-printer arg)))
+ (printer-val (value-or-source printer))
+ (printer-src (source-form printer)))
+ (remember-printer-use arg funstate)
+ (cond ((stringp printer-val)
+ `(local-format-arg ,(arg-value-form arg funstate) ,printer-val))
+ ((vectorp printer-val)
+ `(local-princ
+ (aref ,printer-src
+ ,(arg-value-form arg funstate :numeric))))
+ ((or (functionp printer-val)
+ (and (consp printer-val) (eq (car printer-val) 'function)))
+ `(local-call-arg-printer ,(arg-value-form arg funstate)
+ ,printer-src))
+ ((or (null printer-val) (eq printer-val t))
+ `(,(if (arg-use-label arg) 'local-princ16 'local-princ)
+ ,(arg-value-form arg funstate)))
+ (t
+ (pd-error "illegal printer: ~S" printer-src)))))
+
+(defun string-or-qsym-p (thing)
+ (or (stringp thing)
+ (and (consp thing)
+ (eq (car thing) 'quote)
+ (or (stringp (cadr thing))
+ (symbolp (cadr thing))))))
+
+(defun strip-quote (thing)
+ (if (and (consp thing) (eq (car thing) 'quote))
+ (cadr thing)
+ thing))
+\f
+(defun compare-fields-form (val-form-1 val-form-2)
+ (flet ((listify-fields (fields)
+ (cond ((symbolp fields) fields)
+ ((every #'constantp fields) `',fields)
+ (t `(list ,@fields)))))
+ (cond ((or (symbolp val-form-1) (symbolp val-form-2))
+ `(equal ,(listify-fields val-form-1)
+ ,(listify-fields val-form-2)))
+ (t
+ `(and ,@(mapcar #'(lambda (v1 v2) `(= ,v1 ,v2))
+ val-form-1 val-form-2))))))
+
+(defun compile-test (subj test funstate)
+ (when (and (consp test) (symbolp (car test)) (not (keywordp (car test))))
+ (setf subj (car test)
+ test (cdr test)))
+ (let ((key (if (consp test) (car test) test))
+ (body (if (consp test) (cdr test) nil)))
+ (cond ((null key)
+ nil)
+ ((eq key t)
+ t)
+ ((eq key :constant)
+ (let* ((arg (arg-or-lose subj funstate))
+ (fields (arg-fields arg))
+ (consts body))
+ (when (not (= (length fields) (length consts)))
+ (pd-error "The number of constants doesn't match number of ~
+ fields in: (~S :constant~{ ~S~})"
+ subj body))
+ (compare-fields-form (gen-arg-forms arg :numeric funstate)
+ consts)))
+ ((eq key :positive)
+ `(> ,(arg-value-form (arg-or-lose subj funstate) funstate :numeric)
+ 0))
+ ((eq key :negative)
+ `(< ,(arg-value-form (arg-or-lose subj funstate) funstate :numeric)
+ 0))
+ ((eq key :same-as)
+ (let ((arg1 (arg-or-lose subj funstate))
+ (arg2 (arg-or-lose (car body) funstate)))
+ (unless (and (= (length (arg-fields arg1))
+ (length (arg-fields arg2)))
+ (every #'(lambda (bs1 bs2)
+ (= (byte-size bs1) (byte-size bs2)))
+ (arg-fields arg1)
+ (arg-fields arg2)))
+ (pd-error "can't compare differently sized fields: ~
+ (~S :same-as ~S)" subj (car body)))
+ (compare-fields-form (gen-arg-forms arg1 :numeric funstate)
+ (gen-arg-forms arg2 :numeric funstate))))
+ ((eq key :or)
+ `(or ,@(mapcar #'(lambda (sub) (compile-test subj sub funstate))
+ body)))
+ ((eq key :and)
+ `(and ,@(mapcar #'(lambda (sub) (compile-test subj sub funstate))
+ body)))
+ ((eq key :not)
+ `(not ,(compile-test subj (car body) funstate)))
+ ((and (consp key) (null body))
+ (compile-test subj key funstate))
+ (t
+ (pd-error "bogus test-form: ~S" test)))))
+\f
+(defun find-labeller-fun (args cache)
+ (let ((labelled-fields
+ (mapcar #'arg-name (remove-if-not #'arg-use-label args))))
+ (if (null labelled-fields)
+ (values nil nil)
+ (with-cached-function
+ (name funstate cache function-cache-labellers args
+ :prefix "LABELLER"
+ :constraint labelled-fields)
+ (let ((labels-form 'labels))
+ (dolist (arg args)
+ (when (arg-use-label arg)
+ (setf labels-form
+ `(let ((labels ,labels-form)
+ (addr
+ ,(arg-value-form arg funstate :adjusted nil)))
+ (if (assoc addr labels :test #'eq)
+ labels
+ (cons (cons addr nil) labels))))))
+ `(defun ,name (chunk labels dstate)
+ (declare (type list labels)
+ (type dchunk chunk)
+ (type disassem-state dstate)
+ ;; FIXME: This should be SPEED 0 but can't be
+ ;; until we support byte compilation of
+ ;; components of the SBCL system.
+ #+nil (optimize (speed 0) (safety 0) (debug 0)))
+ (flet ((local-filtered-value (offset)
+ (declare (type filtered-value-index offset))
+ (aref (dstate-filtered-values dstate) offset))
+ (local-extract (bytespec)
+ (dchunk-extract chunk bytespec))
+ (adjust-label (val adjust-fun)
+ (funcall adjust-fun val dstate)))
+ (declare (ignorable #'local-filtered-value #'local-extract
+ #'adjust-label)
+ (inline local-filtered-value local-extract
+ adjust-label))
+ (let* ,(make-arg-temp-bindings funstate)
+ ,labels-form))))))))
+
+(defun find-prefilter-fun (args cache)
+ (let ((filtered-args
+ (mapcar #'arg-name (remove-if-not #'arg-prefilter args))))
+ (if (null filtered-args)
+ (values nil nil)
+ (with-cached-function
+ (name funstate cache function-cache-prefilters args
+ :prefix "PREFILTER"
+ :constraint filtered-args)
+ (collect ((forms))
+ (dolist (arg args)
+ (let ((pf (arg-prefilter arg)))
+ (when pf
+ (forms
+ `(setf (local-filtered-value ,(arg-position arg))
+ ,(maybe-listify
+ (gen-arg-forms arg :filtering funstate)))))
+ ))
+ `(defun ,name (chunk dstate)
+ (declare (type dchunk chunk)
+ (type disassem-state dstate)
+ ;; FIXME: This should be SPEED 0 but can't be
+ ;; until we support byte compilation of
+ ;; components of the SBCL system.
+ #+nil (optimize (speed 0) (safety 0) (debug 0)))
+ (flet (((setf local-filtered-value) (value offset)
+ (declare (type filtered-value-index offset))
+ (setf (aref (dstate-filtered-values dstate) offset)
+ value))
+ (local-filter (value filter)
+ (funcall filter value dstate))
+ (local-extract (bytespec)
+ (dchunk-extract chunk bytespec)))
+ (declare (ignorable #'local-filter #'local-extract)
+ (inline (setf local-filtered-value)
+ local-filter local-extract))
+ ;; Use them for side-effects only.
+ (let* ,(make-arg-temp-bindings funstate)
+ ,@(forms)))))))))
+\f
+(defun compute-mask-id (args)
+ (let ((mask dchunk-zero)
+ (id dchunk-zero))
+ (dolist (arg args (values mask id))
+ (let ((av (arg-value arg)))
+ (when av
+ (do ((fields (arg-fields arg) (cdr fields))
+ (values (if (atom av) (list av) av) (cdr values)))
+ ((null fields))
+ (let ((field-mask (dchunk-make-mask (car fields))))
+ (when (/= (dchunk-and mask field-mask) dchunk-zero)
+ (pd-error "The field ~S in arg ~S overlaps some other field."
+ (car fields)
+ (arg-name arg)))
+ (dchunk-insertf id (car fields) (car values))
+ (dchunk-orf mask field-mask))))))))
+
+(defun install-inst-flavors (name flavors)
+ (setf (gethash name *disassem-insts*)
+ flavors))
+\f
+#!-sb-fluid (declaim (inline bytes-to-bits))
+(declaim (maybe-inline sign-extend aligned-p align tab tab0))
+
+(defun bytes-to-bits (bytes)
+ (declare (type length bytes))
+ (* bytes sb!vm:byte-bits))
+
+(defun bits-to-bytes (bits)
+ (declare (type length bits))
+ (multiple-value-bind (bytes rbits)
+ (truncate bits sb!vm:byte-bits)
+ (when (not (zerop rbits))
+ (error "~D bits is not a byte-multiple." bits))
+ bytes))
+
+(defun sign-extend (int size)
+ (declare (type integer int)
+ (type (integer 0 128) size))
+ (if (logbitp (1- size) int)
+ (dpb int (byte size 0) -1)
+ int))
+
+(defun aligned-p (address size)
+ #!+sb-doc
+ "Returns non-NIL if ADDRESS is aligned on a SIZE byte boundary."
+ (declare (type address address)
+ (type alignment size))
+ (zerop (logand (1- size) address)))
+
+(defun align (address size)
+ #!+sb-doc
+ "Return ADDRESS aligned *upward* to a SIZE byte boundary."
+ (declare (type address address)
+ (type alignment size))
+ (logandc1 (1- size) (+ (1- size) address)))
+
+(defun tab (column stream)
+ (funcall (formatter "~V,1t") stream column)
+ nil)
+(defun tab0 (column stream)
+ (funcall (formatter "~V,0t") stream column)
+ nil)
+
+(defun princ16 (value stream)
+ (write value :stream stream :radix t :base 16 :escape nil))
+\f
+(defun read-signed-suffix (length dstate)
+ (declare (type (member 8 16 32) length)
+ (type disassem-state dstate)
+ (optimize (speed 3) (safety 0)))
+ (sign-extend (read-suffix length dstate) length))
+
+;;; KLUDGE: The associated run-time machinery for this is in
+;;; target-disassem.lisp (much later). This is here just to make sure
+;;; it's defined before it's used. -- WHN ca. 19990701
+(defmacro dstate-get-prop (dstate name)
+ #!+sb-doc
+ "Get the value of the property called NAME in DSTATE. Also setf'able."
+ `(getf (dstate-properties ,dstate) ,name))
--- /dev/null
+;;;; stuff that knows about dumping FASL files
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!C")
+
+(file-comment
+ "$Header$")
+
+;;; FIXME: Double colons are bad, and there are lots of them in this
+;;; file, because both dump logic in SB!C and load logic in SB!IMPL
+;;; need to know about fops. Perhaps all the load/dump logic should be
+;;; moved into a single package, perhaps called SB-LD.
+\f
+;;;; fasl dumper state
+
+;;; The FASL-FILE structure represents everything we need to know
+;;; about dumping to a fasl file. We need to objectify the state,
+;;; since the fasdumper must be reentrant.
+(defstruct (fasl-file
+ #-no-ansi-print-object
+ (:print-object (lambda (x s)
+ (print-unreadable-object (x s :type t)
+ (prin1 (namestring (fasl-file-stream x)) s)))))
+ ;; The stream we dump to.
+ (stream (required-argument) :type stream)
+ ;; Hashtables we use to keep track of dumped constants so that we
+ ;; can get them from the table rather than dumping them again. The
+ ;; EQUAL-TABLE is used for lists and strings, and the EQ-TABLE is
+ ;; used for everything else. We use a separate EQ table to avoid
+ ;; performance patholigies with objects for which EQUAL degnerates
+ ;; to EQL. Everything entered in the EQUAL table is also entered in
+ ;; the EQ table.
+ (equal-table (make-hash-table :test 'equal) :type hash-table)
+ (eq-table (make-hash-table :test 'eq) :type hash-table)
+ ;; The table's current free pointer: the next offset to be used.
+ (table-free 0 :type index)
+ ;; an alist (PACKAGE . OFFSET) of the table offsets for each package
+ ;; we have currently located.
+ (packages () :type list)
+ ;; a table mapping from the Entry-Info structures for dumped XEPs to
+ ;; the table offsets of the corresponding code pointers
+ (entry-table (make-hash-table :test 'eq) :type hash-table)
+ ;; a table holding back-patching info for forward references to XEPs.
+ ;; The key is the Entry-Info structure for the XEP, and the value is
+ ;; a list of conses (<code-handle> . <offset>), where <code-handle>
+ ;; is the offset in the table of the code object needing to be
+ ;; patched, and <offset> is the offset that must be patched.
+ (patch-table (make-hash-table :test 'eq) :type hash-table)
+ ;; a list of the table handles for all of the DEBUG-INFO structures
+ ;; dumped in this file. These structures must be back-patched with
+ ;; source location information when the compilation is complete.
+ (debug-info () :type list)
+ ;; This is used to keep track of objects that we are in the process
+ ;; of dumping so that circularities can be preserved. The key is the
+ ;; object that we have previously seen, and the value is the object
+ ;; that we reference in the table to find this previously seen
+ ;; object. (The value is never NIL.)
+ ;;
+ ;; Except with list objects, the key and the value are always the
+ ;; same. In a list, the key will be some tail of the value.
+ (circularity-table (make-hash-table :test 'eq) :type hash-table)
+ ;; a hash table of structures that are allowed to be dumped. If we
+ ;; try to dump a structure that isn't in this hash table, we lose.
+ (valid-structures (make-hash-table :test 'eq) :type hash-table))
+
+;;; This structure holds information about a circularity.
+(defstruct circularity
+ ;; the kind of modification to make to create circularity
+ (type (required-argument) :type (member :rplaca :rplacd :svset :struct-set))
+ ;; the object containing circularity
+ object
+ ;; index in object for circularity
+ (index (required-argument) :type index)
+ ;; the object to be stored at INDEX in OBJECT. This is that the key
+ ;; that we were using when we discovered the circularity.
+ value
+ ;; the value that was associated with VALUE in the
+ ;; CIRCULARITY-TABLE. This is the object that we look up in the
+ ;; EQ-TABLE to locate VALUE.
+ enclosing-object)
+
+;;; a list of the CIRCULARITY structures for all of the circularities
+;;; detected in the current top-level call to DUMP-OBJECT. Setting
+;;; this lobotomizes circularity detection as well, since circular
+;;; dumping uses the table.
+(defvar *circularities-detected*)
+
+;;; used to inhibit table access when dumping forms to be read by the
+;;; cold loader
+(defvar *cold-load-dump* nil)
+
+;;; used to turn off the structure validation during dumping of source
+;;; info
+(defvar *dump-only-valid-structures* t)
+;;;; utilities
+
+;;; Write the byte B to the specified fasl-file stream.
+(defun dump-byte (b fasl-file)
+ (declare (type (unsigned-byte 8) b) (type fasl-file fasl-file))
+ (write-byte b (fasl-file-stream fasl-file)))
+
+;;; Dump a 4 byte unsigned integer.
+(defun dump-unsigned-32 (num fasl-file)
+ (declare (type (unsigned-byte 32) num) (type fasl-file fasl-file))
+ (let ((stream (fasl-file-stream fasl-file)))
+ (dotimes (i 4)
+ (write-byte (ldb (byte 8 (* 8 i)) num) stream))))
+
+;;; Dump NUM to the fasl stream, represented by N bytes. This works for either
+;;; signed or unsigned integers. There's no range checking -- if you don't
+;;; specify enough bytes for the number to fit, this function cheerfully
+;;; outputs the low bytes.
+(defun dump-integer-as-n-bytes (num bytes file)
+ (declare (integer num) (type index bytes) (type fasl-file file))
+ (do ((n num (ash n -8))
+ (i bytes (1- i)))
+ ((= i 0))
+ (declare (type index i))
+ (dump-byte (logand n #xff) file))
+ (values))
+
+;;; Setting this variable to an (UNSIGNED-BYTE 32) value causes DUMP-FOP to use
+;;; it as a counter and emit a FOP-NOP4 with the counter value before every
+;;; ordinary fop. This can make it easier to follow the progress of FASLOAD
+;;; when debugging/testing/experimenting.
+#!+sb-show (defvar *fop-nop4-count* 0)
+#!+sb-show (declaim (type (or (unsigned-byte 32) null) *fop-nop4-count*))
+;;; FIXME: The default value here should become NIL once I get the system to
+;;; run.
+
+;;; Dump the FOP code for the named FOP to the specified fasl-file.
+;;;
+;;; FIXME: This should be a function, with a compiler macro expansion for the
+;;; common constant-FS case. (Among other things, that'll stop it from
+;;; EVALing ,FILE multiple times.)
+;;;
+;;; FIXME: Compiler macros, frozen classes, inlining, and similar optimizations
+;;; should be conditional on #!+SB-FROZEN.
+(defmacro dump-fop (fs file)
+ (let* ((fs (eval fs))
+ (val (get fs 'sb!impl::fop-code)))
+ (if val
+ `(progn
+ #!+sb-show
+ (when *fop-nop4-count*
+ (dump-byte ,(get 'sb!impl::fop-nop4 'sb!impl::fop-code) ,file)
+ (dump-unsigned-32 (mod (incf *fop-nop4-count*) (expt 2 32)) ,file))
+ (dump-byte ',val ,file))
+ (error "compiler bug: ~S is not a legal fasload operator." fs))))
+
+;;; Dump a FOP-Code along with an integer argument, choosing the FOP based
+;;; on whether the argument will fit in a single byte.
+;;;
+;;; FIXME: This, like DUMP-FOP, should be a function with a compiler-macro
+;;; expansion.
+(defmacro dump-fop* (n byte-fop word-fop file)
+ (once-only ((n-n n)
+ (n-file file))
+ `(cond ((< ,n-n 256)
+ (dump-fop ',byte-fop ,n-file)
+ (dump-byte ,n-n ,n-file))
+ (t
+ (dump-fop ',word-fop ,n-file)
+ (dump-unsigned-32 ,n-n ,n-file)))))
+
+;;; Push the object at table offset Handle on the fasl stack.
+(defun dump-push (handle file)
+ (declare (type index handle) (type fasl-file file))
+ (dump-fop* handle sb!impl::fop-byte-push sb!impl::fop-push file)
+ (values))
+
+;;; Pop the object currently on the fasl stack top into the table, and
+;;; return the table index, incrementing the free pointer.
+(defun dump-pop (file)
+ (prog1
+ (fasl-file-table-free file)
+ (dump-fop 'sb!impl::fop-pop file)
+ (incf (fasl-file-table-free file))))
+
+;;; If X is in File's EQUAL-TABLE, then push the object and return T,
+;;; otherwise NIL. If *COLD-LOAD-DUMP* is true, then do nothing and
+;;; return NIL.
+(defun equal-check-table (x file)
+ (declare (type fasl-file file))
+ (unless *cold-load-dump*
+ (let ((handle (gethash x (fasl-file-equal-table file))))
+ (cond (handle
+ (dump-push handle file)
+ t)
+ (t
+ nil)))))
+
+;;; These functions are called after dumping an object to save the
+;;; object in the table. The object (also passed in as X) must already
+;;; be on the top of the FOP stack. If *COLD-LOAD-DUMP* is true, then
+;;; we don't do anything.
+(defun eq-save-object (x file)
+ (declare (type fasl-file file))
+ (unless *cold-load-dump*
+ (let ((handle (dump-pop file)))
+ (setf (gethash x (fasl-file-eq-table file)) handle)
+ (dump-push handle file)))
+ (values))
+(defun equal-save-object (x file)
+ (declare (type fasl-file file))
+ (unless *cold-load-dump*
+ (let ((handle (dump-pop file)))
+ (setf (gethash x (fasl-file-equal-table file)) handle)
+ (setf (gethash x (fasl-file-eq-table file)) handle)
+ (dump-push handle file)))
+ (values))
+
+;;; Record X in File's CIRCULARITY-TABLE unless *COLD-LOAD-DUMP* is
+;;; true. This is called on objects that we are about to dump might
+;;; have a circular path through them.
+;;;
+;;; The object must not currently be in this table, since the dumper
+;;; should never be recursively called on a circular reference.
+;;; Instead, the dumping function must detect the circularity and
+;;; arrange for the dumped object to be patched.
+(defun note-potential-circularity (x file)
+ (unless *cold-load-dump*
+ (let ((circ (fasl-file-circularity-table file)))
+ (assert (not (gethash x circ)))
+ (setf (gethash x circ) x)))
+ (values))
+
+;;; Dump FORM to a fasl file so that it evaluated at load time in normal
+;;; load and at cold-load time in cold load. This is used to dump package
+;;; frobbing forms.
+(defun fasl-dump-cold-load-form (form file)
+ (declare (type fasl-file file))
+ (dump-fop 'sb!impl::fop-normal-load file)
+ (let ((*cold-load-dump* t))
+ (dump-object form file))
+ (dump-fop 'sb!impl::fop-eval-for-effect file)
+ (dump-fop 'sb!impl::fop-maybe-cold-load file)
+ (values))
+\f
+;;;; opening and closing fasl files
+
+;;; Open a fasl file, write its header, and return a FASL-FILE object for
+;;; dumping to it. Some human-readable information about the source code is
+;;; given by the string WHERE. If BYTE-P is true, this file will contain no
+;;; native code, and is thus largely implementation independent.
+(defun open-fasl-file (name where &optional byte-p)
+ (declare (type pathname name))
+ (let* ((stream (open name
+ :direction :output
+ :if-exists :new-version
+ :element-type 'sb!assem:assembly-unit))
+ (res (make-fasl-file :stream stream)))
+
+ ;; Begin the header with the constant machine-readable (and
+ ;; semi-human-readable) string which is used to identify fasl files.
+ (write-string sb!c:*fasl-header-string-start-string* stream)
+
+ ;; The constant string which begins the header is followed by arbitrary
+ ;; human-readable text, terminated by a special character code.
+ (with-standard-io-syntax
+ (format stream
+ "~% ~
+ compiled from ~S~% ~
+ at ~A~% ~
+ on ~A~% ~
+ using ~A version ~A~%"
+ where
+ (format-universal-time nil (get-universal-time))
+ (machine-instance)
+ (sb!xc:lisp-implementation-type)
+ (sb!xc:lisp-implementation-version)))
+ (dump-byte sb!c:*fasl-header-string-stop-char-code* res)
+
+ ;; Finish the header by outputting fasl file implementation and version in
+ ;; machine-readable form.
+ (multiple-value-bind (implementation version)
+ (if byte-p
+ (values *backend-byte-order*
+ byte-fasl-file-version)
+ (values *backend-fasl-file-implementation*
+ *backend-fasl-file-version*))
+ (dump-unsigned-32 (length (symbol-name implementation)) res)
+ (dotimes (i (length (symbol-name implementation)))
+ (dump-byte (char-code (aref (symbol-name implementation) i)) res))
+ (dump-unsigned-32 version res))
+
+ res))
+
+;;; Close the specified FASL-FILE, aborting the write if ABORT-P.
+;;; We do various sanity checks, then end the group.
+(defun close-fasl-file (file abort-p)
+ (declare (type fasl-file file))
+ (assert (zerop (hash-table-count (fasl-file-patch-table file))))
+ (dump-fop 'sb!impl::fop-verify-empty-stack file)
+ (dump-fop 'sb!impl::fop-verify-table-size file)
+ (dump-unsigned-32 (fasl-file-table-free file) file)
+ (dump-fop 'sb!impl::fop-end-group file)
+ (close (fasl-file-stream file) :abort abort-p)
+ (values))
+\f
+;;;; main entries to object dumping
+
+;;; This function deals with dumping objects that are complex enough so that
+;;; we want to cache them in the table, rather than repeatedly dumping them.
+;;; If the object is in the EQ-TABLE, then we push it, otherwise, we do a type
+;;; dispatch to a type specific dumping function. The type specific branches
+;;; do any appropriate EQUAL-TABLE check and table entry.
+;;;
+;;; When we go to dump the object, we enter it in the CIRCULARITY-TABLE.
+(defun dump-non-immediate-object (x file)
+ (let ((index (gethash x (fasl-file-eq-table file))))
+ (cond ((and index (not *cold-load-dump*))
+ (dump-push index file))
+ (t
+ (typecase x
+ (symbol (dump-symbol x file))
+ (list
+ (unless (equal-check-table x file)
+ (dump-list x file)
+ (equal-save-object x file)))
+ (layout
+ (dump-layout x file)
+ (eq-save-object x file))
+ (instance
+ (dump-structure x file)
+ (eq-save-object x file))
+ (array
+ ;; FIXME: The comment at the head of DUMP-NON-IMMEDIATE-OBJECT
+ ;; says it's for objects which we want to save, instead of
+ ;; repeatedly dumping them. But then we dump arrays here without
+ ;; doing anything a la EQUAL-SAVE-OBJECT. What gives?
+ (dump-array x file))
+ (number
+ (unless (equal-check-table x file)
+ (etypecase x
+ (ratio (dump-ratio x file))
+ (complex (dump-complex x file))
+ (float (dump-float x file))
+ (integer (dump-integer x file)))
+ (equal-save-object x file)))
+ (t
+ ;; This probably never happens, since bad things tend to be
+ ;; detected during IR1 conversion.
+ (error "This object cannot be dumped into a fasl file:~% ~S"
+ x))))))
+ (values))
+
+;;; Dump an object of any type by dispatching to the correct type-specific
+;;; dumping function. We pick off immediate objects, symbols and and magic
+;;; lists here. Other objects are handled by Dump-Non-Immediate-Object.
+;;;
+;;; This is the function used for recursive calls to the fasl dumper. We don't
+;;; worry about creating circularities here, since it is assumed that there is
+;;; a top-level call to Dump-Object.
+(defun sub-dump-object (x file)
+ (cond ((listp x)
+ (if x
+ (dump-non-immediate-object x file)
+ (dump-fop 'sb!impl::fop-empty-list file)))
+ ((symbolp x)
+ (if (eq x t)
+ (dump-fop 'sb!impl::fop-truth file)
+ (dump-non-immediate-object x file)))
+ ((target-fixnump x) (dump-integer x file))
+ ((characterp x) (dump-character x file))
+ (t
+ (dump-non-immediate-object x file))))
+
+;;; Dump stuff to backpatch already dumped objects. Infos is the list of
+;;; Circularity structures describing what to do. The patching FOPs take the
+;;; value to store on the stack. We compute this value by fetching the
+;;; enclosing object from the table, and then CDR'ing it if necessary.
+(defun dump-circularities (infos file)
+ (let ((table (fasl-file-eq-table file)))
+ (dolist (info infos)
+ (let* ((value (circularity-value info))
+ (enclosing (circularity-enclosing-object info)))
+ (dump-push (gethash enclosing table) file)
+ (unless (eq enclosing value)
+ (do ((current enclosing (cdr current))
+ (i 0 (1+ i)))
+ ((eq current value)
+ (dump-fop 'sb!impl::fop-nthcdr file)
+ (dump-unsigned-32 i file))
+ (declare (type index i)))))
+
+ (ecase (circularity-type info)
+ (:rplaca (dump-fop 'sb!impl::fop-rplaca file))
+ (:rplacd (dump-fop 'sb!impl::fop-rplacd file))
+ (:svset (dump-fop 'sb!impl::fop-svset file))
+ (:struct-set (dump-fop 'sb!impl::fop-structset file)))
+ (dump-unsigned-32 (gethash (circularity-object info) table) file)
+ (dump-unsigned-32 (circularity-index info) file))))
+
+;;; Set up stuff for circularity detection, then dump an object. All shared
+;;; and circular structure will be exactly preserved within a single call to
+;;; Dump-Object. Sharing between objects dumped by separate calls is only
+;;; preserved when convenient.
+;;;
+;;; We peek at the object type so that we only pay the circular detection
+;;; overhead on types of objects that might be circular.
+(defun dump-object (x file)
+ (if (or (array-header-p x)
+ (simple-vector-p x)
+ (consp x)
+ (typep x 'instance))
+ (let ((*circularities-detected* ())
+ (circ (fasl-file-circularity-table file)))
+ (clrhash circ)
+ (sub-dump-object x file)
+ (when *circularities-detected*
+ (dump-circularities *circularities-detected* file)
+ (clrhash circ)))
+ (sub-dump-object x file)))
+\f
+;;;; LOAD-TIME-VALUE and MAKE-LOAD-FORM support
+
+;;; Emit a funcall of the function and return the handle for the result.
+(defun fasl-dump-load-time-value-lambda (fun file)
+ (declare (type clambda fun) (type fasl-file file))
+ (let ((handle (gethash (leaf-info fun) (fasl-file-entry-table file))))
+ (assert handle)
+ (dump-push handle file)
+ (dump-fop 'sb!impl::fop-funcall file)
+ (dump-byte 0 file))
+ (dump-pop file))
+
+;;; Return T iff CONSTANT has not already been dumped. It's been dumped
+;;; if it's in the EQ table.
+(defun fasl-constant-already-dumped (constant file)
+ (if (or (gethash constant (fasl-file-eq-table file))
+ (gethash constant (fasl-file-valid-structures file)))
+ t
+ nil))
+
+;;; Use HANDLE whenever we try to dump CONSTANT. HANDLE should have been
+;;; returned earlier by FASL-DUMP-LOAD-TIME-VALUE-LAMBDA.
+(defun fasl-note-handle-for-constant (constant handle file)
+ (let ((table (fasl-file-eq-table file)))
+ (when (gethash constant table)
+ (error "~S already dumped?" constant))
+ (setf (gethash constant table) handle))
+ (values))
+
+;;; Note that the specified structure can just be dumped by enumerating the
+;;; slots.
+(defun fasl-validate-structure (structure file)
+ (setf (gethash structure (fasl-file-valid-structures file)) t)
+ (values))
+\f
+;;;; number dumping
+
+;;; Dump a ratio
+
+(defun dump-ratio (x file)
+ (sub-dump-object (numerator x) file)
+ (sub-dump-object (denominator x) file)
+ (dump-fop 'sb!impl::fop-ratio file))
+
+;;; Dump an integer.
+
+(defun dump-integer (n file)
+ (typecase n
+ ((signed-byte 8)
+ (dump-fop 'sb!impl::fop-byte-integer file)
+ (dump-byte (logand #xFF n) file))
+ ((unsigned-byte 31)
+ (dump-fop 'sb!impl::fop-word-integer file)
+ (dump-unsigned-32 n file))
+ ((signed-byte 32)
+ (dump-fop 'sb!impl::fop-word-integer file)
+ (dump-integer-as-n-bytes n 4 file))
+ (t
+ (let ((bytes (ceiling (1+ (integer-length n)) 8)))
+ (dump-fop* bytes
+ sb!impl::fop-small-integer
+ sb!impl::fop-integer
+ file)
+ (dump-integer-as-n-bytes n bytes file)))))
+
+(defun dump-float (x file)
+ (etypecase x
+ (single-float
+ (dump-fop 'sb!impl::fop-single-float file)
+ (dump-integer-as-n-bytes (single-float-bits x) 4 file))
+ (double-float
+ (dump-fop 'sb!impl::fop-double-float file)
+ (let ((x x))
+ (declare (double-float x))
+ ;; FIXME: Why sometimes DUMP-UNSIGNED-32 and sometimes
+ ;; DUMP-INTEGER-AS-N-BYTES .. 4?
+ (dump-unsigned-32 (double-float-low-bits x) file)
+ (dump-integer-as-n-bytes (double-float-high-bits x) 4 file)))
+ #!+long-float
+ (long-float
+ (dump-fop 'sb!impl::fop-long-float file)
+ (dump-long-float x file))))
+
+(defun dump-complex (x file)
+ (typecase x
+ #-sb-xc-host
+ ((complex single-float)
+ (dump-fop 'sb!impl::fop-complex-single-float file)
+ (dump-integer-as-n-bytes (single-float-bits (realpart x)) 4 file)
+ (dump-integer-as-n-bytes (single-float-bits (imagpart x)) 4 file))
+ #-sb-xc-host
+ ((complex double-float)
+ (dump-fop 'sb!impl::fop-complex-double-float file)
+ (let ((re (realpart x)))
+ (declare (double-float re))
+ (dump-unsigned-32 (double-float-low-bits re) file)
+ (dump-integer-as-n-bytes (double-float-high-bits re) 4 file))
+ (let ((im (imagpart x)))
+ (declare (double-float im))
+ (dump-unsigned-32 (double-float-low-bits im) file)
+ (dump-integer-as-n-bytes (double-float-high-bits im) 4 file)))
+ #!+(and long-float (not sb-xc))
+ ((complex long-float)
+ (dump-fop 'sb!impl::fop-complex-long-float file)
+ (dump-long-float (realpart x) file)
+ (dump-long-float (imagpart x) file))
+ (t
+ (sub-dump-object (realpart x) file)
+ (sub-dump-object (imagpart x) file)
+ (dump-fop 'sb!impl::fop-complex file))))
+\f
+;;;; symbol dumping
+
+;;; Return the table index of PKG, adding the package to the table if
+;;; necessary. During cold load, we read the string as a normal string so that
+;;; we can do the package lookup at cold load time.
+;;;
+;;; KLUDGE: Despite the parallelism in names, the functionality of this
+;;; function is not parallel to other functions DUMP-FOO, e.g. DUMP-SYMBOL
+;;; and DUMP-LIST. -- WHN 19990119
+(defun dump-package (pkg file)
+ (declare (type package pkg) (type fasl-file file) (values index)
+ (inline assoc))
+ (cond ((cdr (assoc pkg (fasl-file-packages file) :test #'eq)))
+ (t
+ (unless *cold-load-dump*
+ (dump-fop 'sb!impl::fop-normal-load file))
+ (dump-simple-string (package-name pkg) file)
+ (dump-fop 'sb!impl::fop-package file)
+ (unless *cold-load-dump*
+ (dump-fop 'sb!impl::fop-maybe-cold-load file))
+ (let ((entry (dump-pop file)))
+ (push (cons pkg entry) (fasl-file-packages file))
+ entry))))
+\f
+;;; dumper for lists
+
+;;; Dump a list, setting up patching information when there are
+;;; circularities. We scan down the list, checking for CDR and CAR
+;;; circularities.
+;;;
+;;; If there is a CDR circularity, we terminate the list with NIL and
+;;; make a CIRCULARITY notation for the CDR of the previous cons.
+;;;
+;;; If there is no CDR circularity, then we mark the current cons and
+;;; check for a CAR circularity. When there is a CAR circularity, we
+;;; make the CAR NIL initially, arranging for the current cons to be
+;;; patched later.
+;;;
+;;; Otherwise, we recursively call the dumper to dump the current
+;;; element.
+;;;
+;;; Marking of the conses is inhibited when *COLD-LOAD-DUMP* is true.
+;;; This inhibits all circularity detection.
+(defun dump-list (list file)
+ (assert (and list
+ (not (gethash list (fasl-file-circularity-table file)))))
+ (do* ((l list (cdr l))
+ (n 0 (1+ n))
+ (circ (fasl-file-circularity-table file)))
+ ((atom l)
+ (cond ((null l)
+ (terminate-undotted-list n file))
+ (t
+ (sub-dump-object l file)
+ (terminate-dotted-list n file))))
+ (declare (type index n))
+ (let ((ref (gethash l circ)))
+ (when ref
+ (push (make-circularity :type :rplacd
+ :object list
+ :index (1- n)
+ :value l
+ :enclosing-object ref)
+ *circularities-detected*)
+ (terminate-undotted-list n file)
+ (return)))
+
+ (unless *cold-load-dump*
+ (setf (gethash l circ) list))
+
+ (let* ((obj (car l))
+ (ref (gethash obj circ)))
+ (cond (ref
+ (push (make-circularity :type :rplaca
+ :object list
+ :index n
+ :value obj
+ :enclosing-object ref)
+ *circularities-detected*)
+ (sub-dump-object nil file))
+ (t
+ (sub-dump-object obj file))))))
+
+(defun terminate-dotted-list (n file)
+ (declare (type index n) (type fasl-file file))
+ (case n
+ (1 (dump-fop 'sb!impl::fop-list*-1 file))
+ (2 (dump-fop 'sb!impl::fop-list*-2 file))
+ (3 (dump-fop 'sb!impl::fop-list*-3 file))
+ (4 (dump-fop 'sb!impl::fop-list*-4 file))
+ (5 (dump-fop 'sb!impl::fop-list*-5 file))
+ (6 (dump-fop 'sb!impl::fop-list*-6 file))
+ (7 (dump-fop 'sb!impl::fop-list*-7 file))
+ (8 (dump-fop 'sb!impl::fop-list*-8 file))
+ (T (do ((nn n (- nn 255)))
+ ((< nn 256)
+ (dump-fop 'sb!impl::fop-list* file)
+ (dump-byte nn file))
+ (declare (type index nn))
+ (dump-fop 'sb!impl::fop-list* file)
+ (dump-byte 255 file)))))
+
+;;; If N > 255, must build list with one list operator, then list* operators.
+
+(defun terminate-undotted-list (n file)
+ (declare (type index n) (type fasl-file file))
+ (case n
+ (1 (dump-fop 'sb!impl::fop-list-1 file))
+ (2 (dump-fop 'sb!impl::fop-list-2 file))
+ (3 (dump-fop 'sb!impl::fop-list-3 file))
+ (4 (dump-fop 'sb!impl::fop-list-4 file))
+ (5 (dump-fop 'sb!impl::fop-list-5 file))
+ (6 (dump-fop 'sb!impl::fop-list-6 file))
+ (7 (dump-fop 'sb!impl::fop-list-7 file))
+ (8 (dump-fop 'sb!impl::fop-list-8 file))
+ (T (cond ((< n 256)
+ (dump-fop 'sb!impl::fop-list file)
+ (dump-byte n file))
+ (t (dump-fop 'sb!impl::fop-list file)
+ (dump-byte 255 file)
+ (do ((nn (- n 255) (- nn 255)))
+ ((< nn 256)
+ (dump-fop 'sb!impl::fop-list* file)
+ (dump-byte nn file))
+ (declare (type index nn))
+ (dump-fop 'sb!impl::fop-list* file)
+ (dump-byte 255 file)))))))
+\f
+;;;; array dumping
+
+;;; Dump the array thing.
+(defun dump-array (x file)
+ (if (vectorp x)
+ (dump-vector x file)
+ (dump-multi-dim-array x file)))
+
+;;; Dump the vector object. If it's not simple, then actually dump a simple
+;;; version of it. But we enter the original in the EQ or EQUAL tables.
+(defun dump-vector (x file)
+ (let ((simple-version (if (array-header-p x)
+ (coerce x 'simple-array)
+ x)))
+ (typecase simple-version
+ (simple-base-string
+ (unless (equal-check-table x file)
+ (dump-simple-string simple-version file)
+ (equal-save-object x file)))
+ (simple-vector
+ (dump-simple-vector simple-version file)
+ (eq-save-object x file))
+ ((simple-array single-float (*))
+ (dump-single-float-vector simple-version file)
+ (eq-save-object x file))
+ ((simple-array double-float (*))
+ (dump-double-float-vector simple-version file)
+ (eq-save-object x file))
+ #!+long-float
+ ((simple-array long-float (*))
+ (dump-long-float-vector simple-version file)
+ (eq-save-object x file))
+ ((simple-array (complex single-float) (*))
+ (dump-complex-single-float-vector simple-version file)
+ (eq-save-object x file))
+ ((simple-array (complex double-float) (*))
+ (dump-complex-double-float-vector simple-version file)
+ (eq-save-object x file))
+ #!+long-float
+ ((simple-array (complex long-float) (*))
+ (dump-complex-long-float-vector simple-version file)
+ (eq-save-object x file))
+ (t
+ (dump-i-vector simple-version file)
+ (eq-save-object x file)))))
+
+;;; Dump a SIMPLE-VECTOR, handling any circularities.
+(defun dump-simple-vector (v file)
+ (declare (type simple-vector v) (type fasl-file file))
+ (note-potential-circularity v file)
+ (do ((index 0 (1+ index))
+ (length (length v))
+ (circ (fasl-file-circularity-table file)))
+ ((= index length)
+ (dump-fop* length
+ sb!impl::fop-small-vector
+ sb!impl::fop-vector
+ file))
+ (let* ((obj (aref v index))
+ (ref (gethash obj circ)))
+ (cond (ref
+ (push (make-circularity :type :svset
+ :object v
+ :index index
+ :value obj
+ :enclosing-object ref)
+ *circularities-detected*)
+ (sub-dump-object nil file))
+ (t
+ (sub-dump-object obj file))))))
+
+(defun dump-i-vector (vec file &key data-only)
+ (declare (type (simple-array * (*)) vec))
+ (let ((len (length vec)))
+ (labels ((dump-unsigned-vector (size bytes)
+ (unless data-only
+ (dump-fop 'sb!impl::fop-int-vector file)
+ (dump-unsigned-32 len file)
+ (dump-byte size file))
+ ;; The case which is easy to handle in a portable way is when
+ ;; the element size is a multiple of the output byte size, and
+ ;; happily that's the only case we need to be portable. (The
+ ;; cross-compiler has to output debug information (including
+ ;; (SIMPLE-ARRAY (UNSIGNED-BYTE 8) *).) The other cases are only
+ ;; needed in the target SBCL, so we let them be handled with
+ ;; unportable bit bashing.
+ (cond ((>= size 8) ; easy cases
+ (multiple-value-bind (floor rem) (floor size 8)
+ (assert (zerop rem))
+ (dovector (i vec)
+ (dump-integer-as-n-bytes i floor file))))
+ (t ; harder cases, not supported in cross-compiler
+ (dump-raw-bytes vec bytes file))))
+ (dump-signed-vector (size bytes)
+ ;; Note: Dumping specialized signed vectors isn't supported in
+ ;; the cross-compiler. (All cases here end up trying to call
+ ;; DUMP-RAW-BYTES, which isn't provided in the cross-compilation
+ ;; host, only on the target machine.)
+ (unless data-only
+ (dump-fop 'sb!impl::fop-signed-int-vector file)
+ (dump-unsigned-32 len file)
+ (dump-byte size file))
+ (dump-raw-bytes vec bytes file)))
+ (etypecase vec
+ ;; KLUDGE: What exactly does the (ASH .. -3) stuff do? -- WHN 19990902
+ (simple-bit-vector
+ (dump-unsigned-vector 1 (ash (+ (the index len) 7) -3)))
+ ((simple-array (unsigned-byte 2) (*))
+ (dump-unsigned-vector 2 (ash (+ (the index (ash len 1)) 7) -3)))
+ ((simple-array (unsigned-byte 4) (*))
+ (dump-unsigned-vector 4 (ash (+ (the index (ash len 2)) 7) -3)))
+ ((simple-array (unsigned-byte 8) (*))
+ (dump-unsigned-vector 8 len))
+ ((simple-array (unsigned-byte 16) (*))
+ (dump-unsigned-vector 16 (* 2 len)))
+ ((simple-array (unsigned-byte 32) (*))
+ (dump-unsigned-vector 32 (* 4 len)))
+ ((simple-array (signed-byte 8) (*))
+ (dump-signed-vector 8 len))
+ ((simple-array (signed-byte 16) (*))
+ (dump-signed-vector 16 (* 2 len)))
+ ((simple-array (signed-byte 30) (*))
+ (dump-signed-vector 30 (* 4 len)))
+ ((simple-array (signed-byte 32) (*))
+ (dump-signed-vector 32 (* 4 len)))))))
+\f
+;;; Dump characters and string-ish things.
+
+(defun dump-character (ch file)
+ (dump-fop 'sb!impl::fop-short-character file)
+ (dump-byte (char-code ch) file))
+
+;;; a helper function shared by DUMP-SIMPLE-STRING and DUMP-SYMBOL
+(defun dump-characters-of-string (s fasl-file)
+ (declare (type string s) (type fasl-file fasl-file))
+ (dovector (c s)
+ (dump-byte (char-code c) fasl-file))
+ (values))
+
+;;; Dump a SIMPLE-BASE-STRING.
+;;; FIXME: should be called DUMP-SIMPLE-BASE-STRING then
+(defun dump-simple-string (s file)
+ (declare (type simple-base-string s))
+ (dump-fop* (length s)
+ sb!impl::fop-small-string
+ sb!impl::fop-string
+ file)
+ (dump-characters-of-string s file)
+ (values))
+
+;;; If we get here, it is assumed that the symbol isn't in the table,
+;;; but we are responsible for putting it there when appropriate. To
+;;; avoid too much special-casing, we always push the symbol in the
+;;; table, but don't record that we have done so if *COLD-LOAD-DUMP*
+;;; is true.
+(defun dump-symbol (s file)
+ (let* ((pname (symbol-name s))
+ (pname-length (length pname))
+ (pkg (symbol-package s)))
+
+ (cond ((null pkg)
+ (dump-fop* pname-length
+ sb!impl::fop-uninterned-small-symbol-save
+ sb!impl::fop-uninterned-symbol-save
+ file))
+ ;; CMU CL had FOP-SYMBOL-SAVE/FOP-SMALL-SYMBOL-SAVE fops which
+ ;; used the current value of *PACKAGE*. Unfortunately that's
+ ;; broken w.r.t. ANSI Common Lisp semantics, so those are gone
+ ;; from SBCL.
+ ;;((eq pkg *package*)
+ ;; (dump-fop* pname-length
+ ;; sb!impl::fop-small-symbol-save
+ ;; sb!impl::fop-symbol-save file))
+ ((eq pkg sb!int:*cl-package*)
+ (dump-fop* pname-length
+ sb!impl::fop-lisp-small-symbol-save
+ sb!impl::fop-lisp-symbol-save
+ file))
+ ((eq pkg sb!int:*keyword-package*)
+ (dump-fop* pname-length
+ sb!impl::fop-keyword-small-symbol-save
+ sb!impl::fop-keyword-symbol-save
+ file))
+ ((< pname-length 256)
+ (dump-fop* (dump-package pkg file)
+ sb!impl::fop-small-symbol-in-byte-package-save
+ sb!impl::fop-small-symbol-in-package-save
+ file)
+ (dump-byte pname-length file))
+ (t
+ (dump-fop* (dump-package pkg file)
+ sb!impl::fop-symbol-in-byte-package-save
+ sb!impl::fop-symbol-in-package-save
+ file)
+ (dump-unsigned-32 pname-length file)))
+
+ (dump-characters-of-string pname file)
+
+ (unless *cold-load-dump*
+ (setf (gethash s (fasl-file-eq-table file))
+ (fasl-file-table-free file)))
+
+ (incf (fasl-file-table-free file)))
+
+ (values))
+\f
+;;;; component (function) dumping
+
+(defun dump-segment (segment code-length fasl-file)
+ (declare (type sb!assem:segment segment)
+ (type fasl-file fasl-file))
+ (let* ((stream (fasl-file-stream fasl-file))
+ (nwritten (write-segment-contents segment stream)))
+ ;; In CMU CL there was no enforced connection between the CODE-LENGTH
+ ;; argument and the number of bytes actually written. I added this
+ ;; assertion while trying to debug portable genesis. -- WHN 19990902
+ (unless (= code-length nwritten)
+ (error "internal error, code-length=~D, nwritten=~D"
+ code-length
+ nwritten)))
+ ;; KLUDGE: It's not clear what this is trying to do, but it looks as though
+ ;; it's an implicit undocumented dependence on a 4-byte wordsize which could
+ ;; be painful in porting. Note also that there are other undocumented
+ ;; modulo-4 things scattered throughout the code and conditionalized
+ ;; with GENGC, and I don't know what those do either. -- WHN 19990323
+ #!+gengc (unless (zerop (logand code-length 3))
+ (dotimes (i (- 4 (logand code-length 3)))
+ (dump-byte 0 fasl-file)))
+ (values))
+
+;;; Dump all the fixups. Currently there are three flavors of fixup:
+;;; - assembly routines: named by a symbol
+;;; - foreign (C) symbols: named by a string
+;;; - code object references: don't need a name.
+(defun dump-fixups (fixups fasl-file)
+ (declare (list fixups) (type fasl-file fasl-file))
+ (dolist (info fixups)
+ ;; FIXME: Packing data with LIST in NOTE-FIXUP and unpacking them
+ ;; with FIRST, SECOND, and THIRD here is hard to follow and maintain.
+ ;; Perhaps we could define a FIXUP-INFO structure to use instead, and
+ ;; rename *FIXUPS* to *FIXUP-INFO-LIST*?
+ (let* ((kind (first info))
+ (fixup (second info))
+ (name (fixup-name fixup))
+ (flavor (fixup-flavor fixup))
+ (offset (third info)))
+ ;; FIXME: This OFFSET is not what's called OFFSET in
+ ;; the FIXUP structure, it's what's called POSN in NOTE-FIXUP.
+ ;; (As far as I can tell, FIXUP-OFFSET is not actually an offset,
+ ;; it's an internal label used instead of NAME for :CODE-OBJECT
+ ;; fixups. Notice that in the :CODE-OBJECT case, NAME is ignored.)
+ (dump-fop 'sb!impl::fop-normal-load fasl-file)
+ (let ((*cold-load-dump* t))
+ (dump-object kind fasl-file))
+ (dump-fop 'sb!impl::fop-maybe-cold-load fasl-file)
+ ;; Depending on the flavor, we may have various kinds of
+ ;; noise before the offset.
+ (ecase flavor
+ (:assembly-routine
+ (assert (symbolp name))
+ (dump-fop 'sb!impl::fop-normal-load fasl-file)
+ (let ((*cold-load-dump* t))
+ (dump-object name fasl-file))
+ (dump-fop 'sb!impl::fop-maybe-cold-load fasl-file)
+ (dump-fop 'sb!impl::fop-assembler-fixup fasl-file))
+ (:foreign
+ (assert (stringp name))
+ (dump-fop 'sb!impl::fop-foreign-fixup fasl-file)
+ (let ((len (length name)))
+ (assert (< len 256)) ; (limit imposed by fop definition)
+ (dump-byte len fasl-file)
+ (dotimes (i len)
+ (dump-byte (char-code (schar name i)) fasl-file))))
+ (:code-object
+ (assert (null name))
+ (dump-fop 'sb!impl::fop-code-object-fixup fasl-file)))
+ ;; No matter what the flavor, we'll always dump the offset.
+ (dump-unsigned-32 offset fasl-file)))
+ (values))
+
+;;; Dump out the constant pool and code-vector for component, push the
+;;; result in the table, and return the offset.
+;;;
+;;; The only tricky thing is handling constant-pool references to functions.
+;;; If we have already dumped the function, then we just push the code pointer.
+;;; Otherwise, we must create back-patching information so that the constant
+;;; will be set when the function is eventually dumped. This is a bit awkward,
+;;; since we don't have the handle for the code object being dumped while we
+;;; are dumping its constants.
+;;;
+;;; We dump trap objects in any unused slots or forward referenced slots.
+(defun dump-code-object (component
+ code-segment
+ code-length
+ trace-table-as-list
+ fixups
+ fasl-file)
+
+ (declare (type component component)
+ (list trace-table-as-list)
+ (type index code-length)
+ (type fasl-file fasl-file))
+
+ (let* ((2comp (component-info component))
+ (constants (ir2-component-constants 2comp))
+ (header-length (length constants))
+ (packed-trace-table (pack-trace-table trace-table-as-list))
+ (total-length (+ code-length
+ (* (length packed-trace-table) tt-bytes-per-entry))))
+
+ (collect ((patches))
+
+ ;; Dump the debug info.
+ #!+gengc
+ (let ((info (debug-info-for-component component))
+ (*dump-only-valid-structures* nil))
+ (dump-object info fasl-file)
+ (let ((info-handle (dump-pop fasl-file)))
+ (dump-push info-handle fasl-file)
+ (push info-handle (fasl-file-debug-info fasl-file))))
+
+ ;; Dump the offset of the trace table.
+ (dump-object code-length fasl-file)
+ ;; KLUDGE: Now that we don't have GENGC, the trace table is hardwired
+ ;; to be empty. Could we get rid of trace tables? What are the
+ ;; virtues of GENGC vs. GENCGC vs. whatnot?
+
+ ;; Dump the constants, noting any :entries that have to be fixed up.
+ (do ((i sb!vm:code-constants-offset (1+ i)))
+ ((>= i header-length))
+ (let ((entry (aref constants i)))
+ (etypecase entry
+ (constant
+ (dump-object (constant-value entry) fasl-file))
+ (cons
+ (ecase (car entry)
+ (:entry
+ (let* ((info (leaf-info (cdr entry)))
+ (handle (gethash info
+ (fasl-file-entry-table fasl-file))))
+ (cond
+ (handle
+ (dump-push handle fasl-file))
+ (t
+ (patches (cons info i))
+ (dump-fop 'sb!impl::fop-misc-trap fasl-file)))))
+ (:load-time-value
+ (dump-push (cdr entry) fasl-file))
+ (:fdefinition
+ (dump-object (cdr entry) fasl-file)
+ (dump-fop 'sb!impl::fop-fdefinition fasl-file))))
+ (null
+ (dump-fop 'sb!impl::fop-misc-trap fasl-file)))))
+
+ ;; Dump the debug info.
+ #!-gengc
+ (let ((info (debug-info-for-component component))
+ (*dump-only-valid-structures* nil))
+ (dump-object info fasl-file)
+ (let ((info-handle (dump-pop fasl-file)))
+ (dump-push info-handle fasl-file)
+ (push info-handle (fasl-file-debug-info fasl-file))))
+
+ (let ((num-consts #!+gengc (- header-length
+ sb!vm:code-debug-info-slot)
+ #!-gengc (- header-length
+ sb!vm:code-trace-table-offset-slot))
+ (total-length #!+gengc (ceiling total-length 4)
+ #!-gengc total-length))
+ (cond ((and (< num-consts #x100) (< total-length #x10000))
+ (dump-fop 'sb!impl::fop-small-code fasl-file)
+ (dump-byte num-consts fasl-file)
+ (dump-integer-as-n-bytes total-length 2 fasl-file))
+ (t
+ (dump-fop 'sb!impl::fop-code fasl-file)
+ (dump-unsigned-32 num-consts fasl-file)
+ (dump-unsigned-32 total-length fasl-file))))
+
+ ;; These two dumps are only ones which contribute to our TOTAL-LENGTH
+ ;; value.
+ (dump-segment code-segment code-length fasl-file)
+ (dump-i-vector packed-trace-table fasl-file :data-only t)
+
+ ;; DUMP-FIXUPS does its own internal DUMP-FOPs: the bytes it dumps aren't
+ ;; included in the TOTAL-LENGTH passed to our FOP-CODE/FOP-SMALL-CODE
+ ;; fop.
+ (dump-fixups fixups fasl-file)
+
+ (dump-fop 'sb!impl::fop-sanctify-for-execution fasl-file)
+ (let ((handle (dump-pop fasl-file)))
+ (dolist (patch (patches))
+ (push (cons handle (cdr patch))
+ (gethash (car patch) (fasl-file-patch-table fasl-file))))
+ handle))))
+
+(defun dump-assembler-routines (code-segment length fixups routines file)
+ (dump-fop 'sb!impl::fop-assembler-code file)
+ (dump-unsigned-32 #!+gengc (ceiling length 4)
+ #!-gengc length
+ file)
+ (write-segment-contents code-segment (fasl-file-stream file))
+ (dolist (routine routines)
+ (dump-fop 'sb!impl::fop-normal-load file)
+ (let ((*cold-load-dump* t))
+ (dump-object (car routine) file))
+ (dump-fop 'sb!impl::fop-maybe-cold-load file)
+ (dump-fop 'sb!impl::fop-assembler-routine file)
+ (dump-unsigned-32 (label-position (cdr routine)) file))
+ (dump-fixups fixups file)
+ (dump-fop 'sb!impl::fop-sanctify-for-execution file)
+ (dump-pop file))
+
+;;; Dump a function-entry data structure corresponding to Entry to File.
+;;; Code-Handle is the table offset of the code object for the component.
+;;;
+;;; If the entry is a DEFUN, then we also dump a FOP-FSET so that the cold
+;;; loader can instantiate the definition at cold-load time, allowing forward
+;;; references to functions in top-level forms.
+(defun dump-one-entry (entry code-handle file)
+ (declare (type entry-info entry) (type index code-handle)
+ (type fasl-file file))
+ (let ((name (entry-info-name entry)))
+ (dump-push code-handle file)
+ (dump-object name file)
+ (dump-object (entry-info-arguments entry) file)
+ (dump-object (entry-info-type entry) file)
+ (dump-fop 'sb!impl::fop-function-entry file)
+ (dump-unsigned-32 (label-position (entry-info-offset entry)) file)
+ (let ((handle (dump-pop file)))
+ (when (and name (or (symbolp name) (listp name)))
+ (dump-object name file)
+ (dump-push handle file)
+ (dump-fop 'sb!impl::fop-fset file))
+ handle)))
+
+;;; Alter the code object referenced by Code-Handle at the specified Offset,
+;;; storing the object referenced by Entry-Handle.
+(defun dump-alter-code-object (code-handle offset entry-handle file)
+ (declare (type index code-handle entry-handle offset) (type fasl-file file))
+ (dump-push code-handle file)
+ (dump-push entry-handle file)
+ (dump-fop* offset
+ sb!impl::fop-byte-alter-code
+ sb!impl::fop-alter-code
+ file)
+ (values))
+
+;;; Dump the code, constants, etc. for component. We pass in the assembler
+;;; fixups, code vector and node info.
+(defun fasl-dump-component (component
+ code-segment
+ code-length
+ trace-table
+ fixups
+ file)
+ (declare (type component component) (list trace-table) (type fasl-file file))
+
+ (dump-fop 'sb!impl::fop-verify-empty-stack file)
+ (dump-fop 'sb!impl::fop-verify-table-size file)
+ (dump-unsigned-32 (fasl-file-table-free file) file)
+
+ #!+sb-dyncount
+ (let ((info (ir2-component-dyncount-info (component-info component))))
+ (when info
+ (fasl-validate-structure info file)))
+
+ (let ((code-handle (dump-code-object component
+ code-segment
+ code-length
+ trace-table
+ fixups
+ file))
+ (2comp (component-info component)))
+ (dump-fop 'sb!impl::fop-verify-empty-stack file)
+
+ (dolist (entry (ir2-component-entries 2comp))
+ (let ((entry-handle (dump-one-entry entry code-handle file)))
+ (setf (gethash entry (fasl-file-entry-table file)) entry-handle)
+
+ (let ((old (gethash entry (fasl-file-patch-table file))))
+ ;; KLUDGE: All this code is shared with FASL-DUMP-BYTE-COMPONENT,
+ ;; and should probably be gathered up into a named function
+ ;; (DUMP-PATCHES?) called from both functions.
+ (when old
+ (dolist (patch old)
+ (dump-alter-code-object (car patch)
+ (cdr patch)
+ entry-handle
+ file))
+ (remhash entry (fasl-file-patch-table file)))))))
+ (values))
+
+(defun dump-byte-code-object (segment code-length constants file)
+ (declare (type sb!assem:segment segment)
+ (type index code-length)
+ (type vector constants)
+ (type fasl-file file))
+ (collect ((entry-patches))
+
+ ;; Dump the debug info.
+ #!+gengc
+ (let ((info (make-debug-info
+ :name (component-name *component-being-compiled*)))
+ (*dump-only-valid-structures* nil))
+ (dump-object info file)
+ (let ((info-handle (dump-pop file)))
+ (dump-push info-handle file)
+ (push info-handle (fasl-file-debug-info file))))
+
+ ;; The "trace table" is initialized by loader to hold a list of all byte
+ ;; functions in this code object (for debug info.)
+ (dump-object nil file)
+
+ ;; Dump the constants.
+ (dotimes (i (length constants))
+ (let ((entry (aref constants i)))
+ (etypecase entry
+ (constant
+ (dump-object (constant-value entry) file))
+ (null
+ (dump-fop 'sb!impl::fop-misc-trap file))
+ (list
+ (ecase (car entry)
+ (:entry
+ (let* ((info (leaf-info (cdr entry)))
+ (handle (gethash info (fasl-file-entry-table file))))
+ (cond
+ (handle
+ (dump-push handle file))
+ (t
+ (entry-patches (cons info
+ (+ i sb!vm:code-constants-offset)))
+ (dump-fop 'sb!impl::fop-misc-trap file)))))
+ (:load-time-value
+ (dump-push (cdr entry) file))
+ (:fdefinition
+ (dump-object (cdr entry) file)
+ (dump-fop 'sb!impl::fop-fdefinition file))
+ (:type-predicate
+ (dump-object 'load-type-predicate file)
+ (let ((*unparse-function-type-simplify* t))
+ (dump-object (type-specifier (cdr entry)) file))
+ (dump-fop 'sb!impl::fop-funcall file)
+ (dump-byte 1 file)))))))
+
+ ;; Dump the debug info.
+ #!-gengc
+ (let ((info (make-debug-info :name
+ (component-name *component-being-compiled*)))
+ (*dump-only-valid-structures* nil))
+ (dump-object info file)
+ (let ((info-handle (dump-pop file)))
+ (dump-push info-handle file)
+ (push info-handle (fasl-file-debug-info file))))
+
+ (let ((num-consts #!+gengc (+ (length constants) 2)
+ #!-gengc (1+ (length constants)))
+ (code-length #!+gengc (ceiling code-length 4)
+ #!-gengc code-length))
+ (cond ((and (< num-consts #x100) (< code-length #x10000))
+ (dump-fop 'sb!impl::fop-small-code file)
+ (dump-byte num-consts file)
+ (dump-integer-as-n-bytes code-length 2 file))
+ (t
+ (dump-fop 'sb!impl::fop-code file)
+ (dump-unsigned-32 num-consts file)
+ (dump-unsigned-32 code-length file))))
+ (dump-segment segment code-length file)
+ (let ((code-handle (dump-pop file))
+ (patch-table (fasl-file-patch-table file)))
+ (dolist (patch (entry-patches))
+ (push (cons code-handle (cdr patch))
+ (gethash (car patch) patch-table)))
+ code-handle)))
+
+;;; Dump a BYTE-FUNCTION object. We dump the layout and
+;;; funcallable-instance info, but rely on the loader setting up the correct
+;;; funcallable-instance-function.
+(defun dump-byte-function (xep code-handle file)
+ (let ((nslots (- (get-closure-length xep)
+ ;; 1- for header
+ (1- sb!vm:funcallable-instance-info-offset))))
+ (dotimes (i nslots)
+ (if (zerop i)
+ (dump-push code-handle file)
+ (dump-object (%funcallable-instance-info xep i) file)))
+ (dump-object (%funcallable-instance-layout xep) file)
+ (dump-fop 'sb!impl::fop-make-byte-compiled-function file)
+ (dump-byte nslots file))
+ (values))
+
+;;; Dump a byte-component. This is similar to FASL-DUMP-COMPONENT, but
+;;; different.
+(defun fasl-dump-byte-component (segment length constants xeps file)
+ (declare (type sb!assem:segment segment)
+ (type index length)
+ (type vector constants)
+ (type list xeps)
+ (type fasl-file file))
+
+ (let ((code-handle (dump-byte-code-object segment length constants file)))
+ (dolist (noise xeps)
+ (let* ((lambda (car noise))
+ (info (lambda-info lambda))
+ (xep (cdr noise)))
+ (dump-byte-function xep code-handle file)
+ (let* ((entry-handle (dump-pop file))
+ (patch-table (fasl-file-patch-table file))
+ (old (gethash info patch-table)))
+ (setf (gethash info (fasl-file-entry-table file)) entry-handle)
+ (when old
+ (dolist (patch old)
+ (dump-alter-code-object (car patch)
+ (cdr patch)
+ entry-handle
+ file))
+ (remhash info patch-table))))))
+ (values))
+
+;;; Dump a FOP-FUNCALL to call an already dumped top-level lambda at load time.
+(defun fasl-dump-top-level-lambda-call (fun file)
+ (declare (type clambda fun) (type fasl-file file))
+ (let ((handle (gethash (leaf-info fun) (fasl-file-entry-table file))))
+ (assert handle)
+ (dump-push handle file)
+ (dump-fop 'sb!impl::fop-funcall-for-effect file)
+ (dump-byte 0 file))
+ (values))
+
+;;; Compute the correct list of DEBUG-SOURCE structures and backpatch all of
+;;; the dumped DEBUG-INFO structures. We clear the FASL-FILE-DEBUG-INFO,
+;;; so that subsequent components with different source info may be dumped.
+(defun fasl-dump-source-info (info file)
+ (declare (type source-info info) (type fasl-file file))
+ (let ((res (debug-source-for-info info))
+ (*dump-only-valid-structures* nil))
+ (dump-object res file)
+ (let ((res-handle (dump-pop file)))
+ (dolist (info-handle (fasl-file-debug-info file))
+ (dump-push res-handle file)
+ (dump-fop 'sb!impl::fop-structset file)
+ (dump-unsigned-32 info-handle file)
+ (dump-unsigned-32 2 file))))
+
+ (setf (fasl-file-debug-info file) ())
+ (values))
+\f
+;;;; dumping structures
+
+(defun dump-structure (struct file)
+ ;; FIXME: Probably *DUMP-ONLY-VALID-STRUCTURES* should become constantly T,
+ ;; right?
+ (when *dump-only-valid-structures*
+ (unless (gethash struct (fasl-file-valid-structures file))
+ (error "attempt to dump invalid structure:~% ~S~%How did this happen?"
+ struct)))
+ (note-potential-circularity struct file)
+ (do ((index 0 (1+ index))
+ (length (%instance-length struct))
+ (circ (fasl-file-circularity-table file)))
+ ((= index length)
+ (dump-fop* length
+ sb!impl::fop-small-struct
+ sb!impl::fop-struct
+ file))
+ (let* ((obj (%instance-ref struct index))
+ (ref (gethash obj circ)))
+ (cond (ref
+ (push (make-circularity :type :struct-set
+ :object struct
+ :index index
+ :value obj
+ :enclosing-object ref)
+ *circularities-detected*)
+ (sub-dump-object nil file))
+ (t
+ (sub-dump-object obj file))))))
+
+(defun dump-layout (obj file)
+ (when (layout-invalid obj)
+ (compiler-error "attempt to dump reference to obsolete class: ~S"
+ (layout-class obj)))
+ (let ((name (sb!xc:class-name (layout-class obj))))
+ (unless name
+ (compiler-error "dumping anonymous layout: ~S" obj))
+ (dump-fop 'sb!impl::fop-normal-load file)
+ (let ((*cold-load-dump* t))
+ (dump-object name file))
+ (dump-fop 'sb!impl::fop-maybe-cold-load file))
+ (sub-dump-object (layout-inherits obj) file)
+ (sub-dump-object (layout-depthoid obj) file)
+ (sub-dump-object (layout-length obj) file)
+ (dump-fop 'sb!impl::fop-layout file))
--- /dev/null
+;;;; support for collecting dynamic vop statistics
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!DYNCOUNT")
+
+(file-comment
+ "$Header$")
+
+(defvar *collect-dynamic-statistics* nil
+ #!+sb-doc
+ "When T, emit extra code to collect dynamic statistics about vop usages.")
+
+(defvar *dynamic-counts-tn* nil
+ #!+sb-doc
+ "Holds the TN for the counts vector.")
+
+(def!struct (dyncount-info (:make-load-form-fun just-dump-it-normally))
+ for
+ (costs (required-argument) :type (simple-array (unsigned-byte 32) (*)))
+ (counts (required-argument) :type (simple-array (unsigned-byte 32) (*))))
+
+(defprinter (dyncount-info)
+ for
+ costs
+ counts)
--- /dev/null
+;;;; constants and types for assembly
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!ASSEM")
+
+(sb!int:file-comment
+ "$Header$")
+
+;;; FIXME: It might make sense to use SB!VM:BYTE-FOO values here instead of the
+;;; various ASSEMBLY-UNIT-FOO things. One problem: BYTE is exported from the CL
+;;; package, so ANSI says that we're not supposed to be attaching any new
+;;; meanings to it. Perhaps rename SB!VM:BYTE-FOO to SB!VM:VMBYTE-FOO or
+;;; SB!VM:VM-BYTE-FOO, and then define the SB!VM:VMBYTE or SB!VM:VM-BYTE types?
+;;;
+;;; If this was done, some of this file could go away, and the rest
+;;; could probably be merged back into assem.lisp. (This file was created
+;;; simply in order to move the ASSEMBLY-UNIT-related definitions before
+;;; compiler/generic/core.lisp in the build sequence.
+
+;;; ASSEMBLY-UNIT-BITS -- the number of bits in the minimum assembly unit,
+;;; (also refered to as a ``byte''). Hopefully, different instruction
+;;; sets won't require changing this.
+(defconstant assembly-unit-bits 8)
+(defconstant assembly-unit-mask (1- (ash 1 assembly-unit-bits)))
+
+(deftype assembly-unit ()
+ `(unsigned-byte ,assembly-unit-bits))
+
+;;; Some functions which accept assembly units can meaningfully accept
+;;; signed values with the same number of bits and silently munge them
+;;; into appropriate unsigned values. (This is handy behavior e.g. when
+;;; assembling branch instructions on the X86.)
+(deftype possibly-signed-assembly-unit ()
+ `(or assembly-unit
+ (signed-byte ,assembly-unit-bits)))
+
+;;; the maximum alignment we can guarantee given the object
+;;; format. If the loader only loads objects 8-byte aligned, we can't do
+;;; any better then that ourselves.
+(defconstant max-alignment 3)
+
+(deftype alignment ()
+ `(integer 0 ,max-alignment))
+
+;;; the maximum an index will ever become. Well, actually,
+;;; just a bound on it so we can define a type. There is no real hard
+;;; limit on indexes, but we will run out of memory sometime.
+(defconstant max-index (1- most-positive-fixnum))
+
+(deftype index ()
+ `(integer 0 ,max-index))
+
+;;; like MAX-INDEX, except for positions
+(defconstant max-posn (1- most-positive-fixnum))
+
+(deftype posn ()
+ `(integer 0 ,max-posn))
+
--- /dev/null
+;;;; This file contains compiler code and compiler-related stuff which
+;;;; can be built early on. Some of the stuff may be here because it's
+;;;; needed early on, some other stuff (e.g. constants) just because
+;;;; it might as well be done early so we don't have to think about
+;;;; whether it's done early enough.
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!C")
+
+(file-comment
+ "$Header$")
+
+;;; FIXME: shouldn't SB-C::&MORE be in this list?
+(defconstant sb!xc:lambda-list-keywords
+ '(&optional &rest &key &aux &body &whole &allow-other-keys &environment)
+ #!+sb-doc
+ "symbols which are magical in a lambda list")
+\f
+;;;; cross-compiler-only versions of CL special variables, so that we
+;;;; don't have weird interactions with the host compiler
+
+(defvar sb!xc:*compile-file-pathname*)
+(defvar sb!xc:*compile-file-truename*)
+(defvar sb!xc:*compile-print*)
+(defvar sb!xc:*compile-verbose*)
+\f
+;;;; miscellaneous types used both in the cross-compiler and on the target
+
+;;;; FIXME: The INDEX and LAYOUT-DEPTHOID definitions probably belong
+;;;; somewhere else, not "early-c", since they're after all not part
+;;;; of the compiler.
+
+(def!type sb!kernel:index () `(integer 0 (,sb!xc:array-dimension-limit)))
+
+;;; the type of LAYOUT-DEPTHOID slot values
+(def!type sb!kernel::layout-depthoid () '(or index (integer -1 -1)))
+
+;;; a value for an optimization declaration
+(def!type sb!c::cookie-quality () '(or (rational 0 3) null))
+\f
+;;; A COOKIE holds information about the compilation environment for a
+;;; node. See the LEXENV definition for a description of how it is
+;;; used.
+(def!struct (cookie (:copier nil))
+ (speed nil :type cookie-quality)
+ (space nil :type cookie-quality)
+ (safety nil :type cookie-quality)
+ (cspeed nil :type cookie-quality)
+ (brevity nil :type cookie-quality)
+ (debug nil :type cookie-quality))
+
+;;; KLUDGE: This needs to be executable in cold init toplevel forms, earlier
+;;; than the default copier closure created by DEFSTRUCT toplevel forms would
+;;; be available, and earlier than LAYOUT-INFO is initialized (which is a
+;;; prerequisite for COPY-STRUCTURE to work), so we define it explicitly using
+;;; DEFUN, so that it can be installed by the cold loader, and using
+;;; hand-written, hand-maintained slot-by-slot copy it doesn't need to call
+;;; COPY-STRUCTURE. -- WHN 19991019
+(defun copy-cookie (cookie)
+ (make-cookie :speed (cookie-speed cookie)
+ :space (cookie-space cookie)
+ :safety (cookie-safety cookie)
+ :cspeed (cookie-cspeed cookie)
+ :brevity (cookie-brevity cookie)
+ :debug (cookie-debug cookie)))
+
+;;; *DEFAULT-COOKIE* holds the current global compiler policy information.
+;;; Whenever the policy is changed, we copy the structure so that old uses will
+;;; still get the old values. *DEFAULT-INTERFACE-COOKIE* holds any values
+;;; specified by an OPTIMIZE-INTERFACE declaration.
+;;;
+;;; FIXME: Why isn't COOKIE called POLICY?
+(declaim (type cookie *default-cookie* *default-interface-cookie*))
+(defvar *default-cookie*) ; initialized in cold init
+(defvar *default-interface-cookie*) ; initialized in cold init
+
+;;; possible values for the INLINE-ness of a function.
+(deftype inlinep ()
+ '(member :inline :maybe-inline :notinline nil))
+(defconstant inlinep-translations
+ '((inline . :inline)
+ (notinline . :notinline)
+ (maybe-inline . :maybe-inline)))
+
+;;; The lexical environment we are currently converting in.
+(defvar *lexenv*)
+(declaim (type lexenv *lexenv*))
+
+;;; *FREE-VARIABLES* translates from the names of variables referenced
+;;; globally to the LEAF structures for them. *FREE-FUNCTIONS* is like
+;;; *FREE-VARIABLES*, only it deals with function names.
+(defvar *free-variables*)
+(defvar *free-functions*)
+(declaim (hash-table *free-variables* *free-functions*))
+
+;;; We use the same Constant structure to represent all equal anonymous
+;;; constants. This hashtable translates from constants to the Leafs that
+;;; represent them.
+(defvar *constants*)
+(declaim (hash-table *constants*))
+
+;;; miscellaneous forward declarations
+(defvar *code-segment*)
+#!+sb-dyncount (defvar *collect-dynamic-statistics*)
+(defvar *component-being-compiled*)
+(defvar *compiler-error-context*)
+(defvar *compiler-error-count*)
+(defvar *compiler-warning-count*)
+(defvar *compiler-style-warning-count*)
+(defvar *compiler-note-count*)
+(defvar *converting-for-interpreter*)
+(defvar *count-vop-usages*)
+(defvar *current-path*)
+(defvar *current-component*)
+(defvar *default-cookie*)
+(defvar *default-interface-cookie*)
+(defvar *dynamic-counts-tn*)
+(defvar *elsewhere*)
+(defvar *event-info*)
+(defvar *event-note-threshold*)
+(defvar *failure-p*)
+(defvar *fixups*)
+(defvar *in-pack*)
+(defvar *info-environment*)
+(defvar *lexenv*)
+(defvar *source-info*)
+(defvar *trace-table*)
+(defvar *undefined-warnings*)
+(defvar *warnings-p*)
+\f
+;;;; miscellaneous utilities
+
+;;; Delete any undefined warnings for NAME and KIND. This is for the
+;;; benefit of the compiler, but it's sometimes called from stuff like
+;;; type-defining code which isn't logically part of the compiler.
+(declaim (ftype (function ((or symbol cons) keyword) (values))
+ note-name-defined))
+(defun note-name-defined (name kind)
+ ;; We do this BOUNDP check because this function can be called when
+ ;; not in a compilation unit (as when loading top-level forms).
+ (when (boundp '*undefined-warnings*)
+ (setq *undefined-warnings*
+ (delete-if (lambda (x)
+ (and (equal (undefined-warning-name x) name)
+ (eq (undefined-warning-kind x) kind)))
+ *undefined-warnings*)))
+ (values))
+
+;;; 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:
+ ;; (DEFVAR *FOO*)
+ ;; (DEFUN FOO (X) (1+ X *FOO*))
+ ;; bar.lisp:
+ ;; (DEFUN BAR (X)
+ ;; (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)))))
+ (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)))
+ (values))
--- /dev/null
+;;;; Code in this file handles VM-independent details of run-time
+;;;; function representation that primarily concern IR2 conversion and
+;;;; the dumper/loader.
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!C")
+
+(file-comment
+ "$Header$")
+
+;;; This phase runs before IR2 conversion, initializing each XEP's
+;;; Entry-Info structure. We call the VM-supplied
+;;; Select-Component-Format function to make VM-dependent
+;;; initializations in the IR2-Component. This includes setting the
+;;; IR2-Component-Kind and allocating fixed implementation overhead in
+;;; the constant pool. If there was a forward reference to a function,
+;;; then the ENTRY-INFO will already exist, but will be uninitialized.
+(defun entry-analyze (component)
+ (let ((2comp (component-info component)))
+ (dolist (fun (component-lambdas component))
+ (when (external-entry-point-p fun)
+ (let ((info (or (leaf-info fun)
+ (setf (leaf-info fun) (make-entry-info)))))
+ (compute-entry-info fun info)
+ (push info (ir2-component-entries 2comp))))))
+
+ (select-component-format component)
+ (values))
+
+;;; Takes the list representation of the debug arglist and turns it
+;;; into a string.
+;;;
+;;; FIXME: Why don't we just save this as a list instead of converting
+;;; it to a string?
+(defun make-arg-names (x)
+ (declare (type functional x))
+ (let ((args (functional-arg-documentation x)))
+ (assert (not (eq args :unspecified)))
+ (if (null args)
+ "()"
+ (let ((*print-pretty* t)
+ (*print-escape* t)
+ (*print-base* 10)
+ (*print-radix* nil)
+ (*print-case* :downcase))
+ (write-to-string args)))))
+
+;;; Initialize Info structure to correspond to the XEP lambda Fun.
+(defun compute-entry-info (fun info)
+ (declare (type clambda fun) (type entry-info info))
+ (let ((bind (lambda-bind fun))
+ (internal-fun (functional-entry-function fun)))
+ (setf (entry-info-closure-p info)
+ (not (null (environment-closure (lambda-environment fun)))))
+ (setf (entry-info-offset info) (gen-label))
+ (setf (entry-info-name info)
+ (let ((name (leaf-name internal-fun)))
+ (or name
+ (component-name (block-component (node-block bind))))))
+ (when (policy bind (>= debug 1))
+ (setf (entry-info-arguments info) (make-arg-names internal-fun))
+ (setf (entry-info-type info) (type-specifier (leaf-type internal-fun)))))
+ (values))
+
+;;; Replace all references to Component's non-closure XEPS that appear in
+;;; top-level components, changing to :TOP-LEVEL-XEP functionals. If the
+;;; cross-component ref is not in a :TOP-LEVEL component, or is to a closure,
+;;; then substitution is suppressed.
+;;;
+;;; When a cross-component ref is not substituted, we return T to indicate that
+;;; early deletion of this component's IR1 should not be done. We also return
+;;; T if this component contains :TOP-LEVEL lambdas (though it is not a
+;;; :TOP-LEVEL component.)
+;;;
+;;; We deliberately don't use the normal reference deletion, since we don't
+;;; want to trigger deletion of the XEP (although it shouldn't hurt, since this
+;;; is called after Component is compiled.) Instead, we just clobber the
+;;; REF-LEAF.
+(defun replace-top-level-xeps (component)
+ (let ((res nil))
+ (dolist (lambda (component-lambdas component))
+ (case (functional-kind lambda)
+ (:external
+ (let* ((ef (functional-entry-function lambda))
+ (new (make-functional :kind :top-level-xep
+ :info (leaf-info lambda)
+ :name (leaf-name ef)
+ :lexenv (make-null-lexenv)))
+ (closure (environment-closure
+ (lambda-environment (main-entry ef)))))
+ (dolist (ref (leaf-refs lambda))
+ (let ((ref-component (block-component (node-block ref))))
+ (cond ((eq ref-component component))
+ ((or (not (eq (component-kind ref-component) :top-level))
+ closure)
+ (setq res t))
+ (t
+ (setf (ref-leaf ref) new)
+ (push ref (leaf-refs new))))))))
+ (:top-level
+ (setq res t))))
+ res))
--- /dev/null
+;;;; This file implements the environment analysis phase for the
+;;;; compiler. This phase annotates IR1 with a hierarchy environment
+;;;; structures, determining the environment that each Lambda
+;;;; allocates its variables and finding what values are closed over
+;;;; by each environment.
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!C")
+
+(file-comment
+ "$Header$")
+
+;;; Do environment analysis on the code in Component. This involves
+;;; various things:
+;;; 1. Make an Environment structure for each non-let lambda, assigning
+;;; the lambda-environment for all lambdas.
+;;; 2. Find all values that need to be closed over by each environment.
+;;; 3. Scan the blocks in the component closing over non-local-exit
+;;; continuations.
+;;; 4. Delete all non-top-level functions with no references. This
+;;; should only get functions with non-NULL kinds, since normal
+;;; functions are deleted when their references go to zero. If
+;;; *byte-compiling*, then don't delete optional entries with no
+;;; references, since the byte interpreter wants to call entries
+;;; that the XEP doesn't.
+(defun environment-analyze (component)
+ (declare (type component component))
+ (assert (every #'(lambda (x)
+ (eq (functional-kind x) :deleted))
+ (component-new-functions component)))
+ (setf (component-new-functions component) ())
+ (dolist (fun (component-lambdas component))
+ (reinit-lambda-environment fun))
+ (dolist (fun (component-lambdas component))
+ (compute-closure fun)
+ (dolist (let (lambda-lets fun))
+ (compute-closure let)))
+
+ (find-non-local-exits component)
+ (find-cleanup-points component)
+ (tail-annotate component)
+
+ (dolist (fun (component-lambdas component))
+ (when (null (leaf-refs fun))
+ (let ((kind (functional-kind fun)))
+ (unless (or (eq kind :top-level)
+ (and *byte-compiling* (eq kind :optional)))
+ (assert (member kind '(:optional :cleanup :escape)))
+ (setf (functional-kind fun) nil)
+ (delete-functional fun)))))
+
+ (values))
+
+;;; Called on component with top-level lambdas before the compilation of the
+;;; associated non-top-level code to detect closed over top-level variables.
+;;; We just do COMPUTE-CLOSURE on all the lambdas. This will pre-allocate
+;;; environments for all the functions with closed-over top-level variables.
+;;; The post-pass will use the existing structure, rather than allocating a new
+;;; one. We return true if we discover any possible closure vars.
+(defun pre-environment-analyze-top-level (component)
+ (declare (type component component))
+ (let ((found-it nil))
+ (dolist (lambda (component-lambdas component))
+ (when (compute-closure lambda)
+ (setq found-it t))
+ (dolist (let (lambda-lets lambda))
+ (when (compute-closure let)
+ (setq found-it t))))
+ found-it))
+
+;;; If Fun has an environment, return it, otherwise assign one.
+(defun get-lambda-environment (fun)
+ (declare (type clambda fun))
+ (let* ((fun (lambda-home fun))
+ (env (lambda-environment fun)))
+ (or env
+ (let ((res (make-environment :function fun)))
+ (setf (lambda-environment fun) res)
+ (dolist (lambda (lambda-lets fun))
+ (setf (lambda-environment lambda) res))
+ res))))
+
+;;; If Fun has no environment, assign one, otherwise clean up variables that
+;;; have no sets or refs. If a var has no references, we remove it from the
+;;; closure. If it has no sets, we clear the INDIRECT flag. This is
+;;; necessary because pre-analysis is done before optimization.
+(defun reinit-lambda-environment (fun)
+ (let ((old (lambda-environment (lambda-home fun))))
+ (cond (old
+ (setf (environment-closure old)
+ (delete-if #'(lambda (x)
+ (and (lambda-var-p x)
+ (null (leaf-refs x))))
+ (environment-closure old)))
+ (flet ((clear (fun)
+ (dolist (var (lambda-vars fun))
+ (unless (lambda-var-sets var)
+ (setf (lambda-var-indirect var) nil)))))
+ (clear fun)
+ (dolist (let (lambda-lets fun))
+ (clear let))))
+ (t
+ (get-lambda-environment fun))))
+ (values))
+
+;;; Get node's environment, assigning one if necessary.
+(defun get-node-environment (node)
+ (declare (type node node))
+ (get-lambda-environment (node-home-lambda node)))
+
+;;; Find any variables in Fun with references outside of the home
+;;; environment and close over them. If a closed over variable is set, then we
+;;; set the Indirect flag so that we will know the closed over value is really
+;;; a pointer to the value cell. We also warn about unreferenced variables
+;;; here, just because it's a convenient place to do it. We return true if we
+;;; close over anything.
+(defun compute-closure (fun)
+ (declare (type clambda fun))
+ (let ((env (get-lambda-environment fun))
+ (did-something nil))
+ (note-unreferenced-vars fun)
+ (dolist (var (lambda-vars fun))
+ (dolist (ref (leaf-refs var))
+ (let ((ref-env (get-node-environment ref)))
+ (unless (eq ref-env env)
+ (when (lambda-var-sets var)
+ (setf (lambda-var-indirect var) t))
+ (setq did-something t)
+ (close-over var ref-env env))))
+ (dolist (set (basic-var-sets var))
+ (let ((set-env (get-node-environment set)))
+ (unless (eq set-env env)
+ (setq did-something t)
+ (setf (lambda-var-indirect var) t)
+ (close-over var set-env env)))))
+ did-something))
+
+;;; Make sure that Thing is closed over in Ref-Env and in all environments
+;;; for the functions that reference Ref-Env's function (not just calls.)
+;;; Home-Env is Thing's home environment. When we reach the home environment,
+;;; we stop propagating the closure.
+(defun close-over (thing ref-env home-env)
+ (declare (type environment ref-env home-env))
+ (cond ((eq ref-env home-env))
+ ((member thing (environment-closure ref-env)))
+ (t
+ (push thing (environment-closure ref-env))
+ (dolist (call (leaf-refs (environment-function ref-env)))
+ (close-over thing (get-node-environment call) home-env))))
+ (values))
+\f
+;;;; non-local exit
+
+;;; Insert the entry stub before the original exit target, and add a new
+;;; entry to the Environment-Nlx-Info. The %NLX-Entry call in the stub is
+;;; passed the NLX-Info as an argument so that the back end knows what entry is
+;;; being done.
+;;;
+;;; The link from the Exit block to the entry stub is changed to be a link to
+;;; the component head. Similarly, the Exit block is linked to the component
+;;; tail. This leaves the entry stub reachable, but makes the flow graph less
+;;; confusing to flow analysis.
+;;;
+;;; If a catch or an unwind-protect, then we set the Lexenv for the last node
+;;; in the cleanup code to be the enclosing environment, to represent the fact
+;;; that the binding was undone as a side-effect of the exit. This will cause
+;;; a lexical exit to be broken up if we are actually exiting the scope (i.e.
+;;; a BLOCK), and will also do any other cleanups that may have to be done on
+;;; the way.
+(defun insert-nlx-entry-stub (exit env)
+ (declare (type environment env) (type exit exit))
+ (let* ((exit-block (node-block exit))
+ (next-block (first (block-succ exit-block)))
+ (cleanup (entry-cleanup (exit-entry exit)))
+ (info (make-nlx-info :cleanup cleanup
+ :continuation (node-cont exit)))
+ (entry (exit-entry exit))
+ (new-block (insert-cleanup-code exit-block next-block
+ entry
+ `(%nlx-entry ',info)
+ (entry-cleanup entry)))
+ (component (block-component new-block)))
+ (unlink-blocks exit-block new-block)
+ (link-blocks exit-block (component-tail component))
+ (link-blocks (component-head component) new-block)
+
+ (setf (nlx-info-target info) new-block)
+ (push info (environment-nlx-info env))
+ (push info (cleanup-nlx-info cleanup))
+ (when (member (cleanup-kind cleanup) '(:catch :unwind-protect))
+ (setf (node-lexenv (block-last new-block))
+ (node-lexenv entry))))
+
+ (values))
+
+;;; Do stuff necessary to represent a non-local exit from the node Exit into
+;;; Env. This is called for each non-local exit node, of which there may be
+;;; several per exit continuation. This is what we do:
+;;; -- If there isn't any NLX-Info entry in the environment, make an entry
+;;; stub, otherwise just move the exit block link to the component tail.
+;;; -- Close over the NLX-Info in the exit environment.
+;;; -- If the exit is from an :Escape function, then substitute a constant
+;;; reference to NLX-Info structure for the escape function reference. This
+;;; will cause the escape function to be deleted (although not removed from
+;;; the DFO.) The escape function is no longer needed, and we don't want to
+;;; emit code for it. We then also change the %NLX-ENTRY call to use
+;;; the NLX continuation so that there will be a use to represent the NLX
+;;; use.
+(defun note-non-local-exit (env exit)
+ (declare (type environment env) (type exit exit))
+ (let ((entry (exit-entry exit))
+ (cont (node-cont exit))
+ (exit-fun (node-home-lambda exit)))
+
+ (if (find-nlx-info entry cont)
+ (let ((block (node-block exit)))
+ (assert (= (length (block-succ block)) 1))
+ (unlink-blocks block (first (block-succ block)))
+ (link-blocks block (component-tail (block-component block))))
+ (insert-nlx-entry-stub exit env))
+
+ (let ((info (find-nlx-info entry cont)))
+ (assert info)
+ (close-over info (node-environment exit) env)
+ (when (eq (functional-kind exit-fun) :escape)
+ (mapc #'(lambda (x)
+ (setf (node-derived-type x) *wild-type*))
+ (leaf-refs exit-fun))
+ (substitute-leaf (find-constant info) exit-fun)
+ (let ((node (block-last (nlx-info-target info))))
+ (delete-continuation-use node)
+ (add-continuation-use node (nlx-info-continuation info))))))
+
+ (values))
+
+;;; Iterate over the Exits in Component, calling Note-Non-Local-Exit when we
+;;; find a block that ends in a non-local Exit node. We also ensure that all
+;;; Exit nodes are either non-local or degenerate by calling IR1-Optimize-Exit
+;;; on local exits. This makes life simpler for later phases.
+(defun find-non-local-exits (component)
+ (declare (type component component))
+ (dolist (lambda (component-lambdas component))
+ (dolist (entry (lambda-entries lambda))
+ (dolist (exit (entry-exits entry))
+ (let ((target-env (node-environment entry)))
+ (if (eq (node-environment exit) target-env)
+ (unless *converting-for-interpreter*
+ (maybe-delete-exit exit))
+ (note-non-local-exit target-env exit))))))
+
+ (values))
+\f
+;;;; cleanup emission
+
+;;; Zoom up the cleanup nesting until we hit Cleanup1, accumulating cleanup
+;;; code as we go. When we are done, convert the cleanup code in an implicit
+;;; MV-Prog1. We have to force local call analysis of new references to
+;;; Unwind-Protect cleanup functions. If we don't actually have to do
+;;; anything, then we don't insert any cleanup code.
+;;;
+;;; If we do insert cleanup code, we check that Block1 doesn't end in a "tail"
+;;; local call.
+;;;
+;;; We don't need to adjust the ending cleanup of the cleanup block, since
+;;; the cleanup blocks are inserted at the start of the DFO, and are thus never
+;;; scanned.
+(defun emit-cleanups (block1 block2)
+ (declare (type cblock block1 block2))
+ (collect ((code)
+ (reanalyze-funs))
+ (let ((cleanup2 (block-start-cleanup block2)))
+ (do ((cleanup (block-end-cleanup block1)
+ (node-enclosing-cleanup (cleanup-mess-up cleanup))))
+ ((eq cleanup cleanup2))
+ (let* ((node (cleanup-mess-up cleanup))
+ (args (when (basic-combination-p node)
+ (basic-combination-args node))))
+ (ecase (cleanup-kind cleanup)
+ (:special-bind
+ (code `(%special-unbind ',(continuation-value (first args)))))
+ (:catch
+ (code `(%catch-breakup)))
+ (:unwind-protect
+ (code `(%unwind-protect-breakup))
+ (let ((fun (ref-leaf (continuation-use (second args)))))
+ (reanalyze-funs fun)
+ (code `(%funcall ,fun))))
+ ((:block :tagbody)
+ (dolist (nlx (cleanup-nlx-info cleanup))
+ (code `(%lexical-exit-breakup ',nlx)))))))
+
+ (when (code)
+ (assert (not (node-tail-p (block-last block1))))
+ (insert-cleanup-code block1 block2
+ (block-last block1)
+ `(progn ,@(code)))
+ (dolist (fun (reanalyze-funs))
+ (local-call-analyze-1 fun)))))
+
+ (values))
+
+;;; Loop over the blocks in component, calling Emit-Cleanups when we see a
+;;; successor in the same environment with a different cleanup. We ignore the
+;;; cleanup transition if it is to a cleanup enclosed by the current cleanup,
+;;; since in that case we are just messing up the environment, hence this is
+;;; not the place to clean it.
+(defun find-cleanup-points (component)
+ (declare (type component component))
+ (do-blocks (block1 component)
+ (let ((env1 (block-environment block1))
+ (cleanup1 (block-end-cleanup block1)))
+ (dolist (block2 (block-succ block1))
+ (when (block-start block2)
+ (let ((env2 (block-environment block2))
+ (cleanup2 (block-start-cleanup block2)))
+ (unless (or (not (eq env2 env1))
+ (eq cleanup1 cleanup2)
+ (and cleanup2
+ (eq (node-enclosing-cleanup
+ (cleanup-mess-up cleanup2))
+ cleanup1)))
+ (emit-cleanups block1 block2)))))))
+ (values))
+
+;;; Mark all tail-recursive uses of function result continuations with the
+;;; corresponding tail-set. Nodes whose type is NIL (i.e. don't return) such
+;;; as calls to ERROR are never annotated as tail in order to preserve
+;;; debugging information.
+(defun tail-annotate (component)
+ (declare (type component component))
+ (dolist (fun (component-lambdas component))
+ (let ((ret (lambda-return fun)))
+ (when ret
+ (let ((result (return-result ret)))
+ (do-uses (use result)
+ (when (and (immediately-used-p result use)
+ (or (not (eq (node-derived-type use) *empty-type*))
+ (not (basic-combination-p use))
+ (eq (basic-combination-kind use) :local)))
+ (setf (node-tail-p use) t)))))))
+ (values))
--- /dev/null
+;;;; This file represents the current state of on-going development on
+;;;; compiler hooks for an interpreter that takes the compiler's IR1 of
+;;;; a program.
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!C")
+
+(file-comment
+ "$Header$")
+
+;;; FIXME: Doesn't this belong somewhere else, like early-c.lisp?
+(declaim (special *constants* *free-variables* *component-being-compiled*
+ *code-vector* *next-location* *result-fixups*
+ *free-functions* *source-paths* *failed-optimizations*
+ *seen-blocks* *seen-functions* *list-conflicts-table*
+ *continuation-number* *continuation-numbers*
+ *number-continuations* *tn-id* *tn-ids* *id-tns*
+ *label-ids* *label-id* *id-labels*
+ *compiler-error-count* *compiler-warning-count*
+ *compiler-style-warning-count* *compiler-note-count*
+ *compiler-error-bailout*
+ #!+sb-show *compiler-trace-output*
+ *last-source-context* *last-original-source*
+ *last-source-form* *last-format-string* *last-format-args*
+ *last-message-count* *check-consistency*
+ *all-components* *converting-for-interpreter*
+ *source-info* *block-compile* *current-path*
+ *current-component* *lexenv*))
+\f
+;;; Translate form into the compiler's IR1 and perform environment
+;;; analysis. This is sort of a combination of COMPILE-FILE,
+;;; SUB-COMPILE-FILE, COMPILE-TOP-LEVEL, and COMPILE-COMPONENT.
+(defun compile-for-eval (form quietly)
+ (with-ir1-namespace
+ (let* ((*block-compile* nil)
+ (*lexenv* (make-null-lexenv))
+ (*compiler-error-bailout*
+ #'(lambda () (error "fatal error, aborting evaluation")))
+ (*current-path* nil)
+ (*last-source-context* nil)
+ (*last-original-source* nil)
+ (*last-source-form* nil)
+ (*last-format-string* nil)
+ (*last-format-args* nil)
+ (*last-message-count* 0)
+ ;; These are now bound by WITH-COMPILATION-UNIT. -- WHN 20000308
+ #+nil (*compiler-error-count* 0)
+ #+nil (*compiler-warning-count* 0)
+ #+nil (*compiler-style-warning-count* 0)
+ #+nil (*compiler-note-count* 0)
+ (*source-info* (make-lisp-source-info form))
+ (*converting-for-interpreter* t)
+ (*gensym-counter* 0)
+ (*warnings-p* nil)
+ (*failure-p* nil))
+
+ (clear-stuff nil)
+ (find-source-paths form 0)
+ ;; This LET comes from COMPILE-TOP-LEVEL.
+ ;; The noted DOLIST is a splice from a call that COMPILE-TOP-LEVEL makes.
+ (sb!xc:with-compilation-unit ()
+ (let ((lambdas (list (ir1-top-level form
+ '(original-source-start 0 0)
+ t))))
+ (declare (list lambdas))
+ (dolist (lambda lambdas)
+ (let* ((component
+ (block-component (node-block (lambda-bind lambda))))
+ (*all-components* (list component)))
+ (local-call-analyze component)))
+ (multiple-value-bind (components top-components)
+ (find-initial-dfo lambdas)
+ (let ((*all-components* (append components top-components)))
+ (when *check-consistency*
+ (check-ir1-consistency *all-components*))
+ ;; This DOLIST body comes from the beginning of
+ ;; COMPILE-COMPONENT.
+ (dolist (component *all-components*)
+ (ir1-finalize component)
+ (let ((*component-being-compiled* component))
+ (environment-analyze component))
+ (annotate-component-for-eval component))
+ (when *check-consistency*
+ (check-ir1-consistency *all-components*))))
+ (car lambdas))))))
+\f
+;;;; annotating IR1 for interpretation
+
+(defstruct (lambda-eval-info (:constructor make-lambda-eval-info
+ (frame-size args-passed entries)))
+ frame-size ; number of stack locations needed to hold locals
+ args-passed ; number of referenced arguments passed to lambda
+ entries ; a-list mapping entry nodes to stack locations
+ (function nil)) ; a function object corresponding to this lambda
+(def!method print-object ((obj lambda-eval-info) str)
+ (print-unreadable-object (obj str :type t)))
+
+(defstruct (entry-node-info (:constructor make-entry-node-info
+ (st-top nlx-tag)))
+ st-top ; stack top when we encounter the entry node
+ nlx-tag) ; tag to which to throw to get back entry node's context
+(def!method print-object ((obj entry-node-info) str)
+ (print-unreadable-object (obj str :type t)))
+
+;;; Some compiler funny functions have definitions, so the interpreter can
+;;; call them. These require special action to coordinate the interpreter,
+;;; system call stack, and the environment. The annotation prepass marks the
+;;; references to these as :unused, so the interpreter doesn't try to fetch
+;;; functions through these undefined symbols.
+(defconstant undefined-funny-funs
+ '(%special-bind %special-unbind %more-arg-context %unknown-values %catch
+ %unwind-protect %catch-breakup %unwind-protect-breakup
+ %lexical-exit-breakup %continue-unwind %nlx-entry))
+
+;;; Some kinds of functions are only passed as arguments to funny functions,
+;;; and are never actually evaluated at run time.
+(defconstant non-closed-function-kinds '(:cleanup :escape))
+
+;;; This annotates continuations, lambda-vars, and lambdas. For each
+;;; continuation, we cache how its destination uses its value. This only buys
+;;; efficiency when the code executes more than once, but the overhead of this
+;;; part of the prepass for code executed only once should be negligible.
+;;;
+;;; As a special case to aid interpreting local function calls, we sometimes
+;;; note the continuation as :unused. This occurs when there is a local call,
+;;; and there is no actual function object to call; we mark the continuation as
+;;; :unused since there is nothing to push on the interpreter's stack.
+;;; Normally we would see a reference to a function that we would push on the
+;;; stack to later pop and apply to the arguments on the stack. To determine
+;;; when we have a local call with no real function object, we look at the node
+;;; to see whether it is a reference with a destination that is a :local
+;;; combination whose function is the reference node's continuation.
+;;;
+;;; After checking for virtual local calls, we check for funny functions the
+;;; compiler refers to for calling to note certain operations. These functions
+;;; are undefined, and if the interpreter tried to reference the function cells
+;;; of these symbols, it would get an error. We mark the continuations
+;;; delivering the values of these references as :unused, so the reference
+;;; never takes place.
+;;;
+;;; For each lambda-var, including a lambda's vars and its let's vars, we note
+;;; the stack offset used to access and store that variable. Then we note the
+;;; lambda with the total number of variables, so we know how big its stack
+;;; frame is. Also in the lambda's info is the number of its arguments that it
+;;; actually references; the interpreter never pushes or pops an unreferenced
+;;; argument, so we can't just use LENGTH on LAMBDA-VARS to know how many args
+;;; the caller passed.
+;;;
+;;; For each entry node in a lambda, we associate in the lambda-eval-info the
+;;; entry node with a stack offset. Evaluation code stores the frame pointer
+;;; in this slot upon processing the entry node to aid stack cleanup and
+;;; correct frame manipulation when processing exit nodes.
+(defun annotate-component-for-eval (component)
+ (do-blocks (b component)
+ (do-nodes (node cont b)
+ (let* ((dest (continuation-dest cont))
+ (refp (typep node 'ref))
+ (leaf (if refp (ref-leaf node))))
+ (setf (continuation-info cont)
+ (cond ((and refp dest (typep dest 'basic-combination)
+ (eq (basic-combination-kind dest) :local)
+ (eq (basic-combination-fun dest) cont))
+ :unused)
+ ((and leaf (typep leaf 'global-var)
+ (eq (global-var-kind leaf) :global-function)
+ (member (sb!c::global-var-name leaf)
+ undefined-funny-funs
+ :test #'eq))
+ :unused)
+ ((and leaf (typep leaf 'clambda)
+ (member (functional-kind leaf)
+ non-closed-function-kinds))
+ (assert (not (eq (functional-kind leaf) :escape)))
+ :unused)
+ (t
+ (typecase dest
+ ;; Change locations in eval.lisp that think :RETURN
+ ;; could occur.
+ ((or mv-combination creturn exit) :multiple)
+ (null :unused)
+ (t :single))))))))
+ (dolist (lambda (component-lambdas component))
+ (let ((locals-count 0)
+ (args-passed-count 0))
+ (dolist (var (lambda-vars lambda))
+ (setf (leaf-info var) locals-count)
+ (incf locals-count)
+ (when (leaf-refs var) (incf args-passed-count)))
+ (dolist (let (lambda-lets lambda))
+ (dolist (var (lambda-vars let))
+ (setf (leaf-info var) locals-count)
+ (incf locals-count)))
+ (let ((entries nil))
+ (dolist (e (lambda-entries lambda))
+ (ecase (process-entry-node-p e)
+ (:blow-it-off)
+ (:local-lexical-exit
+ (push (cons e (make-entry-node-info locals-count nil))
+ entries)
+ (incf locals-count))
+ (:non-local-lexical-exit
+ (push (cons e
+ (make-entry-node-info locals-count
+ (incf locals-count)))
+ entries)
+ (incf locals-count))))
+ (setf (lambda-info lambda)
+ (make-lambda-eval-info locals-count
+ args-passed-count
+ entries))))))
+
+(defun process-entry-node-p (entry)
+ (let ((entry-cleanup (entry-cleanup entry)))
+ (dolist (nlx (environment-nlx-info (node-environment entry))
+ :local-lexical-exit)
+ (let ((cleanup (nlx-info-cleanup nlx)))
+ (when (eq entry-cleanup cleanup)
+ (ecase (cleanup-kind cleanup)
+ ((:block :tagbody)
+ (return :non-local-lexical-exit))
+ ((:catch :unwind-protect)
+ (return :blow-it-off))))))))
+
+;;; Sometime consider annotations to exclude processing of exit nodes when
+;;; we want to do a tail-p thing.
+\f
+;;;; defining funny functions for interpreter
+
+#|
+%listify-rest-args %more-arg %verify-argument-count %argument-count-error
+%odd-keyword-arguments-error %unknown-keyword-argument-error
+|#
+
+(defun %verify-argument-count (supplied-args defined-args)
+ (unless (= supplied-args defined-args)
+ (error "Wrong argument count, wanted ~D and got ~D."
+ defined-args supplied-args))
+ (values))
+
+;;; Use (SETF SYMBOL-FUNCTION) instead of DEFUN so that the compiler
+;;; doesn't try to compile the hidden %THROW MV-CALL in the throw below as
+;;; a local recursive call.
+(setf (symbol-function '%throw)
+ #'(lambda (tag &rest args)
+ (throw tag (values-list args))))
+
+(defun %more-arg (args index)
+ (nth index args))
+
+(defun %listify-rest-args (ptr count)
+ (declare (ignore count))
+ ptr)
+
+(defun %more-arg-values (args start count)
+ (values-list (subseq args start count)))
+
+(defun %argument-count-error (args-passed-count)
+ (error 'simple-program-error
+ :format-control "wrong number of arguments passed: ~S"
+ :format-arguments (list args-passed-count)))
+
+(defun %odd-keyword-arguments-error ()
+ (error 'simple-program-error
+ :format-control "function called with odd number of keyword arguments"
+ :format-arguments nil))
+
+(defun %unknown-keyword-argument-error (keyword)
+ (error 'simple-program-error
+ :format-control "unknown keyword argument: ~S"
+ :format-arguments (list keyword)))
+
+(defun %cleanup-point ())
+
+(defun value-cell-ref (x) (value-cell-ref x))
--- /dev/null
+;;;; This file contains the IR1 interpreter. We first convert to the
+;;;; compiler's IR1, then interpret that.
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!EVAL")
+
+(file-comment
+ "$Header$")
+\f
+;;;; interpreter stack
+
+(defvar *interpreted-function-cache-minimum-size* 25
+ #!+sb-doc
+ "If the interpreted function cache has more functions than this come GC time,
+ then attempt to prune it according to
+ *INTERPRETED-FUNCTION-CACHE-THRESHOLD*.")
+
+(defvar *interpreted-function-cache-threshold* 3
+ #!+sb-doc
+ "If an interpreted function goes uncalled for more than this many GCs, then
+ it is eligible for flushing from the cache.")
+
+(declaim (type (and fixnum unsigned-byte)
+ *interpreted-function-cache-minimum-size*
+ *interpreted-function-cache-threshold*))
+
+;;; The list of INTERPRETED-FUNCTIONS that have translated definitions.
+(defvar *interpreted-function-cache* nil)
+(declaim (type list *interpreted-function-cache*))
+
+;;; Setting this causes the stack operations to dump a trace.
+;;;
+;;; FIXME: perhaps should be #!+SB-SHOW
+(defvar *eval-stack-trace* nil)
+
+;;; Push value on *eval-stack*, growing the stack if necessary. This returns
+;;; value. We save *eval-stack-top* in a local and increment the global before
+;;; storing value on the stack to prevent a GC timing problem. If we stored
+;;; value on the stack using *eval-stack-top* as an index, and we GC'ed before
+;;; incrementing *eval-stack-top*, then INTERPRETER-GC-HOOK would clear the
+;;; location.
+(defun eval-stack-push (value)
+ (let ((len (length (the simple-vector *eval-stack*))))
+ (when (= len *eval-stack-top*)
+ (when *eval-stack-trace* (format t "[PUSH: growing stack.]~%"))
+ (let ((new-stack (make-array (ash len 1))))
+ (replace new-stack *eval-stack* :end1 len :end2 len)
+ (setf *eval-stack* new-stack))))
+ (let ((top *eval-stack-top*))
+ (when *eval-stack-trace* (format t "pushing ~D.~%" top))
+ (incf *eval-stack-top*)
+ (setf (svref *eval-stack* top) value)))
+
+;;; This returns the last value pushed on *eval-stack* and decrements the top
+;;; pointer. We forego setting elements off the end of the stack to nil for GC
+;;; purposes because there is a *before-gc-hook* to take care of this for us.
+;;; However, because of the GC hook, we must be careful to grab the value
+;;; before decrementing *eval-stack-top* since we could GC between the
+;;; decrement and the reference, and the hook would clear the stack slot.
+(defun eval-stack-pop ()
+ (when (zerop *eval-stack-top*)
+ (error "attempt to pop empty eval stack"))
+ (let* ((new-top (1- *eval-stack-top*))
+ (value (svref *eval-stack* new-top)))
+ (when *eval-stack-trace* (format t "popping ~D --> ~S.~%" new-top value))
+ (setf *eval-stack-top* new-top)
+ value))
+
+;;; This allocates n locations on the stack, bumping the top pointer and
+;;; growing the stack if necessary. We set new slots to nil in case we GC
+;;; before having set them; we don't want to hold on to potential garbage
+;;; from old stack fluctuations.
+(defun eval-stack-extend (n)
+ (let ((len (length (the simple-vector *eval-stack*))))
+ (when (> (+ n *eval-stack-top*) len)
+ (when *eval-stack-trace* (format t "[EXTEND: growing stack.]~%"))
+ (let ((new-stack (make-array (+ n (ash len 1)))))
+ (replace new-stack *eval-stack* :end1 len :end2 len)
+ (setf *eval-stack* new-stack))))
+ (let ((new-top (+ *eval-stack-top* n)))
+ (when *eval-stack-trace* (format t "extending to ~D.~%" new-top))
+ (do ((i *eval-stack-top* (1+ i)))
+ ((= i new-top))
+ (setf (svref *eval-stack* i) nil))
+ (setf *eval-stack-top* new-top)))
+
+;;; The anthesis of EVAL-STACK-EXTEND.
+(defun eval-stack-shrink (n)
+ (when *eval-stack-trace*
+ (format t "shrinking to ~D.~%" (- *eval-stack-top* n)))
+ (decf *eval-stack-top* n))
+
+;;; This is used to shrink the stack back to a previous frame pointer.
+(defun eval-stack-set-top (ptr)
+ (when *eval-stack-trace* (format t "setting top to ~D.~%" ptr))
+ (setf *eval-stack-top* ptr))
+
+;;; This returns a local variable from the current stack frame. This is used
+;;; for references the compiler represents as a lambda-var leaf. This is a
+;;; macro for SETF purposes.
+;;;
+;;; FIXME: used only in this file, needn't be in runtime
+(defmacro eval-stack-local (fp offset)
+ `(svref *eval-stack* (+ ,fp ,offset)))
+\f
+;;;; interpreted functions
+
+;;; The list of INTERPRETED-FUNCTIONS that have translated definitions.
+(defvar *interpreted-function-cache* nil)
+(declaim (type list *interpreted-function-cache*))
+
+;;; Return a function that will lazily convert Lambda when called, and will
+;;; cache translations.
+(defun make-interpreted-function (lambda)
+ (let ((res (%make-interpreted-function :lambda lambda
+ :arglist (second lambda))))
+ (setf (funcallable-instance-function res)
+ #'(instance-lambda (&rest args)
+ (let ((fun (interpreted-function-definition res))
+ (args (cons (length args) args)))
+ (setf (interpreted-function-gcs res) 0)
+ (internal-apply (or fun (convert-interpreted-fun res))
+ args '#()))))
+ res))
+
+;;; Eval a FUNCTION form, grab the definition and stick it in.
+(defun convert-interpreted-fun (fun)
+ (declare (type interpreted-function fun))
+ (let* ((new (interpreted-function-definition
+ (internal-eval `#',(interpreted-function-lambda fun)
+ (interpreted-function-converted-once fun)))))
+ (setf (interpreted-function-definition fun) new)
+ (setf (interpreted-function-converted-once fun) t)
+ (let ((name (interpreted-function-%name fun)))
+ (setf (sb!c::leaf-name new) name)
+ (setf (sb!c::leaf-name (sb!c::main-entry
+ (sb!c::functional-entry-function new)))
+ name))
+ (push fun *interpreted-function-cache*)
+ new))
+
+;;; Get the CLAMBDA for the XEP, then look at the inline expansion info in
+;;; the real function.
+(defun interpreted-function-lambda-expression (x)
+ (let ((lambda (interpreted-function-lambda x)))
+ (if lambda
+ (values lambda nil (interpreted-function-%name x))
+ (let ((fun (sb!c::functional-entry-function
+ (interpreted-function-definition x))))
+ (values (sb!c::functional-inline-expansion fun)
+ (if (let ((env (sb!c::functional-lexenv fun)))
+ (or (sb!c::lexenv-functions env)
+ (sb!c::lexenv-variables env)
+ (sb!c::lexenv-blocks env)
+ (sb!c::lexenv-tags env)))
+ t nil)
+ (or (interpreted-function-%name x)
+ (sb!c::component-name
+ (sb!c::block-component
+ (sb!c::node-block
+ (sb!c::lambda-bind (sb!c::main-entry fun)))))))))))
+
+;;; Return a FUNCTION-TYPE describing an eval function. We just grab the
+;;; LEAF-TYPE of the definition, converting the definition if not currently
+;;; cached.
+(defvar *already-looking-for-type-of* nil)
+(defun interpreted-function-type (fun)
+ (if (member fun *already-looking-for-type-of*)
+ (specifier-type 'function)
+ (let* ((*already-looking-for-type-of*
+ (cons fun *already-looking-for-type-of*))
+ (def (or (interpreted-function-definition fun)
+ (sb!sys:without-gcing
+ (convert-interpreted-fun fun)
+ (interpreted-function-definition fun)))))
+ (sb!c::leaf-type (sb!c::functional-entry-function def)))))
+
+(defun interpreted-function-name (x)
+ (multiple-value-bind (ig1 ig2 res) (interpreted-function-lambda-expression x)
+ (declare (ignore ig1 ig2))
+ res))
+(defun (setf interpreted-function-name) (val x)
+ (let ((def (interpreted-function-definition x)))
+ (when def
+ (setf (sb!c::leaf-name def) val)
+ (setf (sb!c::leaf-name (sb!c::main-entry (sb!c::functional-entry-function
+ def)))
+ val))
+ (setf (interpreted-function-%name x) val)))
+
+(defun interpreter-gc-hook ()
+ ;; Clear the unused portion of the eval stack.
+ (let ((len (length (the simple-vector *eval-stack*))))
+ (do ((i *eval-stack-top* (1+ i)))
+ ((= i len))
+ (setf (svref *eval-stack* i) nil)))
+
+ ;; KLUDGE: I'd like to get rid of this, since it adds complexity and causes
+ ;; confusion. (It's not just academic that it causes confusion. When working
+ ;; on the original cross-compiler, I ran across what looked
+ ;; as though it might be a subtle writing-to-the-host-SBCL-compiler-data bug
+ ;; in my cross-compiler code, which turned out to be just a case of compiler
+ ;; warnings coming from recompilation of a flushed-from-the-cache interpreted
+ ;; function. Since it took me a long while to realize how many things the
+ ;; problem depended on (since it was tied up with magic numbers of GC cycles,
+ ;; egads!) I blew over a day trying to isolate the problem in a small test
+ ;; case.
+ ;;
+ ;; The cache-flushing seems to be motivated by efficiency concerns, which
+ ;; seem misplaced when the user chooses to use the interpreter. However, it
+ ;; also interacts with SAVE, and I veered off from deleting it wholesale when
+ ;; I noticed that. After the whole system is working, though, I'd like to
+ ;; revisit this decision. -- WHN 19990713
+ (let ((num (- (length *interpreted-function-cache*)
+ *interpreted-function-cache-minimum-size*)))
+ (when (plusp num)
+ (setq *interpreted-function-cache*
+ (delete-if #'(lambda (x)
+ (when (>= (interpreted-function-gcs x)
+ *interpreted-function-cache-threshold*)
+ (setf (interpreted-function-definition x) nil)
+ t))
+ *interpreted-function-cache*
+ :count num))))
+ (dolist (fun *interpreted-function-cache*)
+ (incf (interpreted-function-gcs fun))))
+(pushnew 'interpreter-gc-hook sb!ext:*before-gc-hooks*)
+
+(defun flush-interpreted-function-cache ()
+ #!+sb-doc
+ "Clear all entries in the eval function cache. This allows the internal
+ representation of the functions to be reclaimed, and also lazily forces
+ macroexpansions to be recomputed."
+ (dolist (fun *interpreted-function-cache*)
+ (setf (interpreted-function-definition fun) nil))
+ (setq *interpreted-function-cache* ()))
+\f
+;;;; INTERNAL-APPLY-LOOP macros
+
+;;;; These macros are intimately related to INTERNAL-APPLY-LOOP. They assume
+;;;; variables established by this function, and they assume they can return
+;;;; from a block by that name. This is sleazy, but we justify it as follows:
+;;;; They are so specialized in use, and their invocation became lengthy, that
+;;;; we allowed them to slime some access to things in their expanding
+;;;; environment. These macros don't really extend our Lisp syntax, but they do
+;;;; provide some template expansion service; it is these cleaner circumstance
+;;;; that require a more rigid programming style.
+;;;;
+;;;; Since these are macros expanded almost solely for COMBINATION nodes,
+;;;; they cascade from the end of this logical page to the beginning here.
+;;;; Therefore, it is best you start looking at them from the end of this
+;;;; section, backwards from normal scanning mode for Lisp code.
+
+;;; This runs a function on some arguments from the stack. If the combination
+;;; occurs in a tail recursive position, then we do the call such that we
+;;; return from tail-p-function with whatever values the call produces. With a
+;;; :local call, we have to restore the stack to its previous frame before
+;;; doing the call. The :full call mechanism does this for us. If it is NOT a
+;;; tail recursive call, and we're in a multiple value context, then then push
+;;; a list of the returned values. Do the same thing if we're in a :return
+;;; context. Push a single value, without listifying it, for a :single value
+;;; context. Otherwise, just call for side effect.
+;;;
+;;; Node is the combination node, and cont is its continuation. Frame-ptr
+;;; is the current frame pointer, and closure is the current environment for
+;;; closure variables. Call-type is either :full or :local, and when it is
+;;; local, lambda is the IR1 lambda to apply.
+;;;
+;;; This assumes the following variables are present: node, cont, frame-ptr,
+;;; and closure. It also assumes a block named internal-apply-loop.
+;;;
+;;; FIXME: used only in this file, needn't be in runtime
+;;; FIXME: down with DO-FOO names for non-iteration constructs!
+(defmacro do-combination (call-type lambda mv-or-normal)
+ (let* ((args (gensym))
+ (calling-closure (gensym))
+ (invoke-fun (ecase mv-or-normal
+ (:mv-call 'mv-internal-invoke)
+ (:normal 'internal-invoke)))
+ (args-form (ecase mv-or-normal
+ (:mv-call
+ `(mv-eval-stack-args
+ (length (sb!c::mv-combination-args node))))
+ (:normal
+ `(eval-stack-args (sb!c:lambda-eval-info-args-passed
+ (sb!c::lambda-info ,lambda))))))
+ (call-form (ecase call-type
+ (:full `(,invoke-fun
+ (length (sb!c::basic-combination-args node))))
+ (:local `(internal-apply
+ ,lambda ,args-form
+ (compute-closure node ,lambda frame-ptr
+ closure)
+ nil))))
+ (tailp-call-form
+ (ecase call-type
+ (:full `(return-from
+ internal-apply-loop
+ ;; INVOKE-FUN takes care of the stack itself.
+ (,invoke-fun (length (sb!c::basic-combination-args node))
+ frame-ptr)))
+ (:local `(let ((,args ,args-form)
+ (,calling-closure
+ (compute-closure node ,lambda frame-ptr closure)))
+ ;; No need to clean up stack slots for GC due to
+ ;; SB!EXT:*BEFORE-GC-HOOK*.
+ (eval-stack-set-top frame-ptr)
+ (return-from
+ internal-apply-loop
+ (internal-apply ,lambda ,args ,calling-closure
+ nil)))))))
+ `(cond ((sb!c::node-tail-p node)
+ ,tailp-call-form)
+ (t
+ (ecase (sb!c::continuation-info cont)
+ ((:multiple :return)
+ (eval-stack-push (multiple-value-list ,call-form)))
+ (:single
+ (eval-stack-push ,call-form))
+ (:unused ,call-form))))))
+
+;;; This sets the variable block in INTERNAL-APPLY-LOOP, and it announces this
+;;; by setting set-block-p for later loop iteration maintenance.
+;;;
+;;; FIXME: used only in this file, needn't be in runtime
+(defmacro set-block (exp)
+ `(progn
+ (setf block ,exp)
+ (setf set-block-p t)))
+
+;;; This sets all the iteration variables in INTERNAL-APPLY-LOOP to iterate
+;;; over a new block's nodes. Block-exp is optional because sometimes we have
+;;; already set block, and we only need to bring the others into agreement.
+;;; If we already set block, then clear the variable that announces this,
+;;; set-block-p.
+;;;
+;;; FIXME: used only in this file, needn't be in runtime
+(defmacro change-blocks (&optional block-exp)
+ `(progn
+ ,(if block-exp
+ `(setf block ,block-exp)
+ `(setf set-block-p nil))
+ (setf node (sb!c::continuation-next (sb!c::block-start block)))
+ (setf last-cont (sb!c::node-cont (sb!c::block-last block)))))
+
+;;; This controls printing visited nodes in INTERNAL-APPLY-LOOP. We use it
+;;; here, and INTERNAL-INVOKE uses it to print function call looking output
+;;; to further describe sb!c::combination nodes.
+(defvar *internal-apply-node-trace* nil)
+(defun maybe-trace-funny-fun (node name &rest args)
+ (when *internal-apply-node-trace*
+ (format t "(~S ~{ ~S~}) c~S~%"
+ name args (sb!c::cont-num (sb!c::node-cont node)))))
+
+;;; This implements the intention of the virtual function name. This is a
+;;; macro because some of these actions must occur without a function call.
+;;; For example, calling a dispatch function to implement special binding would
+;;; be a no-op because returning from that function would cause the system to
+;;; undo any special bindings it established.
+;;;
+;;; NOTE: update SB!C:ANNOTATE-COMPONENT-FOR-EVAL and/or
+;;; sb!c::undefined-funny-funs if you add or remove branches in this routine.
+;;;
+;;; This assumes the following variables are present: node, cont, frame-ptr,
+;;; args, closure, block, and last-cont. It also assumes a block named
+;;; internal-apply-loop.
+;;;
+;;; FIXME: used only in this file, needn't be in runtime
+;;; FIXME: down with DO-FOO names for non-iteration constructs!
+(defmacro do-funny-function (funny-fun-name)
+ (let ((name (gensym)))
+ `(let ((,name ,funny-fun-name))
+ (ecase ,name
+ (sb!c::%special-bind
+ (let ((value (eval-stack-pop))
+ (global-var (eval-stack-pop)))
+ (maybe-trace-funny-fun node ,name global-var value)
+ (sb!sys:%primitive sb!c:bind
+ value
+ (sb!c::global-var-name global-var))))
+ (sb!c::%special-unbind
+ ;; Throw away arg telling me which special, and tell the dynamic
+ ;; binding mechanism to unbind one variable.
+ (eval-stack-pop)
+ (maybe-trace-funny-fun node ,name)
+ (sb!sys:%primitive sb!c:unbind))
+ (sb!c::%catch
+ (let* ((tag (eval-stack-pop))
+ (nlx-info (eval-stack-pop))
+ (fell-through-p nil)
+ ;; Ultimately THROW and CATCH will fix the interpreter's stack
+ ;; since this is necessary for compiled CATCH's and those in
+ ;; the initial top level function.
+ (stack-top *eval-stack-top*)
+ (values
+ (multiple-value-list
+ (catch tag
+ (maybe-trace-funny-fun node ,name tag)
+ (multiple-value-setq (block node cont last-cont)
+ (internal-apply-loop (sb!c::continuation-next cont)
+ frame-ptr lambda args closure))
+ (setf fell-through-p t)))))
+ (cond (fell-through-p
+ ;; We got here because we just saw the SB!C::%CATCH-BREAKUP
+ ;; funny function inside the above recursive call to
+ ;; INTERNAL-APPLY-LOOP. Therefore, we just received and
+ ;; stored the current state of evaluation for falling
+ ;; through.
+ )
+ (t
+ ;; Fix up the interpreter's stack after having thrown here.
+ ;; We won't need to do this in the final implementation.
+ (eval-stack-set-top stack-top)
+ ;; Take the values received in the list bound above, and
+ ;; massage them into the form expected by the continuation
+ ;; of the non-local-exit info.
+ (ecase (sb!c::continuation-info
+ (sb!c::nlx-info-continuation nlx-info))
+ (:single
+ (eval-stack-push (car values)))
+ ((:multiple :return)
+ (eval-stack-push values))
+ (:unused))
+ ;; We want to continue with the code after the CATCH body.
+ ;; The non-local-exit info tells us where this is, but we
+ ;; know that block only contains a call to the funny
+ ;; function SB!C::%NLX-ENTRY, which simply is a place holder
+ ;; for the compiler IR1. We want to skip the target block
+ ;; entirely, so we say it is the block we're in now and say
+ ;; the current cont is the last-cont. This makes the COND
+ ;; at the end of INTERNAL-APPLY-LOOP do the right thing.
+ (setf block (sb!c::nlx-info-target nlx-info))
+ (setf cont last-cont)))))
+ (sb!c::%unwind-protect
+ ;; Cleanup function not pushed due to special-case :UNUSED
+ ;; annotation in ANNOTATE-COMPONENT-FOR-EVAL.
+ (let* ((nlx-info (eval-stack-pop))
+ (fell-through-p nil)
+ (stack-top *eval-stack-top*))
+ (unwind-protect
+ (progn
+ (maybe-trace-funny-fun node ,name)
+ (multiple-value-setq (block node cont last-cont)
+ (internal-apply-loop (sb!c::continuation-next cont)
+ frame-ptr lambda args closure))
+ (setf fell-through-p t))
+ (cond (fell-through-p
+ ;; We got here because we just saw the
+ ;; SB!C::%UNWIND-PROTECT-BREAKUP funny function inside the
+ ;; above recursive call to INTERNAL-APPLY-LOOP.
+ ;; Therefore, we just received and stored the current
+ ;; state of evaluation for falling through.
+ )
+ (t
+ ;; Fix up the interpreter's stack after having thrown
+ ;; here. We won't need to do this in the final
+ ;; implementation.
+ (eval-stack-set-top stack-top)
+ ;; Push some bogus values for exit context to keep the
+ ;; MV-BIND in the UNWIND-PROTECT translation happy.
+ (eval-stack-push '(nil nil 0))
+ (let ((node (sb!c::continuation-next
+ (sb!c::block-start
+ (car (sb!c::block-succ
+ (sb!c::nlx-info-target nlx-info)))))))
+ (internal-apply-loop node frame-ptr lambda args
+ closure)))))))
+ ((sb!c::%catch-breakup
+ sb!c::%unwind-protect-breakup
+ sb!c::%continue-unwind)
+ ;; This shows up when we locally exit a CATCH body -- fell through.
+ ;; Return the current state of evaluation to the previous invocation
+ ;; of INTERNAL-APPLY-LOOP which happens to be running in the
+ ;; SB!C::%CATCH branch of this code.
+ (maybe-trace-funny-fun node ,name)
+ (return-from internal-apply-loop
+ (values block node cont last-cont)))
+ (sb!c::%nlx-entry
+ (maybe-trace-funny-fun node ,name)
+ ;; This just marks a spot in the code for CATCH, UNWIND-PROTECT, and
+ ;; non-local lexical exits (GO or RETURN-FROM).
+ ;; Do nothing since sb!c::%catch does it all when it catches a THROW.
+ ;; Do nothing since sb!c::%unwind-protect does it all when
+ ;; it catches a THROW.
+ )
+ (sb!c::%more-arg-context
+ (let* ((fixed-arg-count (1+ (eval-stack-pop)))
+ ;; Add 1 to actual fixed count for extra arg expected by
+ ;; external entry points (XEP) which some IR1 lambdas have.
+ ;; The extra arg is the number of arguments for arg count
+ ;; consistency checking. SB!C::%MORE-ARG-CONTEXT always runs
+ ;; within an XEP, so the lambda has an extra arg.
+ (more-args (nthcdr fixed-arg-count args)))
+ (maybe-trace-funny-fun node ,name fixed-arg-count)
+ (assert (eq (sb!c::continuation-info cont) :multiple))
+ (eval-stack-push (list more-args (length more-args)))))
+ (sb!c::%unknown-values
+ (error "SB!C::%UNKNOWN-VALUES should never be in interpreter's IR1."))
+ (sb!c::%lexical-exit-breakup
+ ;; We see this whenever we locally exit the extent of a lexical
+ ;; target. That is, we are truly locally exiting an extent we could
+ ;; have non-locally lexically exited. Return the :fell-through flag
+ ;; and the current state of evaluation to the previous invocation
+ ;; of INTERNAL-APPLY-LOOP which happens to be running in the
+ ;; sb!c::entry branch of INTERNAL-APPLY-LOOP.
+ (maybe-trace-funny-fun node ,name)
+ ;; Discard the NLX-INFO arg...
+ (eval-stack-pop)
+ (return-from internal-apply-loop
+ (values :fell-through block node cont last-cont)))))))
+
+;;; This expands for the two types of combination nodes INTERNAL-APPLY-LOOP
+;;; sees. Type is either :mv-call or :normal. Node is the combination node,
+;;; and cont is its continuation. Frame-ptr is the current frame pointer, and
+;;; closure is the current environment for closure variables.
+;;;
+;;; Most of the real work is done by DO-COMBINATION. This first determines if
+;;; the combination node describes a :full call which DO-COMBINATION directly
+;;; handles. If the call is :local, then we either invoke an IR1 lambda, or we
+;;; just bind some LET variables. If the call is :local, and type is :mv-call,
+;;; then we can only be binding multiple values. Otherwise, the combination
+;;; node describes a function known to the compiler, but this may be a funny
+;;; function that actually isn't ever defined. We either take some action for
+;;; the funny function or do a :full call on the known true function, but the
+;;; interpreter doesn't do optimizing stuff for functions known to the
+;;; compiler.
+;;;
+;;; This assumes the following variables are present: node, cont, frame-ptr,
+;;; and closure. It also assumes a block named internal-apply-loop.
+;;;
+;;; FIXME: used only in this file, needn't be in runtime
+(defmacro combination-node (type)
+ (let* ((kind (gensym))
+ (fun (gensym))
+ (lambda (gensym))
+ (letp (gensym))
+ (letp-bind (ecase type
+ (:mv-call nil)
+ (:normal
+ `((,letp (eq (sb!c::functional-kind ,lambda) :let))))))
+ (local-branch
+ (ecase type
+ (:mv-call
+ `(store-mv-let-vars ,lambda frame-ptr
+ (length (sb!c::mv-combination-args node))))
+ (:normal
+ `(if ,letp
+ (store-let-vars ,lambda frame-ptr)
+ (do-combination :local ,lambda ,type))))))
+ `(let ((,kind (sb!c::basic-combination-kind node))
+ (,fun (sb!c::basic-combination-fun node)))
+ (cond ((member ,kind '(:full :error))
+ (do-combination :full nil ,type))
+ ((eq ,kind :local)
+ (let* ((,lambda (sb!c::ref-leaf (sb!c::continuation-use ,fun)))
+ ,@letp-bind)
+ ,local-branch))
+ ((eq (sb!c::continuation-info ,fun) :unused)
+ (assert (typep ,kind 'sb!c::function-info))
+ (do-funny-function (sb!c::continuation-function-name ,fun)))
+ (t
+ (assert (typep ,kind 'sb!c::function-info))
+ (do-combination :full nil ,type))))))
+
+(defun trace-eval (on)
+ (setf *eval-stack-trace* on)
+ (setf *internal-apply-node-trace* on))
+\f
+;;;; INTERNAL-EVAL
+
+;;; Evaluate an arbitary form. We convert the form, then call internal
+;;; apply on it. If *ALREADY-EVALED-THIS* is true, then we bind it to NIL
+;;; around the apply to limit the inhibition to the lexical scope of the
+;;; EVAL-WHEN.
+(defun internal-eval (form &optional quietly)
+ (let ((res (sb!c:compile-for-eval form quietly)))
+ (if *already-evaled-this*
+ (let ((*already-evaled-this* nil))
+ (internal-apply res nil '#()))
+ (internal-apply res nil '#()))))
+
+;;; Later this will probably be the same weird internal thing the compiler
+;;; makes to represent these things.
+(defun make-indirect-value-cell (value)
+ (list value))
+;;; FIXME: used only in this file, needn't be in runtime
+(defmacro indirect-value (value-cell)
+ `(car ,value-cell))
+
+;;; This passes on a node's value appropriately, possibly returning from
+;;; function to do so. When we are tail-p, don't push the value, return it on
+;;; the system's actual call stack; when we blow out of function this way, we
+;;; must return the interpreter's stack to the its state before this call to
+;;; function. When we're in a multiple value context or heading for a return
+;;; node, we push a list of the value for easier handling later. Otherwise,
+;;; just push the value on the interpreter's stack.
+;;;
+;;; FIXME: maybe used only in this file, if so, needn't be in runtime
+(defmacro value (node info value frame-ptr function)
+ `(cond ((sb!c::node-tail-p ,node)
+ (eval-stack-set-top ,frame-ptr)
+ (return-from ,function ,value))
+ ((member ,info '(:multiple :return) :test #'eq)
+ (eval-stack-push (list ,value)))
+ (t (assert (eq ,info :single))
+ (eval-stack-push ,value))))
+
+(defun maybe-trace-nodes (node)
+ (when *internal-apply-node-trace*
+ (format t "<~A-node> c~S~%"
+ (type-of node)
+ (sb!c::cont-num (sb!c::node-cont node)))))
+
+;;; This interprets lambda, a compiler IR1 data structure representing a
+;;; function, applying it to args. Closure is the environment in which to run
+;;; lambda, the variables and such closed over to form lambda. The call occurs
+;;; on the interpreter's stack, so save the current top and extend the stack
+;;; for this lambda's call frame. Then store the args into locals on the
+;;; stack.
+;;;
+;;; Args is the list of arguments to apply to. If IGNORE-UNUSED is true, then
+;;; values for un-read variables are present in the argument list, and must be
+;;; discarded (always true except in a local call.) Args may run out of values
+;;; before vars runs out of variables (in the case of an XEP with optionals);
+;;; we just do CAR of nil and store nil. This is not the proper defaulting
+;;; (which is done by explicit code in the XEP.)
+(defun internal-apply (lambda args closure &optional (ignore-unused t))
+ (let ((frame-ptr *eval-stack-top*))
+ (eval-stack-extend (sb!c:lambda-eval-info-frame-size (sb!c::lambda-info lambda)))
+ (do ((vars (sb!c::lambda-vars lambda) (cdr vars))
+ (args args))
+ ((null vars))
+ (let ((var (car vars)))
+ (cond ((sb!c::leaf-refs var)
+ (setf (eval-stack-local frame-ptr (sb!c::lambda-var-info var))
+ (if (sb!c::lambda-var-indirect var)
+ (make-indirect-value-cell (pop args))
+ (pop args))))
+ (ignore-unused (pop args)))))
+ (internal-apply-loop (sb!c::lambda-bind lambda) frame-ptr lambda args
+ closure)))
+
+;;; This does the work of INTERNAL-APPLY. This also calls itself
+;;; recursively for certain language features, such as CATCH. First is
+;;; the node at which to start interpreting. FRAME-PTR is the current
+;;; frame pointer for accessing local variables. LAMBDA is the IR1
+;;; lambda from which comes the nodes a given call to this function
+;;; processes, and CLOSURE is the environment for interpreting LAMBDA.
+;;; ARGS is the argument list for the lambda given to INTERNAL-APPLY,
+;;; and we have to carry it around with us in case of &more-arg or
+;;; &rest-arg processing which is represented explicitly in the
+;;; compiler's IR1.
+;;;
+;;; KLUDGE: Due to having a truly tail recursive interpreter, some of
+;;; the branches handling a given node need to RETURN-FROM this
+;;; routine. Also, some calls this makes to do work for it must occur
+;;; in tail recursive positions. Because of this required access to
+;;; this function lexical environment and calling positions, we often
+;;; are unable to break off logical chunks of code into functions. We
+;;; have written macros intended solely for use in this routine, and
+;;; due to all the local stuff they need to access and length complex
+;;; calls, we have written them to sleazily access locals from this
+;;; routine. In addition to assuming a block named internal-apply-loop
+;;; exists, they set and reference the following variables: NODE,
+;;; CONT, FRAME-PTR, CLOSURE, BLOCK, LAST-CONT, and SET-BLOCK-P.
+;;; FIXME: Perhaps this kludge could go away if we convert to a
+;;; compiler-only implementation?
+(defun internal-apply-loop (first frame-ptr lambda args closure)
+ ;; FIXME: This will cause source code location information to be compiled
+ ;; into the executable, which will probably cause problems for users running
+ ;; without the sources and/or without the build-the-system readtable.
+ (declare (optimize (debug 2)))
+ (let* ((block (sb!c::node-block first))
+ (last-cont (sb!c::node-cont (sb!c::block-last block)))
+ (node first)
+ (set-block-p nil))
+ (loop
+ (let ((cont (sb!c::node-cont node)))
+ (etypecase node
+ (sb!c::ref
+ (maybe-trace-nodes node)
+ (let ((info (sb!c::continuation-info cont)))
+ (unless (eq info :unused)
+ (value node info (leaf-value node frame-ptr closure)
+ frame-ptr internal-apply-loop))))
+ (sb!c::combination
+ (maybe-trace-nodes node)
+ (combination-node :normal))
+ (sb!c::cif
+ (maybe-trace-nodes node)
+ ;; IF nodes always occur at the end of a block, so pick another.
+ (set-block (if (eval-stack-pop)
+ (sb!c::if-consequent node)
+ (sb!c::if-alternative node))))
+ (sb!c::bind
+ (maybe-trace-nodes node)
+ ;; Ignore bind nodes since INTERNAL-APPLY extends the stack for
+ ;; all of a lambda's locals, and the sb!c::combination branch
+ ;; handles LET binds (moving values off stack top into locals).
+ )
+ (sb!c::cset
+ (maybe-trace-nodes node)
+ (let ((info (sb!c::continuation-info cont))
+ (res (set-leaf-value node frame-ptr closure
+ (eval-stack-pop))))
+ (unless (eq info :unused)
+ (value node info res frame-ptr internal-apply-loop))))
+ (sb!c::entry
+ (maybe-trace-nodes node)
+ (let ((info (cdr (assoc node (sb!c:lambda-eval-info-entries
+ (sb!c::lambda-info lambda))))))
+ ;; No info means no-op entry for CATCH or UNWIND-PROTECT.
+ (when info
+ ;; Store stack top for restoration in local exit situation
+ ;; in sb!c::exit branch.
+ (setf (eval-stack-local frame-ptr
+ (sb!c:entry-node-info-st-top info))
+ *eval-stack-top*)
+ (let ((tag (sb!c:entry-node-info-nlx-tag info)))
+ (when tag
+ ;; Non-local lexical exit (someone closed over a
+ ;; GO tag or BLOCK name).
+ (let ((unique-tag (cons nil nil))
+ values)
+ (setf (eval-stack-local frame-ptr tag) unique-tag)
+ (if (eq cont last-cont)
+ (change-blocks (car (sb!c::block-succ block)))
+ (setf node (sb!c::continuation-next cont)))
+ (loop
+ (multiple-value-setq (values block node cont last-cont)
+ (catch unique-tag
+ (internal-apply-loop node frame-ptr
+ lambda args closure)))
+
+ (when (eq values :fell-through)
+ ;; We hit a %LEXICAL-EXIT-BREAKUP.
+ ;; Interpreting state is set with MV-SETQ above.
+ ;; Just get out of this branch and go on.
+ (return))
+
+ (unless (eq values :non-local-go)
+ ;; We know we're non-locally exiting from a
+ ;; BLOCK with values (saw a RETURN-FROM).
+ (ecase (sb!c::continuation-info cont)
+ (:single
+ (eval-stack-push (car values)))
+ ((:multiple :return)
+ (eval-stack-push values))
+ (:unused)))
+ ;; Start interpreting again at the target, skipping
+ ;; the %NLX-ENTRY block.
+ (setf node
+ (sb!c::continuation-next
+ (sb!c::block-start
+ (car (sb!c::block-succ block))))))))))))
+ (sb!c::exit
+ (maybe-trace-nodes node)
+ (let* ((incoming-values (sb!c::exit-value node))
+ (values (if incoming-values (eval-stack-pop))))
+ (cond
+ ((eq (sb!c::lambda-environment lambda)
+ (sb!c::block-environment
+ (sb!c::node-block (sb!c::exit-entry node))))
+ ;; Local exit.
+ ;; Fixup stack top and massage values for destination.
+ (eval-stack-set-top
+ (eval-stack-local frame-ptr
+ (sb!c:entry-node-info-st-top
+ (cdr (assoc (sb!c::exit-entry node)
+ (sb!c:lambda-eval-info-entries
+ (sb!c::lambda-info lambda)))))))
+ (ecase (sb!c::continuation-info cont)
+ (:single
+ (assert incoming-values)
+ (eval-stack-push (car values)))
+ ((:multiple :return)
+ (assert incoming-values)
+ (eval-stack-push values))
+ (:unused)))
+ (t
+ (let ((info (sb!c::find-nlx-info (sb!c::exit-entry node)
+ cont)))
+ (throw
+ (svref closure
+ (position info
+ (sb!c::environment-closure
+ (sb!c::node-environment node))
+ :test #'eq))
+ (if incoming-values
+ (values values (sb!c::nlx-info-target info) nil cont)
+ (values :non-local-go (sb!c::nlx-info-target info)))))))))
+ (sb!c::creturn
+ (maybe-trace-nodes node)
+ (let ((values (eval-stack-pop)))
+ (eval-stack-set-top frame-ptr)
+ (return-from internal-apply-loop (values-list values))))
+ (sb!c::mv-combination
+ (maybe-trace-nodes node)
+ (combination-node :mv-call)))
+ ;; See function doc below.
+ (reference-this-var-to-keep-it-alive node)
+ (reference-this-var-to-keep-it-alive frame-ptr)
+ (reference-this-var-to-keep-it-alive closure)
+ (cond ((not (eq cont last-cont))
+ (setf node (sb!c::continuation-next cont)))
+ ;; Currently only the last node in a block causes this loop to
+ ;; change blocks, so we never just go to the next node when
+ ;; the current node's branch tried to change blocks.
+ (set-block-p
+ (change-blocks))
+ (t
+ ;; CIF nodes set the block for us, but other last
+ ;; nodes do not.
+ (change-blocks (car (sb!c::block-succ block)))))))))
+
+;;; This function allows a reference to a variable that the compiler cannot
+;;; easily eliminate as unnecessary. We use this at the end of the node
+;;; dispatch in INTERNAL-APPLY-LOOP to make sure the node variable has a
+;;; valid value. Each node branch tends to reference it at the beginning,
+;;; and then there is no reference but a set at the end; the compiler then
+;;; kills the variable between the reference in the dispatch branch and when
+;;; we set it at the end. The problem is that most error will occur in the
+;;; interpreter within one of these node dispatch branches.
+(defun reference-this-var-to-keep-it-alive (node)
+ node)
+
+;;; This sets a sb!c::cset node's var to value, returning value. When var is
+;;; local, we have to compare its home environment to the current one, node's
+;;; environment. If they're the same, we check to see whether the var is
+;;; indirect, and store the value on the stack or in the value cell as
+;;; appropriate. Otherwise, var is a closure variable, and since we're
+;;; setting it, we know its location contains an indirect value object.
+(defun set-leaf-value (node frame-ptr closure value)
+ (let ((var (sb!c::set-var node)))
+ (etypecase var
+ (sb!c::lambda-var
+ (set-leaf-value-lambda-var node var frame-ptr closure value))
+ (sb!c::global-var
+ (setf (symbol-value (sb!c::global-var-name var)) value)))))
+
+;;; This does SET-LEAF-VALUE for a lambda-var leaf. The debugger tools'
+;;; internals uses this also to set interpreted local variables.
+(defun set-leaf-value-lambda-var (node var frame-ptr closure value)
+ (let ((env (sb!c::node-environment node)))
+ (cond ((not (eq (sb!c::lambda-environment (sb!c::lambda-var-home var))
+ env))
+ (setf (indirect-value
+ (svref closure
+ (position var (sb!c::environment-closure env)
+ :test #'eq)))
+ value))
+ ((sb!c::lambda-var-indirect var)
+ (setf (indirect-value
+ (eval-stack-local frame-ptr (sb!c::lambda-var-info var)))
+ value))
+ (t
+ (setf (eval-stack-local frame-ptr (sb!c::lambda-var-info var))
+ value)))))
+
+;;; This figures out how to return a value for a ref node. Leaf is the ref's
+;;; structure that tells us about the value, and it is one of the following
+;;; types:
+;;; constant -- It knows its own value.
+;;; global-var -- It's either a value or function reference. Get it right.
+;;; local-var -- This may on the stack or in the current closure, the
+;;; environment for the lambda INTERNAL-APPLY is currently
+;;; executing. If the leaf's home environment is the same
+;;; as the node's home environment, then the value is on the
+;;; stack, else it's in the closure since it came from another
+;;; environment. Whether the var comes from the stack or the
+;;; closure, it could have come from a closure, and it could
+;;; have been closed over for setting. When this happens, the
+;;; actual value is stored in an indirection object, so
+;;; indirect. See COMPUTE-CLOSURE for the description of
+;;; the structure of the closure argument to this function.
+;;; functional -- This is a reference to an interpreted function that may
+;;; be passed or called anywhere. We return a real function
+;;; that calls INTERNAL-APPLY, closing over the leaf. We also
+;;; have to compute a closure, running environment, for the
+;;; lambda in case it references stuff in the current
+;;; environment. If the closure is empty and there is no
+;;; functional environment, then we use
+;;; MAKE-INTERPRETED-FUNCTION to make a cached translation.
+;;; Since it is too late to lazily convert, we set up the
+;;; INTERPRETED-FUNCTION to be already converted.
+(defun leaf-value (node frame-ptr closure)
+ (let ((leaf (sb!c::ref-leaf node)))
+ (etypecase leaf
+ (sb!c::constant
+ (sb!c::constant-value leaf))
+ (sb!c::global-var
+ (locally (declare (optimize (safety 1)))
+ (if (eq (sb!c::global-var-kind leaf) :global-function)
+ (let ((name (sb!c::global-var-name leaf)))
+ (if (symbolp name)
+ (symbol-function name)
+ (fdefinition name)))
+ (symbol-value (sb!c::global-var-name leaf)))))
+ (sb!c::lambda-var
+ (leaf-value-lambda-var node leaf frame-ptr closure))
+ (sb!c::functional
+ (let* ((calling-closure (compute-closure node leaf frame-ptr closure))
+ (real-fun (sb!c::functional-entry-function leaf))
+ (arg-doc (sb!c::functional-arg-documentation real-fun)))
+ (cond ((sb!c:lambda-eval-info-function (sb!c::leaf-info leaf)))
+ ((and (zerop (length calling-closure))
+ (null (sb!c::lexenv-functions
+ (sb!c::functional-lexenv real-fun))))
+ (let ((res (make-interpreted-function
+ (sb!c::functional-inline-expansion real-fun))))
+ (push res *interpreted-function-cache*)
+ (setf (interpreted-function-definition res) leaf)
+ (setf (interpreted-function-converted-once res) t)
+ (setf (interpreted-function-arglist res) arg-doc)
+ (setf (interpreted-function-%name res)
+ (sb!c::leaf-name real-fun))
+ (setf (sb!c:lambda-eval-info-function
+ (sb!c::leaf-info leaf)) res)
+ res))
+ (t
+ (let ((res (%make-interpreted-function
+ :definition leaf
+ :%name (sb!c::leaf-name real-fun)
+ :arglist arg-doc
+ :closure calling-closure)))
+ (setf (funcallable-instance-function res)
+ #'(instance-lambda (&rest args)
+ (declare (list args))
+ (internal-apply
+ (interpreted-function-definition res)
+ (cons (length args) args)
+ (interpreted-function-closure res))))
+ res))))))))
+
+;;; This does LEAF-VALUE for a lambda-var leaf. The debugger tools' internals
+;;; uses this also to reference interpreted local variables.
+(defun leaf-value-lambda-var (node leaf frame-ptr closure)
+ (let* ((env (sb!c::node-environment node))
+ (temp
+ (if (eq (sb!c::lambda-environment (sb!c::lambda-var-home leaf))
+ env)
+ (eval-stack-local frame-ptr (sb!c::lambda-var-info leaf))
+ (svref closure
+ (position leaf (sb!c::environment-closure env)
+ :test #'eq)))))
+ (if (sb!c::lambda-var-indirect leaf)
+ (indirect-value temp)
+ temp)))
+
+;;; This computes a closure for a local call and for returned call'able closure
+;;; objects. Sometimes the closure is a simple-vector of no elements. Node
+;;; is either a reference node or a combination node. Leaf is either the leaf
+;;; of the reference node or the lambda to internally apply for the combination
+;;; node. Frame-ptr is the current frame pointer for fetching current values
+;;; to store in the closure. Closure is the current closure, the currently
+;;; interpreting lambda's closed over environment.
+;;;
+;;; A computed closure is a vector corresponding to the list of closure
+;;; variables described in an environment. The position of a lambda-var in
+;;; this closure list is the index into the closure vector of values.
+;;;
+;;; Functional-env is the environment description for leaf, the lambda for
+;;; which we're computing a closure. This environment describes which of
+;;; lambda's vars we find in lambda's closure when it's running, versus finding
+;;; them on the stack. For each lambda-var in the functional environment's
+;;; closure list, if the lambda-var's home environment is the current
+;;; environment, then get a value off the stack and store it in the closure
+;;; we're computing. Otherwise that lambda-var's value comes from somewhere
+;;; else, but we have it in our current closure, the environment we're running
+;;; in as we compute this new closure. Find this value the same way we do in
+;;; LEAF-VALUE, by finding the lambda-var's position in the current
+;;; environment's description of the current closure.
+(defun compute-closure (node leaf frame-ptr closure)
+ (let* ((current-env (sb!c::node-environment node))
+ (current-closure-vars (sb!c::environment-closure current-env))
+ (functional-env (sb!c::lambda-environment leaf))
+ (functional-closure-vars (sb!c::environment-closure functional-env))
+ (functional-closure (make-array (length functional-closure-vars))))
+ (do ((vars functional-closure-vars (cdr vars))
+ (i 0 (1+ i)))
+ ((null vars))
+ (let ((ele (car vars)))
+ (setf (svref functional-closure i)
+ (etypecase ele
+ (sb!c::lambda-var
+ (if (eq (sb!c::lambda-environment (sb!c::lambda-var-home ele))
+ current-env)
+ (eval-stack-local frame-ptr (sb!c::lambda-var-info ele))
+ (svref closure
+ (position ele current-closure-vars
+ :test #'eq))))
+ (sb!c::nlx-info
+ (if (eq (sb!c::block-environment (sb!c::nlx-info-target ele))
+ current-env)
+ (eval-stack-local
+ frame-ptr
+ (sb!c:entry-node-info-nlx-tag
+ (cdr (assoc ;; entry node for non-local extent
+ (sb!c::cleanup-mess-up
+ (sb!c::nlx-info-cleanup ele))
+ (sb!c::lambda-eval-info-entries
+ (sb!c::lambda-info
+ ;; lambda INTERNAL-APPLY-LOOP tosses around.
+ (sb!c::environment-function
+ (sb!c::node-environment node))))))))
+ (svref closure
+ (position ele current-closure-vars
+ :test #'eq))))))))
+ functional-closure))
+
+;;; INTERNAL-APPLY uses this to invoke a function from the interpreter's stack
+;;; on some arguments also taken from the stack. When tail-p is non-nil,
+;;; control does not return to INTERNAL-APPLY to further interpret the current
+;;; IR1 lambda, so INTERNAL-INVOKE must clean up the current interpreter's
+;;; stack frame.
+(defun internal-invoke (arg-count &optional tailp)
+ (let ((args (eval-stack-args arg-count)) ;LET says this init form runs first.
+ (fun (eval-stack-pop)))
+ (when tailp (eval-stack-set-top tailp))
+ (when *internal-apply-node-trace*
+ (format t "(~S~{ ~S~})~%" fun args))
+ (apply fun args)))
+
+;;; Almost just like INTERNAL-INVOKE. We call MV-EVAL-STACK-ARGS, and our
+;;; function is in a list on the stack instead of simply on the stack.
+(defun mv-internal-invoke (arg-count &optional tailp)
+ (let ((args (mv-eval-stack-args arg-count)) ;LET runs this init form first.
+ (fun (car (eval-stack-pop))))
+ (when tailp (eval-stack-set-top tailp))
+ (when *internal-apply-node-trace*
+ (format t "(~S~{ ~S~})~%" fun args))
+ (apply fun args)))
+
+;;; This returns a list of the top arg-count elements on the interpreter's
+;;; stack. This removes them from the stack.
+(defun eval-stack-args (arg-count)
+ (let ((args nil))
+ (dotimes (i arg-count args)
+ (push (eval-stack-pop) args))))
+
+;;; This assumes the top count elements on interpreter's stack are lists. This
+;;; returns a single list with all the elements from these lists.
+(defun mv-eval-stack-args (count)
+ (if (= count 1)
+ (eval-stack-pop)
+ (let ((last (eval-stack-pop)))
+ (dotimes (i (1- count))
+ (let ((next (eval-stack-pop)))
+ (setf last
+ (if next (nconc next last) last))))
+ last)))
+
+;;; This stores lambda's vars, stack locals, from values popped off the stack.
+;;; When a var has no references, the compiler computes IR1 such that the
+;;; continuation delivering the value for the unreference var appears unused.
+;;; Because of this, the interpreter drops the value on the floor instead of
+;;; saving it on the stack for binding, so we only pop a value when the var has
+;;; some reference. INTERNAL-APPLY uses this for sb!c::combination nodes
+;;; representing LET's.
+;;;
+;;; When storing the local, if it is indirect, then someone closes over it for
+;;; setting instead of just for referencing. We then store an indirection cell
+;;; with the value, and the referencing code for locals knows how to get the
+;;; actual value.
+(defun store-let-vars (lambda frame-ptr)
+ (let* ((vars (sb!c::lambda-vars lambda))
+ (args (eval-stack-args (count-if #'sb!c::leaf-refs vars))))
+ (declare (list vars args))
+ (dolist (v vars)
+ (when (sb!c::leaf-refs v)
+ (setf (eval-stack-local frame-ptr (sb!c::lambda-var-info v))
+ (if (sb!c::lambda-var-indirect v)
+ (make-indirect-value-cell (pop args))
+ (pop args)))))))
+
+;;; This is similar to STORE-LET-VARS, but the values for the locals appear on
+;;; the stack in a list due to forms that delivered multiple values to this
+;;; lambda/let. Unlike STORE-LET-VARS, there is no control over the delivery
+;;; of a value for an unreferenced var, so we drop the corresponding value on
+;;; the floor when no one references it. INTERNAL-APPLY uses this for
+;;; sb!c::mv-combination nodes representing LET's.
+(defun store-mv-let-vars (lambda frame-ptr count)
+ (assert (= count 1))
+ (let ((args (eval-stack-pop)))
+ (dolist (v (sb!c::lambda-vars lambda))
+ (if (sb!c::leaf-refs v)
+ (setf (eval-stack-local frame-ptr (sb!c::lambda-var-info v))
+ (if (sb!c::lambda-var-indirect v)
+ (make-indirect-value-cell (pop args))
+ (pop args)))
+ (pop args)))))
+
+#|
+;;; This stores lambda's vars, stack locals, from multiple values stored on the
+;;; top of the stack in a list. Since these values arrived multiply, there is
+;;; no control over the delivery of each value for an unreferenced var, so
+;;; unlike STORE-LET-VARS, we have values for variables never used. We drop
+;;; the value corresponding to an unreferenced var on the floor.
+;;; INTERNAL-APPLY uses this for sb!c::mv-combination nodes representing LET's.
+;;;
+;;; IR1 represents variables bound from multiple values in a list in the
+;;; opposite order of the values list. We use STORE-MV-LET-VARS-AUX to recurse
+;;; down the vars list until we bottom out, storing values on the way back up
+;;; the recursion. You must do this instead of NREVERSE'ing the args list, so
+;;; when we run out of values, we store nil's in the correct lambda-vars.
+(defun store-mv-let-vars (lambda frame-ptr count)
+ (assert (= count 1))
+ (print (sb!c::lambda-vars lambda))
+ (store-mv-let-vars-aux frame-ptr (sb!c::lambda-vars lambda) (eval-stack-pop)))
+(defun store-mv-let-vars-aux (frame-ptr vars args)
+ (if vars
+ (let ((remaining-args (store-mv-let-vars-aux frame-ptr (cdr vars) args))
+ (v (car vars)))
+ (when (sb!c::leaf-refs v)
+ (setf (eval-stack-local frame-ptr (sb!c::lambda-var-info v))
+ (if (sb!c::lambda-var-indirect v)
+ (make-indirect-value-cell (car remaining-args))
+ (car remaining-args))))
+ (cdr remaining-args))
+ args))
+|#
--- /dev/null
+;;;; fixups, extracted from codegen.lisp by WHN 19990227 in order
+;;;; to help with cross-compiling bootstrapping
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!C")
+
+(file-comment
+ "$Header$")
+
+;;; FIXUP -- A fixup of some kind.
+(defstruct (fixup
+ (:constructor make-fixup (name flavor &optional offset)))
+ ;; The name and flavor of the fixup. The assembler makes no assumptions
+ ;; about the contents of these fields; their semantics are imposed by the
+ ;; dumper.
+ name
+ flavor
+ ;; OFFSET is an optional offset from whatever external label this fixup
+ ;; refers to. Or in the case of the :CODE-OBJECT flavor of fixups on the :X86
+ ;; architecture, NAME is always NIL, so this fixup doesn't refer to an
+ ;; external label, and OFFSET is an offset from the beginning of the
+ ;; current code block.
+ offset)
+
+;;; were done with another flavor
+
+(def!method print-object ((fixup fixup) stream)
+ (print-unreadable-object (fixup stream :type t)
+ (format stream
+ ":FLAVOR ~S :NAME ~S :OFFSET ~S"
+ (fixup-flavor fixup)
+ (fixup-name fixup)
+ (fixup-offset fixup))))
+
+;;; KLUDGE: Despite its name, this is not a list of FIXUP objects, but rather a
+;;; list of `(,KIND ,FIXUP ,POSN). Perhaps this non-mnemonicity could be
+;;; reduced by naming what's currently a FIXUP structure a FIXUP-REQUEST, and
+;;; then renaming *FIXUPS* to *NOTED-FIXUPS*.-- WHN 19990905
+(defvar *fixups*)
+
+;;; Setting this variable lets you see what's going on as items are
+;;; being pushed onto *FIXUPS*.
+#!+sb-show (defvar *show-fixups-being-pushed-p* nil)
+
+;;; This function is called by assembler instruction emitters when
+;;; they find themselves trying to deal with a fixup.
+(defun note-fixup (segment kind fixup)
+ (sb!assem:emit-back-patch segment
+ 0
+ (lambda (segment posn)
+ (declare (ignore segment))
+ ;; Why use EMIT-BACK-PATCH to cause this PUSH to
+ ;; be done later, instead of just doing it now?
+ ;; I'm not sure. Perhaps there's some concern
+ ;; that POSN isn't known accurately now? Perhaps
+ ;; there's a desire for all fixing up to go
+ ;; through EMIT-BACK-PATCH whether it needs to or
+ ;; not? -- WHN 19990905
+ (push (list kind fixup posn) *fixups*)))
+ (values))
--- /dev/null
+;;;; This file contains floating-point-specific transforms, and may be
+;;;; somewhat implementation-dependent in its assumptions of what the
+;;;; formats are.
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!C")
+
+(file-comment
+ "$Header$")
+\f
+;;;; coercions
+
+(defknown %single-float (real) single-float (movable foldable flushable))
+(defknown %double-float (real) double-float (movable foldable flushable))
+
+(deftransform float ((n &optional f) (* &optional single-float) * :when :both)
+ '(%single-float n))
+
+(deftransform float ((n f) (* double-float) * :when :both)
+ '(%double-float n))
+
+(deftransform %single-float ((n) (single-float) * :when :both)
+ 'n)
+
+(deftransform %double-float ((n) (double-float) * :when :both)
+ 'n)
+
+;;; not strictly float functions, but primarily useful on floats:
+(macrolet ((frob (fun ufun)
+ `(progn
+ (defknown ,ufun (real) integer (movable foldable flushable))
+ (deftransform ,fun ((x &optional by)
+ (* &optional
+ (constant-argument (member 1))))
+ '(let ((res (,ufun x)))
+ (values res (- x res)))))))
+ (frob truncate %unary-truncate)
+ (frob round %unary-round))
+
+;;; RANDOM
+(macrolet ((frob (fun type)
+ `(deftransform random ((num &optional state)
+ (,type &optional *) *
+ :when :both)
+ "Use inline float operations."
+ '(,fun num (or state *random-state*)))))
+ (frob %random-single-float single-float)
+ (frob %random-double-float double-float))
+
+;;; Mersenne Twister RNG
+;;;
+;;; FIXME: It's unpleasant to have RANDOM functionality scattered
+;;; through the code this way. It would be nice to move this into the
+;;; same file as the other RANDOM definitions.
+(deftransform random ((num &optional state)
+ ((integer 1 #.(expt 2 32)) &optional *))
+ ;; FIXME: I almost conditionalized this as #!+sb-doc. Find some way
+ ;; of automatically finding #!+sb-doc in proximity to DEFTRANSFORM
+ ;; to let me scan for places that I made this mistake and didn't
+ ;; catch myself.
+ "use inline (unsigned-byte 32) operations"
+ (let ((num-high (numeric-type-high (continuation-type num))))
+ (when (null num-high)
+ (give-up-ir1-transform))
+ (cond ((constant-continuation-p num)
+ ;; Check the worst case sum absolute error for the random number
+ ;; expectations.
+ (let ((rem (rem (expt 2 32) num-high)))
+ (unless (< (/ (* 2 rem (- num-high rem)) num-high (expt 2 32))
+ (expt 2 (- sb!kernel::random-integer-extra-bits)))
+ (give-up-ir1-transform
+ "The random number expectations are inaccurate."))
+ (if (= num-high (expt 2 32))
+ '(random-chunk (or state *random-state*))
+ #!-x86 '(rem (random-chunk (or state *random-state*)) num)
+ #!+x86
+ ;; Use multiplication, which is faster.
+ '(values (sb!bignum::%multiply
+ (random-chunk (or state *random-state*))
+ num)))))
+ ((> num-high random-fixnum-max)
+ (give-up-ir1-transform
+ "The range is too large to ensure an accurate result."))
+ #!+x86
+ ((< num-high (expt 2 32))
+ '(values (sb!bignum::%multiply (random-chunk (or state
+ *random-state*))
+ num)))
+ (t
+ '(rem (random-chunk (or state *random-state*)) num)))))
+\f
+;;;; float accessors
+
+(defknown make-single-float ((signed-byte 32)) single-float
+ (movable foldable flushable))
+
+(defknown make-double-float ((signed-byte 32) (unsigned-byte 32)) double-float
+ (movable foldable flushable))
+
+(defknown single-float-bits (single-float) (signed-byte 32)
+ (movable foldable flushable))
+
+(defknown double-float-high-bits (double-float) (signed-byte 32)
+ (movable foldable flushable))
+
+(defknown double-float-low-bits (double-float) (unsigned-byte 32)
+ (movable foldable flushable))
+
+(deftransform float-sign ((float &optional float2)
+ (single-float &optional single-float) *)
+ (if float2
+ (let ((temp (gensym)))
+ `(let ((,temp (abs float2)))
+ (if (minusp (single-float-bits float)) (- ,temp) ,temp)))
+ '(if (minusp (single-float-bits float)) -1f0 1f0)))
+
+(deftransform float-sign ((float &optional float2)
+ (double-float &optional double-float) *)
+ (if float2
+ (let ((temp (gensym)))
+ `(let ((,temp (abs float2)))
+ (if (minusp (double-float-high-bits float)) (- ,temp) ,temp)))
+ '(if (minusp (double-float-high-bits float)) -1d0 1d0)))
+\f
+;;;; DECODE-FLOAT, INTEGER-DECODE-FLOAT, and SCALE-FLOAT
+
+(defknown decode-single-float (single-float)
+ (values single-float single-float-exponent (single-float -1f0 1f0))
+ (movable foldable flushable))
+
+(defknown decode-double-float (double-float)
+ (values double-float double-float-exponent (double-float -1d0 1d0))
+ (movable foldable flushable))
+
+(defknown integer-decode-single-float (single-float)
+ (values single-float-significand single-float-int-exponent (integer -1 1))
+ (movable foldable flushable))
+
+(defknown integer-decode-double-float (double-float)
+ (values double-float-significand double-float-int-exponent (integer -1 1))
+ (movable foldable flushable))
+
+(defknown scale-single-float (single-float fixnum) single-float
+ (movable foldable flushable))
+
+(defknown scale-double-float (double-float fixnum) double-float
+ (movable foldable flushable))
+
+(deftransform decode-float ((x) (single-float) * :when :both)
+ '(decode-single-float x))
+
+(deftransform decode-float ((x) (double-float) * :when :both)
+ '(decode-double-float x))
+
+(deftransform integer-decode-float ((x) (single-float) * :when :both)
+ '(integer-decode-single-float x))
+
+(deftransform integer-decode-float ((x) (double-float) * :when :both)
+ '(integer-decode-double-float x))
+
+(deftransform scale-float ((f ex) (single-float *) * :when :both)
+ (if (and #!+x86 t #!-x86 nil
+ (csubtypep (continuation-type ex)
+ (specifier-type '(signed-byte 32)))
+ (not (byte-compiling)))
+ '(coerce (%scalbn (coerce f 'double-float) ex) 'single-float)
+ '(scale-single-float f ex)))
+
+(deftransform scale-float ((f ex) (double-float *) * :when :both)
+ (if (and #!+x86 t #!-x86 nil
+ (csubtypep (continuation-type ex)
+ (specifier-type '(signed-byte 32))))
+ '(%scalbn f ex)
+ '(scale-double-float f ex)))
+
+;;; toy@rtp.ericsson.se:
+;;;
+;;; Optimizers for scale-float. If the float has bounds, new bounds
+;;; are computed for the result, if possible.
+
+#-sb-xc-host ;(CROSS-FLOAT-INFINITY-KLUDGE, see base-target-features.lisp-expr)
+(progn
+#!+propagate-float-type
+(progn
+
+(defun scale-float-derive-type-aux (f ex same-arg)
+ (declare (ignore same-arg))
+ (flet ((scale-bound (x n)
+ ;; We need to be a bit careful here and catch any overflows
+ ;; that might occur. We can ignore underflows which become
+ ;; zeros.
+ (set-bound
+ (handler-case
+ (scale-float (bound-value x) n)
+ (floating-point-overflow ()
+ nil))
+ (consp x))))
+ (when (and (numeric-type-p f) (numeric-type-p ex))
+ (let ((f-lo (numeric-type-low f))
+ (f-hi (numeric-type-high f))
+ (ex-lo (numeric-type-low ex))
+ (ex-hi (numeric-type-high ex))
+ (new-lo nil)
+ (new-hi nil))
+ (when (and f-hi ex-hi)
+ (setf new-hi (scale-bound f-hi ex-hi)))
+ (when (and f-lo ex-lo)
+ (setf new-lo (scale-bound f-lo ex-lo)))
+ (make-numeric-type :class (numeric-type-class f)
+ :format (numeric-type-format f)
+ :complexp :real
+ :low new-lo
+ :high new-hi)))))
+(defoptimizer (scale-single-float derive-type) ((f ex))
+ (two-arg-derive-type f ex #'scale-float-derive-type-aux
+ #'scale-single-float t))
+(defoptimizer (scale-double-float derive-type) ((f ex))
+ (two-arg-derive-type f ex #'scale-float-derive-type-aux
+ #'scale-double-float t))
+
+;;; toy@rtp.ericsson.se:
+;;;
+;;; Defoptimizers for %single-float and %double-float. This makes the
+;;; FLOAT function return the correct ranges if the input has some
+;;; defined range. Quite useful if we want to convert some type of
+;;; bounded integer into a float.
+
+(macrolet
+ ((frob (fun type)
+ (let ((aux-name (symbolicate fun "-DERIVE-TYPE-AUX")))
+ `(progn
+ (defun ,aux-name (num)
+ ;; When converting a number to a float, the limits are
+ ;; the same.
+ (let* ((lo (bound-func #'(lambda (x)
+ (coerce x ',type))
+ (numeric-type-low num)))
+ (hi (bound-func #'(lambda (x)
+ (coerce x ',type))
+ (numeric-type-high num))))
+ (specifier-type `(,',type ,(or lo '*) ,(or hi '*)))))
+
+ (defoptimizer (,fun derive-type) ((num))
+ (one-arg-derive-type num #',aux-name #',fun))))))
+ (frob %single-float single-float)
+ (frob %double-float double-float))
+)) ; PROGN PROGN
+\f
+;;;; float contagion
+
+;;; Do some stuff to recognize when the loser is doing mixed float and
+;;; rational arithmetic, or different float types, and fix it up. If
+;;; we don't, he won't even get so much as an efficency note.
+(deftransform float-contagion-arg1 ((x y) * * :defun-only t :node node)
+ `(,(continuation-function-name (basic-combination-fun node))
+ (float x y) y))
+(deftransform float-contagion-arg2 ((x y) * * :defun-only t :node node)
+ `(,(continuation-function-name (basic-combination-fun node))
+ x (float y x)))
+
+(dolist (x '(+ * / -))
+ (%deftransform x '(function (rational float) *) #'float-contagion-arg1)
+ (%deftransform x '(function (float rational) *) #'float-contagion-arg2))
+
+(dolist (x '(= < > + * / -))
+ (%deftransform x '(function (single-float double-float) *)
+ #'float-contagion-arg1)
+ (%deftransform x '(function (double-float single-float) *)
+ #'float-contagion-arg2))
+
+;;; Prevent ZEROP, PLUSP, and MINUSP from losing horribly. We can't in
+;;; general float rational args to comparison, since Common Lisp
+;;; semantics says we are supposed to compare as rationals, but we can
+;;; do it for any rational that has a precise representation as a
+;;; float (such as 0).
+(macrolet ((frob (op)
+ `(deftransform ,op ((x y) (float rational) * :when :both)
+ (unless (constant-continuation-p y)
+ (give-up-ir1-transform
+ "can't open-code float to rational comparison"))
+ (let ((val (continuation-value y)))
+ (unless (eql (rational (float val)) val)
+ (give-up-ir1-transform
+ "~S doesn't have a precise float representation."
+ val)))
+ `(,',op x (float y x)))))
+ (frob <)
+ (frob >)
+ (frob =))
+\f
+;;;; irrational derive-type methods
+
+;;; Derive the result to be float for argument types in the
+;;; appropriate domain.
+#!-propagate-fun-type
+(dolist (stuff '((asin (real -1.0 1.0))
+ (acos (real -1.0 1.0))
+ (acosh (real 1.0))
+ (atanh (real -1.0 1.0))
+ (sqrt (real 0.0))))
+ (destructuring-bind (name type) stuff
+ (let ((type (specifier-type type)))
+ (setf (function-info-derive-type (function-info-or-lose name))
+ #'(lambda (call)
+ (declare (type combination call))
+ (when (csubtypep (continuation-type
+ (first (combination-args call)))
+ type)
+ (specifier-type 'float)))))))
+
+#!-propagate-fun-type
+(defoptimizer (log derive-type) ((x &optional y))
+ (when (and (csubtypep (continuation-type x)
+ (specifier-type '(real 0.0)))
+ (or (null y)
+ (csubtypep (continuation-type y)
+ (specifier-type '(real 0.0)))))
+ (specifier-type 'float)))
+\f
+;;;; irrational transforms
+
+(defknown (%tan %sinh %asinh %atanh %log %logb %log10 %tan-quick)
+ (double-float) double-float
+ (movable foldable flushable))
+
+(defknown (%sin %cos %tanh %sin-quick %cos-quick)
+ (double-float) (double-float -1.0d0 1.0d0)
+ (movable foldable flushable))
+
+(defknown (%asin %atan)
+ (double-float) (double-float #.(- (/ pi 2)) #.(/ pi 2))
+ (movable foldable flushable))
+
+(defknown (%acos)
+ (double-float) (double-float 0.0d0 #.pi)
+ (movable foldable flushable))
+
+(defknown (%cosh)
+ (double-float) (double-float 1.0d0)
+ (movable foldable flushable))
+
+(defknown (%acosh %exp %sqrt)
+ (double-float) (double-float 0.0d0)
+ (movable foldable flushable))
+
+(defknown %expm1
+ (double-float) (double-float -1d0)
+ (movable foldable flushable))
+
+(defknown (%hypot)
+ (double-float double-float) (double-float 0d0)
+ (movable foldable flushable))
+
+(defknown (%pow)
+ (double-float double-float) double-float
+ (movable foldable flushable))
+
+(defknown (%atan2)
+ (double-float double-float) (double-float #.(- pi) #.pi)
+ (movable foldable flushable))
+
+(defknown (%scalb)
+ (double-float double-float) double-float
+ (movable foldable flushable))
+
+(defknown (%scalbn)
+ (double-float (signed-byte 32)) double-float
+ (movable foldable flushable))
+
+(defknown (%log1p)
+ (double-float) double-float
+ (movable foldable flushable))
+
+(dolist (stuff '((exp %exp *)
+ (log %log float)
+ (sqrt %sqrt float)
+ (asin %asin float)
+ (acos %acos float)
+ (atan %atan *)
+ (sinh %sinh *)
+ (cosh %cosh *)
+ (tanh %tanh *)
+ (asinh %asinh *)
+ (acosh %acosh float)
+ (atanh %atanh float)))
+ (destructuring-bind (name prim rtype) stuff
+ (deftransform name ((x) '(single-float) rtype :eval-name t)
+ `(coerce (,prim (coerce x 'double-float)) 'single-float))
+ (deftransform name ((x) '(double-float) rtype :eval-name t :when :both)
+ `(,prim x))))
+
+;;; The argument range is limited on the x86 FP trig. functions. A
+;;; post-test can detect a failure (and load a suitable result), but
+;;; this test is avoided if possible.
+(dolist (stuff '((sin %sin %sin-quick)
+ (cos %cos %cos-quick)
+ (tan %tan %tan-quick)))
+ (destructuring-bind (name prim prim-quick) stuff
+ (deftransform name ((x) '(single-float) '* :eval-name t)
+ #!+x86 (cond ((csubtypep (continuation-type x)
+ (specifier-type '(single-float
+ (#.(- (expt 2f0 64)))
+ (#.(expt 2f0 64)))))
+ `(coerce (,prim-quick (coerce x 'double-float))
+ 'single-float))
+ (t
+ (compiler-note
+ "unable to avoid inline argument range check~@
+ because the argument range (~S) was not within 2^64"
+ (type-specifier (continuation-type x)))
+ `(coerce (,prim (coerce x 'double-float)) 'single-float)))
+ #!-x86 `(coerce (,prim (coerce x 'double-float)) 'single-float))
+ (deftransform name ((x) '(double-float) '* :eval-name t :when :both)
+ #!+x86 (cond ((csubtypep (continuation-type x)
+ (specifier-type '(double-float
+ (#.(- (expt 2d0 64)))
+ (#.(expt 2d0 64)))))
+ `(,prim-quick x))
+ (t
+ (compiler-note
+ "unable to avoid inline argument range check~@
+ because the argument range (~S) was not within 2^64"
+ (type-specifier (continuation-type x)))
+ `(,prim x)))
+ #!-x86 `(,prim x))))
+
+(deftransform atan ((x y) (single-float single-float) *)
+ `(coerce (%atan2 (coerce x 'double-float) (coerce y 'double-float))
+ 'single-float))
+(deftransform atan ((x y) (double-float double-float) * :when :both)
+ `(%atan2 x y))
+
+(deftransform expt ((x y) ((single-float 0f0) single-float) *)
+ `(coerce (%pow (coerce x 'double-float) (coerce y 'double-float))
+ 'single-float))
+(deftransform expt ((x y) ((double-float 0d0) double-float) * :when :both)
+ `(%pow x y))
+(deftransform expt ((x y) ((single-float 0f0) (signed-byte 32)) *)
+ `(coerce (%pow (coerce x 'double-float) (coerce y 'double-float))
+ 'single-float))
+(deftransform expt ((x y) ((double-float 0d0) (signed-byte 32)) * :when :both)
+ `(%pow x (coerce y 'double-float)))
+
+;;; ANSI says log with base zero returns zero.
+(deftransform log ((x y) (float float) float)
+ '(if (zerop y) y (/ (log x) (log y))))
+\f
+;;; Handle some simple transformations.
+
+(deftransform abs ((x) ((complex double-float)) double-float :when :both)
+ '(%hypot (realpart x) (imagpart x)))
+
+(deftransform abs ((x) ((complex single-float)) single-float)
+ '(coerce (%hypot (coerce (realpart x) 'double-float)
+ (coerce (imagpart x) 'double-float))
+ 'single-float))
+
+(deftransform phase ((x) ((complex double-float)) double-float :when :both)
+ '(%atan2 (imagpart x) (realpart x)))
+
+(deftransform phase ((x) ((complex single-float)) single-float)
+ '(coerce (%atan2 (coerce (imagpart x) 'double-float)
+ (coerce (realpart x) 'double-float))
+ 'single-float))
+
+(deftransform phase ((x) ((float)) float :when :both)
+ '(if (minusp (float-sign x))
+ (float pi x)
+ (float 0 x)))
+
+#!+(or propagate-float-type propagate-fun-type)
+(progn
+
+;;; The number is of type REAL.
+#!-sb-fluid (declaim (inline numeric-type-real-p))
+(defun numeric-type-real-p (type)
+ (and (numeric-type-p type)
+ (eq (numeric-type-complexp type) :real)))
+
+;;; Coerce a numeric type bound to the given type while handling
+;;; exclusive bounds.
+(defun coerce-numeric-bound (bound type)
+ (when bound
+ (if (consp bound)
+ (list (coerce (car bound) type))
+ (coerce bound type))))
+
+) ; PROGN
+
+#!+propagate-fun-type
+(progn
+
+;;;; optimizers for elementary functions
+;;;;
+;;;; These optimizers compute the output range of the elementary
+;;;; function, based on the domain of the input.
+
+;;; Generate a specifier for a complex type specialized to the same
+;;; type as the argument.
+(defun complex-float-type (arg)
+ (declare (type numeric-type arg))
+ (let* ((format (case (numeric-type-class arg)
+ ((integer rational) 'single-float)
+ (t (numeric-type-format arg))))
+ (float-type (or format 'float)))
+ (specifier-type `(complex ,float-type))))
+
+;;; Compute a specifier like '(or float (complex float)), except float
+;;; should be the right kind of float. Allow bounds for the float
+;;; part too.
+(defun float-or-complex-float-type (arg &optional lo hi)
+ (declare (type numeric-type arg))
+ (let* ((format (case (numeric-type-class arg)
+ ((integer rational) 'single-float)
+ (t (numeric-type-format arg))))
+ (float-type (or format 'float))
+ (lo (coerce-numeric-bound lo float-type))
+ (hi (coerce-numeric-bound hi float-type)))
+ (specifier-type `(or (,float-type ,(or lo '*) ,(or hi '*))
+ (complex ,float-type)))))
+
+;;; Test whether the numeric-type ARG is within in domain specified by
+;;; DOMAIN-LOW and DOMAIN-HIGH, consider negative and positive zero to
+;;; be distinct as for the :negative-zero-is-not-zero feature. With
+;;; the :negative-zero-is-not-zero feature this could be handled by
+;;; the numeric subtype code in type.lisp.
+(defun domain-subtypep (arg domain-low domain-high)
+ (declare (type numeric-type arg)
+ (type (or real null) domain-low domain-high))
+ (let* ((arg-lo (numeric-type-low arg))
+ (arg-lo-val (bound-value arg-lo))
+ (arg-hi (numeric-type-high arg))
+ (arg-hi-val (bound-value arg-hi)))
+ ;; Check that the ARG bounds are correctly canonicalized.
+ (when (and arg-lo (floatp arg-lo-val) (zerop arg-lo-val) (consp arg-lo)
+ (minusp (float-sign arg-lo-val)))
+ (compiler-note "float zero bound ~S not correctly canonicalized?" arg-lo)
+ (setq arg-lo '(0l0) arg-lo-val 0l0))
+ (when (and arg-hi (zerop arg-hi-val) (floatp arg-hi-val) (consp arg-hi)
+ (plusp (float-sign arg-hi-val)))
+ (compiler-note "float zero bound ~S not correctly canonicalized?" arg-hi)
+ (setq arg-hi '(-0l0) arg-hi-val -0l0))
+ (and (or (null domain-low)
+ (and arg-lo (>= arg-lo-val domain-low)
+ (not (and (zerop domain-low) (floatp domain-low)
+ (plusp (float-sign domain-low))
+ (zerop arg-lo-val) (floatp arg-lo-val)
+ (if (consp arg-lo)
+ (plusp (float-sign arg-lo-val))
+ (minusp (float-sign arg-lo-val)))))))
+ (or (null domain-high)
+ (and arg-hi (<= arg-hi-val domain-high)
+ (not (and (zerop domain-high) (floatp domain-high)
+ (minusp (float-sign domain-high))
+ (zerop arg-hi-val) (floatp arg-hi-val)
+ (if (consp arg-hi)
+ (minusp (float-sign arg-hi-val))
+ (plusp (float-sign arg-hi-val))))))))))
+
+;;; Elfun-Derive-Type-Simple
+;;;
+;;; Handle monotonic functions of a single variable whose domain is
+;;; possibly part of the real line. ARG is the variable, FCN is the
+;;; function, and DOMAIN is a specifier that gives the (real) domain
+;;; of the function. If ARG is a subset of the DOMAIN, we compute the
+;;; bounds directly. Otherwise, we compute the bounds for the
+;;; intersection between ARG and DOMAIN, and then append a complex
+;;; result, which occurs for the parts of ARG not in the DOMAIN.
+;;;
+;;; Negative and positive zero are considered distinct within
+;;; DOMAIN-LOW and DOMAIN-HIGH, as for the :negative-zero-is-not-zero
+;;; feature.
+;;;
+;;; DEFAULT-LOW and DEFAULT-HIGH are the lower and upper bounds if we
+;;; can't compute the bounds using FCN.
+(defun elfun-derive-type-simple (arg fcn domain-low domain-high
+ default-low default-high
+ &optional (increasingp t))
+ (declare (type (or null real) domain-low domain-high))
+ (etypecase arg
+ (numeric-type
+ (cond ((eq (numeric-type-complexp arg) :complex)
+ (make-numeric-type :class (numeric-type-class arg)
+ :format (numeric-type-format arg)
+ :complexp :complex))
+ ((numeric-type-real-p arg)
+ ;; The argument is real, so let's find the intersection
+ ;; between the argument and the domain of the function.
+ ;; We compute the bounds on the intersection, and for
+ ;; everything else, we return a complex number of the
+ ;; appropriate type.
+ (multiple-value-bind (intersection difference)
+ (interval-intersection/difference (numeric-type->interval arg)
+ (make-interval
+ :low domain-low
+ :high domain-high))
+ (cond
+ (intersection
+ ;; Process the intersection.
+ (let* ((low (interval-low intersection))
+ (high (interval-high intersection))
+ (res-lo (or (bound-func fcn (if increasingp low high))
+ default-low))
+ (res-hi (or (bound-func fcn (if increasingp high low))
+ default-high))
+ ;; Result specifier type.
+ (format (case (numeric-type-class arg)
+ ((integer rational) 'single-float)
+ (t (numeric-type-format arg))))
+ (bound-type (or format 'float))
+ (result-type
+ (make-numeric-type
+ :class 'float
+ :format format
+ :low (coerce-numeric-bound res-lo bound-type)
+ :high (coerce-numeric-bound res-hi bound-type))))
+ ;; If the ARG is a subset of the domain, we don't
+ ;; have to worry about the difference, because that
+ ;; can't occur.
+ (if (or (null difference)
+ ;; Check whether the arg is within the domain.
+ (domain-subtypep arg domain-low domain-high))
+ result-type
+ (list result-type
+ (specifier-type `(complex ,bound-type))))))
+ (t
+ ;; No intersection so the result must be purely complex.
+ (complex-float-type arg)))))
+ (t
+ (float-or-complex-float-type arg default-low default-high))))))
+
+(macrolet
+ ((frob (name domain-low domain-high def-low-bnd def-high-bnd
+ &key (increasingp t))
+ (let ((num (gensym)))
+ `(defoptimizer (,name derive-type) ((,num))
+ (one-arg-derive-type
+ ,num
+ #'(lambda (arg)
+ (elfun-derive-type-simple arg #',name
+ ,domain-low ,domain-high
+ ,def-low-bnd ,def-high-bnd
+ ,increasingp))
+ #',name)))))
+ ;; These functions are easy because they are defined for the whole
+ ;; real line.
+ (frob exp nil nil 0 nil)
+ (frob sinh nil nil nil nil)
+ (frob tanh nil nil -1 1)
+ (frob asinh nil nil nil nil)
+
+ ;; These functions are only defined for part of the real line. The
+ ;; condition selects the desired part of the line.
+ (frob asin -1d0 1d0 (- (/ pi 2)) (/ pi 2))
+ ;; Acos is monotonic decreasing, so we need to swap the function
+ ;; values at the lower and upper bounds of the input domain.
+ (frob acos -1d0 1d0 0 pi :increasingp nil)
+ (frob acosh 1d0 nil nil nil)
+ (frob atanh -1d0 1d0 -1 1)
+ ;; Kahan says that (sqrt -0.0) is -0.0, so use a specifier that
+ ;; includes -0.0.
+ (frob sqrt -0d0 nil 0 nil))
+
+;;; Compute bounds for (expt x y). This should be easy since (expt x
+;;; y) = (exp (* y (log x))). However, computations done this way
+;;; have too much roundoff. Thus we have to do it the hard way.
+(defun safe-expt (x y)
+ (handler-case
+ (expt x y)
+ (error ()
+ nil)))
+
+;;; Handle the case when x >= 1.
+(defun interval-expt-> (x y)
+ (case (sb!c::interval-range-info y 0d0)
+ ('+
+ ;; Y is positive and log X >= 0. The range of exp(y * log(x)) is
+ ;; obviously non-negative. We just have to be careful for
+ ;; infinite bounds (given by nil).
+ (let ((lo (safe-expt (sb!c::bound-value (sb!c::interval-low x))
+ (sb!c::bound-value (sb!c::interval-low y))))
+ (hi (safe-expt (sb!c::bound-value (sb!c::interval-high x))
+ (sb!c::bound-value (sb!c::interval-high y)))))
+ (list (sb!c::make-interval :low (or lo 1) :high hi))))
+ ('-
+ ;; Y is negative and log x >= 0. The range of exp(y * log(x)) is
+ ;; obviously [0, 1]. However, underflow (nil) means 0 is the
+ ;; result.
+ (let ((lo (safe-expt (sb!c::bound-value (sb!c::interval-high x))
+ (sb!c::bound-value (sb!c::interval-low y))))
+ (hi (safe-expt (sb!c::bound-value (sb!c::interval-low x))
+ (sb!c::bound-value (sb!c::interval-high y)))))
+ (list (sb!c::make-interval :low (or lo 0) :high (or hi 1)))))
+ (t
+ ;; Split the interval in half.
+ (destructuring-bind (y- y+)
+ (sb!c::interval-split 0 y t)
+ (list (interval-expt-> x y-)
+ (interval-expt-> x y+))))))
+
+;;; Handle the case when x <= 1
+(defun interval-expt-< (x y)
+ (case (sb!c::interval-range-info x 0d0)
+ ('+
+ ;; The case of 0 <= x <= 1 is easy
+ (case (sb!c::interval-range-info y)
+ ('+
+ ;; Y is positive and log X <= 0. The range of exp(y * log(x)) is
+ ;; obviously [0, 1]. We just have to be careful for infinite bounds
+ ;; (given by nil).
+ (let ((lo (safe-expt (sb!c::bound-value (sb!c::interval-low x))
+ (sb!c::bound-value (sb!c::interval-high y))))
+ (hi (safe-expt (sb!c::bound-value (sb!c::interval-high x))
+ (sb!c::bound-value (sb!c::interval-low y)))))
+ (list (sb!c::make-interval :low (or lo 0) :high (or hi 1)))))
+ ('-
+ ;; Y is negative and log x <= 0. The range of exp(y * log(x)) is
+ ;; obviously [1, inf].
+ (let ((hi (safe-expt (sb!c::bound-value (sb!c::interval-low x))
+ (sb!c::bound-value (sb!c::interval-low y))))
+ (lo (safe-expt (sb!c::bound-value (sb!c::interval-high x))
+ (sb!c::bound-value (sb!c::interval-high y)))))
+ (list (sb!c::make-interval :low (or lo 1) :high hi))))
+ (t
+ ;; Split the interval in half
+ (destructuring-bind (y- y+)
+ (sb!c::interval-split 0 y t)
+ (list (interval-expt-< x y-)
+ (interval-expt-< x y+))))))
+ ('-
+ ;; The case where x <= 0. Y MUST be an INTEGER for this to work!
+ ;; The calling function must insure this! For now we'll just
+ ;; return the appropriate unbounded float type.
+ (list (sb!c::make-interval :low nil :high nil)))
+ (t
+ (destructuring-bind (neg pos)
+ (interval-split 0 x t t)
+ (list (interval-expt-< neg y)
+ (interval-expt-< pos y))))))
+
+;;; Compute bounds for (expt x y).
+
+(defun interval-expt (x y)
+ (case (interval-range-info x 1)
+ ('+
+ ;; X >= 1
+ (interval-expt-> x y))
+ ('-
+ ;; X <= 1
+ (interval-expt-< x y))
+ (t
+ (destructuring-bind (left right)
+ (interval-split 1 x t t)
+ (list (interval-expt left y)
+ (interval-expt right y))))))
+
+(defun fixup-interval-expt (bnd x-int y-int x-type y-type)
+ (declare (ignore x-int))
+ ;; Figure out what the return type should be, given the argument
+ ;; types and bounds and the result type and bounds.
+ (cond ((csubtypep x-type (specifier-type 'integer))
+ ;; An integer to some power. Cases to consider:
+ (case (numeric-type-class y-type)
+ (integer
+ ;; Positive integer to an integer power is either an
+ ;; integer or a rational.
+ (let ((lo (or (interval-low bnd) '*))
+ (hi (or (interval-high bnd) '*)))
+ (if (and (interval-low y-int)
+ (>= (bound-value (interval-low y-int)) 0))
+ (specifier-type `(integer ,lo ,hi))
+ (specifier-type `(rational ,lo ,hi)))))
+ (rational
+ ;; Positive integer to rational power is either a rational
+ ;; or a single-float.
+ (let* ((lo (interval-low bnd))
+ (hi (interval-high bnd))
+ (int-lo (if lo
+ (floor (bound-value lo))
+ '*))
+ (int-hi (if hi
+ (ceiling (bound-value hi))
+ '*))
+ (f-lo (if lo
+ (bound-func #'float lo)
+ '*))
+ (f-hi (if hi
+ (bound-func #'float hi)
+ '*)))
+ (specifier-type `(or (rational ,int-lo ,int-hi)
+ (single-float ,f-lo, f-hi)))))
+ (float
+ ;; Positive integer to a float power is a float.
+ (let ((res (copy-numeric-type y-type)))
+ (setf (numeric-type-low res) (interval-low bnd))
+ (setf (numeric-type-high res) (interval-high bnd))
+ res))
+ (t
+ ;; Positive integer to a number is a number (for now).
+ (specifier-type 'number)))
+ )
+ ((csubtypep x-type (specifier-type 'rational))
+ ;; a rational to some power
+ (case (numeric-type-class y-type)
+ (integer
+ ;; Positive rational to an integer power is always a rational.
+ (specifier-type `(rational ,(or (interval-low bnd) '*)
+ ,(or (interval-high bnd) '*))))
+ (rational
+ ;; Positive rational to rational power is either a rational
+ ;; or a single-float.
+ (let* ((lo (interval-low bnd))
+ (hi (interval-high bnd))
+ (int-lo (if lo
+ (floor (bound-value lo))
+ '*))
+ (int-hi (if hi
+ (ceiling (bound-value hi))
+ '*))
+ (f-lo (if lo
+ (bound-func #'float lo)
+ '*))
+ (f-hi (if hi
+ (bound-func #'float hi)
+ '*)))
+ (specifier-type `(or (rational ,int-lo ,int-hi)
+ (single-float ,f-lo, f-hi)))))
+ (float
+ ;; Positive rational to a float power is a float.
+ (let ((res (copy-numeric-type y-type)))
+ (setf (numeric-type-low res) (interval-low bnd))
+ (setf (numeric-type-high res) (interval-high bnd))
+ res))
+ (t
+ ;; Positive rational to a number is a number (for now).
+ (specifier-type 'number)))
+ )
+ ((csubtypep x-type (specifier-type 'float))
+ ;; a float to some power
+ (case (numeric-type-class y-type)
+ ((or integer rational)
+ ;; Positive float to an integer or rational power is
+ ;; always a float.
+ (make-numeric-type
+ :class 'float
+ :format (numeric-type-format x-type)
+ :low (interval-low bnd)
+ :high (interval-high bnd)))
+ (float
+ ;; Positive float to a float power is a float of the higher type.
+ (make-numeric-type
+ :class 'float
+ :format (float-format-max (numeric-type-format x-type)
+ (numeric-type-format y-type))
+ :low (interval-low bnd)
+ :high (interval-high bnd)))
+ (t
+ ;; Positive float to a number is a number (for now)
+ (specifier-type 'number))))
+ (t
+ ;; A number to some power is a number.
+ (specifier-type 'number))))
+
+(defun merged-interval-expt (x y)
+ (let* ((x-int (numeric-type->interval x))
+ (y-int (numeric-type->interval y)))
+ (mapcar #'(lambda (type)
+ (fixup-interval-expt type x-int y-int x y))
+ (flatten-list (interval-expt x-int y-int)))))
+
+(defun expt-derive-type-aux (x y same-arg)
+ (declare (ignore same-arg))
+ (cond ((or (not (numeric-type-real-p x))
+ (not (numeric-type-real-p y)))
+ ;; Use numeric contagion if either is not real.
+ (numeric-contagion x y))
+ ((csubtypep y (specifier-type 'integer))
+ ;; A real raised to an integer power is well-defined.
+ (merged-interval-expt x y))
+ (t
+ ;; A real raised to a non-integral power can be a float or a
+ ;; complex number.
+ (cond ((or (csubtypep x (specifier-type '(rational 0)))
+ (csubtypep x (specifier-type '(float (0d0)))))
+ ;; But a positive real to any power is well-defined.
+ (merged-interval-expt x y))
+ (t
+ ;; A real to some power. The result could be a real
+ ;; or a complex.
+ (float-or-complex-float-type (numeric-contagion x y)))))))
+
+(defoptimizer (expt derive-type) ((x y))
+ (two-arg-derive-type x y #'expt-derive-type-aux #'expt))
+
+;;; Note we must assume that a type including 0.0 may also include
+;;; -0.0 and thus the result may be complex -infinity + i*pi.
+(defun log-derive-type-aux-1 (x)
+ (elfun-derive-type-simple x #'log 0d0 nil nil nil))
+
+(defun log-derive-type-aux-2 (x y same-arg)
+ (let ((log-x (log-derive-type-aux-1 x))
+ (log-y (log-derive-type-aux-1 y))
+ (result '()))
+ ;; log-x or log-y might be union types. We need to run through
+ ;; the union types ourselves because /-derive-type-aux doesn't.
+ (dolist (x-type (prepare-arg-for-derive-type log-x))
+ (dolist (y-type (prepare-arg-for-derive-type log-y))
+ (push (/-derive-type-aux x-type y-type same-arg) result)))
+ (setf result (flatten-list result))
+ (if (rest result)
+ (make-union-type result)
+ (first result))))
+
+(defoptimizer (log derive-type) ((x &optional y))
+ (if y
+ (two-arg-derive-type x y #'log-derive-type-aux-2 #'log)
+ (one-arg-derive-type x #'log-derive-type-aux-1 #'log)))
+
+(defun atan-derive-type-aux-1 (y)
+ (elfun-derive-type-simple y #'atan nil nil (- (/ pi 2)) (/ pi 2)))
+
+(defun atan-derive-type-aux-2 (y x same-arg)
+ (declare (ignore same-arg))
+ ;; The hard case with two args. We just return the max bounds.
+ (let ((result-type (numeric-contagion y x)))
+ (cond ((and (numeric-type-real-p x)
+ (numeric-type-real-p y))
+ (let* ((format (case (numeric-type-class result-type)
+ ((integer rational) 'single-float)
+ (t (numeric-type-format result-type))))
+ (bound-format (or format 'float)))
+ (make-numeric-type :class 'float
+ :format format
+ :complexp :real
+ :low (coerce (- pi) bound-format)
+ :high (coerce pi bound-format))))
+ (t
+ ;; The result is a float or a complex number
+ (float-or-complex-float-type result-type)))))
+
+(defoptimizer (atan derive-type) ((y &optional x))
+ (if x
+ (two-arg-derive-type y x #'atan-derive-type-aux-2 #'atan)
+ (one-arg-derive-type y #'atan-derive-type-aux-1 #'atan)))
+
+(defun cosh-derive-type-aux (x)
+ ;; We note that cosh x = cosh |x| for all real x.
+ (elfun-derive-type-simple
+ (if (numeric-type-real-p x)
+ (abs-derive-type-aux x)
+ x)
+ #'cosh nil nil 0 nil))
+
+(defoptimizer (cosh derive-type) ((num))
+ (one-arg-derive-type num #'cosh-derive-type-aux #'cosh))
+
+(defun phase-derive-type-aux (arg)
+ (let* ((format (case (numeric-type-class arg)
+ ((integer rational) 'single-float)
+ (t (numeric-type-format arg))))
+ (bound-type (or format 'float)))
+ (cond ((numeric-type-real-p arg)
+ (case (interval-range-info (numeric-type->interval arg) 0.0)
+ ('+
+ ;; The number is positive, so the phase is 0.
+ (make-numeric-type :class 'float
+ :format format
+ :complexp :real
+ :low (coerce 0 bound-type)
+ :high (coerce 0 bound-type)))
+ ('-
+ ;; The number is always negative, so the phase is pi.
+ (make-numeric-type :class 'float
+ :format format
+ :complexp :real
+ :low (coerce pi bound-type)
+ :high (coerce pi bound-type)))
+ (t
+ ;; We can't tell. The result is 0 or pi. Use a union
+ ;; type for this.
+ (list
+ (make-numeric-type :class 'float
+ :format format
+ :complexp :real
+ :low (coerce 0 bound-type)
+ :high (coerce 0 bound-type))
+ (make-numeric-type :class 'float
+ :format format
+ :complexp :real
+ :low (coerce pi bound-type)
+ :high (coerce pi bound-type))))))
+ (t
+ ;; We have a complex number. The answer is the range -pi
+ ;; to pi. (-pi is included because we have -0.)
+ (make-numeric-type :class 'float
+ :format format
+ :complexp :real
+ :low (coerce (- pi) bound-type)
+ :high (coerce pi bound-type))))))
+
+(defoptimizer (phase derive-type) ((num))
+ (one-arg-derive-type num #'phase-derive-type-aux #'phase))
+
+) ; PROGN
+
+(deftransform realpart ((x) ((complex rational)) *)
+ '(sb!kernel:%realpart x))
+(deftransform imagpart ((x) ((complex rational)) *)
+ '(sb!kernel:%imagpart x))
+
+;;; Make REALPART and IMAGPART return the appropriate types. This
+;;; should help a lot in optimized code.
+
+(defun realpart-derive-type-aux (type)
+ (let ((class (numeric-type-class type))
+ (format (numeric-type-format type)))
+ (cond ((numeric-type-real-p type)
+ ;; The realpart of a real has the same type and range as
+ ;; the input.
+ (make-numeric-type :class class
+ :format format
+ :complexp :real
+ :low (numeric-type-low type)
+ :high (numeric-type-high type)))
+ (t
+ ;; We have a complex number. The result has the same type
+ ;; as the real part, except that it's real, not complex,
+ ;; obviously.
+ (make-numeric-type :class class
+ :format format
+ :complexp :real
+ :low (numeric-type-low type)
+ :high (numeric-type-high type))))))
+
+#!+(or propagate-fun-type propagate-float-type)
+(defoptimizer (realpart derive-type) ((num))
+ (one-arg-derive-type num #'realpart-derive-type-aux #'realpart))
+
+(defun imagpart-derive-type-aux (type)
+ (let ((class (numeric-type-class type))
+ (format (numeric-type-format type)))
+ (cond ((numeric-type-real-p type)
+ ;; The imagpart of a real has the same type as the input,
+ ;; except that it's zero.
+ (let ((bound-format (or format class 'real)))
+ (make-numeric-type :class class
+ :format format
+ :complexp :real
+ :low (coerce 0 bound-format)
+ :high (coerce 0 bound-format))))
+ (t
+ ;; We have a complex number. The result has the same type as
+ ;; the imaginary part, except that it's real, not complex,
+ ;; obviously.
+ (make-numeric-type :class class
+ :format format
+ :complexp :real
+ :low (numeric-type-low type)
+ :high (numeric-type-high type))))))
+
+#!+(or propagate-fun-type propagate-float-type)
+(defoptimizer (imagpart derive-type) ((num))
+ (one-arg-derive-type num #'imagpart-derive-type-aux #'imagpart))
+
+(defun complex-derive-type-aux-1 (re-type)
+ (if (numeric-type-p re-type)
+ (make-numeric-type :class (numeric-type-class re-type)
+ :format (numeric-type-format re-type)
+ :complexp (if (csubtypep re-type
+ (specifier-type 'rational))
+ :real
+ :complex)
+ :low (numeric-type-low re-type)
+ :high (numeric-type-high re-type))
+ (specifier-type 'complex)))
+
+(defun complex-derive-type-aux-2 (re-type im-type same-arg)
+ (declare (ignore same-arg))
+ (if (and (numeric-type-p re-type)
+ (numeric-type-p im-type))
+ ;; Need to check to make sure numeric-contagion returns the
+ ;; right type for what we want here.
+
+ ;; Also, what about rational canonicalization, like (complex 5 0)
+ ;; is 5? So, if the result must be complex, we make it so.
+ ;; If the result might be complex, which happens only if the
+ ;; arguments are rational, we make it a union type of (or
+ ;; rational (complex rational)).
+ (let* ((element-type (numeric-contagion re-type im-type))
+ (rat-result-p (csubtypep element-type
+ (specifier-type 'rational))))
+ (if rat-result-p
+ (make-union-type
+ (list element-type
+ (specifier-type
+ `(complex ,(numeric-type-class element-type)))))
+ (make-numeric-type :class (numeric-type-class element-type)
+ :format (numeric-type-format element-type)
+ :complexp (if rat-result-p
+ :real
+ :complex))))
+ (specifier-type 'complex)))
+
+#!+(or propagate-fun-type propagate-float-type)
+(defoptimizer (complex derive-type) ((re &optional im))
+ (if im
+ (two-arg-derive-type re im #'complex-derive-type-aux-2 #'complex)
+ (one-arg-derive-type re #'complex-derive-type-aux-1 #'complex)))
+
+;;; Define some transforms for complex operations. We do this in lieu
+;;; of complex operation VOPs.
+(macrolet ((frob (type)
+ `(progn
+ ;; negation
+ (deftransform %negate ((z) ((complex ,type)) *)
+ '(complex (%negate (realpart z)) (%negate (imagpart z))))
+ ;; complex addition and subtraction
+ (deftransform + ((w z) ((complex ,type) (complex ,type)) *)
+ '(complex (+ (realpart w) (realpart z))
+ (+ (imagpart w) (imagpart z))))
+ (deftransform - ((w z) ((complex ,type) (complex ,type)) *)
+ '(complex (- (realpart w) (realpart z))
+ (- (imagpart w) (imagpart z))))
+ ;; Add and subtract a complex and a real.
+ (deftransform + ((w z) ((complex ,type) real) *)
+ '(complex (+ (realpart w) z) (imagpart w)))
+ (deftransform + ((z w) (real (complex ,type)) *)
+ '(complex (+ (realpart w) z) (imagpart w)))
+ ;; Add and subtract a real and a complex number.
+ (deftransform - ((w z) ((complex ,type) real) *)
+ '(complex (- (realpart w) z) (imagpart w)))
+ (deftransform - ((z w) (real (complex ,type)) *)
+ '(complex (- z (realpart w)) (- (imagpart w))))
+ ;; Multiply and divide two complex numbers.
+ (deftransform * ((x y) ((complex ,type) (complex ,type)) *)
+ '(let* ((rx (realpart x))
+ (ix (imagpart x))
+ (ry (realpart y))
+ (iy (imagpart y)))
+ (complex (- (* rx ry) (* ix iy))
+ (+ (* rx iy) (* ix ry)))))
+ (deftransform / ((x y) ((complex ,type) (complex ,type)) *)
+ '(let* ((rx (realpart x))
+ (ix (imagpart x))
+ (ry (realpart y))
+ (iy (imagpart y)))
+ (if (> (abs ry) (abs iy))
+ (let* ((r (/ iy ry))
+ (dn (* ry (+ 1 (* r r)))))
+ (complex (/ (+ rx (* ix r)) dn)
+ (/ (- ix (* rx r)) dn)))
+ (let* ((r (/ ry iy))
+ (dn (* iy (+ 1 (* r r)))))
+ (complex (/ (+ (* rx r) ix) dn)
+ (/ (- (* ix r) rx) dn))))))
+ ;; Multiply a complex by a real or vice versa.
+ (deftransform * ((w z) ((complex ,type) real) *)
+ '(complex (* (realpart w) z) (* (imagpart w) z)))
+ (deftransform * ((z w) (real (complex ,type)) *)
+ '(complex (* (realpart w) z) (* (imagpart w) z)))
+ ;; Divide a complex by a real.
+ (deftransform / ((w z) ((complex ,type) real) *)
+ '(complex (/ (realpart w) z) (/ (imagpart w) z)))
+ ;; conjugate of complex number
+ (deftransform conjugate ((z) ((complex ,type)) *)
+ '(complex (realpart z) (- (imagpart z))))
+ ;; CIS
+ (deftransform cis ((z) ((,type)) *)
+ '(complex (cos z) (sin z)))
+ ;; comparison
+ (deftransform = ((w z) ((complex ,type) (complex ,type)) *)
+ '(and (= (realpart w) (realpart z))
+ (= (imagpart w) (imagpart z))))
+ (deftransform = ((w z) ((complex ,type) real) *)
+ '(and (= (realpart w) z) (zerop (imagpart w))))
+ (deftransform = ((w z) (real (complex ,type)) *)
+ '(and (= (realpart z) w) (zerop (imagpart z)))))))
+
+ (frob single-float)
+ (frob double-float))
+
+;;; Here are simple optimizers for sin, cos, and tan. They do not
+;;; produce a minimal range for the result; the result is the widest
+;;; possible answer. This gets around the problem of doing range
+;;; reduction correctly but still provides useful results when the
+;;; inputs are union types.
+
+#!+propagate-fun-type
+(progn
+(defun trig-derive-type-aux (arg domain fcn
+ &optional def-lo def-hi (increasingp t))
+ (etypecase arg
+ (numeric-type
+ (cond ((eq (numeric-type-complexp arg) :complex)
+ (make-numeric-type :class (numeric-type-class arg)
+ :format (numeric-type-format arg)
+ :complexp :complex))
+ ((numeric-type-real-p arg)
+ (let* ((format (case (numeric-type-class arg)
+ ((integer rational) 'single-float)
+ (t (numeric-type-format arg))))
+ (bound-type (or format 'float)))
+ ;; If the argument is a subset of the "principal" domain
+ ;; of the function, we can compute the bounds because
+ ;; the function is monotonic. We can't do this in
+ ;; general for these periodic functions because we can't
+ ;; (and don't want to) do the argument reduction in
+ ;; exactly the same way as the functions themselves do
+ ;; it.
+ (if (csubtypep arg domain)
+ (let ((res-lo (bound-func fcn (numeric-type-low arg)))
+ (res-hi (bound-func fcn (numeric-type-high arg))))
+ (unless increasingp
+ (rotatef res-lo res-hi))
+ (make-numeric-type
+ :class 'float
+ :format format
+ :low (coerce-numeric-bound res-lo bound-type)
+ :high (coerce-numeric-bound res-hi bound-type)))
+ (make-numeric-type
+ :class 'float
+ :format format
+ :low (and def-lo (coerce def-lo bound-type))
+ :high (and def-hi (coerce def-hi bound-type))))))
+ (t
+ (float-or-complex-float-type arg def-lo def-hi))))))
+
+(defoptimizer (sin derive-type) ((num))
+ (one-arg-derive-type
+ num
+ #'(lambda (arg)
+ ;; Derive the bounds if the arg is in [-pi/2, pi/2].
+ (trig-derive-type-aux
+ arg
+ (specifier-type `(float ,(- (/ pi 2)) ,(/ pi 2)))
+ #'sin
+ -1 1))
+ #'sin))
+
+(defoptimizer (cos derive-type) ((num))
+ (one-arg-derive-type
+ num
+ #'(lambda (arg)
+ ;; Derive the bounds if the arg is in [0, pi].
+ (trig-derive-type-aux arg
+ (specifier-type `(float 0d0 ,pi))
+ #'cos
+ -1 1
+ nil))
+ #'cos))
+
+(defoptimizer (tan derive-type) ((num))
+ (one-arg-derive-type
+ num
+ #'(lambda (arg)
+ ;; Derive the bounds if the arg is in [-pi/2, pi/2].
+ (trig-derive-type-aux arg
+ (specifier-type `(float ,(- (/ pi 2)) ,(/ pi 2)))
+ #'tan
+ nil nil))
+ #'tan))
+
+;;; CONJUGATE always returns the same type as the input type.
+(defoptimizer (conjugate derive-type) ((num))
+ (continuation-type num))
+
+(defoptimizer (cis derive-type) ((num))
+ (one-arg-derive-type num
+ #'(lambda (arg)
+ (sb!c::specifier-type
+ `(complex ,(or (numeric-type-format arg) 'float))))
+ #'cis))
+
+) ; PROGN
--- /dev/null
+;;;; This file defines all the standard functions to be known
+;;;; functions. Each function has type and side-effect information,
+;;;; and may also have IR1 optimizers.
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!C")
+
+(file-comment
+ "$Header$")
+\f
+;;;; information for known functions:
+
+(defknown coerce (t type-specifier) t
+ ;; Note:
+ ;; (1) This is not FLUSHABLE because it's defined to signal errors.
+ ;; (2) It's not worth trying to make this FOLDABLE in the
+ ;; cross-compiler,because
+ ;; (a) it would probably be really hard to make all the
+ ;; tricky issues (e.g. which specialized array types are
+ ;; supported) match between cross-compiler and target
+ ;; compiler, and besides
+ ;; (b) leaving it not FOLDABLE lets us use the idiom
+ ;; (COERCE FOO 'SOME-SPECIALIZED-ARRAY-TYPE-OR-ANOTHER)
+ ;; as a way of delaying the generation of specialized
+ ;; array types until runtime, which helps us keep the
+ ;; cross-compiler's dumper relatively simple and which
+ ;; lets us preserve distinctions which might not even exist
+ ;; on the cross-compilation host (because ANSI doesn't
+ ;; guarantee that specialized array types exist there).
+ (movable #-sb-xc-host foldable)
+ :derive-type (result-type-specifier-nth-arg 2))
+(defknown list-to-simple-string* (list) simple-string)
+(defknown list-to-bit-vector* (list) bit-vector)
+(defknown list-to-vector* (list type) vector)
+(defknown list-to-simple-vector* (list) simple-vector)
+(defknown vector-to-vector* (vector type) vector)
+(defknown vector-to-simple-string* (vector) vector)
+
+(defknown type-of (t) t (foldable flushable))
+
+;;; These can be affected by type definitions, so they're not FOLDABLE.
+(defknown (upgraded-complex-part-type upgraded-array-element-type)
+ (type-specifier) type-specifier
+ (flushable))
+\f
+;;;; from the "Predicates" chapter:
+
+;;; FIXME: Is it right to have TYPEP (and TYPE-OF, elsewhere; and
+;;; perhaps SPECIAL-OPERATOR-P and others) be FOLDABLE in the
+;;; cross-compilation host? After all, some type relationships (e.g.
+;;; FIXNUMness) might be different between host and target. Perhaps
+;;; this property should be protected by #-SB-XC-HOST? Perhaps we need
+;;; 3-stage bootstrapping after all? (Ugh! It's *so* slow already!)
+(defknown typep (t type-specifier) boolean
+ (flushable
+ ;; Unlike SUBTYPEP or UPGRADED-ARRAY-ELEMENT-TYPE and friends, this
+ ;; seems to be FOLDABLE. Like SUBTYPEP, it's affected by type
+ ;; definitions, but unlike SUBTYPEP, there should be no way to make
+ ;; a TYPEP expression with constant arguments which doesn't return
+ ;; an error before the type declaration (because of undefined
+ ;; type). E.g. you can do
+ ;; (SUBTYPEP 'INTEGER 'FOO) => NIL, NIL
+ ;; (DEFTYPE FOO () T)
+ ;; (SUBTYPEP 'INTEGER 'FOO) => T, T
+ ;; but the analogous
+ ;; (TYPEP 12 'FOO)
+ ;; (DEFTYPE FOO () T)
+ ;; (TYPEP 12 'FOO)
+ ;; doesn't work because the first call is an error.
+ ;;
+ ;; (UPGRADED-ARRAY-ELEMENT-TYPE and UPGRADED-COMPLEX-PART-TYPE have
+ ;; behavior like SUBTYPEP in this respect, not like TYPEP.)
+ foldable))
+(defknown subtypep (type-specifier type-specifier) (values boolean boolean)
+ ;; This is not FOLDABLE because its value is affected by type
+ ;; definitions.
+ ;;
+ ;; FIXME: Is it OK to fold this when the types have already been
+ ;; defined? Does the code inherited from CMU CL already do this?
+ (flushable))
+
+(defknown (null symbolp atom consp listp numberp integerp rationalp floatp
+ complexp characterp stringp bit-vector-p vectorp
+ simple-vector-p simple-string-p simple-bit-vector-p arrayp
+ sb!xc:packagep functionp compiled-function-p not)
+ (t) boolean (movable foldable flushable))
+
+(defknown (eq eql) (t t) boolean (movable foldable flushable))
+(defknown (equal equalp) (t t) boolean (foldable flushable recursive))
+\f
+;;;; classes
+
+(sb!xc:deftype name-for-class () 't)
+(defknown class-name (sb!xc:class) name-for-class (flushable))
+(defknown find-class (name-for-class &optional t lexenv)
+ (or sb!xc:class null) ())
+(defknown class-of (t) sb!xc:class (flushable))
+(defknown layout-of (t) layout (flushable))
+(defknown copy-structure (structure-object) structure-object
+ (flushable unsafe))
+\f
+;;;; from the "Control Structure" chapter:
+
+;;; This is not FLUSHABLE, since it's required to signal an error if
+;;; unbound.
+(defknown (symbol-value symbol-function) (symbol) t ())
+
+(defknown boundp (symbol) boolean (flushable))
+(defknown fboundp ((or symbol cons)) boolean (flushable explicit-check))
+(defknown special-operator-p (symbol) t
+ ;; The set of special operators never changes.
+ (movable foldable flushable))
+(defknown set (symbol t) t (unsafe)
+ :derive-type #'result-type-last-arg)
+(defknown fdefinition ((or symbol cons)) function (unsafe explicit-check))
+(defknown %set-fdefinition ((or symbol cons) function) function
+ (unsafe explicit-check))
+(defknown makunbound (symbol) symbol)
+(defknown fmakunbound ((or symbol cons)) (or symbol cons)
+ (unsafe explicit-check))
+(defknown (get-setf-method get-setf-method-multiple-value)
+ ((or list symbol) &optional lexenv)
+ (values list list list form form)
+ (flushable))
+(defknown apply (callable t &rest t) *) ; ### Last arg must be List...
+(defknown funcall (callable &rest t) *)
+
+(defknown (mapcar maplist mapcan mapcon) (callable list &rest list) list
+ (call))
+
+(defknown (mapc mapl) (callable list &rest list) list (foldable call))
+
+;;; We let VALUES-LIST be foldable, since constant-folding will turn
+;;; it into VALUES. VALUES is not foldable, since MV constants are
+;;; represented by a call to VALUES.
+(defknown values (&rest t) * (movable flushable unsafe))
+(defknown values-list (list) * (movable foldable flushable))
+\f
+;;;; from the "Macros" chapter:
+
+(defknown macro-function (symbol &optional lexenv)
+ (or function null)
+ (flushable))
+(defknown (macroexpand macroexpand-1) (t &optional lexenv)
+ (values form &optional boolean))
+
+(defknown compiler-macro-function (t &optional lexenv)
+ (or function null)
+ (flushable))
+\f
+;;;; from the "Declarations" chapter:
+
+(defknown proclaim (list) (values) (recursive))
+
+;;;; from the "Symbols" chapter:
+
+(defknown get (symbol t &optional t) t (flushable))
+(defknown remprop (symbol t) t)
+(defknown symbol-plist (symbol) list (flushable))
+(defknown getf (list t &optional t) t (foldable flushable))
+(defknown get-properties (list list) (values t t list) (foldable flushable))
+(defknown symbol-name (symbol) simple-string (movable foldable flushable))
+(defknown make-symbol (string) symbol (flushable))
+(defknown copy-symbol (symbol &optional t) symbol (flushable))
+(defknown gensym (&optional (or string unsigned-byte)) symbol ())
+(defknown symbol-package (symbol) (or sb!xc:package null) (flushable))
+(defknown keywordp (t) boolean (flushable)) ; If someone uninterns it...
+\f
+;;;; from the "Packages" chapter:
+
+(sb!xc:deftype package-designator () '(or stringable sb!xc:package))
+(sb!xc:deftype symbols () '(or list symbol))
+
+;;; Should allow a package name, I think, tho CLtL II doesn't say so...
+(defknown gentemp (&optional string package-designator) symbol)
+
+(defknown make-package (stringable &key
+ (:use list)
+ (:nicknames list)
+ ;; ### Extensions...
+ (:internal-symbols index)
+ (:external-symbols index))
+ sb!xc:package)
+(defknown find-package (package-designator) (or sb!xc:package null)
+ (flushable))
+(defknown package-name (package-designator) (or simple-string null)
+ (flushable))
+(defknown package-nicknames (package-designator) list (flushable))
+(defknown rename-package (package-designator package-designator &optional list)
+ sb!xc:package)
+(defknown package-use-list (package-designator) list (flushable))
+(defknown package-used-by-list (package-designator) list (flushable))
+(defknown package-shadowing-symbols (package-designator) list (flushable))
+(defknown list-all-packages () list (flushable))
+(defknown intern (string &optional package-designator)
+ (values symbol (member :internal :external :inherited nil))
+ ())
+(defknown find-symbol (string &optional package-designator)
+ (values symbol (member :internal :external :inherited nil))
+ (flushable))
+(defknown (export import) (symbols &optional package-designator) (eql t))
+(defknown unintern (symbol &optional package-designator) boolean)
+(defknown unexport (symbols &optional package-designator) (eql t))
+(defknown shadowing-import (symbols &optional package-designator) (eql t))
+(defknown shadow ((or symbol string list) &optional package-designator) (eql t))
+(defknown (use-package unuse-package) ((or list package-designator) &optional package-designator) (eql t))
+(defknown find-all-symbols (stringable) list (flushable))
+\f
+;;;; from the "Numbers" chapter:
+
+(defknown zerop (number) boolean (movable foldable flushable explicit-check))
+(defknown (plusp minusp) (real) boolean
+ (movable foldable flushable explicit-check))
+(defknown (oddp evenp) (integer) boolean
+ (movable foldable flushable explicit-check))
+(defknown (= /=) (number &rest number) boolean
+ (movable foldable flushable explicit-check))
+(defknown (< > <= >=) (real &rest real) boolean
+ (movable foldable flushable explicit-check))
+(defknown (max min) (real &rest real) real
+ (movable foldable flushable explicit-check))
+
+(defknown + (&rest number) number
+ (movable foldable flushable explicit-check))
+(defknown - (number &rest number) number
+ (movable foldable flushable explicit-check))
+(defknown * (&rest number) number
+ (movable foldable flushable explicit-check))
+(defknown / (number &rest number) number
+ (movable foldable flushable explicit-check))
+(defknown (1+ 1-) (number) number
+ (movable foldable flushable explicit-check))
+
+(defknown conjugate (number) number
+ (movable foldable flushable explicit-check))
+
+(defknown gcd (&rest integer) unsigned-byte
+ (movable foldable flushable explicit-check)
+ #|:derive-type 'boolean-result-type|#)
+(defknown lcm (&rest integer) unsigned-byte
+ (movable foldable flushable explicit-check))
+
+#!-propagate-fun-type
+(defknown exp (number) irrational
+ (movable foldable flushable explicit-check recursive)
+ :derive-type #'result-type-float-contagion)
+
+#!+propagate-fun-type
+(defknown exp (number) irrational
+ (movable foldable flushable explicit-check recursive))
+
+(defknown expt (number number) number
+ (movable foldable flushable explicit-check recursive))
+(defknown log (number &optional real) irrational
+ (movable foldable flushable explicit-check))
+(defknown sqrt (number) irrational
+ (movable foldable flushable explicit-check))
+(defknown isqrt (unsigned-byte) unsigned-byte
+ (movable foldable flushable explicit-check recursive))
+
+(defknown (abs phase signum) (number) number
+ (movable foldable flushable explicit-check))
+(defknown cis (real) (complex float)
+ (movable foldable flushable explicit-check))
+
+#!-propagate-fun-type
+(progn
+(defknown (sin cos) (number)
+ (or (float -1.0 1.0) (complex float))
+ (movable foldable flushable explicit-check recursive)
+ :derive-type #'result-type-float-contagion)
+
+(defknown atan
+ (number &optional real) irrational
+ (movable foldable flushable explicit-check recursive)
+ :derive-type #'result-type-float-contagion)
+
+(defknown (tan sinh cosh tanh asinh)
+ (number) irrational (movable foldable flushable explicit-check recursive)
+ :derive-type #'result-type-float-contagion)
+) ; PROGN
+
+#!+propagate-fun-type
+(progn
+(defknown (sin cos) (number)
+ (or (float -1.0 1.0) (complex float))
+ (movable foldable flushable explicit-check recursive))
+
+(defknown atan
+ (number &optional real) irrational
+ (movable foldable flushable explicit-check recursive))
+
+(defknown (tan sinh cosh tanh asinh)
+ (number) irrational (movable foldable flushable explicit-check recursive))
+) ; PROGN
+
+(defknown (asin acos acosh atanh)
+ (number) irrational
+ (movable foldable flushable explicit-check recursive))
+
+(defknown float (real &optional float) float
+ (movable foldable flushable explicit-check))
+
+(defknown (rational) (real) rational
+ (movable foldable flushable explicit-check))
+
+(defknown (rationalize) (real) rational
+ (movable foldable flushable explicit-check recursive))
+
+(defknown (numerator denominator) (rational) integer
+ (movable foldable flushable))
+
+(defknown (floor ceiling truncate round)
+ (real &optional real) (values integer real)
+ (movable foldable flushable explicit-check))
+
+(defknown (mod rem) (real real) real
+ (movable foldable flushable explicit-check))
+
+(defknown (ffloor fceiling fround ftruncate)
+ (real &optional real) (values float float)
+ (movable foldable flushable explicit-check))
+
+(defknown decode-float (float) (values float float-exponent float)
+ (movable foldable flushable explicit-check))
+(defknown scale-float (float float-exponent) float
+ (movable foldable flushable explicit-check))
+(defknown float-radix (float) float-radix
+ (movable foldable flushable explicit-check))
+(defknown float-sign (float &optional float) float
+ (movable foldable flushable explicit-check))
+(defknown (float-digits float-precision) (float) float-digits
+ (movable foldable flushable explicit-check))
+(defknown integer-decode-float (float)
+ (values integer float-exponent (member -1 1))
+ (movable foldable flushable explicit-check))
+
+(defknown complex (real &optional real) number
+ (movable foldable flushable explicit-check))
+
+(defknown (realpart imagpart) (number) real (movable foldable flushable))
+
+(defknown (logior logxor logand logeqv) (&rest integer) integer
+ (movable foldable flushable explicit-check))
+
+(defknown (lognand lognor logandc1 logandc2 logorc1 logorc2)
+ (integer integer) integer
+ (movable foldable flushable explicit-check))
+
+(defknown boole (boole-code integer integer) integer
+ (movable foldable flushable))
+
+(defknown lognot (integer) integer (movable foldable flushable explicit-check))
+(defknown logtest (integer integer) boolean (movable foldable flushable))
+(defknown logbitp (bit-index integer) boolean (movable foldable flushable))
+(defknown ash (integer integer) integer (movable foldable flushable explicit-check))
+(defknown (logcount integer-length) (integer) bit-index
+ (movable foldable flushable explicit-check))
+;;; FIXME: According to the ANSI spec, it's legal to use any
+;;; nonnegative indices for BYTE arguments, not just BIT-INDEX. It's
+;;; hard to come up with useful ways to do this, but it is possible to
+;;; come up with *legal* ways to do this, so it would be nice
+;;; to fix this so we comply with the spec.
+(defknown byte (bit-index bit-index) byte-specifier
+ (movable foldable flushable))
+(defknown (byte-size byte-position) (byte-specifier) bit-index
+ (movable foldable flushable))
+(defknown ldb (byte-specifier integer) integer (movable foldable flushable))
+(defknown ldb-test (byte-specifier integer) boolean
+ (movable foldable flushable))
+(defknown mask-field (byte-specifier integer) integer
+ (movable foldable flushable))
+(defknown dpb (integer byte-specifier integer) integer
+ (movable foldable flushable))
+(defknown deposit-field (integer byte-specifier integer) integer
+ (movable foldable flushable))
+(defknown random ((real (0)) &optional random-state) (real 0) ())
+(defknown make-random-state (&optional (or (member nil t) random-state))
+ random-state (flushable))
+(defknown random-state-p (t) boolean (movable foldable flushable))
+\f
+;;;; from the "Characters" chapter:
+(defknown (standard-char-p graphic-char-p alpha-char-p
+ upper-case-p lower-case-p both-case-p alphanumericp)
+ (character) boolean (movable foldable flushable))
+
+(defknown digit-char-p (character &optional unsigned-byte)
+ (or (integer 0 35) null) (movable foldable flushable))
+
+(defknown (char= char/= char< char> char<= char>= char-equal char-not-equal
+ char-lessp char-greaterp char-not-greaterp char-not-lessp)
+ (character &rest character) boolean (movable foldable flushable))
+
+(defknown character (t) character (movable foldable flushable))
+(defknown char-code (character) char-code (movable foldable flushable))
+(defknown (char-upcase char-downcase) (character) character
+ (movable foldable flushable))
+(defknown digit-char (integer &optional integer)
+ (or character null) (movable foldable flushable))
+(defknown char-int (character) char-code (movable foldable flushable))
+(defknown char-name (character) (or simple-string null)
+ (movable foldable flushable))
+(defknown name-char (stringable) (or character null)
+ (movable foldable flushable))
+(defknown code-char (char-code) base-char
+ ;; By suppressing constant folding on CODE-CHAR when the
+ ;; cross-compiler is running in the cross-compilation host vanilla
+ ;; ANSI Common Lisp, we can use CODE-CHAR expressions to delay until
+ ;; target Lisp run time the generation of CHARACTERs which aren't
+ ;; STANDARD-CHARACTERs. That way, we don't need to rely on the host
+ ;; Common Lisp being able to handle any characters other than those
+ ;; guaranteed by the ANSI spec.
+ (movable #-sb-xc-host foldable flushable))
+\f
+;;;; from the "Sequences" chapter:
+
+(defknown elt (sequence index) t (foldable flushable))
+
+(defknown subseq (sequence index &optional sequence-end) consed-sequence
+ (flushable)
+ :derive-type (sequence-result-nth-arg 1))
+
+(defknown copy-seq (sequence) consed-sequence (flushable)
+ :derive-type #'result-type-first-arg)
+
+(defknown length (sequence) index (foldable flushable))
+
+(defknown reverse (sequence) consed-sequence (flushable)
+ :derive-type #'result-type-first-arg)
+
+(defknown nreverse (sequence) sequence ()
+ :derive-type #'result-type-first-arg)
+
+(defknown make-sequence (type-specifier index
+ &key
+ (:initial-element t))
+ consed-sequence
+ (movable flushable unsafe)
+ :derive-type (result-type-specifier-nth-arg 1))
+
+(defknown concatenate (type-specifier &rest sequence) consed-sequence
+ (flushable)
+ :derive-type (result-type-specifier-nth-arg 1))
+
+(defknown map (type-specifier callable sequence &rest sequence) consed-sequence
+ (flushable call)
+; :DERIVE-TYPE 'TYPE-SPEC-ARG1 ? Nope... (MAP NIL ...) returns NULL, not NIL.
+ )
+(defknown %map-to-list-arity-1 (callable sequence) list (flushable call))
+(defknown %map-to-simple-vector-arity-1 (callable sequence) simple-vector
+ (flushable call))
+(defknown %map-to-nil-on-simple-vector (callable simple-vector) null
+ (flushable call))
+(defknown %map-to-nil-on-vector (callable vector) null (flushable call))
+(defknown %map-to-nil-on-sequence (callable sequence) null (flushable call))
+
+;;; returns predicate result...
+(defknown some (callable sequence &rest sequence) t
+ (foldable flushable call))
+
+(defknown (every notany notevery) (callable sequence &rest sequence) boolean
+ (foldable flushable call))
+
+;;; unsafe for :INITIAL-VALUE...
+(defknown reduce (callable
+ sequence
+ &key
+ (:from-end t)
+ (:start index)
+ (:end sequence-end)
+ (:initial-value t)
+ (:key callable))
+ t
+ (foldable flushable call unsafe))
+
+(defknown fill (sequence t &key (:start index) (:end sequence-end)) sequence
+ (unsafe)
+ :derive-type #'result-type-first-arg)
+
+(defknown replace (sequence
+ sequence
+ &key
+ (:start1 index)
+ (:end1 sequence-end)
+ (:start2 index)
+ (:end2 sequence-end))
+ sequence ()
+ :derive-type #'result-type-first-arg)
+
+(defknown remove
+ (t sequence &key (:from-end t) (:test callable)
+ (:test-not callable) (:start index) (:end sequence-end)
+ (:count sequence-end) (:key callable))
+ consed-sequence
+ (flushable call)
+ :derive-type (sequence-result-nth-arg 2))
+
+(defknown substitute
+ (t t sequence &key (:from-end t) (:test callable)
+ (:test-not callable) (:start index) (:end sequence-end)
+ (:count sequence-end) (:key callable))
+ consed-sequence
+ (flushable call)
+ :derive-type (sequence-result-nth-arg 3))
+
+(defknown (remove-if remove-if-not)
+ (callable sequence &key (:from-end t) (:start index) (:end sequence-end)
+ (:count sequence-end) (:key callable))
+ consed-sequence
+ (flushable call)
+ :derive-type (sequence-result-nth-arg 2))
+
+(defknown (substitute-if substitute-if-not)
+ (t callable sequence &key (:from-end t) (:start index) (:end sequence-end)
+ (:count sequence-end) (:key callable))
+ consed-sequence
+ (flushable call)
+ :derive-type (sequence-result-nth-arg 3))
+
+(defknown delete
+ (t sequence &key (:from-end t) (:test callable)
+ (:test-not callable) (:start index) (:end sequence-end)
+ (:count sequence-end) (:key callable))
+ sequence
+ (flushable call)
+ :derive-type (sequence-result-nth-arg 2))
+
+(defknown nsubstitute
+ (t t sequence &key (:from-end t) (:test callable)
+ (:test-not callable) (:start index) (:end sequence-end)
+ (:count sequence-end) (:key callable))
+ sequence
+ (flushable call)
+ :derive-type (sequence-result-nth-arg 3))
+
+(defknown (delete-if delete-if-not)
+ (callable sequence &key (:from-end t) (:start index) (:end sequence-end)
+ (:count sequence-end) (:key callable))
+ sequence
+ (flushable call)
+ :derive-type (sequence-result-nth-arg 2))
+
+(defknown (nsubstitute-if nsubstitute-if-not)
+ (t callable sequence &key (:from-end t) (:start index) (:end sequence-end)
+ (:count sequence-end) (:key callable))
+ sequence
+ (flushable call)
+ :derive-type (sequence-result-nth-arg 3))
+
+(defknown remove-duplicates
+ (sequence &key (:test callable) (:test-not callable) (:start index) (:from-end t)
+ (:end sequence-end) (:key callable))
+ consed-sequence
+ (flushable call)
+ :derive-type (sequence-result-nth-arg 1))
+
+(defknown delete-duplicates
+ (sequence &key (:test callable) (:test-not callable) (:start index) (:from-end t)
+ (:end sequence-end) (:key callable))
+ sequence
+ (flushable call)
+ :derive-type (sequence-result-nth-arg 1))
+
+(defknown find (t sequence &key (:test callable) (:test-not callable)
+ (:start index) (:from-end t) (:end sequence-end) (:key callable))
+ t
+ (foldable flushable call))
+
+(defknown (find-if find-if-not)
+ (callable sequence &key (:from-end t) (:start index) (:end sequence-end)
+ (:key callable))
+ t
+ (foldable flushable call))
+
+(defknown position (t sequence &key (:test callable) (:test-not callable)
+ (:start index) (:from-end t) (:end sequence-end)
+ (:key callable))
+ (or index null)
+ (foldable flushable call))
+
+(defknown (position-if position-if-not)
+ (callable sequence &key (:from-end t) (:start index) (:end sequence-end)
+ (:key callable))
+ (or index null)
+ (foldable flushable call))
+
+(defknown count (t sequence &key (:test callable) (:test-not callable)
+ (:start index) (:from-end t) (:end sequence-end)
+ (:key callable))
+ index
+ (foldable flushable call))
+
+(defknown (count-if count-if-not)
+ (callable sequence &key (:from-end t) (:start index) (:end sequence-end)
+ (:key callable))
+ index
+ (foldable flushable call))
+
+(defknown (mismatch search)
+ (sequence sequence &key (:from-end t) (:test callable) (:test-not callable)
+ (:start1 index) (:end1 sequence-end) (:start2 index) (:end2 sequence-end)
+ (:key callable))
+ (or index null)
+ (foldable flushable call))
+
+;;; not FLUSHABLE, since vector sort guaranteed in-place...
+(defknown (stable-sort sort) (sequence callable &key (:key callable)) sequence
+ (call)
+ :derive-type (sequence-result-nth-arg 1))
+
+(defknown merge (type-specifier sequence sequence callable
+ &key (:key callable))
+ sequence
+ (flushable call)
+ :derive-type (result-type-specifier-nth-arg 1))
+
+;;; not FLUSHABLE, despite what CMU CL's DEFKNOWN said..
+(defknown read-sequence (sequence stream
+ &key
+ (:start index)
+ (:end sequence-end))
+ (index)
+ ())
+
+(defknown write-sequence (sequence stream
+ &key
+ (:start index)
+ (:end sequence-end))
+ sequence
+ ()
+ :derive-type (sequence-result-nth-arg 1))
+\f
+;;;; from the "Manipulating List Structure" chapter:
+(defknown (car cdr caar cadr cdar cddr
+ caaar caadr cadar caddr cdaar cdadr cddar cdddr
+ caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr
+ cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr
+ first second third fourth fifth sixth seventh eighth ninth tenth
+ rest)
+ (list)
+ t
+ (foldable flushable))
+
+(defknown cons (t t) cons (movable flushable unsafe))
+
+(defknown tree-equal (t t &key (:test callable) (:test-not callable)) boolean
+ (foldable flushable call))
+(defknown endp (t) boolean (foldable flushable movable))
+(defknown list-length (list) (or index null) (foldable flushable))
+(defknown (nth nthcdr) (index list) t (foldable flushable))
+(defknown last (list &optional index) list (foldable flushable))
+(defknown list (&rest t) list (movable flushable unsafe))
+(defknown list* (t &rest t) t (movable flushable unsafe))
+(defknown make-list (index &key (:initial-element t)) list
+ (movable flushable unsafe))
+
+;;; All but last must be list...
+(defknown append (&rest t) t (flushable))
+
+(defknown copy-list (list) list (flushable))
+(defknown copy-alist (list) list (flushable))
+(defknown copy-tree (t) t (flushable recursive))
+(defknown revappend (list t) t (flushable))
+(defknown nconc (&rest list) list ())
+(defknown nreconc (list t) list ())
+(defknown butlast (list &optional index) list (flushable))
+(defknown nbutlast (list &optional index) list ())
+(defknown ldiff (list t) list (flushable))
+(defknown (rplaca rplacd) (cons t) list (unsafe))
+
+(defknown (nsubst subst) (t t t &key (:key callable) (:test callable)
+ (:test-not callable))
+ list (flushable unsafe call))
+
+(defknown (subst-if subst-if-not nsubst-if nsubst-if-not)
+ (t t t &key (:key callable))
+ list (flushable unsafe call))
+
+(defknown (sublis nsublis) (list t &key (:key callable) (:test callable)
+ (:test-not callable))
+ list (flushable unsafe call))
+
+(defknown member (t list &key (:key callable) (:test callable)
+ (:test-not callable))
+ list (foldable flushable call))
+(defknown (member-if member-if-not) (callable list &key (:key callable))
+ list (foldable flushable call))
+
+(defknown tailp (t list) boolean (foldable flushable))
+
+(defknown adjoin (t list &key (:key callable) (:test callable)
+ (:test-not callable))
+ list (foldable flushable unsafe call))
+
+(defknown (union intersection set-difference set-exclusive-or)
+ (list list &key (:key callable) (:test callable) (:test-not callable))
+ list
+ (foldable flushable call))
+
+(defknown (nunion nintersection nset-difference nset-exclusive-or)
+ (list list &key (:key callable) (:test callable) (:test-not callable))
+ list
+ (foldable flushable call))
+
+(defknown subsetp
+ (list list &key (:key callable) (:test callable) (:test-not callable))
+ boolean
+ (foldable flushable call))
+
+(defknown acons (t t t) list (movable flushable unsafe))
+(defknown pairlis (t t &optional t) list (flushable unsafe))
+
+(defknown (rassoc assoc)
+ (t list &key (:key callable) (:test callable) (:test-not callable))
+ list (foldable flushable call))
+(defknown (assoc-if-not assoc-if rassoc-if rassoc-if-not)
+ (callable list &key (:key callable)) list (foldable flushable call))
+
+(defknown (memq assq) (t list) list (foldable flushable unsafe))
+(defknown delq (t list) list (flushable unsafe))
+\f
+;;;; from the "Hash Tables" chapter:
+
+(defknown make-hash-table
+ (&key (:test callable) (:size unsigned-byte)
+ (:rehash-size (or (integer 1) (float (1.0))))
+ (:rehash-threshold (real 0 1))
+ (:weak-p t))
+ hash-table
+ (flushable unsafe))
+(defknown hash-table-p (t) boolean (movable foldable flushable))
+(defknown gethash (t hash-table &optional t) (values t boolean)
+ (foldable flushable unsafe))
+(defknown %puthash (t hash-table t) t (unsafe))
+(defknown remhash (t hash-table) boolean ())
+(defknown maphash (callable hash-table) null (foldable flushable call))
+(defknown clrhash (hash-table) hash-table ())
+(defknown hash-table-count (hash-table) index (foldable flushable))
+(defknown hash-table-rehash-size (hash-table) (or (integer 1) (float (1.0)))
+ (foldable flushable))
+(defknown hash-table-rehash-threshold (hash-table) (real 0 1)
+ (foldable flushable))
+(defknown hash-table-size (hash-table) index (foldable flushable))
+(defknown hash-table-test (hash-table) symbol (foldable flushable))
+(defknown sxhash (t) (integer 0 #.sb!vm:*target-most-positive-fixnum*)
+ (foldable flushable))
+\f
+;;;; from the "Arrays" chapter
+
+(defknown make-array ((or index list)
+ &key
+ (:element-type type-specifier)
+ (:initial-element t)
+ (:initial-contents t)
+ (:adjustable t)
+ (:fill-pointer t)
+ (:displaced-to (or array null))
+ (:displaced-index-offset index))
+ array (flushable unsafe))
+
+(defknown vector (&rest t) simple-vector (flushable unsafe))
+
+(defknown aref (array &rest index) t (foldable flushable))
+(defknown row-major-aref (array index) t (foldable flushable))
+
+(defknown array-element-type (array)
+ type-specifier
+ (foldable flushable recursive))
+(defknown array-rank (array) array-rank (foldable flushable))
+(defknown array-dimension (array array-rank) index (foldable flushable))
+(defknown array-dimensions (array) list (foldable flushable))
+(defknown array-in-bounds-p (array &rest index) boolean (foldable flushable))
+(defknown array-row-major-index (array &rest index) array-total-size
+ (foldable flushable))
+(defknown array-total-size (array) array-total-size (foldable flushable))
+(defknown adjustable-array-p (array) boolean (movable foldable flushable))
+
+(defknown svref (simple-vector index) t (foldable flushable))
+(defknown bit ((array bit) &rest index) bit (foldable flushable))
+(defknown sbit ((simple-array bit) &rest index) bit (foldable flushable))
+
+(defknown (bit-and bit-ior bit-xor bit-eqv bit-nand bit-nor bit-andc1 bit-andc2
+ bit-orc1 bit-orc2)
+ ((array bit) (array bit) &optional (or (array bit) (member t)))
+ (array bit)
+ (foldable)
+ #|:derive-type #'result-type-last-arg|#)
+
+(defknown bit-not ((array bit) &optional (or (array bit) (member t)))
+ (array bit)
+ (foldable)
+ #|:derive-type #'result-type-last-arg|#)
+
+(defknown array-has-fill-pointer-p (array) boolean (movable foldable flushable))
+(defknown fill-pointer (vector) index (foldable flushable))
+(defknown vector-push (t vector) (or index null) ())
+(defknown vector-push-extend (t vector &optional index) index ())
+(defknown vector-pop (vector) t ())
+
+(defknown adjust-array
+ (array (or index list) &key (:element-type type-specifier)
+ (:initial-element t) (:initial-contents list)
+ (:fill-pointer t) (:displaced-to (or array null))
+ (:displaced-index-offset index))
+ array (unsafe))
+; :derive-type 'result-type-arg1) Not even close...
+\f
+;;;; from the "Strings" chapter:
+
+(defknown char (string index) character (foldable flushable))
+(defknown schar (simple-string index) character (foldable flushable))
+
+(sb!xc:deftype stringable () '(or character string symbol))
+
+(defknown (string= string-equal)
+ (stringable stringable &key (:start1 index) (:end1 sequence-end)
+ (:start2 index) (:end2 sequence-end))
+ boolean
+ (foldable flushable))
+
+(defknown (string< string> string<= string>= string/= string-lessp
+ string-greaterp string-not-lessp string-not-greaterp
+ string-not-equal)
+ (stringable stringable &key (:start1 index) (:end1 sequence-end)
+ (:start2 index) (:end2 sequence-end))
+ (or index null)
+ (foldable flushable))
+
+(defknown make-string (index &key (:element-type type-specifier)
+ (:initial-element character))
+ simple-string (flushable))
+
+(defknown (string-trim string-left-trim string-right-trim)
+ (sequence stringable) simple-string (flushable))
+
+(defknown (string-upcase string-downcase string-capitalize)
+ (stringable &key (:start index) (:end sequence-end))
+ simple-string (flushable))
+
+(defknown (nstring-upcase nstring-downcase nstring-capitalize)
+ (string &key (:start index) (:end sequence-end))
+ string ())
+
+(defknown string (stringable) string
+ (flushable explicit-check))
+\f
+;;;; internal non-keyword versions of string predicates:
+
+(defknown (string<* string>* string<=* string>=* string/=*)
+ (stringable stringable index sequence-end index sequence-end)
+ (or index null)
+ (foldable flushable))
+
+(defknown string=*
+ (stringable stringable index sequence-end index sequence-end)
+ boolean
+ (foldable flushable))
+\f
+;;;; from the "Eval" chapter:
+
+(defknown eval (t) * (recursive))
+(defknown constantp (t &optional lexenv) boolean
+ (foldable flushable))
+\f
+;;;; from the "Streams" chapter:
+
+(defknown make-synonym-stream (symbol) stream (flushable))
+(defknown make-broadcast-stream (&rest stream) stream (flushable))
+(defknown make-concatenated-stream (&rest stream) stream (flushable))
+(defknown make-two-way-stream (stream stream) stream (flushable))
+(defknown make-echo-stream (stream stream) stream (flushable))
+(defknown make-string-input-stream (string &optional index index) stream (flushable unsafe))
+(defknown make-string-output-stream () stream (flushable))
+(defknown get-output-stream-string (stream) simple-string ())
+(defknown streamp (t) boolean (movable foldable flushable))
+(defknown stream-element-type (stream) type-specifier (movable foldable flushable))
+(defknown (output-stream-p input-stream-p) (stream) boolean (movable foldable
+ flushable))
+(defknown close (stream &key (:abort t)) stream ())
+\f
+;;;; from the "Input/Output" chapter:
+
+;;; The I/O functions are currently given effects ANY under the theory
+;;; that code motion over I/O operations is particularly confusing and
+;;; not very important for efficency.
+
+(defknown copy-readtable (&optional (or readtable null) readtable) readtable
+ ())
+(defknown readtablep (t) boolean (movable foldable flushable))
+
+(defknown set-syntax-from-char
+ (character character &optional (or readtable null) readtable) (eql t)
+ ())
+
+(defknown set-macro-character (character callable &optional t readtable) (eql t)
+ (unsafe))
+(defknown get-macro-character (character &optional readtable)
+ (values callable boolean) (flushable))
+
+(defknown make-dispatch-macro-character (character &optional t readtable)
+ (eql t) ())
+(defknown set-dispatch-macro-character
+ (character character callable &optional readtable) (eql t)
+ (unsafe))
+(defknown get-dispatch-macro-character
+ (character character &optional readtable) callable
+ (flushable))
+
+;;; may return any type due to eof-value...
+(defknown (read read-preserving-whitespace read-char-no-hang read-char)
+ (&optional streamlike t t t) t (explicit-check))
+
+(defknown read-delimited-list (character &optional streamlike t) t
+ (explicit-check))
+(defknown read-line (&optional streamlike t t t) (values t boolean)
+ (explicit-check))
+(defknown unread-char (character &optional streamlike) t
+ (explicit-check))
+(defknown peek-char (&optional (or character (member nil t)) streamlike t t t)
+ t
+ (explicit-check))
+(defknown listen (&optional streamlike) boolean (flushable explicit-check))
+
+(defknown clear-input (&optional stream) null (explicit-check))
+
+(defknown read-from-string
+ (string &optional t t
+ &key
+ (:start index)
+ (:end sequence-end)
+ (:preserve-whitespace t))
+ (values t index))
+(defknown parse-integer
+ (string &key
+ (:start index)
+ (:end sequence-end)
+ (:radix (integer 2 36))
+ (:junk-allowed t))
+ (values (or integer null ()) index))
+
+(defknown read-byte (stream &optional t t) t (explicit-check))
+
+(defknown write
+ (t &key
+ (:stream streamlike)
+ (:escape t)
+ (:radix t)
+ (:base (integer 2 36))
+ (:circle t)
+ (:pretty t)
+ (:level (or unsigned-byte null))
+ (:readably t)
+ (:length (or unsigned-byte null))
+ (:case t)
+ (:array t)
+ (:gensym t)
+ (:lines (or unsigned-byte null))
+ (:right-margin (or unsigned-byte null))
+ (:miser-width (or unsigned-byte null))
+ (:pprint-dispatch t))
+ t
+ (any explicit-check)
+ :derive-type #'result-type-first-arg)
+
+(defknown (prin1 print princ) (t &optional streamlike) t (any explicit-check)
+ :derive-type #'result-type-first-arg)
+
+;;; xxx-TO-STRING functions are not foldable because they depend on
+;;; the dynamic environment.
+(defknown write-to-string
+ (t &key (:escape t) (:radix t) (:base (integer 2 36)) (:readably t)
+ (:circle t) (:pretty t) (:level (or unsigned-byte null))
+ (:length (or unsigned-byte null)) (:case t) (:array t) (:gensym t)
+ (:lines (or unsigned-byte null)) (:right-margin (or unsigned-byte null))
+ (:miser-width (or unsigned-byte null)) (:pprint-dispatch t))
+ simple-string
+ (foldable flushable explicit-check))
+
+(defknown (prin1-to-string princ-to-string) (t) simple-string (flushable))
+
+(defknown write-char (character &optional streamlike) character
+ (explicit-check))
+(defknown (write-string write-line)
+ (string &optional streamlike &key (:start index) (:end sequence-end))
+ string
+ (explicit-check))
+
+(defknown (terpri finish-output force-output clear-output)
+ (&optional streamlike) null
+ (explicit-check))
+
+(defknown fresh-line (&optional streamlike) boolean
+ (explicit-check))
+
+(defknown write-byte (integer stream) integer
+ (explicit-check))
+
+(defknown format ((or streamlike string) (or string function) &rest t)
+ (or string null)
+ (explicit-check))
+
+(defknown (y-or-n-p yes-or-no-p) (&optional string &rest t) boolean
+ (explicit-check))
+\f
+;;;; from the "File System Interface" chapter:
+
+;;; No pathname functions are foldable because they all potentially
+;;; depend on *DEFAULT-PATHNAME-DEFAULTS*, e.g. to provide a default
+;;; host when parsing a namestring.
+
+(defknown wild-pathname-p (pathname-designator
+ &optional
+ (member nil :host :device
+ :directory :name
+ :type :version))
+ boolean
+ (flushable))
+(defknown pathname-match-p (pathname-designator pathname-designator) boolean
+ (flushable))
+(defknown translate-pathname (pathname-designator
+ pathname-designator
+ pathname-designator &key)
+ pathname
+ (flushable))
+
+;;; KLUDGE: There was a comment from CMU CL here, "We need to add the
+;;; logical pathname stuff here." -- WHN 19991213
+
+(defknown pathname (pathname-designator) pathname (flushable))
+(defknown truename (pathname-designator) pathname ())
+
+(defknown parse-namestring
+ (pathname-designator &optional pathname-host pathname-designator
+ &key
+ (:start index)
+ (:end sequence-end)
+ (:junk-allowed t))
+ (values (or pathname null) index)
+ ())
+
+(defknown merge-pathnames
+ (pathname-designator &optional pathname-designator pathname-version)
+ pathname
+ (flushable))
+
+(defknown make-pathname
+ (&key (:defaults pathname-designator)
+ (:host (or string pathname-host))
+ (:device (or string pathname-device))
+ (:directory (or pathname-directory string (member :wild)))
+ (:name (or pathname-name string (member :wild)))
+ (:type (or pathname-type string (member :wild)))
+ (:version pathname-version) (:case (member :local :common)))
+ pathname (flushable))
+
+(defknown pathnamep (t) boolean (movable flushable))
+
+(defknown pathname-host (pathname-designator
+ &key (:case (member :local :common)))
+ pathname-host (flushable))
+(defknown pathname-device (pathname-designator
+ &key (:case (member :local :common)))
+ pathname-device (flushable))
+(defknown pathname-directory (pathname-designator
+ &key (:case (member :local :common)))
+ pathname-directory (flushable))
+(defknown pathname-name (pathname-designator
+ &key (:case (member :local :common)))
+ pathname-name (flushable))
+(defknown pathname-type (pathname-designator
+ &key (:case (member :local :common)))
+ pathname-type (flushable))
+(defknown pathname-version (pathname-designator)
+ pathname-version (flushable))
+
+(defknown (namestring file-namestring directory-namestring host-namestring)
+ (pathname-designator) simple-string
+ (flushable))
+
+(defknown enough-namestring (pathname-designator &optional pathname-designator)
+ simple-string
+ (flushable))
+
+(defknown user-homedir-pathname (&optional t) pathname (flushable))
+
+(defknown open
+ (pathname-designator &key
+ (:direction (member :input :output :io :probe))
+ (:element-type type-specifier)
+ (:if-exists (member :error :new-version :rename
+ :rename-and-delete :overwrite
+ :append :supersede nil))
+ (:if-does-not-exist (member :error :create nil))
+ (:external-format (member :default)))
+ (or stream null))
+
+(defknown rename-file (pathname-designator filename)
+ (values pathname pathname pathname))
+(defknown delete-file (pathname-designator) t)
+(defknown probe-file (pathname-designator) (or pathname null) (flushable))
+(defknown file-write-date (pathname-designator) (or unsigned-byte null)
+ (flushable))
+(defknown file-author (pathname-designator) (or simple-string null)
+ (flushable))
+
+(defknown file-position (stream &optional
+ (or unsigned-byte (member :start :end)))
+ (or unsigned-byte (member t nil)))
+(defknown file-length (stream) (or unsigned-byte null) (flushable))
+
+(defknown load
+ ((or filename stream)
+ &key
+ (:verbose t)
+ (:print t)
+ (:if-does-not-exist (member :error :create nil))
+ ;; FIXME: ANSI specifies an :EXTERNAL-FORMAT keyword too.
+ )
+ t)
+
+(defknown directory (pathname-designator &key
+ (:check-for-subdirs t)
+ (:all t)
+ (:follow-links t))
+ list (flushable))
+\f
+;;;; from the "Errors" chapter:
+
+(defknown error (t &rest t) nil) ; never returns...
+(defknown cerror (string t &rest t) null)
+(defknown warn (t &rest t) null)
+(defknown break (&optional t &rest t) null)
+\f
+;;;; from the "Miscellaneous" Chapter:
+
+(defknown compile ((or symbol cons) &optional (or list function null))
+ (values (or function symbol cons) boolean boolean))
+
+(defknown compile-file
+ (filename
+ &key
+ (:output-file (or filename
+ null
+ ;; FIXME: This last case is a non-ANSI hack.
+ (member t)))
+ (:verbose t)
+ (:print t)
+ (:external-format t)
+ (:block-compile t)
+ (:entry-points list)
+ (:byte-compile (member t nil :maybe)))
+ (values (or pathname null) boolean boolean))
+
+(defknown disassemble (callable &key
+ (:stream stream)
+ (:use-labels t))
+ null)
+
+(defknown fdocumentation (t symbol)
+ (or string null)
+ (flushable))
+
+(defknown describe (t &optional (or stream (member t nil))) (values))
+(defknown inspect (t) (values))
+
+(defknown room (&optional (member t nil :default)) (values))
+(defknown ed (&optional (or symbol cons filename) &key (:init t) (:display t))
+ t)
+(defknown dribble (&optional filename &key (:if-exists t)) t)
+
+(defknown apropos (stringable &optional package-designator t) (values))
+(defknown apropos-list (stringable &optional package-designator t) list
+ (flushable))
+
+(defknown get-decoded-time ()
+ (values (integer 0 59) (integer 0 59) (integer 0 23) (integer 1 31)
+ (integer 1 12) unsigned-byte (integer 0 6) boolean (rational -24 24))
+ (flushable))
+
+(defknown get-universal-time () unsigned-byte (flushable))
+
+(defknown decode-universal-time
+ (unsigned-byte &optional (or null (rational -24 24)))
+ (values (integer 0 59) (integer 0 59) (integer 0 23) (integer 1 31)
+ (integer 1 12) unsigned-byte (integer 0 6) boolean (rational -24 24))
+ (flushable))
+
+(defknown encode-universal-time
+ ((integer 0 59) (integer 0 59) (integer 0 23) (integer 1 31)
+ (integer 1 12) unsigned-byte &optional (or null (rational -24 24)))
+ unsigned-byte
+ (flushable))
+
+(defknown (get-internal-run-time get-internal-real-time)
+ () internal-time (flushable))
+
+(defknown sleep ((or (rational 0) (float 0.0))) null)
+
+;;; Even though ANSI defines LISP-IMPLEMENTATION-TYPE and
+;;; LISP-IMPLEMENTATION-VERSION to possibly punt and return NIL, we
+;;; know that there's no valid reason for our implementations to ever
+;;; do so, so we can safely guarantee that they'll return strings.
+(defknown (lisp-implementation-type lisp-implementation-version)
+ () simple-string (flushable))
+
+;;; For any of these functions, meaningful information might not be
+;;; available, so -- unlike the related LISP-IMPLEMENTATION-FOO
+;;; functions -- these really can return NIL.
+(defknown (machine-type machine-version machine-instance
+ software-type software-version
+ short-site-name long-site-name)
+ () (or simple-string null) (flushable))
+
+(defknown identity (t) t (movable foldable flushable unsafe)
+ :derive-type #'result-type-first-arg)
+
+;;; &OPTIONAL is to agree with the optimization in the interpreter stub.
+(defknown constantly (t &optional t t &rest t) function (movable flushable))
+(defknown complement (function) function (movable flushable))
+\f
+;;;; magical compiler frobs
+
+;;; We can't fold this in general because of SATISFIES. There is a
+;;; special optimizer anyway.
+(defknown %typep (t (or type-specifier ctype)) boolean
+ (movable flushable explicit-check))
+(defknown %instance-typep (t (or type-specifier ctype)) boolean
+ (movable flushable explicit-check))
+
+(defknown %cleanup-point () t)
+(defknown %special-bind (t t) t)
+(defknown %special-unbind (t) t)
+(defknown %listify-rest-args (t index) list (flushable))
+(defknown %more-arg-context (t t) (values t index) (flushable))
+(defknown %more-arg (t index) t)
+(defknown %more-arg-values (t index index) * (flushable))
+(defknown %verify-argument-count (index index) (values))
+(defknown %argument-count-error (t) nil)
+(defknown %unknown-values () *)
+(defknown %catch (t t) t)
+(defknown %unwind-protect (t t) t)
+(defknown (%catch-breakup %unwind-protect-breakup) () t)
+(defknown %lexical-exit-breakup (t) t)
+(defknown %continue-unwind (t t t) nil)
+(defknown %throw (t &rest t) nil) ; This is MV-called.
+(defknown %nlx-entry (t) *)
+(defknown %%primitive (t t &rest t) *)
+(defknown %pop-values (t) t)
+(defknown %type-check-error (t t) nil)
+(defknown %odd-keyword-arguments-error () nil)
+(defknown %unknown-keyword-argument-error (t) nil)
+(defknown (%ldb %mask-field) (bit-index bit-index integer) unsigned-byte
+ (movable foldable flushable explicit-check))
+(defknown (%dpb %deposit-field) (integer bit-index bit-index integer) integer
+ (movable foldable flushable explicit-check))
+(defknown %negate (number) number (movable foldable flushable explicit-check))
+(defknown %check-bound (array index fixnum) index (movable foldable flushable))
+(defknown data-vector-ref (simple-array index) t (foldable flushable explicit-check))
+(defknown data-vector-set (array index t) t (unsafe explicit-check))
+(defknown hairy-data-vector-ref (array index) t (foldable flushable explicit-check))
+(defknown hairy-data-vector-set (array index t) t (unsafe explicit-check))
+(defknown sb!kernel:%caller-frame-and-pc () (values t t) (flushable))
+(defknown sb!kernel:%with-array-data (array index (or index null))
+ (values (simple-array * (*)) index index index)
+ (foldable flushable))
+(defknown %set-symbol-package (symbol t) t (unsafe))
+(defknown %coerce-name-to-function (t) function (flushable))
+
+;;; Structure slot accessors or setters are magically "known" to be
+;;; these functions, although the var remains the Slot-Accessor
+;;; describing the actual function called.
+;;;
+;;; FIXME: It would be nice to make structure slot accessors be
+;;; ordinary functions (proclaimed as SB-EXT:CONSTANT-FUNCTION, but
+;;; otherwise ordinary).
+(defknown %slot-accessor (t) t (flushable))
+(defknown %slot-setter (t t) t (unsafe))
+\f
+;;;; SETF inverses
+
+(defknown %aset (array &rest t) t (unsafe))
+(defknown %set-row-major-aref (array index t) t (unsafe))
+(defknown %rplaca (cons t) t (unsafe))
+(defknown %rplacd (cons t) t (unsafe))
+(defknown %put (symbol t t) t (unsafe))
+(defknown %setelt (sequence index t) t (unsafe))
+(defknown %svset (simple-vector index t) t (unsafe))
+(defknown %bitset (bit-vector &rest index) bit (unsafe))
+(defknown %sbitset (simple-bit-vector &rest index) bit (unsafe))
+(defknown %charset (string index character) character (unsafe))
+(defknown %scharset (simple-string index character) character (unsafe))
+(defknown %set-symbol-value (symbol t) t (unsafe))
+(defknown fset (symbol function) function (unsafe))
+(defknown %set-symbol-plist (symbol t) t (unsafe))
+(defknown (setf fdocumentation) ((or string null) t symbol)
+ (or string null)
+ ())
+(defknown %setnth (index list t) t (unsafe))
+(defknown %set-fill-pointer (vector index) index (unsafe))
+\f
+;;;; internal type predicates
+
+;;; Simple TYPEP uses that don't have any standard predicate are
+;;; translated into non-standard unary predicates.
+(defknown (fixnump bignump ratiop short-float-p single-float-p double-float-p
+ long-float-p base-char-p %standard-char-p %instancep
+ array-header-p)
+ (t) boolean (movable foldable flushable))
+\f
+;;;; miscellaneous "sub-primitives"
+
+(defknown %sp-string-compare
+ (simple-string index index simple-string index index)
+ (or index null)
+ (foldable flushable))
--- /dev/null
+;;;; stuff that knows how to load compiled code directly into core
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!C")
+
+(file-comment
+ "$Header$")
+
+;;; A CORE-OBJECT structure holds the state needed to resolve cross-component
+;;; references during in-core compilation.
+(defstruct (core-object
+ (:constructor make-core-object ())
+ #-no-ansi-print-object
+ (:print-object (lambda (x s)
+ (print-unreadable-object (x s :type t)))))
+ ;; A hashtable translating ENTRY-INFO structures to the corresponding actual
+ ;; FUNCTIONs for functions in this compilation.
+ (entry-table (make-hash-table :test 'eq) :type hash-table)
+ ;; A hashtable translating ENTRY-INFO structures to a list of pairs
+ ;; (<code object> . <offset>) describing the places that need to be
+ ;; backpatched to point to the function for ENTRY-INFO.
+ (patch-table (make-hash-table :test 'eq) :type hash-table)
+ ;; A list of all the DEBUG-INFO objects created, kept so that we can
+ ;; backpatch with the source info.
+ (debug-info () :type list))
+
+;;; Note the existence of FUNCTION.
+(defun note-function (info function object)
+ (declare (type function function)
+ (type core-object object))
+ (let ((patch-table (core-object-patch-table object)))
+ (dolist (patch (gethash info patch-table))
+ (setf (code-header-ref (car patch) (the index (cdr patch))) function))
+ (remhash info patch-table))
+ (setf (gethash info (core-object-entry-table object)) function)
+ (values))
+
+;;; Do "load-time" fixups on the code vector.
+(defun do-core-fixups (code fixups)
+ (declare (list fixups))
+ (dolist (info fixups)
+ (let* ((kind (first info))
+ (fixup (second info))
+ (name (fixup-name fixup))
+ (flavor (fixup-flavor fixup))
+ (offset (third info))
+ (value (ecase flavor
+ (:assembly-routine
+ (assert (symbolp name))
+ (or (gethash name *assembler-routines*)
+ (error "undefined assembler routine: ~S" name)))
+ (:foreign
+ (assert (stringp name))
+ (or (sb!impl::foreign-symbol-address-as-integer name)
+ (error "unknown foreign symbol: ~S")))
+ #!+x86
+ (:code-object
+ (assert (null name))
+ (values (get-lisp-obj-address code) t)))))
+ (sb!vm:fixup-code-object code offset value kind))))
+
+;;; Stick a reference to the function Fun in Code-Object at index I. If the
+;;; function hasn't been compiled yet, make a note in the Patch-Table.
+(defun reference-core-function (code-obj i fun object)
+ (declare (type core-object object) (type functional fun)
+ (type index i))
+ (let* ((info (leaf-info fun))
+ (found (gethash info (core-object-entry-table object))))
+ (if found
+ (setf (code-header-ref code-obj i) found)
+ (push (cons code-obj i)
+ (gethash info (core-object-patch-table object)))))
+ (values))
+
+;;; Call the top-level lambda function dumped for Entry, returning the
+;;; values. Entry may be a :TOP-LEVEL-XEP functional.
+(defun core-call-top-level-lambda (entry object)
+ (declare (type functional entry) (type core-object object))
+ (funcall (or (gethash (leaf-info entry)
+ (core-object-entry-table object))
+ (error "Unresolved forward reference."))))
+
+;;; 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)
+ (declare (type source-info info) (type core-object object))
+ (assert (zerop (hash-table-count (core-object-patch-table object))))
+ (let ((res (debug-source-for-info info)))
+ (dolist (sinfo res)
+ (setf (debug-source-info sinfo) source-info))
+ (dolist (info (core-object-debug-info object))
+ (setf (compiled-debug-info-source info) res))
+ (setf (core-object-debug-info object) ()))
+ (values))
--- /dev/null
+;;;; type-based constants
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!VM")
+
+(file-comment
+ "$Header$")
+
+;;; FIXME: It's clever using :SUFFIX -TYPE for these things, but it's
+;;; a pain for people just learning to find their way around the code
+;;; who want to figure out where things like EVEN-FIXNUM type are
+;;; defined. Remove the :SUFFIXes and just expand out the full names.
+
+;;; the main types. These types are represented by the low three bits of the
+;;; pointer or immeditate object.
+(defenum (:suffix -type)
+ even-fixnum
+ function-pointer
+ other-immediate-0
+ list-pointer
+ odd-fixnum
+ instance-pointer
+ other-immediate-1
+ other-pointer)
+
+;;; the heap types. Each of these types is in the header of objects in
+;;; the heap.
+(defenum (:suffix -type
+ :start (+ (ash 1 lowtag-bits) other-immediate-0-type)
+ :step (ash 1 (1- lowtag-bits)))
+ bignum
+ ratio
+ single-float
+ double-float
+ #!+long-float long-float
+ complex
+ complex-single-float
+ complex-double-float
+ #!+long-float complex-long-float
+
+ simple-array
+ simple-string
+ simple-bit-vector
+ simple-vector
+ simple-array-unsigned-byte-2
+ simple-array-unsigned-byte-4
+ simple-array-unsigned-byte-8
+ simple-array-unsigned-byte-16
+ simple-array-unsigned-byte-32
+ simple-array-signed-byte-8
+ simple-array-signed-byte-16
+ simple-array-signed-byte-30
+ simple-array-signed-byte-32
+ simple-array-single-float
+ simple-array-double-float
+ #!+long-float simple-array-long-float
+ simple-array-complex-single-float
+ simple-array-complex-double-float
+ #!+long-float simple-array-complex-long-float
+ complex-string
+ complex-bit-vector
+ complex-vector
+ complex-array
+
+ code-header
+ function-header
+ closure-header
+ funcallable-instance-header
+ byte-code-function
+ byte-code-closure
+ closure-function-header
+ #!-gengc return-pc-header
+ #!+gengc forwarding-pointer
+ value-cell-header
+ symbol-header
+ base-char
+ sap
+ unbound-marker
+ weak-pointer
+ instance-header
+ fdefn
+ )
+
+;;; the different vector subtypes
+(defenum (:prefix vector- :suffix -subtype)
+ normal
+ unused
+ valid-hashing
+ must-rehash)
--- /dev/null
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!VM")
+
+(file-comment
+ "$Header$")
+
+(defmacro defenum ((&key (prefix "") (suffix "") (start 0) (step 1))
+ &rest identifiers)
+ (let ((results nil)
+ (index 0)
+ (start (eval start))
+ (step (eval step)))
+ (dolist (id identifiers)
+ (when id
+ (multiple-value-bind (root docs)
+ (if (consp id)
+ (values (car id) (cdr id))
+ (values id nil))
+ (push `(defconstant ,(intern (concatenate 'simple-string
+ (string prefix)
+ (string root)
+ (string suffix)))
+ ,(+ start (* step index))
+ ,@docs)
+ results)))
+ (incf index))
+ `(eval-when (:compile-toplevel :load-toplevel :execute)
+ ,@(nreverse results))))
--- /dev/null
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!VM")
+
+(file-comment
+ "$Header$")
+
+(eval-when (:compile-toplevel :execute :load-toplevel)
+
+(defconstant lowtag-bits 3
+ #!+sb-doc
+ "Number of bits at the low end of a pointer used for type information.")
+
+(defconstant lowtag-mask (1- (ash 1 lowtag-bits))
+ #!+sb-doc
+ "Mask to extract the low tag bits from a pointer.")
+
+(defconstant lowtag-limit (ash 1 lowtag-bits)
+ #!+sb-doc
+ "Exclusive upper bound on the value of the low tag bits from a pointer.")
+
+(defconstant type-bits 8
+ #!+sb-doc
+ "Number of bits used in the header word of a data block to store the type.")
+
+(defconstant type-mask (1- (ash 1 type-bits))
+ #!+sb-doc
+ "Mask to extract the type from a header word.")
+
+); eval-when
+
+;;; FIXME: Couldn't/shouldn't these be DEFCONSTANT instead of DEFPARAMETER?
+(defparameter *target-most-positive-fixnum* (1- (ash 1 29))
+ #!+sb-doc
+ "most-positive-fixnum in the target architecture.")
+(defparameter *target-most-negative-fixnum* (ash -1 29)
+ #!+sb-doc
+ "most-negative-fixnum in the target architecture.")
--- /dev/null
+;;;; "cold" core image builder: This is how we create a target Lisp
+;;;; system from scratch, by converting from fasl files to an image
+;;;; file in the cross-compilation host, without the help of the
+;;;; target Lisp system.
+;;;;
+;;;; As explained by Rob MacLachlan on the CMU CL mailing list Wed, 06
+;;;; Jan 1999 11:05:02 -0500, this cold load generator more or less
+;;;; fakes up static function linking. I.e. it makes sure that all the
+;;;; functions in the fasl files it reads are bound to the
+;;;; corresponding symbols before execution starts. It doesn't do
+;;;; anything to initialize variable values; instead it just arranges
+;;;; for !COLD-INIT to be called at cold load time. !COLD-INIT is
+;;;; responsible for explicitly initializing anything which has to be
+;;;; initialized early before it transfers control to the ordinary
+;;;; top-level forms.
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!IMPL")
+
+(file-comment
+ "$Header$")
+
+;;; a magic number used to identify core files
+(defconstant core-magic
+ (logior (ash (char-code #\S) 24)
+ (ash (char-code #\B) 16)
+ (ash (char-code #\C) 8)
+ (char-code #\L)))
+
+;;; the current version of SBCL core files
+;;;
+;;; FIXME: This is left over from CMU CL, and not well thought out.
+;;; It's good to make sure that the runtime doesn't try to run core
+;;; files from the wrong version, but a single number is not the ideal
+;;; way to do this in high level data like this (as opposed to e.g. in
+;;; IP packets), and in fact the CMU CL version number never ended up
+;;; being incremented past 0. A better approach might be to use a
+;;; string which is set from CVS data.
+(defconstant sbcl-core-version-integer 0)
+
+(defun round-up (number size)
+ #!+sb-doc
+ "Round NUMBER up to be an integral multiple of SIZE."
+ (* size (ceiling number size)))
+\f
+;;;; representation of spaces in the core
+
+(defvar *dynamic*)
+(defconstant dynamic-space-id 1)
+
+(defvar *static*)
+(defconstant static-space-id 2)
+
+(defvar *read-only*)
+(defconstant read-only-space-id 3)
+
+(eval-when (:compile-toplevel :execute :load-toplevel)
+ (defconstant descriptor-low-bits 16
+ "the number of bits in the low half of the descriptor")
+ (defconstant target-space-alignment (ash 1 descriptor-low-bits)
+ "the alignment requirement for spaces in the target.
+ Must be at least (ASH 1 DESCRIPTOR-LOW-BITS)"))
+
+;;; a GENESIS-time representation of a memory space (e.g. read-only space,
+;;; dynamic space, or static space)
+(defstruct (gspace (:constructor %make-gspace))
+ ;; name and identifier for this GSPACE
+ (name (required-argument) :type symbol :read-only t)
+ (identifier (required-argument) :type fixnum :read-only t)
+ ;; the word address where the data will be loaded
+ (word-address (required-argument) :type unsigned-byte :read-only t)
+ ;; the data themselves. (Note that in CMU CL this was a pair
+ ;; of fields SAP and WORDS-ALLOCATED, but that wasn't very portable.)
+ (bytes (make-array target-space-alignment :element-type '(unsigned-byte 8))
+ :type (simple-array (unsigned-byte 8) 1))
+ ;; the index of the next unwritten word (i.e. chunk of
+ ;; SB!VM:WORD-BYTES bytes) in BYTES, or equivalently the number of
+ ;; words actually written in BYTES. In order to convert to an actual
+ ;; index into BYTES, thus must be multiplied by SB!VM:WORD-BYTES.
+ (free-word-index 0))
+
+(defun gspace-byte-address (gspace)
+ (ash (gspace-word-address gspace) sb!vm:word-shift))
+
+(def!method print-object ((gspace gspace) stream)
+ (print-unreadable-object (gspace stream :type t)
+ (format stream "~S" (gspace-name gspace))))
+
+(defun make-gspace (name identifier byte-address)
+ (unless (zerop (rem byte-address target-space-alignment))
+ (error "The byte address #X~X is not aligned on a #X~X-byte boundary."
+ byte-address
+ target-space-alignment))
+ (%make-gspace :name name
+ :identifier identifier
+ :word-address (ash byte-address (- sb!vm:word-shift))))
+
+;;; KLUDGE: Doing it this way seems to partly replicate the
+;;; functionality of Common Lisp adjustable arrays. Is there any way
+;;; to do this stuff in one line of code by using standard Common Lisp
+;;; stuff? -- WHN 19990816
+(defun expand-gspace-bytes (gspace)
+ (let* ((old-bytes (gspace-bytes gspace))
+ (old-length (length old-bytes))
+ (new-length (* 2 old-length))
+ (new-bytes (make-array new-length :element-type '(unsigned-byte 8))))
+ (replace new-bytes old-bytes :end1 old-length)
+ (setf (gspace-bytes gspace)
+ new-bytes))
+ (values))
+\f
+;;;; representation of descriptors
+
+(defstruct (descriptor
+ (:constructor make-descriptor
+ (high low &optional gspace word-offset)))
+ ;; the GSPACE that this descriptor is allocated in, or NIL if not set yet.
+ (gspace nil :type (or gspace null))
+ ;; the offset in words from the start of GSPACE, or NIL if not set yet
+ (word-offset nil :type (or (unsigned-byte #.sb!vm:word-bits) null))
+ ;; the high and low halves of the descriptor KLUDGE: Judging from
+ ;; the comments in genesis.lisp of the CMU CL old-rt compiler, this
+ ;; split dates back from a very early version of genesis where
+ ;; 32-bit integers were represented as conses of two 16-bit
+ ;; integers. In any system with nice (UNSIGNED-BYTE 32) structure
+ ;; slots, like CMU CL >= 17 or any version of SBCL, there seems to
+ ;; be no reason to persist in this. -- WHN 19990917
+ high low)
+(def!method print-object ((des descriptor) stream)
+ (let ((lowtag (descriptor-lowtag des)))
+ (print-unreadable-object (des stream :type t)
+ (cond ((or (= lowtag sb!vm:even-fixnum-type)
+ (= lowtag sb!vm:odd-fixnum-type))
+ (let ((unsigned (logior (ash (descriptor-high des)
+ (1+ (- descriptor-low-bits
+ sb!vm:lowtag-bits)))
+ (ash (descriptor-low des)
+ (- 1 sb!vm:lowtag-bits)))))
+ (format stream
+ "for fixnum: ~D"
+ (if (> unsigned #x1FFFFFFF)
+ (- unsigned #x40000000)
+ unsigned))))
+ ((or (= lowtag sb!vm:other-immediate-0-type)
+ (= lowtag sb!vm:other-immediate-1-type))
+ (format stream
+ "for other immediate: #X~X, type #b~8,'0B"
+ (ash (descriptor-bits des) (- sb!vm:type-bits))
+ (logand (descriptor-low des) sb!vm:type-mask)))
+ (t
+ (format stream
+ "for pointer: #X~X, lowtag #b~3,'0B, ~A"
+ (logior (ash (descriptor-high des) descriptor-low-bits)
+ (logandc2 (descriptor-low des) sb!vm:lowtag-mask))
+ lowtag
+ (let ((gspace (descriptor-gspace des)))
+ (if gspace
+ (gspace-name gspace)
+ "unknown"))))))))
+
+(defun allocate-descriptor (gspace length lowtag)
+ #!+sb-doc
+ "Return a descriptor for a block of LENGTH bytes out of GSPACE. The free
+ word index is boosted as necessary, and if additional memory is needed, we
+ grow the GSPACE. The descriptor returned is a pointer of type LOWTAG."
+ (let* ((bytes (round-up length (ash 1 sb!vm:lowtag-bits)))
+ (old-free-word-index (gspace-free-word-index gspace))
+ (new-free-word-index (+ old-free-word-index
+ (ash bytes (- sb!vm:word-shift)))))
+ ;; Grow GSPACE as necessary until it's big enough to handle
+ ;; NEW-FREE-WORD-INDEX.
+ (do ()
+ ((>= (length (gspace-bytes gspace))
+ (* new-free-word-index sb!vm:word-bytes)))
+ (expand-gspace-bytes gspace))
+ ;; Now that GSPACE is big enough, we can meaningfully grab a chunk of it.
+ (setf (gspace-free-word-index gspace) new-free-word-index)
+ (let ((ptr (+ (gspace-word-address gspace) old-free-word-index)))
+ (make-descriptor (ash ptr (- sb!vm:word-shift descriptor-low-bits))
+ (logior (ash (logand ptr
+ (1- (ash 1
+ (- descriptor-low-bits
+ sb!vm:word-shift))))
+ sb!vm:word-shift)
+ lowtag)
+ gspace
+ old-free-word-index))))
+
+(defun descriptor-lowtag (des)
+ #!+sb-doc
+ "the lowtag bits for DES"
+ (logand (descriptor-low des) sb!vm:lowtag-mask))
+
+(defun descriptor-bits (des)
+ (logior (ash (descriptor-high des) descriptor-low-bits)
+ (descriptor-low des)))
+
+(defun descriptor-fixnum (des)
+ (let ((bits (descriptor-bits des)))
+ (if (logbitp (1- sb!vm:word-bits) bits)
+ ;; KLUDGE: The (- SB!VM:WORD-BITS 2) term here looks right to
+ ;; me, and it works, but in CMU CL it was (1- SB!VM:WORD-BITS),
+ ;; and although that doesn't make sense for me, or work for me,
+ ;; it's hard to see how it could have been wrong, since CMU CL
+ ;; genesis worked. It would be nice to understand how this came
+ ;; to be.. -- WHN 19990901
+ (logior (ash bits -2) (ash -1 (- sb!vm:word-bits 2)))
+ (ash bits -2))))
+
+;;; common idioms
+(defun descriptor-bytes (des)
+ (gspace-bytes (descriptor-intuit-gspace des)))
+(defun descriptor-byte-offset (des)
+ (ash (descriptor-word-offset des) sb!vm:word-shift))
+
+;;; If DESCRIPTOR-GSPACE is already set, just return that. Otherwise,
+;;; figure out a GSPACE which corresponds to DES, set it into
+;;; (DESCRIPTOR-GSPACE DES), set a consistent value into
+;;; (DESCRIPTOR-WORD-OFFSET DES), and return the GSPACE.
+(declaim (ftype (function (descriptor) gspace) descriptor-intuit-gspace))
+(defun descriptor-intuit-gspace (des)
+ (if (descriptor-gspace des)
+ (descriptor-gspace des)
+ ;; KLUDGE: It's not completely clear to me what's going on here;
+ ;; this is a literal translation from of some rather mysterious
+ ;; code from CMU CL's DESCRIPTOR-SAP function. Some explanation
+ ;; would be nice. -- WHN 19990817
+ (let ((lowtag (descriptor-lowtag des))
+ (high (descriptor-high des))
+ (low (descriptor-low des)))
+ (if (or (eql lowtag sb!vm:function-pointer-type)
+ (eql lowtag sb!vm:instance-pointer-type)
+ (eql lowtag sb!vm:list-pointer-type)
+ (eql lowtag sb!vm:other-pointer-type))
+ (dolist (gspace (list *dynamic* *static* *read-only*)
+ (error "couldn't find a GSPACE for ~S" des))
+ ;; This code relies on the fact that GSPACEs are aligned such that
+ ;; the descriptor-low-bits low bits are zero.
+ (when (and (>= high (ash (gspace-word-address gspace)
+ (- sb!vm:word-shift descriptor-low-bits)))
+ (<= high (ash (+ (gspace-word-address gspace)
+ (gspace-free-word-index gspace))
+ (- sb!vm:word-shift descriptor-low-bits))))
+ (setf (descriptor-gspace des) gspace)
+ (setf (descriptor-word-offset des)
+ (+ (ash (- high (ash (gspace-word-address gspace)
+ (- sb!vm:word-shift
+ descriptor-low-bits)))
+ (- descriptor-low-bits sb!vm:word-shift))
+ (ash (logandc2 low sb!vm:lowtag-mask)
+ (- sb!vm:word-shift))))
+ (return gspace)))
+ (error "don't even know how to look for a GSPACE for ~S" des)))))
+
+(defun make-random-descriptor (value)
+ (make-descriptor (logand (ash value (- descriptor-low-bits))
+ (1- (ash 1
+ (- sb!vm:word-bits descriptor-low-bits))))
+ (logand value (1- (ash 1 descriptor-low-bits)))))
+
+(defun make-fixnum-descriptor (num)
+ (when (>= (integer-length num)
+ (1+ (- sb!vm:word-bits sb!vm:lowtag-bits)))
+ (error "~D is too big for a fixnum." num))
+ (make-random-descriptor (ash num (1- sb!vm:lowtag-bits))))
+
+(defun make-other-immediate-descriptor (data type)
+ (make-descriptor (ash data (- sb!vm:type-bits descriptor-low-bits))
+ (logior (logand (ash data (- descriptor-low-bits
+ sb!vm:type-bits))
+ (1- (ash 1 descriptor-low-bits)))
+ type)))
+
+(defun make-character-descriptor (data)
+ (make-other-immediate-descriptor data sb!vm:base-char-type))
+
+(defun descriptor-beyond (des offset type)
+ (let* ((low (logior (+ (logandc2 (descriptor-low des) sb!vm:lowtag-mask)
+ offset)
+ type))
+ (high (+ (descriptor-high des)
+ (ash low (- descriptor-low-bits)))))
+ (make-descriptor high (logand low (1- (ash 1 descriptor-low-bits))))))
+\f
+;;;; miscellaneous variables and other noise
+
+;;; a numeric value to be returned for undefined foreign symbols, or NIL if
+;;; undefined foreign symbols are to be treated as an error.
+;;; (In the first pass of GENESIS, needed to create a header file before
+;;; the C runtime can be built, various foreign symbols will necessarily
+;;; be undefined, but we don't need actual values for them anyway, and
+;;; we can just use 0 or some other placeholder. In the second pass of
+;;; GENESIS, all foreign symbols should be defined, so any undefined
+;;; foreign symbol is a problem.)
+;;;
+;;; KLUDGE: It would probably be cleaner to rewrite GENESIS so that it
+;;; never tries to look up foreign symbols in the first place unless
+;;; it's actually creating a core file (as in the second pass) instead
+;;; of using this hack to allow it to go through the motions without
+;;; causing an error. -- WHN 20000825
+(defvar *foreign-symbol-placeholder-value*)
+
+;;; a handle on the trap object
+(defvar *unbound-marker*)
+;; was: (make-other-immediate-descriptor 0 sb!vm:unbound-marker-type)
+
+;;; a handle on the NIL object
+(defvar *nil-descriptor*)
+
+;;; the head of a list of TOPLEVEL-THINGs describing stuff to be done
+;;; when the target Lisp starts up
+;;;
+;;; Each TOPLEVEL-THING can be a function to be executed or a fixup or
+;;; loadtime value, represented by (CONS KEYWORD ..). The FILENAME
+;;; tells which fasl file each list element came from, for debugging
+;;; purposes.
+(defvar *current-reversed-cold-toplevels*)
+
+;;; the name of the object file currently being cold loaded (as a string, not a
+;;; pathname), or NIL if we're not currently cold loading any object file
+(defvar *cold-load-filename* nil)
+(declaim (type (or string null) *cold-load-filename*))
+
+;;; This is vestigial support for the CMU CL byte-swapping code. CMU
+;;; CL code tested for whether it needed to swap bytes in GENESIS by
+;;; comparing the byte order of *BACKEND* to the byte order of
+;;; *NATIVE-BACKEND*, a concept which doesn't exist in SBCL. Instead,
+;;; in SBCL byte order swapping would need to be explicitly requested
+;;; with a keyword argument to GENESIS.
+;;;
+;;; I'm not sure whether this is a problem or not, and I don't have a
+;;; machine with different byte order to test to find out for sure.
+;;; The version of the system which is fed to the cross-compiler is
+;;; now written in a subset of Common Lisp which doesn't require
+;;; dumping a lot of things in such a way that machine byte order
+;;; matters. (Mostly this is a matter of not using any specialized
+;;; array type unless there's portable, high-level code to dump it.)
+;;; If it *is* a problem, and you're trying to resurrect this code,
+;;; please test particularly carefully, since I haven't had a chance
+;;; to test the byte-swapping code at all. -- WHN 19990816
+;;;
+;;; When this variable is non-NIL, byte-swapping is enabled wherever
+;;; classic GENESIS would have done it. I.e. the value of this variable
+;;; is the logical complement of
+;;; (EQ (SB!C:BACKEND-BYTE-ORDER SB!C:*NATIVE-BACKEND*)
+;;; (SB!C:BACKEND-BYTE-ORDER SB!C:*BACKEND*))
+;;; from CMU CL.
+(defvar *genesis-byte-order-swap-p*)
+\f
+;;;; miscellaneous stuff to read and write the core memory
+
+;;; FIXME: should be DEFINE-MODIFY-MACRO
+(defmacro cold-push (thing list)
+ #!+sb-doc
+ "Push THING onto the given cold-load LIST."
+ `(setq ,list (cold-cons ,thing ,list)))
+
+(defun maybe-byte-swap (word)
+ (declare (type (unsigned-byte 32) word))
+ (assert (= sb!vm:word-bits 32))
+ (assert (= sb!vm:byte-bits 8))
+ (if (not *genesis-byte-order-swap-p*)
+ word
+ (logior (ash (ldb (byte 8 0) word) 24)
+ (ash (ldb (byte 8 8) word) 16)
+ (ash (ldb (byte 8 16) word) 8)
+ (ldb (byte 8 24) word))))
+
+(defun maybe-byte-swap-short (short)
+ (declare (type (unsigned-byte 16) short))
+ (assert (= sb!vm:word-bits 32))
+ (assert (= sb!vm:byte-bits 8))
+ (if (not *genesis-byte-order-swap-p*)
+ short
+ (logior (ash (ldb (byte 8 0) short) 8)
+ (ldb (byte 8 8) short))))
+
+;;; like SAP-REF-32, except that instead of a SAP we use a byte vector
+(defun byte-vector-ref-32 (byte-vector byte-index)
+ (assert (= sb!vm:word-bits 32))
+ (assert (= sb!vm:byte-bits 8))
+ (ecase sb!c:*backend-byte-order*
+ (:little-endian
+ (logior (ash (aref byte-vector (+ byte-index 0)) 0)
+ (ash (aref byte-vector (+ byte-index 1)) 8)
+ (ash (aref byte-vector (+ byte-index 2)) 16)
+ (ash (aref byte-vector (+ byte-index 3)) 24)))
+ (:big-endian
+ (error "stub: no big-endian ports of SBCL (yet?)"))))
+(defun (setf byte-vector-ref-32) (new-value byte-vector byte-index)
+ (assert (= sb!vm:word-bits 32))
+ (assert (= sb!vm:byte-bits 8))
+ (ecase sb!c:*backend-byte-order*
+ (:little-endian
+ (setf (aref byte-vector (+ byte-index 0)) (ldb (byte 8 0) new-value)
+ (aref byte-vector (+ byte-index 1)) (ldb (byte 8 8) new-value)
+ (aref byte-vector (+ byte-index 2)) (ldb (byte 8 16) new-value)
+ (aref byte-vector (+ byte-index 3)) (ldb (byte 8 24) new-value)))
+ (:big-endian
+ (error "stub: no big-endian ports of SBCL (yet?)")))
+ new-value)
+
+(declaim (ftype (function (descriptor sb!vm:word) descriptor) read-wordindexed))
+(defun read-wordindexed (address index)
+ #!+sb-doc
+ "Return the value which is displaced by INDEX words from ADDRESS."
+ (let* ((gspace (descriptor-intuit-gspace address))
+ (bytes (gspace-bytes gspace))
+ (byte-index (ash (+ index (descriptor-word-offset address))
+ sb!vm:word-shift))
+ ;; KLUDGE: Do we really need to do byte swap here? It seems
+ ;; as though we shouldn't.. (This attempts to be a literal
+ ;; translation of CMU CL code, and I don't have a big-endian
+ ;; machine to test it.) -- WHN 19990817
+ (value (maybe-byte-swap (byte-vector-ref-32 bytes byte-index))))
+ (make-random-descriptor value)))
+
+(declaim (ftype (function (descriptor) descriptor) read-memory))
+(defun read-memory (address)
+ #!+sb-doc
+ "Return the value at ADDRESS."
+ (read-wordindexed address 0))
+
+;;; (Note: In CMU CL, this function expected a SAP-typed ADDRESS
+;;; value, instead of the SAPINT we use here.)
+(declaim (ftype (function (sb!vm:word descriptor) (values)) note-load-time-value-reference))
+(defun note-load-time-value-reference (address marker)
+ (cold-push (cold-cons
+ (cold-intern :load-time-value-fixup)
+ (cold-cons (sapint-to-core address)
+ (cold-cons
+ (number-to-core (descriptor-word-offset marker))
+ *nil-descriptor*)))
+ *current-reversed-cold-toplevels*)
+ (values))
+
+(declaim (ftype (function (descriptor sb!vm:word descriptor)) write-wordindexed))
+(defun write-wordindexed (address index value)
+ #!+sb-doc
+ "Write VALUE displaced INDEX words from ADDRESS."
+ ;; KLUDGE: There is an algorithm (used in DESCRIPTOR-INTUIT-GSPACE)
+ ;; for calculating the value of the GSPACE slot from scratch. It
+ ;; doesn't work for all values, only some of them, but mightn't it
+ ;; be reasonable to see whether it works on VALUE before we give up
+ ;; because (DESCRIPTOR-GSPACE VALUE) isn't set? (Or failing that,
+ ;; perhaps write a comment somewhere explaining why it's not a good
+ ;; idea?) -- WHN 19990817
+ (if (and (null (descriptor-gspace value))
+ (not (null (descriptor-word-offset value))))
+ (note-load-time-value-reference (+ (logandc2 (descriptor-bits address)
+ sb!vm:lowtag-mask)
+ (ash index sb!vm:word-shift))
+ value)
+ ;; Note: There's a MAYBE-BYTE-SWAP in here in CMU CL, which I
+ ;; think is unnecessary now that we're doing the write
+ ;; byte-by-byte at high level. (I can't test this, though..) --
+ ;; WHN 19990817
+ (let* ((bytes (gspace-bytes (descriptor-intuit-gspace address)))
+ (byte-index (ash (+ index (descriptor-word-offset address))
+ sb!vm:word-shift)))
+ (setf (byte-vector-ref-32 bytes byte-index)
+ (maybe-byte-swap (descriptor-bits value))))))
+
+(declaim (ftype (function (descriptor descriptor)) write-memory))
+(defun write-memory (address value)
+ #!+sb-doc
+ "Write VALUE (a DESCRIPTOR) at ADDRESS (also a DESCRIPTOR)."
+ (write-wordindexed address 0 value))
+\f
+;;;; allocating images of primitive objects in the cold core
+
+;;; There are three kinds of blocks of memory in the type system:
+;;; * Boxed objects (cons cells, structures, etc): These objects have no
+;;; header as all slots are descriptors.
+;;; * Unboxed objects (bignums): There is a single header word that contains
+;;; the length.
+;;; * Vector objects: There is a header word with the type, then a word for
+;;; the length, then the data.
+(defun allocate-boxed-object (gspace length lowtag)
+ #!+sb-doc
+ "Allocate LENGTH words in GSPACE and return a new descriptor of type LOWTAG
+ pointing to them."
+ (allocate-descriptor gspace (ash length sb!vm:word-shift) lowtag))
+(defun allocate-unboxed-object (gspace element-bits length type)
+ #!+sb-doc
+ "Allocate LENGTH units of ELEMENT-BITS bits plus a header word in GSPACE and
+ return an ``other-pointer'' descriptor to them. Initialize the header word
+ with the resultant length and TYPE."
+ (let* ((bytes (/ (* element-bits length) sb!vm:byte-bits))
+ (des (allocate-descriptor gspace
+ (+ bytes sb!vm:word-bytes)
+ sb!vm:other-pointer-type)))
+ (write-memory des
+ (make-other-immediate-descriptor (ash bytes
+ (- sb!vm:word-shift))
+ type))
+ des))
+(defun allocate-vector-object (gspace element-bits length type)
+ #!+sb-doc
+ "Allocate LENGTH units of ELEMENT-BITS size plus a header plus a length slot in
+ GSPACE and return an ``other-pointer'' descriptor to them. Initialize the
+ header word with TYPE and the length slot with LENGTH."
+ ;; FIXME: Here and in ALLOCATE-UNBOXED-OBJECT, BYTES is calculated using
+ ;; #'/ instead of #'CEILING, which seems wrong.
+ (let* ((bytes (/ (* element-bits length) sb!vm:byte-bits))
+ (des (allocate-descriptor gspace (+ bytes (* 2 sb!vm:word-bytes))
+ sb!vm:other-pointer-type)))
+ (write-memory des (make-other-immediate-descriptor 0 type))
+ (write-wordindexed des
+ sb!vm:vector-length-slot
+ (make-fixnum-descriptor length))
+ des))
+\f
+;;;; copying simple objects into the cold core
+
+(defun string-to-core (string &optional (gspace *dynamic*))
+ #!+sb-doc
+ "Copy string into the cold core and return a descriptor to it."
+ ;; (Remember that the system convention for storage of strings leaves an
+ ;; extra null byte at the end to aid in call-out to C.)
+ (let* ((length (length string))
+ (des (allocate-vector-object gspace
+ sb!vm:byte-bits
+ (1+ length)
+ sb!vm:simple-string-type))
+ (bytes (gspace-bytes gspace))
+ (offset (+ (* sb!vm:vector-data-offset sb!vm:word-bytes)
+ (descriptor-byte-offset des))))
+ (write-wordindexed des
+ sb!vm:vector-length-slot
+ (make-fixnum-descriptor length))
+ (dotimes (i length)
+ (setf (aref bytes (+ offset i))
+ ;; KLUDGE: There's no guarantee that the character
+ ;; encoding here will be the same as the character
+ ;; encoding on the target machine, so using CHAR-CODE as
+ ;; we do, or a bitwise copy as CMU CL code did, is sleazy.
+ ;; (To make this more portable, perhaps we could use
+ ;; indices into the sequence which is used to test whether
+ ;; a character is a STANDARD-CHAR?) -- WHN 19990817
+ (char-code (aref string i))))
+ (setf (aref bytes (+ offset length))
+ 0) ; null string-termination character for C
+ des))
+
+(defun bignum-to-core (n)
+ #!+sb-doc
+ "Copy a bignum to the cold core."
+ (let* ((words (ceiling (1+ (integer-length n)) sb!vm:word-bits))
+ (handle (allocate-unboxed-object *dynamic*
+ sb!vm:word-bits
+ words
+ sb!vm:bignum-type)))
+ (declare (fixnum words))
+ (do ((index 1 (1+ index))
+ (remainder n (ash remainder (- sb!vm:word-bits))))
+ ((> index words)
+ (unless (zerop (integer-length remainder))
+ ;; FIXME: Shouldn't this be a fatal error?
+ (warn "~D words of ~D were written, but ~D bits were left over."
+ words n remainder)))
+ (let ((word (ldb (byte sb!vm:word-bits 0) remainder)))
+ (write-wordindexed handle index
+ (make-descriptor (ash word (- descriptor-low-bits))
+ (ldb (byte descriptor-low-bits 0)
+ word)))))
+ handle))
+
+(defun number-pair-to-core (first second type)
+ #!+sb-doc
+ "Makes a number pair of TYPE (ratio or complex) and fills it in."
+ (let ((des (allocate-unboxed-object *dynamic* sb!vm:word-bits 2 type)))
+ (write-wordindexed des 1 first)
+ (write-wordindexed des 2 second)
+ des))
+
+(defun float-to-core (x)
+ (etypecase x
+ (single-float
+ (let ((des (allocate-unboxed-object *dynamic*
+ sb!vm:word-bits
+ (1- sb!vm:single-float-size)
+ sb!vm:single-float-type)))
+ (write-wordindexed des
+ sb!vm:single-float-value-slot
+ (make-random-descriptor (single-float-bits x)))
+ des))
+ (double-float
+ (let ((des (allocate-unboxed-object *dynamic*
+ sb!vm:word-bits
+ (1- sb!vm:double-float-size)
+ sb!vm:double-float-type))
+ (high-bits (make-random-descriptor (double-float-high-bits x)))
+ (low-bits (make-random-descriptor (double-float-low-bits x))))
+ (ecase sb!c:*backend-byte-order*
+ (:little-endian
+ (write-wordindexed des sb!vm:double-float-value-slot low-bits)
+ (write-wordindexed des (1+ sb!vm:double-float-value-slot) high-bits))
+ (:big-endian
+ (write-wordindexed des sb!vm:double-float-value-slot high-bits)
+ (write-wordindexed des (1+ sb!vm:double-float-value-slot) low-bits)))
+ des))
+ #!+(and long-float x86)
+ (long-float
+ (let ((des (allocate-unboxed-object *dynamic*
+ sb!vm:word-bits
+ (1- sb!vm:long-float-size)
+ sb!vm:long-float-type))
+ (exp-bits (make-random-descriptor (long-float-exp-bits x)))
+ (high-bits (make-random-descriptor (long-float-high-bits x)))
+ (low-bits (make-random-descriptor (long-float-low-bits x))))
+ (ecase sb!c:*backend-byte-order*
+ (:little-endian
+ (write-wordindexed des sb!vm:long-float-value-slot low-bits)
+ (write-wordindexed des (1+ sb!vm:long-float-value-slot) high-bits)
+ (write-wordindexed des (+ 2 sb!vm:long-float-value-slot) exp-bits))
+ (:big-endian
+ (error "LONG-FLOAT is not supported for big-endian byte order.")))
+ des))))
+
+(defun complex-single-float-to-core (num)
+ (declare (type (complex single-float) num))
+ (let ((des (allocate-unboxed-object *dynamic* sb!vm:word-bits
+ (1- sb!vm:complex-single-float-size)
+ sb!vm:complex-single-float-type)))
+ (write-wordindexed des sb!vm:complex-single-float-real-slot
+ (make-random-descriptor (single-float-bits (realpart num))))
+ (write-wordindexed des sb!vm:complex-single-float-imag-slot
+ (make-random-descriptor (single-float-bits (imagpart num))))
+ des))
+
+(defun complex-double-float-to-core (num)
+ (declare (type (complex double-float) num))
+ (let ((des (allocate-unboxed-object *dynamic* sb!vm:word-bits
+ (1- sb!vm:complex-double-float-size)
+ sb!vm:complex-double-float-type)))
+ (let* ((real (realpart num))
+ (high-bits (make-random-descriptor (double-float-high-bits real)))
+ (low-bits (make-random-descriptor (double-float-low-bits real))))
+ (ecase sb!c:*backend-byte-order*
+ (:little-endian
+ (write-wordindexed des sb!vm:complex-double-float-real-slot low-bits)
+ (write-wordindexed des (1+ sb!vm:complex-double-float-real-slot) high-bits))
+ (:big-endian
+ (write-wordindexed des sb!vm:complex-double-float-real-slot high-bits)
+ (write-wordindexed des (1+ sb!vm:complex-double-float-real-slot) low-bits))))
+ (let* ((imag (imagpart num))
+ (high-bits (make-random-descriptor (double-float-high-bits imag)))
+ (low-bits (make-random-descriptor (double-float-low-bits imag))))
+ (ecase sb!c:*backend-byte-order*
+ (:little-endian
+ (write-wordindexed des sb!vm:complex-double-float-imag-slot low-bits)
+ (write-wordindexed des (1+ sb!vm:complex-double-float-imag-slot) high-bits))
+ (:big-endian
+ (write-wordindexed des sb!vm:complex-double-float-imag-slot high-bits)
+ (write-wordindexed des (1+ sb!vm:complex-double-float-imag-slot) low-bits))))
+ des))
+
+(defun number-to-core (number)
+ #!+sb-doc
+ "Copy the given number to the core, or flame out if we can't deal with it."
+ (typecase number
+ (integer (if (< (integer-length number) 30)
+ (make-fixnum-descriptor number)
+ (bignum-to-core number)))
+ (ratio (number-pair-to-core (number-to-core (numerator number))
+ (number-to-core (denominator number))
+ sb!vm:ratio-type))
+ ((complex single-float) (complex-single-float-to-core number))
+ ((complex double-float) (complex-double-float-to-core number))
+ #!+long-float
+ ((complex long-float)
+ (error "~S isn't a cold-loadable number at all!" number))
+ (complex (number-pair-to-core (number-to-core (realpart number))
+ (number-to-core (imagpart number))
+ sb!vm:complex-type))
+ (float (float-to-core number))
+ (t (error "~S isn't a cold-loadable number at all!" number))))
+
+(declaim (ftype (function (sb!vm:word) descriptor) sap-to-core))
+(defun sapint-to-core (sapint)
+ (let ((des (allocate-unboxed-object *dynamic*
+ sb!vm:word-bits
+ (1- sb!vm:sap-size)
+ sb!vm:sap-type)))
+ (write-wordindexed des
+ sb!vm:sap-pointer-slot
+ (make-random-descriptor sapint))
+ des))
+
+;;; Allocate a cons cell in GSPACE and fill it in with CAR and CDR.
+(defun cold-cons (car cdr &optional (gspace *dynamic*))
+ (let ((dest (allocate-boxed-object gspace 2 sb!vm:list-pointer-type)))
+ (write-memory dest car)
+ (write-wordindexed dest 1 cdr)
+ dest))
+
+;;; Make a simple-vector that holds the specified OBJECTS, and return its
+;;; descriptor.
+(defun vector-in-core (&rest objects)
+ (let* ((size (length objects))
+ (result (allocate-vector-object *dynamic* sb!vm:word-bits size
+ sb!vm:simple-vector-type)))
+ (dotimes (index size)
+ (write-wordindexed result (+ index sb!vm:vector-data-offset)
+ (pop objects)))
+ result))
+\f
+;;;; symbol magic
+
+;;; FIXME: This should be a keyword argument of ALLOCATE-SYMBOL.
+(defvar *cold-symbol-allocation-gspace* nil)
+
+;;; Allocate (and initialize) a symbol.
+(defun allocate-symbol (name)
+ (declare (simple-string name))
+ (let ((symbol (allocate-unboxed-object (or *cold-symbol-allocation-gspace*
+ *dynamic*)
+ sb!vm:word-bits
+ (1- sb!vm:symbol-size)
+ sb!vm:symbol-header-type)))
+ (write-wordindexed symbol sb!vm:symbol-value-slot *unbound-marker*)
+ #!+x86
+ (write-wordindexed symbol
+ sb!vm:symbol-hash-slot
+ (make-fixnum-descriptor
+ (1+ (random sb!vm:*target-most-positive-fixnum*))))
+ (write-wordindexed symbol sb!vm:symbol-plist-slot *nil-descriptor*)
+ (write-wordindexed symbol sb!vm:symbol-name-slot
+ (string-to-core name *dynamic*))
+ (write-wordindexed symbol sb!vm:symbol-package-slot *nil-descriptor*)
+ symbol))
+
+;;; Set the cold symbol value of SYMBOL-OR-SYMBOL-DES, which can be either a
+;;; descriptor of a cold symbol or (in an abbreviation for the
+;;; most common usage pattern) an ordinary symbol, which will be
+;;; automatically cold-interned.
+(declaim (ftype (function ((or descriptor symbol) descriptor)) cold-set))
+(defun cold-set (symbol-or-symbol-des value)
+ (let ((symbol-des (etypecase symbol-or-symbol-des
+ (descriptor symbol-or-symbol-des)
+ (symbol (cold-intern symbol-or-symbol-des)))))
+ (write-wordindexed symbol-des sb!vm:symbol-value-slot value)))
+\f
+;;;; layouts and type system pre-initialization
+
+;;; Since we want to be able to dump structure constants and
+;;; predicates with reference layouts, we need to create layouts at
+;;; cold-load time. We use the name to intern layouts by, and dump a
+;;; list of all cold layouts in *!INITIAL-LAYOUTS* so that type system
+;;; initialization can find them. The only thing that's tricky [sic --
+;;; WHN 19990816] is initializing layout's layout, which must point to
+;;; itself.
+
+;;; a map from class names to lists of
+;;; `(,descriptor ,name ,length ,inherits ,depth)
+;;; KLUDGE: It would be more understandable and maintainable to use
+;;; DEFSTRUCT (:TYPE LIST) here. -- WHN 19990823
+(defvar *cold-layouts* (make-hash-table :test 'equal))
+
+;;; a map from DESCRIPTOR-BITS of cold layouts to the name, for inverting
+;;; mapping
+(defvar *cold-layout-names* (make-hash-table :test 'eql))
+
+;;; FIXME: *COLD-LAYOUTS* and *COLD-LAYOUT-NAMES* should be
+;;; initialized by binding in GENESIS.
+
+;;; the descriptor for layout's layout (needed when making layouts)
+(defvar *layout-layout*)
+
+;;; FIXME: This information should probably be pulled out of the
+;;; cross-compiler's tables at genesis time instead of inserted by
+;;; hand here as a bare numeric constant.
+(defconstant target-layout-length 16)
+
+;;; Return a list of names created from the cold layout INHERITS data
+;;; in X.
+(defun listify-cold-inherits (x)
+ (let ((len (descriptor-fixnum (read-wordindexed x
+ sb!vm:vector-length-slot))))
+ (collect ((res))
+ (dotimes (index len)
+ (let* ((des (read-wordindexed x (+ sb!vm:vector-data-offset index)))
+ (found (gethash (descriptor-bits des) *cold-layout-names*)))
+ (if found
+ (res found)
+ (error "unknown descriptor at index ~S (bits = ~8,'0X)"
+ index
+ (descriptor-bits des)))))
+ (res))))
+
+(declaim (ftype (function (symbol descriptor descriptor descriptor) descriptor)
+ make-cold-layout))
+(defun make-cold-layout (name length inherits depthoid)
+ (let ((result (allocate-boxed-object *dynamic*
+ ;; KLUDGE: Why 1+? -- WHN 19990901
+ (1+ target-layout-length)
+ sb!vm:instance-pointer-type)))
+ (write-memory result
+ (make-other-immediate-descriptor target-layout-length
+ sb!vm:instance-header-type))
+
+ ;; KLUDGE: The offsets into LAYOUT below should probably be pulled out
+ ;; of the cross-compiler's tables at genesis time instead of inserted
+ ;; by hand as bare numeric constants. -- WHN ca. 19990901
+
+ ;; Set slot 0 = the layout of the layout.
+ (write-wordindexed result sb!vm:instance-slots-offset *layout-layout*)
+
+ ;; Set the immediately following slots = CLOS hash values.
+ ;;
+ ;; Note: CMU CL didn't set these in genesis, but instead arranged
+ ;; for them to be set at cold init time. That resulted in slightly
+ ;; kludgy-looking code, but there were at least two things to be
+ ;; said for it:
+ ;; 1. It put the hash values under the control of the target Lisp's
+ ;; RANDOM function, so that CLOS behavior would be nearly
+ ;; deterministic (instead of depending on the implementation of
+ ;; RANDOM in the cross-compilation host, and the state of its
+ ;; RNG when genesis begins).
+ ;; 2. It automatically ensured that all hash values in the target Lisp
+ ;; were part of the same sequence, so that we didn't have to worry
+ ;; about the possibility of the first hash value set in genesis
+ ;; being precisely equal to the some hash value set in cold init time
+ ;; (because the target Lisp RNG has advanced to precisely the same
+ ;; state that the host Lisp RNG was in earlier).
+ ;; Point 1 should not be an issue in practice because of the way we do our
+ ;; build procedure in two steps, so that the SBCL that we end up with has
+ ;; been created by another SBCL (whose RNG is under our control).
+ ;; Point 2 is more of an issue. If ANSI had provided a way to feed
+ ;; entropy into an RNG, we would have no problem: we'd just feed
+ ;; some specialized genesis-time-only pattern into the RNG state
+ ;; before using it. However, they didn't, so we have a slight
+ ;; problem. We address it by generating the hash values using a
+ ;; different algorithm than we use in ordinary operation.
+ (dotimes (i sb!kernel:layout-clos-hash-length)
+ (let (;; The expression here is pretty arbitrary, we just want
+ ;; to make sure that it's not something which is (1)
+ ;; evenly distributed and (2) not foreordained to arise in
+ ;; the target Lisp's (RANDOM-LAYOUT-CLOS-HASH) sequence
+ ;; and show up as the CLOS-HASH value of some other
+ ;; LAYOUT.
+ ;;
+ ;; FIXME: This expression here can generate a zero value,
+ ;; and the CMU CL code goes out of its way to generate
+ ;; strictly positive values (even though the field is
+ ;; declared as an INDEX). Check that it's really OK to
+ ;; have zero values in the CLOS-HASH slots.
+ (hash-value (mod (logxor (logand (random-layout-clos-hash) 15253)
+ (logandc2 (random-layout-clos-hash) 15253)
+ 1)
+ ;; (The MOD here is defensive programming
+ ;; to make sure we never write an
+ ;; out-of-range value even if some joker
+ ;; sets LAYOUT-CLOS-HASH-MAX to other
+ ;; than 2^n-1 at some time in the
+ ;; future.)
+ (1+ sb!kernel:layout-clos-hash-max))))
+ (write-wordindexed result
+ (+ i sb!vm:instance-slots-offset 1)
+ (make-fixnum-descriptor hash-value))))
+
+ ;; Set other slot values.
+ (let ((base (+ sb!vm:instance-slots-offset
+ sb!kernel:layout-clos-hash-length
+ 1)))
+ ;; (Offset 0 is CLASS, "the class this is a layout for", which
+ ;; is uninitialized at this point.)
+ (write-wordindexed result (+ base 1) *nil-descriptor*) ; marked invalid
+ (write-wordindexed result (+ base 2) inherits)
+ (write-wordindexed result (+ base 3) depthoid)
+ (write-wordindexed result (+ base 4) length)
+ (write-wordindexed result (+ base 5) *nil-descriptor*) ; info
+ (write-wordindexed result (+ base 6) *nil-descriptor*)) ; pure
+
+ (setf (gethash name *cold-layouts*)
+ (list result
+ name
+ (descriptor-fixnum length)
+ (listify-cold-inherits inherits)
+ (descriptor-fixnum depthoid)))
+ (setf (gethash (descriptor-bits result) *cold-layout-names*) name)
+
+ result))
+
+(defun initialize-layouts ()
+
+ (clrhash *cold-layouts*)
+
+ ;; We initially create the layout of LAYOUT itself with NIL as the LAYOUT and
+ ;; #() as INHERITS,
+ (setq *layout-layout* *nil-descriptor*)
+ (setq *layout-layout*
+ (make-cold-layout 'layout
+ (number-to-core target-layout-length)
+ (vector-in-core)
+ ;; FIXME: hard-coded LAYOUT-DEPTHOID of LAYOUT..
+ (number-to-core 4)))
+ (write-wordindexed *layout-layout*
+ sb!vm:instance-slots-offset
+ *layout-layout*)
+
+ ;; Then we create the layouts that we'll need to make a correct INHERITS
+ ;; vector for the layout of LAYOUT itself..
+ ;;
+ ;; FIXME: The various LENGTH and DEPTHOID numbers should be taken from
+ ;; the compiler's tables, not set by hand.
+ (let* ((t-layout
+ (make-cold-layout 't
+ (number-to-core 0)
+ (vector-in-core)
+ (number-to-core 0)))
+ (i-layout
+ (make-cold-layout 'instance
+ (number-to-core 0)
+ (vector-in-core t-layout)
+ (number-to-core 1)))
+ (so-layout
+ (make-cold-layout 'structure-object
+ (number-to-core 1)
+ (vector-in-core t-layout i-layout)
+ (number-to-core 2)))
+ (bso-layout
+ (make-cold-layout 'structure!object
+ (number-to-core 1)
+ (vector-in-core t-layout i-layout so-layout)
+ (number-to-core 3)))
+ (layout-inherits (vector-in-core t-layout
+ i-layout
+ so-layout
+ bso-layout)))
+
+ ;; ..and return to backpatch the layout of LAYOUT.
+ (setf (fourth (gethash 'layout *cold-layouts*))
+ (listify-cold-inherits layout-inherits))
+ (write-wordindexed *layout-layout*
+ ;; FIXME: hardcoded offset into layout struct
+ (+ sb!vm:instance-slots-offset
+ layout-clos-hash-length
+ 1
+ 2)
+ layout-inherits)))
+\f
+;;;; interning symbols in the cold image
+
+;;; In order to avoid having to know about the package format, we
+;;; build a data structure in *COLD-PACKAGE-SYMBOLS* that holds all
+;;; interned symbols along with info about their packages. The data
+;;; structure is a list of sublists, where the sublists have the
+;;; following format:
+;;; (<make-package-arglist>
+;;; <internal-symbols>
+;;; <external-symbols>
+;;; <imported-internal-symbols>
+;;; <imported-external-symbols>
+;;; <shadowing-symbols>)
+;;;
+;;; KLUDGE: It would be nice to implement the sublists as instances of
+;;; a DEFSTRUCT (:TYPE LIST). (They'd still be lists, but at least we'd be
+;;; using mnemonically-named operators to access them, instead of trying
+;;; to remember what THIRD and FIFTH mean, and hoping that we never
+;;; need to change the list layout..) -- WHN 19990825
+
+;;; an alist from packages to lists of that package's symbols to be dumped
+(defvar *cold-package-symbols*)
+(declaim (type list *cold-package-symbols*))
+
+;;; a map from descriptors to symbols, so that we can back up. The key is the
+;;; address in the target core.
+(defvar *cold-symbols*)
+(declaim (type hash-table *cold-symbols*))
+
+;;; Return a handle on an interned symbol. If necessary allocate the
+;;; symbol and record which package the symbol was referenced in. When
+;;; we allocate the symbol, make sure we record a reference to the
+;;; symbol in the home package so that the package gets set.
+(defun cold-intern (symbol &optional (package (symbol-package symbol)))
+
+ ;; Anything on the cross-compilation host which refers to the target
+ ;; machinery through the host SB-XC package can be translated to
+ ;; something on the target which refers to the same machinery
+ ;; through the target COMMON-LISP package.
+ (let ((p (find-package "SB-XC")))
+ (when (eq package p)
+ (setf package *cl-package*))
+ (when (eq (symbol-package symbol) p)
+ (setf symbol (intern (symbol-name symbol) *cl-package*))))
+
+ (let (;; Information about each cold-interned symbol is stored
+ ;; in COLD-INTERN-INFO.
+ ;; (CAR COLD-INTERN-INFO) = descriptor of symbol
+ ;; (CDR COLD-INTERN-INFO) = list of packages, other than symbol's
+ ;; own package, referring to symbol
+ ;; (*COLD-PACKAGE-SYMBOLS* and *COLD-SYMBOLS* store basically the same
+ ;; information, but with the mapping running the opposite way.)
+ (cold-intern-info (get symbol 'cold-intern-info)))
+ (unless cold-intern-info
+ (cond ((eq (symbol-package symbol) package)
+ (let ((handle (allocate-symbol (symbol-name symbol))))
+ (setf (gethash (descriptor-bits handle) *cold-symbols*) symbol)
+ (when (eq package *keyword-package*)
+ (cold-set handle handle))
+ (setq cold-intern-info
+ (setf (get symbol 'cold-intern-info) (cons handle nil)))))
+ (t
+ (cold-intern symbol)
+ (setq cold-intern-info (get symbol 'cold-intern-info)))))
+ (unless (or (null package)
+ (member package (cdr cold-intern-info)))
+ (push package (cdr cold-intern-info))
+ (let* ((old-cps-entry (assoc package *cold-package-symbols*))
+ (cps-entry (or old-cps-entry
+ (car (push (list package)
+ *cold-package-symbols*)))))
+ (unless old-cps-entry
+ (/show "created *COLD-PACKAGE-SYMBOLS* entry for" package symbol))
+ (push symbol (rest cps-entry))))
+ (car cold-intern-info)))
+
+;;; Construct and return a value for use as *NIL-DESCRIPTOR*.
+(defun make-nil-descriptor ()
+ (let* ((des (allocate-unboxed-object
+ *static*
+ sb!vm:word-bits
+ sb!vm:symbol-size
+ 0))
+ (result (make-descriptor (descriptor-high des)
+ (+ (descriptor-low des)
+ (* 2 sb!vm:word-bytes)
+ (- sb!vm:list-pointer-type
+ sb!vm:other-pointer-type)))))
+ (write-wordindexed des
+ 1
+ (make-other-immediate-descriptor
+ 0
+ sb!vm:symbol-header-type))
+ (write-wordindexed des
+ (+ 1 sb!vm:symbol-value-slot)
+ result)
+ (write-wordindexed des
+ (+ 2 sb!vm:symbol-value-slot)
+ result)
+ (write-wordindexed des
+ (+ 1 sb!vm:symbol-plist-slot)
+ result)
+ (write-wordindexed des
+ (+ 1 sb!vm:symbol-name-slot)
+ ;; This is *DYNAMIC*, and DES is *STATIC*,
+ ;; because that's the way CMU CL did it; I'm
+ ;; not sure whether there's an underlying
+ ;; reason. -- WHN 1990826
+ (string-to-core "NIL" *dynamic*))
+ (write-wordindexed des
+ (+ 1 sb!vm:symbol-package-slot)
+ result)
+ (setf (get nil 'cold-intern-info)
+ (cons result nil))
+ (cold-intern nil)
+ result))
+
+;;; Since the initial symbols must be allocated before we can intern
+;;; anything else, we intern those here. We also set the value of T.
+(defun initialize-non-nil-symbols ()
+ #!+sb-doc
+ "Initialize the cold load symbol-hacking data structures."
+ (let ((*cold-symbol-allocation-gspace* *static*))
+ ;; Intern the others.
+ (dolist (symbol sb!vm:*static-symbols*)
+ (let* ((des (cold-intern symbol))
+ (offset-wanted (sb!vm:static-symbol-offset symbol))
+ (offset-found (- (descriptor-low des)
+ (descriptor-low *nil-descriptor*))))
+ (unless (= offset-wanted offset-found)
+ ;; FIXME: should be fatal
+ (warn "Offset from ~S to ~S is ~D, not ~D"
+ symbol
+ nil
+ offset-found
+ offset-wanted))))
+ ;; Establish the value of T.
+ (let ((t-symbol (cold-intern t)))
+ (cold-set t-symbol t-symbol))))
+
+;;; a helper function for FINISH-SYMBOLS: Return a cold alist suitable
+;;; to be stored in *!INITIAL-LAYOUTS*.
+(defun cold-list-all-layouts ()
+ (let ((result *nil-descriptor*))
+ (maphash (lambda (key stuff)
+ (cold-push (cold-cons (cold-intern key)
+ (first stuff))
+ result))
+ *cold-layouts*)
+ result))
+
+;;; Establish initial values for magic symbols.
+;;;
+;;; Scan over all the symbols referenced in each package in
+;;; *COLD-PACKAGE-SYMBOLS* making that for each one there's an
+;;; appropriate entry in the *!INITIAL-SYMBOLS* data structure to
+;;; intern it.
+(defun finish-symbols ()
+
+ ;; FIXME: Why use SETQ (setting symbol value) instead of just using
+ ;; the function values for these things?? I.e. why do we need this
+ ;; section at all? Is it because all the FDEFINITION stuff gets in
+ ;; the way of reading function values and is too hairy to rely on at
+ ;; cold boot? FIXME: 5/6 of these are in *STATIC-SYMBOLS* in
+ ;; parms.lisp, but %HANDLE-FUNCTION-END-BREAKPOINT is not. Why?
+ ;; Explain.
+ (macrolet ((frob (symbol)
+ `(cold-set ',symbol
+ (cold-fdefinition-object (cold-intern ',symbol)))))
+ (frob !cold-init)
+ (frob sb!impl::maybe-gc)
+ (frob internal-error)
+ (frob sb!di::handle-breakpoint)
+ (frob sb!di::handle-function-end-breakpoint)
+ (frob sb!impl::fdefinition-object))
+
+ (cold-set '*current-catch-block* (make-fixnum-descriptor 0))
+ (cold-set '*current-unwind-protect-block* (make-fixnum-descriptor 0))
+ (cold-set '*eval-stack-top* (make-fixnum-descriptor 0))
+
+ (cold-set '*free-interrupt-context-index* (make-fixnum-descriptor 0))
+
+ ;; FIXME: *!INITIAL-LAYOUTS* should be exported from SB!KERNEL, or
+ ;; perhaps from SB-LD.
+ (cold-set 'sb!kernel::*!initial-layouts* (cold-list-all-layouts))
+
+ (/show "dumping packages" (mapcar #'car *cold-package-symbols*))
+ (let ((initial-symbols *nil-descriptor*))
+ (dolist (cold-package-symbols-entry *cold-package-symbols*)
+ (let* ((cold-package (car cold-package-symbols-entry))
+ (symbols (cdr cold-package-symbols-entry))
+ (shadows (package-shadowing-symbols cold-package))
+ (internal *nil-descriptor*)
+ (external *nil-descriptor*)
+ (imported-internal *nil-descriptor*)
+ (imported-external *nil-descriptor*)
+ (shadowing *nil-descriptor*))
+ (/show "dumping" cold-package symbols)
+
+ ;; FIXME: Add assertions here to make sure that inappropriate stuff
+ ;; isn't being dumped:
+ ;; * the CL-USER package
+ ;; * the SB-COLD package
+ ;; * any internal symbols in the CL package
+ ;; * basically any package other than CL, KEYWORD, or the packages
+ ;; in package-data-list.lisp-expr
+ ;; and that the structure of the KEYWORD package (e.g. whether
+ ;; any symbols are internal to it) matches what we want in the
+ ;; target SBCL.
+
+ ;; FIXME: It seems possible that by looking at the contents of
+ ;; packages in the target SBCL we could find which symbols in
+ ;; package-data-lisp.lisp-expr are now obsolete. (If I
+ ;; understand correctly, only symbols which actually have
+ ;; definitions or which are otherwise referred to actually end
+ ;; up in the target packages.)
+
+ (dolist (symbol symbols)
+ (let ((handle (car (get symbol 'cold-intern-info)))
+ (imported-p (not (eq (symbol-package symbol) cold-package))))
+ (multiple-value-bind (found where)
+ (find-symbol (symbol-name symbol) cold-package)
+ (unless (and where (eq found symbol))
+ (error "The symbol ~S is not available in ~S."
+ symbol
+ cold-package))
+ (when (memq symbol shadows)
+ (cold-push handle shadowing))
+ (case where
+ (:internal (if imported-p
+ (cold-push handle imported-internal)
+ (cold-push handle internal)))
+ (:external (if imported-p
+ (cold-push handle imported-external)
+ (cold-push handle external)))))))
+ (let ((r *nil-descriptor*))
+ (cold-push shadowing r)
+ (cold-push imported-external r)
+ (cold-push imported-internal r)
+ (cold-push external r)
+ (cold-push internal r)
+ (cold-push (make-make-package-args cold-package) r)
+ ;; FIXME: It would be more space-efficient to use vectors
+ ;; instead of lists here, and space-efficiency here would be
+ ;; nice, since it would reduce the peak memory usage in
+ ;; genesis and cold init.
+ (cold-push r initial-symbols))))
+ (cold-set '*!initial-symbols* initial-symbols))
+
+ (cold-set '*!initial-fdefn-objects* (list-all-fdefn-objects))
+
+ (cold-set '*!reversed-cold-toplevels* *current-reversed-cold-toplevels*)
+
+ #!+x86
+ (progn
+ (cold-set 'sb!vm::*fp-constant-0d0* (number-to-core 0d0))
+ (cold-set 'sb!vm::*fp-constant-1d0* (number-to-core 1d0))
+ (cold-set 'sb!vm::*fp-constant-0s0* (number-to-core 0s0))
+ (cold-set 'sb!vm::*fp-constant-1s0* (number-to-core 1s0))
+ #!+long-float
+ (progn
+ (cold-set 'sb!vm::*fp-constant-0l0* (number-to-core 0L0))
+ (cold-set 'sb!vm::*fp-constant-1l0* (number-to-core 1L0))
+ ;; FIXME: Why is initialization of PI conditional on LONG-FLOAT?
+ ;; (ditto LG2, LN2, L2E, etc.)
+ (cold-set 'sb!vm::*fp-constant-pi* (number-to-core pi))
+ (cold-set 'sb!vm::*fp-constant-l2t* (number-to-core (log 10L0 2L0)))
+ (cold-set 'sb!vm::*fp-constant-l2e*
+ (number-to-core (log 2.718281828459045235360287471352662L0 2L0)))
+ (cold-set 'sb!vm::*fp-constant-lg2* (number-to-core (log 2L0 10L0)))
+ (cold-set 'sb!vm::*fp-constant-ln2*
+ (number-to-core
+ (log 2L0 2.718281828459045235360287471352662L0))))
+ #!+gencgc
+ (cold-set 'sb!vm::*SCAVENGE-READ-ONLY-GSPACE* *nil-descriptor*)))
+
+;;; Make a cold list that can be used as the arg list to MAKE-PACKAGE in order
+;;; to make a package that is similar to PKG.
+(defun make-make-package-args (pkg)
+ (let* ((use *nil-descriptor*)
+ (cold-nicknames *nil-descriptor*)
+ (res *nil-descriptor*))
+ (dolist (u (package-use-list pkg))
+ (when (assoc u *cold-package-symbols*)
+ (cold-push (string-to-core (package-name u)) use)))
+ (let* ((pkg-name (package-name pkg))
+ ;; Make the package nickname lists for the standard packages
+ ;; be the minimum specified by ANSI, regardless of what value
+ ;; the cross-compilation host happens to use.
+ (warm-nicknames (cond ((string= pkg-name "COMMON-LISP")
+ '("CL"))
+ ((string= pkg-name "COMMON-LISP-USER")
+ '("CL-USER"))
+ ((string= pkg-name "KEYWORD")
+ '())
+ ;; For packages other than the
+ ;; standard packages, the nickname
+ ;; list was specified by our package
+ ;; setup code, not by properties of
+ ;; what cross-compilation host we
+ ;; happened to use, and we can just
+ ;; propagate it into the target.
+ (t
+ (package-nicknames pkg)))))
+ (dolist (warm-nickname warm-nicknames)
+ (cold-push (string-to-core warm-nickname) cold-nicknames)))
+
+ (cold-push (number-to-core (truncate (package-internal-symbol-count pkg)
+ 0.8))
+ res)
+ (cold-push (cold-intern :internal-symbols) res)
+ (cold-push (number-to-core (truncate (package-external-symbol-count pkg)
+ 0.8))
+ res)
+ (cold-push (cold-intern :external-symbols) res)
+
+ (cold-push cold-nicknames res)
+ (cold-push (cold-intern :nicknames) res)
+
+ (cold-push use res)
+ (cold-push (cold-intern :use) res)
+
+ (cold-push (string-to-core (package-name pkg)) res)
+ res))
+\f
+;;;; fdefinition objects
+
+;;; a hash table mapping from fdefinition names to descriptors of cold
+;;; objects. Note: Since fdefinition names can be lists like '(SETF
+;;; FOO), and we want to have only one entry per name, this must be an
+;;; 'EQUAL hash table, not the default 'EQL.
+(defvar *cold-fdefn-objects*)
+
+(defvar *cold-fdefn-gspace* nil)
+
+;;; Given a cold representation of an FDEFN name, return a warm representation.
+;;;
+;;; Note: Despite the name, this actually has little to do with
+;;; FDEFNs, it's just a function for warming up values, and the only
+;;; values it knows how to warm up are symbols and lists. (The
+;;; connection to FDEFNs is that symbols and lists are the only
+;;; possible names for functions.)
+(declaim (ftype (function (descriptor) (or symbol list)) warm-fdefn-name))
+(defun warm-fdefn-name (des)
+ (ecase (descriptor-lowtag des)
+ (#.sb!vm:list-pointer-type ; FIXME: no #.
+ (if (= (descriptor-bits des) (descriptor-bits *nil-descriptor*))
+ nil
+ ;; FIXME: If we cold-intern this again, we might get a different
+ ;; name. Check to make sure that any hash tables along the way
+ ;; are 'EQUAL not 'EQL.
+ (cons (warm-fdefn-name (read-wordindexed des sb!vm:cons-car-slot))
+ (warm-fdefn-name (read-wordindexed des sb!vm:cons-cdr-slot)))))
+ (#.sb!vm:other-pointer-type ; FIXME: no #.
+ (or (gethash (descriptor-bits des) *cold-symbols*)
+ (descriptor-bits des)))))
+
+(defun cold-fdefinition-object (cold-name &optional leave-fn-raw)
+ (declare (type descriptor cold-name))
+ (let ((warm-name (warm-fdefn-name cold-name)))
+ (or (gethash warm-name *cold-fdefn-objects*)
+ (let ((fdefn (allocate-boxed-object (or *cold-fdefn-gspace* *dynamic*)
+ (1- sb!vm:fdefn-size)
+ sb!vm:other-pointer-type)))
+
+ (setf (gethash warm-name *cold-fdefn-objects*) fdefn)
+ (write-memory fdefn (make-other-immediate-descriptor
+ (1- sb!vm:fdefn-size) sb!vm:fdefn-type))
+ (write-wordindexed fdefn sb!vm:fdefn-name-slot cold-name)
+ (unless leave-fn-raw
+ (write-wordindexed fdefn sb!vm:fdefn-function-slot
+ *nil-descriptor*)
+ (write-wordindexed fdefn
+ sb!vm:fdefn-raw-addr-slot
+ (make-random-descriptor
+ (lookup-foreign-symbol "undefined_tramp"))))
+ fdefn))))
+
+(defun cold-fset (cold-name defn)
+ (declare (type descriptor cold-name))
+ (let ((fdefn (cold-fdefinition-object cold-name t))
+ (type (logand (descriptor-low (read-memory defn)) sb!vm:type-mask)))
+ (write-wordindexed fdefn sb!vm:fdefn-function-slot defn)
+ (write-wordindexed fdefn
+ sb!vm:fdefn-raw-addr-slot
+ (ecase type
+ (#.sb!vm:function-header-type
+ #!+sparc
+ defn
+ #!-sparc
+ (make-random-descriptor
+ (+ (logandc2 (descriptor-bits defn)
+ sb!vm:lowtag-mask)
+ (ash sb!vm:function-code-offset
+ sb!vm:word-shift))))
+ (#.sb!vm:closure-header-type
+ (make-random-descriptor
+ (lookup-foreign-symbol "closure_tramp")))))
+ fdefn))
+
+(defun initialize-static-fns ()
+ (let ((*cold-fdefn-gspace* *static*))
+ (dolist (sym sb!vm:*static-functions*)
+ (let* ((fdefn (cold-fdefinition-object (cold-intern sym)))
+ (offset (- (+ (- (descriptor-low fdefn)
+ sb!vm:other-pointer-type)
+ (* sb!vm:fdefn-raw-addr-slot sb!vm:word-bytes))
+ (descriptor-low *nil-descriptor*)))
+ (desired (sb!vm:static-function-offset sym)))
+ (unless (= offset desired)
+ ;; FIXME: should be fatal
+ (warn "Offset from FDEFN ~S to ~S is ~D, not ~D."
+ sym nil offset desired))))))
+
+(defun list-all-fdefn-objects ()
+ (let ((result *nil-descriptor*))
+ (maphash #'(lambda (key value)
+ (declare (ignore key))
+ (cold-push value result))
+ *cold-fdefn-objects*)
+ result))
+\f
+;;;; fixups and related stuff
+
+;;; an EQUAL hash table
+(defvar *cold-foreign-symbol-table*)
+(declaim (type hash-table *cold-foreign-symbol-table*))
+
+(defun load-foreign-symbol-table (filename)
+ (with-open-file (file filename)
+ (loop
+ (let ((line (read-line file nil nil)))
+ (unless line
+ (return))
+ ;; UNIX symbol tables might have tabs in them, and tabs are
+ ;; not in Common Lisp STANDARD-CHAR, so there seems to be no
+ ;; nice portable way to deal with them within Lisp, alas.
+ ;; Fortunately, it's easy to use UNIX command line tools like
+ ;; sed to remove the problem, so it's not too painful for us
+ ;; to push responsibility for converting tabs to spaces out to
+ ;; the caller.
+ ;;
+ ;; Other non-STANDARD-CHARs are problematic for the same reason.
+ ;; Make sure that there aren't any..
+ (let ((ch (find-if (lambda (char)
+ (not (typep char 'standard-char)))
+ line)))
+ (when ch
+ (error "non-STANDARD-CHAR ~S found in foreign symbol table:~%~S"
+ ch
+ line)))
+ (setf line (string-trim '(#\space) line))
+ (let ((p1 (position #\space line :from-end nil))
+ (p2 (position #\space line :from-end t)))
+ (if (not (and p1 p2 (< p1 p2)))
+ ;; KLUDGE: It's too messy to try to understand all
+ ;; possible output from nm, so we just punt the lines we
+ ;; don't recognize. We realize that there's some chance
+ ;; that might get us in trouble someday, so we warn
+ ;; about it.
+ (warn "ignoring unrecognized line ~S in ~A" line filename)
+ (multiple-value-bind (value name)
+ (if (string= "0x" line :end2 2)
+ (values (parse-integer line :start 2 :end p1 :radix 16)
+ (subseq line (1+ p2)))
+ (values (parse-integer line :end p1 :radix 16)
+ (subseq line (1+ p2))))
+ (multiple-value-bind (old-value found)
+ (gethash name *cold-foreign-symbol-table*)
+ (when (and found
+ (not (= old-value value)))
+ (warn "redefining ~S from #X~X to #X~X"
+ name old-value value)))
+ (setf (gethash name *cold-foreign-symbol-table*) value))))))
+ (values)))
+
+(defun lookup-foreign-symbol (name)
+ #!+x86
+ (let ((prefixes
+ #!+linux #(;; FIXME: How many of these are actually
+ ;; needed? The first four are taken from rather
+ ;; disorganized CMU CL code, which could easily
+ ;; have had redundant values in it..
+ "_"
+ "__"
+ "__libc_"
+ "ldso_stub__"
+ ;; ..and the fifth seems to match most
+ ;; actual symbols, at least in RedHat 6.2.
+ "")
+ #!+freebsd #("")
+ #!+openbsd #("_")))
+ (or (some (lambda (prefix)
+ (gethash (concatenate 'string prefix name)
+ *cold-foreign-symbol-table*
+ nil))
+ prefixes)
+ *foreign-symbol-placeholder-value*
+ (progn
+ (format *error-output* "~&The foreign symbol table is:~%")
+ (maphash (lambda (k v)
+ (format *error-output* "~&~S = #X~8X~%" k v))
+ *cold-foreign-symbol-table*)
+ (format *error-output* "~&The prefix table is: ~S~%" prefixes)
+ (error "The foreign symbol ~S is undefined." name))))
+ #!-x86 (error "non-x86 unsupported in SBCL (but see old CMU CL code)"))
+
+(defvar *cold-assembler-routines*)
+
+(defvar *cold-assembler-fixups*)
+
+(defun record-cold-assembler-routine (name address)
+ (/xhow "in RECORD-COLD-ASSEMBLER-ROUTINE" name address)
+ (push (cons name address)
+ *cold-assembler-routines*))
+
+(defun record-cold-assembler-fixup (routine
+ code-object
+ offset
+ &optional
+ (kind :both))
+ (push (list routine code-object offset kind)
+ *cold-assembler-fixups*))
+
+(defun lookup-assembler-reference (symbol)
+ (let ((value (cdr (assoc symbol *cold-assembler-routines*))))
+ ;; FIXME: Should this be ERROR instead of WARN?
+ (unless value
+ (warn "Assembler routine ~S not defined." symbol))
+ value))
+
+;;; The x86 port needs to store code fixups along with code objects if
+;;; they are to be moved, so fixups for code objects in the dynamic
+;;; heap need to be noted.
+#!+x86
+(defvar *load-time-code-fixups*)
+
+#!+x86
+(defun note-load-time-code-fixup (code-object offset value kind)
+ ;; If CODE-OBJECT might be moved
+ (when (= (gspace-identifier (descriptor-intuit-gspace code-object))
+ dynamic-space-id)
+ ;; FIXME: pushed thing should be a structure, not just a list
+ (push (list code-object offset value kind) *load-time-code-fixups*))
+ (values))
+
+#!+x86
+(defun output-load-time-code-fixups ()
+ (dolist (fixups *load-time-code-fixups*)
+ (let ((code-object (first fixups))
+ (offset (second fixups))
+ (value (third fixups))
+ (kind (fourth fixups)))
+ (cold-push (cold-cons
+ (cold-intern :load-time-code-fixup)
+ (cold-cons
+ code-object
+ (cold-cons
+ (number-to-core offset)
+ (cold-cons
+ (number-to-core value)
+ (cold-cons
+ (cold-intern kind)
+ *nil-descriptor*)))))
+ *current-reversed-cold-toplevels*))))
+
+;;; Given a pointer to a code object and an offset relative to the
+;;; tail of the code object's header, return an offset relative to the
+;;; (beginning of the) code object.
+;;;
+;;; FIXME: It might be clearer to reexpress
+;;; (LET ((X (CALC-OFFSET CODE-OBJECT OFFSET0))) ..)
+;;; as
+;;; (LET ((X (+ OFFSET0 (CODE-OBJECT-HEADER-N-BYTES CODE-OBJECT)))) ..).
+(declaim (ftype (function (descriptor sb!vm:word)) calc-offset))
+(defun calc-offset (code-object offset-from-tail-of-header)
+ (let* ((header (read-memory code-object))
+ (header-n-words (ash (descriptor-bits header) (- sb!vm:type-bits)))
+ (header-n-bytes (ash header-n-words sb!vm:word-shift))
+ (result (+ offset-from-tail-of-header header-n-bytes)))
+ result))
+
+(declaim (ftype (function (descriptor sb!vm:word sb!vm:word keyword))
+ do-cold-fixup))
+(defun do-cold-fixup (code-object after-header value kind)
+ (let* ((offset-within-code-object (calc-offset code-object after-header))
+ (gspace-bytes (descriptor-bytes code-object))
+ (gspace-byte-offset (+ (descriptor-byte-offset code-object)
+ offset-within-code-object))
+ (gspace-byte-address (gspace-byte-address
+ (descriptor-gspace code-object))))
+ (ecase sb!c:*backend-fasl-file-implementation*
+ ;; Classic CMU CL supported these, and I haven't gone out of my way
+ ;; to break them, but I have no way of testing them.. -- WHN 19990817
+ #|
+ (#.sb!c:pmax-fasl-file-implementation
+ (ecase kind
+ (:jump
+ (assert (zerop (ash value -28)))
+ (setf (ldb (byte 26 0) (sap-ref-32 sap 0))
+ (ash value -2)))
+ (:lui
+ (setf (sap-ref-16 sap 0)
+ (+ (ash value -16)
+ (if (logbitp 15 value) 1 0))))
+ (:addi
+ (setf (sap-ref-16 sap 0)
+ (ldb (byte 16 0) value)))))
+ (#.sb!c:sparc-fasl-file-implementation
+ (let ((inst (maybe-byte-swap (sap-ref-32 sap 0))))
+ (ecase kind
+ (:call
+ (error "Can't deal with call fixups yet."))
+ (:sethi
+ (setf inst
+ (dpb (ldb (byte 22 10) value)
+ (byte 22 0)
+ inst)))
+ (:add
+ (setf inst
+ (dpb (ldb (byte 10 0) value)
+ (byte 10 0)
+ inst))))
+ (setf (sap-ref-32 sap 0)
+ (maybe-byte-swap inst))))
+ ((#.sb!c:rt-fasl-file-implementation
+ #.sb!c:rt-afpa-fasl-file-implementation)
+ (ecase kind
+ (:cal
+ (setf (sap-ref-16 sap 2)
+ (maybe-byte-swap-short
+ (ldb (byte 16 0) value))))
+ (:cau
+ (let ((high (ldb (byte 16 16) value)))
+ (setf (sap-ref-16 sap 2)
+ (maybe-byte-swap-short
+ (if (logbitp 15 value) (1+ high) high)))))
+ (:ba
+ (unless (zerop (ash value -24))
+ (warn "#X~8,'0X out of range for branch-absolute." value))
+ (let ((inst (maybe-byte-swap-short (sap-ref-16 sap 0))))
+ (setf (sap-ref-16 sap 0)
+ (maybe-byte-swap-short
+ (dpb (ldb (byte 8 16) value)
+ (byte 8 0)
+ inst))))
+ (setf (sap-ref-16 sap 2)
+ (maybe-byte-swap-short (ldb (byte 16 0) value))))))
+ |#
+ (:x86
+ (let* ((un-fixed-up (byte-vector-ref-32 gspace-bytes
+ gspace-byte-offset))
+ (code-object-start-addr (logandc2 (descriptor-bits code-object)
+ sb!vm:lowtag-mask)))
+ (assert (= code-object-start-addr
+ (+ gspace-byte-address
+ (descriptor-byte-offset code-object))))
+ (ecase kind
+ (:absolute
+ (let ((fixed-up (+ value un-fixed-up)))
+ (setf (byte-vector-ref-32 gspace-bytes gspace-byte-offset)
+ fixed-up)
+ ;; comment from CMU CL sources:
+ ;;
+ ;; Note absolute fixups that point within the object.
+ ;; KLUDGE: There seems to be an implicit assumption in
+ ;; the old CMU CL code here, that if it doesn't point
+ ;; before the object, it must point within the object
+ ;; (not beyond it). It would be good to add an
+ ;; explanation of why that's true, or an assertion that
+ ;; it's really true, or both.
+ (unless (< fixed-up code-object-start-addr)
+ (note-load-time-code-fixup code-object
+ after-header
+ value
+ kind))))
+ (:relative ; (used for arguments to X86 relative CALL instruction)
+ (let ((fixed-up (- (+ value un-fixed-up)
+ gspace-byte-address
+ gspace-byte-offset
+ sb!vm:word-bytes))) ; length of CALL argument
+ (setf (byte-vector-ref-32 gspace-bytes gspace-byte-offset)
+ fixed-up)
+ ;; Note relative fixups that point outside the code
+ ;; object, which is to say all relative fixups, since
+ ;; relative addressing within a code object never needs
+ ;; a fixup.
+ (note-load-time-code-fixup code-object
+ after-header
+ value
+ kind))))))
+ ;; CMU CL supported these, and I haven't gone out of my way to break
+ ;; them, but I have no way of testing them.. -- WHN 19990817
+ #|
+ (#.sb!c:hppa-fasl-file-implementation
+ (let ((inst (maybe-byte-swap (sap-ref-32 sap 0))))
+ (setf (sap-ref-32 sap 0)
+ (maybe-byte-swap
+ (ecase kind
+ (:load
+ (logior (ash (ldb (byte 11 0) value) 1)
+ (logand inst #xffffc000)))
+ (:load-short
+ (let ((low-bits (ldb (byte 11 0) value)))
+ (assert (<= 0 low-bits (1- (ash 1 4))))
+ (logior (ash low-bits 17)
+ (logand inst #xffe0ffff))))
+ (:hi
+ (logior (ash (ldb (byte 5 13) value) 16)
+ (ash (ldb (byte 2 18) value) 14)
+ (ash (ldb (byte 2 11) value) 12)
+ (ash (ldb (byte 11 20) value) 1)
+ (ldb (byte 1 31) value)
+ (logand inst #xffe00000)))
+ (:branch
+ (let ((bits (ldb (byte 9 2) value)))
+ (assert (zerop (ldb (byte 2 0) value)))
+ (logior (ash bits 3)
+ (logand inst #xffe0e002)))))))))
+ (#.sb!c:alpha-fasl-file-implementation
+ (ecase kind
+ (:jmp-hint
+ (assert (zerop (ldb (byte 2 0) value)))
+ #+nil
+ (setf (sap-ref-16 sap 0)
+ (logior (sap-ref-16 sap 0) (ldb (byte 14 0) (ash value -2)))))
+ (:bits-63-48
+ (let* ((value (if (logbitp 15 value) (+ value (ash 1 16)) value))
+ (value (if (logbitp 31 value) (+ value (ash 1 32)) value))
+ (value (if (logbitp 47 value) (+ value (ash 1 48)) value)))
+ (setf (sap-ref-8 sap 0) (ldb (byte 8 48) value))
+ (setf (sap-ref-8 sap 1) (ldb (byte 8 56) value))))
+ (:bits-47-32
+ (let* ((value (if (logbitp 15 value) (+ value (ash 1 16)) value))
+ (value (if (logbitp 31 value) (+ value (ash 1 32)) value)))
+ (setf (sap-ref-8 sap 0) (ldb (byte 8 32) value))
+ (setf (sap-ref-8 sap 1) (ldb (byte 8 40) value))))
+ (:ldah
+ (let ((value (if (logbitp 15 value) (+ value (ash 1 16)) value)))
+ (setf (sap-ref-8 sap 0) (ldb (byte 8 16) value))
+ (setf (sap-ref-8 sap 1) (ldb (byte 8 24) value))))
+ (:lda
+ (setf (sap-ref-8 sap 0) (ldb (byte 8 0) value))
+ (setf (sap-ref-8 sap 1) (ldb (byte 8 8) value)))))
+ (#.sb!c:sgi-fasl-file-implementation
+ (ecase kind
+ (:jump
+ (assert (zerop (ash value -28)))
+ (setf (ldb (byte 26 0) (sap-ref-32 sap 0))
+ (ash value -2)))
+ (:lui
+ (setf (sap-ref-16 sap 2)
+ (+ (ash value -16)
+ (if (logbitp 15 value) 1 0))))
+ (:addi
+ (setf (sap-ref-16 sap 2)
+ (ldb (byte 16 0) value)))))
+ |#
+ ))
+ (values))
+
+(defun resolve-assembler-fixups ()
+ (dolist (fixup *cold-assembler-fixups*)
+ (let* ((routine (car fixup))
+ (value (lookup-assembler-reference routine)))
+ (when value
+ (do-cold-fixup (second fixup) (third fixup) value (fourth fixup))))))
+
+(defun linkage-info-to-core ()
+ (let ((result *nil-descriptor*))
+ (maphash #'(lambda (symbol value)
+ (cold-push (cold-cons (string-to-core symbol)
+ (number-to-core value))
+ result))
+ *cold-foreign-symbol-table*)
+ (cold-set (cold-intern '*!initial-foreign-symbols*) result))
+ (let ((result *nil-descriptor*))
+ (dolist (rtn *cold-assembler-routines*)
+ (cold-push (cold-cons (cold-intern (car rtn))
+ (number-to-core (cdr rtn)))
+ result))
+ (cold-set (cold-intern '*!initial-assembler-routines*) result)))
+\f
+;;;; general machinery for cold-loading FASL files
+
+(defvar *cold-fop-functions* (replace (make-array 256) *fop-functions*)
+ #!+sb-doc
+ "FOP functions for cold loading")
+
+(defvar *normal-fop-functions*)
+
+;;; This is like DEFINE-FOP which defines fops for warm load, but unlike
+;;; DEFINE-FOP, this version
+;;; (1) looks up the code for this name (created by a previous DEFINE-FOP)
+;;; instead of creating a code, and
+;;; (2) stores its definition in the *COLD-FOP-FUNCTIONS* vector, instead
+;;; of storing in the *FOP-FUNCTIONS* vector.
+(defmacro define-cold-fop ((name &optional (pushp t)) &rest forms)
+ (check-type pushp (member nil t :nope))
+ (let ((code (get name 'fop-code))
+ (fname (concat-pnames 'cold- name)))
+ (unless code
+ (error "~S is not a defined FOP." name))
+ `(progn
+ (defun ,fname ()
+ ,@(if (eq pushp :nope)
+ forms
+ `((with-fop-stack ,pushp ,@forms))))
+ (setf (svref *cold-fop-functions* ,code) #',fname))))
+
+(defmacro clone-cold-fop ((name &optional (pushp t)) (small-name) &rest forms)
+ (check-type pushp (member nil t :nope))
+ `(progn
+ (macrolet ((clone-arg () '(read-arg 4)))
+ (define-cold-fop (,name ,pushp) ,@forms))
+ (macrolet ((clone-arg () '(read-arg 1)))
+ (define-cold-fop (,small-name ,pushp) ,@forms))))
+
+;;; Cause a fop to be undefined in cold load.
+(defmacro not-cold-fop (name)
+ `(define-cold-fop (,name)
+ (error "The fop ~S is not supported in cold load." ',name)))
+
+;;; COLD-LOAD loads stuff into the core image being built by calling FASLOAD
+;;; with the fop function table rebound to a table of cold loading functions.
+(defun cold-load (filename)
+ #!+sb-doc
+ "Load the file named by FILENAME into the cold load image being built."
+ (let* ((*normal-fop-functions* *fop-functions*)
+ (*fop-functions* *cold-fop-functions*)
+ (*cold-load-filename* (etypecase filename
+ (string filename)
+ (pathname (namestring filename)))))
+ (with-open-file (s filename :element-type '(unsigned-byte 8))
+ (fasload s nil nil))))
+\f
+;;;; miscellaneous cold fops
+
+(define-cold-fop (fop-misc-trap) *unbound-marker*)
+
+(define-cold-fop (fop-character)
+ (make-character-descriptor (read-arg 3)))
+(define-cold-fop (fop-short-character)
+ (make-character-descriptor (read-arg 1)))
+
+(define-cold-fop (fop-empty-list) *nil-descriptor*)
+(define-cold-fop (fop-truth) (cold-intern t))
+
+(define-cold-fop (fop-normal-load :nope)
+ (setq *fop-functions* *normal-fop-functions*))
+
+(define-fop (fop-maybe-cold-load 82 :nope)
+ (when *cold-load-filename*
+ (setq *fop-functions* *cold-fop-functions*)))
+
+(define-cold-fop (fop-maybe-cold-load :nope))
+
+(clone-cold-fop (fop-struct)
+ (fop-small-struct)
+ (let* ((size (clone-arg))
+ (result (allocate-boxed-object *dynamic*
+ (1+ size)
+ sb!vm:instance-pointer-type)))
+ (write-memory result (make-other-immediate-descriptor
+ size
+ sb!vm:instance-header-type))
+ (do ((index (1- size) (1- index)))
+ ((minusp index))
+ (declare (fixnum index))
+ (write-wordindexed result
+ (+ index sb!vm:instance-slots-offset)
+ (pop-stack)))
+ result))
+
+(define-cold-fop (fop-layout)
+ (let* ((length-des (pop-stack))
+ (depthoid-des (pop-stack))
+ (cold-inherits (pop-stack))
+ (name (pop-stack))
+ (old (gethash name *cold-layouts*)))
+ (declare (type descriptor length-des depthoid-des cold-inherits))
+ (declare (type symbol name))
+ ;; If a layout of this name has been defined already
+ (if old
+ ;; Enforce consistency between the previous definition and the
+ ;; current definition, then return the previous definition.
+ (destructuring-bind
+ ;; FIXME: This would be more maintainable if we used
+ ;; DEFSTRUCT (:TYPE LIST) to define COLD-LAYOUT. -- WHN 19990825
+ (old-layout-descriptor
+ old-name
+ old-length
+ old-inherits-list
+ old-depthoid)
+ old
+ (declare (type descriptor old-layout-descriptor))
+ (declare (type index old-length))
+ (declare (type fixnum old-depthoid))
+ (declare (type list old-inherits-list))
+ (assert (eq name old-name))
+ (let ((length (descriptor-fixnum length-des))
+ (inherits-list (listify-cold-inherits cold-inherits))
+ (depthoid (descriptor-fixnum depthoid-des)))
+ (unless (= length old-length)
+ (error "cold loading a reference to class ~S when the compile~%~
+ time length was ~S and current length is ~S"
+ name
+ length
+ old-length))
+ (unless (equal inherits-list old-inherits-list)
+ (error "cold loading a reference to class ~S when the compile~%~
+ time inherits were ~S~%~
+ and current inherits are ~S"
+ name
+ inherits-list
+ old-inherits-list))
+ (unless (= depthoid old-depthoid)
+ (error "cold loading a reference to class ~S when the compile~%~
+ time inheritance depthoid was ~S and current inheritance~%~
+ depthoid is ~S"
+ name
+ depthoid
+ old-depthoid)))
+ old-layout-descriptor)
+ ;; Make a new definition from scratch.
+ (make-cold-layout name length-des cold-inherits depthoid-des))))
+\f
+;;;; cold fops for loading symbols
+
+;;; Load a symbol SIZE characters long from *FASL-FILE* and intern
+;;; that symbol in PACKAGE.
+(defun cold-load-symbol (size package)
+ (let ((string (make-string size)))
+ (read-string-as-bytes *fasl-file* string)
+ (cold-intern (intern string package) package)))
+
+(macrolet ((frob (name pname-len package-len)
+ `(define-cold-fop (,name)
+ (let ((index (read-arg ,package-len)))
+ (push-fop-table
+ (cold-load-symbol (read-arg ,pname-len)
+ (svref *current-fop-table* index)))))))
+ (frob fop-symbol-in-package-save 4 4)
+ (frob fop-small-symbol-in-package-save 1 4)
+ (frob fop-symbol-in-byte-package-save 4 1)
+ (frob fop-small-symbol-in-byte-package-save 1 1))
+
+(clone-cold-fop (fop-lisp-symbol-save)
+ (fop-lisp-small-symbol-save)
+ (push-fop-table (cold-load-symbol (clone-arg) *cl-package*)))
+
+(clone-cold-fop (fop-keyword-symbol-save)
+ (fop-keyword-small-symbol-save)
+ (push-fop-table (cold-load-symbol (clone-arg) *keyword-package*)))
+
+(clone-cold-fop (fop-uninterned-symbol-save)
+ (fop-uninterned-small-symbol-save)
+ (let* ((size (clone-arg))
+ (name (make-string size)))
+ (read-string-as-bytes *fasl-file* name)
+ (let ((symbol (allocate-symbol name)))
+ (push-fop-table symbol))))
+\f
+;;;; cold fops for loading lists
+
+;;; Make a list of the top LENGTH things on the fop stack. The last
+;;; cdr of the list is set to LAST.
+(defmacro cold-stack-list (length last)
+ `(do* ((index ,length (1- index))
+ (result ,last (cold-cons (pop-stack) result)))
+ ((= index 0) result)
+ (declare (fixnum index))))
+
+(define-cold-fop (fop-list)
+ (cold-stack-list (read-arg 1) *nil-descriptor*))
+(define-cold-fop (fop-list*)
+ (cold-stack-list (read-arg 1) (pop-stack)))
+(define-cold-fop (fop-list-1)
+ (cold-stack-list 1 *nil-descriptor*))
+(define-cold-fop (fop-list-2)
+ (cold-stack-list 2 *nil-descriptor*))
+(define-cold-fop (fop-list-3)
+ (cold-stack-list 3 *nil-descriptor*))
+(define-cold-fop (fop-list-4)
+ (cold-stack-list 4 *nil-descriptor*))
+(define-cold-fop (fop-list-5)
+ (cold-stack-list 5 *nil-descriptor*))
+(define-cold-fop (fop-list-6)
+ (cold-stack-list 6 *nil-descriptor*))
+(define-cold-fop (fop-list-7)
+ (cold-stack-list 7 *nil-descriptor*))
+(define-cold-fop (fop-list-8)
+ (cold-stack-list 8 *nil-descriptor*))
+(define-cold-fop (fop-list*-1)
+ (cold-stack-list 1 (pop-stack)))
+(define-cold-fop (fop-list*-2)
+ (cold-stack-list 2 (pop-stack)))
+(define-cold-fop (fop-list*-3)
+ (cold-stack-list 3 (pop-stack)))
+(define-cold-fop (fop-list*-4)
+ (cold-stack-list 4 (pop-stack)))
+(define-cold-fop (fop-list*-5)
+ (cold-stack-list 5 (pop-stack)))
+(define-cold-fop (fop-list*-6)
+ (cold-stack-list 6 (pop-stack)))
+(define-cold-fop (fop-list*-7)
+ (cold-stack-list 7 (pop-stack)))
+(define-cold-fop (fop-list*-8)
+ (cold-stack-list 8 (pop-stack)))
+\f
+;;;; cold fops for loading vectors
+
+(clone-cold-fop (fop-string)
+ (fop-small-string)
+ (let* ((len (clone-arg))
+ (string (make-string len)))
+ (read-string-as-bytes *fasl-file* string)
+ (string-to-core string)))
+
+(clone-cold-fop (fop-vector)
+ (fop-small-vector)
+ (let* ((size (clone-arg))
+ (result (allocate-vector-object *dynamic*
+ sb!vm:word-bits
+ size
+ sb!vm:simple-vector-type)))
+ (do ((index (1- size) (1- index)))
+ ((minusp index))
+ (declare (fixnum index))
+ (write-wordindexed result
+ (+ index sb!vm:vector-data-offset)
+ (pop-stack)))
+ result))
+
+(define-cold-fop (fop-int-vector)
+ (let* ((len (read-arg 4))
+ (sizebits (read-arg 1))
+ (type (case sizebits
+ (1 sb!vm:simple-bit-vector-type)
+ (2 sb!vm:simple-array-unsigned-byte-2-type)
+ (4 sb!vm:simple-array-unsigned-byte-4-type)
+ (8 sb!vm:simple-array-unsigned-byte-8-type)
+ (16 sb!vm:simple-array-unsigned-byte-16-type)
+ (32 sb!vm:simple-array-unsigned-byte-32-type)
+ (t (error "losing element size: ~D" sizebits))))
+ (result (allocate-vector-object *dynamic* sizebits len type))
+ (start (+ (descriptor-byte-offset result)
+ (ash sb!vm:vector-data-offset sb!vm:word-shift)))
+ (end (+ start
+ (ceiling (* len sizebits)
+ sb!vm:byte-bits))))
+ (read-sequence-or-die (descriptor-bytes result)
+ *fasl-file*
+ :start start
+ :end end)
+ result))
+
+(define-cold-fop (fop-single-float-vector)
+ (let* ((len (read-arg 4))
+ (result (allocate-vector-object *dynamic*
+ sb!vm:word-bits
+ len
+ sb!vm:simple-array-single-float-type))
+ (start (+ (descriptor-byte-offset result)
+ (ash sb!vm:vector-data-offset sb!vm:word-shift)))
+ (end (+ start (* len sb!vm:word-bytes))))
+ (read-sequence-or-die (descriptor-bytes result)
+ *fasl-file*
+ :start start
+ :end end)
+ result))
+
+(not-cold-fop fop-double-float-vector)
+#!+long-float (not-cold-fop fop-long-float-vector)
+(not-cold-fop fop-complex-single-float-vector)
+(not-cold-fop fop-complex-double-float-vector)
+#!+long-float (not-cold-fop fop-complex-long-float-vector)
+
+(define-cold-fop (fop-array)
+ (let* ((rank (read-arg 4))
+ (data-vector (pop-stack))
+ (result (allocate-boxed-object *dynamic*
+ (+ sb!vm:array-dimensions-offset rank)
+ sb!vm:other-pointer-type)))
+ (write-memory result
+ (make-other-immediate-descriptor rank
+ sb!vm:simple-array-type))
+ (write-wordindexed result sb!vm:array-fill-pointer-slot *nil-descriptor*)
+ (write-wordindexed result sb!vm:array-data-slot data-vector)
+ (write-wordindexed result sb!vm:array-displacement-slot *nil-descriptor*)
+ (write-wordindexed result sb!vm:array-displaced-p-slot *nil-descriptor*)
+ (let ((total-elements 1))
+ (dotimes (axis rank)
+ (let ((dim (pop-stack)))
+ (unless (or (= (descriptor-lowtag dim) sb!vm:even-fixnum-type)
+ (= (descriptor-lowtag dim) sb!vm:odd-fixnum-type))
+ (error "non-fixnum dimension? (~S)" dim))
+ (setf total-elements
+ (* total-elements
+ (logior (ash (descriptor-high dim)
+ (- descriptor-low-bits (1- sb!vm:lowtag-bits)))
+ (ash (descriptor-low dim)
+ (- 1 sb!vm:lowtag-bits)))))
+ (write-wordindexed result
+ (+ sb!vm:array-dimensions-offset axis)
+ dim)))
+ (write-wordindexed result
+ sb!vm:array-elements-slot
+ (make-fixnum-descriptor total-elements)))
+ result))
+\f
+;;;; cold fops for loading numbers
+
+(defmacro define-cold-number-fop (fop)
+ `(define-cold-fop (,fop :nope)
+ ;; Invoke the ordinary warm version of this fop to push the
+ ;; number.
+ (,fop)
+ ;; Replace the warm fop result with the cold image of the warm
+ ;; fop result.
+ (with-fop-stack t
+ (let ((number (pop-stack)))
+ (number-to-core number)))))
+
+(define-cold-number-fop fop-single-float)
+(define-cold-number-fop fop-double-float)
+(define-cold-number-fop fop-integer)
+(define-cold-number-fop fop-small-integer)
+(define-cold-number-fop fop-word-integer)
+(define-cold-number-fop fop-byte-integer)
+(define-cold-number-fop fop-complex-single-float)
+(define-cold-number-fop fop-complex-double-float)
+
+#!+long-float
+(define-cold-fop (fop-long-float)
+ (ecase sb!c:*backend-fasl-file-implementation*
+ (:x86 ; 80 bit long-float format
+ (prepare-for-fast-read-byte *fasl-file*
+ (let* ((des (allocate-unboxed-object *dynamic* sb!vm:word-bits
+ (1- sb!vm:long-float-size)
+ sb!vm:long-float-type))
+ (low-bits (make-random-descriptor (fast-read-u-integer 4)))
+ (high-bits (make-random-descriptor (fast-read-u-integer 4)))
+ (exp-bits (make-random-descriptor (fast-read-s-integer 2))))
+ (done-with-fast-read-byte)
+ (write-wordindexed des sb!vm:long-float-value-slot low-bits)
+ (write-wordindexed des (1+ sb!vm:long-float-value-slot) high-bits)
+ (write-wordindexed des (+ 2 sb!vm:long-float-value-slot) exp-bits)
+ des)))
+ ;; This was supported in CMU CL, but isn't currently supported in
+ ;; SBCL.
+ #+nil
+ (#.sb!c:sparc-fasl-file-implementation ; 128 bit long-float format
+ (prepare-for-fast-read-byte *fasl-file*
+ (let* ((des (allocate-unboxed-object *dynamic* sb!vm:word-bits
+ (1- sb!vm:long-float-size)
+ sb!vm:long-float-type))
+ (low-bits (make-random-descriptor (fast-read-u-integer 4)))
+ (mid-bits (make-random-descriptor (fast-read-u-integer 4)))
+ (high-bits (make-random-descriptor (fast-read-u-integer 4)))
+ (exp-bits (make-random-descriptor (fast-read-s-integer 4))))
+ (done-with-fast-read-byte)
+ (write-wordindexed des sb!vm:long-float-value-slot exp-bits)
+ (write-wordindexed des (1+ sb!vm:long-float-value-slot) high-bits)
+ (write-wordindexed des (+ 2 sb!vm:long-float-value-slot) mid-bits)
+ (write-wordindexed des (+ 3 sb!vm:long-float-value-slot) low-bits)
+ des)))))
+
+#!+long-float
+(define-cold-fop (fop-complex-long-float)
+ (ecase sb!c:*backend-fasl-file-implementation*
+ (:x86 ; 80 bit long-float format
+ (prepare-for-fast-read-byte *fasl-file*
+ (let* ((des (allocate-unboxed-object *dynamic* sb!vm:word-bits
+ (1- sb!vm:complex-long-float-size)
+ sb!vm:complex-long-float-type))
+ (real-low-bits (make-random-descriptor (fast-read-u-integer 4)))
+ (real-high-bits (make-random-descriptor (fast-read-u-integer 4)))
+ (real-exp-bits (make-random-descriptor (fast-read-s-integer 2)))
+ (imag-low-bits (make-random-descriptor (fast-read-u-integer 4)))
+ (imag-high-bits (make-random-descriptor (fast-read-u-integer 4)))
+ (imag-exp-bits (make-random-descriptor (fast-read-s-integer 2))))
+ (done-with-fast-read-byte)
+ (write-wordindexed des
+ sb!vm:complex-long-float-real-slot
+ real-low-bits)
+ (write-wordindexed des
+ (1+ sb!vm:complex-long-float-real-slot)
+ real-high-bits)
+ (write-wordindexed des
+ (+ 2 sb!vm:complex-long-float-real-slot)
+ real-exp-bits)
+ (write-wordindexed des
+ sb!vm:complex-long-float-imag-slot
+ imag-low-bits)
+ (write-wordindexed des
+ (1+ sb!vm:complex-long-float-imag-slot)
+ imag-high-bits)
+ (write-wordindexed des
+ (+ 2 sb!vm:complex-long-float-imag-slot)
+ imag-exp-bits)
+ des)))
+ ;; This was supported in CMU CL, but isn't currently supported in SBCL.
+ #+nil
+ (#.sb!c:sparc-fasl-file-implementation ; 128 bit long-float format
+ (prepare-for-fast-read-byte *fasl-file*
+ (let* ((des (allocate-unboxed-object *dynamic* sb!vm:word-bits
+ (1- sb!vm:complex-long-float-size)
+ sb!vm:complex-long-float-type))
+ (real-low-bits (make-random-descriptor (fast-read-u-integer 4)))
+ (real-mid-bits (make-random-descriptor (fast-read-u-integer 4)))
+ (real-high-bits (make-random-descriptor (fast-read-u-integer 4)))
+ (real-exp-bits (make-random-descriptor (fast-read-s-integer 4)))
+ (imag-low-bits (make-random-descriptor (fast-read-u-integer 4)))
+ (imag-mid-bits (make-random-descriptor (fast-read-u-integer 4)))
+ (imag-high-bits (make-random-descriptor (fast-read-u-integer 4)))
+ (imag-exp-bits (make-random-descriptor (fast-read-s-integer 4))))
+ (done-with-fast-read-byte)
+ (write-wordindexed des
+ sb!vm:complex-long-float-real-slot
+ real-exp-bits)
+ (write-wordindexed des
+ (1+ sb!vm:complex-long-float-real-slot)
+ real-high-bits)
+ (write-wordindexed des
+ (+ 2 sb!vm:complex-long-float-real-slot)
+ real-mid-bits)
+ (write-wordindexed des
+ (+ 3 sb!vm:complex-long-float-real-slot)
+ real-low-bits)
+ (write-wordindexed des
+ sb!vm:complex-long-float-real-slot
+ imag-exp-bits)
+ (write-wordindexed des
+ (1+ sb!vm:complex-long-float-real-slot)
+ imag-high-bits)
+ (write-wordindexed des
+ (+ 2 sb!vm:complex-long-float-real-slot)
+ imag-mid-bits)
+ (write-wordindexed des
+ (+ 3 sb!vm:complex-long-float-real-slot)
+ imag-low-bits)
+ des)))))
+
+(define-cold-fop (fop-ratio)
+ (let ((den (pop-stack)))
+ (number-pair-to-core (pop-stack) den sb!vm:ratio-type)))
+
+(define-cold-fop (fop-complex)
+ (let ((im (pop-stack)))
+ (number-pair-to-core (pop-stack) im sb!vm:complex-type)))
+\f
+;;;; cold fops for calling (or not calling)
+
+(not-cold-fop fop-eval)
+(not-cold-fop fop-eval-for-effect)
+
+(defvar *load-time-value-counter*)
+
+(define-cold-fop (fop-funcall)
+ (unless (= (read-arg 1) 0)
+ (error "You can't FOP-FUNCALL arbitrary stuff in cold load."))
+ (let ((counter *load-time-value-counter*))
+ (cold-push (cold-cons
+ (cold-intern :load-time-value)
+ (cold-cons
+ (pop-stack)
+ (cold-cons
+ (number-to-core counter)
+ *nil-descriptor*)))
+ *current-reversed-cold-toplevels*)
+ (setf *load-time-value-counter* (1+ counter))
+ (make-descriptor 0 0 nil counter)))
+
+(defun finalize-load-time-value-noise ()
+ (cold-set (cold-intern 'sb!impl::*!load-time-values*)
+ (allocate-vector-object *dynamic*
+ sb!vm:word-bits
+ *load-time-value-counter*
+ sb!vm:simple-vector-type)))
+
+(define-cold-fop (fop-funcall-for-effect nil)
+ (if (= (read-arg 1) 0)
+ (cold-push (pop-stack)
+ *current-reversed-cold-toplevels*)
+ (error "You can't FOP-FUNCALL arbitrary stuff in cold load.")))
+\f
+;;;; cold fops for fixing up circularities
+
+(define-cold-fop (fop-rplaca nil)
+ (let ((obj (svref *current-fop-table* (read-arg 4)))
+ (idx (read-arg 4)))
+ (write-memory (cold-nthcdr idx obj) (pop-stack))))
+
+(define-cold-fop (fop-rplacd nil)
+ (let ((obj (svref *current-fop-table* (read-arg 4)))
+ (idx (read-arg 4)))
+ (write-wordindexed (cold-nthcdr idx obj) 1 (pop-stack))))
+
+(define-cold-fop (fop-svset nil)
+ (let ((obj (svref *current-fop-table* (read-arg 4)))
+ (idx (read-arg 4)))
+ (write-wordindexed obj
+ (+ idx
+ (ecase (descriptor-lowtag obj)
+ (#.sb!vm:instance-pointer-type 1)
+ (#.sb!vm:other-pointer-type 2)))
+ (pop-stack))))
+
+(define-cold-fop (fop-structset nil)
+ (let ((obj (svref *current-fop-table* (read-arg 4)))
+ (idx (read-arg 4)))
+ (write-wordindexed obj (1+ idx) (pop-stack))))
+
+(define-cold-fop (fop-nthcdr t)
+ (cold-nthcdr (read-arg 4) (pop-stack)))
+
+(defun cold-nthcdr (index obj)
+ (dotimes (i index)
+ (setq obj (read-wordindexed obj 1)))
+ obj)
+\f
+;;;; cold fops for loading code objects and functions
+
+(define-cold-fop (fop-fset nil)
+ (let ((fn (pop-stack))
+ (name (pop-stack)))
+ (cold-fset name fn)))
+
+(define-cold-fop (fop-fdefinition)
+ (cold-fdefinition-object (pop-stack)))
+
+(define-cold-fop (fop-sanctify-for-execution)
+ (pop-stack))
+
+(not-cold-fop fop-make-byte-compiled-function)
+
+;;; Setting this variable shows what code looks like before any
+;;; fixups (or function headers) are applied.
+#!+sb-show (defvar *show-pre-fixup-code-p* nil)
+
+;;; FIXME: The logic here should be converted into a function
+;;; COLD-CODE-FOP-GUTS (NCONST CODE-SIZE) called by DEFINE-COLD-FOP
+;;; FOP-CODE and DEFINE-COLD-FOP FOP-SMALL-CODE, so that
+;;; variable-capture nastiness like (LET ((NCONST ,NCONST) ..) ..)
+;;; doesn't keep me awake at night.
+(defmacro define-cold-code-fop (name nconst code-size)
+ `(define-cold-fop (,name)
+ (let* ((nconst ,nconst)
+ (code-size ,code-size)
+ (raw-header-n-words (+ sb!vm:code-trace-table-offset-slot nconst))
+ (header-n-words
+ ;; Note: we round the number of constants up to ensure
+ ;; that the code vector will be properly aligned.
+ (round-up raw-header-n-words 2))
+ (des (allocate-descriptor
+ ;; In the X86 with CGC, code can't be relocated, so
+ ;; we have to put it into static space. In all other
+ ;; configurations, code can go into dynamic space.
+ #!+(and x86 cgc) *static* ; KLUDGE: Why? -- WHN 19990907
+ #!-(and x86 cgc) *dynamic*
+ (+ (ash header-n-words sb!vm:word-shift) code-size)
+ sb!vm:other-pointer-type)))
+ (write-memory des
+ (make-other-immediate-descriptor header-n-words
+ sb!vm:code-header-type))
+ (write-wordindexed des
+ sb!vm:code-code-size-slot
+ (make-fixnum-descriptor
+ (ash (+ code-size (1- (ash 1 sb!vm:word-shift)))
+ (- sb!vm:word-shift))))
+ (write-wordindexed des sb!vm:code-entry-points-slot *nil-descriptor*)
+ (write-wordindexed des sb!vm:code-debug-info-slot (pop-stack))
+ (when (oddp raw-header-n-words)
+ (write-wordindexed des
+ raw-header-n-words
+ (make-random-descriptor 0)))
+ (do ((index (1- raw-header-n-words) (1- index)))
+ ((< index sb!vm:code-trace-table-offset-slot))
+ (write-wordindexed des index (pop-stack)))
+ (let* ((start (+ (descriptor-byte-offset des)
+ (ash header-n-words sb!vm:word-shift)))
+ (end (+ start code-size)))
+ (read-sequence-or-die (descriptor-bytes des)
+ *fasl-file*
+ :start start
+ :end end)
+ #!+sb-show
+ (when *show-pre-fixup-code-p*
+ (format *trace-output*
+ "~&/raw code from code-fop ~D ~D:~%"
+ nconst
+ code-size)
+ (do ((i start (+ i sb!vm:word-bytes)))
+ ((>= i end))
+ (format *trace-output*
+ "/#X~8,'0x: #X~8,'0x~%"
+ (+ i (gspace-byte-address (descriptor-gspace des)))
+ (byte-vector-ref-32 (descriptor-bytes des) i)))))
+ des)))
+
+(define-cold-code-fop fop-code (read-arg 4) (read-arg 4))
+
+(define-cold-code-fop fop-small-code (read-arg 1) (read-arg 2))
+
+(clone-cold-fop (fop-alter-code nil)
+ (fop-byte-alter-code)
+ (let ((slot (clone-arg))
+ (value (pop-stack))
+ (code (pop-stack)))
+ (write-wordindexed code slot value)))
+
+(define-cold-fop (fop-function-entry)
+ (let* ((type (pop-stack))
+ (arglist (pop-stack))
+ (name (pop-stack))
+ (code-object (pop-stack))
+ (offset (calc-offset code-object (read-arg 4)))
+ (fn (descriptor-beyond code-object
+ offset
+ sb!vm:function-pointer-type))
+ (next (read-wordindexed code-object sb!vm:code-entry-points-slot)))
+ (unless (zerop (logand offset sb!vm:lowtag-mask))
+ ;; FIXME: This should probably become a fatal error.
+ (warn "unaligned function entry: ~S at #X~X" name offset))
+ (write-wordindexed code-object sb!vm:code-entry-points-slot fn)
+ (write-memory fn
+ (make-other-immediate-descriptor (ash offset
+ (- sb!vm:word-shift))
+ sb!vm:function-header-type))
+ (write-wordindexed fn
+ sb!vm:function-self-slot
+ ;; KLUDGE: Wiring decisions like this in at
+ ;; this level ("if it's an x86") instead of a
+ ;; higher level of abstraction ("if it has such
+ ;; and such relocation peculiarities (which
+ ;; happen to be confined to the x86)") is bad.
+ ;; It would be nice if the code were instead
+ ;; conditional on some more descriptive
+ ;; feature, :STICKY-CODE or
+ ;; :LOAD-GC-INTERACTION or something.
+ ;;
+ ;; FIXME: The X86 definition of the function
+ ;; self slot breaks everything object.tex says
+ ;; about it. (As far as I can tell, the X86
+ ;; definition makes it a pointer to the actual
+ ;; code instead of a pointer back to the object
+ ;; itself.) Ask on the mailing list whether
+ ;; this is documented somewhere, and if not,
+ ;; try to reverse engineer some documentation
+ ;; before release.
+ #!-x86
+ ;; a pointer back to the function object, as
+ ;; described in CMU CL
+ ;; src/docs/internals/object.tex
+ fn
+ #!+x86
+ ;; KLUDGE: a pointer to the actual code of the
+ ;; object, as described nowhere that I can find
+ ;; -- WHN 19990907
+ (make-random-descriptor
+ (+ (descriptor-bits fn)
+ (- (ash sb!vm:function-code-offset sb!vm:word-shift)
+ ;; FIXME: We should mask out the type
+ ;; bits, not assume we know what they
+ ;; are and subtract them out this way.
+ sb!vm:function-pointer-type))))
+ (write-wordindexed fn sb!vm:function-next-slot next)
+ (write-wordindexed fn sb!vm:function-name-slot name)
+ (write-wordindexed fn sb!vm:function-arglist-slot arglist)
+ (write-wordindexed fn sb!vm:function-type-slot type)
+ fn))
+
+(define-cold-fop (fop-foreign-fixup)
+ (let* ((kind (pop-stack))
+ (code-object (pop-stack))
+ (len (read-arg 1))
+ (sym (make-string len)))
+ (read-string-as-bytes *fasl-file* sym)
+ (let ((offset (read-arg 4))
+ (value (lookup-foreign-symbol sym)))
+ (do-cold-fixup code-object offset value kind))
+ code-object))
+
+(define-cold-fop (fop-assembler-code)
+ (let* ((length (read-arg 4))
+ (header-n-words
+ ;; Note: we round the number of constants up to ensure that
+ ;; the code vector will be properly aligned.
+ (round-up sb!vm:code-constants-offset 2))
+ (des (allocate-descriptor *read-only*
+ (+ (ash header-n-words sb!vm:word-shift)
+ length)
+ sb!vm:other-pointer-type)))
+ (write-memory des
+ (make-other-immediate-descriptor header-n-words
+ sb!vm:code-header-type))
+ (write-wordindexed des
+ sb!vm:code-code-size-slot
+ (make-fixnum-descriptor
+ (ash (+ length (1- (ash 1 sb!vm:word-shift)))
+ (- sb!vm:word-shift))))
+ (write-wordindexed des sb!vm:code-entry-points-slot *nil-descriptor*)
+ (write-wordindexed des sb!vm:code-debug-info-slot *nil-descriptor*)
+
+ (let* ((start (+ (descriptor-byte-offset des)
+ (ash header-n-words sb!vm:word-shift)))
+ (end (+ start length)))
+ (read-sequence-or-die (descriptor-bytes des)
+ *fasl-file*
+ :start start
+ :end end))
+ des))
+
+(define-cold-fop (fop-assembler-routine)
+ (let* ((routine (pop-stack))
+ (des (pop-stack))
+ (offset (calc-offset des (read-arg 4))))
+ (record-cold-assembler-routine
+ routine
+ (+ (logandc2 (descriptor-bits des) sb!vm:lowtag-mask) offset))
+ des))
+
+(define-cold-fop (fop-assembler-fixup)
+ (let* ((routine (pop-stack))
+ (kind (pop-stack))
+ (code-object (pop-stack))
+ (offset (read-arg 4)))
+ (record-cold-assembler-fixup routine code-object offset kind)
+ code-object))
+
+(define-cold-fop (fop-code-object-fixup)
+ (let* ((kind (pop-stack))
+ (code-object (pop-stack))
+ (offset (read-arg 4))
+ (value (descriptor-bits code-object)))
+ (do-cold-fixup code-object offset value kind)
+ code-object))
+\f
+;;;; emitting C header file
+
+(defun tail-comp (string tail)
+ (and (>= (length string) (length tail))
+ (string= string tail :start1 (- (length string) (length tail)))))
+
+(defun head-comp (string head)
+ (and (>= (length string) (length head))
+ (string= string head :end1 (length head))))
+
+(defun write-c-header ()
+
+ (format t "/*~%")
+ (dolist (line
+ '("This is a machine-generated file. Do not edit it by hand."
+ ""
+ "This file contains low-level information about the"
+ "internals of a particular version and configuration"
+ "of SBCL. It is used by the C compiler to create a runtime"
+ "support environment, an executable program in the host"
+ "operating system's native format, which can then be used to"
+ "load and run 'core' files, which are basically programs"
+ "in SBCL's own format."))
+ (format t " * ~A~%" line))
+ (format t " */~%")
+ (terpri)
+
+ (format t "#ifndef _SBCL_H_~%#define _SBCL_H_~%")
+ (terpri)
+
+ (format t "#define SBCL_CORE_VERSION_INTEGER ~D~%" sbcl-core-version-integer)
+ (format t
+ "#define SBCL_VERSION_STRING ~S~%"
+ (sb!xc:lisp-implementation-version))
+ (format t "#define CORE_MAGIC 0x~X~%" core-magic)
+ (terpri)
+
+ ;; FIXME: Other things from core.h should be defined here too:
+ ;; #define CORE_END 3840
+ ;; #define CORE_NDIRECTORY 3861
+ ;; #define CORE_VALIDATE 3845
+ ;; #define CORE_VERSION 3860
+ ;; #define CORE_MACHINE_STATE 3862
+ ;; (Except that some of them are obsolete and should be deleted instead.)
+ ;; also
+ ;; #define DYNAMIC_SPACE_ID (1)
+ ;; #define STATIC_SPACE_ID (2)
+ ;; #define READ_ONLY_SPACE_ID (3)
+
+ (let ((constants nil))
+ (do-external-symbols (symbol (find-package "SB!VM"))
+ (when (constantp symbol)
+ (let ((name (symbol-name symbol)))
+ (labels
+ ((record (prefix string priority)
+ (push (list (concatenate
+ 'simple-string
+ prefix
+ (delete #\- (string-capitalize string)))
+ priority
+ (symbol-value symbol)
+ (fdocumentation symbol 'variable))
+ constants))
+ (test-tail (tail prefix priority)
+ (when (tail-comp name tail)
+ (record prefix
+ (subseq name 0
+ (- (length name)
+ (length tail)))
+ priority)))
+ (test-head (head prefix priority)
+ (when (head-comp name head)
+ (record prefix
+ (subseq name (length head))
+ priority))))
+ (test-tail "-TYPE" "type_" 0)
+ (test-tail "-FLAG" "flag_" 1)
+ (test-tail "-TRAP" "trap_" 2)
+ (test-tail "-SUBTYPE" "subtype_" 3)
+ (test-head "TRACE-TABLE-" "tracetab_" 4)
+ (test-tail "-SC-NUMBER" "sc_" 5)))))
+ (setf constants
+ (sort constants
+ #'(lambda (const1 const2)
+ (if (= (second const1) (second const2))
+ (< (third const1) (third const2))
+ (< (second const1) (second const2))))))
+ (let ((prev-priority (second (car constants))))
+ (dolist (const constants)
+ (unless (= prev-priority (second const))
+ (terpri)
+ (setf prev-priority (second const)))
+ (format t
+ "#define ~A ~D /* 0x~X */~@[ /* ~A */~]~%"
+ (first const)
+ (third const)
+ (third const)
+ (fourth const))))
+ (terpri)
+ (format t "#define ERRORS { \\~%")
+ ;; FIXME: Is this just DO-VECTOR?
+ (let ((internal-errors sb!c:*backend-internal-errors*))
+ (dotimes (i (length internal-errors))
+ (format t " ~S, /*~D*/ \\~%" (cdr (aref internal-errors i)) i)))
+ (format t " NULL \\~%}~%")
+ (terpri))
+ (let ((structs (sort (copy-list sb!vm:*primitive-objects*) #'string<
+ :key #'(lambda (obj)
+ (symbol-name
+ (sb!vm:primitive-object-name obj))))))
+ (format t "#ifndef LANGUAGE_ASSEMBLY~2%")
+ (format t "#define LISPOBJ(x) ((lispobj)x)~2%")
+ (dolist (obj structs)
+ (format t
+ "struct ~A {~%"
+ (nsubstitute #\_ #\-
+ (string-downcase (string (sb!vm:primitive-object-name obj)))))
+ (when (sb!vm:primitive-object-header obj)
+ (format t " lispobj header;~%"))
+ (dolist (slot (sb!vm:primitive-object-slots obj))
+ (format t " ~A ~A~@[[1]~];~%"
+ (getf (sb!vm:slot-options slot) :c-type "lispobj")
+ (nsubstitute #\_ #\-
+ (string-downcase (string (sb!vm:slot-name slot))))
+ (sb!vm:slot-rest-p slot)))
+ (format t "};~2%"))
+ (format t "#else /* LANGUAGE_ASSEMBLY */~2%")
+ (format t "#define LISPOBJ(thing) thing~2%")
+ (dolist (obj structs)
+ (let ((name (sb!vm:primitive-object-name obj))
+ (lowtag (eval (sb!vm:primitive-object-lowtag obj))))
+ (when lowtag
+ (dolist (slot (sb!vm:primitive-object-slots obj))
+ (format t "#define ~A_~A_OFFSET ~D~%"
+ (substitute #\_ #\- (string name))
+ (substitute #\_ #\- (string (sb!vm:slot-name slot)))
+ (- (* (sb!vm:slot-offset slot) sb!vm:word-bytes) lowtag)))
+ (terpri))))
+ (format t "#endif /* LANGUAGE_ASSEMBLY */~2%"))
+ (dolist (symbol (cons nil sb!vm:*static-symbols*))
+ ;; FIXME: It would be nice to use longer names NIL and (particularly) T
+ ;; in #define statements.
+ (format t "#define ~A LISPOBJ(0x~X)~%"
+ (nsubstitute #\_ #\-
+ (remove-if #'(lambda (char)
+ (member char '(#\% #\* #\. #\!)))
+ (symbol-name symbol)))
+ (if *static* ; if we ran GENESIS
+ ;; We actually ran GENESIS, use the real value.
+ (descriptor-bits (cold-intern symbol))
+ ;; We didn't run GENESIS, so guess at the address.
+ (+ sb!vm:*target-static-space-start*
+ sb!vm:word-bytes
+ sb!vm:other-pointer-type
+ (if symbol (sb!vm:static-symbol-offset symbol) 0)))))
+ (format t "~%#endif~%"))
+\f
+;;;; writing map file
+
+;;; Write a map file describing the cold load. Some of this
+;;; information is subject to change due to relocating GC, but even so
+;;; it can be very handy when attempting to troubleshoot the early
+;;; stages of cold load.
+(defun write-map ()
+ (let ((*print-pretty* nil)
+ (*print-case* :upcase))
+ (format t "assembler routines defined in core image:~2%")
+ (dolist (routine (sort (copy-list *cold-assembler-routines*) #'<
+ :key #'cdr))
+ (format t "#X~8,'0X: ~S~%" (cdr routine) (car routine)))
+ (let ((funs nil)
+ (undefs nil))
+ (maphash #'(lambda (name fdefn)
+ (let ((fun (read-wordindexed fdefn
+ sb!vm:fdefn-function-slot)))
+ (if (= (descriptor-bits fun)
+ (descriptor-bits *nil-descriptor*))
+ (push name undefs)
+ (let ((addr (read-wordindexed fdefn
+ sb!vm:fdefn-raw-addr-slot)))
+ (push (cons name (descriptor-bits addr))
+ funs)))))
+ *cold-fdefn-objects*)
+ (format t "~%~|~%initially defined functions:~2%")
+ (dolist (info (sort funs #'< :key #'cdr))
+ (format t "0x~8,'0X: ~S #X~8,'0X~%" (cdr info) (car info)
+ (- (cdr info) #x17)))
+ (format t
+"~%~|
+(a note about initially undefined function references: These functions
+are referred to by code which is installed by GENESIS, but they are not
+installed by GENESIS. This is not necessarily a problem; functions can
+be defined later, by cold init toplevel forms, or in files compiled and
+loaded at warm init, or elsewhere. As long as they are defined before
+they are called, everything should be OK. Things are also OK if the
+cross-compiler knew their inline definition and used that everywhere
+that they were called before the out-of-line definition is installed,
+as is fairly common for structure accessors.)
+initially undefined function references:~2%")
+ (labels ((key (name)
+ (etypecase name
+ (symbol (symbol-name name))
+ ;; FIXME: should use standard SETF-function parsing logic
+ (list (key (second name))))))
+ (dolist (name (sort undefs #'string< :key #'key))
+ (format t "~S" name)
+ ;; FIXME: This ACCESSOR-FOR stuff should go away when the
+ ;; code has stabilized. (It's only here to help me
+ ;; categorize the flood of undefined functions caused by
+ ;; completely rewriting the bootstrap process. Hopefully any
+ ;; future maintainers will mostly have small numbers of
+ ;; undefined functions..)
+ (let ((accessor-for (info :function :accessor-for name)))
+ (when accessor-for
+ (format t " (accessor for ~S)" accessor-for)))
+ (format t "~%")))))
+
+ (format t "~%~|~%layout names:~2%")
+ (collect ((stuff))
+ (maphash #'(lambda (name gorp)
+ (declare (ignore name))
+ (stuff (cons (descriptor-bits (car gorp))
+ (cdr gorp))))
+ *cold-layouts*)
+ (dolist (x (sort (stuff) #'< :key #'car))
+ (apply #'format t "~8,'0X: ~S[~D]~%~10T~S~%" x)))
+
+ (values))
+\f
+;;;; writing core file
+
+(defvar *core-file*)
+(defvar *data-page*)
+
+;;; KLUDGE: These numbers correspond to values in core.h. If they're
+;;; documented anywhere, I haven't found it. (I haven't tried very
+;;; hard yet.) -- WHN 19990826
+(defparameter version-entry-type-code 3860)
+(defparameter validate-entry-type-code 3845)
+(defparameter directory-entry-type-code 3841)
+(defparameter new-directory-entry-type-code 3861)
+(defparameter initial-function-entry-type-code 3863)
+(defparameter end-entry-type-code 3840)
+
+(declaim (ftype (function (sb!vm:word) sb!vm:word) write-long))
+(defun write-long (num) ; FIXME: WRITE-WORD would be a better name.
+ (ecase sb!c:*backend-byte-order*
+ (:little-endian
+ (dotimes (i 4)
+ (write-byte (ldb (byte 8 (* i 8)) num) *core-file*)))
+ (:big-endian
+ (dotimes (i 4)
+ (write-byte (ldb (byte 8 (* (- 3 i) 8)) num) *core-file*))))
+ num)
+
+(defun advance-to-page ()
+ (force-output *core-file*)
+ (file-position *core-file*
+ (round-up (file-position *core-file*)
+ sb!c:*backend-page-size*)))
+
+(defun output-gspace (gspace)
+ (force-output *core-file*)
+ (let* ((posn (file-position *core-file*))
+ (bytes (* (gspace-free-word-index gspace) sb!vm:word-bytes))
+ (pages (ceiling bytes sb!c:*backend-page-size*))
+ (total-bytes (* pages sb!c:*backend-page-size*)))
+
+ (file-position *core-file*
+ (* sb!c:*backend-page-size* (1+ *data-page*)))
+ (format t
+ "writing ~S byte~:P [~S page~:P] from ~S~%"
+ total-bytes
+ pages
+ gspace)
+ (force-output)
+
+ ;; Note: It is assumed that the GSPACE allocation routines always
+ ;; allocate whole pages (of size *target-page-size*) and that any
+ ;; empty gspace between the free pointer and the end of page will
+ ;; be zero-filled. This will always be true under Mach on machines
+ ;; where the page size is equal. (RT is 4K, PMAX is 4K, Sun 3 is
+ ;; 8K).
+ (write-sequence (gspace-bytes gspace) *core-file* :end total-bytes)
+ (force-output *core-file*)
+ (file-position *core-file* posn)
+
+ ;; Write part of a (new) directory entry which looks like this:
+ ;; GSPACE IDENTIFIER
+ ;; WORD COUNT
+ ;; DATA PAGE
+ ;; ADDRESS
+ ;; PAGE COUNT
+ (write-long (gspace-identifier gspace))
+ (write-long (gspace-free-word-index gspace))
+ (write-long *data-page*)
+ (multiple-value-bind (floor rem)
+ (floor (gspace-byte-address gspace) sb!c:*backend-page-size*)
+ ;; FIXME: Define an INSIST macro which does like ASSERT, but
+ ;; less expensively (ERROR, not CERROR), and which reports
+ ;; "internal error" on failure. Use it here and elsewhere in the
+ ;; system.
+ (assert (zerop rem))
+ (write-long floor))
+ (write-long pages)
+
+ (incf *data-page* pages)))
+
+;;; Create a core file created from the cold loaded image. (This is
+;;; the "initial core file" because core files could be created later
+;;; by executing SAVE-LISP in a running system, perhaps after we've
+;;; added some functionality to the system.)
+(declaim (ftype (function (string)) write-initial-core-file))
+(defun write-initial-core-file (filename)
+
+ (let ((filenamestring (namestring filename))
+ (*data-page* 0))
+
+ (format t
+ "[building initial core file in file ~S: ~%"
+ filenamestring)
+ (force-output)
+
+ (with-open-file (*core-file* filenamestring
+ :direction :output
+ :element-type '(unsigned-byte 8)
+ :if-exists :rename-and-delete)
+
+ ;; Write the magic number.
+ (write-long core-magic)
+
+ ;; Write the Version entry.
+ (write-long version-entry-type-code)
+ (write-long 3)
+ (write-long sbcl-core-version-integer)
+
+ ;; Write the New Directory entry header.
+ (write-long new-directory-entry-type-code)
+ (write-long 17) ; length = (5 words/space) * 3 spaces + 2 for header.
+
+ (output-gspace *read-only*)
+ (output-gspace *static*)
+ (output-gspace *dynamic*)
+
+ ;; Write the initial function.
+ (write-long initial-function-entry-type-code)
+ (write-long 3)
+ (let* ((cold-name (cold-intern '!cold-init))
+ (cold-fdefn (cold-fdefinition-object cold-name))
+ (initial-function (read-wordindexed cold-fdefn
+ sb!vm:fdefn-function-slot)))
+ (format t
+ "~&/(DESCRIPTOR-BITS INITIAL-FUNCTION)=#X~X~%"
+ (descriptor-bits initial-function))
+ (write-long (descriptor-bits initial-function)))
+
+ ;; Write the End entry.
+ (write-long end-entry-type-code)
+ (write-long 2)))
+
+ (format t "done]~%")
+ (force-output)
+ (/show "leaving WRITE-INITIAL-CORE-FILE")
+ (values))
+\f
+;;;; the actual GENESIS function
+
+;;; Read the FASL files in OBJECT-FILE-NAMES and produce a Lisp core,
+;;; and/or information about a Lisp core, therefrom.
+;;;
+;;; input file arguments:
+;;; SYMBOL-TABLE-FILE-NAME names a UNIX-style .nm file *with* *any*
+;;; *tab* *characters* *converted* *to* *spaces*. (We push
+;;; responsibility for removing tabs out to the caller it's
+;;; trivial to remove them using UNIX command line tools like
+;;; sed, whereas it's a headache to do it portably in Lisp because
+;;; #\TAB is not a STANDARD-CHAR.) If this file is not supplied,
+;;; a core file cannot be built (but a C header file can be).
+;;;
+;;; output files arguments (any of which may be NIL to suppress output):
+;;; CORE-FILE-NAME gets a Lisp core.
+;;; C-HEADER-FILE-NAME gets a C header file, traditionally called
+;;; internals.h, which is used by the C compiler when constructing
+;;; the executable which will load the core.
+;;; MAP-FILE-NAME gets (?) a map file. (dunno about this -- WHN 19990815)
+;;;
+;;; other arguments:
+;;; BYTE-ORDER-SWAP-P controls whether GENESIS tries to swap bytes
+;;; in some places in the output. It's only appropriate when
+;;; cross-compiling from a machine with one byte order to a
+;;; machine with the opposite byte order, which is irrelevant in
+;;; current (19990816) SBCL, since only the X86 architecture is
+;;; supported. If you're trying to add support for more
+;;; architectures, see the comments on DEFVAR
+;;; *GENESIS-BYTE-ORDER-SWAP-P* for more information.
+;;;
+;;; FIXME: GENESIS doesn't belong in SB!VM. Perhaps in %KERNEL for now,
+;;; perhaps eventually in SB-LD or SB-BOOT.
+(defun sb!vm:genesis (&key
+ object-file-names
+ symbol-table-file-name
+ core-file-name
+ map-file-name
+ c-header-file-name
+ byte-order-swap-p)
+
+ (when (and core-file-name
+ (not symbol-table-file-name))
+ (error "can't output a core file without symbol table file input"))
+
+ (format t
+ "~&beginning GENESIS, ~A~%"
+ (if core-file-name
+ ;; Note: This output summarizing what we're doing is
+ ;; somewhat telegraphic in style, not meant to imply that
+ ;; we're not e.g. also creating a header file when we
+ ;; create a core.
+ (format nil "creating core ~S" core-file-name)
+ (format nil "creating header ~S" c-header-file-name)))
+
+ (let* ((*cold-foreign-symbol-table* (make-hash-table :test 'equal)))
+
+ ;; Read symbol table, if any.
+ (when symbol-table-file-name
+ (load-foreign-symbol-table symbol-table-file-name))
+
+ ;; Now that we've successfully read our only input file (by
+ ;; loading the symbol table, if any), it's a good time to ensure
+ ;; that there'll be someplace for our output files to go when
+ ;; we're done.
+ (flet ((frob (filename)
+ (when filename
+ (ensure-directories-exist filename :verbose t))))
+ (frob core-file-name)
+ (frob map-file-name)
+ (frob c-header-file-name))
+
+ ;; (This shouldn't matter in normal use, since GENESIS normally
+ ;; only runs once in any given Lisp image, but it could reduce
+ ;; confusion if we ever experiment with running, tweaking, and
+ ;; rerunning genesis interactively.)
+ (do-all-symbols (sym)
+ (remprop sym 'cold-intern-info))
+
+ (let* ((*foreign-symbol-placeholder-value* (if core-file-name nil 0))
+ (*load-time-value-counter* 0)
+ (*genesis-byte-order-swap-p* byte-order-swap-p)
+ (*cold-fdefn-objects* (make-hash-table :test 'equal))
+ (*cold-symbols* (make-hash-table :test 'equal))
+ (*cold-package-symbols* nil)
+ (*read-only* (make-gspace :read-only
+ read-only-space-id
+ sb!vm:*target-read-only-space-start*))
+ (*static* (make-gspace :static
+ static-space-id
+ sb!vm:*target-static-space-start*))
+ (*dynamic* (make-gspace :dynamic
+ dynamic-space-id
+ sb!vm:*target-dynamic-space-start*))
+ (*nil-descriptor* (make-nil-descriptor))
+ (*current-reversed-cold-toplevels* *nil-descriptor*)
+ (*unbound-marker* (make-other-immediate-descriptor
+ 0
+ sb!vm:unbound-marker-type))
+ *cold-assembler-fixups*
+ *cold-assembler-routines*
+ #!+x86 *load-time-code-fixups*)
+
+ ;; Prepare for cold load.
+ (initialize-non-nil-symbols)
+ (initialize-layouts)
+ (initialize-static-fns)
+
+ ;; Initialize the *COLD-SYMBOLS* system with the information
+ ;; from package-data-list.lisp-expr and
+ ;; common-lisp-exports.lisp-expr.
+ ;;
+ ;; Why do things this way? Historically, the *COLD-SYMBOLS*
+ ;; machinery was designed and implemented in CMU CL long before
+ ;; I (WHN) ever heard of CMU CL. It dumped symbols and packages
+ ;; iff they were used in the cold image. When I added the
+ ;; package-data-list.lisp-expr mechanism, the idea was to
+ ;; centralize all information about packages and exports. Thus,
+ ;; it was the natural place for information even about packages
+ ;; (such as SB!PCL and SB!WALKER) which aren't used much until
+ ;; after cold load. This didn't quite match the CMU CL approach
+ ;; of filling *COLD-SYMBOLS* with symbols which appear in the
+ ;; cold image and then dumping only those symbols. By explicitly
+ ;; putting all the symbols from package-data-list.lisp-expr and
+ ;; from common-lisp-exports.lisp-expr into *COLD-SYMBOLS* here,
+ ;; we feed our centralized symbol information into the old CMU
+ ;; CL code without having to change the old CMU CL code too
+ ;; much. (And the old CMU CL code is still useful for making
+ ;; sure that the appropriate keywords and internal symbols end
+ ;; up interned in the target Lisp, which is good, e.g. in order
+ ;; to make keyword arguments work right and in order to make
+ ;; BACKTRACEs into target Lisp system code be legible.)
+ (dolist (exported-name
+ (sb-cold:read-from-file "common-lisp-exports.lisp-expr"))
+ (cold-intern (intern exported-name *cl-package*)))
+ (dolist (pd (sb-cold:read-from-file "package-data-list.lisp-expr"))
+ (declare (type sb-cold:package-data pd))
+ (let ((package (find-package (sb-cold:package-data-name pd))))
+ (labels (;; Call FN on every node of the TREE.
+ (mapc-on-tree (fn tree)
+ (typecase tree
+ (cons (mapc-on-tree fn (car tree))
+ (mapc-on-tree fn (cdr tree)))
+ (t (funcall fn tree)
+ (values))))
+ ;; Make sure that information about the association
+ ;; between PACKAGE and the symbol named NAME gets
+ ;; recorded in the cold-intern system or (as a
+ ;; convenience when dealing with the tree structure
+ ;; allowed in the PACKAGE-DATA-EXPORTS slot) do
+ ;; nothing if NAME is NIL.
+ (chill (name)
+ (when name
+ (cold-intern (intern name package) package))))
+ (mapc-on-tree #'chill (sb-cold:package-data-export pd))
+ (mapc #'chill (sb-cold:package-data-reexport pd))
+ (dolist (sublist (sb-cold:package-data-import-from pd))
+ (destructuring-bind (package-name &rest symbol-names) sublist
+ (declare (ignore package-name))
+ (mapc #'chill symbol-names))))))
+
+ ;; Cold load.
+ (dolist (file-name object-file-names)
+ (write-line (namestring file-name))
+ (cold-load file-name))
+
+ ;; Tidy up loose ends left by cold loading. ("Postpare from cold load?")
+ (resolve-assembler-fixups)
+ #!+x86 (output-load-time-code-fixups)
+ (linkage-info-to-core)
+ (finish-symbols)
+ (/show "back from FINISH-SYMBOLS")
+ (finalize-load-time-value-noise)
+
+ ;; Tell the target Lisp how much stuff we've allocated.
+ (cold-set '*read-only-space-free-pointer*
+ (allocate-descriptor *read-only* 0 sb!vm:even-fixnum-type))
+ (cold-set '*static-space-free-pointer*
+ (allocate-descriptor *static* 0 sb!vm:even-fixnum-type))
+ (cold-set '*initial-dynamic-space-free-pointer*
+ (allocate-descriptor *dynamic* 0 sb!vm:even-fixnum-type))
+ (/show "done setting free pointers")
+
+ ;; Write results to files.
+ ;;
+ ;; FIXME: I dislike this approach of redefining
+ ;; *STANDARD-OUTPUT* instead of putting the new stream in a
+ ;; lexical variable, and it's annoying to have WRITE-MAP (to
+ ;; *STANDARD-OUTPUT*) not be parallel to WRITE-INITIAL-CORE-FILE
+ ;; (to a stream explicitly passed as an argument).
+ (when map-file-name
+ (with-open-file (*standard-output* map-file-name
+ :direction :output
+ :if-exists :supersede)
+ (write-map)))
+ (when c-header-file-name
+ (with-open-file (*standard-output* c-header-file-name
+ :direction :output
+ :if-exists :supersede)
+ (write-c-header)))
+ (when core-file-name
+ (write-initial-core-file core-file-name)))))
--- /dev/null
+;;;; This file defines all of the internal errors. How they are
+;;;; handled is defined in .../code/interr.lisp. How they are signaled
+;;;; depends on the machine.
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!KERNEL")
+
+(file-comment
+ "$Header$")
+
+(defun error-number-or-lose (name)
+ (or (position name sb!c:*backend-internal-errors* :key #'car)
+ (error "unknown internal error: ~S" name)))
+
+;;; FIXME: Having each of these error handlers be a full, named function
+;;; seems to contribute a noticeable amount of bloat and little value.
+;;; Perhaps we could just make a single error-handling function with a
+;;; big CASE statement inside it?
+(eval-when (:compile-toplevel :execute)
+ (def!macro define-internal-errors (&rest errors)
+ (let ((info (mapcar #'(lambda (x)
+ (if x
+ (cons (symbolicate (first x) "-ERROR")
+ (second x))
+ '(nil . "unused")))
+ errors)))
+ `(progn
+ (setf sb!c:*backend-internal-errors*
+ ',(coerce info 'vector))
+ nil))))
+
+(define-internal-errors
+ (unknown
+ "unknown system lossage")
+ (object-not-function
+ "Object is not of type FUNCTION.")
+ (object-not-list
+ "Object is not of type LIST.")
+ (object-not-bignum
+ "Object is not of type BIGNUM.")
+ (object-not-ratio
+ "Object is not of type RATIO.")
+ (object-not-single-float
+ "Object is not of type SINGLE-FLOAT.")
+ (object-not-double-float
+ "Object is not of type DOUBLE-FLOAT.")
+ #!+long-float
+ (object-not-long-float
+ "Object is not of type LONG-FLOAT.")
+ (object-not-simple-string
+ "Object is not of type SIMPLE-STRING.")
+ (object-not-simple-bit-vector
+ "Object is not of type SIMPLE-BIT-VECTOR.")
+ (object-not-simple-vector
+ "Object is not of type SIMPLE-VECTOR.")
+ (object-not-fixnum
+ "Object is not of type FIXNUM.")
+ (object-not-function-or-symbol
+ "Object is not of type FUNCTION or SYMBOL.")
+ (object-not-vector
+ "Object is not of type VECTOR.")
+ (object-not-string
+ "Object is not of type STRING.")
+ (object-not-bit-vector
+ "Object is not of type BIT-VECTOR.")
+ (object-not-array
+ "Object is not of type ARRAY.")
+ (object-not-number
+ "Object is not of type NUMBER.")
+ (object-not-rational
+ "Object is not of type RATIONAL.")
+ (object-not-float
+ "Object is not of type FLOAT.")
+ (object-not-real
+ "Object is not of type REAL.")
+ (object-not-integer
+ "Object is not of type INTEGER.")
+ (object-not-cons
+ "Object is not of type CONS.")
+ (object-not-symbol
+ "Object is not of type SYMBOL.")
+ (undefined-symbol
+ ;; FIXME: Isn't this used for calls to unbound (SETF FOO) too? If so, revise
+ ;; the name.
+ "An attempt was made to use an undefined FDEFINITION.")
+ (object-not-coerceable-to-function
+ "Object is not coerceable to type FUNCTION.")
+ (invalid-argument-count
+ "invalid argument count")
+ (bogus-argument-to-values-list
+ "bogus argument to VALUES-LIST")
+ (unbound-symbol
+ "An attempt was made to use an undefined SYMBOL-VALUE.")
+ ;; FIXME: We shouldn't need these placeholder NIL entries any more
+ ;; now that we pass our magic numbers cleanly through sbcl.h.
+ nil
+ (object-not-sap
+ "Object is not a System Area Pointer (SAP).")
+ (invalid-unwind
+ "attempt to RETURN-FROM a block that no longer exists")
+ (unseen-throw-tag
+ "attempt to THROW to a non-existent tag")
+ (division-by-zero
+ "division by zero")
+ (object-not-type
+ "Object is of the wrong type.")
+ (odd-keyword-arguments
+ "odd number of keyword arguments")
+ (unknown-keyword-argument
+ "unknown keyword")
+ nil
+ nil
+ (invalid-array-index
+ "invalid array index")
+ (wrong-number-of-indices
+ "wrong number of indices")
+ (object-not-simple-array
+ "Object is not of type SIMPLE-ARRAY.")
+ (object-not-signed-byte-32
+ "Object is not of type (SIGNED-BYTE 32).")
+ (object-not-unsigned-byte-32
+ "Object is not of type (UNSIGNED-BYTE 32).")
+ (object-not-simple-array-unsigned-byte-2
+ "Object is not of type (SIMPLE-ARRAY (UNSIGNED-BYTE 2) (*)).")
+ (object-not-simple-array-unsigned-byte-4
+ "Object is not of type (SIMPLE-ARRAY (UNSIGNED-BYTE 4) (*)).")
+ (object-not-simple-array-unsigned-byte-8
+ "Object is not of type (SIMPLE-ARRAY (UNSIGNED-BYTE 8) (*)).")
+ (object-not-simple-array-unsigned-byte-16
+ "Object is not of type (SIMPLE-ARRAY (UNSIGNED-BYTE 16) (*)).")
+ (object-not-simple-array-unsigned-byte-32
+ "Object is not of type (SIMPLE-ARRAY (UNSIGNED-BYTE 32) (*)).")
+ (object-not-simple-array-signed-byte-8
+ "Object is not of type (SIMPLE-ARRAY (SIGNED-BYTE 8) (*)).")
+ (object-not-simple-array-signed-byte-16
+ "Object is not of type (SIMPLE-ARRAY (SIGNED-BYTE 16) (*)).")
+ (object-not-simple-array-signed-byte-30
+ "Object is not of type (SIMPLE-ARRAY FIXNUM (*)).")
+ (object-not-simple-array-signed-byte-32
+ "Object is not of type (SIMPLE-ARRAY (SIGNED-BYTE 32) (*)).")
+ (object-not-simple-array-single-float
+ "Object is not of type (SIMPLE-ARRAY SINGLE-FLOAT (*)).")
+ (object-not-simple-array-double-float
+ "Object is not of type (SIMPLE-ARRAY DOUBLE-FLOAT (*)).")
+ #!+long-float
+ (object-not-simple-array-long-float
+ "Object is not of type (SIMPLE-ARRAY LONG-FLOAT (*)).")
+ (object-not-simple-array-complex-single-float
+ "Object is not of type (SIMPLE-ARRAY (COMPLEX SINGLE-FLOAT) (*)).")
+ (object-not-simple-array-complex-double-float
+ "Object is not of type (SIMPLE-ARRAY (COMPLEX DOUBLE-FLOAT) (*)).")
+ #!+long-float
+ (object-not-simple-array-complex-long-float
+ "Object is not of type (SIMPLE-ARRAY (COMPLEX LONG-FLOAT) (*)).")
+ (object-not-complex
+ "Object is not of type COMPLEX.")
+ (object-not-complex-rational
+ "Object is not of type (COMPLEX RATIONAL).")
+ (object-not-complex-float
+ "Object is not of type (COMPLEX FLOAT).")
+ (object-not-complex-single-float
+ "Object is not of type (COMPLEX SINGLE-FLOAT).")
+ (object-not-complex-double-float
+ "Object is not of type (COMPLEX DOUBLE-FLOAT).")
+ #!+long-float
+ (object-not-complex-long-float
+ "Object is not of type (COMPLEX LONG-FLOAT).")
+ (object-not-weak-pointer
+ "Object is not a WEAK-POINTER.")
+ (object-not-instance
+ "Object is not a INSTANCE.")
+ (object-not-base-char
+ "Object is not of type BASE-CHAR.")
+ (nil-function-returned
+ "A function with declared result type NIL returned.")
+ (layout-invalid
+ "invalid layout (indicates obsolete instance)"))
--- /dev/null
+;;;; machine-independent aspects of the object representation
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!VM")
+
+(file-comment
+ "$Header$")
+\f
+;;;; the primitive objects themselves
+
+(define-primitive-object (cons :lowtag list-pointer-type
+ :alloc-trans cons)
+ (car :ref-trans car :set-trans sb!c::%rplaca :init :arg)
+ (cdr :ref-trans cdr :set-trans sb!c::%rplacd :init :arg))
+
+(define-primitive-object (instance :lowtag instance-pointer-type
+ :header instance-header-type
+ :alloc-trans %make-instance)
+ (slots :rest-p t))
+
+(define-primitive-object (bignum :lowtag other-pointer-type
+ :header bignum-type
+ :alloc-trans sb!bignum::%allocate-bignum)
+ (digits :rest-p t :c-type #!-alpha "long" #!+alpha "u32"))
+
+(define-primitive-object (ratio :type ratio
+ :lowtag other-pointer-type
+ :header ratio-type
+ :alloc-trans %make-ratio)
+ (numerator :type integer
+ :ref-known (flushable movable)
+ :ref-trans %numerator
+ :init :arg)
+ (denominator :type integer
+ :ref-known (flushable movable)
+ :ref-trans %denominator
+ :init :arg))
+
+(define-primitive-object (single-float :lowtag other-pointer-type
+ :header single-float-type)
+ (value :c-type "float"))
+
+(define-primitive-object (double-float :lowtag other-pointer-type
+ :header double-float-type)
+ (filler)
+ (value :c-type "double" :length 2))
+
+#!+long-float
+(define-primitive-object (long-float :lowtag other-pointer-type
+ :header long-float-type)
+ #!+sparc (filler)
+ (value :c-type "long double" :length #!+x86 3 #!+sparc 4))
+
+(define-primitive-object (complex :type complex
+ :lowtag other-pointer-type
+ :header complex-type
+ :alloc-trans %make-complex)
+ (real :type real
+ :ref-known (flushable movable)
+ :ref-trans %realpart
+ :init :arg)
+ (imag :type real
+ :ref-known (flushable movable)
+ :ref-trans %imagpart
+ :init :arg))
+
+(define-primitive-object (array :lowtag other-pointer-type
+ :header t)
+ (fill-pointer :type index
+ :ref-trans %array-fill-pointer
+ :ref-known (flushable foldable)
+ :set-trans (setf %array-fill-pointer)
+ :set-known (unsafe))
+ (fill-pointer-p :type (member t nil)
+ :ref-trans %array-fill-pointer-p
+ :ref-known (flushable foldable)
+ :set-trans (setf %array-fill-pointer-p)
+ :set-known (unsafe))
+ (elements :type index
+ :ref-trans %array-available-elements
+ :ref-known (flushable foldable)
+ :set-trans (setf %array-available-elements)
+ :set-known (unsafe))
+ (data :type array
+ :ref-trans %array-data-vector
+ :ref-known (flushable foldable)
+ :set-trans (setf %array-data-vector)
+ :set-known (unsafe))
+ (displacement :type (or index null)
+ :ref-trans %array-displacement
+ :ref-known (flushable foldable)
+ :set-trans (setf %array-displacement)
+ :set-known (unsafe))
+ (displaced-p :type (member t nil)
+ :ref-trans %array-displaced-p
+ :ref-known (flushable foldable)
+ :set-trans (setf %array-displaced-p)
+ :set-known (unsafe))
+ (dimensions :rest-p t))
+
+(define-primitive-object (vector :type vector
+ :lowtag other-pointer-type
+ :header t)
+ (length :ref-trans sb!c::vector-length
+ :type index)
+ (data :rest-p t :c-type #!-alpha "unsigned long" #!+alpha "u32"))
+
+(define-primitive-object (code :type code-component
+ :lowtag other-pointer-type
+ :header t)
+ (code-size :type index
+ :ref-known (flushable movable)
+ :ref-trans %code-code-size)
+ (entry-points :type (or function null)
+ :ref-known (flushable)
+ :ref-trans %code-entry-points
+ :set-known (unsafe)
+ :set-trans (setf %code-entry-points))
+ (debug-info :type t
+ :ref-known (flushable)
+ :ref-trans %code-debug-info
+ :set-known (unsafe)
+ :set-trans (setf %code-debug-info))
+ (trace-table-offset)
+ (constants :rest-p t))
+
+(define-primitive-object (fdefn :type fdefn
+ :lowtag other-pointer-type
+ :header fdefn-type)
+ (name :ref-trans fdefn-name)
+ (function :type (or function null) :ref-trans fdefn-function)
+ (raw-addr :c-type #!-alpha "char *" #!+alpha "u32"))
+
+(define-primitive-object (function :type function
+ :lowtag function-pointer-type
+ :header function-header-type)
+ #!-gengc (self :ref-trans %function-self :set-trans (setf %function-self))
+ #!+gengc (entry-point :c-type "char *")
+ (next :type (or function null)
+ :ref-known (flushable)
+ :ref-trans %function-next
+ :set-known (unsafe)
+ :set-trans (setf %function-next))
+ (name :ref-known (flushable)
+ :ref-trans %function-name
+ :set-known (unsafe)
+ :set-trans (setf %function-name))
+ (arglist :ref-known (flushable)
+ :ref-trans %function-arglist
+ :set-known (unsafe)
+ :set-trans (setf %function-arglist))
+ (type :ref-known (flushable)
+ :ref-trans %function-type
+ :set-known (unsafe)
+ :set-trans (setf %function-type))
+ (code :rest-p t :c-type "unsigned char"))
+
+#!-gengc
+(define-primitive-object (return-pc :lowtag other-pointer-type :header t)
+ (return-point :c-type "unsigned char" :rest-p t))
+
+(define-primitive-object (closure :lowtag function-pointer-type
+ :header closure-header-type)
+ #!-gengc (function :init :arg :ref-trans %closure-function)
+ #!+gengc (entry-point :c-type "char *")
+ (info :rest-p t))
+
+(define-primitive-object (funcallable-instance
+ :lowtag function-pointer-type
+ :header funcallable-instance-header-type
+ :alloc-trans %make-funcallable-instance)
+ #!-gengc
+ (function
+ :ref-known (flushable) :ref-trans %funcallable-instance-function
+ :set-known (unsafe) :set-trans (setf %funcallable-instance-function))
+ #!+gengc (entry-point :c-type "char *")
+ (lexenv :ref-known (flushable) :ref-trans %funcallable-instance-lexenv
+ :set-known (unsafe) :set-trans (setf %funcallable-instance-lexenv))
+ (layout :init :arg
+ :ref-known (flushable) :ref-trans %funcallable-instance-layout
+ :set-known (unsafe) :set-trans (setf %funcallable-instance-layout))
+ (info :rest-p t))
+
+(define-primitive-object (value-cell :lowtag other-pointer-type
+ :header value-cell-header-type
+ :alloc-trans make-value-cell)
+ (value :set-trans value-cell-set
+ :set-known (unsafe)
+ :ref-trans value-cell-ref
+ :ref-known (flushable)
+ :init :arg))
+
+#!+alpha
+(define-primitive-object (sap :lowtag other-pointer-type
+ :header sap-type)
+ (padding)
+ (pointer :c-type "char *" :length 2))
+
+#!-alpha
+(define-primitive-object (sap :lowtag other-pointer-type
+ :header sap-type)
+ (pointer :c-type "char *"))
+
+
+(define-primitive-object (weak-pointer :type weak-pointer
+ :lowtag other-pointer-type
+ :header weak-pointer-type
+ :alloc-trans make-weak-pointer)
+ (value :ref-trans sb!c::%weak-pointer-value :ref-known (flushable)
+ :init :arg)
+ (broken :type (member t nil)
+ :ref-trans sb!c::%weak-pointer-broken :ref-known (flushable)
+ :init :null)
+ (next :c-type #!-alpha "struct weak_pointer *" #!+alpha "u32"))
+
+;;;; other non-heap data blocks
+
+(define-primitive-object (binding)
+ value
+ symbol)
+
+(define-primitive-object (unwind-block)
+ (current-uwp :c-type #!-alpha "struct unwind_block *" #!+alpha "u32")
+ (current-cont :c-type #!-alpha "lispobj *" #!+alpha "u32")
+ #!-x86 current-code
+ entry-pc)
+
+(define-primitive-object (catch-block)
+ (current-uwp :c-type #!-alpha "struct unwind_block *" #!+alpha "u32")
+ (current-cont :c-type #!-alpha "lispobj *" #!+alpha "u32")
+ #!-x86 current-code
+ entry-pc
+ tag
+ (previous-catch :c-type #!-alpha "struct catch_block *" #!+alpha "u32")
+ size)
+
+;;; (For an explanation of this, see the comments at the definition of
+;;; KLUDGE-NONDETERMINISTIC-CATCH-BLOCK-SIZE.)
+(assert (= sb!vm::kludge-nondeterministic-catch-block-size catch-block-size))
+
+#!+gengc
+(define-primitive-object (mutator)
+ ;; Holds the lisp thread structure, if any.
+ (thread)
+ ;; Signal control magic.
+ (foreign-fn-call-active :c-type "boolean")
+ (interrupts-disabled-count :c-type "int")
+ (interrupt-pending :c-type "boolean")
+ (pending-signal :c-type "int")
+ (pending-code :c-type "int")
+ (pending-mask :c-type "int")
+ (gc-pending :c-type "boolean")
+ ;; Stacks.
+ (control-stack-base :c-type "lispobj *")
+ (control-stack-pointer :c-type "lispobj *")
+ (control-stack-end :c-type "lispobj *")
+ (control-frame-pointer :c-type "lispobj *")
+ (current-unwind-protect :c-type "struct unwind_block *")
+ (current-catch-block :c-type "struct catch_block *")
+ (binding-stack-base :c-type "struct binding *")
+ (binding-stack-pointer :c-type "struct binding *")
+ (binding-stack-end :c-type "struct binding *")
+ (number-stack-base :c-type "char *")
+ (number-stack-pointer :c-type "char *")
+ (number-stack-end :c-type "char *")
+ (eval-stack)
+ (eval-stack-top)
+ ;; Allocation stuff.
+ (nursery-start :c-type "lispobj *")
+ (nursery-fill-pointer :c-type "lispobj *")
+ (nursery-end :c-type "lispobj *")
+ (storebuf-start :c-type "lispobj **")
+ (storebuf-fill-pointer :c-type "lispobj **")
+ (storebuf-end :c-type "lispobj **")
+ (words-consed :c-type "unsigned long"))
+
+\f
+;;;; symbols
+
+#!+gengc
+(defknown %make-symbol (index simple-string) symbol
+ (flushable movable))
+
+#+gengc
+(defknown symbol-hash (symbol) index
+ (flushable movable))
+
+#+x86
+(defknown symbol-hash (symbol) (integer 0 #.*target-most-positive-fixnum*)
+ (flushable movable))
+
+(define-primitive-object (symbol :lowtag other-pointer-type
+ :header symbol-header-type
+ #!-x86 :alloc-trans
+ #!-(or gengc x86) make-symbol
+ #!+gengc %make-symbol)
+ (value :set-trans %set-symbol-value
+ :init :unbound)
+ #!-(or gengc x86) unused
+ #!+gengc (hash :init :arg)
+ #!+x86 (hash)
+ (plist :ref-trans symbol-plist
+ :set-trans %set-symbol-plist
+ :init :null)
+ (name :ref-trans symbol-name :init :arg)
+ (package :ref-trans symbol-package
+ :set-trans %set-symbol-package
+ :init :null))
+
+(define-primitive-object (complex-single-float
+ :lowtag other-pointer-type
+ :header complex-single-float-type)
+ (real :c-type "float")
+ (imag :c-type "float"))
+
+(define-primitive-object (complex-double-float
+ :lowtag other-pointer-type
+ :header complex-double-float-type)
+ (filler)
+ (real :c-type "double" :length 2)
+ (imag :c-type "double" :length 2))
+
+#!+long-float
+(define-primitive-object (complex-long-float
+ :lowtag other-pointer-type
+ :header complex-long-float-type)
+ #!+sparc (filler)
+ (real :c-type "long double" :length #!+x86 3 #!+sparc 4)
+ (imag :c-type "long double" :length #!+x86 3 #!+sparc 4))
+
--- /dev/null
+;;;; machine-independent aspects of the object representation and
+;;;; primitive types
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!VM")
+
+(file-comment
+ "$Header$")
+\f
+;;;; primitive type definitions
+
+(def-primitive-type t (descriptor-reg))
+(setf *backend-t-primitive-type* (primitive-type-or-lose 't))
+
+;;; primitive integer types that fit in registers
+(def-primitive-type positive-fixnum (any-reg signed-reg unsigned-reg)
+ :type (unsigned-byte 29))
+#!-alpha
+(def-primitive-type unsigned-byte-31 (signed-reg unsigned-reg descriptor-reg)
+ :type (unsigned-byte 31))
+#!-alpha
+(def-primitive-type unsigned-byte-32 (unsigned-reg descriptor-reg)
+ :type (unsigned-byte 32))
+#!+alpha
+(def-primitive-type unsigned-byte-63 (signed-reg unsigned-reg descriptor-reg)
+ :type (unsigned-byte 63))
+#!+alpha
+(def-primitive-type unsigned-byte-64 (unsigned-reg descriptor-reg)
+ :type (unsigned-byte 64))
+(def-primitive-type fixnum (any-reg signed-reg)
+ :type (signed-byte 30))
+#!-alpha
+(def-primitive-type signed-byte-32 (signed-reg descriptor-reg)
+ :type (signed-byte 32))
+#!+alpha
+(def-primitive-type signed-byte-64 (signed-reg descriptor-reg)
+ :type (signed-byte 64))
+
+(defvar *fixnum-primitive-type* (primitive-type-or-lose 'fixnum))
+
+(def-primitive-type-alias tagged-num (:or positive-fixnum fixnum))
+(def-primitive-type-alias unsigned-num (:or #!-alpha unsigned-byte-32
+ #!-alpha unsigned-byte-31
+ #!+alpha unsigned-byte-64
+ #!+alpha unsigned-byte-63
+ positive-fixnum))
+(def-primitive-type-alias signed-num (:or #!-alpha signed-byte-32
+ #!+alpha signed-byte-64
+ fixnum
+ #!-alpha unsigned-byte-31
+ #!+alpha unsigned-byte-63
+ positive-fixnum))
+
+;;; other primitive immediate types
+(def-primitive-type base-char (base-char-reg any-reg))
+
+;;; primitive pointer types
+(def-primitive-type function (descriptor-reg))
+(def-primitive-type list (descriptor-reg))
+(def-primitive-type instance (descriptor-reg))
+
+(def-primitive-type funcallable-instance (descriptor-reg))
+
+;;; primitive other-pointer number types
+(def-primitive-type bignum (descriptor-reg))
+(def-primitive-type ratio (descriptor-reg))
+(def-primitive-type complex (descriptor-reg))
+(def-primitive-type single-float (single-reg descriptor-reg))
+(def-primitive-type double-float (double-reg descriptor-reg))
+#!+long-float
+(def-primitive-type long-float (long-reg descriptor-reg))
+(def-primitive-type complex-single-float (complex-single-reg descriptor-reg)
+ :type (complex single-float))
+(def-primitive-type complex-double-float (complex-double-reg descriptor-reg)
+ :type (complex double-float))
+#!+long-float
+(def-primitive-type complex-long-float (complex-long-reg descriptor-reg)
+ :type (complex long-float))
+
+;;; primitive other-pointer array types
+(def-primitive-type simple-string (descriptor-reg)
+ :type simple-base-string)
+(def-primitive-type simple-bit-vector (descriptor-reg))
+(def-primitive-type simple-vector (descriptor-reg))
+(def-primitive-type simple-array-unsigned-byte-2 (descriptor-reg)
+ :type (simple-array (unsigned-byte 2) (*)))
+(def-primitive-type simple-array-unsigned-byte-4 (descriptor-reg)
+ :type (simple-array (unsigned-byte 4) (*)))
+(def-primitive-type simple-array-unsigned-byte-8 (descriptor-reg)
+ :type (simple-array (unsigned-byte 8) (*)))
+(def-primitive-type simple-array-unsigned-byte-16 (descriptor-reg)
+ :type (simple-array (unsigned-byte 16) (*)))
+(def-primitive-type simple-array-unsigned-byte-32 (descriptor-reg)
+ :type (simple-array (unsigned-byte 32) (*)))
+(def-primitive-type simple-array-signed-byte-8 (descriptor-reg)
+ :type (simple-array (signed-byte 8) (*)))
+(def-primitive-type simple-array-signed-byte-16 (descriptor-reg)
+ :type (simple-array (signed-byte 16) (*)))
+(def-primitive-type simple-array-signed-byte-30 (descriptor-reg)
+ :type (simple-array (signed-byte 30) (*)))
+(def-primitive-type simple-array-signed-byte-32 (descriptor-reg)
+ :type (simple-array (signed-byte 32) (*)))
+(def-primitive-type simple-array-single-float (descriptor-reg)
+ :type (simple-array single-float (*)))
+(def-primitive-type simple-array-double-float (descriptor-reg)
+ :type (simple-array double-float (*)))
+#!+long-float
+(def-primitive-type simple-array-long-float (descriptor-reg)
+ :type (simple-array long-float (*)))
+(def-primitive-type simple-array-complex-single-float (descriptor-reg)
+ :type (simple-array (complex single-float) (*)))
+(def-primitive-type simple-array-complex-double-float (descriptor-reg)
+ :type (simple-array (complex double-float) (*)))
+#!+long-float
+(def-primitive-type simple-array-complex-long-float (descriptor-reg)
+ :type (simple-array (complex long-float) (*)))
+
+;;; Note: The complex array types are not included, 'cause it is pointless to
+;;; restrict VOPs to them.
+
+;;; other primitive other-pointer types
+(def-primitive-type system-area-pointer (sap-reg descriptor-reg))
+(def-primitive-type weak-pointer (descriptor-reg))
+
+;;; miscellaneous primitive types that don't exist at the LISP level
+(def-primitive-type catch-block (catch-block) :type nil)
+\f
+;;;; PRIMITIVE-TYPE-OF and friends
+
+;;; Return the most restrictive primitive type that contains Object.
+(def-vm-support-routine primitive-type-of (object)
+ (let ((type (ctype-of object)))
+ (cond ((not (member-type-p type)) (primitive-type type))
+ ((equal (member-type-members type) '(nil))
+ (primitive-type-or-lose 'list))
+ (t
+ *backend-t-primitive-type*))))
+
+(defvar *simple-array-primitive-types*
+ '((base-char . simple-string)
+ (bit . simple-bit-vector)
+ ((unsigned-byte 2) . simple-array-unsigned-byte-2)
+ ((unsigned-byte 4) . simple-array-unsigned-byte-4)
+ ((unsigned-byte 8) . simple-array-unsigned-byte-8)
+ ((unsigned-byte 16) . simple-array-unsigned-byte-16)
+ ((unsigned-byte 32) . simple-array-unsigned-byte-32)
+ ((signed-byte 8) . simple-array-signed-byte-8)
+ ((signed-byte 16) . simple-array-signed-byte-16)
+ (fixnum . simple-array-signed-byte-30)
+ ((signed-byte 32) . simple-array-signed-byte-32)
+ (single-float . simple-array-single-float)
+ (double-float . simple-array-double-float)
+ #!+long-float (long-float . simple-array-long-float)
+ ((complex single-float) . simple-array-complex-single-float)
+ ((complex double-float) . simple-array-complex-double-float)
+ #!+long-float
+ ((complex long-float) . simple-array-complex-long-float)
+ (t . simple-vector))
+ #!+sb-doc
+ "An a-list for mapping simple array element types to their
+ corresponding primitive types.")
+
+;;; Return the primitive type corresponding to a type descriptor
+;;; structure. The second value is true when the primitive type is
+;;; exactly equivalent to the argument Lisp type.
+;;;
+;;; In a bootstrapping situation, we should be careful to use the
+;;; correct values for the system parameters.
+;;;
+;;; We need an aux function because we need to use both def-vm-support-routine
+;;; and defun-cached.
+(def-vm-support-routine primitive-type (type)
+ (primitive-type-aux type))
+(defun-cached (primitive-type-aux
+ :hash-function (lambda (x)
+ (logand (type-hash-value x) #x1FF))
+ :hash-bits 9
+ :values 2
+ :default (values nil :empty))
+ ((type eq))
+ (declare (type ctype type))
+ (macrolet ((any () '(values *backend-t-primitive-type* nil))
+ (exactly (type)
+ `(values (primitive-type-or-lose ',type) t))
+ (part-of (type)
+ `(values (primitive-type-or-lose ',type) nil)))
+ (flet ((maybe-numeric-type-union (t1 t2)
+ (let ((t1-name (primitive-type-name t1))
+ (t2-name (primitive-type-name t2)))
+ (case t1-name
+ (positive-fixnum
+ (if (or (eq t2-name 'fixnum)
+ (eq t2-name #!-alpha 'signed-byte-32
+ #!+alpha 'signed-byte-64)
+ (eq t2-name #!-alpha 'unsigned-byte-31
+ #!+alpha 'unsigned-byte-63)
+ (eq t2-name #!-alpha 'unsigned-byte-32
+ #!+alpha 'unsigned-byte-64))
+ t2))
+ (fixnum
+ (case t2-name
+ (#!-alpha signed-byte-32
+ #!+alpha signed-byte-64 t2)
+ (#!-alpha unsigned-byte-31
+ #!+alpha unsigned-byte-63
+ (primitive-type-or-lose
+ #!-alpha 'signed-byte-32
+ #!+alpha 'signed-byte-64))))
+ (#!-alpha signed-byte-32
+ #!+alpha signed-byte-64
+ (if (eq t2-name #!-alpha 'unsigned-byte-31
+ #!+alpha 'unsigned-byte-63)
+ t1))
+ (#!-alpha unsigned-byte-31
+ #!+alpha unsigned-byte-63
+ (if (eq t2-name #!-alpha 'unsigned-byte-32
+ #!+alpha 'unsigned-byte-64)
+ t2))))))
+ (etypecase type
+ (numeric-type
+ (let ((lo (numeric-type-low type))
+ (hi (numeric-type-high type)))
+ (case (numeric-type-complexp type)
+ (:real
+ (case (numeric-type-class type)
+ (integer
+ (cond ((and hi lo)
+ (dolist (spec
+ `((positive-fixnum 0 ,(1- (ash 1 29)))
+ #!-alpha
+ (unsigned-byte-31 0 ,(1- (ash 1 31)))
+ #!-alpha
+ (unsigned-byte-32 0 ,(1- (ash 1 32)))
+ #!+alpha
+ (unsigned-byte-63 0 ,(1- (ash 1 63)))
+ #!+alpha
+ (unsigned-byte-64 0 ,(1- (ash 1 64)))
+ (fixnum ,(ash -1 29)
+ ,(1- (ash 1 29)))
+ #!-alpha
+ (signed-byte-32 ,(ash -1 31)
+ ,(1- (ash 1 31)))
+ #!+alpha
+ (signed-byte-64 ,(ash -1 63)
+ ,(1- (ash 1 63))))
+ (if (or (< hi (ash -1 29))
+ (> lo (1- (ash 1 29))))
+ (part-of bignum)
+ (any)))
+ (let ((type (car spec))
+ (min (cadr spec))
+ (max (caddr spec)))
+ (when (<= min lo hi max)
+ (return (values
+ (primitive-type-or-lose type)
+ (and (= lo min) (= hi max))))))))
+ ((or (and hi (< hi most-negative-fixnum))
+ (and lo (> lo most-positive-fixnum)))
+ (part-of bignum))
+ (t
+ (any))))
+ (float
+ (let ((exact (and (null lo) (null hi))))
+ (case (numeric-type-format type)
+ ((short-float single-float)
+ (values (primitive-type-or-lose 'single-float)
+ exact))
+ ((double-float #!-long-float long-float)
+ (values (primitive-type-or-lose 'double-float)
+ exact))
+ #!+long-float
+ (long-float
+ (values (primitive-type-or-lose 'long-float)
+ exact))
+ (t
+ (any)))))
+ (t
+ (any))))
+ (:complex
+ (if (eq (numeric-type-class type) 'float)
+ (let ((exact (and (null lo) (null hi))))
+ (case (numeric-type-format type)
+ ((short-float single-float)
+ (values (primitive-type-or-lose 'complex-single-float)
+ exact))
+ ((double-float #!-long-float long-float)
+ (values (primitive-type-or-lose 'complex-double-float)
+ exact))
+ #!+long-float
+ (long-float
+ (values (primitive-type-or-lose 'complex-long-float)
+ exact))
+ (t
+ (part-of complex))))
+ (part-of complex)))
+ (t
+ (any)))))
+ (array-type
+ (if (array-type-complexp type)
+ (any)
+ (let* ((dims (array-type-dimensions type))
+ (etype (array-type-specialized-element-type type))
+ (type-spec (type-specifier etype))
+ (ptype (cdr (assoc type-spec *simple-array-primitive-types*
+ :test #'equal))))
+ (if (and (consp dims) (null (rest dims)) ptype)
+ (values (primitive-type-or-lose ptype)
+ (eq (first dims) '*))
+ (any)))))
+ (union-type
+ (if (type= type (specifier-type 'list))
+ (exactly list)
+ (let ((types (union-type-types type)))
+ (multiple-value-bind (res exact) (primitive-type (first types))
+ (dolist (type (rest types) (values res exact))
+ (multiple-value-bind (ptype ptype-exact)
+ (primitive-type type)
+ (unless ptype-exact (setq exact nil))
+ (unless (eq ptype res)
+ (let ((new-ptype
+ (or (maybe-numeric-type-union res ptype)
+ (maybe-numeric-type-union ptype res))))
+ (if new-ptype
+ (setq res new-ptype)
+ (return (any)))))))))))
+ (member-type
+ (let* ((members (member-type-members type))
+ (res (primitive-type-of (first members))))
+ (dolist (mem (rest members) (values res nil))
+ (let ((ptype (primitive-type-of mem)))
+ (unless (eq ptype res)
+ (let ((new-ptype (or (maybe-numeric-type-union res ptype)
+ (maybe-numeric-type-union ptype res))))
+ (if new-ptype
+ (setq res new-ptype)
+ (return (any)))))))))
+ (named-type
+ (ecase (named-type-name type)
+ ((t *) (values *backend-t-primitive-type* t))
+ ((nil) (any))))
+ (sb!xc:built-in-class
+ (case (sb!xc:class-name type)
+ ((complex function instance
+ system-area-pointer weak-pointer)
+ (values (primitive-type-or-lose (sb!xc:class-name type)) t))
+ (funcallable-instance
+ (part-of function))
+ (base-char
+ (exactly base-char))
+ (cons
+ (part-of list))
+ (t
+ (any))))
+ (function-type
+ (exactly function))
+ (sb!xc:class
+ (if (csubtypep type (specifier-type 'function))
+ (part-of function)
+ (part-of instance)))
+ (ctype
+ (any))))))
--- /dev/null
+;;;; target-only code that knows how to load compiled code directly
+;;;; into core
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!C")
+
+(file-comment
+ "$Header$")
+
+;;; Make a function entry, filling in slots from the ENTRY-INFO.
+(defun make-function-entry (entry code-obj object)
+ (declare (type entry-info entry) (type core-object object))
+ (let ((offset (label-position (entry-info-offset entry))))
+ (declare (type index offset))
+ (unless (zerop (logand offset sb!vm:lowtag-mask))
+ (error "Unaligned function object, offset = #X~X." offset))
+ (let ((res (%primitive compute-function code-obj offset)))
+ (setf (%function-self res) res)
+ (setf (%function-next res) (%code-entry-points code-obj))
+ (setf (%code-entry-points code-obj) res)
+ (setf (%function-name res) (entry-info-name entry))
+ (setf (%function-arglist res) (entry-info-arguments entry))
+ (setf (%function-type res) (entry-info-type entry))
+
+ (note-function entry res object))))
+
+;;; Dump a component to core. We pass in the assembler fixups, code vector
+;;; and node info.
+(defun make-core-component (component segment length trace-table fixups object)
+ (declare (type component component)
+ (type sb!assem:segment segment)
+ (type index length)
+ (list trace-table fixups)
+ (type core-object object))
+ (without-gcing
+ (let* ((2comp (component-info component))
+ (constants (ir2-component-constants 2comp))
+ (trace-table (pack-trace-table trace-table))
+ (trace-table-len (length trace-table))
+ (trace-table-bits (* trace-table-len tt-bits-per-entry))
+ (total-length (+ length (ceiling trace-table-bits sb!vm:byte-bits)))
+ (box-num (- (length constants) sb!vm:code-trace-table-offset-slot))
+ #!+x86
+ (code-obj
+ ;; FIXME: What is this *ENABLE-DYNAMIC-SPACE-CODE* stuff?
+ (if (and (boundp sb!impl::*enable-dynamic-space-code*)
+ sb!impl::*enable-dynamic-space-code*)
+ (%primitive allocate-dynamic-code-object box-num total-length)
+ (%primitive allocate-code-object box-num total-length)))
+ #!-x86
+ (code-obj
+ (%primitive allocate-code-object box-num total-length))
+ (fill-ptr (code-instructions code-obj)))
+ (declare (type index box-num total-length))
+
+ (sb!assem:on-segment-contents-vectorly
+ segment
+ (lambda (v)
+ (declare (type (simple-array sb!assem:assembly-unit 1) v))
+ (copy-byte-vector-to-system-area v fill-ptr)
+ (setf fill-ptr (sap+ fill-ptr (length v)))))
+
+ (do-core-fixups code-obj fixups)
+
+ (dolist (entry (ir2-component-entries 2comp))
+ (make-function-entry entry code-obj object))
+
+ (sb!vm:sanctify-for-execution code-obj)
+
+ (let ((info (debug-info-for-component component)))
+ (push info (core-object-debug-info object))
+ (setf (%code-debug-info code-obj) info))
+
+ (setf (code-header-ref code-obj sb!vm:code-trace-table-offset-slot) length)
+ (copy-to-system-area trace-table
+ (* sb!vm:vector-data-offset sb!vm:word-bits)
+ fill-ptr
+ 0
+ trace-table-bits)
+
+ (do ((index sb!vm:code-constants-offset (1+ index)))
+ ((>= index (length constants)))
+ (let ((const (aref constants index)))
+ (etypecase const
+ (null)
+ (constant
+ (setf (code-header-ref code-obj index)
+ (constant-value const)))
+ (list
+ (ecase (car const)
+ (:entry
+ (reference-core-function code-obj index
+ (cdr const) object))
+ (:fdefinition
+ (setf (code-header-ref code-obj index)
+ (sb!impl::fdefinition-object (cdr const) t))))))))))
+ (values))
+
+(defun make-core-byte-component (segment length constants xeps object)
+ (declare (type sb!assem:segment segment)
+ (type index length)
+ (type vector constants)
+ (type list xeps)
+ (type core-object object))
+ (without-gcing
+ (let* ((num-constants (length constants))
+ ;; KLUDGE: On the X86, using ALLOCATE-CODE-OBJECT is
+ ;; supposed to make the result non-relocatable, which is
+ ;; probably not what we want. Could this be made into
+ ;; ALLOCATE-DYNAMIC-CODE-OBJECT? Is there some other fix?
+ ;; Am I just confused? -- WHN 19990916
+ (code-obj (%primitive allocate-code-object
+ (the index (1+ num-constants))
+ length))
+ (fill-ptr (code-instructions code-obj)))
+ (declare (type index length)
+ (type system-area-pointer fill-ptr))
+ (sb!assem:on-segment-contents-vectorly
+ segment
+ (lambda (v)
+ (declare (type (simple-array sb!assem:assembly-unit 1) v))
+ (copy-byte-vector-to-system-area v fill-ptr)
+ (setf fill-ptr (sap+ fill-ptr (length v)))))
+
+ (setf (code-header-ref code-obj sb!vm:code-trace-table-offset-slot)
+ nil)
+ (dolist (noise xeps)
+ (let ((xep (cdr noise)))
+ (setf (byte-function-component xep) code-obj)
+ (initialize-byte-compiled-function xep)
+ (note-function (lambda-info (car noise)) xep object)))
+
+ (dotimes (index num-constants)
+ (let ((const (aref constants index))
+ (code-obj-index (+ index sb!vm:code-constants-offset)))
+ (etypecase const
+ (null)
+ (constant
+ (setf (code-header-ref code-obj code-obj-index)
+ (constant-value const)))
+ (list
+ (ecase (car const)
+ (:entry
+ (reference-core-function code-obj code-obj-index (cdr const)
+ object))
+ (:fdefinition
+ (setf (code-header-ref code-obj code-obj-index)
+ (sb!impl::fdefinition-object (cdr const) t)))
+ (:type-predicate
+ (let ((*unparse-function-type-simplify* t))
+ (setf (code-header-ref code-obj code-obj-index)
+ (load-type-predicate (type-specifier (cdr const))))))
+ (:xep
+ (let ((xep (cdr (assoc (cdr const) xeps :test #'eq))))
+ (assert xep)
+ (setf (code-header-ref code-obj code-obj-index) xep))))))))))
+
+ (values))
+
--- /dev/null
+;;;; utility functions needed by the back end to generate code
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!VM")
+
+(file-comment
+ "$Header$")
+\f
+(defun fixnumize (num)
+ #!+sb-doc
+ "Make a fixnum out of NUM. (i.e. shift by two bits if it will fit.)"
+ (if (<= #x-20000000 num #x1fffffff)
+ (ash num 2)
+ (error "~D is too big for a fixnum." num)))
+\f
+;;;; routines for dealing with static symbols
+
+(defun static-symbol-p (symbol)
+ (or (null symbol)
+ (and (member symbol *static-symbols*) t)))
+
+(defun static-symbol-offset (symbol)
+ #!+sb-doc
+ "the byte offset of the static symbol SYMBOL"
+ (if symbol
+ (let ((posn (position symbol *static-symbols*)))
+ (unless posn (error "~S is not a static symbol." symbol))
+ (+ (* posn (pad-data-block symbol-size))
+ (pad-data-block (1- symbol-size))
+ other-pointer-type
+ (- list-pointer-type)))
+ 0))
+
+(defun offset-static-symbol (offset)
+ #!+sb-doc
+ "Given a byte offset, OFFSET, return the appropriate static symbol."
+ (if (zerop offset)
+ nil
+ (multiple-value-bind (n rem)
+ (truncate (+ offset list-pointer-type (- other-pointer-type)
+ (- (pad-data-block (1- symbol-size))))
+ (pad-data-block symbol-size))
+ (unless (and (zerop rem) (<= 0 n (1- (length *static-symbols*))))
+ (error "The byte offset ~D is not valid." offset))
+ (elt *static-symbols* n))))
+
+(defun static-function-offset (name)
+ #!+sb-doc
+ "Return the (byte) offset from NIL to the start of the fdefn object
+ for the static function NAME."
+ (let ((static-syms (length *static-symbols*))
+ (static-function-index (position name *static-functions*)))
+ (unless static-function-index
+ (error "~S isn't a static function." name))
+ (+ (* static-syms (pad-data-block symbol-size))
+ (pad-data-block (1- symbol-size))
+ (- list-pointer-type)
+ (* static-function-index (pad-data-block fdefn-size))
+ (* fdefn-raw-addr-slot word-bytes))))
--- /dev/null
+;;;; signatures of machine-specific functions
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!C")
+
+(file-comment
+ "$Header$")
+\f
+;;;; internal type predicates
+
+;;; Simple TYPEP uses that don't have any standard predicate are
+;;; translated into non-standard unary predicates.
+(defknown (fixnump bignump ratiop
+ short-float-p single-float-p double-float-p long-float-p
+ complex-rational-p complex-float-p complex-single-float-p
+ complex-double-float-p #!+long-float complex-long-float-p
+ complex-vector-p
+ base-char-p %standard-char-p %instancep
+ array-header-p
+ simple-array-p simple-array-unsigned-byte-2-p
+ simple-array-unsigned-byte-4-p simple-array-unsigned-byte-8-p
+ simple-array-unsigned-byte-16-p simple-array-unsigned-byte-32-p
+ simple-array-signed-byte-8-p simple-array-signed-byte-16-p
+ simple-array-signed-byte-30-p simple-array-signed-byte-32-p
+ simple-array-single-float-p simple-array-double-float-p
+ #!+long-float simple-array-long-float-p
+ simple-array-complex-single-float-p
+ simple-array-complex-double-float-p
+ #!+long-float simple-array-complex-long-float-p
+ system-area-pointer-p realp unsigned-byte-32-p signed-byte-32-p
+ vector-t-p weak-pointer-p code-component-p lra-p
+ funcallable-instance-p)
+ (t) boolean (movable foldable flushable))
+\f
+;;;; miscellaneous "sub-primitives"
+
+(defknown %sp-string-compare
+ (simple-string index index simple-string index index)
+ (or index null)
+ (foldable flushable))
+
+(defknown %sxhash-simple-string (simple-string) index
+ (foldable flushable))
+
+(defknown %sxhash-simple-substring (simple-string index) index
+ (foldable flushable))
+
+(defknown vector-length (vector) index (flushable))
+
+(defknown vector-sap ((simple-unboxed-array (*))) system-area-pointer
+ (flushable))
+
+(defknown get-lowtag (t) (unsigned-byte #.sb!vm:lowtag-bits)
+ (flushable movable))
+(defknown get-type (t) (unsigned-byte #.sb!vm:type-bits)
+ (flushable movable))
+
+(defknown (get-header-data get-closure-length) (t) (unsigned-byte 24)
+ (flushable))
+(defknown set-header-data (t (unsigned-byte 24)) t
+ (unsafe))
+
+
+(defknown %make-instance (index) instance
+ (unsafe))
+(defknown %instance-layout (instance) layout
+ (foldable flushable))
+(defknown %set-instance-layout (instance layout) layout
+ (unsafe))
+(defknown %instance-length (instance) index
+ (foldable flushable))
+(defknown %instance-ref (instance index) t
+ (flushable))
+(defknown %instance-set (instance index t) t
+ (unsafe))
+(defknown %layout-invalid-error (t layout) nil)
+
+
+(sb!xc:deftype raw-vector () '(simple-array (unsigned-byte 32) (*)))
+
+(defknown %raw-ref-single (raw-vector index) single-float
+ (foldable flushable))
+(defknown %raw-ref-double (raw-vector index) double-float
+ (foldable flushable))
+#!+long-float
+(defknown %raw-ref-long (raw-vector index) long-float
+ (foldable flushable))
+(defknown %raw-set-single (raw-vector index single-float) single-float
+ (unsafe))
+(defknown %raw-set-double (raw-vector index double-float) double-float
+ (unsafe))
+#!+long-float
+(defknown %raw-set-long (raw-vector index long-float) long-float
+ (unsafe))
+
+(defknown %raw-ref-complex-single (raw-vector index) (complex single-float)
+ (foldable flushable))
+(defknown %raw-ref-complex-double (raw-vector index) (complex double-float)
+ (foldable flushable))
+#!+long-float
+(defknown %raw-ref-complex-long (raw-vector index) (complex long-float)
+ (foldable flushable))
+(defknown %raw-set-complex-single (raw-vector index (complex single-float))
+ (complex single-float)
+ (unsafe))
+(defknown %raw-set-complex-double (raw-vector index (complex double-float))
+ (complex double-float)
+ (unsafe))
+#!+long-float
+(defknown %raw-set-complex-long (raw-vector index (complex long-float))
+ (complex long-float)
+ (unsafe))
+
+(defknown %raw-bits (t fixnum) (unsigned-byte 32)
+ (foldable flushable))
+(defknown (%set-raw-bits) (t fixnum (unsigned-byte 32)) (unsigned-byte 32)
+ (unsafe))
+
+
+(defknown allocate-vector ((unsigned-byte 8) index index) (simple-array * (*))
+ (flushable movable))
+
+(defknown make-array-header ((unsigned-byte 8) (unsigned-byte 24)) array
+ (flushable movable))
+
+
+(defknown make-weak-pointer (t) weak-pointer
+ (flushable))
+
+(defknown %make-complex (real real) complex
+ (flushable movable))
+(defknown %make-ratio (rational rational) ratio
+ (flushable movable))
+(defknown make-value-cell (t) t
+ (flushable movable))
+
+(defknown (dynamic-space-free-pointer binding-stack-pointer-sap
+ control-stack-pointer-sap) ()
+ system-area-pointer
+ (flushable))
+\f
+;;;; debugger support
+
+(defknown current-sp () system-area-pointer (movable flushable))
+(defknown current-fp () system-area-pointer (movable flushable))
+(defknown stack-ref (system-area-pointer index) t (flushable))
+(defknown %set-stack-ref (system-area-pointer index t) t (unsafe))
+(defknown lra-code-header (t) t (movable flushable))
+(defknown function-code-header (t) t (movable flushable))
+(defknown make-lisp-obj ((unsigned-byte 32)) t (movable flushable))
+(defknown get-lisp-obj-address (t) (unsigned-byte 32) (movable flushable))
+(defknown function-word-offset (function) index (movable flushable))
+\f
+;;;; 32-bit logical operations
+
+(defknown merge-bits ((unsigned-byte 5) (unsigned-byte 32) (unsigned-byte 32))
+ (unsigned-byte 32)
+ (foldable flushable movable))
+
+(defknown 32bit-logical-not ((unsigned-byte 32)) (unsigned-byte 32)
+ (foldable flushable movable))
+
+(defknown (32bit-logical-and 32bit-logical-nand
+ 32bit-logical-or 32bit-logical-nor
+ 32bit-logical-xor 32bit-logical-eqv
+ 32bit-logical-andc1 32bit-logical-andc2
+ 32bit-logical-orc1 32bit-logical-orc2)
+ ((unsigned-byte 32) (unsigned-byte 32)) (unsigned-byte 32)
+ (foldable flushable movable))
+
+(defknown (shift-towards-start shift-towards-end) ((unsigned-byte 32) fixnum)
+ (unsigned-byte 32)
+ (foldable flushable movable))
+\f
+;;;; bignum operations
+
+(defknown %allocate-bignum (bignum-index) bignum-type
+ (flushable))
+
+(defknown %bignum-length (bignum-type) bignum-index
+ (foldable flushable movable))
+
+(defknown %bignum-set-length (bignum-type bignum-index) bignum-type
+ (unsafe))
+
+(defknown %bignum-ref (bignum-type bignum-index) bignum-element-type
+ (flushable))
+
+(defknown %bignum-set (bignum-type bignum-index bignum-element-type)
+ bignum-element-type
+ (unsafe))
+
+(defknown %digit-0-or-plusp (bignum-element-type) boolean
+ (foldable flushable movable))
+
+(defknown (%add-with-carry %subtract-with-borrow)
+ (bignum-element-type bignum-element-type (mod 2))
+ (values bignum-element-type (mod 2))
+ (foldable flushable movable))
+
+(defknown %multiply-and-add
+ (bignum-element-type bignum-element-type bignum-element-type
+ &optional bignum-element-type)
+ (values bignum-element-type bignum-element-type)
+ (foldable flushable movable))
+
+(defknown %multiply (bignum-element-type bignum-element-type)
+ (values bignum-element-type bignum-element-type)
+ (foldable flushable movable))
+
+(defknown %lognot (bignum-element-type) bignum-element-type
+ (foldable flushable movable))
+
+(defknown (%logand %logior %logxor) (bignum-element-type bignum-element-type)
+ bignum-element-type
+ (foldable flushable movable))
+
+(defknown %fixnum-to-digit (fixnum) bignum-element-type
+ (foldable flushable movable))
+
+(defknown %floor (bignum-element-type bignum-element-type bignum-element-type)
+ (values bignum-element-type bignum-element-type)
+ (foldable flushable movable))
+
+(defknown %fixnum-digit-with-correct-sign (bignum-element-type)
+ (signed-byte #.sb!vm:word-bits)
+ (foldable flushable movable))
+
+(defknown (%ashl %ashr %digit-logical-shift-right)
+ (bignum-element-type (mod 32)) bignum-element-type
+ (foldable flushable movable))
+\f
+;;;; bit-bashing routines
+
+(defknown copy-to-system-area
+ ((simple-unboxed-array (*)) index system-area-pointer index index)
+ null
+ ())
+
+(defknown copy-from-system-area
+ (system-area-pointer index (simple-unboxed-array (*)) index index)
+ null
+ ())
+
+(defknown system-area-copy
+ (system-area-pointer index system-area-pointer index index)
+ null
+ ())
+
+(defknown bit-bash-copy
+ ((simple-unboxed-array (*)) index
+ (simple-unboxed-array (*)) index index)
+ null
+ ())
+\f
+;;;; code/function/fdefn object manipulation routines
+
+(defknown code-instructions (t) system-area-pointer (flushable movable))
+(defknown code-header-ref (t index) t (flushable))
+(defknown code-header-set (t index t) t ())
+
+(defknown function-subtype (function) (unsigned-byte #.sb!vm:type-bits)
+ (flushable))
+(defknown ((setf function-subtype))
+ ((unsigned-byte #.sb!vm:type-bits) function)
+ (unsigned-byte #.sb!vm:type-bits)
+ ())
+
+(defknown make-fdefn (t) fdefn (flushable movable))
+(defknown fdefn-p (t) boolean (movable foldable flushable))
+(defknown fdefn-name (fdefn) t (foldable flushable))
+(defknown fdefn-function (fdefn) (or function null) (flushable))
+(defknown (setf fdefn-function) (function fdefn) t (unsafe))
+(defknown fdefn-makunbound (fdefn) t ())
+
+(defknown %function-self (function) function
+ (flushable))
+(defknown (setf %function-self) (function function) function
+ (unsafe))
+
+(defknown %closure-function (function) function
+ (flushable))
+
+(defknown %closure-index-ref (function index) t
+ (flushable))
+
+(defknown %make-funcallable-instance (index layout) function
+ (unsafe))
+
+(defknown %funcallable-instance-info (function index) t (flushable))
+(defknown %set-funcallable-instance-info (function index t) t (unsafe))
+\f
+;;;; mutator accessors
+
+(defknown mutator-self () system-area-pointer (flushable movable))
--- /dev/null
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!C")
+
+(file-comment
+ "$Header$")
+
+(defoptimizer ir2-convert-reffer ((object) node block name offset lowtag)
+ (let* ((cont (node-cont node))
+ (locs (continuation-result-tns cont
+ (list *backend-t-primitive-type*)))
+ (res (first locs)))
+ (vop slot node block (continuation-tn node block object)
+ name offset lowtag res)
+ (move-continuation-result node block locs cont)))
+
+#!+gengc
+(defun needs-remembering (cont)
+ (if (csubtypep (continuation-type cont)
+ (load-time-value (specifier-type '(or fixnum character
+ (member t nil)))))
+ nil
+ t))
+
+(defoptimizer ir2-convert-setter ((object value) node block name offset lowtag)
+ (let ((value-tn (continuation-tn node block value)))
+ (vop set-slot node block (continuation-tn node block object) value-tn
+ name offset lowtag #!+gengc (needs-remembering value))
+ (move-continuation-result node block (list value-tn) (node-cont node))))
+
+(defoptimizer ir2-convert-setfer ((value object) node block name offset lowtag)
+ (let ((value-tn (continuation-tn node block value)))
+ (vop set-slot node block (continuation-tn node block object) value-tn
+ name offset lowtag #!+gengc (needs-remembering value))
+ (move-continuation-result node block (list value-tn) (node-cont node))))
+
+(defun do-inits (node block name result lowtag inits args)
+ (let ((unbound-marker-tn nil))
+ (dolist (init inits)
+ (let ((kind (car init))
+ (slot (cdr init)))
+ (vop set-slot node block result
+ (ecase kind
+ (:arg
+ (assert args)
+ (continuation-tn node block (pop args)))
+ (:unbound
+ (or unbound-marker-tn
+ (setf unbound-marker-tn
+ (let ((tn (make-restricted-tn
+ nil
+ (sc-number-or-lose 'sb!vm::any-reg))))
+ (vop make-unbound-marker node block tn)
+ tn))))
+ (:null
+ (emit-constant nil)))
+ name slot lowtag #!+gengc nil))))
+ (assert (null args)))
+
+(defun do-fixed-alloc (node block name words type lowtag result)
+ #!-gengc
+ (vop fixed-alloc node block name words type lowtag result)
+ #!+gengc
+ (if (>= words sb!vm:large-object-cutoff)
+ (vop large-alloc node block (emit-constant (logandc2 (1+ words) 1))
+ (emit-constant lowtag) (emit-constant type) (emit-constant 0) name
+ result)
+ (vop fixed-alloc node block name words type lowtag result)))
+
+(defoptimizer ir2-convert-fixed-allocation
+ ((&rest args) node block name words type lowtag inits)
+ (let* ((cont (node-cont node))
+ (locs (continuation-result-tns cont
+ (list *backend-t-primitive-type*)))
+ (result (first locs)))
+ (do-fixed-alloc node block name words type lowtag result)
+ (do-inits node block name result lowtag inits args)
+ (move-continuation-result node block locs cont)))
+
+(defoptimizer ir2-convert-variable-allocation
+ ((extra &rest args) node block name words type lowtag inits)
+ (let* ((cont (node-cont node))
+ (locs (continuation-result-tns cont
+ (list *backend-t-primitive-type*)))
+ (result (first locs)))
+ (if (constant-continuation-p extra)
+ (let ((words (+ (continuation-value extra) words)))
+ (do-fixed-alloc node block name words type lowtag result))
+ (vop var-alloc node block (continuation-tn node block extra) name words
+ type lowtag result))
+ (do-inits node block name result lowtag inits args)
+ (move-continuation-result node block locs cont)))
+
+
+\f
+;;;; other allocation support
+
+#!+gengc
+(defoptimizer (make-array-header ir2-convert) ((type rank) node block)
+ (let* ((cont (node-cont node))
+ (locs (continuation-result-tns cont
+ (list *backend-t-primitive-type*)))
+ (result (first locs)))
+ (if (and (constant-continuation-p type)
+ (constant-continuation-p rank))
+ (do-fixed-alloc node block 'make-array-header
+ (+ (continuation-value rank)
+ sb!vm:array-dimensions-offset)
+ (continuation-value type)
+ sb!vm:other-pointer-type result)
+ (vop make-array-header node block (continuation-tn node block type)
+ (continuation-tn node block rank) result))
+ (move-continuation-result node block locs cont)))
+\f
+;;;; replacements for stuff in ir2tran to make gengc work
+
+#!+gengc
+(defun ir2-convert-closure (node block leaf res)
+ (declare (type ref node) (type ir2-block block)
+ (type functional leaf) (type tn res))
+ (unless (leaf-info leaf)
+ (setf (leaf-info leaf) (make-entry-info)))
+ (let ((entry (make-load-time-constant-tn :entry leaf))
+ (closure (etypecase leaf
+ (clambda
+ (environment-closure (get-lambda-environment leaf)))
+ (functional
+ (assert (eq (functional-kind leaf) :top-level-xep))
+ nil))))
+ (if closure
+ (let ((this-env (node-environment node)))
+ #!+gengc (let ((temp (make-normal-tn *backend-t-primitive-type*)))
+ (do-fixed-alloc node block 'make-closure
+ (+ (length closure)
+ sb!vm:closure-info-offset)
+ sb!vm:closure-header-type
+ sb!vm:function-pointer-type
+ res)
+ (emit-move node block entry temp)
+ (vop %set-function-self node block temp res temp))
+ ;; KLUDGE: #!-GENGC nested inside #!+GENGC doesn't make much sense;
+ ;; it's just a literal translation of the CMU CL distinction between
+ ;; host and backend. If GENGC code is ever revived, this should be
+ ;; cleaned up.
+ #!-gengc (vop make-closure node block entry (length closure) res)
+ (loop for what in closure and n from 0 do
+ (unless (and (lambda-var-p what)
+ (null (leaf-refs what)))
+ (vop closure-init node block
+ res
+ (find-in-environment what this-env)
+ n
+ nil))))
+ (emit-move node block entry res)))
+ (values))
+
+#!+gengc
+(defun ir2-convert-set (node block)
+ (declare (type cset node) (type ir2-block block))
+ (let* ((cont (node-cont node))
+ (leaf (set-var node))
+ (value (set-value node))
+ (val-tn (continuation-tn node block value))
+ (locs (if (continuation-info cont)
+ (continuation-result-tns
+ cont (list (primitive-type (leaf-type leaf))))
+ nil)))
+ (etypecase leaf
+ (lambda-var
+ (when (leaf-refs leaf)
+ (let ((tn (find-in-environment leaf (node-environment node))))
+ (if (lambda-var-indirect leaf)
+ (vop value-cell-set node block tn val-tn
+ (needs-remembering value))
+ (emit-move node block val-tn tn)))))
+ (global-var
+ (ecase (global-var-kind leaf)
+ ((:special :global)
+ (assert (symbolp (leaf-name leaf)))
+ (vop set node block (emit-constant (leaf-name leaf)) val-tn
+ (needs-remembering value))))))
+
+ (when locs
+ (emit-move node block val-tn (first locs))
+ (move-continuation-result node block locs cont)))
+ (values))
+
+#!+gengc
+(defoptimizer (%lexical-exit-breakup ir2-convert) ((info) node block)
+ (vop value-cell-set node block
+ (find-in-environment (continuation-value info) (node-environment node))
+ (emit-constant 0)
+ nil))
+
+#!+gengc
+(defoptimizer (%slot-setter ir2-convert) ((value str) node block)
+ (let ((val (continuation-tn node block value)))
+ (vop instance-set node block
+ (continuation-tn node block str)
+ val
+ (dsd-index
+ (slot-accessor-slot
+ (ref-leaf
+ (continuation-use
+ (combination-fun node)))))
+ (needs-remembering value))
+
+ (move-continuation-result node block (list val) (node-cont node))))
--- /dev/null
+;;;; some macros and constants that are object-format-specific or are
+;;;; used for defining the object format
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!VM")
+
+(file-comment
+ "$Header$")
+\f
+;;;; other miscellaneous stuff
+
+;;; This returns a form that returns a dual-word aligned number of bytes when
+;;; given a number of words.
+;;;
+;;; FIXME: should be a function
+;;; FIXME: should be called PAD-DATA-BLOCK-SIZE
+(defmacro pad-data-block (words)
+ `(logandc2 (+ (ash ,words word-shift) lowtag-mask) lowtag-mask))
+\f
+;;;; primitive object definition stuff
+
+(defun remove-keywords (options keywords)
+ (cond ((null options) nil)
+ ((member (car options) keywords)
+ (remove-keywords (cddr options) keywords))
+ (t
+ (list* (car options) (cadr options)
+ (remove-keywords (cddr options) keywords)))))
+
+(def!struct (prim-object-slot
+ (:constructor make-slot (name docs rest-p offset length options))
+ (:make-load-form-fun just-dump-it-normally)
+ (:conc-name slot-))
+ (name nil :type symbol)
+ (docs nil :type (or null simple-string))
+ (rest-p nil :type (member t nil))
+ (offset 0 :type fixnum)
+ (length 1 :type fixnum)
+ (options nil :type list))
+
+(def!struct (primitive-object (:make-load-form-fun just-dump-it-normally))
+ (name nil :type symbol)
+ (header nil :type symbol)
+ (lowtag nil :type symbol)
+ (options nil :type list)
+ (slots nil :type list)
+ (size 0 :type fixnum)
+ (variable-length nil :type (member t nil)))
+
+(defvar *primitive-objects* nil)
+
+(defun %define-primitive-object (primobj)
+ (let ((name (primitive-object-name primobj)))
+ (setf *primitive-objects*
+ (cons primobj
+ (remove name *primitive-objects*
+ :key #'primitive-object-name :test #'eq)))
+ name))
+
+(defmacro define-primitive-object
+ ((name &key header lowtag alloc-trans (type t))
+ &rest slot-specs)
+ (collect ((slots) (exports) (constants) (forms) (inits))
+ (let ((offset (if header 1 0))
+ (variable-length nil))
+ (dolist (spec slot-specs)
+ (when variable-length
+ (error "No more slots can follow a :rest-p slot."))
+ (destructuring-bind
+ (slot-name &rest options
+ &key docs rest-p (length (if rest-p 0 1))
+ ((:type slot-type) t) init
+ (ref-known nil ref-known-p) ref-trans
+ (set-known nil set-known-p) set-trans
+ &allow-other-keys)
+ (if (atom spec) (list spec) spec)
+ (slots (make-slot slot-name docs rest-p offset length
+ (remove-keywords options
+ '(:docs :rest-p :length))))
+ (let ((offset-sym (symbolicate name "-" slot-name
+ (if rest-p "-OFFSET" "-SLOT"))))
+ (constants `(defconstant ,offset-sym ,offset
+ ,@(when docs (list docs))))
+ (exports offset-sym))
+ (when ref-trans
+ (when ref-known-p
+ (forms `(defknown ,ref-trans (,type) ,slot-type ,ref-known)))
+ (forms `(def-reffer ,ref-trans ,offset ,lowtag)))
+ (when set-trans
+ (when set-known-p
+ (forms `(defknown ,set-trans
+ ,(if (listp set-trans)
+ (list slot-type type)
+ (list type slot-type))
+ ,slot-type
+ ,set-known)))
+ (forms `(def-setter ,set-trans ,offset ,lowtag)))
+ (when init
+ (inits (cons init offset)))
+ (when rest-p
+ (setf variable-length t))
+ (incf offset length)))
+ (unless variable-length
+ (let ((size (symbolicate name "-SIZE")))
+ (constants `(defconstant ,size ,offset
+ ,(format nil
+ "Number of slots used by each ~S~
+ ~@[~* including the header~]."
+ name header)))
+ (exports size)))
+ (when alloc-trans
+ (forms `(def-alloc ,alloc-trans ,offset ,variable-length ,header
+ ,lowtag ',(inits))))
+ `(progn
+ (let ((sb!int::*rogue-export* "DEFINE-PRIMITIVE-OBJECT"))
+ (export ',(exports)))
+ (eval-when (:compile-toplevel :load-toplevel :execute)
+ (%define-primitive-object
+ ',(make-primitive-object :name name
+ :header header
+ :lowtag lowtag
+ :slots (slots)
+ :size offset
+ :variable-length variable-length))
+ ,@(constants))
+ ,@(forms)))))
+\f
+;;;; stuff for defining reffers and setters
+
+(in-package "SB!C")
+
+(defun %def-reffer (name offset lowtag)
+ (let ((info (function-info-or-lose name)))
+ (setf (function-info-ir2-convert info)
+ #'(lambda (node block)
+ (ir2-convert-reffer node block name offset lowtag))))
+ name)
+
+(defmacro def-reffer (name offset lowtag)
+ `(%def-reffer ',name ,offset ,lowtag))
+
+(defun %def-setter (name offset lowtag)
+ (let ((info (function-info-or-lose name)))
+ (setf (function-info-ir2-convert info)
+ (if (listp name)
+ #'(lambda (node block)
+ (ir2-convert-setfer node block name offset lowtag))
+ #'(lambda (node block)
+ (ir2-convert-setter node block name offset lowtag)))))
+ name)
+
+(defmacro def-setter (name offset lowtag)
+ `(%def-setter ',name ,offset ,lowtag))
+
+(defun %def-alloc (name words variable-length header lowtag inits)
+ (let ((info (function-info-or-lose name)))
+ (setf (function-info-ir2-convert info)
+ (if variable-length
+ #'(lambda (node block)
+ (ir2-convert-variable-allocation node block name words header
+ lowtag inits))
+ #'(lambda (node block)
+ (ir2-convert-fixed-allocation node block name words header
+ lowtag inits)))))
+ name)
+
+(defmacro def-alloc (name words variable-length header lowtag inits)
+ `(%def-alloc ',name ,words ,variable-length ,header ,lowtag ,inits))
+\f
+;;;; some general constant definitions
+
+;;; FIXME: SC-NUMBER-LIMIT should probably be exported from SB!C
+;;; or SB!VM so that we don't need to do this extra IN-PACKAGE.
+(in-package "SB!C")
+
+;;; the maximum number of SCs in any implementation
+(defconstant sc-number-limit 32)
--- /dev/null
+;;;; implementation-dependent transforms
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!C")
+
+(file-comment
+ "$Header$")
+
+;;; FIXME: It would be good to implement SB!XC:DEFCONSTANT, and use
+;;; use that here, so that the compiler is born knowing this value.
+;;; FIXME: Add a comment telling whether this holds for all vectors
+;;; or only for vectors based on simple arrays (non-adjustable, etc.).
+(defconstant vector-data-bit-offset
+ (* sb!vm:vector-data-offset sb!vm:word-bits))
+
+;;; We need to define these predicates, since the TYPEP source transform picks
+;;; whichever predicate was defined last when there are multiple predicates for
+;;; equivalent types.
+(def-source-transform short-float-p (x) `(single-float-p ,x))
+#!-long-float
+(def-source-transform long-float-p (x) `(double-float-p ,x))
+
+(def-source-transform compiled-function-p (x)
+ `(functionp ,x))
+
+(def-source-transform char-int (x)
+ `(char-code ,x))
+
+(deftransform abs ((x) (rational))
+ '(if (< x 0) (- x) x))
+
+;;; The layout is stored in slot 0.
+(def-source-transform %instance-layout (x)
+ `(truly-the layout (%instance-ref ,x 0)))
+(def-source-transform %set-instance-layout (x val)
+ `(%instance-set ,x 0 (the layout ,val)))
+\f
+;;;; character support
+
+;;; In our implementation there are really only BASE-CHARs.
+(def-source-transform characterp (obj)
+ `(base-char-p ,obj))
+\f
+;;;; simplifying HAIRY-DATA-VECTOR-REF and HAIRY-DATA-VECTOR-SET
+
+(deftransform hairy-data-vector-ref ((array index) (array t) * :important t)
+ "avoid runtime dispatch on array element type"
+ (let ((element-ctype (extract-upgraded-element-type array)))
+ (declare (type ctype element-ctype))
+ (when (eq *wild-type* element-ctype)
+ (give-up-ir1-transform
+ "Upgraded element type of array is not known at compile time."))
+ ;; (The expansion here is basically a degenerate case of
+ ;; WITH-ARRAY-DATA. Since WITH-ARRAY-DATA is implemented as a
+ ;; macro, and macros aren't expanded in transform output, we have
+ ;; to hand-expand it ourselves.)
+ (let ((element-type-specifier (type-specifier element-ctype)))
+ `(multiple-value-bind (array index)
+ ;; FIXME: All this noise should move into a
+ ;; %DATA-VECTOR-AND-INDEX function, and there should be
+ ;; DEFTRANSFORMs for %DATA-VECTOR-AND-INDEX to optimize the
+ ;; function call away when the array is known to be simple,
+ ;; and to specialize to
+ ;; %DATA-VECTOR-AND-INDEX-IN-VECTOR-CASE when the array is
+ ;; known to have only one dimension.
+ (if (array-header-p array)
+ (%with-array-data array index nil)
+ (let ((array array))
+ (declare (type (simple-array ,element-type-specifier 1)
+ array))
+ (%check-bound array 0 index)
+ (values array index)))
+ (declare (type (simple-array ,element-type-specifier 1) array))
+ (data-vector-ref array index)))))
+
+(deftransform data-vector-ref ((array index)
+ (simple-array t))
+ (let ((array-type (continuation-type array)))
+ (unless (array-type-p array-type)
+ (give-up-ir1-transform))
+ (let ((dims (array-type-dimensions array-type)))
+ (when (or (atom dims) (= (length dims) 1))
+ (give-up-ir1-transform))
+ (let ((el-type (array-type-element-type array-type))
+ (total-size (if (member '* dims)
+ '*
+ (reduce #'* dims))))
+ `(data-vector-ref (truly-the (simple-array ,(type-specifier el-type)
+ (,total-size))
+ (%array-data-vector array))
+ index)))))
+
+(deftransform hairy-data-vector-set ((array index new-value)
+ (array t t)
+ *
+ :important t)
+ "avoid runtime dispatch on array element type"
+ (let ((element-ctype (extract-upgraded-element-type array)))
+ (declare (type ctype element-ctype))
+ (when (eq *wild-type* element-ctype)
+ (give-up-ir1-transform
+ "Upgraded element type of array is not known at compile time."))
+ (let ((element-type-specifier (type-specifier element-ctype)))
+ `(multiple-value-bind (array index)
+ ;; FIXME: All this noise should move into a
+ ;; %DATA-VECTOR-AND-INDEX function, and there should be
+ ;; DEFTRANSFORMs for %DATA-VECTOR-AND-INDEX to optimize the
+ ;; function call away when the array is known to be simple,
+ ;; and to specialize to
+ ;; %DATA-VECTOR-AND-INDEX-IN-VECTOR-CASE when the array is
+ ;; known to have only one dimension.
+ (if (array-header-p array)
+ (%with-array-data array index nil)
+ (let ((array array))
+ (declare (type (simple-array ,element-type-specifier 1)
+ array))
+ (%check-bound array 0 index)
+ (values array index)))
+ (data-vector-set (truly-the (simple-array ,element-type-specifier 1)
+ array)
+ index
+ new-value)))))
+
+(deftransform data-vector-set ((array index new-value)
+ (simple-array t t))
+ (let ((array-type (continuation-type array)))
+ (unless (array-type-p array-type)
+ (give-up-ir1-transform))
+ (let ((dims (array-type-dimensions array-type)))
+ (when (or (atom dims) (= (length dims) 1))
+ (give-up-ir1-transform))
+ (let ((el-type (array-type-element-type array-type))
+ (total-size (if (member '* dims)
+ '*
+ (reduce #'* dims))))
+ `(data-vector-set (truly-the (simple-array ,(type-specifier el-type)
+ (,total-size))
+ (%array-data-vector array))
+ index
+ new-value)))))
+
+;;; transforms for getting at simple arrays of (UNSIGNED-BYTE N) when (< N 8)
+;;;
+;;; FIXME: In CMU CL, these were commented out with #+NIL. Why? Should
+;;; we fix them or should we delete them? (Perhaps these definitions
+;;; predate the various DATA-VECTOR-REF-FOO VOPs which have
+;;; (:TRANSLATE DATA-VECTOR-REF), and are redundant now?)
+#+nil
+(macrolet
+ ((frob (type bits)
+ (let ((elements-per-word (truncate sb!vm:word-bits bits)))
+ `(progn
+ (deftransform data-vector-ref ((vector index)
+ (,type *))
+ `(multiple-value-bind (word bit)
+ (floor index ,',elements-per-word)
+ (ldb ,(ecase sb!vm:target-byte-order
+ (:little-endian '(byte ,bits (* bit ,bits)))
+ (:big-endian '(byte ,bits (- sb!vm:word-bits
+ (* (1+ bit) ,bits)))))
+ (%raw-bits vector (+ word sb!vm:vector-data-offset)))))
+ (deftransform data-vector-set ((vector index new-value)
+ (,type * *))
+ `(multiple-value-bind (word bit)
+ (floor index ,',elements-per-word)
+ (setf (ldb ,(ecase sb!vm:target-byte-order
+ (:little-endian '(byte ,bits (* bit ,bits)))
+ (:big-endian
+ '(byte ,bits (- sb!vm:word-bits
+ (* (1+ bit) ,bits)))))
+ (%raw-bits vector (+ word sb!vm:vector-data-offset)))
+ new-value)))))))
+ (frob simple-bit-vector 1)
+ (frob (simple-array (unsigned-byte 2) (*)) 2)
+ (frob (simple-array (unsigned-byte 4) (*)) 4))
+\f
+;;;; simple string transforms
+
+(deftransform subseq ((string start &optional (end nil))
+ (simple-string t &optional t))
+ `(let* ((length (- (or end (length string))
+ start))
+ (result (make-string length)))
+ (declare (optimize (safety 0)))
+ (bit-bash-copy string
+ (the index
+ (+ (the index (* start sb!vm:byte-bits))
+ ,vector-data-bit-offset))
+ result
+ ,vector-data-bit-offset
+ (the index (* length sb!vm:byte-bits)))
+ result))
+
+(deftransform copy-seq ((seq) (simple-string))
+ `(let* ((length (length seq))
+ (res (make-string length)))
+ (declare (optimize (safety 0)))
+ (bit-bash-copy seq
+ ,vector-data-bit-offset
+ res
+ ,vector-data-bit-offset
+ (the index (* length sb!vm:byte-bits)))
+ res))
+
+(deftransform replace ((string1 string2 &key (start1 0) (start2 0)
+ end1 end2)
+ (simple-string simple-string &rest t))
+ `(locally (declare (optimize (safety 0)))
+ (bit-bash-copy string2
+ (the index
+ (+ (the index (* start2 sb!vm:byte-bits))
+ ,vector-data-bit-offset))
+ string1
+ (the index
+ (+ (the index (* start1 sb!vm:byte-bits))
+ ,vector-data-bit-offset))
+ (the index
+ (* (min (the index (- (or end1 (length string1))
+ start1))
+ (the index (- (or end2 (length string2))
+ start2)))
+ sb!vm:byte-bits)))
+ string1))
+
+(deftransform concatenate ((rtype &rest sequences)
+ (t &rest simple-string)
+ simple-string)
+ (collect ((lets)
+ (forms)
+ (all-lengths)
+ (args))
+ (dolist (seq sequences)
+ (declare (ignore seq))
+ (let ((n-seq (gensym))
+ (n-length (gensym)))
+ (args n-seq)
+ (lets `(,n-length (the index (* (length ,n-seq) sb!vm:byte-bits))))
+ (all-lengths n-length)
+ (forms `(bit-bash-copy ,n-seq ,vector-data-bit-offset
+ res start
+ ,n-length))
+ (forms `(setq start (+ start ,n-length)))))
+ `(lambda (rtype ,@(args))
+ (declare (ignore rtype))
+ (let* (,@(lets)
+ (res (make-string (truncate (the index (+ ,@(all-lengths)))
+ sb!vm:byte-bits)))
+ (start ,vector-data-bit-offset))
+ (declare (type index start ,@(all-lengths)))
+ ,@(forms)
+ res))))
+\f
+;;;; bit vector hackery
+
+;;; SIMPLE-BIT-VECTOR bit-array operations are transformed to a word loop that
+;;; does 32 bits at a time.
+;;;
+;;; FIXME: This is a lot of repeatedly macroexpanded code. It should be a
+;;; function call instead. And do it with DEF-FROB instead of DOLIST.
+(dolist (x '((bit-and 32bit-logical-and)
+ (bit-ior 32bit-logical-or)
+ (bit-xor 32bit-logical-xor)
+ (bit-eqv 32bit-logical-eqv)
+ (bit-nand 32bit-logical-nand)
+ (bit-nor 32bit-logical-nor)
+ (bit-andc1 32bit-logical-andc1)
+ (bit-andc2 32bit-logical-andc2)
+ (bit-orc1 32bit-logical-orc1)
+ (bit-orc2 32bit-logical-orc2)))
+ (destructuring-bind (bitfun wordfun) x
+ (deftransform bitfun
+ ((bit-array-1 bit-array-2 result-bit-array)
+ '(simple-bit-vector simple-bit-vector simple-bit-vector) '*
+ :eval-name t :node node :policy (>= speed space))
+ `(progn
+ ,@(unless (policy node (zerop safety))
+ '((unless (= (length bit-array-1) (length bit-array-2)
+ (length result-bit-array))
+ (error "Argument and/or result bit arrays are not the same length:~
+ ~% ~S~% ~S ~% ~S"
+ bit-array-1 bit-array-2 result-bit-array))))
+ (do ((index sb!vm:vector-data-offset (1+ index))
+ (end (+ sb!vm:vector-data-offset
+ (truncate (the index
+ (+ (length bit-array-1)
+ sb!vm:word-bits -1))
+ sb!vm:word-bits))))
+ ((= index end) result-bit-array)
+ (declare (optimize (speed 3) (safety 0))
+ (type index index end))
+ (setf (%raw-bits result-bit-array index)
+ (,wordfun (%raw-bits bit-array-1 index)
+ (%raw-bits bit-array-2 index))))))))
+
+(deftransform bit-not
+ ((bit-array result-bit-array)
+ (simple-bit-vector simple-bit-vector) *
+ :node node :policy (>= speed space))
+ `(progn
+ ,@(unless (policy node (zerop safety))
+ '((unless (= (length bit-array)
+ (length result-bit-array))
+ (error "Argument and result bit arrays are not the same length:~
+ ~% ~S~% ~S"
+ bit-array result-bit-array))))
+ (do ((index sb!vm:vector-data-offset (1+ index))
+ (end (+ sb!vm:vector-data-offset
+ (truncate (the index
+ (+ (length bit-array)
+ (1- sb!vm:word-bits)))
+ sb!vm:word-bits))))
+ ((= index end) result-bit-array)
+ (declare (optimize (speed 3) (safety 0))
+ (type index index end))
+ (setf (%raw-bits result-bit-array index)
+ (32bit-logical-not (%raw-bits bit-array index))))))
+\f
+;;;; primitive translator for BYTE-BLT
+
+(def-primitive-translator byte-blt (src src-start dst dst-start dst-end)
+ `(let ((src ,src)
+ (src-start (* ,src-start sb!vm:byte-bits))
+ (dst ,dst)
+ (dst-start (* ,dst-start sb!vm:byte-bits))
+ (dst-end (* ,dst-end sb!vm:byte-bits)))
+ (let ((length (- dst-end dst-start)))
+ (etypecase src
+ (system-area-pointer
+ (etypecase dst
+ (system-area-pointer
+ (system-area-copy src src-start dst dst-start length))
+ ((simple-unboxed-array (*))
+ (copy-from-system-area src src-start
+ dst (+ dst-start ,vector-data-bit-offset)
+ length))))
+ ((simple-unboxed-array (*))
+ (etypecase dst
+ (system-area-pointer
+ (copy-to-system-area src (+ src-start ,vector-data-bit-offset)
+ dst dst-start
+ length))
+ ((simple-unboxed-array (*))
+ (bit-bash-copy src (+ src-start ,vector-data-bit-offset)
+ dst (+ dst-start ,vector-data-bit-offset)
+ length))))))))
+\f
+;;;; transforms for EQL of floating point values
+
+(deftransform eql ((x y) (single-float single-float))
+ '(= (single-float-bits x) (single-float-bits y)))
+
+(deftransform eql ((x y) (double-float double-float))
+ '(and (= (double-float-low-bits x) (double-float-low-bits y))
+ (= (double-float-high-bits x) (double-float-high-bits y))))
--- /dev/null
+;;;; This file contains implementation-dependent parts of the type
+;;;; support code. This is stuff which deals with the mapping from
+;;;; types defined in Common Lisp to types actually supported by an
+;;;; implementation.
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!KERNEL")
+
+(file-comment
+ "$Header$")
+
+(!begin-collecting-cold-init-forms)
+\f
+;;;; FIXME: I'm not sure where to put this. -- WHN 19990817
+
+(deftype sb!vm:word () `(unsigned-byte ,sb!vm:word-bits))
+\f
+;;;; implementation-dependent DEFTYPEs
+
+;;; Make DOUBLE-FLOAT a synonym for LONG-FLOAT, SINGLE-FLOAT for SHORT-FLOAT.
+;;; This is expanded before the translator gets a chance, so we will get
+;;; precedence.
+#!-long-float
+(setf (info :type :kind 'long-float) :defined)
+#!-long-float
+(sb!xc:deftype long-float (&optional low high)
+ `(double-float ,low ,high))
+(setf (info :type :kind 'short-float) :defined)
+(sb!xc:deftype short-float (&optional low high)
+ `(single-float ,low ,high))
+
+;;; an index into an integer
+(sb!xc:deftype bit-index () `(integer 0 ,most-positive-fixnum))
+
+;;; worst-case values for float attributes
+(sb!xc:deftype float-exponent ()
+ #!-long-float 'double-float-exponent
+ #!+long-float 'long-float-exponent)
+(sb!xc:deftype float-digits ()
+ #!-long-float `(integer 0 ,sb!vm:double-float-digits)
+ #!+long-float `(integer 0 ,sb!vm:long-float-digits))
+(sb!xc:deftype float-radix () '(integer 2 2))
+
+;;; a code for BOOLE
+(sb!xc:deftype boole-code () '(unsigned-byte 4))
+
+;;; a byte specifier (as generated by BYTE)
+(sb!xc:deftype byte-specifier () 'cons)
+
+;;; result of CHAR-INT
+(sb!xc:deftype char-int () 'char-code)
+
+;;; PATHNAME pieces, as returned by the PATHNAME-xxx functions
+(sb!xc:deftype pathname-host () '(or sb!impl::host null))
+(sb!xc:deftype pathname-device ()
+ '(or simple-string (member nil :unspecific)))
+(sb!xc:deftype pathname-directory () 'list)
+(sb!xc:deftype pathname-name ()
+ '(or simple-string sb!impl::pattern (member nil :unspecific :wild)))
+(sb!xc:deftype pathname-type ()
+ '(or simple-string sb!impl::pattern (member nil :unspecific :wild)))
+(sb!xc:deftype pathname-version ()
+ '(or integer (member nil :newest :wild :unspecific)))
+
+;;; internal time format. (Note: not a FIXNUM, ouch..)
+(sb!xc:deftype internal-time () 'unsigned-byte)
+
+(sb!xc:deftype bignum-element-type () `(unsigned-byte ,sb!vm:word-bits))
+(sb!xc:deftype bignum-type () 'bignum)
+(sb!xc:deftype bignum-index () 'index)
+\f
+;;;; hooks into the type system
+
+;;; the kinds of specialized array that actually exist in this implementation
+(defvar *specialized-array-element-types*)
+(!cold-init-forms
+ (setf *specialized-array-element-types*
+ '(bit
+ (unsigned-byte 2)
+ (unsigned-byte 4)
+ (unsigned-byte 8)
+ (unsigned-byte 16)
+ (unsigned-byte 32)
+ (signed-byte 8)
+ (signed-byte 16)
+ (signed-byte 30)
+ (signed-byte 32)
+ (complex single-float)
+ (complex double-float)
+ #!+long-float (complex long-float)
+ base-char
+ single-float
+ double-float
+ #!+long-float long-float)))
+
+(sb!xc:deftype unboxed-array (&optional dims)
+ (collect ((types (list 'or)))
+ (dolist (type *specialized-array-element-types*)
+ (when (subtypep type '(or integer character float (complex float)))
+ (types `(array ,type ,dims))))
+ (types)))
+
+(sb!xc:deftype simple-unboxed-array (&optional dims)
+ (collect ((types (list 'or)))
+ (dolist (type *specialized-array-element-types*)
+ (when (subtypep type '(or integer character float (complex float)))
+ (types `(simple-array ,type ,dims))))
+ (types)))
+
+;;; Return the symbol that describes the format of FLOAT.
+(declaim (ftype (function (float) symbol) float-format-name))
+(defun float-format-name (x)
+ (etypecase x
+ (single-float 'single-float)
+ (double-float 'double-float)
+ #!+long-float (long-float 'long-float)))
+
+;;; This function is called when the type code wants to find out how
+;;; an array will actually be implemented. We set the
+;;; Specialized-Element-Type to correspond to the actual
+;;; specialization used in this implementation.
+(declaim (ftype (function (array-type) array-type) specialize-array-type))
+(defun specialize-array-type (type)
+ (let ((eltype (array-type-element-type type)))
+ (setf (array-type-specialized-element-type type)
+ (if (eq eltype *wild-type*)
+ *wild-type*
+ (dolist (stype-name *specialized-array-element-types*
+ ;; FIXME: Use *UNIVERSAL-TYPE* here?
+ (specifier-type 't))
+ ;; FIXME: Mightn't it be better to have
+ ;; *SPECIALIZED-ARRAY-ELEMENT-TYPES* be stored as precalculated
+ ;; SPECIFIER-TYPE results, instead of having to calculate
+ ;; them on the fly this way? (Call the new array
+ ;; *SPECIALIZED-ARRAY-ELEMENT-SPECIFIER-TYPES* or something..)
+ (let ((stype (specifier-type stype-name)))
+ (when (csubtypep eltype stype)
+ (return stype))))))
+ type))
+
+;;; Return the most specific integer type that can be quickly checked that
+;;; includes the given type.
+(defun containing-integer-type (subtype)
+ (dolist (type '(fixnum
+ (signed-byte 32)
+ (unsigned-byte 32)
+ integer)
+ (error "~S isn't an integer type?" subtype))
+ (when (csubtypep subtype (specifier-type type))
+ (return type))))
+
+;;; If Type has a CHECK-xxx template, but doesn't have a corresponding
+;;; primitive-type, then return the template's name. Otherwise, return NIL.
+(defun hairy-type-check-template-name (type)
+ (declare (type ctype type))
+ (typecase type
+ (named-type
+ (case (named-type-name type)
+ (cons 'sb!c:check-cons)
+ (symbol 'sb!c:check-symbol)
+ (t nil)))
+ (numeric-type
+ (cond ((type= type (specifier-type 'fixnum))
+ 'sb!c:check-fixnum)
+ ((type= type (specifier-type '(signed-byte 32)))
+ 'sb!c:check-signed-byte-32)
+ ((type= type (specifier-type '(unsigned-byte 32)))
+ 'sb!c:check-unsigned-byte-32)
+ (t nil)))
+ (function-type
+ 'sb!c:check-function)
+ (t
+ nil)))
+\f
+(!defun-from-collected-cold-init-forms !vm-type-cold-init)
--- /dev/null
+;;;; This file contains the implementation specific type
+;;;; transformation magic. Basically, the various non-standard
+;;;; predicates that can be used in TYPEP transformations.
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!C")
+
+(file-comment
+ "$Header$")
+\f
+;;;; internal predicates
+
+;;; These type predicates are used to implement simple cases of TYPEP.
+;;; They shouldn't be used explicitly.
+(define-type-predicate base-char-p base-char)
+(define-type-predicate bignump bignum)
+(define-type-predicate complex-double-float-p (complex double-float))
+(define-type-predicate complex-single-float-p (complex single-float))
+#!+long-float
+(define-type-predicate complex-long-float-p (complex long-float))
+;;; (COMPLEX-VECTOR-P isn't here because it's not so much a Lisp-level
+;;; type predicate as just a hack to get at the type code so that we
+;;; can implement some primitive stuff in Lisp.)
+(define-type-predicate double-float-p double-float)
+(define-type-predicate fixnump fixnum)
+(define-type-predicate long-float-p long-float)
+(define-type-predicate ratiop ratio)
+(define-type-predicate short-float-p short-float)
+(define-type-predicate single-float-p single-float)
+(define-type-predicate simple-array-p simple-array)
+(define-type-predicate simple-array-unsigned-byte-2-p
+ (simple-array (unsigned-byte 2) (*)))
+(define-type-predicate simple-array-unsigned-byte-4-p
+ (simple-array (unsigned-byte 4) (*)))
+(define-type-predicate simple-array-unsigned-byte-8-p
+ (simple-array (unsigned-byte 8) (*)))
+(define-type-predicate simple-array-unsigned-byte-16-p
+ (simple-array (unsigned-byte 16) (*)))
+(define-type-predicate simple-array-unsigned-byte-32-p
+ (simple-array (unsigned-byte 32) (*)))
+(define-type-predicate simple-array-signed-byte-8-p
+ (simple-array (signed-byte 8) (*)))
+(define-type-predicate simple-array-signed-byte-16-p
+ (simple-array (signed-byte 16) (*)))
+(define-type-predicate simple-array-signed-byte-30-p
+ (simple-array (signed-byte 30) (*)))
+(define-type-predicate simple-array-signed-byte-32-p
+ (simple-array (signed-byte 32) (*)))
+(define-type-predicate simple-array-single-float-p
+ (simple-array single-float (*)))
+(define-type-predicate simple-array-double-float-p
+ (simple-array double-float (*)))
+#!+long-float
+(define-type-predicate simple-array-long-float-p
+ (simple-array long-float (*)))
+(define-type-predicate simple-array-complex-single-float-p
+ (simple-array (complex single-float) (*)))
+(define-type-predicate simple-array-complex-double-float-p
+ (simple-array (complex double-float) (*)))
+#!+long-float
+(define-type-predicate simple-array-complex-long-float-p
+ (simple-array (complex long-float) (*)))
+(define-type-predicate system-area-pointer-p system-area-pointer)
+(define-type-predicate unsigned-byte-32-p (unsigned-byte 32))
+(define-type-predicate signed-byte-32-p (signed-byte 32))
+(define-type-predicate vector-t-p (vector t))
+(define-type-predicate weak-pointer-p weak-pointer)
+(define-type-predicate code-component-p code-component)
+(define-type-predicate lra-p lra)
+(define-type-predicate fdefn-p fdefn)
+
+;;; Unlike the un-%'ed versions, these are true type predicates,
+;;; accepting any type object.
+(define-type-predicate %standard-char-p standard-char)
--- /dev/null
+;;;; This file provides a functional interface to global information
+;;;; about named things in the system. Information is considered to be
+;;;; global if it must persist between invocations of the compiler. The
+;;;; use of a functional interface eliminates the need for the compiler
+;;;; to worry about the actual representation. This is important, since
+;;;; the information may well have several representations.
+;;;;
+;;;; The database contains arbitrary Lisp values, addressed by a
+;;;; combination of Name, Class and Type. The Name is a EQUAL-thing
+;;;; which is the name of the thing we are recording information
+;;;; about. Class is the kind of object involved. Typical classes are
+;;;; :FUNCTION, :VARIABLE, :TYPE, ... A Type names a particular piece
+;;;; of information within a given class. Class and Type are keywords,
+;;;; and are compared with EQ.
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!C")
+
+(file-comment
+ "$Header$")
+
+(!begin-collecting-cold-init-forms)
+
+;;; The DEFVAR for this appears later.
+;;; FIXME: centralize
+(declaim (special *universal-type*))
+
+;;; This is sorta semantically equivalent to SXHASH, but optimized for legal
+;;; function names. Note: semantically equivalent does *not* mean that it
+;;; always returns the same value as SXHASH, just that it satisfies the formal
+;;; definition of SXHASH. The ``sorta'' is because SYMBOL-HASH will not
+;;; necessarily return the same value in different lisp images.
+;;;
+;;; Why optimize? We want to avoid the fully-general TYPECASE in ordinary
+;;; SXHASH, because
+;;; 1. This hash function has to run when we're initializing the globaldb,
+;;; so it has to run before the type system is initialized, and it's
+;;; easier to make it do this if we don't try to do a general TYPECASE.
+;;; 2. This function is in a potential bottleneck for the compiler,
+;;; and avoiding the general TYPECASE lets us improve performance
+;;; because
+;;; 2a. the general TYPECASE is intrinsically slow, and
+;;; 2b. the general TYPECASE is too big for us to easily afford
+;;; to inline it, so it brings with it a full function call.
+;;;
+;;; Why not specialize instead of optimize? (I.e. why fall through to
+;;; general SXHASH as a last resort?) Because the INFO database is used
+;;; to hold all manner of things, e.g. (INFO :TYPE :BUILTIN ..)
+;;; which is called on values like (UNSIGNED-BYTE 29). Falling through
+;;; to SXHASH lets us support all manner of things (as long as they
+;;; aren't used too early in cold boot).
+#!-sb-fluid (declaim (inline globaldb-sxhashoid))
+(defun globaldb-sxhashoid (x)
+ (cond #-sb-xc-host ; (SYMBOL-HASH doesn't exist on cross-compilation host.)
+ ((symbolp x)
+ (symbol-hash x))
+ #-sb-xc-host ; (SYMBOL-HASH doesn't exist on cross-compilation host.)
+ ((and (listp x)
+ (eq (first x) 'setf)
+ (let ((rest (rest x)))
+ (and (symbolp (car rest))
+ (null (cdr rest)))))
+ (logxor (symbol-hash (second x))
+ 110680597))
+ (t (sxhash x))))
+
+;;; Given any non-negative integer, return a prime number >= to it.
+;;;
+;;; FIXME: This logic should be shared with ALMOST-PRIMIFY in hash-table.lisp.
+;;; Perhaps the merged logic should be PRIMIFY-HASH-TABLE-SIZE, implemented as
+;;; a lookup table of primes after integral powers of two:
+;;; #(17 37 67 131 ..)
+;;; (Or, if that's too coarse, after half-integral powers of two.) By thus
+;;; getting rid of any need for primality testing at runtime, we could
+;;; punt POSITIVE-PRIMEP, too.
+(defun primify (x)
+ (declare (type unsigned-byte x))
+ (do ((n (logior x 1) (+ n 2)))
+ ((sb!sys:positive-primep n)
+ n)))
+\f
+;;;; info classes, info types, and type numbers, part I: what's needed not only
+;;;; at compile time but also at run time
+
+;;;; Note: This section is a blast from the past, a little trip down memory
+;;;; lane to revisit the weird host/target interactions of the CMU CL build
+;;;; process. Because of the way that the cross-compiler and target compiler
+;;;; share stuff here, if you change anything in here, you'd be well-advised to
+;;;; nuke all your fasl files and restart compilation from the very beginning
+;;;; of the bootstrap process.
+
+;;; Why do we suppress the :COMPILE-TOPLEVEL situation here when we're running
+;;; the cross-compiler? The cross-compiler (which was built from these sources)
+;;; has its version of these data and functions defined in the same places we'd
+;;; be defining into. We're happy with its version, since it was compiled from
+;;; the same sources, so there's no point in overwriting its nice compiled
+;;; version of this stuff with our interpreted version. (And any time we're
+;;; *not* happy with its version, perhaps because we've been editing the
+;;; sources partway through bootstrapping, tch tch, overwriting its version
+;;; with our version would be unlikely to help, because that would make the
+;;; cross-compiler very confused.)
+(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
+
+(defstruct (class-info
+ (:constructor make-class-info (name))
+ #-no-ansi-print-object
+ (:print-object (lambda (x s)
+ (print-unreadable-object (x s :type t)
+ (prin1 (class-info-name x))))))
+ ;; name of this class
+ (name nil :type keyword :read-only t)
+ ;; List of Type-Info structures for each type in this class.
+ (types () :type list))
+
+;;; At run time, we represent the type of info that we want by a small
+;;; non-negative integer.
+(defconstant type-number-bits 6)
+(deftype type-number () `(unsigned-byte ,type-number-bits))
+
+;;; a map from type numbers to TYPE-INFO objects. There is one type
+;;; number for each defined CLASS/TYPE pair.
+;;;
+;;; We build its value at compile time (with calls to DEFINE-INFO-TYPE), then
+;;; generate code to recreate the compile time value, and arrange for that
+;;; code to be called in cold load.
+(defvar *info-types*)
+(declaim (type simple-vector *info-types*))
+(eval-when (:compile-toplevel :execute)
+ (setf *info-types*
+ (make-array (ash 1 type-number-bits) :initial-element nil)))
+
+(defstruct (type-info
+ #-no-ansi-print-object
+ (:print-object (lambda (x s)
+ (print-unreadable-object (x s)
+ (format s
+ "~S ~S, Number = ~D"
+ (class-info-name (type-info-class x))
+ (type-info-name x)
+ (type-info-number x))))))
+ ;; the name of this type
+ (name (required-argument) :type keyword)
+ ;; this type's class
+ (class (required-argument) :type class-info)
+ ;; a number that uniquely identifies this type (and implicitly its class)
+ (number (required-argument) :type type-number)
+ ;; a type specifier which info of this type must satisfy
+ (type nil :type t)
+ ;; a function called when there is no information of this type
+ (default (lambda () (error "type not defined yet")) :type function))
+
+;;; a map from class names to CLASS-INFO structures
+;;;
+;;; We build the value for this at compile time (with calls to
+;;; DEFINE-INFO-CLASS), then generate code to recreate the compile time
+;;; value, and arrange for that code to be called in cold load.
+(defvar *info-classes*)
+(declaim (hash-table *info-classes*))
+(eval-when (:compile-toplevel :execute)
+ (setf *info-classes* (make-hash-table)))
+
+;;; If Name is the name of a type in Class, then return the TYPE-INFO,
+;;; otherwise NIL.
+(defun find-type-info (name class)
+ (declare (type keyword name) (type class-info class))
+ (dolist (type (class-info-types class) nil)
+ (when (eq (type-info-name type) name)
+ (return type))))
+
+;;; Return the info structure for an info class or type, or die trying.
+(declaim (ftype (function (keyword) class-info) class-info-or-lose))
+(defun class-info-or-lose (class)
+ (declare (type keyword class))
+ (or (gethash class *info-classes*)
+ (error "~S is not a defined info class." class)))
+(declaim (ftype (function (keyword keyword) type-info) type-info-or-lose))
+(defun type-info-or-lose (class type)
+ (or (find-type-info type (class-info-or-lose class))
+ (error "~S is not a defined info type." type)))
+
+) ; EVAL-WHEN
+\f
+;;;; info classes, info types, and type numbers, part II: what's needed only at
+;;;; compile time, not at run time
+
+;;; FIXME: Perhaps this stuff (the definition of DEFINE-INFO-CLASS
+;;; and the calls to it) could/should go in a separate file,
+;;; perhaps info-classes.lisp?
+
+(eval-when (:compile-toplevel :execute)
+
+;;; Set up the data structures to support an info class. We make sure that
+;;; the class exists at compile time so that macros can use it, but don't
+;;; actually store the init function until load time so that we don't break the
+;;; running compiler.
+(#+sb-xc-host defmacro
+ #-sb-xc-host sb!xc:defmacro
+ define-info-class (class)
+ #!+sb-doc
+ "Define-Info-Class Class
+ Define a new class of global information."
+ (declare (type keyword class))
+ `(progn
+ ;; (We don't need to evaluate this at load time, compile time is enough.
+ ;; There's special logic elsewhere which deals with cold load
+ ;; initialization by inspecting the info class data structures at compile
+ ;; time and generating code to recreate those data structures.)
+ (eval-when (:compile-toplevel :execute)
+ (unless (gethash ,class *info-classes*)
+ (setf (gethash ,class *info-classes*) (make-class-info ,class))))
+ ,class))
+
+;;; Find a type number not already in use by looking for a null entry in
+;;; *INFO-TYPES*.
+(defun find-unused-type-number ()
+ (or (position nil *info-types*)
+ (error "no more INFO type numbers available")))
+
+;;; a list of forms for initializing the DEFAULT slots of TYPE-INFO objects,
+;;; accumulated during compilation and eventually converted into a function to
+;;; be called at cold load time after the appropriate TYPE-INFO objects have
+;;; been created
+;;;
+;;; Note: This is quite similar to the !COLD-INIT-FORMS machinery, but
+;;; we can't conveniently use the ordinary !COLD-INIT-FORMS machinery
+;;; here. The problem is that the natural order in which the
+;;; default-slot-initialization forms are generated relative to the
+;;; order in which the TYPE-INFO-creation forms are generated doesn't
+;;; match the relative order in which the forms need to be executed at
+;;; cold load time.
+(defparameter *reversed-type-info-init-forms* nil)
+
+;;; The main thing we do is determine the type's number. We need to do this
+;;; at macroexpansion time, since both the COMPILE and LOAD time calls to
+;;; %DEFINE-INFO-TYPE must use the same type number.
+(#+sb-xc-host defmacro
+ #-sb-xc-host sb!xc:defmacro
+ define-info-type (&key (class (required-argument))
+ (type (required-argument))
+ (type-spec (required-argument))
+ default)
+ #!+sb-doc
+ "Define-Info-Type Class Type default Type-Spec
+ Define a new type of global information for Class. Type is the name
+ of the type, Default is the value for that type when it hasn't been set, and
+ Type-Spec is a type-specifier which values of the type must satisfy. The
+ default expression is evaluated each time the information is needed, with
+ Name bound to the name for which the information is being looked up. If the
+ default evaluates to something with the second value true, then the second
+ value of Info will also be true."
+ (declare (type keyword class type))
+ `(progn
+ (eval-when (:compile-toplevel :execute)
+ ;; At compile time, ensure that the type number exists. It will need
+ ;; to be forced to exist at cold load time, too, but that's not handled
+ ;; here; it's handled by later code which looks at the compile time
+ ;; state and generates code to replicate it at cold load time.
+ (let* ((class-info (class-info-or-lose ',class))
+ (old-type-info (find-type-info ',type class-info)))
+ (unless old-type-info
+ (let* ((new-type-number (find-unused-type-number))
+ (new-type-info
+ (make-type-info :name ',type
+ :class class-info
+ :number new-type-number)))
+ (setf (aref *info-types* new-type-number) new-type-info)
+ (push new-type-info (class-info-types class-info)))))
+ ;; Arrange for TYPE-INFO-DEFAULT and TYPE-INFO-TYPE to be set at cold
+ ;; load time. (They can't very well be set at cross-compile time, since
+ ;; they differ between the cross-compiler and the target. The
+ ;; DEFAULT slot values differ because they're compiled closures, and
+ ;; the TYPE slot values differ in the use of SB!XC symbols instead
+ ;; of CL symbols.)
+ (push `(let ((type-info (type-info-or-lose ,',class ,',type)))
+ (setf (type-info-default type-info)
+ ;; FIXME: This code is sort of nasty. It would be
+ ;; cleaner if DEFAULT accepted a real function, instead
+ ;; of accepting a statement which will be turned into a
+ ;; lambda assuming that the argument name is NAME. It
+ ;; might even be more microefficient, too, since many
+ ;; DEFAULTs could be implemented as (CONSTANTLY NIL)
+ ;; instead of full-blown (LAMBDA (X) NIL).
+ (lambda (name)
+ (declare (ignorable name))
+ ,',default))
+ (setf (type-info-type type-info) ',',type-spec))
+ *reversed-type-info-init-forms*))
+ ',type))
+
+) ; EVAL-WHEN
+\f
+;;;; generic info environments
+
+;;; Note: the CACHE-NAME slot is deliberately not shared for bootstrapping
+;;; reasons. If we access with accessors for the exact type, then the inline
+;;; type check will win. If the inline check didn't win, we would try to use
+;;; the type system before it was properly initialized.
+(defstruct (info-env (:constructor nil))
+ ;; Some string describing what is in this environment, for printing purposes
+ ;; only.
+ (name (required-argument) :type string))
+(def!method print-object ((x info-env) stream)
+ (print-unreadable-object (x stream :type t)
+ (prin1 (info-env-name x) stream)))
+\f
+;;;; generic interfaces
+
+;;; FIXME: used only in this file, needn't be in runtime
+(defmacro do-info ((env &key (name (gensym)) (class (gensym)) (type (gensym))
+ (type-number (gensym)) (value (gensym)) known-volatile)
+ &body body)
+ #!+sb-doc
+ "DO-INFO (Env &Key Name Class Type Value) Form*
+ Iterate over all the values stored in the Info-Env Env. Name is bound to
+ the entry's name, Class and Type are bound to the class and type
+ (represented as keywords), and Value is bound to the entry's value."
+ (once-only ((n-env env))
+ (if known-volatile
+ (do-volatile-info name class type type-number value n-env body)
+ `(if (typep ,n-env 'volatile-info-env)
+ ,(do-volatile-info name class type type-number value n-env body)
+ ,(do-compact-info name class type type-number value
+ n-env body)))))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+
+;;; Return code to iterate over a compact info environment.
+(defun do-compact-info (name-var class-var type-var type-number-var value-var
+ n-env body)
+ (let ((n-index (gensym))
+ (n-type (gensym))
+ (punt (gensym)))
+ (once-only ((n-table `(compact-info-env-table ,n-env))
+ (n-entries-index `(compact-info-env-index ,n-env))
+ (n-entries `(compact-info-env-entries ,n-env))
+ (n-entries-info `(compact-info-env-entries-info ,n-env))
+ (n-info-types '*info-types*))
+ `(dotimes (,n-index (length ,n-table))
+ (declare (type index ,n-index))
+ (block ,PUNT
+ (let ((,name-var (svref ,n-table ,n-index)))
+ (unless (eql ,name-var 0)
+ (do-anonymous ((,n-type (aref ,n-entries-index ,n-index)
+ (1+ ,n-type)))
+ (nil)
+ (declare (type index ,n-type))
+ ,(once-only ((n-info `(aref ,n-entries-info ,n-type)))
+ `(let ((,type-number-var
+ (logand ,n-info compact-info-entry-type-mask)))
+ ,(once-only ((n-type-info
+ `(svref ,n-info-types
+ ,type-number-var)))
+ `(let ((,type-var (type-info-name ,n-type-info))
+ (,class-var (class-info-name
+ (type-info-class ,n-type-info)))
+ (,value-var (svref ,n-entries ,n-type)))
+ (declare (ignorable ,type-var ,class-var
+ ,value-var))
+ ,@body
+ (unless (zerop (logand ,n-info compact-info-entry-last))
+ (return-from ,PUNT))))))))))))))
+
+;;; Return code to iterate over a volatile info environment.
+(defun do-volatile-info (name-var class-var type-var type-number-var value-var
+ n-env body)
+ (let ((n-index (gensym)) (n-names (gensym)) (n-types (gensym)))
+ (once-only ((n-table `(volatile-info-env-table ,n-env))
+ (n-info-types '*info-types*))
+ `(dotimes (,n-index (length ,n-table))
+ (declare (type index ,n-index))
+ (do-anonymous ((,n-names (svref ,n-table ,n-index)
+ (cdr ,n-names)))
+ ((null ,n-names))
+ (let ((,name-var (caar ,n-names)))
+ (declare (ignorable ,name-var))
+ (do-anonymous ((,n-types (cdar ,n-names) (cdr ,n-types)))
+ ((null ,n-types))
+ (let ((,type-number-var (caar ,n-types)))
+ ,(once-only ((n-type `(svref ,n-info-types
+ ,type-number-var)))
+ `(let ((,type-var (type-info-name ,n-type))
+ (,class-var (class-info-name
+ (type-info-class ,n-type)))
+ (,value-var (cdar ,n-types)))
+ (declare (ignorable ,type-var ,class-var ,value-var))
+ ,@body))))))))))
+
+) ; EVAL-WHEN
+\f
+;;;; INFO cache
+
+;;;; We use a hash cache to cache name X type => value for the current
+;;;; value of *INFO-ENVIRONMENT*. This is in addition to the
+;;;; per-environment caching of name => types.
+
+;;; The value of *INFO-ENVIRONMENT* that has cached values.
+;;; *INFO-ENVIRONMENT* should never be destructively modified, so if
+;;; it is EQ to this, then the cache is valid.
+(defvar *cached-info-environment*)
+(!cold-init-forms
+ (setf *cached-info-environment* nil))
+
+;;; the hash function used for the INFO cache
+#!-sb-fluid (declaim (inline info-cache-hash))
+(defun info-cache-hash (name type)
+ (logand
+ (the fixnum
+ (logxor (globaldb-sxhashoid name)
+ (ash (the fixnum type) 7)))
+ #x3FF))
+
+(!cold-init-forms
+ (/show0 "before initialization of INFO hash cache"))
+(define-hash-cache info ((name eq) (type eq))
+ :values 2
+ :hash-function info-cache-hash
+ :hash-bits 10
+ :default (values nil :empty)
+ :init-wrapper !cold-init-forms)
+(!cold-init-forms
+ (/show0 "clearing INFO hash cache")
+ (info-cache-clear)
+ (/show0 "done clearing INFO hash cache"))
+
+;;; If the info cache is invalid, then clear it.
+#!-sb-fluid (declaim (inline clear-invalid-info-cache))
+(defun clear-invalid-info-cache ()
+ ;; Unless the cache is valid..
+ (unless (eq *info-environment* *cached-info-environment*)
+ (;; In the target Lisp, this should be done without interrupts, but in the
+ ;; host Lisp when cross-compiling, we don't need to sweat it, since no
+ ;; affected-by-GC hashes should be used when running under the host Lisp
+ ;; (since that's non-portable) and since only one thread should be used
+ ;; when running under the host Lisp (because multiple threads are
+ ;; non-portable too).
+ #-sb-xc-host without-interrupts
+ #+sb-xc-host progn
+ (info-cache-clear)
+ (setq *cached-info-environment* *info-environment*))))
+\f
+;;;; compact info environments
+
+;;; The upper limit on the size of the ENTRIES vector in a COMPACT-INFO-ENV.
+(defconstant compact-info-env-entries-bits 16)
+(deftype compact-info-entries-index () `(unsigned-byte ,compact-info-env-entries-bits))
+
+;;; the type of the values in COMPACT-INFO-ENTRIES-INFO
+(deftype compact-info-entry () `(unsigned-byte ,(1+ type-number-bits)))
+
+;;; This is an open hashtable with rehashing. Since modification is not
+;;; allowed, we don't have to worry about deleted entries. We indirect through
+;;; a parallel vector to find the index in the ENTRIES at which the entries for
+;;; a given name starts.
+(defstruct (compact-info-env (:include info-env)
+ #-sb-xc-host (:pure :substructure))
+ ;; If this value is EQ to the name we want to look up, then the cache hit
+ ;; function can be called instead of the lookup function.
+ (cache-name 0)
+ ;; The index in ENTRIES for the CACHE-NAME, or NIL if that name has no
+ ;; entries.
+ (cache-index nil :type (or compact-info-entries-index null))
+ ;; Hashtable of the names in this environment. If a bucket is unused, it is
+ ;; 0.
+ (table (required-argument) :type simple-vector)
+ ;; Indirection vector parallel to TABLE, translating indices in TABLE to the
+ ;; start of the ENTRIES for that name. Unused entries are undefined.
+ (index (required-argument)
+ :type (simple-array compact-info-entries-index (*)))
+ ;; Vector contining in contiguous ranges the values of for all the types of
+ ;; info for each name.
+ (entries (required-argument) :type simple-vector)
+ ;; Vector parallel to ENTRIES, indicating the type number for the value
+ ;; stored in that location and whether this location is the last type of info
+ ;; stored for this name. The type number is in the low TYPE-NUMBER-BITS
+ ;; bits, and the next bit is set if this is the last entry.
+ (entries-info (required-argument)
+ :type (simple-array compact-info-entry (*))))
+
+(defconstant compact-info-entry-type-mask (ldb (byte type-number-bits 0) -1))
+(defconstant compact-info-entry-last (ash 1 type-number-bits))
+
+;;; Return the value of the type corresponding to Number for the currently
+;;; cached name in Env.
+#!-sb-fluid (declaim (inline compact-info-cache-hit))
+(defun compact-info-cache-hit (env number)
+ (declare (type compact-info-env env) (type type-number number))
+ (let ((entries-info (compact-info-env-entries-info env))
+ (index (compact-info-env-cache-index env)))
+ (if index
+ (do ((index index (1+ index)))
+ (nil)
+ (declare (type index index))
+ (let ((info (aref entries-info index)))
+ (when (= (logand info compact-info-entry-type-mask) number)
+ (return (values (svref (compact-info-env-entries env) index)
+ t)))
+ (unless (zerop (logand compact-info-entry-last info))
+ (return (values nil nil)))))
+ (values nil nil))))
+
+;;; Encache Name in the compact environment Env. Hash is the
+;;; GLOBALDB-SXHASHOID of Name.
+(defun compact-info-lookup (env name hash)
+ (declare (type compact-info-env env) (type index hash))
+ (let* ((table (compact-info-env-table env))
+ (len (length table))
+ (len-2 (- len 2))
+ (hash2 (- len-2 (rem hash len-2))))
+ (declare (type index len-2 hash2))
+ (macrolet ((lookup (test)
+ `(do ((probe (rem hash len)
+ (let ((new (+ probe hash2)))
+ (declare (type index new))
+ ;; same as (mod new len), but faster.
+ (if (>= new len)
+ (the index (- new len))
+ new))))
+ (nil)
+ (let ((entry (svref table probe)))
+ (when (eql entry 0)
+ (return nil))
+ (when (,test entry name)
+ (return (aref (compact-info-env-index env)
+ probe)))))))
+ (setf (compact-info-env-cache-index env)
+ (if (symbolp name)
+ (lookup eq)
+ (lookup equal)))
+ (setf (compact-info-env-cache-name env) name)))
+
+ (values))
+
+;;; Exact density (modulo rounding) of the hashtable in a compact info
+;;; environment in names/bucket.
+(defconstant compact-info-environment-density 65)
+
+;;; Iterate over the environment once to find out how many names and entries
+;;; it has, then build the result. This code assumes that all the entries for
+;;; a name well be iterated over contiguously, which holds true for the
+;;; implementation of iteration over both kinds of environments.
+;;;
+;;; When building the table, we sort the entries by POINTER< in an attempt
+;;; to preserve any VM locality present in the original load order, rather than
+;;; randomizing with the original hash function.
+(defun compact-info-environment (env &key (name (info-env-name env)))
+ #!+sb-doc
+ "Return a new compact info environment that holds the same information as
+ Env."
+ (let ((name-count 0)
+ (prev-name 0)
+ (entry-count 0))
+ (collect ((names))
+ (let ((types ()))
+ (do-info (env :name name :type-number num :value value)
+ (unless (eq name prev-name)
+ (incf name-count)
+ (unless (eql prev-name 0)
+ (names (cons prev-name types)))
+ (setq prev-name name)
+ (setq types ()))
+ (incf entry-count)
+ (push (cons num value) types))
+ (unless (eql prev-name 0)
+ (names (cons prev-name types))))
+
+ (let* ((table-size (primify
+ (+ (truncate (* name-count 100)
+ compact-info-environment-density)
+ 3)))
+ (table (make-array table-size :initial-element 0))
+ (index (make-array table-size
+ :element-type 'compact-info-entries-index))
+ (entries (make-array entry-count))
+ (entries-info (make-array entry-count
+ :element-type 'compact-info-entry))
+ (sorted (sort (names)
+ #+sb-xc-host #'<
+ #-sb-xc-host (lambda (x y)
+ ;; FIXME: What's going on here?
+ (< (%primitive make-fixnum x)
+ (%primitive make-fixnum y))))))
+ (let ((entries-idx 0))
+ (dolist (types sorted)
+ (let* ((name (first types))
+ (hash (globaldb-sxhashoid name))
+ (len-2 (- table-size 2))
+ (hash2 (- len-2 (rem hash len-2))))
+ (do ((probe (rem hash table-size)
+ (rem (+ probe hash2) table-size)))
+ (nil)
+ (let ((entry (svref table probe)))
+ (when (eql entry 0)
+ (setf (svref table probe) name)
+ (setf (aref index probe) entries-idx)
+ (return))
+ (assert (not (equal entry name))))))
+
+ (unless (zerop entries-idx)
+ (setf (aref entries-info (1- entries-idx))
+ (logior (aref entries-info (1- entries-idx))
+ compact-info-entry-last)))
+
+ (loop for (num . value) in (rest types) do
+ (setf (aref entries-info entries-idx) num)
+ (setf (aref entries entries-idx) value)
+ (incf entries-idx)))
+
+ (unless (zerop entry-count)
+ (setf (aref entries-info (1- entry-count))
+ (logior (aref entries-info (1- entry-count))
+ compact-info-entry-last)))
+
+ (make-compact-info-env :name name
+ :table table
+ :index index
+ :entries entries
+ :entries-info entries-info))))))
+\f
+;;;; volatile environments
+
+;;; This is a closed hashtable, with the bucket being computed by taking the
+;;; GLOBALDB-SXHASHOID of the Name mod the table size.
+(defstruct (volatile-info-env (:include info-env))
+ ;; If this value is EQ to the name we want to look up, then the cache hit
+ ;; function can be called instead of the lookup function.
+ (cache-name 0)
+ ;; The alist translating type numbers to values for the currently cached
+ ;; name.
+ (cache-types nil :type list)
+ ;; Vector of alists of alists of the form:
+ ;; ((Name . ((Type-Number . Value) ...) ...)
+ (table (required-argument) :type simple-vector)
+ ;; The number of distinct names currently in this table (each name may have
+ ;; multiple entries, since there can be many types of info.
+ (count 0 :type index)
+ ;; The number of names at which we should grow the table and rehash.
+ (threshold 0 :type index))
+
+;;; Just like COMPACT-INFO-CACHE-HIT, only do it on a volatile environment.
+#!-sb-fluid (declaim (inline volatile-info-cache-hit))
+(defun volatile-info-cache-hit (env number)
+ (declare (type volatile-info-env env) (type type-number number))
+ (dolist (type (volatile-info-env-cache-types env) (values nil nil))
+ (when (eql (car type) number)
+ (return (values (cdr type) t)))))
+
+;;; Just like COMPACT-INFO-LOOKUP, only do it on a volatile environment.
+(defun volatile-info-lookup (env name hash)
+ (declare (type volatile-info-env env) (type index hash))
+ (let ((table (volatile-info-env-table env)))
+ (macrolet ((lookup (test)
+ `(dolist (entry (svref table (mod hash (length table))) ())
+ (when (,test (car entry) name)
+ (return (cdr entry))))))
+ (setf (volatile-info-env-cache-types env)
+ (if (symbolp name)
+ (lookup eq)
+ (lookup equal)))
+ (setf (volatile-info-env-cache-name env) name)))
+
+ (values))
+
+;;; Given a volatile environment Env, bind Table-Var the environment's table
+;;; and Index-Var to the index of Name's bucket in the table. We also flush
+;;; the cache so that things will be consistent if body modifies something.
+(eval-when (:compile-toplevel :execute)
+ (#+sb-xc-host cl:defmacro
+ #-sb-xc-host sb!xc:defmacro
+ with-info-bucket ((table-var index-var name env) &body body)
+ (once-only ((n-name name)
+ (n-env env))
+ `(progn
+ (setf (volatile-info-env-cache-name ,n-env) 0)
+ (let* ((,table-var (volatile-info-env-table ,n-env))
+ (,index-var (mod (globaldb-sxhashoid ,n-name)
+ (length ,table-var))))
+ ,@body)))))
+
+;;; Get the info environment that we use for write/modification operations.
+;;; This is always the first environment in the list, and must be a
+;;; VOLATILE-INFO-ENV.
+#!-sb-fluid (declaim (inline get-write-info-env))
+(defun get-write-info-env (&optional (env-list *info-environment*))
+ (let ((env (car env-list)))
+ (unless env
+ (error "no info environment?"))
+ (unless (typep env 'volatile-info-env)
+ (error "cannot modify this environment: ~S" env))
+ (the volatile-info-env env)))
+
+;;; If Name is already present in the table, then just create or
+;;; modify the specified type. Otherwise, add the new name and type,
+;;; checking for rehashing.
+;;;
+;;; We rehash by making a new larger environment, copying all of the
+;;; entries into it, then clobbering the old environment with the new
+;;; environment's table. We clear the old table to prevent it from
+;;; holding onto garbage if it is statically allocated.
+;;;
+;;; We return the new value so that this can be conveniently used in a
+;;; SETF function.
+(defun set-info-value (name0 type new-value
+ &optional (env (get-write-info-env)))
+ (declare (type type-number type) (type volatile-info-env env)
+ (inline assoc))
+ (let ((name (uncross name0)))
+ (when (eql name 0)
+ (error "0 is not a legal INFO name."))
+ ;; We don't enter the value in the cache because we don't know that this
+ ;; info-environment is part of *cached-info-environment*.
+ (info-cache-enter name type nil :empty)
+ (with-info-bucket (table index name env)
+ (let ((types (if (symbolp name)
+ (assoc name (svref table index) :test #'eq)
+ (assoc name (svref table index) :test #'equal))))
+ (cond
+ (types
+ (let ((value (assoc type (cdr types))))
+ (if value
+ (setf (cdr value) new-value)
+ (push (cons type new-value) (cdr types)))))
+ (t
+ (push (cons name (list (cons type new-value)))
+ (svref table index))
+
+ (let ((count (incf (volatile-info-env-count env))))
+ (when (>= count (volatile-info-env-threshold env))
+ (let ((new (make-info-environment :size (* count 2))))
+ (do-info (env :name entry-name :type-number entry-num
+ :value entry-val :known-volatile t)
+ (set-info-value entry-name entry-num entry-val new))
+ (fill (volatile-info-env-table env) nil)
+ (setf (volatile-info-env-table env)
+ (volatile-info-env-table new))
+ (setf (volatile-info-env-threshold env)
+ (volatile-info-env-threshold new)))))))))
+ new-value))
+
+;;; FIXME: It should be possible to eliminate the hairy compiler macros below
+;;; by declaring INFO and (SETF INFO) inline and making a simple compiler macro
+;;; for TYPE-INFO-OR-LOSE. (If we didn't worry about efficiency of the
+;;; cross-compiler, we could even do it by just making TYPE-INFO-OR-LOSE
+;;; foldable.)
+
+;;; INFO is the standard way to access the database. It's settable.
+(defun info (class type name &optional (env-list nil env-list-p))
+ #!+sb-doc
+ "Return the information of the specified TYPE and CLASS for NAME.
+ The second value returned is true if there is any such information
+ recorded. If there is no information, the first value returned is
+ the default and the second value returned is NIL."
+ ;; FIXME: At some point check systematically to make sure that the system
+ ;; doesn't do any full calls to INFO or (SETF INFO), or at least none in any
+ ;; inner loops.
+ (let ((info (type-info-or-lose class type)))
+ (if env-list-p
+ (get-info-value name (type-info-number info) env-list)
+ (get-info-value name (type-info-number info)))))
+#!-sb-fluid
+(define-compiler-macro info
+ (&whole whole class type name &optional (env-list nil env-list-p))
+ ;; Constant CLASS and TYPE is an overwhelmingly common special case, and we
+ ;; can resolve it much more efficiently than the general case.
+ (if (and (constantp class) (constantp type))
+ (let ((info (type-info-or-lose class type)))
+ `(the ,(type-info-type info)
+ (get-info-value ,name
+ ,(type-info-number info)
+ ,@(when env-list-p `(,env-list)))))
+ whole))
+(defun (setf info) (new-value
+ class
+ type
+ name
+ &optional (env-list nil env-list-p))
+ (let* ((info (type-info-or-lose class type))
+ (tin (type-info-number info)))
+ (if env-list-p
+ (set-info-value name
+ tin
+ new-value
+ (get-write-info-env env-list))
+ (set-info-value name
+ tin
+ new-value)))
+ new-value)
+;;; FIXME: We'd like to do this, but Python doesn't support
+;;; compiler macros and it's hard to change it so that it does.
+;;; It might make more sense to just convert INFO :FOO :BAR into
+;;; an ordinary function, so that instead of calling INFO :FOO :BAR
+;;; you call e.g. INFO%FOO%BAR. Then dynamic linking could be handled
+;;; by the ordinary Lisp mechanisms and we wouldn't have to maintain
+;;; all this cruft..
+#|
+#!-sb-fluid
+(progn
+ (define-compiler-macro (setf info) (&whole whole
+ new-value
+ class
+ type
+ name
+ &optional (env-list nil env-list-p))
+ ;; Constant CLASS and TYPE is an overwhelmingly common special case, and we
+ ;; can resolve it much more efficiently than the general case.
+ (if (and (constantp class) (constantp type))
+ (let* ((info (type-info-or-lose class type))
+ (tin (type-info-number info)))
+ (if env-list-p
+ `(set-info-value ,name
+ ,tin
+ ,new-value
+ (get-write-info-env ,env-list))
+ `(set-info-value ,name
+ ,tin
+ ,new-value)))
+ whole)))
+|#
+
+;;; the maximum density of the hashtable in a volatile env (in names/bucket)
+;;; FIXME: actually seems to be measured in percent, should be converted
+;;; to be measured in names/bucket
+(defconstant volatile-info-environment-density 50)
+
+;;; Make a new volatile environment of the specified size.
+(defun make-info-environment (&key (size 42) (name "Unknown"))
+ (declare (type (integer 1) size))
+ (let ((table-size (primify (truncate (* size 100)
+ volatile-info-environment-density))))
+ (make-volatile-info-env :name name
+ :table (make-array table-size :initial-element nil)
+ :threshold size)))
+
+(defun clear-info (class type name)
+ #!+sb-doc
+ "Clear the information of the specified Type and Class for Name in the
+ current environment, allowing any inherited info to become visible. We
+ return true if there was any info."
+ (let ((info (type-info-or-lose class type)))
+ (clear-info-value name (type-info-number info))))
+#!-sb-fluid
+(define-compiler-macro clear-info (&whole whole class type name)
+ ;; Constant CLASS and TYPE is an overwhelmingly common special case, and
+ ;; we can resolve it much more efficiently than the general case.
+ (if (and (keywordp class) (keywordp type))
+ (let ((info (type-info-or-lose class type)))
+ `(clear-info-value ,name ,(type-info-number info)))
+ whole))
+(defun clear-info-value (name type)
+ (declare (type type-number type) (inline assoc))
+ (clear-invalid-info-cache)
+ (info-cache-enter name type nil :empty)
+ (with-info-bucket (table index name (get-write-info-env))
+ (let ((types (assoc name (svref table index) :test #'equal)))
+ (when (and types
+ (assoc type (cdr types)))
+ (setf (cdr types)
+ (delete type (cdr types) :key #'car))
+ t))))
+\f
+;;;; *INFO-ENVIRONMENT*
+
+;;; We do info access relative to the current *INFO-ENVIRONMENT*, a
+;;; list of INFO-ENVIRONMENT structures.
+(defvar *info-environment*)
+(declaim (type list *info-environment*))
+(!cold-init-forms
+ (setq *info-environment*
+ (list (make-info-environment :name "initial global")))
+ (/show0 "done setting *INFO-ENVIRONMENT*"))
+;;; FIXME: should perhaps be *INFO-ENV-LIST*. And rename
+;;; all FOO-INFO-ENVIRONMENT-BAR stuff to FOO-INFO-ENV-BAR.
+\f
+;;;; GET-INFO-VALUE
+
+;;; Check whether the name and type is in our cache, if so return it.
+;;; Otherwise, search for the value and encache it.
+;;;
+;;; Return the value from the first environment which has it defined, or
+;;; return the default if none does. We have a cache for the last name looked
+;;; up in each environment. We don't compute the hash until the first time the
+;;; cache misses. When the cache does miss, we invalidate it before calling the
+;;; lookup routine to eliminate the possiblity of the cache being partially
+;;; updated if the lookup is interrupted.
+(defun get-info-value (name0 type &optional (env-list nil env-list-p))
+ (declare (type type-number type))
+ (let ((name (uncross name0)))
+ (flet ((lookup-ignoring-global-cache (env-list)
+ (let ((hash nil))
+ (dolist (env env-list
+ (multiple-value-bind (val winp)
+ (funcall (type-info-default
+ (svref *info-types* type))
+ name)
+ (values val winp)))
+ (macrolet ((frob (lookup cache slot)
+ `(progn
+ (unless (eq name (,slot env))
+ (unless hash
+ (setq hash (globaldb-sxhashoid name)))
+ (setf (,slot env) 0)
+ (,lookup env name hash))
+ (multiple-value-bind (value winp)
+ (,cache env type)
+ (when winp (return (values value t)))))))
+ (if (typep env 'volatile-info-env)
+ (frob volatile-info-lookup volatile-info-cache-hit
+ volatile-info-env-cache-name)
+ (frob compact-info-lookup compact-info-cache-hit
+ compact-info-env-cache-name)))))))
+ (cond (env-list-p
+ (lookup-ignoring-global-cache env-list))
+ (t
+ (clear-invalid-info-cache)
+ (multiple-value-bind (val winp) (info-cache-lookup name type)
+ (if (eq winp :empty)
+ (multiple-value-bind (val winp)
+ (lookup-ignoring-global-cache *info-environment*)
+ (info-cache-enter name type val winp)
+ (values val winp))
+ (values val winp))))))))
+\f
+;;;; definitions for function information
+
+(define-info-class :function)
+
+;;; The kind of functional object being described. If null, Name isn't a known
+;;; functional object.
+(define-info-type
+ :class :function
+ :type :kind
+ :type-spec (member nil :function :macro :special-form)
+ ;; I'm a little confused what the correct behavior of this default is. It's
+ ;; not clear how to generalize the FBOUNDP expression to the cross-compiler.
+ ;; As far as I can tell, NIL is a safe default -- it might keep the compiler
+ ;; from making some valid optimization, but it shouldn't produce incorrect
+ ;; code. -- WHN 19990330
+ :default
+ #+sb-xc-host nil
+ #-sb-xc-host (if (fboundp name) :function nil))
+
+;;; The type specifier for this function.
+(define-info-type
+ :class :function
+ :type :type
+ :type-spec ctype
+ ;; Again (as in DEFINE-INFO-TYPE :CLASS :FUNCTION :TYPE :KIND) it's not clear
+ ;; how to generalize the FBOUNDP expression to the cross-compiler.
+ ;; -- WHN 19990330
+ :default
+ #+sb-xc-host (specifier-type 'function)
+ #-sb-xc-host (if (fboundp name)
+ (extract-function-type (fdefinition name))
+ (specifier-type 'function)))
+
+;;; The Assumed-Type for this function, if we have to infer the type due to not
+;;; having a declaration or definition.
+(define-info-type
+ :class :function
+ :type :assumed-type
+ :type-spec (or approximate-function-type null))
+
+;;; 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
+(define-info-type
+ :class :function
+ :type :where-from
+ :type-spec (member :declared :assumed :defined)
+ :default
+ ;; Again (as in DEFINE-INFO-TYPE :CLASS :FUNCTION :TYPE :KIND) it's
+ ;; not clear how to generalize the FBOUNDP expression to the
+ ;; cross-compiler. -- WHN 19990606
+ #+sb-xc-host :assumed
+ #-sb-xc-host (if (fboundp name) :defined :assumed))
+
+;;; Lambda used for inline expansion of this function.
+(define-info-type
+ :class :function
+ :type :inline-expansion
+ :type-spec list)
+
+;;; Specifies whether this function may be expanded inline. If null, we
+;;; don't care.
+(define-info-type
+ :class :function
+ :type :inlinep
+ :type-spec inlinep
+ :default nil)
+
+;;; A macro-like function which transforms a call to this function
+;;; into some other Lisp form. This expansion is inhibited if inline
+;;; expansion is inhibited.
+(define-info-type
+ :class :function
+ :type :source-transform
+ :type-spec (or function null))
+
+;;; The macroexpansion function for this macro.
+(define-info-type
+ :class :function
+ :type :macro-function
+ :type-spec (or function null)
+ :default nil)
+
+;;; The compiler-macroexpansion function for this macro.
+(define-info-type
+ :class :function
+ :type :compiler-macro-function
+ :type-spec (or function null)
+ :default nil)
+
+;;; A function which converts this special form into IR1.
+(define-info-type
+ :class :function
+ :type :ir1-convert
+ :type-spec (or function null))
+
+;;; A function which gets a chance to do stuff to the IR1 for any call to this
+;;; function.
+(define-info-type
+ :class :function
+ :type :ir1-transform
+ :type-spec (or function null))
+
+;;; If a function is a slot accessor or setter, then this is the class that it
+;;; accesses slots of.
+(define-info-type
+ :class :function
+ :type :accessor-for
+ :type-spec (or sb!xc:class null)
+ :default nil)
+
+;;; If a function is "known" to the compiler, then this is FUNCTION-INFO
+;;; structure containing the info used to special-case compilation.
+(define-info-type
+ :class :function
+ :type :info
+ :type-spec (or function-info null)
+ :default nil)
+
+(define-info-type
+ :class :function
+ :type :documentation
+ :type-spec (or string null)
+ :default nil)
+
+(define-info-type
+ :class :function
+ :type :definition
+ :type-spec t
+ :default nil)
+\f
+;;;; definitions for other miscellaneous information
+
+(define-info-class :variable)
+
+;;; The kind of variable-like thing described.
+(define-info-type
+ :class :variable
+ :type :kind
+ :type-spec (member :special :constant :global :alien)
+ :default (if (or (eq (symbol-package name) *keyword-package*)
+ (member name '(t nil)))
+ :constant
+ :global))
+
+;;; 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.
+(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.
+(define-info-type
+ :class :variable
+ :type :constant-value
+ :type-spec t
+ :default (if (boundp name)
+ (values (symbol-value name) t)
+ (values nil nil)))
+
+(define-info-type
+ :class :variable
+ :type :alien-info
+ :type-spec (or heap-alien-info null)
+ :default nil)
+
+(define-info-type
+ :class :variable
+ :type :documentation
+ :type-spec (or string null)
+ :default nil)
+
+(define-info-class :type)
+
+;;; 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.
+(define-info-type
+ :class :type
+ :type :expander
+ :type-spec (or function null)
+ :default nil)
+
+(define-info-type
+ :class :type
+ :type :documentation
+ :type-spec (or string null))
+
+;;; Function that parses type specifiers into CTYPE structures.
+(define-info-type
+ :class :type
+ :type :translator
+ :type-spec (or function null)
+ :default nil)
+
+;;; If true, then the type coresponding to this name. Note that if this is a
+;;; built-in class with a translation, then this is the translation, not the
+;;; class object. This info type keeps track of various atomic types (NIL etc.)
+;;; and also serves as a cache to ensure that common standard types (atomic and
+;;; otherwise) are only consed once.
+(define-info-type
+ :class :type
+ :type :builtin
+ :type-spec (or ctype null)
+ :default nil)
+
+;;; If this is a class name, then the value is a cons (Name . Class), where
+;;; Class may be null if the class hasn't been defined yet. Note that for
+;;; built-in classes, the kind may be :PRIMITIVE and not :INSTANCE. The
+;;; the name is in the cons so that we can signal a meaningful error if we only
+;;; have the cons.
+(define-info-type
+ :class :type
+ :type :class
+ :type-spec (or sb!kernel::class-cell null)
+ :default nil)
+
+;;; Layout for this type being used by the compiler.
+(define-info-type
+ :class :type
+ :type :compiler-layout
+ :type-spec (or layout null)
+ :default (let ((class (sb!xc:find-class name nil)))
+ (when class (class-layout class))))
+
+(define-info-class :typed-structure)
+(define-info-type
+ :class :typed-structure
+ :type :info
+ :type-spec t
+ :default nil)
+
+(define-info-class :declaration)
+(define-info-type
+ :class :declaration
+ :type :recognized
+ :type-spec boolean)
+
+(define-info-class :alien-type)
+(define-info-type
+ :class :alien-type
+ :type :kind
+ :type-spec (member :primitive :defined :unknown)
+ :default :unknown)
+(define-info-type
+ :class :alien-type
+ :type :translator
+ :type-spec (or function null)
+ :default nil)
+(define-info-type
+ :class :alien-type
+ :type :definition
+ :type-spec (or alien-type null)
+ :default nil)
+(define-info-type
+ :class :alien-type
+ :type :struct
+ :type-spec (or alien-type null)
+ :default nil)
+(define-info-type
+ :class :alien-type
+ :type :union
+ :type-spec (or alien-type null)
+ :default nil)
+(define-info-type
+ :class :alien-type
+ :type :enum
+ :type-spec (or alien-type null)
+ :default nil)
+
+(define-info-class :setf)
+
+(define-info-type
+ :class :setf
+ :type :inverse
+ :type-spec (or symbol null)
+ :default nil)
+
+(define-info-type
+ :class :setf
+ :type :documentation
+ :type-spec (or string null)
+ :default nil)
+
+(define-info-type
+ :class :setf
+ :type :expander
+ :type-spec (or function null)
+ :default nil)
+
+;;; Used for storing miscellaneous documentation types. The stuff is an alist
+;;; translating documentation kinds to values.
+(define-info-class :random-documentation)
+(define-info-type
+ :class :random-documentation
+ :type :stuff
+ :type-spec list
+ :default ())
+
+#!-sb-fluid (declaim (freeze-type info-env))
+\f
+;;; Now that we have finished initializing *INFO-CLASSES* and *INFO-TYPES* (at
+;;; compile time), generate code to set them at cold load time to the same
+;;; state they have currently.
+(!cold-init-forms
+ (/show0 "beginning *INFO-CLASSES* init, calling MAKE-HASH-TABLE")
+ (setf *info-classes*
+ (make-hash-table :size #.(hash-table-size *info-classes*)
+ ;; FIXME: These remaining arguments are only here
+ ;; for debugging, to try track down weird cold
+ ;; boot problems.
+ #|:rehash-size 1.5
+ :rehash-threshold 1|#))
+ (/show0 "done with MAKE-HASH-TABLE in *INFO-CLASSES* init")
+ (dolist (class-info-name '#.(let ((result nil))
+ (maphash (lambda (key value)
+ (declare (ignore value))
+ (push key result))
+ *info-classes*)
+ result))
+ (let ((class-info (make-class-info class-info-name)))
+ (setf (gethash class-info-name *info-classes*)
+ class-info)))
+ (/show0 "done with *INFO-CLASSES* initialization")
+ (/show0 "beginning *INFO-TYPES* initialization")
+ (setf *info-types*
+ (map 'vector
+ (lambda (x)
+ (when x
+ (let* ((class-info (class-info-or-lose (second x)))
+ (type-info (make-type-info :name (first x)
+ :class class-info
+ :number (third x)
+ :type (fourth x))))
+ (push type-info (class-info-types class-info))
+ type-info)))
+ '#.(map 'list
+ (lambda (info-type)
+ (when info-type
+ (list (type-info-name info-type)
+ (class-info-name (type-info-class info-type))
+ (type-info-number info-type)
+ (type-info-type info-type))))
+ *info-types*)))
+ (/show0 "done with *INFO-TYPES* initialization"))
+
+;;; At cold load time, after the INFO-TYPE objects have been created, we can
+;;; set their DEFAULT and TYPE slots.
+(macrolet ((frob ()
+ `(!cold-init-forms
+ ,@(reverse *reversed-type-info-init-forms*))))
+ (frob))
+\f
+;;;; a hack for detecting
+;;;; (DEFUN FOO (X Y)
+;;;; ..
+;;;; (SETF (BAR A FFH) 12) ; compiles to a call to #'(SETF BAR)
+;;;; ..)
+;;;; (DEFSETF BAR SET-BAR) ; can't influence previous compilation
+;;;;
+;;;; KLUDGE: Arguably it should be another class/type combination in the
+;;;; globaldb. However, IMHO the whole globaldb/fdefinition treatment of setf
+;;;; functions is a mess which ought to be rewritten, and I'm not inclined to
+;;;; mess with it short of that. So I just put this bag on the side of it
+;;;; instead..
+
+;;; true for symbols FOO which have been assumed to have '(SETF FOO)
+;;; bound to a function
+(defvar *setf-assumed-fboundp*)
+(!cold-init-forms (setf *setf-assumed-fboundp* (make-hash-table)))
+\f
+(!defun-from-collected-cold-init-forms !globaldb-cold-init)
--- /dev/null
+;;;; This file contains the GTN pass in the compiler. GTN allocates
+;;;; the TNs that hold the values of lexical variables and determines
+;;;; the calling conventions and passing locations used in function
+;;;; calls.
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!C")
+
+(file-comment
+ "$Header$")
+
+;;; We make a pass over the component's environments, assigning argument
+;;; passing locations and return conventions and TNs for local variables.
+(defun gtn-analyze (component)
+ (setf (component-info component) (make-ir2-component))
+ (let ((funs (component-lambdas component)))
+ (dolist (fun funs)
+ (assign-ir2-environment fun)
+ (assign-return-locations fun)
+ (assign-ir2-nlx-info fun)
+ (assign-lambda-var-tns fun nil)
+ (dolist (let (lambda-lets fun))
+ (assign-lambda-var-tns let t))))
+
+ (values))
+
+;;; We have to allocate the home TNs for variables before we can call
+;;; Assign-IR2-Environment so that we can close over TNs that haven't had their
+;;; home environment assigned yet. Here we evaluate the DEBUG-INFO/SPEED
+;;; tradeoff to determine how variables are allocated. If SPEED is 3, then all
+;;; variables are subject to lifetime analysis. Otherwise, only Let-P variables
+;;; are allocated normally, and that can be inhibited by DEBUG-INFO = 3.
+(defun assign-lambda-var-tns (fun let-p)
+ (declare (type clambda fun))
+ (dolist (var (lambda-vars fun))
+ (when (leaf-refs var)
+ (let* ((type (if (lambda-var-indirect var)
+ *backend-t-primitive-type*
+ (primitive-type (leaf-type var))))
+ (temp (make-normal-tn type))
+ (node (lambda-bind fun))
+ (res (if (or (and let-p (policy node (< debug 3)))
+ (policy node (zerop debug))
+ (policy node (= speed 3)))
+ temp
+ (environment-debug-live-tn temp
+ (lambda-environment fun)))))
+ (setf (tn-leaf res) var)
+ (setf (leaf-info var) res))))
+ (values))
+
+;;; Give an IR2-Environment structure to Fun. We make the TNs which hold
+;;; environment values and the old-FP/return-PC.
+(defun assign-ir2-environment (fun)
+ (declare (type clambda fun))
+ (let ((env (lambda-environment fun)))
+ (collect ((env))
+ (dolist (thing (environment-closure env))
+ (let ((ptype (etypecase thing
+ (lambda-var
+ (if (lambda-var-indirect thing)
+ *backend-t-primitive-type*
+ (primitive-type (leaf-type thing))))
+ (nlx-info *backend-t-primitive-type*))))
+ (env (cons thing (make-normal-tn ptype)))))
+
+ (let ((res (make-ir2-environment
+ :environment (env)
+ :return-pc-pass (make-return-pc-passing-location
+ (external-entry-point-p fun)))))
+ (setf (environment-info env) res)
+ (setf (ir2-environment-old-fp res)
+ (make-old-fp-save-location env))
+ (setf (ir2-environment-return-pc res)
+ (make-return-pc-save-location env)))))
+
+ (values))
+
+;;; Return true if Fun's result continuation is used in a TR full call. We
+;;; only consider explicit :Full calls. It is assumed that known calls are
+;;; never part of a tail-recursive loop, so we don't need to enforce
+;;; tail-recursion. In any case, we don't know which known calls will
+;;; actually be full calls until after LTN.
+(defun has-full-call-use (fun)
+ (declare (type clambda fun))
+ (let ((return (lambda-return fun)))
+ (and return
+ (do-uses (use (return-result return) nil)
+ (when (and (node-tail-p use)
+ (basic-combination-p use)
+ (eq (basic-combination-kind use) :full))
+ (return t))))))
+
+;;; Return true if we should use the standard (unknown) return convention
+;;; for a tail-set. We use the standard return convention when:
+;;; -- We must use the standard convention to preserve tail-recursion, since
+;;; the tail-set contains both an XEP and a TR full call.
+;;; -- It appears to be more efficient to use the standard convention, since
+;;; there are no non-TR local calls that could benefit from a non-standard
+;;; convention.
+(defun use-standard-returns (tails)
+ (declare (type tail-set tails))
+ (let ((funs (tail-set-functions tails)))
+ (or (and (find-if #'external-entry-point-p funs)
+ (find-if #'has-full-call-use funs))
+ (block punt
+ (dolist (fun funs t)
+ (dolist (ref (leaf-refs fun))
+ (let* ((cont (node-cont ref))
+ (dest (continuation-dest cont)))
+ (when (and dest
+ (not (node-tail-p dest))
+ (basic-combination-p dest)
+ (eq (basic-combination-fun dest) cont)
+ (eq (basic-combination-kind dest) :local))
+ (return-from punt nil)))))))))
+
+;;; If policy indicates, give an efficency note about our inability to use
+;;; the known return convention. We try to find a function in the tail set
+;;; with non-constant return values to use as context. If there is no such
+;;; function, then be more vague.
+(defun return-value-efficency-note (tails)
+ (declare (type tail-set tails))
+ (let ((funs (tail-set-functions tails)))
+ (when (policy (lambda-bind (first funs)) (> (max speed space) brevity))
+ (dolist (fun funs
+ (let ((*compiler-error-context* (lambda-bind (first funs))))
+ (compiler-note
+ "Return value count mismatch prevents known return ~
+ from these functions:~
+ ~{~% ~A~}"
+ (remove nil (mapcar #'leaf-name funs)))))
+ (let ((ret (lambda-return fun)))
+ (when ret
+ (let ((rtype (return-result-type ret)))
+ (multiple-value-bind (ignore count) (values-types rtype)
+ (declare (ignore ignore))
+ (when (eq count :unknown)
+ (let ((*compiler-error-context* (lambda-bind fun)))
+ (compiler-note
+ "Return type not fixed values, so can't use known return ~
+ convention:~% ~S"
+ (type-specifier rtype)))
+ (return)))))))))
+ (values))
+
+;;; Return a Return-Info structure describing how we should return from
+;;; functions in the specified tail set. We use the unknown values convention
+;;; if the number of values is unknown, or if it is a good idea for some other
+;;; reason. Otherwise we allocate passing locations for a fixed number of
+;;; values.
+(defun return-info-for-set (tails)
+ (declare (type tail-set tails))
+ (multiple-value-bind (types count) (values-types (tail-set-type tails))
+ (let ((ptypes (mapcar #'primitive-type types))
+ (use-standard (use-standard-returns tails)))
+ (when (and (eq count :unknown) (not use-standard))
+ (return-value-efficency-note tails))
+ (if (or (eq count :unknown) use-standard)
+ (make-return-info :kind :unknown
+ :count count
+ :types ptypes)
+ (make-return-info :kind :fixed
+ :count count
+ :types ptypes
+ :locations (mapcar #'make-normal-tn ptypes))))))
+
+;;; If Tail-Set doesn't have any Info, then make a Return-Info for it. If
+;;; we choose a return convention other than :Unknown, and this environment is
+;;; for an XEP, then break tail recursion on the XEP calls, since we must
+;;; always use unknown values when returning from an XEP.
+(defun assign-return-locations (fun)
+ (declare (type clambda fun))
+ (let* ((tails (lambda-tail-set fun))
+ (returns (or (tail-set-info tails)
+ (setf (tail-set-info tails)
+ (return-info-for-set tails))))
+ (return (lambda-return fun)))
+ (when (and return
+ (not (eq (return-info-kind returns) :unknown))
+ (external-entry-point-p fun))
+ (do-uses (use (return-result return))
+ (setf (node-tail-p use) nil))))
+ (values))
+
+;;; Make an IR2-NLX-Info structure for each NLX entry point recorded. We
+;;; call a VM supplied function to make the Save-SP restricted on the stack.
+;;; The NLX-Entry VOP's :Force-To-Stack Save-P value doesn't do this, since the
+;;; SP is an argument to the VOP, and thus isn't live afterwards.
+(defun assign-ir2-nlx-info (fun)
+ (declare (type clambda fun))
+ (let ((env (lambda-environment fun)))
+ (dolist (nlx (environment-nlx-info env))
+ (setf (nlx-info-info nlx)
+ (make-ir2-nlx-info
+ :home (when (member (cleanup-kind (nlx-info-cleanup nlx))
+ '(:block :tagbody))
+ (make-normal-tn *backend-t-primitive-type*))
+ :save-sp (make-nlx-sp-tn env)))))
+ (values))
--- /dev/null
+;;;; miscellaneous functions which use INFO
+;;;;
+;;;; (In CMU CL, these were in globaldb.lisp. They've been moved here
+;;;; because references to INFO can't be compiled correctly until
+;;;; globaldb initialization is complete, and the SBCL technique for
+;;;; initializing the global database in the cross-compiler isn't
+;;;; completed until load time.)
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!C")
+
+(file-comment
+ "$Header$")
+\f
+;;; Check the legality of a function name that is being introduced.
+;;; -- If it names a macro, then give a warning and blast the macro
+;;; information.
+;;; -- If it is a structure slot accessor, give a warning and blast
+;;; the structure.
+;;; -- Check for conflicting setf macros.
+(declaim (ftype (function ((or symbol cons)) t) proclaim-as-function-name))
+(defun proclaim-as-function-name (name)
+ (check-function-name name)
+ (ecase (info :function :kind name)
+ (:function
+ (let ((accessor-for (info :function :accessor-for name)))
+ (when accessor-for
+ (compiler-warning
+ "Undefining structure type:~% ~S~@
+ so that this slot accessor can be redefined:~% ~S"
+ (sb!xc:class-name accessor-for) name)
+ ;; FIXME: This is such weird, unfriendly behavior.. (What if
+ ;; the user didn't want his structure blasted?) It probably
+ ;; violates ANSI, too. (Check this.) Perhaps instead of
+ ;; undefining the structure, we should attach the lost
+ ;; accessor function to SB-EXT:LOST-STRUCTURE-ACCESSORS on
+ ;; the property list of the symbol which names the structure?
+ (undefine-structure accessor-for)
+ (setf (info :function :kind name) :function))))
+ (:macro
+ (compiler-style-warning "~S previously defined as a macro." name)
+ (setf (info :function :kind name) :function)
+ (setf (info :function :where-from name) :assumed)
+ (clear-info :function :macro-function name))
+ ((nil)
+ (setf (info :function :kind name) :function)))
+ (note-if-setf-function-and-macro name)
+ name)
+
+;;; Make NAME no longer be a function name: clear everything back to the
+;;; default.
+(defun undefine-function-name (name)
+ (when name
+ (macrolet ((frob (type &optional val)
+ `(unless (eq (info :function ,type name) ,val)
+ (setf (info :function ,type name) ,val))))
+ (frob :info)
+ (frob :type (specifier-type 'function))
+ (frob :where-from :assumed)
+ (frob :inlinep)
+ (frob :kind)
+ (frob :accessor-for)
+ (frob :inline-expansion)
+ (frob :source-transform)
+ (frob :assumed-type)))
+ (values))
+\f
+;;;; ANSI Common Lisp functions which are defined in terms of the info
+;;;; database
+
+(defun sb!xc:constantp (object &optional environment)
+ #!+sb-doc
+ "True of any Lisp object that has a constant value: types that eval to
+ themselves, keywords, constants, and list whose car is QUOTE."
+ ;; FIXME: Should STRUCTURE-OBJECT and/or STANDARD-OBJECT be here?
+ ;; They eval to themselves..
+ ;;
+ ;; KLUDGE: Someday it might be nice to make the code recognize foldable
+ ;; functions and call itself recursively on their arguments, so that
+ ;; more of the examples in the ANSI CL definition are recognized.
+ ;; (e.g. (+ 3 2), (SQRT PI), and (LENGTH '(A B C)))
+ (declare (ignore environment))
+ (typecase object
+ (number t)
+ (character t)
+ (array t)
+ ;; (Note that the following test on INFO catches KEYWORDs as well as
+ ;; explicitly DEFCONSTANT symbols.)
+ (symbol (eq (info :variable :kind object) :constant))
+ (list (eq (car object) 'quote))))
+
+(declaim (ftype (function (symbol &optional (or null sb!c::lexenv))) sb!xc:macro-function))
+(defun sb!xc:macro-function (symbol &optional env)
+ #!+sb-doc
+ "If SYMBOL names a macro in ENV, returns the expansion function,
+ else returns NIL. If ENV is unspecified or NIL, use the global
+ environment only."
+ (declare (symbol symbol))
+ (let* ((fenv (when env (sb!c::lexenv-functions env)))
+ (local-def (cdr (assoc symbol fenv))))
+ (cond (local-def
+ (if (and (consp local-def) (eq (car local-def) 'MACRO))
+ (cdr local-def)
+ nil))
+ ((eq (info :function :kind symbol) :macro)
+ (values (info :function :macro-function symbol)))
+ (t
+ nil))))
+
+;;; Note: Technically there could be an ENV optional argument to SETF
+;;; MACRO-FUNCTION, but since ANSI says that the consequences of
+;;; supplying that optional argument are undefined, we don't allow it.
+;;; (Thus our implementation of this unspecified behavior is to
+;;; complain that the wrong number of arguments was supplied. Since
+;;; the behavior is unspecified, this is conforming.:-)
+(defun (setf sb!xc:macro-function) (function symbol)
+ (declare (symbol symbol) (type function function))
+ (when (eq (info :function :kind symbol) :special-form)
+ (error "~S names a special form." symbol))
+ (setf (info :function :kind symbol) :macro)
+ (setf (info :function :macro-function symbol) function)
+ ;; This is a nice thing to have in the target SBCL, but in the
+ ;; cross-compilation host it's not nice to mess with
+ ;; (SYMBOL-FUNCTION FOO) where FOO might be a symbol in the
+ ;; cross-compilation host's COMMON-LISP package.
+ #-sb-xc-host
+ (setf (symbol-function symbol)
+ (lambda (&rest args)
+ (declare (ignore args))
+ ;; (ANSI specification of FUNCALL says that this should be
+ ;; an error of type UNDEFINED-FUNCTION, not just SIMPLE-ERROR.)
+ (error 'undefined-function :name symbol)))
+ function)
+
+(defun sb!xc:compiler-macro-function (name &optional env)
+ #!+sb-doc
+ "If NAME names a compiler-macro, returns the expansion function,
+ else returns NIL. Note: if the name is shadowed in ENV by a local
+ definition, or declared NOTINLINE, NIL is returned. Can be
+ set with SETF."
+ (let ((found (and env
+ (cdr (assoc name (sb!c::lexenv-functions env)
+ :test #'equal)))))
+ (unless (eq (cond ((sb!c::defined-function-p found)
+ (sb!c::defined-function-inlinep found))
+ (found :notinline)
+ (t
+ (info :function :inlinep name)))
+ :notinline)
+ (values (info :function :compiler-macro-function name)))))
+(defun (setf sb!xc:compiler-macro-function) (function name)
+ (declare (type (or symbol list) name)
+ (type (or function null) function))
+ (when (eq (info :function :kind name) :special-form)
+ (error "~S names a special form." name))
+ (setf (info :function :compiler-macro-function name) function)
+ function)
+\f
+;;;; a subset of DOCUMENTATION functionality for bootstrapping
+
+;;; FDOCUMENTATION is like DOCUMENTATION, but with less functionality,
+;;; and implemented with DEFUN instead of DEFGENERIC so that it can
+;;; run before CLOS is set up. Supported DOC-TYPE values are
+;;; FUNCTION
+;;; SETF
+;;; STRUCTURE
+;;; T
+;;; TYPE
+;;; VARIABLE
+;;; FIXME: Other types end up in INFO :RANDOM-DOCUMENTATION :STUFF. I
+;;; should add some code to monitor this and make sure that nothing is
+;;; unintentionally being sent to never never land this way.
+;;; FIXME: Rename FDOCUMENTATION to BDOCUMENTATION, by analogy with
+;;; DEF!STRUCT and DEF!MACRO and so forth. And consider simply saving
+;;; all the BDOCUMENTATION entries in a *BDOCUMENTATION* hash table
+;;; and slamming them into PCL once PCL gets going.
+(defun fdocumentation (x doc-type)
+ (flet ((try-cmucl-random-doc (x doc-type)
+ (declare (symbol doc-type))
+ (cdr (assoc doc-type
+ (values (info :random-documentation :stuff x))))))
+ (case doc-type
+ (variable
+ (typecase x
+ (symbol (values (info :variable :documentation x)))))
+ (function
+ (cond ((functionp x)
+ (function-doc x))
+ ((legal-function-name-p x)
+ ;; FIXME: Is it really right to make
+ ;; (DOCUMENTATION '(SETF FOO) 'FUNCTION) equivalent to
+ ;; (DOCUMENTATION 'FOO 'FUNCTION)? That's what CMU CL
+ ;; did, so we do it, but I'm not sure it's what ANSI wants.
+ (values (info :function :documentation
+ (function-name-block-name x))))))
+ (structure
+ (typecase x
+ (symbol (when (eq (info :type :kind x) :instance)
+ (values (info :type :documentation x))))))
+ (type
+ (typecase x
+ (structure-class (values (info :type :documentation (class-name x))))
+ (t (and (typep x 'symbol) (values (info :type :documentation x))))))
+ (setf (info :setf :documentation x))
+ ((t)
+ (typecase x
+ (function (function-doc x))
+ (package (package-doc-string x))
+ (structure-class (values (info :type :documentation (class-name x))))
+ (symbol (try-cmucl-random-doc x doc-type))))
+ (t
+ (typecase x
+ ;; FIXME: This code comes from CMU CL, but
+ ;; TRY-CMUCL-RANDOM-DOC doesn't seem to be defined anywhere
+ ;; in CMU CL. Perhaps it could be defined by analogy with the
+ ;; corresponding SETF FDOCUMENTATION code.
+ (symbol (try-cmucl-random-doc x doc-type)))))))
+(defun (setf fdocumentation) (string name doc-type)
+ ;; FIXME: I think it should be possible to set documentation for
+ ;; things (e.g. compiler macros) named (SETF FOO). fndb.lisp
+ ;; declares DOC-TYPE to be a SYMBOL, which contradicts that. What
+ ;; should be done?
+ (case doc-type
+ (variable (setf (info :variable :documentation name) string))
+ (function (setf (info :function :documentation name) string))
+ (structure (if (eq (info :type :kind name) :instance)
+ (setf (info :type :documentation name) string)
+ (error "~S is not the name of a structure type." name)))
+ (type (setf (info :type :documentation name) string))
+ (setf (setf (info :setf :documentation name) string))
+ (t
+ (let ((pair (assoc doc-type (info :random-documentation :stuff name))))
+ (if pair
+ (setf (cdr pair) string)
+ (push (cons doc-type string)
+ (info :random-documentation :stuff name))))))
+ string)
--- /dev/null
+;;;; This file implements the IR1 finalize phase, which checks for
+;;;; various semantic errors.
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!C")
+
+(file-comment
+ "$Header$")
+
+;;; Give the user grief about optimizations that we weren't able to do. It
+;;; is assumed that they want to hear, or there wouldn't be any entries in the
+;;; table. If the node has been deleted or is no longer a known call, then do
+;;; nothing; some other optimization must have gotten to it.
+(defun note-failed-optimization (node failures)
+ (declare (type combination node) (list failures))
+ (unless (or (node-deleted node)
+ (not (function-info-p (combination-kind node))))
+ (let ((*compiler-error-context* node))
+ (dolist (failure failures)
+ (let ((what (cdr failure))
+ (note (transform-note (car failure))))
+ (cond
+ ((consp what)
+ (compiler-note "unable to ~A because:~%~6T~?"
+ note (first what) (rest what)))
+ ((valid-function-use node what
+ :argument-test #'types-intersect
+ :result-test #'values-types-intersect)
+ (collect ((messages))
+ (flet ((frob (string &rest stuff)
+ (messages string)
+ (messages stuff)))
+ (valid-function-use node what
+ :warning-function #'frob
+ :error-function #'frob))
+
+ (compiler-note "unable to ~A due to type uncertainty:~@
+ ~{~6T~?~^~&~}"
+ note (messages))))))))))
+
+;;; For each named function with an XEP, note the definition of that
+;;; name, and add derived type information to the info environment. We
+;;; also delete the FUNCTIONAL from *FREE-FUNCTIONS* to eliminate the
+;;; possibility that new references might be converted to it.
+(defun finalize-xep-definition (fun)
+ (let* ((leaf (functional-entry-function fun))
+ (name (leaf-name leaf))
+ (dtype (definition-type leaf)))
+ (setf (leaf-type leaf) dtype)
+ (when (or (and name (symbolp name))
+ (and (consp name) (eq (car name) 'setf)))
+ (let* ((where (info :function :where-from name))
+ (*compiler-error-context* (lambda-bind (main-entry leaf)))
+ (global-def (gethash name *free-functions*))
+ (global-p
+ (and (defined-function-p global-def)
+ (eq (defined-function-functional global-def) leaf))))
+ (note-name-defined name :function)
+ (when global-p
+ (remhash name *free-functions*))
+ (ecase where
+ (:assumed
+ (let ((approx-type (info :function :assumed-type name)))
+ (when (and approx-type (function-type-p dtype))
+ (valid-approximate-type approx-type dtype))
+ (setf (info :function :type name) dtype)
+ (setf (info :function :assumed-type name) nil))
+ (setf (info :function :where-from name) :defined))
+ (:declared); Just keep declared type.
+ (:defined
+ (when global-p
+ (setf (info :function :type name) dtype)))))))
+ (values))
+
+;;; Find all calls in Component to assumed functions and update the assumed
+;;; type information. This is delayed until now so that we have the best
+;;; possible information about the actual argument types.
+(defun note-assumed-types (component name var)
+ (when (and (eq (leaf-where-from var) :assumed)
+ (not (and (defined-function-p var)
+ (eq (defined-function-inlinep var) :notinline)))
+ (eq (info :function :where-from name) :assumed)
+ (eq (info :function :kind name) :function))
+ (let ((atype (info :function :assumed-type name)))
+ (dolist (ref (leaf-refs var))
+ (let ((dest (continuation-dest (node-cont ref))))
+ (when (and (eq (block-component (node-block ref)) component)
+ (combination-p dest)
+ (eq (continuation-use (basic-combination-fun dest)) ref))
+ (setq atype (note-function-use dest atype)))))
+ (setf (info :function :assumed-type name) atype))))
+
+;;; Do miscellaneous things that we want to do once all optimization has
+;;; been done:
+;;; -- Record the derived result type before the back-end trashes the
+;;; flow graph.
+;;; -- Note definition of any entry points.
+;;; -- Note any failed optimizations.
+(defun ir1-finalize (component)
+ (declare (type component component))
+ (dolist (fun (component-lambdas component))
+ (case (functional-kind fun)
+ (:external
+ (finalize-xep-definition fun))
+ ((nil)
+ (setf (leaf-type fun) (definition-type fun)))))
+
+ (maphash #'note-failed-optimization
+ (component-failed-optimizations component))
+
+ (maphash #'(lambda (k v)
+ (note-assumed-types component k v))
+ *free-functions*)
+ (values))
--- /dev/null
+;;;; This file implements the IR1 optimization phase of the compiler.
+;;;; IR1 optimization is a grab-bag of optimizations that don't make
+;;;; major changes to the block-level control flow and don't use flow
+;;;; analysis. These optimizations can mostly be classified as
+;;;; "meta-evaluation", but there is a sizable top-down component as
+;;;; well.
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!C")
+
+(file-comment
+ "$Header$")
+\f
+;;;; interface for obtaining results of constant folding
+
+;;; Return true if the sole use of Cont is a reference to a constant leaf.
+(declaim (ftype (function (continuation) boolean) constant-continuation-p))
+(defun constant-continuation-p (cont)
+ (let ((use (continuation-use cont)))
+ (and (ref-p use)
+ (constant-p (ref-leaf use)))))
+
+;;; Return the constant value for a continuation whose only use is a
+;;; constant node.
+(declaim (ftype (function (continuation) t) continuation-value))
+(defun continuation-value (cont)
+ (assert (constant-continuation-p cont))
+ (constant-value (ref-leaf (continuation-use cont))))
+\f
+;;;; interface for obtaining results of type inference
+
+;;; Return a (possibly values) type that describes what we have proven
+;;; about the type of Cont without taking any type assertions into
+;;; consideration. This is just the union of the NODE-DERIVED-TYPE of
+;;; all the uses. Most often people use CONTINUATION-DERIVED-TYPE or
+;;; CONTINUATION-TYPE instead of using this function directly.
+(defun continuation-proven-type (cont)
+ (declare (type continuation cont))
+ (ecase (continuation-kind cont)
+ ((:block-start :deleted-block-start)
+ (let ((uses (block-start-uses (continuation-block cont))))
+ (if uses
+ (do ((res (node-derived-type (first uses))
+ (values-type-union (node-derived-type (first current))
+ res))
+ (current (rest uses) (rest current)))
+ ((null current) res))
+ *empty-type*)))
+ (:inside-block
+ (node-derived-type (continuation-use cont)))))
+
+;;; Our best guess for the type of this continuation's value. Note
+;;; that this may be Values or Function type, which cannot be passed
+;;; as an argument to the normal type operations. See
+;;; Continuation-Type. This may be called on deleted continuations,
+;;; always returning *.
+;;;
+;;; What we do is call CONTINUATION-PROVEN-TYPE and check whether the
+;;; result is a subtype of the assertion. If so, return the proven
+;;; type and set TYPE-CHECK to nil. Otherwise, return the intersection
+;;; of the asserted and proven types, and set TYPE-CHECK T. If
+;;; TYPE-CHECK already has a non-null value, then preserve it. Only in
+;;; the somewhat unusual circumstance of a newly discovered assertion
+;;; will we change TYPE-CHECK from NIL to T.
+;;;
+;;; The result value is cached in the CONTINUATION-%DERIVED-TYPE slot.
+;;; If the slot is true, just return that value, otherwise recompute
+;;; and stash the value there.
+#!-sb-fluid (declaim (inline continuation-derived-type))
+(defun continuation-derived-type (cont)
+ (declare (type continuation cont))
+ (or (continuation-%derived-type cont)
+ (%continuation-derived-type cont)))
+(defun %continuation-derived-type (cont)
+ (declare (type continuation cont))
+ (let ((proven (continuation-proven-type cont))
+ (asserted (continuation-asserted-type cont)))
+ (cond ((values-subtypep proven asserted)
+ (setf (continuation-%type-check cont) nil)
+ (setf (continuation-%derived-type cont) proven))
+ (t
+ (unless (or (continuation-%type-check cont)
+ (not (continuation-dest cont))
+ (eq asserted *universal-type*))
+ (setf (continuation-%type-check cont) t))
+
+ (setf (continuation-%derived-type cont)
+ (values-type-intersection asserted proven))))))
+
+;;; Call CONTINUATION-DERIVED-TYPE to make sure the slot is up to
+;;; date, then return it.
+#!-sb-fluid (declaim (inline continuation-type-check))
+(defun continuation-type-check (cont)
+ (declare (type continuation cont))
+ (continuation-derived-type cont)
+ (continuation-%type-check cont))
+
+;;; Return the derived type for CONT's first value. This is guaranteed
+;;; not to be a VALUES or FUNCTION type.
+(declaim (ftype (function (continuation) ctype) continuation-type))
+(defun continuation-type (cont)
+ (single-value-type (continuation-derived-type cont)))
+\f
+;;;; interface routines used by optimizers
+
+;;; This function is called by optimizers to indicate that something
+;;; interesting has happened to the value of Cont. Optimizers must
+;;; make sure that they don't call for reoptimization when nothing has
+;;; happened, since optimization will fail to terminate.
+;;;
+;;; We clear any cached type for the continuation and set the
+;;; reoptimize flags on everything in sight, unless the continuation
+;;; is deleted (in which case we do nothing.)
+;;;
+;;; Since this can get called during IR1 conversion, we have to be
+;;; careful not to fly into space when the Dest's Prev is missing.
+(defun reoptimize-continuation (cont)
+ (declare (type continuation cont))
+ (unless (member (continuation-kind cont) '(:deleted :unused))
+ (setf (continuation-%derived-type cont) nil)
+ (let ((dest (continuation-dest cont)))
+ (when dest
+ (setf (continuation-reoptimize cont) t)
+ (setf (node-reoptimize dest) t)
+ (let ((prev (node-prev dest)))
+ (when prev
+ (let* ((block (continuation-block prev))
+ (component (block-component block)))
+ (when (typep dest 'cif)
+ (setf (block-test-modified block) t))
+ (setf (block-reoptimize block) t)
+ (setf (component-reoptimize component) t))))))
+ (do-uses (node cont)
+ (setf (block-type-check (node-block node)) t)))
+ (values))
+
+;;; Annotate Node to indicate that its result has been proven to be
+;;; typep to RType. After IR1 conversion has happened, this is the
+;;; only correct way to supply information discovered about a node's
+;;; type. If you screw with the Node-Derived-Type directly, then
+;;; information may be lost and reoptimization may not happen.
+;;;
+;;; What we do is intersect Rtype with Node's Derived-Type. If the
+;;; intersection is different from the old type, then we do a
+;;; Reoptimize-Continuation on the Node-Cont.
+(defun derive-node-type (node rtype)
+ (declare (type node node) (type ctype rtype))
+ (let ((node-type (node-derived-type node)))
+ (unless (eq node-type rtype)
+ (let ((int (values-type-intersection node-type rtype)))
+ (when (type/= node-type int)
+ (when (and *check-consistency*
+ (eq int *empty-type*)
+ (not (eq rtype *empty-type*)))
+ (let ((*compiler-error-context* node))
+ (compiler-warning
+ "New inferred type ~S conflicts with old type:~
+ ~% ~S~%*** Bug?"
+ (type-specifier rtype) (type-specifier node-type))))
+ (setf (node-derived-type node) int)
+ (reoptimize-continuation (node-cont node))))))
+ (values))
+
+;;; Similar to Derive-Node-Type, but asserts that it is an error for
+;;; Cont's value not to be typep to Type. If we improve the assertion,
+;;; we set TYPE-CHECK and TYPE-ASSERTED to guarantee that the new
+;;; assertion will be checked.
+(defun assert-continuation-type (cont type)
+ (declare (type continuation cont) (type ctype type))
+ (let ((cont-type (continuation-asserted-type cont)))
+ (unless (eq cont-type type)
+ (let ((int (values-type-intersection cont-type type)))
+ (when (type/= cont-type int)
+ (setf (continuation-asserted-type cont) int)
+ (do-uses (node cont)
+ (setf (block-attributep (block-flags (node-block node))
+ type-check type-asserted)
+ t))
+ (reoptimize-continuation cont)))))
+ (values))
+
+;;; Assert that Call is to a function of the specified Type. It is
+;;; assumed that the call is legal and has only constants in the
+;;; keyword positions.
+(defun assert-call-type (call type)
+ (declare (type combination call) (type function-type type))
+ (derive-node-type call (function-type-returns type))
+ (let ((args (combination-args call)))
+ (dolist (req (function-type-required type))
+ (when (null args) (return-from assert-call-type))
+ (let ((arg (pop args)))
+ (assert-continuation-type arg req)))
+ (dolist (opt (function-type-optional type))
+ (when (null args) (return-from assert-call-type))
+ (let ((arg (pop args)))
+ (assert-continuation-type arg opt)))
+
+ (let ((rest (function-type-rest type)))
+ (when rest
+ (dolist (arg args)
+ (assert-continuation-type arg rest))))
+
+ (dolist (key (function-type-keywords type))
+ (let ((name (key-info-name key)))
+ (do ((arg args (cddr arg)))
+ ((null arg))
+ (when (eq (continuation-value (first arg)) name)
+ (assert-continuation-type
+ (second arg) (key-info-type key)))))))
+ (values))
+\f
+;;;; IR1-OPTIMIZE
+
+;;; Do one forward pass over Component, deleting unreachable blocks
+;;; and doing IR1 optimizations. We can ignore all blocks that don't
+;;; have the Reoptimize flag set. If Component-Reoptimize is true when
+;;; we are done, then another iteration would be beneficial.
+;;;
+;;; We delete blocks when there is either no predecessor or the block
+;;; is in a lambda that has been deleted. These blocks would
+;;; eventually be deleted by DFO recomputation, but doing it here
+;;; immediately makes the effect available to IR1 optimization.
+(defun ir1-optimize (component)
+ (declare (type component component))
+ (setf (component-reoptimize component) nil)
+ (do-blocks (block component)
+ (cond
+ ((or (block-delete-p block)
+ (null (block-pred block))
+ (eq (functional-kind (block-home-lambda block)) :deleted))
+ (delete-block block))
+ (t
+ (loop
+ (let ((succ (block-succ block)))
+ (unless (and succ (null (rest succ)))
+ (return)))
+
+ (let ((last (block-last block)))
+ (typecase last
+ (cif
+ (flush-dest (if-test last))
+ (when (unlink-node last)
+ (return)))
+ (exit
+ (when (maybe-delete-exit last)
+ (return)))))
+
+ (unless (join-successor-if-possible block)
+ (return)))
+
+ (when (and (block-reoptimize block) (block-component block))
+ (assert (not (block-delete-p block)))
+ (ir1-optimize-block block))
+
+ (when (and (block-flush-p block) (block-component block))
+ (assert (not (block-delete-p block)))
+ (flush-dead-code block)))))
+
+ (values))
+
+;;; Loop over the nodes in Block, looking for stuff that needs to be
+;;; optimized. We dispatch off of the type of each node with its
+;;; reoptimize flag set:
+
+;;; -- With a combination, we call Propagate-Function-Change whenever
+;;; the function changes, and call IR1-Optimize-Combination if any
+;;; argument changes.
+;;; -- With an Exit, we derive the node's type from the Value's type. We don't
+;;; propagate Cont's assertion to the Value, since if we did, this would
+;;; move the checking of Cont's assertion to the exit. This wouldn't work
+;;; with Catch and UWP, where the Exit node is just a placeholder for the
+;;; actual unknown exit.
+;;;
+;;; Note that we clear the node & block reoptimize flags *before* doing the
+;;; optimization. This ensures that the node or block will be reoptimized if
+;;; necessary. We leave the NODE-OPTIMIZE flag set going into
+;;; IR1-OPTIMIZE-RETURN, since IR1-OPTIMIZE-RETURN wants to clear the flag
+;;; itself.
+(defun ir1-optimize-block (block)
+ (declare (type cblock block))
+ (setf (block-reoptimize block) nil)
+ (do-nodes (node cont block :restart-p t)
+ (when (node-reoptimize node)
+ (setf (node-reoptimize node) nil)
+ (typecase node
+ (ref)
+ (combination
+ (ir1-optimize-combination node))
+ (cif
+ (ir1-optimize-if node))
+ (creturn
+ (setf (node-reoptimize node) t)
+ (ir1-optimize-return node))
+ (mv-combination
+ (ir1-optimize-mv-combination node))
+ (exit
+ (let ((value (exit-value node)))
+ (when value
+ (derive-node-type node (continuation-derived-type value)))))
+ (cset
+ (ir1-optimize-set node)))))
+ (values))
+
+;;; We cannot combine with a successor block if:
+;;; 1. The successor has more than one predecessor.
+;;; 2. The last node's Cont is also used somewhere else.
+;;; 3. The successor is the current block (infinite loop).
+;;; 4. The next block has a different cleanup, and thus we may want to insert
+;;; cleanup code between the two blocks at some point.
+;;; 5. The next block has a different home lambda, and thus the control
+;;; transfer is a non-local exit.
+;;;
+;;; If we succeed, we return true, otherwise false.
+;;;
+;;; Joining is easy when the successor's Start continuation is the same from
+;;; our Last's Cont. If they differ, then we can still join when the last
+;;; continuation has no next and the next continuation has no uses. In this
+;;; case, we replace the next continuation with the last before joining the
+;;; blocks.
+(defun join-successor-if-possible (block)
+ (declare (type cblock block))
+ (let ((next (first (block-succ block))))
+ (when (block-start next)
+ (let* ((last (block-last block))
+ (last-cont (node-cont last))
+ (next-cont (block-start next)))
+ (cond ((or (rest (block-pred next))
+ (not (eq (continuation-use last-cont) last))
+ (eq next block)
+ (not (eq (block-end-cleanup block)
+ (block-start-cleanup next)))
+ (not (eq (block-home-lambda block)
+ (block-home-lambda next))))
+ nil)
+ ((eq last-cont next-cont)
+ (join-blocks block next)
+ t)
+ ((and (null (block-start-uses next))
+ (eq (continuation-kind last-cont) :inside-block))
+ (let ((next-node (continuation-next next-cont)))
+ ;; If next-cont does have a dest, it must be unreachable,
+ ;; since there are no uses. DELETE-CONTINUATION will mark the
+ ;; dest block as delete-p [and also this block, unless it is
+ ;; no longer backward reachable from the dest block.]
+ (delete-continuation next-cont)
+ (setf (node-prev next-node) last-cont)
+ (setf (continuation-next last-cont) next-node)
+ (setf (block-start next) last-cont)
+ (join-blocks block next))
+ t)
+ (t
+ nil))))))
+
+;;; Join together two blocks which have the same ending/starting
+;;; continuation. The code in Block2 is moved into Block1 and Block2 is
+;;; deleted from the DFO. We combine the optimize flags for the two blocks so
+;;; that any indicated optimization gets done.
+(defun join-blocks (block1 block2)
+ (declare (type cblock block1 block2))
+ (let* ((last (block-last block2))
+ (last-cont (node-cont last))
+ (succ (block-succ block2))
+ (start2 (block-start block2)))
+ (do ((cont start2 (node-cont (continuation-next cont))))
+ ((eq cont last-cont)
+ (when (eq (continuation-kind last-cont) :inside-block)
+ (setf (continuation-block last-cont) block1)))
+ (setf (continuation-block cont) block1))
+
+ (unlink-blocks block1 block2)
+ (dolist (block succ)
+ (unlink-blocks block2 block)
+ (link-blocks block1 block))
+
+ (setf (block-last block1) last)
+ (setf (continuation-kind start2) :inside-block))
+
+ (setf (block-flags block1)
+ (attributes-union (block-flags block1)
+ (block-flags block2)
+ (block-attributes type-asserted test-modified)))
+
+ (let ((next (block-next block2))
+ (prev (block-prev block2)))
+ (setf (block-next prev) next)
+ (setf (block-prev next) prev))
+
+ (values))
+
+;;; Delete any nodes in Block whose value is unused and have no
+;;; side-effects. We can delete sets of lexical variables when the set
+;;; variable has no references.
+;;;
+;;; [### For now, don't delete potentially flushable calls when they have the
+;;; Call attribute. Someday we should look at the funcitonal args to determine
+;;; if they have any side-effects.]
+(defun flush-dead-code (block)
+ (declare (type cblock block))
+ (do-nodes-backwards (node cont block)
+ (unless (continuation-dest cont)
+ (typecase node
+ (ref
+ (delete-ref node)
+ (unlink-node node))
+ (combination
+ (let ((info (combination-kind node)))
+ (when (function-info-p info)
+ (let ((attr (function-info-attributes info)))
+ (when (and (ir1-attributep attr flushable)
+ (not (ir1-attributep attr call)))
+ (flush-dest (combination-fun node))
+ (dolist (arg (combination-args node))
+ (flush-dest arg))
+ (unlink-node node))))))
+ (mv-combination
+ (when (eq (basic-combination-kind node) :local)
+ (let ((fun (combination-lambda node)))
+ (when (dolist (var (lambda-vars fun) t)
+ (when (or (leaf-refs var)
+ (lambda-var-sets var))
+ (return nil)))
+ (flush-dest (first (basic-combination-args node)))
+ (delete-let fun)))))
+ (exit
+ (let ((value (exit-value node)))
+ (when value
+ (flush-dest value)
+ (setf (exit-value node) nil))))
+ (cset
+ (let ((var (set-var node)))
+ (when (and (lambda-var-p var)
+ (null (leaf-refs var)))
+ (flush-dest (set-value node))
+ (setf (basic-var-sets var)
+ (delete node (basic-var-sets var)))
+ (unlink-node node)))))))
+
+ (setf (block-flush-p block) nil)
+ (values))
+\f
+;;;; local call return type propagation
+
+;;; This function is called on RETURN nodes that have their REOPTIMIZE flag
+;;; set. It iterates over the uses of the RESULT, looking for interesting
+;;; stuff to update the TAIL-SET. If a use isn't a local call, then we union
+;;; its type together with the types of other such uses. We assign to the
+;;; RETURN-RESULT-TYPE the intersection of this type with the RESULT's asserted
+;;; type. We can make this intersection now (potentially before type checking)
+;;; because this assertion on the result will eventually be checked (if
+;;; appropriate.)
+;;;
+;;; We call MAYBE-CONVERT-TAIL-LOCAL-CALL on each local non-MV combination,
+;;; which may change the succesor of the call to be the called function, and if
+;;; so, checks if the call can become an assignment. If we convert to an
+;;; assignment, we abort, since the RETURN has been deleted.
+(defun find-result-type (node)
+ (declare (type creturn node))
+ (let ((result (return-result node)))
+ (collect ((use-union *empty-type* values-type-union))
+ (do-uses (use result)
+ (cond ((and (basic-combination-p use)
+ (eq (basic-combination-kind use) :local))
+ (assert (eq (lambda-tail-set (node-home-lambda use))
+ (lambda-tail-set (combination-lambda use))))
+ (when (combination-p use)
+ (when (nth-value 1 (maybe-convert-tail-local-call use))
+ (return-from find-result-type (values)))))
+ (t
+ (use-union (node-derived-type use)))))
+ (let ((int (values-type-intersection
+ (continuation-asserted-type result)
+ (use-union))))
+ (setf (return-result-type node) int))))
+ (values))
+
+;;; Do stuff to realize that something has changed about the value delivered
+;;; to a return node. Since we consider the return values of all functions in
+;;; the tail set to be equivalent, this amounts to bringing the entire tail set
+;;; up to date. We iterate over the returns for all the functions in the tail
+;;; set, reanalyzing them all (not treating Node specially.)
+;;;
+;;; When we are done, we check whether the new type is different from the old
+;;; TAIL-SET-TYPE. If so, we set the type and also reoptimize all the
+;;; continuations for references to functions in the tail set. This will cause
+;;; IR1-OPTIMIZE-COMBINATION to derive the new type as the results of the
+;;; calls.
+(defun ir1-optimize-return (node)
+ (declare (type creturn node))
+ (let* ((tails (lambda-tail-set (return-lambda node)))
+ (funs (tail-set-functions tails)))
+ (collect ((res *empty-type* values-type-union))
+ (dolist (fun funs)
+ (let ((return (lambda-return fun)))
+ (when return
+ (when (node-reoptimize return)
+ (setf (node-reoptimize return) nil)
+ (find-result-type return))
+ (res (return-result-type return)))))
+
+ (when (type/= (res) (tail-set-type tails))
+ (setf (tail-set-type tails) (res))
+ (dolist (fun (tail-set-functions tails))
+ (dolist (ref (leaf-refs fun))
+ (reoptimize-continuation (node-cont ref)))))))
+
+ (values))
+\f
+;;;; IF optimization
+
+;;; If the test has multiple uses, replicate the node when possible.
+;;; Also check whether the predicate is known to be true or false,
+;;; deleting the IF node in favor of the appropriate branch when this
+;;; is the case.
+(defun ir1-optimize-if (node)
+ (declare (type cif node))
+ (let ((test (if-test node))
+ (block (node-block node)))
+
+ (when (and (eq (block-start block) test)
+ (eq (continuation-next test) node)
+ (rest (block-start-uses block)))
+ (do-uses (use test)
+ (when (immediately-used-p test use)
+ (convert-if-if use node)
+ (when (continuation-use test) (return)))))
+
+ (let* ((type (continuation-type test))
+ (victim
+ (cond ((constant-continuation-p test)
+ (if (continuation-value test)
+ (if-alternative node)
+ (if-consequent node)))
+ ((not (types-intersect type (specifier-type 'null)))
+ (if-alternative node))
+ ((type= type (specifier-type 'null))
+ (if-consequent node)))))
+ (when victim
+ (flush-dest test)
+ (when (rest (block-succ block))
+ (unlink-blocks block victim))
+ (setf (component-reanalyze (block-component (node-block node))) t)
+ (unlink-node node))))
+ (values))
+
+;;; Create a new copy of an IF Node that tests the value of the node
+;;; Use. The test must have >1 use, and must be immediately used by
+;;; Use. Node must be the only node in its block (implying that
+;;; block-start = if-test).
+;;;
+;;; This optimization has an effect semantically similar to the
+;;; source-to-source transformation:
+;;; (IF (IF A B C) D E) ==>
+;;; (IF A (IF B D E) (IF C D E))
+;;;
+;;; We clobber the NODE-SOURCE-PATH of both the original and the new
+;;; node so that dead code deletion notes will definitely not consider
+;;; either node to be part of the original source. One node might
+;;; become unreachable, resulting in a spurious note.
+(defun convert-if-if (use node)
+ (declare (type node use) (type cif node))
+ (with-ir1-environment node
+ (let* ((block (node-block node))
+ (test (if-test node))
+ (cblock (if-consequent node))
+ (ablock (if-alternative node))
+ (use-block (node-block use))
+ (dummy-cont (make-continuation))
+ (new-cont (make-continuation))
+ (new-node (make-if :test new-cont
+ :consequent cblock
+ :alternative ablock))
+ (new-block (continuation-starts-block new-cont)))
+ (prev-link new-node new-cont)
+ (setf (continuation-dest new-cont) new-node)
+ (add-continuation-use new-node dummy-cont)
+ (setf (block-last new-block) new-node)
+
+ (unlink-blocks use-block block)
+ (delete-continuation-use use)
+ (add-continuation-use use new-cont)
+ (link-blocks use-block new-block)
+
+ (link-blocks new-block cblock)
+ (link-blocks new-block ablock)
+
+ (push "<IF Duplication>" (node-source-path node))
+ (push "<IF Duplication>" (node-source-path new-node))
+
+ (reoptimize-continuation test)
+ (reoptimize-continuation new-cont)
+ (setf (component-reanalyze *current-component*) t)))
+ (values))
+\f
+;;;; exit IR1 optimization
+
+;;; This function attempts to delete an exit node, returning true if
+;;; it deletes the block as a consequence:
+;;; -- If the exit is degenerate (has no Entry), then we don't do anything,
+;;; since there is nothing to be done.
+;;; -- If the exit node and its Entry have the same home lambda then we know
+;;; the exit is local, and can delete the exit. We change uses of the
+;;; Exit-Value to be uses of the original continuation, then unlink the
+;;; node. If the exit is to a TR context, then we must do MERGE-TAIL-SETS
+;;; on any local calls which delivered their value to this exit.
+;;; -- If there is no value (as in a GO), then we skip the value semantics.
+;;;
+;;; This function is also called by environment analysis, since it
+;;; wants all exits to be optimized even if normal optimization was
+;;; omitted.
+(defun maybe-delete-exit (node)
+ (declare (type exit node))
+ (let ((value (exit-value node))
+ (entry (exit-entry node))
+ (cont (node-cont node)))
+ (when (and entry
+ (eq (node-home-lambda node) (node-home-lambda entry)))
+ (setf (entry-exits entry) (delete node (entry-exits entry)))
+ (prog1
+ (unlink-node node)
+ (when value
+ (collect ((merges))
+ (when (return-p (continuation-dest cont))
+ (do-uses (use value)
+ (when (and (basic-combination-p use)
+ (eq (basic-combination-kind use) :local))
+ (merges use))))
+ (substitute-continuation-uses cont value)
+ (dolist (merge (merges))
+ (merge-tail-sets merge))))))))
+\f
+;;;; combination IR1 optimization
+
+;;; Report as we try each transform?
+#!+sb-show
+(defvar *show-transforms-p* nil)
+
+;;; Do IR1 optimizations on a Combination node.
+(declaim (ftype (function (combination) (values)) ir1-optimize-combination))
+(defun ir1-optimize-combination (node)
+ (when (continuation-reoptimize (basic-combination-fun node))
+ (propagate-function-change node))
+ (let ((args (basic-combination-args node))
+ (kind (basic-combination-kind node)))
+ (case kind
+ (:local
+ (let ((fun (combination-lambda node)))
+ (if (eq (functional-kind fun) :let)
+ (propagate-let-args node fun)
+ (propagate-local-call-args node fun))))
+ ((:full :error)
+ (dolist (arg args)
+ (when arg
+ (setf (continuation-reoptimize arg) nil))))
+ (t
+ (dolist (arg args)
+ (when arg
+ (setf (continuation-reoptimize arg) nil)))
+
+ (let ((attr (function-info-attributes kind)))
+ (when (and (ir1-attributep attr foldable)
+ ;; KLUDGE: The next test could be made more sensitive,
+ ;; only suppressing constant-folding of functions with
+ ;; CALL attributes when they're actually passed
+ ;; function arguments. -- WHN 19990918
+ (not (ir1-attributep attr call))
+ (every #'constant-continuation-p args)
+ (continuation-dest (node-cont node))
+ ;; Even if the function is foldable in principle,
+ ;; it might be one of our low-level
+ ;; implementation-specific functions. Such
+ ;; functions don't necessarily exist at runtime on
+ ;; a plain vanilla ANSI Common Lisp
+ ;; cross-compilation host, in which case the
+ ;; cross-compiler can't fold it because the
+ ;; cross-compiler doesn't know how to evaluate it.
+ #+sb-xc-host
+ (let* ((ref (continuation-use (combination-fun node)))
+ (fun (leaf-name (ref-leaf ref))))
+ (fboundp fun)))
+ (constant-fold-call node)
+ (return-from ir1-optimize-combination)))
+
+ (let ((fun (function-info-derive-type kind)))
+ (when fun
+ (let ((res (funcall fun node)))
+ (when res
+ (derive-node-type node res)
+ (maybe-terminate-block node nil)))))
+
+ (let ((fun (function-info-optimizer kind)))
+ (unless (and fun (funcall fun node))
+ (dolist (x (function-info-transforms kind))
+ #!+sb-show
+ (when *show-transforms-p*
+ (let* ((cont (basic-combination-fun node))
+ (fname (continuation-function-name cont t)))
+ (/show "trying transform" x (transform-function x) "for" fname)))
+ (unless (ir1-transform node x)
+ #!+sb-show
+ (when *show-transforms-p*
+ (/show "quitting because IR1-TRANSFORM result was NIL"))
+ (return))))))))
+
+ (values))
+
+;;; If Call is to a function that doesn't return (i.e. return type is
+;;; NIL), then terminate the block there, and link it to the component
+;;; tail. We also change the call's CONT to be a dummy continuation to
+;;; prevent the use from confusing things.
+;;;
+;;; Except when called during IR1, we delete the continuation if it
+;;; has no other uses. (If it does have other uses, we reoptimize.)
+;;;
+;;; Termination on the basis of a continuation type assertion is
+;;; inhibited when:
+;;; -- The continuation is deleted (hence the assertion is spurious), or
+;;; -- We are in IR1 conversion (where THE assertions are subject to
+;;; weakening.)
+(defun maybe-terminate-block (call ir1-p)
+ (declare (type basic-combination call))
+ (let* ((block (node-block call))
+ (cont (node-cont call))
+ (tail (component-tail (block-component block)))
+ (succ (first (block-succ block))))
+ (unless (or (and (eq call (block-last block)) (eq succ tail))
+ (block-delete-p block)
+ *converting-for-interpreter*)
+ (when (or (and (eq (continuation-asserted-type cont) *empty-type*)
+ (not (or ir1-p (eq (continuation-kind cont) :deleted))))
+ (eq (node-derived-type call) *empty-type*))
+ (cond (ir1-p
+ (delete-continuation-use call)
+ (cond
+ ((block-last block)
+ (assert (and (eq (block-last block) call)
+ (eq (continuation-kind cont) :block-start))))
+ (t
+ (setf (block-last block) call)
+ (link-blocks block (continuation-starts-block cont)))))
+ (t
+ (node-ends-block call)
+ (delete-continuation-use call)
+ (if (eq (continuation-kind cont) :unused)
+ (delete-continuation cont)
+ (reoptimize-continuation cont))))
+
+ (unlink-blocks block (first (block-succ block)))
+ (setf (component-reanalyze (block-component block)) t)
+ (assert (not (block-succ block)))
+ (link-blocks block tail)
+ (add-continuation-use call (make-continuation))
+ t))))
+
+;;; Called both by IR1 conversion and IR1 optimization when they have
+;;; verified the type signature for the call, and are wondering if
+;;; something should be done to special-case the call. If Call is a
+;;; call to a global function, then see whether it defined or known:
+;;; -- If a DEFINED-FUNCTION should be inline expanded, then convert the
+;;; expansion and change the call to call it. Expansion is enabled if
+;;; :INLINE or if space=0. If the FUNCTIONAL slot is true, we never expand,
+;;; since this function has already been converted. Local call analysis
+;;; will duplicate the definition if necessary. We claim that the parent
+;;; form is LABELS for context declarations, since we don't want it to be
+;;; considered a real global function.
+;;; -- In addition to a direct check for the function name in the table, we
+;;; also must check for slot accessors. If the function is a slot accessor,
+;;; then we set the combination kind to the function info of %Slot-Setter or
+;;; %Slot-Accessor, as appropriate.
+;;; -- If it is a known function, mark it as such by setting the Kind.
+;;;
+;;; We return the leaf referenced (NIL if not a leaf) and the
+;;; function-info assigned.
+(defun recognize-known-call (call ir1-p)
+ (declare (type combination call))
+ (let* ((ref (continuation-use (basic-combination-fun call)))
+ (leaf (when (ref-p ref) (ref-leaf ref)))
+ (inlinep (if (and (defined-function-p leaf)
+ (not (byte-compiling)))
+ (defined-function-inlinep leaf)
+ :no-chance)))
+ (cond
+ ((eq inlinep :notinline) (values nil nil))
+ ((not (and (global-var-p leaf)
+ (eq (global-var-kind leaf) :global-function)))
+ (values leaf nil))
+ ((and (ecase inlinep
+ (:inline t)
+ (:no-chance nil)
+ ((nil :maybe-inline) (policy call (zerop space))))
+ (defined-function-inline-expansion leaf)
+ (let ((fun (defined-function-functional leaf)))
+ (or (not fun)
+ (and (eq inlinep :inline) (functional-kind fun))))
+ (inline-expansion-ok call))
+ (flet ((frob ()
+ (let ((res (ir1-convert-lambda-for-defun
+ (defined-function-inline-expansion leaf)
+ leaf t
+ #'ir1-convert-inline-lambda)))
+ (setf (defined-function-functional leaf) res)
+ (change-ref-leaf ref res))))
+ (if ir1-p
+ (frob)
+ (with-ir1-environment call
+ (frob)
+ (local-call-analyze *current-component*))))
+
+ (values (ref-leaf (continuation-use (basic-combination-fun call)))
+ nil))
+ (t
+ (let* ((name (leaf-name leaf))
+ (info (info :function :info
+ (if (slot-accessor-p leaf)
+ (if (consp name)
+ '%slot-setter
+ '%slot-accessor)
+ name))))
+ (if info
+ (values leaf (setf (basic-combination-kind call) info))
+ (values leaf nil)))))))
+
+;;; Check whether CALL satisfies TYPE. If so, apply the type to the
+;;; call, and do MAYBE-TERMINATE-BLOCK and return the values of
+;;; RECOGNIZE-KNOWN-CALL. If an error, set the combination kind and
+;;; return NIL, NIL. If the type is just FUNCTION, then skip the
+;;; syntax check, arg/result type processing, but still call
+;;; RECOGNIZE-KNOWN-CALL, since the call might be to a known lambda,
+;;; and that checking is done by local call analysis.
+(defun validate-call-type (call type ir1-p)
+ (declare (type combination call) (type ctype type))
+ (cond ((not (function-type-p type))
+ (assert (multiple-value-bind (val win)
+ (csubtypep type (specifier-type 'function))
+ (or val (not win))))
+ (recognize-known-call call ir1-p))
+ ((valid-function-use call type
+ :argument-test #'always-subtypep
+ :result-test #'always-subtypep
+ :error-function #'compiler-warning
+ :warning-function #'compiler-note)
+ (assert-call-type call type)
+ (maybe-terminate-block call ir1-p)
+ (recognize-known-call call ir1-p))
+ (t
+ (setf (combination-kind call) :error)
+ (values nil nil))))
+
+;;; This is called by IR1-OPTIMIZE when the function for a call has
+;;; changed. If the call is local, we try to let-convert it, and
+;;; derive the result type. If it is a :FULL call, we validate it
+;;; against the type, which recognizes known calls, does inline
+;;; expansion, etc. If a call to a predicate in a non-conditional
+;;; position or to a function with a source transform, then we
+;;; reconvert the form to give IR1 another chance.
+(defun propagate-function-change (call)
+ (declare (type combination call))
+ (let ((*compiler-error-context* call)
+ (fun-cont (basic-combination-fun call)))
+ (setf (continuation-reoptimize fun-cont) nil)
+ (case (combination-kind call)
+ (:local
+ (let ((fun (combination-lambda call)))
+ (maybe-let-convert fun)
+ (unless (member (functional-kind fun) '(:let :assignment :deleted))
+ (derive-node-type call (tail-set-type (lambda-tail-set fun))))))
+ (:full
+ (multiple-value-bind (leaf info)
+ (validate-call-type call (continuation-type fun-cont) nil)
+ (cond ((functional-p leaf)
+ (convert-call-if-possible
+ (continuation-use (basic-combination-fun call))
+ call))
+ ((not leaf))
+ ((or (info :function :source-transform (leaf-name leaf))
+ (and info
+ (ir1-attributep (function-info-attributes info)
+ predicate)
+ (let ((dest (continuation-dest (node-cont call))))
+ (and dest (not (if-p dest))))))
+ (let ((name (leaf-name leaf)))
+ (when (symbolp name)
+ (let ((dums (loop repeat (length (combination-args call))
+ collect (gensym))))
+ (transform-call call
+ `(lambda ,dums
+ (,name ,@dums))))))))))))
+ (values))
+\f
+;;;; known function optimization
+
+;;; Add a failed optimization note to FAILED-OPTIMZATIONS for Node,
+;;; Fun and Args. If there is already a note for Node and Transform,
+;;; replace it, otherwise add a new one.
+(defun record-optimization-failure (node transform args)
+ (declare (type combination node) (type transform transform)
+ (type (or function-type list) args))
+ (let* ((table (component-failed-optimizations *component-being-compiled*))
+ (found (assoc transform (gethash node table))))
+ (if found
+ (setf (cdr found) args)
+ (push (cons transform args) (gethash node table))))
+ (values))
+
+;;; Attempt to transform NODE using TRANSFORM-FUNCTION, subject to the
+;;; call type constraint TRANSFORM-TYPE. If we are inhibited from
+;;; doing the transform for some reason and FLAME is true, then we
+;;; make a note of the message in FAILED-OPTIMIZATIONS for IR1
+;;; finalize to pick up. We return true if the transform failed, and
+;;; thus further transformation should be attempted. We return false
+;;; if either the transform succeeded or was aborted.
+(defun ir1-transform (node transform)
+ (declare (type combination node) (type transform transform))
+ (let* ((type (transform-type transform))
+ (fun (transform-function transform))
+ (constrained (function-type-p type))
+ (table (component-failed-optimizations *component-being-compiled*))
+ (flame (if (transform-important transform)
+ (policy node (>= speed brevity))
+ (policy node (> speed brevity))))
+ (*compiler-error-context* node))
+ (cond ((not (member (transform-when transform)
+ (if *byte-compiling*
+ '(:byte :both)
+ '(:native :both))))
+ ;; FIXME: Make sure that there's a transform for
+ ;; (MEMBER SYMBOL ..) into MEMQ.
+ ;; FIXME: Note that when/if I make SHARE operation to shared
+ ;; constant data between objects in the system, remember that a
+ ;; SHAREd list, or other SHAREd compound object, can be processed
+ ;; recursively, so that e.g. the two lists above can share their
+ ;; '(:BOTH) tail sublists.
+ (let ((when (transform-when transform)))
+ (not (or (eq when :both)
+ (eq when (if *byte-compiling* :byte :native)))))
+ t)
+ ((or (not constrained)
+ (valid-function-use node type :strict-result t))
+ (multiple-value-bind (severity args)
+ (catch 'give-up-ir1-transform
+ (transform-call node (funcall fun node))
+ (values :none nil))
+ (ecase severity
+ (:none
+ (remhash node table)
+ nil)
+ (:aborted
+ (setf (combination-kind node) :error)
+ (when args
+ (apply #'compiler-warning args))
+ (remhash node table)
+ nil)
+ (:failure
+ (if args
+ (when flame
+ (record-optimization-failure node transform args))
+ (setf (gethash node table)
+ (remove transform (gethash node table) :key #'car)))
+ t))))
+ ((and flame
+ (valid-function-use node
+ type
+ :argument-test #'types-intersect
+ :result-test #'values-types-intersect))
+ (record-optimization-failure node transform type)
+ t)
+ (t
+ t))))
+
+;;; Just throw the severity and args...
+(declaim (ftype (function (&rest t) nil) give-up-ir1-transform))
+(defun give-up-ir1-transform (&rest args)
+ #!+sb-doc
+ "This function is used to throw out of an IR1 transform, aborting this
+ attempt to transform the call, but admitting the possibility that this or
+ some other transform will later succeed. If arguments are supplied, they are
+ format arguments for an efficiency note."
+ (throw 'give-up-ir1-transform (values :failure args)))
+(defun abort-ir1-transform (&rest args)
+ #!+sb-doc
+ "This function is used to throw out of an IR1 transform and force a normal
+ call to the function at run time. No further optimizations will be
+ attempted."
+ (throw 'give-up-ir1-transform (values :aborted args)))
+
+;;; Take the lambda-expression Res, IR1 convert it in the proper
+;;; environment, and then install it as the function for the call
+;;; Node. We do local call analysis so that the new function is
+;;; integrated into the control flow.
+(defun transform-call (node res)
+ (declare (type combination node) (list res))
+ (with-ir1-environment node
+ (let ((new-fun (ir1-convert-inline-lambda res))
+ (ref (continuation-use (combination-fun node))))
+ (change-ref-leaf ref new-fun)
+ (setf (combination-kind node) :full)
+ (local-call-analyze *current-component*)))
+ (values))
+
+;;; Replace a call to a foldable function of constant arguments with
+;;; the result of evaluating the form. We insert the resulting
+;;; constant node after the call, stealing the call's continuation. We
+;;; give the call a continuation with no Dest, which should cause it
+;;; and its arguments to go away. If there is an error during the
+;;; evaluation, we give a warning and leave the call alone, making the
+;;; call a :ERROR call.
+;;;
+;;; If there is more than one value, then we transform the call into a
+;;; values form.
+(defun constant-fold-call (call)
+ (declare (type combination call))
+ (let* ((args (mapcar #'continuation-value (combination-args call)))
+ (ref (continuation-use (combination-fun call)))
+ (fun (leaf-name (ref-leaf ref))))
+
+ (multiple-value-bind (values win)
+ (careful-call fun args call "constant folding")
+ (if (not win)
+ (setf (combination-kind call) :error)
+ (let ((dummies (loop repeat (length args)
+ collect (gensym))))
+ (transform-call
+ call
+ `(lambda ,dummies
+ (declare (ignore ,@dummies))
+ (values ,@(mapcar #'(lambda (x) `',x) values))))))))
+
+ (values))
+\f
+;;;; local call optimization
+
+;;; Propagate Type to Leaf and its Refs, marking things changed. If
+;;; the leaf type is a function type, then just leave it alone, since
+;;; TYPE is never going to be more specific than that (and
+;;; TYPE-INTERSECTION would choke.)
+(defun propagate-to-refs (leaf type)
+ (declare (type leaf leaf) (type ctype type))
+ (let ((var-type (leaf-type leaf)))
+ (unless (function-type-p var-type)
+ (let ((int (type-intersection var-type type)))
+ (when (type/= int var-type)
+ (setf (leaf-type leaf) int)
+ (dolist (ref (leaf-refs leaf))
+ (derive-node-type ref int))))
+ (values))))
+
+;;; Figure out the type of a LET variable that has sets. We compute
+;;; the union of the initial value Type and the types of all the set
+;;; values and to a PROPAGATE-TO-REFS with this type.
+(defun propagate-from-sets (var type)
+ (collect ((res type type-union))
+ (dolist (set (basic-var-sets var))
+ (res (continuation-type (set-value set)))
+ (setf (node-reoptimize set) nil))
+ (propagate-to-refs var (res)))
+ (values))
+
+;;; If a LET variable, find the initial value's type and do
+;;; PROPAGATE-FROM-SETS. We also derive the VALUE's type as the node's
+;;; type.
+(defun ir1-optimize-set (node)
+ (declare (type cset node))
+ (let ((var (set-var node)))
+ (when (and (lambda-var-p var) (leaf-refs var))
+ (let ((home (lambda-var-home var)))
+ (when (eq (functional-kind home) :let)
+ (let ((iv (let-var-initial-value var)))
+ (setf (continuation-reoptimize iv) nil)
+ (propagate-from-sets var (continuation-type iv)))))))
+
+ (derive-node-type node (continuation-type (set-value node)))
+ (values))
+
+;;; Return true if the value of Ref will always be the same (and is
+;;; thus legal to substitute.)
+(defun constant-reference-p (ref)
+ (declare (type ref ref))
+ (let ((leaf (ref-leaf ref)))
+ (typecase leaf
+ ((or constant functional) t)
+ (lambda-var
+ (null (lambda-var-sets leaf)))
+ (defined-function
+ (not (eq (defined-function-inlinep leaf) :notinline)))
+ (global-var
+ (case (global-var-kind leaf)
+ (:global-function t)
+ (:constant t))))))
+
+;;; If we have a non-set LET var with a single use, then (if possible)
+;;; replace the variable reference's CONT with the arg continuation.
+;;; This is inhibited when:
+;;; -- CONT has other uses, or
+;;; -- CONT receives multiple values, or
+;;; -- the reference is in a different environment from the variable, or
+;;; -- either continuation has a funky TYPE-CHECK annotation.
+;;; -- the continuations have incompatible assertions, so the new asserted type
+;;; would be NIL.
+;;; -- the var's DEST has a different policy than the ARG's (think safety).
+;;;
+;;; We change the Ref to be a reference to NIL with unused value, and
+;;; let it be flushed as dead code. A side-effect of this substitution
+;;; is to delete the variable.
+(defun substitute-single-use-continuation (arg var)
+ (declare (type continuation arg) (type lambda-var var))
+ (let* ((ref (first (leaf-refs var)))
+ (cont (node-cont ref))
+ (cont-atype (continuation-asserted-type cont))
+ (dest (continuation-dest cont)))
+ (when (and (eq (continuation-use cont) ref)
+ dest
+ (not (typep dest '(or creturn exit mv-combination)))
+ (eq (node-home-lambda ref)
+ (lambda-home (lambda-var-home var)))
+ (member (continuation-type-check arg) '(t nil))
+ (member (continuation-type-check cont) '(t nil))
+ (not (eq (values-type-intersection
+ cont-atype
+ (continuation-asserted-type arg))
+ *empty-type*))
+ (eq (lexenv-cookie (node-lexenv dest))
+ (lexenv-cookie (node-lexenv (continuation-dest arg)))))
+ (assert (member (continuation-kind arg)
+ '(:block-start :deleted-block-start :inside-block)))
+ (assert-continuation-type arg cont-atype)
+ (setf (node-derived-type ref) *wild-type*)
+ (change-ref-leaf ref (find-constant nil))
+ (substitute-continuation arg cont)
+ (reoptimize-continuation arg)
+ t)))
+
+;;; Delete a LET, removing the call and bind nodes, and warning about
+;;; any unreferenced variables. Note that FLUSH-DEAD-CODE will come
+;;; along right away and delete the REF and then the lambda, since we
+;;; flush the FUN continuation.
+(defun delete-let (fun)
+ (declare (type clambda fun))
+ (assert (member (functional-kind fun) '(:let :mv-let)))
+ (note-unreferenced-vars fun)
+ (let ((call (let-combination fun)))
+ (flush-dest (basic-combination-fun call))
+ (unlink-node call)
+ (unlink-node (lambda-bind fun))
+ (setf (lambda-bind fun) nil))
+ (values))
+
+;;; This function is called when one of the arguments to a LET
+;;; changes. We look at each changed argument. If the corresponding
+;;; variable is set, then we call PROPAGATE-FROM-SETS. Otherwise, we
+;;; consider substituting for the variable, and also propagate
+;;; derived-type information for the arg to all the Var's refs.
+;;;
+;;; Substitution is inhibited when the arg leaf's derived type isn't a
+;;; subtype of the argument's asserted type. This prevents type
+;;; checking from being defeated, and also ensures that the best
+;;; representation for the variable can be used.
+;;;
+;;; Substitution of individual references is inhibited if the
+;;; reference is in a different component from the home. This can only
+;;; happen with closures over top-level lambda vars. In such cases,
+;;; the references may have already been compiled, and thus can't be
+;;; retroactively modified.
+;;;
+;;; If all of the variables are deleted (have no references) when we
+;;; are done, then we delete the LET.
+;;;
+;;; Note that we are responsible for clearing the
+;;; Continuation-Reoptimize flags.
+(defun propagate-let-args (call fun)
+ (declare (type combination call) (type clambda fun))
+ (loop for arg in (combination-args call)
+ and var in (lambda-vars fun) do
+ (when (and arg (continuation-reoptimize arg))
+ (setf (continuation-reoptimize arg) nil)
+ (cond
+ ((lambda-var-sets var)
+ (propagate-from-sets var (continuation-type arg)))
+ ((let ((use (continuation-use arg)))
+ (when (ref-p use)
+ (let ((leaf (ref-leaf use)))
+ (when (and (constant-reference-p use)
+ (values-subtypep (leaf-type leaf)
+ (continuation-asserted-type arg)))
+ (propagate-to-refs var (continuation-type arg))
+ (let ((this-comp (block-component (node-block use))))
+ (substitute-leaf-if
+ #'(lambda (ref)
+ (cond ((eq (block-component (node-block ref))
+ this-comp)
+ t)
+ (t
+ (assert (eq (functional-kind (lambda-home fun))
+ :top-level))
+ nil)))
+ leaf var))
+ t)))))
+ ((and (null (rest (leaf-refs var)))
+ (not *byte-compiling*)
+ (substitute-single-use-continuation arg var)))
+ (t
+ (propagate-to-refs var (continuation-type arg))))))
+
+ (when (every #'null (combination-args call))
+ (delete-let fun))
+
+ (values))
+
+;;; This function is called when one of the args to a non-LET local
+;;; call changes. For each changed argument corresponding to an unset
+;;; variable, we compute the union of the types across all calls and
+;;; propagate this type information to the var's refs.
+;;;
+;;; If the function has an XEP, then we don't do anything, since we
+;;; won't discover anything.
+;;;
+;;; We can clear the Continuation-Reoptimize flags for arguments in
+;;; all calls corresponding to changed arguments in Call, since the
+;;; only use in IR1 optimization of the Reoptimize flag for local call
+;;; args is right here.
+(defun propagate-local-call-args (call fun)
+ (declare (type combination call) (type clambda fun))
+
+ (unless (or (functional-entry-function fun)
+ (lambda-optional-dispatch fun))
+ (let* ((vars (lambda-vars fun))
+ (union (mapcar #'(lambda (arg var)
+ (when (and arg
+ (continuation-reoptimize arg)
+ (null (basic-var-sets var)))
+ (continuation-type arg)))
+ (basic-combination-args call)
+ vars))
+ (this-ref (continuation-use (basic-combination-fun call))))
+
+ (dolist (arg (basic-combination-args call))
+ (when arg
+ (setf (continuation-reoptimize arg) nil)))
+
+ (dolist (ref (leaf-refs fun))
+ (let ((dest (continuation-dest (node-cont ref))))
+ (unless (or (eq ref this-ref) (not dest))
+ (setq union
+ (mapcar #'(lambda (this-arg old)
+ (when old
+ (setf (continuation-reoptimize this-arg) nil)
+ (type-union (continuation-type this-arg) old)))
+ (basic-combination-args dest)
+ union)))))
+
+ (mapc #'(lambda (var type)
+ (when type
+ (propagate-to-refs var type)))
+ vars union)))
+
+ (values))
+\f
+;;;; multiple values optimization
+
+;;; Do stuff to notice a change to a MV combination node. There are
+;;; two main branches here:
+;;; -- If the call is local, then it is already a MV let, or should
+;;; become one. Note that although all :LOCAL MV calls must eventually
+;;; be converted to :MV-LETs, there can be a window when the call
+;;; is local, but has not been LET converted yet. This is because
+;;; the entry-point lambdas may have stray references (in other
+;;; entry points) that have not been deleted yet.
+;;; -- The call is full. This case is somewhat similar to the non-MV
+;;; combination optimization: we propagate return type information and
+;;; notice non-returning calls. We also have an optimization
+;;; which tries to convert MV-CALLs into MV-binds.
+(defun ir1-optimize-mv-combination (node)
+ (ecase (basic-combination-kind node)
+ (:local
+ (let ((fun-cont (basic-combination-fun node)))
+ (when (continuation-reoptimize fun-cont)
+ (setf (continuation-reoptimize fun-cont) nil)
+ (maybe-let-convert (combination-lambda node))))
+ (setf (continuation-reoptimize (first (basic-combination-args node))) nil)
+ (when (eq (functional-kind (combination-lambda node)) :mv-let)
+ (unless (convert-mv-bind-to-let node)
+ (ir1-optimize-mv-bind node))))
+ (:full
+ (let* ((fun (basic-combination-fun node))
+ (fun-changed (continuation-reoptimize fun))
+ (args (basic-combination-args node)))
+ (when fun-changed
+ (setf (continuation-reoptimize fun) nil)
+ (let ((type (continuation-type fun)))
+ (when (function-type-p type)
+ (derive-node-type node (function-type-returns type))))
+ (maybe-terminate-block node nil)
+ (let ((use (continuation-use fun)))
+ (when (and (ref-p use) (functional-p (ref-leaf use)))
+ (convert-call-if-possible use node)
+ (when (eq (basic-combination-kind node) :local)
+ (maybe-let-convert (ref-leaf use))))))
+ (unless (or (eq (basic-combination-kind node) :local)
+ (eq (continuation-function-name fun) '%throw))
+ (ir1-optimize-mv-call node))
+ (dolist (arg args)
+ (setf (continuation-reoptimize arg) nil))))
+ (:error))
+ (values))
+
+;;; Propagate derived type info from the values continuation to the
+;;; vars.
+(defun ir1-optimize-mv-bind (node)
+ (declare (type mv-combination node))
+ (let ((arg (first (basic-combination-args node)))
+ (vars (lambda-vars (combination-lambda node))))
+ (multiple-value-bind (types nvals)
+ (values-types (continuation-derived-type arg))
+ (unless (eq nvals :unknown)
+ (mapc #'(lambda (var type)
+ (if (basic-var-sets var)
+ (propagate-from-sets var type)
+ (propagate-to-refs var type)))
+ vars
+ (append types
+ (make-list (max (- (length vars) nvals) 0)
+ :initial-element (specifier-type 'null))))))
+ (setf (continuation-reoptimize arg) nil))
+ (values))
+
+;;; If possible, convert a general MV call to an MV-BIND. We can do
+;;; this if:
+;;; -- The call has only one argument, and
+;;; -- The function has a known fixed number of arguments, or
+;;; -- The argument yields a known fixed number of values.
+;;;
+;;; What we do is change the function in the MV-CALL to be a lambda
+;;; that "looks like an MV bind", which allows
+;;; IR1-OPTIMIZE-MV-COMBINATION to notice that this call can be
+;;; converted (the next time around.) This new lambda just calls the
+;;; actual function with the MV-BIND variables as arguments. Note that
+;;; this new MV bind is not let-converted immediately, as there are
+;;; going to be stray references from the entry-point functions until
+;;; they get deleted.
+;;;
+;;; In order to avoid loss of argument count checking, we only do the
+;;; transformation according to a known number of expected argument if
+;;; safety is unimportant. We can always convert if we know the number
+;;; of actual values, since the normal call that we build will still
+;;; do any appropriate argument count checking.
+;;;
+;;; We only attempt the transformation if the called function is a
+;;; constant reference. This allows us to just splice the leaf into
+;;; the new function, instead of trying to somehow bind the function
+;;; expression. The leaf must be constant because we are evaluating it
+;;; again in a different place. This also has the effect of squelching
+;;; multiple warnings when there is an argument count error.
+(defun ir1-optimize-mv-call (node)
+ (let ((fun (basic-combination-fun node))
+ (*compiler-error-context* node)
+ (ref (continuation-use (basic-combination-fun node)))
+ (args (basic-combination-args node)))
+
+ (unless (and (ref-p ref) (constant-reference-p ref)
+ args (null (rest args)))
+ (return-from ir1-optimize-mv-call))
+
+ (multiple-value-bind (min max)
+ (function-type-nargs (continuation-type fun))
+ (let ((total-nvals
+ (multiple-value-bind (types nvals)
+ (values-types (continuation-derived-type (first args)))
+ (declare (ignore types))
+ (if (eq nvals :unknown) nil nvals))))
+
+ (when total-nvals
+ (when (and min (< total-nvals min))
+ (compiler-warning
+ "MULTIPLE-VALUE-CALL with ~R values when the function expects ~
+ at least ~R."
+ total-nvals min)
+ (setf (basic-combination-kind node) :error)
+ (return-from ir1-optimize-mv-call))
+ (when (and max (> total-nvals max))
+ (compiler-warning
+ "MULTIPLE-VALUE-CALL with ~R values when the function expects ~
+ at most ~R."
+ total-nvals max)
+ (setf (basic-combination-kind node) :error)
+ (return-from ir1-optimize-mv-call)))
+
+ (let ((count (cond (total-nvals)
+ ((and (policy node (zerop safety)) (eql min max))
+ min)
+ (t nil))))
+ (when count
+ (with-ir1-environment node
+ (let* ((dums (loop repeat count collect (gensym)))
+ (ignore (gensym))
+ (fun (ir1-convert-lambda
+ `(lambda (&optional ,@dums &rest ,ignore)
+ (declare (ignore ,ignore))
+ (funcall ,(ref-leaf ref) ,@dums)))))
+ (change-ref-leaf ref fun)
+ (assert (eq (basic-combination-kind node) :full))
+ (local-call-analyze *current-component*)
+ (assert (eq (basic-combination-kind node) :local)))))))))
+ (values))
+
+;;; If we see:
+;;; (multiple-value-bind
+;;; (x y)
+;;; (values xx yy)
+;;; ...)
+;;; Convert to:
+;;; (let ((x xx)
+;;; (y yy))
+;;; ...)
+;;;
+;;; What we actually do is convert the VALUES combination into a
+;;; normal LET combination calling the original :MV-LET lambda. If
+;;; there are extra args to VALUES, discard the corresponding
+;;; continuations. If there are insufficient args, insert references
+;;; to NIL.
+(defun convert-mv-bind-to-let (call)
+ (declare (type mv-combination call))
+ (let* ((arg (first (basic-combination-args call)))
+ (use (continuation-use arg)))
+ (when (and (combination-p use)
+ (eq (continuation-function-name (combination-fun use))
+ 'values))
+ (let* ((fun (combination-lambda call))
+ (vars (lambda-vars fun))
+ (vals (combination-args use))
+ (nvars (length vars))
+ (nvals (length vals)))
+ (cond ((> nvals nvars)
+ (mapc #'flush-dest (subseq vals nvars))
+ (setq vals (subseq vals 0 nvars)))
+ ((< nvals nvars)
+ (with-ir1-environment use
+ (let ((node-prev (node-prev use)))
+ (setf (node-prev use) nil)
+ (setf (continuation-next node-prev) nil)
+ (collect ((res vals))
+ (loop as cont = (make-continuation use)
+ and prev = node-prev then cont
+ repeat (- nvars nvals)
+ do (reference-constant prev cont nil)
+ (res cont))
+ (setq vals (res)))
+ (prev-link use (car (last vals)))))))
+ (setf (combination-args use) vals)
+ (flush-dest (combination-fun use))
+ (let ((fun-cont (basic-combination-fun call)))
+ (setf (continuation-dest fun-cont) use)
+ (setf (combination-fun use) fun-cont))
+ (setf (combination-kind use) :local)
+ (setf (functional-kind fun) :let)
+ (flush-dest (first (basic-combination-args call)))
+ (unlink-node call)
+ (when vals
+ (reoptimize-continuation (first vals)))
+ (propagate-to-args use fun))
+ t)))
+
+;;; If we see:
+;;; (values-list (list x y z))
+;;;
+;;; Convert to:
+;;; (values x y z)
+;;;
+;;; In implementation, this is somewhat similar to
+;;; CONVERT-MV-BIND-TO-LET. We grab the args of LIST and make them
+;;; args of the VALUES-LIST call, flushing the old argument
+;;; continuation (allowing the LIST to be flushed.)
+(defoptimizer (values-list optimizer) ((list) node)
+ (let ((use (continuation-use list)))
+ (when (and (combination-p use)
+ (eq (continuation-function-name (combination-fun use))
+ 'list))
+ (change-ref-leaf (continuation-use (combination-fun node))
+ (find-free-function 'values "in a strange place"))
+ (setf (combination-kind node) :full)
+ (let ((args (combination-args use)))
+ (dolist (arg args)
+ (setf (continuation-dest arg) node))
+ (setf (combination-args use) nil)
+ (flush-dest list)
+ (setf (combination-args node) args))
+ t)))
+
+;;; If VALUES appears in a non-MV context, then effectively convert it
+;;; to a PROG1. This allows the computation of the additional values
+;;; to become dead code.
+(deftransform values ((&rest vals) * * :node node)
+ (when (typep (continuation-dest (node-cont node))
+ '(or creturn exit mv-combination))
+ (give-up-ir1-transform))
+ (setf (node-derived-type node) *wild-type*)
+ (if vals
+ (let ((dummies (loop repeat (1- (length vals))
+ collect (gensym))))
+ `(lambda (val ,@dummies)
+ (declare (ignore ,@dummies))
+ val))
+ 'nil))
--- /dev/null
+;;;; This file contains code which does the translation from Lisp code
+;;;; to the first intermediate representation (IR1).
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!C")
+
+(file-comment
+ "$Header$")
+
+(declaim (special *compiler-error-bailout*))
+
+;;; *SOURCE-PATHS* is a hashtable from source code forms to the path
+;;; taken through the source to reach the form. This provides a way to
+;;; keep track of the location of original source forms, even when
+;;; macroexpansions and other arbitary permutations of the code
+;;; happen. This table is initialized by calling Find-Source-Paths on
+;;; the original source.
+(declaim (hash-table *source-paths*))
+(defvar *source-paths*)
+
+;;; *CURRENT-COMPONENT* is the Component structure which we link
+;;; blocks into as we generate them. This just serves to glue the
+;;; emitted blocks together until local call analysis and flow graph
+;;; canonicalization figure out what is really going on. We need to
+;;; keep track of all the blocks generated so that we can delete them
+;;; if they turn out to be unreachable.
+;;;
+;;; FIXME: It's confusing having one variable named *CURRENT-COMPONENT*
+;;; and another named *COMPONENT-BEING-COMPILED*. (In CMU CL they
+;;; were called *CURRENT-COMPONENT* and *COMPILE-COMPONENT* respectively,
+;;; which also confusing.)
+(declaim (type (or component null) *current-component*))
+(defvar *current-component*)
+
+;;; *CURRENT-PATH* is the source path of the form we are currently
+;;; translating. See NODE-SOURCE-PATH in the NODE structure.
+(declaim (list *current-path*))
+(defvar *current-path* nil)
+
+;;; *CONVERTING-FOR-INTERPRETER* is true when we are creating IR1 to
+;;; be interpreted rather than compiled. This inhibits source
+;;; tranformations and stuff.
+(defvar *converting-for-interpreter* nil)
+;;; FIXME: Rename to *IR1-FOR-INTERPRETER-NOT-COMPILER-P*.
+
+;;; *COMPILE-TIME-DEFINE-MACROS* is true when we want DEFMACRO
+;;; definitions to be installed in the compilation environment as
+;;; interpreted functions. We set this to false when compiling some
+;;; parts of the system.
+(defvar *compile-time-define-macros* t)
+;;; FIXME: I think this can go away with the new system.
+
+;;; 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.")
+\f
+;;;; namespace management utilities
+
+;;; Return a GLOBAL-VAR structure usable for referencing the global
+;;; function NAME.
+(defun find-free-really-function (name)
+ (unless (info :function :kind name)
+ (setf (info :function :kind name) :function)
+ (setf (info :function :where-from name) :assumed))
+
+ (let ((where (info :function :where-from name)))
+ (when (eq where :assumed)
+ (note-undefined-reference name :function))
+ (make-global-var :kind :global-function
+ :name name
+ :type (if (or *derive-function-types*
+ (eq where :declared))
+ (info :function :type name)
+ (specifier-type 'function))
+ :where-from where)))
+
+;;; Return a SLOT-ACCESSOR structure usable for referencing the slot
+;;; accessor NAME. CLASS is the structure class.
+(defun find-structure-slot-accessor (class name)
+ (declare (type sb!xc:class class))
+ (let* ((info (layout-info
+ (or (info :type :compiler-layout (sb!xc:class-name class))
+ (class-layout class))))
+ (accessor (if (listp name) (cadr name) name))
+ (slot (find accessor (dd-slots info) :key #'sb!kernel:dsd-accessor))
+ (type (dd-name info))
+ (slot-type (dsd-type slot)))
+ (assert slot () "Can't find slot ~S." type)
+ (make-slot-accessor
+ :name name
+ :type (specifier-type
+ (if (listp name)
+ `(function (,slot-type ,type) ,slot-type)
+ `(function (,type) ,slot-type)))
+ :for class
+ :slot slot)))
+
+;;; If NAME is already entered in *FREE-FUNCTIONS*, then return the
+;;; value. Otherwise, make a new GLOBAL-VAR using information from the
+;;; global environment and enter it in *FREE-FUNCTIONS*. If NAME names
+;;; a macro or special form, then we error out using the supplied
+;;; context which indicates what we were trying to do that demanded a
+;;; function.
+(defun find-free-function (name context)
+ (declare (string context))
+ (declare (values global-var))
+ (or (gethash name *free-functions*)
+ (ecase (info :function :kind name)
+ ;; FIXME: The :MACRO and :SPECIAL-FORM cases could be merged.
+ (:macro
+ (compiler-error "The macro name ~S was found ~A." name context))
+ (:special-form
+ (compiler-error "The special form name ~S was found ~A."
+ name
+ context))
+ ((:function nil)
+ (check-function-name name)
+ (note-if-setf-function-and-macro name)
+ (let ((expansion (info :function :inline-expansion name))
+ (inlinep (info :function :inlinep name)))
+ (setf (gethash name *free-functions*)
+ (if (or expansion inlinep)
+ (make-defined-function
+ :name name
+ :inline-expansion expansion
+ :inlinep inlinep
+ :where-from (info :function :where-from name)
+ :type (info :function :type name))
+ (let ((info (info :function :accessor-for name)))
+ (etypecase info
+ (null
+ (find-free-really-function name))
+ (sb!xc:structure-class
+ (find-structure-slot-accessor info name))
+ (sb!xc:class
+ (if (typep (layout-info (info :type :compiler-layout
+ (sb!xc:class-name
+ info)))
+ 'defstruct-description)
+ (find-structure-slot-accessor info name)
+ (find-free-really-function name))))))))))))
+
+;;; Return the LEAF structure for the lexically apparent function
+;;; definition of NAME.
+(declaim (ftype (function (t string) leaf) find-lexically-apparent-function))
+(defun find-lexically-apparent-function (name context)
+ (let ((var (lexenv-find name functions :test #'equal)))
+ (cond (var
+ (unless (leaf-p var)
+ (assert (and (consp var) (eq (car var) 'macro)))
+ (compiler-error "found macro name ~S ~A" name context))
+ var)
+ (t
+ (find-free-function name context)))))
+
+;;; Return the LEAF node for a global variable reference to NAME. If
+;;; NAME is already entered in *FREE-VARIABLES*, then we just return
+;;; the corresponding value. Otherwise, we make a new leaf using
+;;; information from the global environment and enter it in
+;;; *FREE-VARIABLES*. If the variable is unknown, then we emit a
+;;; warning.
+(defun find-free-variable (name)
+ (declare (values (or leaf heap-alien-info)))
+ (unless (symbolp name)
+ (compiler-error "Variable name is not a symbol: ~S." name))
+ (or (gethash name *free-variables*)
+ (let ((kind (info :variable :kind name))
+ (type (info :variable :type name))
+ (where-from (info :variable :where-from name)))
+ (when (and (eq where-from :assumed) (eq kind :global))
+ (note-undefined-reference name :variable))
+
+ (setf (gethash name *free-variables*)
+ (if (eq kind :alien)
+ (info :variable :alien-info name)
+ (multiple-value-bind (val valp)
+ (info :variable :constant-value name)
+ (if (and (eq kind :constant) valp)
+ (make-constant :value val
+ :name name
+ :type (ctype-of val)
+ :where-from where-from)
+ (make-global-var :kind kind
+ :name name
+ :type type
+ :where-from where-from))))))))
+\f
+;;; Grovel over CONSTANT checking for any sub-parts that need to be
+;;; processed with MAKE-LOAD-FORM. We have to be careful, because
+;;; CONSTANT might be circular. We also check that the constant (and
+;;; any subparts) are dumpable at all.
+(defconstant list-to-hash-table-threshold 32)
+(defun maybe-emit-make-load-forms (constant)
+ (let ((things-processed nil)
+ (count 0))
+ ;; FIXME: Does this LIST-or-HASH-TABLE messiness give much benefit?
+ (declare (type (or list hash-table) things-processed)
+ (type (integer 0 #.(1+ list-to-hash-table-threshold)) count)
+ (inline member))
+ (labels ((grovel (value)
+ ;; Unless VALUE is an object which which obviously
+ ;; can't contain other objects
+ (unless (typep value
+ '(or #-sb-xc-host unboxed-array
+ symbol
+ number
+ character
+ string))
+ (etypecase things-processed
+ (list
+ (when (member value things-processed :test #'eq)
+ (return-from grovel nil))
+ (push value things-processed)
+ (incf count)
+ (when (> count list-to-hash-table-threshold)
+ (let ((things things-processed))
+ (setf things-processed
+ (make-hash-table :test 'eq))
+ (dolist (thing things)
+ (setf (gethash thing things-processed) t)))))
+ (hash-table
+ (when (gethash value things-processed)
+ (return-from grovel nil))
+ (setf (gethash value things-processed) t)))
+ (typecase value
+ (cons
+ (grovel (car value))
+ (grovel (cdr value)))
+ (simple-vector
+ (dotimes (i (length value))
+ (grovel (svref value i))))
+ ((vector t)
+ (dotimes (i (length value))
+ (grovel (aref value i))))
+ ((simple-array t)
+ ;; Even though the (ARRAY T) branch does the exact
+ ;; same thing as this branch we do this separately
+ ;; so that the compiler can use faster versions of
+ ;; array-total-size and row-major-aref.
+ (dotimes (i (array-total-size value))
+ (grovel (row-major-aref value i))))
+ ((array t)
+ (dotimes (i (array-total-size value))
+ (grovel (row-major-aref value i))))
+ (;; In the target SBCL, we can dump any instance,
+ ;; but in the cross-compilation host,
+ ;; %INSTANCE-FOO functions don't work on general
+ ;; instances, only on STRUCTURE!OBJECTs.
+ #+sb-xc-host structure!object
+ #-sb-xc-host instance
+ (when (emit-make-load-form value)
+ (dotimes (i (%instance-length value))
+ (grovel (%instance-ref value i)))))
+ (t
+ (compiler-error
+ "Objects of type ~S can't be dumped into fasl files."
+ (type-of value)))))))
+ (grovel constant)))
+ (values))
+\f
+;;;; some flow-graph hacking utilities
+
+;;; This function sets up the back link between the node and the
+;;; continuation which continues at it.
+#!-sb-fluid (declaim (inline prev-link))
+(defun prev-link (node cont)
+ (declare (type node node) (type continuation cont))
+ (assert (not (continuation-next cont)))
+ (setf (continuation-next cont) node)
+ (setf (node-prev node) cont))
+
+;;; This function is used to set the continuation for a node, and thus
+;;; determine what receives the value and what is evaluated next. If
+;;; the continuation has no block, then we make it be in the block
+;;; that the node is in. If the continuation heads its block, we end
+;;; our block and link it to that block. If the continuation is not
+;;; currently used, then we set the derived-type for the continuation
+;;; to that of the node, so that a little type propagation gets done.
+;;;
+;;; We also deal with a bit of THE's semantics here: we weaken the
+;;; assertion on CONT to be no stronger than the assertion on CONT in
+;;; our scope. See the IR1-CONVERT method for THE.
+#!-sb-fluid (declaim (inline use-continuation))
+(defun use-continuation (node cont)
+ (declare (type node node) (type continuation cont))
+ (let ((node-block (continuation-block (node-prev node))))
+ (case (continuation-kind cont)
+ (:unused
+ (setf (continuation-block cont) node-block)
+ (setf (continuation-kind cont) :inside-block)
+ (setf (continuation-use cont) node)
+ (setf (node-cont node) cont))
+ (t
+ (%use-continuation node cont)))))
+(defun %use-continuation (node cont)
+ (declare (type node node) (type continuation cont) (inline member))
+ (let ((block (continuation-block cont))
+ (node-block (continuation-block (node-prev node))))
+ (assert (eq (continuation-kind cont) :block-start))
+ (assert (not (block-last node-block)) () "~S has already ended."
+ node-block)
+ (setf (block-last node-block) node)
+ (assert (null (block-succ node-block)) () "~S already has successors."
+ node-block)
+ (setf (block-succ node-block) (list block))
+ (assert (not (member node-block (block-pred block) :test #'eq)) ()
+ "~S is already a predecessor of ~S." node-block block)
+ (push node-block (block-pred block))
+ (add-continuation-use node cont)
+ (unless (eq (continuation-asserted-type cont) *wild-type*)
+ (let ((new (values-type-union (continuation-asserted-type cont)
+ (or (lexenv-find cont type-restrictions)
+ *wild-type*))))
+ (when (type/= new (continuation-asserted-type cont))
+ (setf (continuation-asserted-type cont) new)
+ (reoptimize-continuation cont))))))
+\f
+;;;; exported functions
+
+;;; This function takes a form and the top-level form number for that
+;;; form, and returns a lambda representing the translation of that
+;;; form in the current global environment. The lambda is top-level
+;;; lambda that can be called to cause evaluation of the forms. This
+;;; lambda is in the initial component. If FOR-VALUE is T, then the
+;;; value of the form is returned from the function, otherwise NIL is
+;;; returned.
+;;;
+;;; This function may have arbitrary effects on the global environment
+;;; due to processing of PROCLAIMs and EVAL-WHENs. All syntax error
+;;; checking is done, with erroneous forms being replaced by a proxy
+;;; which signals an error if it is evaluated. Warnings about possibly
+;;; inconsistent or illegal changes to the global environment will
+;;; also be given.
+;;;
+;;; We make the initial component and convert the form in a PROGN (and
+;;; an optional NIL tacked on the end.) We then return the lambda. We
+;;; bind all of our state variables here, rather than relying on the
+;;; global value (if any) so that IR1 conversion will be reentrant.
+;;; This is necessary for EVAL-WHEN processing, etc.
+;;;
+;;; The hashtables used to hold global namespace info must be
+;;; reallocated elsewhere. Note also that *LEXENV* is not bound, so
+;;; that local macro definitions can be introduced by enclosing code.
+(defun ir1-top-level (form path for-value)
+ (declare (list path))
+ (let* ((*current-path* path)
+ (component (make-empty-component))
+ (*current-component* component))
+ (setf (component-name component) "initial component")
+ (setf (component-kind component) :initial)
+ (let* ((forms (if for-value `(,form) `(,form nil)))
+ (res (ir1-convert-lambda-body forms ())))
+ (setf (leaf-name res) "top-level form")
+ (setf (functional-entry-function res) res)
+ (setf (functional-arg-documentation res) ())
+ (setf (functional-kind res) :top-level)
+ res)))
+
+;;; *CURRENT-FORM-NUMBER* is used in FIND-SOURCE-PATHS to compute the
+;;; form number to associate with a source path. This should be bound
+;;; to 0 around the processing of each truly top-level form.
+(declaim (type index *current-form-number*))
+(defvar *current-form-number*)
+
+;;; This function is called on freshly read forms to record the
+;;; initial location of each form (and subform.) Form is the form to
+;;; find the paths in, and TLF-Num is the top-level form number of the
+;;; truly top-level form.
+;;;
+;;; This gets a bit interesting when the source code is circular. This
+;;; can (reasonably?) happen in the case of circular list constants.
+(defun find-source-paths (form tlf-num)
+ (declare (type index tlf-num))
+ (let ((*current-form-number* 0))
+ (sub-find-source-paths form (list tlf-num)))
+ (values))
+(defun sub-find-source-paths (form path)
+ (unless (gethash form *source-paths*)
+ (setf (gethash form *source-paths*)
+ (list* 'original-source-start *current-form-number* path))
+ (incf *current-form-number*)
+ (let ((pos 0)
+ (subform form)
+ (trail form))
+ (declare (fixnum pos))
+ (macrolet ((frob ()
+ '(progn
+ (when (atom subform) (return))
+ (let ((fm (car subform)))
+ (when (consp fm)
+ (sub-find-source-paths fm (cons pos path)))
+ (incf pos))
+ (setq subform (cdr subform))
+ (when (eq subform trail) (return)))))
+ (loop
+ (frob)
+ (frob)
+ (setq trail (cdr trail)))))))
+\f
+;;;; IR1-CONVERT, macroexpansion and special form dispatching
+
+(macrolet (;; Bind *COMPILER-ERROR-BAILOUT* to a function that throws
+ ;; out of the body and converts a proxy form instead.
+ (ir1-error-bailout ((start
+ cont
+ form
+ &optional
+ (proxy ``(error "execution of a form compiled with errors:~% ~S"
+ ',,form)))
+ &body body)
+ (let ((skip (gensym "SKIP")))
+ `(block ,skip
+ (catch 'ir1-error-abort
+ (let ((*compiler-error-bailout*
+ #'(lambda ()
+ (throw 'ir1-error-abort nil))))
+ ,@body
+ (return-from ,skip nil)))
+ (ir1-convert ,start ,cont ,proxy)))))
+
+ ;; Translate FORM into IR1. The code is inserted as the NEXT of the
+ ;; continuation START. CONT is the continuation which receives the
+ ;; value of the FORM to be translated. The translators call this
+ ;; function recursively to translate their subnodes.
+ ;;
+ ;; As a special hack to make life easier in the compiler, a LEAF
+ ;; IR1-converts into a reference to that LEAF structure. This allows
+ ;; the creation using backquote of forms that contain leaf
+ ;; references, without having to introduce dummy names into the
+ ;; namespace.
+ (declaim (ftype (function (continuation continuation t) (values)) ir1-convert))
+ (defun ir1-convert (start cont form)
+ (ir1-error-bailout (start cont form)
+ (let ((*current-path* (or (gethash form *source-paths*)
+ (cons form *current-path*))))
+ (if (atom form)
+ (cond ((and (symbolp form) (not (keywordp form)))
+ (ir1-convert-variable start cont form))
+ ((leaf-p form)
+ (reference-leaf start cont form))
+ (t
+ (reference-constant start cont form)))
+ (let ((fun (car form)))
+ (cond
+ ((symbolp fun)
+ (let ((lexical-def (lexenv-find fun functions)))
+ (typecase lexical-def
+ (null (ir1-convert-global-functoid start cont form))
+ (functional
+ (ir1-convert-local-combination start
+ cont
+ form
+ lexical-def))
+ (global-var
+ (ir1-convert-srctran start cont lexical-def form))
+ (t
+ (assert (and (consp lexical-def)
+ (eq (car lexical-def) 'macro)))
+ (ir1-convert start cont
+ (careful-expand-macro (cdr lexical-def)
+ form))))))
+ ((or (atom fun) (not (eq (car fun) 'lambda)))
+ (compiler-error "illegal function call"))
+ (t
+ (ir1-convert-combination start
+ cont
+ form
+ (ir1-convert-lambda fun))))))))
+ (values))
+
+ ;; Generate a reference to a manifest constant, creating a new leaf
+ ;; if necessary. If we are producing a fasl-file, make sure that
+ ;; MAKE-LOAD-FORM gets used on any parts of the constant that it
+ ;; needs to be.
+ (defun reference-constant (start cont value)
+ (declare (type continuation start cont)
+ (inline find-constant))
+ (ir1-error-bailout
+ (start cont value
+ '(error "attempt to reference undumpable constant"))
+ (when (producing-fasl-file)
+ (maybe-emit-make-load-forms value))
+ (let* ((leaf (find-constant value))
+ (res (make-ref (leaf-type leaf) leaf)))
+ (push res (leaf-refs leaf))
+ (prev-link res start)
+ (use-continuation res cont)))
+ (values)))
+
+;;; Add Fun to the COMPONENT-REANALYZE-FUNCTIONS. Fun is returned.
+ (defun maybe-reanalyze-function (fun)
+ (declare (type functional fun))
+ (when (typep fun '(or optional-dispatch clambda))
+ (pushnew fun (component-reanalyze-functions *current-component*)))
+ fun)
+
+;;; Generate a Ref node for LEAF, frobbing the LEAF structure as
+;;; needed. If LEAF represents a defined function which has already
+;;; been converted, and is not :NOTINLINE, then reference the
+;;; functional instead.
+(defun reference-leaf (start cont leaf)
+ (declare (type continuation start cont) (type leaf leaf))
+ (let* ((leaf (or (and (defined-function-p leaf)
+ (not (eq (defined-function-inlinep leaf)
+ :notinline))
+ (let ((fun (defined-function-functional leaf)))
+ (when (and fun (not (functional-kind fun)))
+ (maybe-reanalyze-function fun))))
+ leaf))
+ (res (make-ref (or (lexenv-find leaf type-restrictions)
+ (leaf-type leaf))
+ leaf)))
+ (push res (leaf-refs leaf))
+ (setf (leaf-ever-used leaf) t)
+ (prev-link res start)
+ (use-continuation res cont)))
+
+;;; Convert a reference to a symbolic constant or variable. If the
+;;; symbol is entered in the LEXENV-VARIABLES we use that definition,
+;;; otherwise we find the current global definition. This is also
+;;; where we pick off symbol macro and Alien variable references.
+(defun ir1-convert-variable (start cont name)
+ (declare (type continuation start cont) (symbol name))
+ (let ((var (or (lexenv-find name variables) (find-free-variable name))))
+ (etypecase var
+ (leaf
+ (when (and (lambda-var-p var) (lambda-var-ignorep var))
+ ;; (ANSI's specification for the IGNORE declaration requires
+ ;; that this be a STYLE-WARNING, not a full WARNING.)
+ (compiler-style-warning "reading an ignored variable: ~S" name))
+ (reference-leaf start cont var))
+ (cons
+ (assert (eq (car var) 'MACRO))
+ (ir1-convert start cont (cdr var)))
+ (heap-alien-info
+ (ir1-convert start cont `(%heap-alien ',var)))))
+ (values))
+
+;;; Convert anything that looks like a special form, global function
+;;; or macro call.
+(defun ir1-convert-global-functoid (start cont form)
+ (declare (type continuation start cont) (list form))
+ (let* ((fun (first form))
+ (translator (info :function :ir1-convert fun))
+ (cmacro (info :function :compiler-macro-function fun)))
+ (cond (translator (funcall translator start cont form))
+ ((and cmacro (not *converting-for-interpreter*)
+ (not (eq (info :function :inlinep fun) :notinline)))
+ (let ((res (careful-expand-macro cmacro form)))
+ (if (eq res form)
+ (ir1-convert-global-functoid-no-cmacro start cont form fun)
+ (ir1-convert start cont res))))
+ (t
+ (ir1-convert-global-functoid-no-cmacro start cont form fun)))))
+
+;;; Handle the case of where the call was not a compiler macro, or was a
+;;; compiler macro and passed.
+(defun ir1-convert-global-functoid-no-cmacro (start cont form fun)
+ (declare (type continuation start cont) (list form))
+ ;; FIXME: Couldn't all the INFO calls here be converted into
+ ;; standard CL functions, like MACRO-FUNCTION or something?
+ ;; And what happens with lexically-defined (MACROLET) macros
+ ;; here, anyway?
+ (ecase (info :function :kind fun)
+ (:macro
+ (ir1-convert start
+ cont
+ (careful-expand-macro (info :function :macro-function fun)
+ form)))
+ ((nil :function)
+ (ir1-convert-srctran start cont (find-free-function fun "Eh?") form))))
+
+(defun muffle-warning-or-die ()
+ (muffle-warning)
+ (error "internal error -- no MUFFLE-WARNING restart"))
+
+;;; Trap errors during the macroexpansion.
+(defun careful-expand-macro (fun form)
+ (handler-bind (;; When cross-compiling, we can get style warnings
+ ;; about e.g. undefined functions. An unhandled
+ ;; CL:STYLE-WARNING (as opposed to a
+ ;; SB!C::COMPILER-NOTE) would cause FAILURE-P to be
+ ;; set on the return from #'SB!XC:COMPILE-FILE, which
+ ;; would falsely indicate an error sufficiently
+ ;; serious that we should stop the build process. To
+ ;; avoid this, we translate CL:STYLE-WARNING
+ ;; conditions from the host Common Lisp into
+ ;; cross-compiler SB!C::COMPILER-NOTE calls. (It
+ ;; might be cleaner to just make Python use
+ ;; CL:STYLE-WARNING internally, so that the
+ ;; significance of any host Common Lisp
+ ;; CL:STYLE-WARNINGs is understood automatically. But
+ ;; for now I'm not motivated to do this. -- WHN
+ ;; 19990412)
+ (style-warning (lambda (c)
+ (compiler-note "(during macroexpansion)~%~A"
+ c)
+ (muffle-warning-or-die)))
+ ;; KLUDGE: CMU CL in its wisdom (version 2.4.6 for
+ ;; Debian Linux, anyway) raises a CL:WARNING
+ ;; condition (not a CL:STYLE-WARNING) for undefined
+ ;; symbols when converting interpreted functions,
+ ;; causing COMPILE-FILE to think the file has a real
+ ;; problem, causing COMPILE-FILE to return FAILURE-P
+ ;; set (not just WARNINGS-P set). Since undefined
+ ;; symbol warnings are often harmless forward
+ ;; references, and since it'd be inordinately painful
+ ;; to try to eliminate all such forward references,
+ ;; these warnings are basically unavoidable. Thus, we
+ ;; need to coerce the system to work through them,
+ ;; and this code does so, by crudely suppressing all
+ ;; warnings in cross-compilation macroexpansion. --
+ ;; WHN 19990412
+ #+cmu
+ (warning (lambda (c)
+ (compiler-note
+ "(during macroexpansion)~%~
+ ~A~%~
+ (KLUDGE: That was a non-STYLE WARNING.~%~
+ Ordinarily that would cause compilation to~%~
+ fail. However, since we're running under~%~
+ CMU CL, and since CMU CL emits non-STYLE~%~
+ warnings for safe, hard-to-fix things (e.g.~%~
+ references to not-yet-defined functions)~%~
+ we're going to have to ignore it and proceed~%~
+ anyway. Hopefully we're not ignoring anything~%~
+ horrible here..)~%"
+ c)
+ (muffle-warning-or-die)))
+ (error (lambda (c)
+ (compiler-error "(during macroexpansion)~%~A" c))))
+ (funcall sb!xc:*macroexpand-hook*
+ fun
+ form
+ *lexenv*)))
+\f
+;;;; conversion utilities
+
+;;; Convert a bunch of forms, discarding all the values except the
+;;; last. If there aren't any forms, then translate a NIL.
+(declaim (ftype (function (continuation continuation list) (values))
+ ir1-convert-progn-body))
+(defun ir1-convert-progn-body (start cont body)
+ (if (endp body)
+ (reference-constant start cont nil)
+ (let ((this-start start)
+ (forms body))
+ (loop
+ (let ((form (car forms)))
+ (when (endp (cdr forms))
+ (ir1-convert this-start cont form)
+ (return))
+ (let ((this-cont (make-continuation)))
+ (ir1-convert this-start this-cont form)
+ (setq this-start this-cont forms (cdr forms)))))))
+ (values))
+\f
+;;;; converting combinations
+
+;;; Convert a function call where the function (Fun) is a Leaf. We
+;;; return the Combination node so that we can poke at it if we want to.
+(declaim (ftype (function (continuation continuation list leaf) combination)
+ ir1-convert-combination))
+(defun ir1-convert-combination (start cont form fun)
+ (let ((fun-cont (make-continuation)))
+ (reference-leaf start fun-cont fun)
+ (ir1-convert-combination-args fun-cont cont (cdr form))))
+
+;;; Convert the arguments to a call and make the Combination node. Fun-Cont
+;;; is the continuation which yields the function to call. Form is the source
+;;; for the call. Args is the list of arguments for the call, which defaults
+;;; to the cdr of source. We return the Combination node.
+(defun ir1-convert-combination-args (fun-cont cont args)
+ (declare (type continuation fun-cont cont) (list args))
+ (let ((node (make-combination fun-cont)))
+ (setf (continuation-dest fun-cont) node)
+ (assert-continuation-type fun-cont
+ (specifier-type '(or function symbol)))
+ (collect ((arg-conts))
+ (let ((this-start fun-cont))
+ (dolist (arg args)
+ (let ((this-cont (make-continuation node)))
+ (ir1-convert this-start this-cont arg)
+ (setq this-start this-cont)
+ (arg-conts this-cont)))
+ (prev-link node this-start)
+ (use-continuation node cont)
+ (setf (combination-args node) (arg-conts))))
+ node))
+
+;;; Convert a call to a global function. If not :NOTINLINE, then we do
+;;; source transforms and try out any inline expansion. If there is no
+;;; expansion, but is :INLINE, then give an efficiency note (unless a known
+;;; function which will quite possibly be open-coded.) Next, we go to
+;;; ok-combination conversion.
+(defun ir1-convert-srctran (start cont var form)
+ (declare (type continuation start cont) (type global-var var))
+ (let ((inlinep (when (defined-function-p var)
+ (defined-function-inlinep var))))
+ (cond
+ ((eq inlinep :notinline)
+ (ir1-convert-combination start cont form var))
+ (*converting-for-interpreter*
+ (ir1-convert-combination-checking-type start cont form var))
+ (t
+ (let ((transform (info :function :source-transform (leaf-name var))))
+ (cond
+ (transform
+ (multiple-value-bind (result pass) (funcall transform form)
+ (if pass
+ (ir1-convert-maybe-predicate start cont form var)
+ (ir1-convert start cont result))))
+ (t
+ (ir1-convert-maybe-predicate start cont form var))))))))
+
+;;; If the function has the Predicate attribute, and the CONT's DEST isn't
+;;; an IF, then we convert (IF <form> T NIL), ensuring that a predicate always
+;;; appears in a conditional context.
+;;;
+;;; If the function isn't a predicate, then we call
+;;; IR1-CONVERT-COMBINATION-CHECKING-TYPE.
+(defun ir1-convert-maybe-predicate (start cont form var)
+ (declare (type continuation start cont) (list form) (type global-var var))
+ (let ((info (info :function :info (leaf-name var))))
+ (if (and info
+ (ir1-attributep (function-info-attributes info) predicate)
+ (not (if-p (continuation-dest cont))))
+ (ir1-convert start cont `(if ,form t nil))
+ (ir1-convert-combination-checking-type start cont form var))))
+
+;;; Actually really convert a global function call that we are allowed
+;;; to early-bind.
+;;;
+;;; If we know the function type of the function, then we check the
+;;; call for syntactic legality with respect to the declared function
+;;; type. If it is impossible to determine whether the call is correct
+;;; due to non-constant keywords, then we give up, marking the call as
+;;; :FULL to inhibit further error messages. We return true when the
+;;; call is legal.
+;;;
+;;; If the call is legal, we also propagate type assertions from the
+;;; function type to the arg and result continuations. We do this now
+;;; so that IR1 optimize doesn't have to redundantly do the check
+;;; later so that it can do the type propagation.
+(defun ir1-convert-combination-checking-type (start cont form var)
+ (declare (type continuation start cont) (list form) (type leaf var))
+ (let* ((node (ir1-convert-combination start cont form var))
+ (fun-cont (basic-combination-fun node))
+ (type (leaf-type var)))
+ (when (validate-call-type node type t)
+ (setf (continuation-%derived-type fun-cont) type)
+ (setf (continuation-reoptimize fun-cont) nil)
+ (setf (continuation-%type-check fun-cont) nil)))
+
+ (values))
+
+;;; Convert a call to a local function. If the function has already
+;;; been let converted, then throw FUN to LOCAL-CALL-LOSSAGE. This
+;;; should only happen when we are converting inline expansions for
+;;; local functions during optimization.
+(defun ir1-convert-local-combination (start cont form fun)
+ (if (functional-kind fun)
+ (throw 'local-call-lossage fun)
+ (ir1-convert-combination start cont form
+ (maybe-reanalyze-function fun))))
+\f
+;;;; PROCESS-DECLS
+
+;;; Given a list of Lambda-Var structures and a variable name, return
+;;; the structure for that name, or NIL if it isn't found. We return
+;;; the *last* variable with that name, since LET* bindings may be
+;;; duplicated, and declarations always apply to the last.
+(declaim (ftype (function (list symbol) (or lambda-var list))
+ find-in-bindings))
+(defun find-in-bindings (vars name)
+ (let ((found nil))
+ (dolist (var vars)
+ (cond ((leaf-p var)
+ (when (eq (leaf-name var) name)
+ (setq found var))
+ (let ((info (lambda-var-arg-info var)))
+ (when info
+ (let ((supplied-p (arg-info-supplied-p info)))
+ (when (and supplied-p
+ (eq (leaf-name supplied-p) name))
+ (setq found supplied-p))))))
+ ((and (consp var) (eq (car var) name))
+ (setf found (cdr var)))))
+ found))
+
+;;; Called by Process-Decls to deal with a variable type declaration.
+;;; If a lambda-var being bound, we intersect the type with the vars
+;;; type, otherwise we add a type-restriction on the var. If a symbol
+;;; macro, we just wrap a THE around the expansion.
+(defun process-type-declaration (decl res vars)
+ (declare (list decl vars) (type lexenv res))
+ (let ((type (specifier-type (first decl))))
+ (collect ((restr nil cons)
+ (new-vars nil cons))
+ (dolist (var-name (rest decl))
+ (let* ((bound-var (find-in-bindings vars var-name))
+ (var (or bound-var
+ (lexenv-find var-name variables)
+ (find-free-variable var-name))))
+ (etypecase var
+ (leaf
+ (let* ((old-type (or (lexenv-find var type-restrictions)
+ (leaf-type var)))
+ (int (if (or (function-type-p type)
+ (function-type-p old-type))
+ type
+ (type-intersection old-type type))))
+ (cond ((eq int *empty-type*)
+ (unless (policy nil (= brevity 3))
+ (compiler-warning
+ "The type declarations ~S and ~S for ~S conflict."
+ (type-specifier old-type) (type-specifier type)
+ var-name)))
+ (bound-var (setf (leaf-type bound-var) int))
+ (t
+ (restr (cons var int))))))
+ (cons
+ ;; FIXME: non-ANSI weirdness
+ (assert (eq (car var) 'MACRO))
+ (new-vars `(,var-name . (MACRO . (the ,(first decl)
+ ,(cdr var))))))
+ (heap-alien-info
+ (compiler-error
+ "~S is an alien variable, so its type can't be declared."
+ var-name)))))
+
+ (if (or (restr) (new-vars))
+ (make-lexenv :default res
+ :type-restrictions (restr)
+ :variables (new-vars))
+ res))))
+
+;;; Somewhat similar to Process-Type-Declaration, but handles
+;;; declarations for function variables. In addition to allowing
+;;; declarations for functions being bound, we must also deal with
+;;; declarations that constrain the type of lexically apparent
+;;; functions.
+(defun process-ftype-declaration (spec res names fvars)
+ (declare (list spec names fvars) (type lexenv res))
+ (let ((type (specifier-type spec)))
+ (collect ((res nil cons))
+ (dolist (name names)
+ (let ((found (find name fvars :key #'leaf-name :test #'equal)))
+ (cond
+ (found
+ (setf (leaf-type found) type)
+ (assert-definition-type found type
+ :warning-function #'compiler-note
+ :where "FTYPE declaration"))
+ (t
+ (res (cons (find-lexically-apparent-function
+ name "in a function type declaration")
+ type))))))
+ (if (res)
+ (make-lexenv :default res :type-restrictions (res))
+ res))))
+
+;;; Process a special declaration, returning a new LEXENV. A non-bound
+;;; special declaration is instantiated by throwing a special variable
+;;; into the variables.
+(defun process-special-declaration (spec res vars)
+ (declare (list spec vars) (type lexenv res))
+ (collect ((new-venv nil cons))
+ (dolist (name (cdr spec))
+ (let ((var (find-in-bindings vars name)))
+ (etypecase var
+ (cons
+ (assert (eq (car var) 'MACRO))
+ (compiler-error
+ "~S is a symbol-macro and thus can't be declared special."
+ name))
+ (lambda-var
+ (when (lambda-var-ignorep var)
+ ;; ANSI's definition for "Declaration IGNORE, IGNORABLE"
+ ;; requires that this be a STYLE-WARNING, not a full WARNING.
+ (compiler-style-warning
+ "The ignored variable ~S is being declared special."
+ name))
+ (setf (lambda-var-specvar var)
+ (specvar-for-binding name)))
+ (null
+ (unless (assoc name (new-venv) :test #'eq)
+ (new-venv (cons name (specvar-for-binding name))))))))
+ (if (new-venv)
+ (make-lexenv :default res :variables (new-venv))
+ res)))
+
+;;; Return a DEFINED-FUNCTION which copies a global-var but for its inlinep.
+(defun make-new-inlinep (var inlinep)
+ (declare (type global-var var) (type inlinep inlinep))
+ (let ((res (make-defined-function
+ :name (leaf-name var)
+ :where-from (leaf-where-from var)
+ :type (leaf-type var)
+ :inlinep inlinep)))
+ (when (defined-function-p var)
+ (setf (defined-function-inline-expansion res)
+ (defined-function-inline-expansion var))
+ (setf (defined-function-functional res)
+ (defined-function-functional var)))
+ res))
+
+;;; Parse an inline/notinline declaration. If it's a local function we're
+;;; defining, set its INLINEP. If a global function, add a new FENV entry.
+(defun process-inline-declaration (spec res fvars)
+ (let ((sense (cdr (assoc (first spec) inlinep-translations :test #'eq)))
+ (new-fenv ()))
+ (dolist (name (rest spec))
+ (let ((fvar (find name fvars :key #'leaf-name :test #'equal)))
+ (if fvar
+ (setf (functional-inlinep fvar) sense)
+ (let ((found
+ (find-lexically-apparent-function
+ name "in an inline or notinline declaration")))
+ (etypecase found
+ (functional
+ (when (policy nil (>= speed brevity))
+ (compiler-note "ignoring ~A declaration not at ~
+ definition of local function:~% ~S"
+ sense name)))
+ (global-var
+ (push (cons name (make-new-inlinep found sense))
+ new-fenv)))))))
+
+ (if new-fenv
+ (make-lexenv :default res :functions new-fenv)
+ res)))
+
+;;; Like FIND-IN-BINDINGS, but looks for #'foo in the fvars.
+(defun find-in-bindings-or-fbindings (name vars fvars)
+ (declare (list vars fvars))
+ (if (consp name)
+ (destructuring-bind (wot fn-name) name
+ (unless (eq wot 'function)
+ (compiler-error "The function or variable name ~S is unrecognizable."
+ name))
+ (find fn-name fvars :key #'leaf-name :test #'equal))
+ (find-in-bindings vars name)))
+
+;;; Process an ignore/ignorable declaration, checking for various losing
+;;; conditions.
+(defun process-ignore-declaration (spec vars fvars)
+ (declare (list spec vars fvars))
+ (dolist (name (rest spec))
+ (let ((var (find-in-bindings-or-fbindings name vars fvars)))
+ (cond
+ ((not var)
+ ;; ANSI's definition for "Declaration IGNORE, IGNORABLE"
+ ;; requires that this be a STYLE-WARNING, not a full WARNING.
+ (compiler-style-warning "declaring unknown variable ~S to be ignored"
+ name))
+ ;; FIXME: This special case looks like non-ANSI weirdness.
+ ((and (consp var) (consp (cdr var)) (eq (cadr var) 'macro))
+ ;; Just ignore the IGNORE decl.
+ )
+ ((functional-p var)
+ (setf (leaf-ever-used var) t))
+ ((lambda-var-specvar var)
+ ;; ANSI's definition for "Declaration IGNORE, IGNORABLE"
+ ;; requires that this be a STYLE-WARNING, not a full WARNING.
+ (compiler-style-warning "declaring special variable ~S to be ignored"
+ name))
+ ((eq (first spec) 'ignorable)
+ (setf (leaf-ever-used var) t))
+ (t
+ (setf (lambda-var-ignorep var) t)))))
+ (values))
+
+;;; FIXME: This is non-ANSI, so the default should be T, or it should
+;;; go away, I think.
+(defvar *suppress-values-declaration* nil
+ #!+sb-doc
+ "If true, processing of the VALUES declaration is inhibited.")
+
+;;; Process a single declaration spec, agumenting the specified LEXENV
+;;; Res and returning it as a result. Vars and Fvars are as described in
+;;; PROCESS-DECLS.
+(defun process-1-declaration (spec res vars fvars cont)
+ (declare (list spec vars fvars) (type lexenv res) (type continuation cont))
+ (case (first spec)
+ (special (process-special-declaration spec res vars))
+ (ftype
+ (unless (cdr spec)
+ (compiler-error "No type specified in FTYPE declaration: ~S." spec))
+ (process-ftype-declaration (second spec) res (cddr spec) fvars))
+ (function
+ ;; Handle old style FUNCTION declaration, which is an abbreviation for
+ ;; FTYPE. Args are name, arglist, result type.
+ (cond ((and (proper-list-of-length-p spec 3 4)
+ (listp (third spec)))
+ (process-ftype-declaration `(function ,@(cddr spec)) res
+ (list (second spec))
+ fvars))
+ (t
+ (process-type-declaration spec res vars))))
+ ((inline notinline maybe-inline)
+ (process-inline-declaration spec res fvars))
+ ((ignore ignorable)
+ (process-ignore-declaration spec vars fvars)
+ res)
+ (optimize
+ (make-lexenv
+ :default res
+ :cookie (process-optimize-declaration spec (lexenv-cookie res))))
+ (optimize-interface
+ (make-lexenv
+ :default res
+ :interface-cookie (process-optimize-declaration
+ spec
+ (lexenv-interface-cookie res))))
+ (type
+ (process-type-declaration (cdr spec) res vars))
+ (sb!pcl::class
+ (process-type-declaration (list (third spec) (second spec)) res vars))
+ (values
+ (if *suppress-values-declaration*
+ res
+ (let ((types (cdr spec)))
+ (do-the-stuff (if (eql (length types) 1)
+ (car types)
+ `(values ,@types))
+ cont res 'values))))
+ (dynamic-extent
+ (when (policy nil (> speed brevity))
+ (compiler-note
+ "The DYNAMIC-EXTENT declaration is not implemented (ignored)."))
+ res)
+ (t
+ (let ((what (first spec)))
+ (cond ((member what *standard-type-names*)
+ (process-type-declaration spec res vars))
+ ((and (not (and (symbolp what)
+ (string= (symbol-name what) "CLASS"))) ; pcl hack
+ (or (info :type :kind what)
+ (and (consp what) (info :type :translator (car what)))))
+ (unless (policy nil (= brevity 3))
+ ;; FIXME: Is it ANSI to warn about this? I think not.
+ (compiler-note "abbreviated type declaration: ~S." spec))
+ (process-type-declaration spec res vars))
+ ((info :declaration :recognized what)
+ res)
+ (t
+ (compiler-warning "unrecognized declaration ~S" spec)
+ res))))))
+
+;;; Use a list of DECLARE forms to annotate the lists of LAMBDA-VAR and
+;;; Functional structures which are being bound. In addition to filling in
+;;; slots in the leaf structures, we return a new LEXENV which reflects
+;;; pervasive special and function type declarations, (NOT)INLINE declarations
+;;; and OPTIMIZE declarations. CONT is the continuation affected by VALUES
+;;; declarations.
+;;;
+;;; This is also called in main.lisp when PROCESS-FORM handles a use of
+;;; LOCALLY.
+(defun process-decls (decls vars fvars cont &optional (env *lexenv*))
+ (declare (list decls vars fvars) (type continuation cont))
+ (dolist (decl decls)
+ (dolist (spec (rest decl))
+ (unless (consp spec)
+ (compiler-error "malformed declaration specifier ~S in ~S"
+ spec
+ decl))
+ (setq env (process-1-declaration spec env vars fvars cont))))
+ env)
+
+;;; Return the Specvar for Name to use when we see a local SPECIAL
+;;; declaration. If there is a global variable of that name, then
+;;; check that it isn't a constant and return it. Otherwise, create an
+;;; anonymous GLOBAL-VAR.
+(defun specvar-for-binding (name)
+ (cond ((not (eq (info :variable :where-from name) :assumed))
+ (let ((found (find-free-variable name)))
+ (when (heap-alien-info-p found)
+ (compiler-error
+ "~S is an alien variable and so can't be declared special."
+ name))
+ (when (or (not (global-var-p found))
+ (eq (global-var-kind found) :constant))
+ (compiler-error
+ "~S is a constant and so can't be declared special."
+ name))
+ found))
+ (t
+ (make-global-var :kind :special
+ :name name
+ :where-from :declared))))
+\f
+;;;; LAMBDA hackery
+
+;;;; Note: Take a look at the compiler-overview.tex section on "Hairy
+;;;; function representation" before you seriously mess with this
+;;;; stuff.
+
+;;; Verify that a thing is a legal name for a variable and return a
+;;; Var structure for it, filling in info if it is globally special.
+;;; If it is losing, we punt with a Compiler-Error. Names-So-Far is an
+;;; alist of names which have previously been bound. If the name is in
+;;; this list, then we error out.
+(declaim (ftype (function (t list) lambda-var) varify-lambda-arg))
+(defun varify-lambda-arg (name names-so-far)
+ (declare (inline member))
+ (unless (symbolp name)
+ (compiler-error "The lambda-variable ~S is not a symbol." name))
+ (when (member name names-so-far :test #'eq)
+ (compiler-error "The variable ~S occurs more than once in the lambda-list."
+ name))
+ (let ((kind (info :variable :kind name)))
+ (when (or (keywordp name) (eq kind :constant))
+ (compiler-error "The name of the lambda-variable ~S is a constant."
+ name))
+ (cond ((eq kind :special)
+ (let ((specvar (find-free-variable name)))
+ (make-lambda-var :name name
+ :type (leaf-type specvar)
+ :where-from (leaf-where-from specvar)
+ :specvar specvar)))
+ (t
+ (note-lexical-binding name)
+ (make-lambda-var :name name)))))
+
+;;; Make the keyword for a keyword arg, checking that the keyword
+;;; isn't already used by one of the Vars. We also check that the
+;;; keyword isn't the magical :allow-other-keys.
+(declaim (ftype (function (symbol list t) keyword) make-keyword-for-arg))
+(defun make-keyword-for-arg (symbol vars keywordify)
+ (let ((key (if (and keywordify (not (keywordp symbol)))
+ (intern (symbol-name symbol) "KEYWORD")
+ symbol)))
+ (when (eq key :allow-other-keys)
+ (compiler-error "No keyword arg can be called :ALLOW-OTHER-KEYS."))
+ (dolist (var vars)
+ (let ((info (lambda-var-arg-info var)))
+ (when (and info
+ (eq (arg-info-kind info) :keyword)
+ (eq (arg-info-keyword info) key))
+ (compiler-error
+ "The keyword ~S appears more than once in the lambda-list."
+ key))))
+ key))
+
+;;; Parse a lambda-list into a list of Var structures, stripping off
+;;; any aux bindings. Each arg name is checked for legality, and
+;;; duplicate names are checked for. If an arg is globally special,
+;;; the var is marked as :special instead of :lexical. Keyword,
+;;; optional and rest args are annotated with an arg-info structure
+;;; which contains the extra information. If we hit something losing,
+;;; we bug out with Compiler-Error. These values are returned:
+;;; 1. A list of the var structures for each top-level argument.
+;;; 2. A flag indicating whether &key was specified.
+;;; 3. A flag indicating whether other keyword args are allowed.
+;;; 4. A list of the &aux variables.
+;;; 5. A list of the &aux values.
+(declaim (ftype (function (list) (values list boolean boolean list list))
+ find-lambda-vars))
+(defun find-lambda-vars (list)
+ (multiple-value-bind (required optional restp rest keyp keys allowp aux
+ morep more-context more-count)
+ (parse-lambda-list list)
+ (collect ((vars)
+ (names-so-far)
+ (aux-vars)
+ (aux-vals))
+ ;; Parse-Default deals with defaults and supplied-p args for optionals
+ ;; and keywords args.
+ (flet ((parse-default (spec info)
+ (when (consp (cdr spec))
+ (setf (arg-info-default info) (second spec))
+ (when (consp (cddr spec))
+ (let* ((supplied-p (third spec))
+ (supplied-var (varify-lambda-arg supplied-p
+ (names-so-far))))
+ (setf (arg-info-supplied-p info) supplied-var)
+ (names-so-far supplied-p)
+ (when (> (length (the list spec)) 3)
+ (compiler-error
+ "The list ~S is too long to be an arg specifier."
+ spec)))))))
+
+ (dolist (name required)
+ (let ((var (varify-lambda-arg name (names-so-far))))
+ (vars var)
+ (names-so-far name)))
+
+ (dolist (spec optional)
+ (if (atom spec)
+ (let ((var (varify-lambda-arg spec (names-so-far))))
+ (setf (lambda-var-arg-info var) (make-arg-info :kind :optional))
+ (vars var)
+ (names-so-far spec))
+ (let* ((name (first spec))
+ (var (varify-lambda-arg name (names-so-far)))
+ (info (make-arg-info :kind :optional)))
+ (setf (lambda-var-arg-info var) info)
+ (vars var)
+ (names-so-far name)
+ (parse-default spec info))))
+
+ (when restp
+ (let ((var (varify-lambda-arg rest (names-so-far))))
+ (setf (lambda-var-arg-info var) (make-arg-info :kind :rest))
+ (vars var)
+ (names-so-far rest)))
+
+ (when morep
+ (let ((var (varify-lambda-arg more-context (names-so-far))))
+ (setf (lambda-var-arg-info var)
+ (make-arg-info :kind :more-context))
+ (vars var)
+ (names-so-far more-context))
+ (let ((var (varify-lambda-arg more-count (names-so-far))))
+ (setf (lambda-var-arg-info var)
+ (make-arg-info :kind :more-count))
+ (vars var)
+ (names-so-far more-count)))
+
+ (dolist (spec keys)
+ (cond
+ ((atom spec)
+ (let ((var (varify-lambda-arg spec (names-so-far))))
+ (setf (lambda-var-arg-info var)
+ (make-arg-info :kind :keyword
+ :keyword (make-keyword-for-arg spec
+ (vars)
+ t)))
+ (vars var)
+ (names-so-far spec)))
+ ((atom (first spec))
+ (let* ((name (first spec))
+ (var (varify-lambda-arg name (names-so-far)))
+ (info (make-arg-info
+ :kind :keyword
+ :keyword (make-keyword-for-arg name (vars) t))))
+ (setf (lambda-var-arg-info var) info)
+ (vars var)
+ (names-so-far name)
+ (parse-default spec info)))
+ (t
+ (let ((head (first spec)))
+ (unless (proper-list-of-length-p head 2)
+ (error "malformed keyword arg specifier: ~S" spec))
+ (let* ((name (second head))
+ (var (varify-lambda-arg name (names-so-far)))
+ (info (make-arg-info
+ :kind :keyword
+ :keyword (make-keyword-for-arg (first head)
+ (vars)
+ nil))))
+ (setf (lambda-var-arg-info var) info)
+ (vars var)
+ (names-so-far name)
+ (parse-default spec info))))))
+
+ (dolist (spec aux)
+ (cond ((atom spec)
+ (let ((var (varify-lambda-arg spec nil)))
+ (aux-vars var)
+ (aux-vals nil)
+ (names-so-far spec)))
+ (t
+ (unless (proper-list-of-length-p spec 1 2)
+ (compiler-error "malformed &AUX binding specifier: ~S"
+ spec))
+ (let* ((name (first spec))
+ (var (varify-lambda-arg name nil)))
+ (aux-vars var)
+ (aux-vals (second spec))
+ (names-so-far name)))))
+
+ (values (vars) keyp allowp (aux-vars) (aux-vals))))))
+
+;;; Similar to IR1-Convert-Progn-Body except that we sequentially bind each
+;;; Aux-Var to the corresponding Aux-Val before converting the body. If there
+;;; are no bindings, just convert the body, otherwise do one binding and
+;;; recurse on the rest.
+;;;
+;;; If Interface is true, then we convert bindings with the interface
+;;; policy. For real &aux bindings, and implicit aux bindings introduced by
+;;; keyword bindings, this is always true. It is only false when LET* directly
+;;; calls this function.
+(defun ir1-convert-aux-bindings (start cont body aux-vars aux-vals interface)
+ (declare (type continuation start cont) (list body aux-vars aux-vals))
+ (if (null aux-vars)
+ (ir1-convert-progn-body start cont body)
+ (let ((fun-cont (make-continuation))
+ (fun (ir1-convert-lambda-body body (list (first aux-vars))
+ (rest aux-vars) (rest aux-vals)
+ interface)))
+ (reference-leaf start fun-cont fun)
+ (let ((*lexenv* (if interface
+ (make-lexenv
+ :cookie (make-interface-cookie *lexenv*))
+ *lexenv*)))
+ (ir1-convert-combination-args fun-cont cont
+ (list (first aux-vals))))))
+ (values))
+
+;;; Similar to IR1-Convert-Progn-Body except that code to bind the Specvar
+;;; for each Svar to the value of the variable is wrapped around the body. If
+;;; there are no special bindings, we just convert the body, otherwise we do
+;;; one special binding and recurse on the rest.
+;;;
+;;; We make a cleanup and introduce it into the lexical environment. If
+;;; there are multiple special bindings, the cleanup for the blocks will end up
+;;; being the innermost one. We force Cont to start a block outside of this
+;;; cleanup, causing cleanup code to be emitted when the scope is exited.
+(defun ir1-convert-special-bindings (start cont body aux-vars aux-vals
+ interface svars)
+ (declare (type continuation start cont)
+ (list body aux-vars aux-vals svars))
+ (cond
+ ((null svars)
+ (ir1-convert-aux-bindings start cont body aux-vars aux-vals interface))
+ (t
+ (continuation-starts-block cont)
+ (let ((cleanup (make-cleanup :kind :special-bind))
+ (var (first svars))
+ (next-cont (make-continuation))
+ (nnext-cont (make-continuation)))
+ (ir1-convert start next-cont
+ `(%special-bind ',(lambda-var-specvar var) ,var))
+ (setf (cleanup-mess-up cleanup) (continuation-use next-cont))
+ (let ((*lexenv* (make-lexenv :cleanup cleanup)))
+ (ir1-convert next-cont nnext-cont '(%cleanup-point))
+ (ir1-convert-special-bindings nnext-cont cont body aux-vars aux-vals
+ interface (rest svars))))))
+ (values))
+
+;;; Create a lambda node out of some code, returning the result. The
+;;; bindings are specified by the list of var structures Vars. We deal
+;;; with adding the names to the Lexenv-Variables for the conversion.
+;;; The result is added to the New-Functions in the
+;;; *Current-Component* and linked to the component head and tail.
+;;;
+;;; We detect special bindings here, replacing the original Var in the
+;;; lambda list with a temporary variable. We then pass a list of the
+;;; special vars to IR1-Convert-Special-Bindings, which actually emits
+;;; the special binding code.
+;;;
+;;; We ignore any Arg-Info in the Vars, trusting that someone else is
+;;; dealing with &nonsense.
+;;;
+;;; Aux-Vars is a list of Var structures for variables that are to be
+;;; sequentially bound. Each Aux-Val is a form that is to be evaluated
+;;; to get the initial value for the corresponding Aux-Var. Interface
+;;; is a flag as T when there are real aux values (see let* and
+;;; ir1-convert-aux-bindings.)
+(defun ir1-convert-lambda-body (body vars &optional aux-vars aux-vals
+ interface result)
+ (declare (list body vars aux-vars aux-vals)
+ (type (or continuation null) result))
+ (let* ((bind (make-bind))
+ (lambda (make-lambda :vars vars :bind bind))
+ (result (or result (make-continuation))))
+ (setf (lambda-home lambda) lambda)
+ (collect ((svars)
+ (new-venv nil cons))
+
+ (dolist (var vars)
+ (setf (lambda-var-home var) lambda)
+ (let ((specvar (lambda-var-specvar var)))
+ (cond (specvar
+ (svars var)
+ (new-venv (cons (leaf-name specvar) specvar)))
+ (t
+ (note-lexical-binding (leaf-name var))
+ (new-venv (cons (leaf-name var) var))))))
+
+ (let ((*lexenv* (make-lexenv :variables (new-venv)
+ :lambda lambda
+ :cleanup nil)))
+ (setf (bind-lambda bind) lambda)
+ (setf (node-lexenv bind) *lexenv*)
+
+ (let ((cont1 (make-continuation))
+ (cont2 (make-continuation)))
+ (continuation-starts-block cont1)
+ (prev-link bind cont1)
+ (use-continuation bind cont2)
+ (ir1-convert-special-bindings cont2 result body aux-vars aux-vals
+ interface (svars)))
+
+ (let ((block (continuation-block result)))
+ (when block
+ (let ((return (make-return :result result :lambda lambda))
+ (tail-set (make-tail-set :functions (list lambda)))
+ (dummy (make-continuation)))
+ (setf (lambda-tail-set lambda) tail-set)
+ (setf (lambda-return lambda) return)
+ (setf (continuation-dest result) return)
+ (setf (block-last block) return)
+ (prev-link return result)
+ (use-continuation return dummy))
+ (link-blocks block (component-tail *current-component*))))))
+
+ (link-blocks (component-head *current-component*) (node-block bind))
+ (push lambda (component-new-functions *current-component*))
+ lambda))
+
+;;; Create the actual entry-point function for an optional entry
+;;; point. The lambda binds copies of each of the Vars, then calls Fun
+;;; with the argument Vals and the Defaults. Presumably the Vals refer
+;;; to the Vars by name. The Vals are passed in in reverse order.
+;;;
+;;; If any of the copies of the vars are referenced more than once,
+;;; then we mark the corresponding var as Ever-Used to inhibit
+;;; "defined but not read" warnings for arguments that are only used
+;;; by default forms.
+;;;
+;;; We bind *LEXENV* to change the policy to the interface policy.
+(defun convert-optional-entry (fun vars vals defaults)
+ (declare (type clambda fun) (list vars vals defaults))
+ (let* ((fvars (reverse vars))
+ (arg-vars (mapcar (lambda (var)
+ (unless (lambda-var-specvar var)
+ (note-lexical-binding (leaf-name var)))
+ (make-lambda-var
+ :name (leaf-name var)
+ :type (leaf-type var)
+ :where-from (leaf-where-from var)
+ :specvar (lambda-var-specvar var)))
+ fvars))
+ (*lexenv* (make-lexenv :cookie (make-interface-cookie *lexenv*)))
+ (fun
+ (ir1-convert-lambda-body
+ `((%funcall ,fun ,@(reverse vals) ,@defaults))
+ arg-vars)))
+ (mapc #'(lambda (var arg-var)
+ (when (cdr (leaf-refs arg-var))
+ (setf (leaf-ever-used var) t)))
+ fvars arg-vars)
+ fun))
+
+;;; This function deals with supplied-p vars in optional arguments. If
+;;; the there is no supplied-p arg, then we just call
+;;; IR1-Convert-Hairy-Args on the remaining arguments, and generate a
+;;; optional entry that calls the result. If there is a supplied-p
+;;; var, then we add it into the default vars and throw a T into the
+;;; entry values. The resulting entry point function is returned.
+(defun generate-optional-default-entry (res default-vars default-vals
+ entry-vars entry-vals
+ vars supplied-p-p body
+ aux-vars aux-vals cont)
+ (declare (type optional-dispatch res)
+ (list default-vars default-vals entry-vars entry-vals vars body
+ aux-vars aux-vals)
+ (type (or continuation null) cont))
+ (let* ((arg (first vars))
+ (arg-name (leaf-name arg))
+ (info (lambda-var-arg-info arg))
+ (supplied-p (arg-info-supplied-p info))
+ (ep (if supplied-p
+ (ir1-convert-hairy-args
+ res
+ (list* supplied-p arg default-vars)
+ (list* (leaf-name supplied-p) arg-name default-vals)
+ (cons arg entry-vars)
+ (list* t arg-name entry-vals)
+ (rest vars) t body aux-vars aux-vals cont)
+ (ir1-convert-hairy-args
+ res
+ (cons arg default-vars)
+ (cons arg-name default-vals)
+ (cons arg entry-vars)
+ (cons arg-name entry-vals)
+ (rest vars) supplied-p-p body aux-vars aux-vals cont))))
+
+ (convert-optional-entry ep default-vars default-vals
+ (if supplied-p
+ (list (arg-info-default info) nil)
+ (list (arg-info-default info))))))
+
+;;; Create the More-Entry function for the Optional-Dispatch Res.
+;;; Entry-Vars and Entry-Vals describe the fixed arguments. Rest is the var
+;;; for any Rest arg. Keys is a list of the keyword arg vars.
+;;;
+;;; The most interesting thing that we do is parse keywords. We create a
+;;; bunch of temporary variables to hold the result of the parse, and then loop
+;;; over the supplied arguments, setting the appropriate temps for the supplied
+;;; keyword. Note that it is significant that we iterate over the keywords in
+;;; reverse order --- this implements the CL requirement that (when a keyword
+;;; appears more than once) the first value is used.
+;;;
+;;; If there is no supplied-p var, then we initialize the temp to the
+;;; default and just pass the temp into the main entry. Since non-constant
+;;; keyword args are forcibly given a supplied-p var, we know that the default
+;;; is constant, and thus safe to evaluate out of order.
+;;;
+;;; If there is a supplied-p var, then we create temps for both the value
+;;; and the supplied-p, and pass them into the main entry, letting it worry
+;;; about defaulting.
+;;;
+;;; We deal with :allow-other-keys by delaying unknown keyword errors until
+;;; we have scanned all the keywords.
+;;;
+;;; When converting the function, we bind *LEXENV* to change the
+;;; compilation policy over to the interface policy, so that keyword
+;;; args will be checked even when type checking isn't on in general.
+(defun convert-more-entry (res entry-vars entry-vals rest morep keys)
+ (declare (type optional-dispatch res) (list entry-vars entry-vals keys))
+ (collect ((arg-vars)
+ (arg-vals (reverse entry-vals))
+ (temps)
+ (body))
+
+ (dolist (var (reverse entry-vars))
+ (arg-vars (make-lambda-var :name (leaf-name var)
+ :type (leaf-type var)
+ :where-from (leaf-where-from var))))
+
+ (let* ((n-context (gensym "N-CONTEXT-"))
+ (context-temp (make-lambda-var :name n-context))
+ (n-count (gensym "N-COUNT-"))
+ (count-temp (make-lambda-var :name n-count
+ :type (specifier-type 'index)))
+ (*lexenv* (make-lexenv :cookie (make-interface-cookie *lexenv*))))
+
+ (arg-vars context-temp count-temp)
+
+ (when rest
+ (arg-vals `(%listify-rest-args ,n-context ,n-count)))
+ (when morep
+ (arg-vals n-context)
+ (arg-vals n-count))
+
+ (when (optional-dispatch-keyp res)
+ (let ((n-index (gensym "N-INDEX-"))
+ (n-key (gensym "N-KEY-"))
+ (n-value-temp (gensym "N-VALUE-TEMP-"))
+ (n-allowp (gensym "N-ALLOWP-"))
+ (n-losep (gensym "N-LOSEP-"))
+ (allowp (or (optional-dispatch-allowp res)
+ (policy nil (zerop safety)))))
+
+ (temps `(,n-index (1- ,n-count)) n-key n-value-temp)
+ (body `(declare (fixnum ,n-index) (ignorable ,n-key ,n-value-temp)))
+
+ (collect ((tests))
+ (dolist (key keys)
+ (let* ((info (lambda-var-arg-info key))
+ (default (arg-info-default info))
+ (keyword (arg-info-keyword info))
+ (supplied-p (arg-info-supplied-p info))
+ (n-value (gensym "N-VALUE-")))
+ (temps `(,n-value ,default))
+ (cond (supplied-p
+ (let ((n-supplied (gensym "N-SUPPLIED-")))
+ (temps n-supplied)
+ (arg-vals n-value n-supplied)
+ (tests `((eq ,n-key ,keyword)
+ (setq ,n-supplied t)
+ (setq ,n-value ,n-value-temp)))))
+ (t
+ (arg-vals n-value)
+ (tests `((eq ,n-key ,keyword)
+ (setq ,n-value ,n-value-temp)))))))
+
+ (unless allowp
+ (temps n-allowp n-losep)
+ (tests `((eq ,n-key :allow-other-keys)
+ (setq ,n-allowp ,n-value-temp)))
+ (tests `(t
+ (setq ,n-losep ,n-key))))
+
+ (body
+ `(when (oddp ,n-count)
+ (%odd-keyword-arguments-error)))
+
+ (body
+ `(locally
+ (declare (optimize (safety 0)))
+ (loop
+ (when (minusp ,n-index) (return))
+ (setf ,n-value-temp (%more-arg ,n-context ,n-index))
+ (decf ,n-index)
+ (setq ,n-key (%more-arg ,n-context ,n-index))
+ (decf ,n-index)
+ (cond ,@(tests)))))
+
+ (unless allowp
+ (body `(when (and ,n-losep (not ,n-allowp))
+ (%unknown-keyword-argument-error ,n-losep)))))))
+
+ (let ((ep (ir1-convert-lambda-body
+ `((let ,(temps)
+ ,@(body)
+ (%funcall ,(optional-dispatch-main-entry res)
+ . ,(arg-vals)))) ; FIXME: What is the '.'? ,@?
+ (arg-vars))))
+ (setf (optional-dispatch-more-entry res) ep))))
+
+ (values))
+
+;;; Called by IR1-Convert-Hairy-Args when we run into a rest or keyword arg.
+;;; The arguments are similar to that function, but we split off any rest arg
+;;; and pass it in separately. Rest is the rest arg var, or NIL if there is no
+;;; rest arg. Keys is a list of the keyword argument vars.
+;;;
+;;; When there are keyword arguments, we introduce temporary gensym
+;;; variables to hold the values while keyword defaulting is in progress to get
+;;; the required sequential binding semantics.
+;;;
+;;; This gets interesting mainly when there are keyword arguments with
+;;; supplied-p vars or non-constant defaults. In either case, pass in a
+;;; supplied-p var. If the default is non-constant, we introduce an IF in the
+;;; main entry that tests the supplied-p var and decides whether to evaluate
+;;; the default or not. In this case, the real incoming value is NIL, so we
+;;; must union NULL with the declared type when computing the type for the main
+;;; entry's argument.
+(defun ir1-convert-more (res default-vars default-vals entry-vars entry-vals
+ rest more-context more-count keys supplied-p-p
+ body aux-vars aux-vals cont)
+ (declare (type optional-dispatch res)
+ (list default-vars default-vals entry-vars entry-vals keys body
+ aux-vars aux-vals)
+ (type (or continuation null) cont))
+ (collect ((main-vars (reverse default-vars))
+ (main-vals default-vals cons)
+ (bind-vars)
+ (bind-vals))
+ (when rest
+ (main-vars rest)
+ (main-vals '()))
+ (when more-context
+ (main-vars more-context)
+ (main-vals nil)
+ (main-vars more-count)
+ (main-vals 0))
+
+ (dolist (key keys)
+ (let* ((info (lambda-var-arg-info key))
+ (default (arg-info-default info))
+ (hairy-default (not (sb!xc:constantp default)))
+ (supplied-p (arg-info-supplied-p info))
+ (n-val (make-symbol (format nil ; FIXME: GENSYM?
+ "~A-DEFAULTING-TEMP"
+ (leaf-name key))))
+ (key-type (leaf-type key))
+ (val-temp (make-lambda-var
+ :name n-val
+ :type (if hairy-default
+ (type-union key-type (specifier-type 'null))
+ key-type))))
+ (main-vars val-temp)
+ (bind-vars key)
+ (cond ((or hairy-default supplied-p)
+ (let* ((n-supplied (gensym "N-SUPPLIED-"))
+ (supplied-temp (make-lambda-var :name n-supplied)))
+ (unless supplied-p
+ (setf (arg-info-supplied-p info) supplied-temp))
+ (when hairy-default
+ (setf (arg-info-default info) nil))
+ (main-vars supplied-temp)
+ (cond (hairy-default
+ (main-vals nil nil)
+ (bind-vals `(if ,n-supplied ,n-val ,default)))
+ (t
+ (main-vals default nil)
+ (bind-vals n-val)))
+ (when supplied-p
+ (bind-vars supplied-p)
+ (bind-vals n-supplied))))
+ (t
+ (main-vals (arg-info-default info))
+ (bind-vals n-val)))))
+
+ (let* ((main-entry (ir1-convert-lambda-body body (main-vars)
+ (append (bind-vars) aux-vars)
+ (append (bind-vals) aux-vals)
+ t
+ cont))
+ (last-entry (convert-optional-entry main-entry default-vars
+ (main-vals) ())))
+ (setf (optional-dispatch-main-entry res) main-entry)
+ (convert-more-entry res entry-vars entry-vals rest more-context keys)
+
+ (push (if supplied-p-p
+ (convert-optional-entry last-entry entry-vars entry-vals ())
+ last-entry)
+ (optional-dispatch-entry-points res))
+ last-entry)))
+
+;;; This function generates the entry point functions for the
+;;; optional-dispatch Res. We accomplish this by recursion on the list of
+;;; arguments, analyzing the arglist on the way down and generating entry
+;;; points on the way up.
+;;;
+;;; Default-Vars is a reversed list of all the argument vars processed so
+;;; far, including supplied-p vars. Default-Vals is a list of the names of the
+;;; Default-Vars.
+;;;
+;;; Entry-Vars is a reversed list of processed argument vars, excluding
+;;; supplied-p vars. Entry-Vals is a list things that can be evaluated to get
+;;; the values for all the vars from the Entry-Vars. It has the var name for
+;;; each required or optional arg, and has T for each supplied-p arg.
+;;;
+;;; Vars is a list of the Lambda-Var structures for arguments that haven't
+;;; been processed yet. Supplied-p-p is true if a supplied-p argument has
+;;; already been processed; only in this case are the Default-XXX and Entry-XXX
+;;; different.
+;;;
+;;; The result at each point is a lambda which should be called by the above
+;;; level to default the remaining arguments and evaluate the body. We cause
+;;; the body to be evaluated by converting it and returning it as the result
+;;; when the recursion bottoms out.
+;;;
+;;; Each level in the recursion also adds its entry point function to the
+;;; result Optional-Dispatch. For most arguments, the defaulting function and
+;;; the entry point function will be the same, but when supplied-p args are
+;;; present they may be different.
+;;;
+;;; When we run into a rest or keyword arg, we punt out to
+;;; IR1-Convert-More, which finishes for us in this case.
+(defun ir1-convert-hairy-args (res default-vars default-vals
+ entry-vars entry-vals
+ vars supplied-p-p body aux-vars
+ aux-vals cont)
+ (declare (type optional-dispatch res)
+ (list default-vars default-vals entry-vars entry-vals vars body
+ aux-vars aux-vals)
+ (type (or continuation null) cont))
+ (cond ((not vars)
+ (if (optional-dispatch-keyp res)
+ ;; Handle &KEY with no keys...
+ (ir1-convert-more res default-vars default-vals
+ entry-vars entry-vals
+ nil nil nil vars supplied-p-p body aux-vars
+ aux-vals cont)
+ (let ((fun (ir1-convert-lambda-body body (reverse default-vars)
+ aux-vars aux-vals t cont)))
+ (setf (optional-dispatch-main-entry res) fun)
+ (push (if supplied-p-p
+ (convert-optional-entry fun entry-vars entry-vals ())
+ fun)
+ (optional-dispatch-entry-points res))
+ fun)))
+ ((not (lambda-var-arg-info (first vars)))
+ (let* ((arg (first vars))
+ (nvars (cons arg default-vars))
+ (nvals (cons (leaf-name arg) default-vals)))
+ (ir1-convert-hairy-args res nvars nvals nvars nvals
+ (rest vars) nil body aux-vars aux-vals
+ cont)))
+ (t
+ (let* ((arg (first vars))
+ (info (lambda-var-arg-info arg))
+ (kind (arg-info-kind info)))
+ (ecase kind
+ (:optional
+ (let ((ep (generate-optional-default-entry
+ res default-vars default-vals
+ entry-vars entry-vals vars supplied-p-p body
+ aux-vars aux-vals cont)))
+ (push (if supplied-p-p
+ (convert-optional-entry ep entry-vars entry-vals ())
+ ep)
+ (optional-dispatch-entry-points res))
+ ep))
+ (:rest
+ (ir1-convert-more res default-vars default-vals
+ entry-vars entry-vals
+ arg nil nil (rest vars) supplied-p-p body
+ aux-vars aux-vals cont))
+ (:more-context
+ (ir1-convert-more res default-vars default-vals
+ entry-vars entry-vals
+ nil arg (second vars) (cddr vars) supplied-p-p
+ body aux-vars aux-vals cont))
+ (:keyword
+ (ir1-convert-more res default-vars default-vals
+ entry-vars entry-vals
+ nil nil nil vars supplied-p-p body aux-vars
+ aux-vals cont)))))))
+
+;;; This function deals with the case where we have to make an
+;;; Optional-Dispatch to represent a lambda. We cons up the result and call
+;;; IR1-Convert-Hairy-Args to do the work. When it is done, we figure out the
+;;; min-args and max-args.
+(defun ir1-convert-hairy-lambda (body vars keyp allowp aux-vars aux-vals cont)
+ (declare (list body vars aux-vars aux-vals) (type continuation cont))
+ (let ((res (make-optional-dispatch :arglist vars
+ :allowp allowp
+ :keyp keyp))
+ (min (or (position-if #'lambda-var-arg-info vars) (length vars))))
+ (push res (component-new-functions *current-component*))
+ (ir1-convert-hairy-args res () () () () vars nil body aux-vars aux-vals
+ cont)
+ (setf (optional-dispatch-min-args res) min)
+ (setf (optional-dispatch-max-args res)
+ (+ (1- (length (optional-dispatch-entry-points res))) min))
+
+ (flet ((frob (ep)
+ (when ep
+ (setf (functional-kind ep) :optional)
+ (setf (leaf-ever-used ep) t)
+ (setf (lambda-optional-dispatch ep) res))))
+ (dolist (ep (optional-dispatch-entry-points res)) (frob ep))
+ (frob (optional-dispatch-more-entry res))
+ (frob (optional-dispatch-main-entry res)))
+
+ res))
+
+;;; Convert a Lambda into a Lambda or Optional-Dispatch leaf.
+(defun ir1-convert-lambda (form &optional name)
+ (unless (consp form)
+ (compiler-error "A ~S was found when expecting a lambda expression:~% ~S"
+ (type-of form)
+ form))
+ (unless (eq (car form) 'lambda)
+ (compiler-error "~S was expected but ~S was found:~% ~S"
+ 'lambda
+ (car form)
+ form))
+ (unless (and (consp (cdr form)) (listp (cadr form)))
+ (compiler-error
+ "The lambda expression has a missing or non-list lambda-list:~% ~S"
+ form))
+
+ (multiple-value-bind (vars keyp allow-other-keys aux-vars aux-vals)
+ (find-lambda-vars (cadr form))
+ (multiple-value-bind (forms decls) (sb!sys:parse-body (cddr form))
+ (let* ((cont (make-continuation))
+ (*lexenv* (process-decls decls
+ (append aux-vars vars)
+ nil cont))
+ (res (if (or (find-if #'lambda-var-arg-info vars) keyp)
+ (ir1-convert-hairy-lambda forms vars keyp
+ allow-other-keys
+ aux-vars aux-vals cont)
+ (ir1-convert-lambda-body forms vars aux-vars aux-vals
+ t cont))))
+ (setf (functional-inline-expansion res) form)
+ (setf (functional-arg-documentation res) (cadr form))
+ (setf (leaf-name res) name)
+ res))))
+\f
+;;; FIXME: This file is rather long, and contains two distinct sections,
+;;; transform machinery above this point and transforms themselves below this
+;;; point. Why not split it in two? (ir1translate.lisp and
+;;; ir1translators.lisp?) Then consider byte-compiling the translators, too.
+\f
+;;;; control special forms
+
+(def-ir1-translator progn ((&rest forms) start cont)
+ #!+sb-doc
+ "Progn Form*
+ Evaluates each Form in order, returning the values of the last form. With no
+ forms, returns NIL."
+ (ir1-convert-progn-body start cont forms))
+
+(def-ir1-translator if ((test then &optional else) start cont)
+ #!+sb-doc
+ "If Predicate Then [Else]
+ If Predicate evaluates to non-null, evaluate Then and returns its values,
+ otherwise evaluate Else and return its values. Else defaults to NIL."
+ (let* ((pred (make-continuation))
+ (then-cont (make-continuation))
+ (then-block (continuation-starts-block then-cont))
+ (else-cont (make-continuation))
+ (else-block (continuation-starts-block else-cont))
+ (dummy-cont (make-continuation))
+ (node (make-if :test pred
+ :consequent then-block
+ :alternative else-block)))
+ (setf (continuation-dest pred) node)
+ (ir1-convert start pred test)
+ (prev-link node pred)
+ (use-continuation node dummy-cont)
+
+ (let ((start-block (continuation-block pred)))
+ (setf (block-last start-block) node)
+ (continuation-starts-block cont)
+
+ (link-blocks start-block then-block)
+ (link-blocks start-block else-block)
+
+ (ir1-convert then-cont cont then)
+ (ir1-convert else-cont cont else))))
+\f
+;;;; BLOCK and TAGBODY
+
+;;;; We make an Entry node to mark the start and a :Entry cleanup to
+;;;; mark its extent. When doing GO or RETURN-FROM, we emit an Exit
+;;;; node.
+
+;;; Make a :entry cleanup and emit an Entry node, then convert the
+;;; body in the modified environment. We make Cont start a block now,
+;;; since if it was done later, the block would be in the wrong
+;;; environment.
+(def-ir1-translator block ((name &rest forms) start cont)
+ #!+sb-doc
+ "Block Name Form*
+ Evaluate the Forms as a PROGN. Within the lexical scope of the body,
+ (RETURN-FROM Name Value-Form) can be used to exit the form, returning the
+ result of Value-Form."
+ (unless (symbolp name)
+ (compiler-error "The block name ~S is not a symbol." name))
+ (continuation-starts-block cont)
+ (let* ((dummy (make-continuation))
+ (entry (make-entry))
+ (cleanup (make-cleanup :kind :block
+ :mess-up entry)))
+ (push entry (lambda-entries (lexenv-lambda *lexenv*)))
+ (setf (entry-cleanup entry) cleanup)
+ (prev-link entry start)
+ (use-continuation entry dummy)
+ (let ((*lexenv* (make-lexenv :blocks (list (cons name (list entry cont)))
+ :cleanup cleanup)))
+ (ir1-convert-progn-body dummy cont forms))))
+
+;;; We make Cont start a block just so that it will have a block
+;;; assigned. People assume that when they pass a continuation into
+;;; IR1-Convert as Cont, it will have a block when it is done.
+(def-ir1-translator return-from ((name &optional value)
+ start cont)
+ #!+sb-doc
+ "Return-From Block-Name Value-Form
+ Evaluate the Value-Form, returning its values from the lexically enclosing
+ BLOCK Block-Name. This is constrained to be used only within the dynamic
+ extent of the BLOCK."
+ (continuation-starts-block cont)
+ (let* ((found (or (lexenv-find name blocks)
+ (compiler-error "return for unknown block: ~S" name)))
+ (value-cont (make-continuation))
+ (entry (first found))
+ (exit (make-exit :entry entry
+ :value value-cont)))
+ (push exit (entry-exits entry))
+ (setf (continuation-dest value-cont) exit)
+ (ir1-convert start value-cont value)
+ (prev-link exit value-cont)
+ (use-continuation exit (second found))))
+
+;;; Return a list of the segments of a tagbody. Each segment looks
+;;; like (<tag> <form>* (go <next tag>)). That is, we break up the
+;;; tagbody into segments of non-tag statements, and explicitly
+;;; represent the drop-through with a GO. The first segment has a
+;;; dummy NIL tag, since it represents code before the first tag. The
+;;; last segment (which may also be the first segment) ends in NIL
+;;; rather than a GO.
+(defun parse-tagbody (body)
+ (declare (list body))
+ (collect ((segments))
+ (let ((current (cons nil body)))
+ (loop
+ (let ((tag-pos (position-if-not #'listp current :start 1)))
+ (unless tag-pos
+ (segments `(,@current nil))
+ (return))
+ (let ((tag (elt current tag-pos)))
+ (when (assoc tag (segments))
+ (compiler-error
+ "The tag ~S appears more than once in the tagbody."
+ tag))
+ (unless (or (symbolp tag) (integerp tag))
+ (compiler-error "~S is not a legal tagbody statement." tag))
+ (segments `(,@(subseq current 0 tag-pos) (go ,tag))))
+ (setq current (nthcdr tag-pos current)))))
+ (segments)))
+
+;;; Set up the cleanup, emitting the entry node. Then make a block for
+;;; each tag, building up the tag list for LEXENV-TAGS as we go.
+;;; Finally, convert each segment with the precomputed Start and Cont
+;;; values.
+(def-ir1-translator tagbody ((&rest statements) start cont)
+ #!+sb-doc
+ "Tagbody {Tag | Statement}*
+ Define tags for used with GO. The Statements are evaluated in order
+ (skipping Tags) and NIL is returned. If a statement contains a GO to a
+ defined Tag within the lexical scope of the form, then control is transferred
+ to the next statement following that tag. A Tag must an integer or a
+ symbol. A statement must be a list. Other objects are illegal within the
+ body."
+ (continuation-starts-block cont)
+ (let* ((dummy (make-continuation))
+ (entry (make-entry))
+ (segments (parse-tagbody statements))
+ (cleanup (make-cleanup :kind :tagbody
+ :mess-up entry)))
+ (push entry (lambda-entries (lexenv-lambda *lexenv*)))
+ (setf (entry-cleanup entry) cleanup)
+ (prev-link entry start)
+ (use-continuation entry dummy)
+
+ (collect ((tags)
+ (starts)
+ (conts))
+ (starts dummy)
+ (dolist (segment (rest segments))
+ (let ((tag-cont (make-continuation)))
+ (conts tag-cont)
+ (starts tag-cont)
+ (continuation-starts-block tag-cont)
+ (tags (list (car segment) entry tag-cont))))
+ (conts cont)
+
+ (let ((*lexenv* (make-lexenv :cleanup cleanup :tags (tags))))
+ (mapc #'(lambda (segment start cont)
+ (ir1-convert-progn-body start cont (rest segment)))
+ segments (starts) (conts))))))
+
+;;; Emit an Exit node without any value.
+(def-ir1-translator go ((tag) start cont)
+ #!+sb-doc
+ "Go Tag
+ Transfer control to the named Tag in the lexically enclosing TAGBODY. This
+ is constrained to be used only within the dynamic extent of the TAGBODY."
+ (continuation-starts-block cont)
+ (let* ((found (or (lexenv-find tag tags :test #'eql)
+ (compiler-error "Go to nonexistent tag: ~S." tag)))
+ (entry (first found))
+ (exit (make-exit :entry entry)))
+ (push exit (entry-exits entry))
+ (prev-link exit start)
+ (use-continuation exit (second found))))
+\f
+;;;; translators for compiler-magic special forms
+
+;;; Do stuff to do an EVAL-WHEN. This is split off from the IR1
+;;; convert method so that it can be shared by the special-case
+;;; top-level form processing code. We play with the dynamic
+;;; environment and eval stuff, then call Fun with a list of forms to
+;;; be processed at load time.
+;;;
+;;; Note: the EVAL situation is always ignored: this is conceptually a
+;;; compile-only implementation.
+;;;
+;;; We have to interact with the interpreter to ensure that the forms
+;;; get EVAL'ed exactly once. We bind *ALREADY-EVALED-THIS* to true to
+;;; inhibit evaluation of any enclosed EVAL-WHENs, either by IR1
+;;; conversion done by EVAL, or by conversion of the body for
+;;; load-time processing. If *ALREADY-EVALED-THIS* is true then we *do
+;;; not* eval since some enclosing eval-when already did.
+;;;
+;;; We know we are EVAL'ing for LOAD since we wouldn't get called
+;;; otherwise. If LOAD is a situation we call FUN on body. If we
+;;; aren't evaluating for LOAD, then we call FUN on NIL for the result
+;;; of the EVAL-WHEN.
+(defun do-eval-when-stuff (situations body fun)
+
+ (when (or (not (listp situations))
+ (set-difference situations
+ '(compile load eval
+ :compile-toplevel :load-toplevel :execute)))
+ (compiler-error "bad EVAL-WHEN situation list: ~S" situations))
+
+ (let ((deprecated-names (intersection situations '(compile load eval))))
+ (when deprecated-names
+ (style-warn "using deprecated EVAL-WHEN situation names ~S"
+ deprecated-names)))
+
+ (let* ((do-eval (and (intersection '(compile :compile-toplevel) situations)
+ (not sb!eval::*already-evaled-this*)))
+ (sb!eval::*already-evaled-this* t))
+ (when do-eval
+ (eval `(progn ,@body)))
+ (if (or (intersection '(:load-toplevel load) situations)
+ (and *converting-for-interpreter*
+ (intersection '(:execute eval) situations)))
+ (funcall fun body)
+ (funcall fun '(nil)))))
+
+(def-ir1-translator eval-when ((situations &rest body) start cont)
+ #!+sb-doc
+ "EVAL-WHEN (Situation*) Form*
+ Evaluate the Forms in the specified Situations, any of COMPILE, LOAD, EVAL.
+ This is conceptually a compile-only implementation, so EVAL is a no-op."
+ (do-eval-when-stuff situations body
+ #'(lambda (forms)
+ (ir1-convert-progn-body start cont forms))))
+
+;;; Like DO-EVAL-WHEN-STUFF, only do a macrolet. Fun is not passed any
+;;; arguments.
+(defun do-macrolet-stuff (definitions fun)
+ (declare (list definitions) (type function fun))
+ (let ((whole (gensym "WHOLE"))
+ (environment (gensym "ENVIRONMENT")))
+ (collect ((new-fenv))
+ (dolist (def definitions)
+ (let ((name (first def))
+ (arglist (second def))
+ (body (cddr def)))
+ (unless (symbolp name)
+ (compiler-error "The local macro name ~S is not a symbol." name))
+ (when (< (length def) 2)
+ (compiler-error
+ "The list ~S is too short to be a legal local macro definition."
+ name))
+ (multiple-value-bind (body local-decs)
+ (parse-defmacro arglist whole body name 'macrolet
+ :environment environment)
+ (new-fenv `(,(first def) macro .
+ ,(coerce `(lambda (,whole ,environment)
+ ,@local-decs (block ,name ,body))
+ 'function))))))
+
+ (let ((*lexenv* (make-lexenv :functions (new-fenv))))
+ (funcall fun))))
+
+ (values))
+
+(def-ir1-translator macrolet ((definitions &rest body) start cont)
+ #!+sb-doc
+ "MACROLET ({(Name Lambda-List Form*)}*) Body-Form*
+ Evaluate the Body-Forms in an environment with the specified local macros
+ defined. Name is the local macro name, Lambda-List is the DEFMACRO style
+ destructuring lambda list, and the Forms evaluate to the expansion. The
+ Forms are evaluated in the null environment."
+ (do-macrolet-stuff definitions
+ #'(lambda ()
+ (ir1-convert-progn-body start cont body))))
+
+;;; not really a special form, but..
+(def-ir1-translator declare ((&rest stuff) start cont)
+ (declare (ignore stuff))
+ ;; We ignore START and CONT too, but we can't use DECLARE IGNORE to
+ ;; tell the compiler about it here, because the DEF-IR1-TRANSLATOR
+ ;; macro would put the DECLARE in the wrong place, so..
+ start cont
+ (compiler-error "misplaced declaration"))
+\f
+;;;; %PRIMITIVE
+;;;;
+;;;; Uses of %PRIMITIVE are either expanded into Lisp code or turned
+;;;; into a funny function.
+
+;;; Carefully evaluate a list of forms, returning a list of the results.
+(defun eval-info-args (args)
+ (declare (list args))
+ (handler-case (mapcar #'eval args)
+ (error (condition)
+ (compiler-error "Lisp error during evaluation of info args:~%~A"
+ condition))))
+
+;;; a hashtable that translates from primitive names to translation functions
+(defvar *primitive-translators* (make-hash-table :test 'eq))
+
+;;; If there is a primitive translator, then we expand the call.
+;;; Otherwise, we convert to the %%PRIMITIVE funny function. The first
+;;; argument is the template, the second is a list of the results of
+;;; any codegen-info args, and the remaining arguments are the runtime
+;;; arguments.
+;;;
+;;; We do a bunch of error checking now so that we don't bomb out with
+;;; a fatal error during IR2 conversion.
+;;;
+;;; KLUDGE: It's confusing having multiple names floating around for
+;;; nearly the same concept: PRIMITIVE, TEMPLATE, VOP. Might it be
+;;; possible to reimplement BYTE-BLT (the only use of
+;;; *PRIMITIVE-TRANSLATORS*) some other way, then get rid of primitive
+;;; translators altogether, so that there would be no distinction
+;;; between primitives and vops? Then we could call primitives vops,
+;;; rename TEMPLATE to VOP-TEMPLATE, rename BACKEND-TEMPLATE-NAMES to
+;;; BACKEND-VOPS, and rename %PRIMITIVE to VOP.. -- WHN 19990906
+;;; FIXME: Look at doing this ^, it doesn't look too hard actually. I
+;;; think BYTE-BLT could probably just become an inline function.
+(def-ir1-translator %primitive ((&whole form name &rest args) start cont)
+
+ (unless (symbolp name)
+ (compiler-error "The primitive name ~S is not a symbol." name))
+
+ (let* ((translator (gethash name *primitive-translators*)))
+ (if translator
+ (ir1-convert start cont (funcall translator (cdr form)))
+ (let* ((template (or (gethash name *backend-template-names*)
+ (compiler-error
+ "The primitive name ~A is not defined."
+ name)))
+ (required (length (template-arg-types template)))
+ (info (template-info-arg-count template))
+ (min (+ required info))
+ (nargs (length args)))
+ (if (template-more-args-type template)
+ (when (< nargs min)
+ (compiler-error "Primitive ~A was called with ~R argument~:P, ~
+ but wants at least ~R."
+ name
+ nargs
+ min))
+ (unless (= nargs min)
+ (compiler-error "Primitive ~A was called with ~R argument~:P, ~
+ but wants exactly ~R."
+ name
+ nargs
+ min)))
+
+ (when (eq (template-result-types template) :conditional)
+ (compiler-error
+ "%PRIMITIVE was used with a conditional template."))
+
+ (when (template-more-results-type template)
+ (compiler-error
+ "%PRIMITIVE was used with an unknown values template."))
+
+ (ir1-convert start
+ cont
+ `(%%primitive ',template
+ ',(eval-info-args
+ (subseq args required min))
+ ,@(subseq args 0 required)
+ ,@(subseq args min)))))))
+\f
+;;;; QUOTE and FUNCTION
+
+(def-ir1-translator quote ((thing) start cont)
+ #!+sb-doc
+ "QUOTE Value
+ Return Value without evaluating it."
+ (reference-constant start cont thing))
+
+(def-ir1-translator function ((thing) start cont)
+ #!+sb-doc
+ "FUNCTION Name
+ Return the lexically apparent definition of the function Name. Name may also
+ be a lambda."
+ (if (consp thing)
+ (case (car thing)
+ ((lambda)
+ (reference-leaf start cont (ir1-convert-lambda thing)))
+ ((setf)
+ (let ((var (find-lexically-apparent-function
+ thing "as the argument to FUNCTION")))
+ (reference-leaf start cont var)))
+ ((instance-lambda)
+ (let ((res (ir1-convert-lambda `(lambda ,@(cdr thing)))))
+ (setf (getf (functional-plist res) :fin-function) t)
+ (reference-leaf start cont res)))
+ (t
+ (compiler-error "~S is not a legal function name." thing)))
+ (let ((var (find-lexically-apparent-function
+ thing "as the argument to FUNCTION")))
+ (reference-leaf start cont var))))
+\f
+;;;; FUNCALL
+
+;;; FUNCALL is implemented on %FUNCALL, which can only call functions
+;;; (not symbols). %FUNCALL is used directly in some places where the
+;;; call should always be open-coded even if FUNCALL is :NOTINLINE.
+(deftransform funcall ((function &rest args) * * :when :both)
+ (collect ((arg-names))
+ (dolist (arg args)
+ (declare (ignore arg))
+ (arg-names (gensym "FUNCALL-ARG-NAMES-")))
+ `(lambda (function ,@(arg-names))
+ (%funcall ,(if (csubtypep (continuation-type function)
+ (specifier-type 'function))
+ 'function
+ '(if (functionp function)
+ function
+ (%coerce-name-to-function function)))
+ ,@(arg-names)))))
+
+(def-ir1-translator %funcall ((function &rest args) start cont)
+ (let ((fun-cont (make-continuation)))
+ (ir1-convert start fun-cont function)
+ (assert-continuation-type fun-cont (specifier-type 'function))
+ (ir1-convert-combination-args fun-cont cont args)))
+
+;;; This source transform exists to reduce the amount of work for the
+;;; compiler. If the called function is a FUNCTION form, then convert
+;;; directly to %FUNCALL, instead of waiting around for type
+;;; inference.
+(def-source-transform funcall (function &rest args)
+ (if (and (consp function) (eq (car function) 'function))
+ `(%funcall ,function ,@args)
+ (values nil t)))
+
+(deftransform %coerce-name-to-function ((thing) * * :when :both)
+ (give-up-ir1-transform
+ "might be a symbol, so must call FDEFINITION at runtime"))
+\f
+;;;; symbol macros
+
+(def-ir1-translator symbol-macrolet ((specs &body body) start cont)
+ #!+sb-doc
+ "SYMBOL-MACROLET ({(Name Expansion)}*) Decl* Form*
+ Define the Names as symbol macros with the given Expansions. Within the
+ body, references to a Name will effectively be replaced with the Expansion."
+ (multiple-value-bind (forms decls) (sb!sys:parse-body body nil)
+ (collect ((res))
+ (dolist (spec specs)
+ (unless (proper-list-of-length-p spec 2)
+ (compiler-error "The symbol macro binding ~S is malformed." spec))
+ (let ((name (first spec))
+ (def (second spec)))
+ (unless (symbolp name)
+ (compiler-error "The symbol macro name ~S is not a symbol." name))
+ (when (assoc name (res) :test #'eq)
+ (compiler-style-warning
+ "The name ~S occurs more than once in SYMBOL-MACROLET."
+ name))
+ (res `(,name . (MACRO . ,def)))))
+
+ (let* ((*lexenv* (make-lexenv :variables (res)))
+ (*lexenv* (process-decls decls (res) nil cont)))
+ (ir1-convert-progn-body start cont forms)))))
+\f
+;;; This is a frob that DEFSTRUCT expands into to establish the compiler
+;;; semantics. The other code in the expansion and %%COMPILER-DEFSTRUCT do
+;;; most of the work, we just clear all of the functions out of
+;;; *FREE-FUNCTIONS* to keep things in synch. %%COMPILER-DEFSTRUCT is also
+;;; called at load-time.
+(def-ir1-translator %compiler-defstruct ((info) start cont :kind :function)
+ (let* ((info (eval info)))
+ (%%compiler-defstruct info)
+ (dolist (slot (dd-slots info))
+ (let ((fun (dsd-accessor slot)))
+ (remhash fun *free-functions*)
+ (unless (dsd-read-only slot)
+ (remhash `(setf ,fun) *free-functions*))))
+ (remhash (dd-predicate info) *free-functions*)
+ (remhash (dd-copier info) *free-functions*)
+ (ir1-convert start cont `(%%compiler-defstruct ',info))))
+
+;;; Return the contents of a quoted form.
+(defun unquote (x)
+ (if (and (consp x)
+ (= 2 (length x))
+ (eq 'quote (first x)))
+ (second x)
+ (error "not a quoted form")))
+
+;;; Don't actually compile anything, instead call the function now.
+(def-ir1-translator %compiler-only-defstruct
+ ((info inherits) start cont :kind :function)
+ (function-%compiler-only-defstruct (unquote info) (unquote inherits))
+ (reference-constant start cont nil))
+\f
+;;;; LET and LET*
+;;;;
+;;;; (LET and LET* can't be implemented as macros due to the fact that
+;;;; any pervasive declarations also affect the evaluation of the
+;;;; arguments.)
+
+;;; Given a list of binding specifiers in the style of Let, return:
+;;; 1. The list of var structures for the variables bound.
+;;; 2. The initial value form for each variable.
+;;;
+;;; The variable names are checked for legality and globally special
+;;; variables are marked as such. Context is the name of the form, for
+;;; error reporting purposes.
+(declaim (ftype (function (list symbol) (values list list list))
+ extract-let-variables))
+(defun extract-let-variables (bindings context)
+ (collect ((vars)
+ (vals)
+ (names))
+ (flet ((get-var (name)
+ (varify-lambda-arg name
+ (if (eq context 'let*)
+ nil
+ (names)))))
+ (dolist (spec bindings)
+ (cond ((atom spec)
+ (let ((var (get-var spec)))
+ (vars var)
+ (names (cons spec var))
+ (vals nil)))
+ (t
+ (unless (proper-list-of-length-p spec 1 2)
+ (compiler-error "The ~S binding spec ~S is malformed."
+ context
+ spec))
+ (let* ((name (first spec))
+ (var (get-var name)))
+ (vars var)
+ (names name)
+ (vals (second spec)))))))
+
+ (values (vars) (vals) (names))))
+
+(def-ir1-translator let ((bindings &body body)
+ start cont)
+ #!+sb-doc
+ "LET ({(Var [Value]) | Var}*) Declaration* Form*
+ During evaluation of the Forms, bind the Vars to the result of evaluating the
+ Value forms. The variables are bound in parallel after all of the Values are
+ evaluated."
+ (multiple-value-bind (forms decls) (sb!sys:parse-body body nil)
+ (multiple-value-bind (vars values) (extract-let-variables bindings 'let)
+ (let* ((*lexenv* (process-decls decls vars nil cont))
+ (fun-cont (make-continuation))
+ (fun (ir1-convert-lambda-body forms vars)))
+ (reference-leaf start fun-cont fun)
+ (ir1-convert-combination-args fun-cont cont values)))))
+
+(def-ir1-translator let* ((bindings &body body)
+ start cont)
+ #!+sb-doc
+ "LET* ({(Var [Value]) | Var}*) Declaration* Form*
+ Similar to LET, but the variables are bound sequentially, allowing each Value
+ form to reference any of the previous Vars."
+ (multiple-value-bind (forms decls) (sb!sys:parse-body body nil)
+ (multiple-value-bind (vars values) (extract-let-variables bindings 'let*)
+ (let ((*lexenv* (process-decls decls vars nil cont)))
+ (ir1-convert-aux-bindings start cont forms vars values nil)))))
+
+;;; This is a lot like a LET* with no bindings. Unlike LET*, LOCALLY
+;;; has to preserves top-level-formness, but we don't need to worry
+;;; about that here, because special logic in the compiler main loop
+;;; grabs top-level LOCALLYs and takes care of them before this
+;;; transform ever sees them.
+(def-ir1-translator locally ((&body body)
+ start cont)
+ #!+sb-doc
+ "LOCALLY Declaration* Form*
+ Sequentially evaluate the Forms in a lexical environment where the
+ the Declarations have effect. If LOCALLY is a top-level form, then
+ the Forms are also processed as top-level forms."
+ (multiple-value-bind (forms decls) (sb!sys:parse-body body nil)
+ (let* ((*lexenv* (process-decls decls nil nil cont)))
+ (ir1-convert-aux-bindings start cont forms nil nil nil))))
+\f
+;;;; FLET and LABELS
+
+;;; Given a list of local function specifications in the style of
+;;; Flet, return lists of the function names and of the lambdas which
+;;; are their definitions.
+;;;
+;;; The function names are checked for legality. Context is the name
+;;; of the form, for error reporting.
+(declaim (ftype (function (list symbol) (values list list))
+ extract-flet-variables))
+(defun extract-flet-variables (definitions context)
+ (collect ((names)
+ (defs))
+ (dolist (def definitions)
+ (when (or (atom def) (< (length def) 2))
+ (compiler-error "The ~S definition spec ~S is malformed." context def))
+
+ (let ((name (check-function-name (first def))))
+ (names name)
+ (multiple-value-bind (forms decls) (sb!sys:parse-body (cddr def))
+ (defs `(lambda ,(second def)
+ ,@decls
+ (block ,(function-name-block-name name)
+ . ,forms))))))
+ (values (names) (defs))))
+
+(def-ir1-translator flet ((definitions &body body)
+ start cont)
+ #!+sb-doc
+ "FLET ({(Name Lambda-List Declaration* Form*)}*) Declaration* Body-Form*
+ Evaluate the Body-Forms with some local function definitions. The bindings
+ do not enclose the definitions; any use of Name in the Forms will refer to
+ the lexically apparent function definition in the enclosing environment."
+ (multiple-value-bind (forms decls) (sb!sys:parse-body body nil)
+ (multiple-value-bind (names defs)
+ (extract-flet-variables definitions 'flet)
+ (let* ((fvars (mapcar (lambda (n d)
+ (ir1-convert-lambda d n))
+ names defs))
+ (*lexenv* (make-lexenv
+ :default (process-decls decls nil fvars cont)
+ :functions (pairlis names fvars))))
+ (ir1-convert-progn-body start cont forms)))))
+
+;;; For LABELS, we have to create dummy function vars and add them to
+;;; the function namespace while converting the functions. We then
+;;; modify all the references to these leaves so that they point to
+;;; the real functional leaves. We also backpatch the FENV so that if
+;;; the lexical environment is used for inline expansion we will get
+;;; the right functions.
+(def-ir1-translator labels ((definitions &body body) start cont)
+ #!+sb-doc
+ "LABELS ({(Name Lambda-List Declaration* Form*)}*) Declaration* Body-Form*
+ Evaluate the Body-Forms with some local function definitions. The bindings
+ enclose the new definitions, so the defined functions can call themselves or
+ each other."
+ (multiple-value-bind (forms decls) (sb!sys:parse-body body nil)
+ (multiple-value-bind (names defs)
+ (extract-flet-variables definitions 'labels)
+ (let* ((new-fenv (loop for name in names
+ collect (cons name (make-functional :name name))))
+ (real-funs
+ (let ((*lexenv* (make-lexenv :functions new-fenv)))
+ (mapcar (lambda (n d)
+ (ir1-convert-lambda d n))
+ names defs))))
+
+ (loop for real in real-funs and env in new-fenv do
+ (let ((dum (cdr env)))
+ (substitute-leaf real dum)
+ (setf (cdr env) real)))
+
+ (let ((*lexenv* (make-lexenv
+ :default (process-decls decls nil real-funs cont)
+ :functions (pairlis names real-funs))))
+ (ir1-convert-progn-body start cont forms))))))
+\f
+;;;; THE
+
+;;; Do stuff to recognize a THE or VALUES declaration. Cont is the
+;;; continuation that the assertion applies to, Type is the type
+;;; specifier and Lexenv is the current lexical environment. Name is
+;;; the name of the declaration we are doing, for use in error
+;;; messages.
+;;;
+;;; This is somewhat involved, since a type assertion may only be made
+;;; on a continuation, not on a node. We can't just set the
+;;; continuation asserted type and let it go at that, since there may
+;;; be parallel THE's for the same continuation, i.e.:
+;;; (if ...
+;;; (the foo ...)
+;;; (the bar ...))
+;;;
+;;; In this case, our representation can do no better than the union
+;;; of these assertions. And if there is a branch with no assertion,
+;;; we have nothing at all. We really need to recognize scoping, since
+;;; we need to be able to discern between parallel assertions (which
+;;; we union) and nested ones (which we intersect).
+;;;
+;;; We represent the scoping by throwing our innermost (intersected)
+;;; assertion on Cont into the TYPE-RESTRICTIONS. As we go down, we
+;;; intersect our assertions together. If Cont has no uses yet, we
+;;; have not yet bottomed out on the first COND branch; in this case
+;;; we optimistically assume that this type will be the one we end up
+;;; with, and set the ASSERTED-TYPE to it. We can never get better
+;;; than the type that we have the first time we bottom out. Later
+;;; THE's (or the absence thereof) can only weaken this result.
+;;;
+;;; We make this work by getting USE-CONTINUATION to do the unioning
+;;; across COND branches. We can't do it here, since we don't know how
+;;; many branches there are going to be.
+(defun do-the-stuff (type cont lexenv name)
+ (declare (type continuation cont) (type lexenv lexenv))
+ (let* ((ctype (values-specifier-type type))
+ (old-type (or (lexenv-find cont type-restrictions)
+ *wild-type*))
+ (intersects (values-types-intersect old-type ctype))
+ (int (values-type-intersection old-type ctype))
+ (new (if intersects int old-type)))
+ (when (null (find-uses cont))
+ (setf (continuation-asserted-type cont) new))
+ (when (and (not intersects)
+ (not (policy nil (= brevity 3)))) ;FIXME: really OK to suppress?
+ (compiler-warning
+ "The type ~S in ~S declaration conflicts with an enclosing assertion:~% ~S"
+ (type-specifier ctype)
+ name
+ (type-specifier old-type)))
+ (make-lexenv :type-restrictions `((,cont . ,new))
+ :default lexenv)))
+
+;;; FIXME: In a version of CMU CL that I used at Cadabra ca. 20000101,
+;;; this didn't seem to expand into an assertion, at least for ALIEN
+;;; values. Check that SBCL doesn't have this problem.
+(def-ir1-translator the ((type value) start cont)
+ #!+sb-doc
+ "THE Type Form
+ Assert that Form evaluates to the specified type (which may be a VALUES
+ type.)"
+ (let ((*lexenv* (do-the-stuff type cont *lexenv* 'the)))
+ (ir1-convert start cont value)))
+
+;;; Since the CONTINUATION-DERIVED-TYPE is computed as the union of
+;;; its uses's types, setting it won't work. Instead we must intersect
+;;; the type with the uses's DERIVED-TYPE.
+(def-ir1-translator truly-the ((type value) start cont)
+ #!+sb-doc
+ "Truly-The Type Value
+ Like the THE special form, except that it believes whatever you tell it. It
+ will never generate a type check, but will cause a warning if the compiler
+ can prove the assertion is wrong."
+ (declare (inline member))
+ (let ((type (values-specifier-type type))
+ (old (find-uses cont)))
+ (ir1-convert start cont value)
+ (do-uses (use cont)
+ (unless (member use old :test #'eq)
+ (derive-node-type use type)))))
+\f
+;;;; SETQ
+
+;;; If there is a definition in LEXENV-VARIABLES, just set that,
+;;; otherwise look at the global information. If the name is for a
+;;; constant, then error out.
+(def-ir1-translator setq ((&whole source &rest things) start cont)
+ #!+sb-doc
+ "SETQ {Var Value}*
+ Set the variables to the values. If more than one pair is supplied, the
+ assignments are done sequentially. If Var names a symbol macro, SETF the
+ expansion."
+ (let ((len (length things)))
+ (when (oddp len)
+ (compiler-error "odd number of args to SETQ: ~S" source))
+ (if (= len 2)
+ (let* ((name (first things))
+ (leaf (or (lexenv-find name variables)
+ (find-free-variable name))))
+ (etypecase leaf
+ (leaf
+ (when (or (constant-p leaf)
+ (and (global-var-p leaf)
+ (eq (global-var-kind leaf) :constant)))
+ (compiler-error "~S is a constant and thus can't be set." name))
+ (when (and (lambda-var-p leaf)
+ (lambda-var-ignorep leaf))
+ ;; ANSI's definition of "Declaration IGNORE, IGNORABLE"
+ ;; requires that this be a STYLE-WARNING, not a full warning.
+ (compiler-style-warning
+ "~S is being set even though it was declared to be ignored."
+ name))
+ (set-variable start cont leaf (second things)))
+ (cons
+ (assert (eq (car leaf) 'MACRO))
+ (ir1-convert start cont `(setf ,(cdr leaf) ,(second things))))
+ (heap-alien-info
+ (ir1-convert start cont
+ `(%set-heap-alien ',leaf ,(second things))))))
+ (collect ((sets))
+ (do ((thing things (cddr thing)))
+ ((endp thing)
+ (ir1-convert-progn-body start cont (sets)))
+ (sets `(setq ,(first thing) ,(second thing))))))))
+
+;;; Kind of like Reference-Leaf, but we generate a Set node. This
+;;; should only need to be called in Setq.
+(defun set-variable (start cont var value)
+ (declare (type continuation start cont) (type basic-var var))
+ (let ((dest (make-continuation)))
+ (setf (continuation-asserted-type dest) (leaf-type var))
+ (ir1-convert start dest value)
+ (let ((res (make-set :var var :value dest)))
+ (setf (continuation-dest dest) res)
+ (setf (leaf-ever-used var) t)
+ (push res (basic-var-sets var))
+ (prev-link res dest)
+ (use-continuation res cont))))
+\f
+;;;; CATCH, THROW and UNWIND-PROTECT
+
+;;; We turn THROW into a multiple-value-call of a magical function,
+;;; since as as far as IR1 is concerned, it has no interesting
+;;; properties other than receiving multiple-values.
+(def-ir1-translator throw ((tag result) start cont)
+ #!+sb-doc
+ "Throw Tag Form
+ Do a non-local exit, return the values of Form from the CATCH whose tag
+ evaluates to the same thing as Tag."
+ (ir1-convert start cont
+ `(multiple-value-call #'%throw ,tag ,result)))
+
+;;; This is a special special form used to instantiate a cleanup as
+;;; the current cleanup within the body. Kind is a the kind of cleanup
+;;; to make, and Mess-Up is a form that does the mess-up action. We
+;;; make the MESS-UP be the USE of the Mess-Up form's continuation,
+;;; and introduce the cleanup into the lexical environment. We
+;;; back-patch the Entry-Cleanup for the current cleanup to be the new
+;;; cleanup, since this inner cleanup is the interesting one.
+(def-ir1-translator %within-cleanup ((kind mess-up &body body) start cont)
+ (let ((dummy (make-continuation))
+ (dummy2 (make-continuation)))
+ (ir1-convert start dummy mess-up)
+ (let* ((mess-node (continuation-use dummy))
+ (cleanup (make-cleanup :kind kind
+ :mess-up mess-node))
+ (old-cup (lexenv-cleanup *lexenv*))
+ (*lexenv* (make-lexenv :cleanup cleanup)))
+ (setf (entry-cleanup (cleanup-mess-up old-cup)) cleanup)
+ (ir1-convert dummy dummy2 '(%cleanup-point))
+ (ir1-convert-progn-body dummy2 cont body))))
+
+;;; This is a special special form that makes an "escape function"
+;;; which returns unknown values from named block. We convert the
+;;; function, set its kind to :Escape, and then reference it. The
+;;; :Escape kind indicates that this function's purpose is to
+;;; represent a non-local control transfer, and that it might not
+;;; actually have to be compiled.
+;;;
+;;; Note that environment analysis replaces references to escape
+;;; functions with references to the corresponding NLX-Info structure.
+(def-ir1-translator %escape-function ((tag) start cont)
+ (let ((fun (ir1-convert-lambda
+ `(lambda ()
+ (return-from ,tag (%unknown-values))))))
+ (setf (functional-kind fun) :escape)
+ (reference-leaf start cont fun)))
+
+;;; Yet another special special form. This one looks up a local
+;;; function and smashes it to a :Cleanup function, as well as
+;;; referencing it.
+(def-ir1-translator %cleanup-function ((name) start cont)
+ (let ((fun (lexenv-find name functions)))
+ (assert (lambda-p fun))
+ (setf (functional-kind fun) :cleanup)
+ (reference-leaf start cont fun)))
+
+;;; We represent the possibility of the control transfer by making an
+;;; "escape function" that does a lexical exit, and instantiate the
+;;; cleanup using %within-cleanup.
+(def-ir1-translator catch ((tag &body body) start cont)
+ #!+sb-doc
+ "Catch Tag Form*
+ Evaluates Tag and instantiates it as a catcher while the body forms are
+ evaluated in an implicit PROGN. If a THROW is done to Tag within the dynamic
+ scope of the body, then control will be transferred to the end of the body
+ and the thrown values will be returned."
+ (ir1-convert
+ start cont
+ (let ((exit-block (gensym "EXIT-BLOCK-")))
+ `(block ,exit-block
+ (%within-cleanup
+ :catch
+ (%catch (%escape-function ,exit-block) ,tag)
+ ,@body)))))
+
+;;; UNWIND-PROTECT is similar to CATCH, but more hairy. We make the
+;;; cleanup forms into a local function so that they can be referenced
+;;; both in the case where we are unwound and in any local exits. We
+;;; use %Cleanup-Function on this to indicate that reference by
+;;; %Unwind-Protect isn't "real", and thus doesn't cause creation of
+;;; an XEP.
+(def-ir1-translator unwind-protect ((protected &body cleanup) start cont)
+ #!+sb-doc
+ "Unwind-Protect Protected Cleanup*
+ Evaluate the form Protected, returning its values. The cleanup forms are
+ evaluated whenever the dynamic scope of the Protected form is exited (either
+ due to normal completion or a non-local exit such as THROW)."
+ (ir1-convert
+ start cont
+ (let ((cleanup-fun (gensym "CLEANUP-FUN-"))
+ (drop-thru-tag (gensym "DROP-THRU-TAG-"))
+ (exit-tag (gensym "EXIT-TAG-"))
+ (next (gensym "NEXT"))
+ (start (gensym "START"))
+ (count (gensym "COUNT")))
+ `(flet ((,cleanup-fun () ,@cleanup nil))
+ ;; FIXME: If we ever get DYNAMIC-EXTENT working, then
+ ;; ,CLEANUP-FUN should probably be declared DYNAMIC-EXTENT,
+ ;; and something can be done to make %ESCAPE-FUNCTION have
+ ;; dynamic extent too.
+ (block ,drop-thru-tag
+ (multiple-value-bind (,next ,start ,count)
+ (block ,exit-tag
+ (%within-cleanup
+ :unwind-protect
+ (%unwind-protect (%escape-function ,exit-tag)
+ (%cleanup-function ,cleanup-fun))
+ (return-from ,drop-thru-tag ,protected)))
+ (,cleanup-fun)
+ (%continue-unwind ,next ,start ,count)))))))
+\f
+;;;; multiple-value stuff
+
+;;; If there are arguments, MULTIPLE-VALUE-CALL turns into an
+;;; MV-Combination.
+;;;
+;;; If there are no arguments, then we convert to a normal
+;;; combination, ensuring that a MV-Combination always has at least
+;;; one argument. This can be regarded as an optimization, but it is
+;;; more important for simplifying compilation of MV-Combinations.
+(def-ir1-translator multiple-value-call ((fun &rest args) start cont)
+ #!+sb-doc
+ "MULTIPLE-VALUE-CALL Function Values-Form*
+ Call Function, passing all the values of each Values-Form as arguments,
+ values from the first Values-Form making up the first argument, etc."
+ (let* ((fun-cont (make-continuation))
+ (node (if args
+ (make-mv-combination fun-cont)
+ (make-combination fun-cont))))
+ (ir1-convert start fun-cont
+ (if (and (consp fun) (eq (car fun) 'function))
+ fun
+ (once-only ((fun fun))
+ `(if (functionp ,fun)
+ ,fun
+ (%coerce-name-to-function ,fun)))))
+ (setf (continuation-dest fun-cont) node)
+ (assert-continuation-type fun-cont
+ (specifier-type '(or function symbol)))
+ (collect ((arg-conts))
+ (let ((this-start fun-cont))
+ (dolist (arg args)
+ (let ((this-cont (make-continuation node)))
+ (ir1-convert this-start this-cont arg)
+ (setq this-start this-cont)
+ (arg-conts this-cont)))
+ (prev-link node this-start)
+ (use-continuation node cont)
+ (setf (basic-combination-args node) (arg-conts))))))
+
+;;; Multiple-Value-Prog1 is represented implicitly in IR1 by having a
+;;; the result code use result continuation (CONT), but transfer
+;;; control to the evaluation of the body. In other words, the result
+;;; continuation isn't Immediately-Used-P by the nodes that compute
+;;; the result.
+;;;
+;;; In order to get the control flow right, we convert the result with
+;;; a dummy result continuation, then convert all the uses of the
+;;; dummy to be uses of CONT. If a use is an Exit, then we also
+;;; substitute CONT for the dummy in the corresponding Entry node so
+;;; that they are consistent. Note that this doesn't amount to
+;;; changing the exit target, since the control destination of an exit
+;;; is determined by the block successor; we are just indicating the
+;;; continuation that the result is delivered to.
+;;;
+;;; We then convert the body, using another dummy continuation in its
+;;; own block as the result. After we are done converting the body, we
+;;; move all predecessors of the dummy end block to CONT's block.
+;;;
+;;; Note that we both exploit and maintain the invariant that the CONT
+;;; to an IR1 convert method either has no block or starts the block
+;;; that control should transfer to after completion for the form.
+;;; Nested MV-Prog1's work because during conversion of the result
+;;; form, we use dummy continuation whose block is the true control
+;;; destination.
+(def-ir1-translator multiple-value-prog1 ((result &rest forms) start cont)
+ #!+sb-doc
+ "MULTIPLE-VALUE-PROG1 Values-Form Form*
+ Evaluate Values-Form and then the Forms, but return all the values of
+ Values-Form."
+ (continuation-starts-block cont)
+ (let* ((dummy-result (make-continuation))
+ (dummy-start (make-continuation))
+ (cont-block (continuation-block cont)))
+ (continuation-starts-block dummy-start)
+ (ir1-convert start dummy-start result)
+
+ (substitute-continuation-uses cont dummy-start)
+
+ (continuation-starts-block dummy-result)
+ (ir1-convert-progn-body dummy-start dummy-result forms)
+ (let ((end-block (continuation-block dummy-result)))
+ (dolist (pred (block-pred end-block))
+ (unlink-blocks pred end-block)
+ (link-blocks pred cont-block))
+ (assert (not (continuation-dest dummy-result)))
+ (delete-continuation dummy-result)
+ (remove-from-dfo end-block))))
+\f
+;;;; interface to defining macros
+
+;;;; DEFMACRO, DEFUN and DEFCONSTANT expand into calls to %DEFxxx
+;;;; functions so that we get a chance to see what is going on. We
+;;;; define IR1 translators for these functions which look at the
+;;;; definition and then generate a call to the %%DEFxxx function.
+
+;;; Return a new source path with any stuff intervening between the
+;;; current path and the first form beginning with Name stripped off.
+;;; This is used to hide the guts of DEFmumble macros to prevent
+;;; annoying error messages.
+(defun revert-source-path (name)
+ (do ((path *current-path* (cdr path)))
+ ((null path) *current-path*)
+ (let ((first (first path)))
+ (when (or (eq first name)
+ (eq first 'original-source-start))
+ (return path)))))
+
+;;; Warn about incompatible or illegal definitions and add the macro
+;;; to the compiler environment.
+;;;
+;;; Someday we could check for macro arguments being incompatibly
+;;; redefined. Doing this right will involve finding the old macro
+;;; lambda-list and comparing it with the new one.
+(def-ir1-translator %defmacro ((qname qdef lambda-list doc) start cont
+ :kind :function)
+ (let (;; QNAME is typically a quoted name. I think the idea is to let
+ ;; %DEFMACRO work as an ordinary function when interpreting. Whatever
+ ;; the reason it's there, we don't want it any more. -- WHN 19990603
+ (name (eval qname))
+ ;; QDEF should be a sharp-quoted definition. We don't want to make a
+ ;; function of it just yet, so we just drop the sharp-quote.
+ (def (progn
+ (assert (eq 'function (first qdef)))
+ (assert (proper-list-of-length-p qdef 2))
+ (second qdef))))
+
+ (unless (symbolp name)
+ (compiler-error "The macro name ~S is not a symbol." name))
+
+ (ecase (info :function :kind name)
+ ((nil))
+ (:function
+ (remhash name *free-functions*)
+ (undefine-function-name name)
+ (compiler-warning
+ "~S is being redefined as a macro when it was previously ~(~A~) to be a function."
+ name
+ (info :function :where-from name)))
+ (:macro)
+ (:special-form
+ (compiler-error "The special form ~S can't be redefined as a macro."
+ name)))
+
+ (setf (info :function :kind name) :macro)
+ (setf (info :function :where-from name) :defined)
+
+ (when *compile-time-define-macros*
+ (setf (info :function :macro-function name)
+ (coerce def 'function)))
+
+ (let* ((*current-path* (revert-source-path 'defmacro))
+ (fun (ir1-convert-lambda def name)))
+ (setf (leaf-name fun)
+ (concatenate 'string "DEFMACRO " (symbol-name name)))
+ (setf (functional-arg-documentation fun) (eval lambda-list))
+
+ (ir1-convert start cont `(%%defmacro ',name ,fun ,doc)))
+
+ (when sb!xc:*compile-print*
+ (compiler-mumble "converted ~S~%" name))))
+
+(def-ir1-translator %define-compiler-macro ((name def lambda-list doc)
+ start cont
+ :kind :function)
+ (let ((name (eval name))
+ (def (second def))) ; Don't want to make a function just yet...
+
+ (when (eq (info :function :kind name) :special-form)
+ (compiler-error "attempt to define a compiler-macro for special form ~S"
+ name))
+
+ (when *compile-time-define-macros*
+ (setf (info :function :compiler-macro-function name)
+ (coerce def 'function)))
+
+ (let* ((*current-path* (revert-source-path 'define-compiler-macro))
+ (fun (ir1-convert-lambda def name)))
+ (setf (leaf-name fun)
+ (let ((*print-case* :upcase))
+ (format nil "DEFINE-COMPILER-MACRO ~S" name)))
+ (setf (functional-arg-documentation fun) (eval lambda-list))
+
+ (ir1-convert start cont `(%%define-compiler-macro ',name ,fun ,doc)))
+
+ (when sb!xc:*compile-print*
+ (compiler-mumble "converted ~S~%" name))))
+
+;;; Update the global environment to correspond to the new definition.
+(def-ir1-translator %defconstant ((name value doc) start cont
+ :kind :function)
+ (let ((name (eval name))
+ (newval (eval value)))
+ (unless (symbolp name)
+ (compiler-error "constant name not a symbol: ~S" name))
+ (when (eq name t)
+ (compiler-error "The value of T can't be changed."))
+ (when (eq name nil)
+ (compiler-error "Nihil ex nihil. (can't change NIL)"))
+ (when (keywordp name)
+ (compiler-error "Keyword values can't be changed."))
+
+ (let ((kind (info :variable :kind name)))
+ (case kind
+ (:constant
+ ;; FIXME: ANSI says EQL, not EQUALP. Perhaps make a special
+ ;; variant of this warning for the case where they're EQUALP,
+ ;; since people seem to be confused about this.
+ (unless (equalp newval (info :variable :constant-value name))
+ (compiler-warning "redefining constant ~S as:~% ~S" name newval)))
+ (:global)
+ (t
+ (compiler-warning "redefining ~(~A~) ~S to be a constant"
+ kind
+ name))))
+
+ (setf (info :variable :kind name) :constant)
+ (setf (info :variable :where-from name) :defined)
+ (setf (info :variable :constant-value name) newval)
+ (remhash name *free-variables*))
+
+ (ir1-convert start cont `(%%defconstant ,name ,value ,doc)))
+\f
+;;;; defining global functions
+
+;;; Convert FUN as a lambda in the null environment, but use the
+;;; current compilation policy. Note that FUN may be a
+;;; LAMBDA-WITH-ENVIRONMENT, so we may have to augment the environment
+;;; to reflect the state at the definition site.
+(defun ir1-convert-inline-lambda (fun &optional name)
+ (destructuring-bind (decls macros symbol-macros &rest body)
+ (if (eq (car fun) 'lambda-with-environment)
+ (cdr fun)
+ `(() () () . ,(cdr fun)))
+ (let ((*lexenv* (make-lexenv
+ :default (process-decls decls nil nil
+ (make-continuation)
+ (make-null-lexenv))
+ :variables (copy-list symbol-macros)
+ :functions
+ (mapcar #'(lambda (x)
+ `(,(car x) .
+ (macro . ,(coerce (cdr x) 'function))))
+ macros)
+ :cookie (lexenv-cookie *lexenv*)
+ :interface-cookie (lexenv-interface-cookie *lexenv*))))
+ (ir1-convert-lambda `(lambda ,@body) name))))
+
+;;; Return a lambda that has been "closed" with respect to ENV,
+;;; returning a LAMBDA-WITH-ENVIRONMENT if there are interesting
+;;; macros or declarations. If there is something too complex (like a
+;;; lexical variable) in the environment, then we return NIL.
+(defun inline-syntactic-closure-lambda (lambda &optional (env *lexenv*))
+ (let ((variables (lexenv-variables env))
+ (functions (lexenv-functions env))
+ (decls ())
+ (symmacs ())
+ (macros ()))
+ (cond ((or (lexenv-blocks env) (lexenv-tags env)) nil)
+ ((and (null variables) (null functions))
+ lambda)
+ ((dolist (x variables nil)
+ (let ((name (car x))
+ (what (cdr x)))
+ (when (eq x (assoc name variables :test #'eq))
+ (typecase what
+ (cons
+ (assert (eq (car what) 'macro))
+ (push x symmacs))
+ (global-var
+ (assert (eq (global-var-kind what) :special))
+ (push `(special ,name) decls))
+ (t (return t))))))
+ nil)
+ ((dolist (x functions nil)
+ (let ((name (car x))
+ (what (cdr x)))
+ (when (eq x (assoc name functions :test #'equal))
+ (typecase what
+ (cons
+ (push (cons name
+ (function-lambda-expression (cdr what)))
+ macros))
+ (global-var
+ (when (defined-function-p what)
+ (push `(,(car (rassoc (defined-function-inlinep what)
+ inlinep-translations))
+ ,name)
+ decls)))
+ (t (return t))))))
+ nil)
+ (t
+ `(lambda-with-environment ,decls
+ ,macros
+ ,symmacs
+ . ,(rest lambda))))))
+
+;;; Get a DEFINED-FUNCTION object for a function we are about to
+;;; define. If the function has been forward referenced, then
+;;; substitute for the previous references.
+(defun get-defined-function (name)
+ (let* ((name (proclaim-as-function-name name))
+ (found (find-free-function name "Eh?")))
+ (note-name-defined name :function)
+ (cond ((not (defined-function-p found))
+ (assert (not (info :function :inlinep name)))
+ (let* ((where-from (leaf-where-from found))
+ (res (make-defined-function
+ :name name
+ :where-from (if (eq where-from :declared)
+ :declared :defined)
+ :type (leaf-type found))))
+ (substitute-leaf res found)
+ (setf (gethash name *free-functions*) res)))
+ ;; If *FREE-FUNCTIONS* has a previously converted definition for this
+ ;; name, then blow it away and try again.
+ ((defined-function-functional found)
+ (remhash name *free-functions*)
+ (get-defined-function name))
+ (t found))))
+
+;;; Check a new global function definition for consistency with
+;;; previous declaration or definition, and assert argument/result
+;;; types if appropriate. This this assertion is suppressed by the
+;;; EXPLICIT-CHECK attribute, which is specified on functions that
+;;; check their argument types as a consequence of type dispatching.
+;;; This avoids redundant checks such as NUMBERP on the args to +,
+;;; etc.
+(defun assert-new-definition (var fun)
+ (let ((type (leaf-type var))
+ (for-real (eq (leaf-where-from var) :declared))
+ (info (info :function :info (leaf-name var))))
+ (assert-definition-type
+ fun type
+ :error-function #'compiler-warning
+ :warning-function (cond (info #'compiler-warning)
+ (for-real #'compiler-note)
+ (t nil))
+ :really-assert
+ (and for-real
+ (not (and info
+ (ir1-attributep (function-info-attributes info)
+ explicit-check))))
+ :where (if for-real
+ "previous declaration"
+ "previous definition"))))
+
+;;; Convert a lambda doing all the basic stuff we would do if we were
+;;; converting a DEFUN. This is used both by the %DEFUN translator and
+;;; for global inline expansion.
+;;;
+;;; Unless a :INLINE function, we temporarily clobber the inline
+;;; expansion. This prevents recursive inline expansion of
+;;; opportunistic pseudo-inlines.
+(defun ir1-convert-lambda-for-defun (lambda var expansion converter)
+ (declare (cons lambda) (function converter) (type defined-function var))
+ (let ((var-expansion (defined-function-inline-expansion var)))
+ (unless (eq (defined-function-inlinep var) :inline)
+ (setf (defined-function-inline-expansion var) nil))
+ (let* ((name (leaf-name var))
+ (fun (funcall converter lambda name))
+ (function-info (info :function :info name)))
+ (setf (functional-inlinep fun) (defined-function-inlinep var))
+ (assert-new-definition var fun)
+ (setf (defined-function-inline-expansion var) var-expansion)
+ ;; If definitely not an interpreter stub, then substitute for any
+ ;; old references.
+ (unless (or (eq (defined-function-inlinep var) :notinline)
+ (not *block-compile*)
+ (and function-info
+ (or (function-info-transforms function-info)
+ (function-info-templates function-info)
+ (function-info-ir2-convert function-info))))
+ (substitute-leaf fun var)
+ ;; If in a simple environment, then we can allow backward
+ ;; references to this function from following top-level forms.
+ (when expansion (setf (defined-function-functional var) fun)))
+ fun)))
+
+;;; Convert the definition and install it in the global environment
+;;; with a LABELS-like effect. If the lexical environment is not null,
+;;; then we only install the definition during the processing of this
+;;; DEFUN, ensuring that the function cannot be called outside of the
+;;; correct environment. If the function is globally NOTINLINE, then
+;;; that inhibits even local substitution. Also, emit top-level code
+;;; to install the definition.
+;;;
+;;; This is one of the major places where the semantics of block
+;;; compilation is handled. Substitution for global names is totally
+;;; inhibited if *BLOCK-COMPILE* is NIL. And if *BLOCK-COMPILE* is
+;;; true and entry points are specified, then we don't install global
+;;; definitions for non-entry functions (effectively turning them into
+;;; local lexical functions.)
+(def-ir1-translator %defun ((name def doc source) start cont
+ :kind :function)
+ (declare (ignore source))
+ (let* ((name (eval name))
+ (lambda (second def))
+ (*current-path* (revert-source-path 'defun))
+ (expansion (unless (eq (info :function :inlinep name) :notinline)
+ (inline-syntactic-closure-lambda lambda))))
+ ;; If not in a simple environment or NOTINLINE, then discard any forward
+ ;; references to this function.
+ (unless expansion (remhash name *free-functions*))
+
+ (let* ((var (get-defined-function name))
+ (save-expansion (and (member (defined-function-inlinep var)
+ '(:inline :maybe-inline))
+ expansion)))
+ (setf (defined-function-inline-expansion var) expansion)
+ (setf (info :function :inline-expansion name) save-expansion)
+ ;; If there is a type from a previous definition, blast it, since it is
+ ;; obsolete.
+ (when (eq (leaf-where-from var) :defined)
+ (setf (leaf-type var) (specifier-type 'function)))
+
+ (let ((fun (ir1-convert-lambda-for-defun lambda
+ var
+ expansion
+ #'ir1-convert-lambda)))
+ (ir1-convert
+ start cont
+ (if (and *block-compile* *entry-points*
+ (not (member name *entry-points* :test #'equal)))
+ `',name
+ `(%%defun ',name ,fun ,doc
+ ,@(when save-expansion `(',save-expansion)))))
+
+ (when sb!xc:*compile-print*
+ (compiler-mumble "converted ~S~%" name))))))
--- /dev/null
+;;;; This file contains miscellaneous utilities used for manipulating
+;;;; the IR1 representation.
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!C")
+
+(file-comment
+ "$Header$")
+\f
+;;;; cleanup hackery
+
+;;; Return the innermost cleanup enclosing Node, or NIL if there is none in
+;;; its function. If Node has no cleanup, but is in a let, then we must still
+;;; check the environment that the call is in.
+(defun node-enclosing-cleanup (node)
+ (declare (type node node))
+ (do ((lexenv (node-lexenv node)
+ (lambda-call-lexenv (lexenv-lambda lexenv))))
+ ((null lexenv) nil)
+ (let ((cup (lexenv-cleanup lexenv)))
+ (when cup (return cup)))))
+
+;;; Convert the Form in a block inserted between Block1 and Block2 as an
+;;; implicit MV-Prog1. The inserted block is returned. Node is used for IR1
+;;; context when converting the form. Note that the block is not assigned a
+;;; number, and is linked into the DFO at the beginning. We indicate that we
+;;; have trashed the DFO by setting Component-Reanalyze. If Cleanup is
+;;; supplied, then convert with that cleanup.
+(defun insert-cleanup-code (block1 block2 node form &optional cleanup)
+ (declare (type cblock block1 block2) (type node node)
+ (type (or cleanup null) cleanup))
+ (setf (component-reanalyze (block-component block1)) t)
+ (with-ir1-environment node
+ (let* ((start (make-continuation))
+ (block (continuation-starts-block start))
+ (cont (make-continuation))
+ (*lexenv* (if cleanup
+ (make-lexenv :cleanup cleanup)
+ *lexenv*)))
+ (change-block-successor block1 block2 block)
+ (link-blocks block block2)
+ (ir1-convert start cont form)
+ (setf (block-last block) (continuation-use cont))
+ block)))
+\f
+;;;; continuation use hacking
+
+;;; Return a list of all the nodes which use Cont.
+(declaim (ftype (function (continuation) list) find-uses))
+(defun find-uses (cont)
+ (ecase (continuation-kind cont)
+ ((:block-start :deleted-block-start)
+ (block-start-uses (continuation-block cont)))
+ (:inside-block (list (continuation-use cont)))
+ (:unused nil)
+ (:deleted nil)))
+
+;;; Update continuation use information so that Node is no longer a
+;;; use of its Cont. If the old continuation doesn't start its block,
+;;; then we don't update the Block-Start-Uses, since it will be
+;;; deleted when we are done.
+;;;
+;;; Note: if you call this function, you may have to do a
+;;; REOPTIMIZE-CONTINUATION to inform IR1 optimization that something
+;;; has changed.
+(declaim (ftype (function (node) (values)) delete-continuation-use))
+(defun delete-continuation-use (node)
+ (let* ((cont (node-cont node))
+ (block (continuation-block cont)))
+ (ecase (continuation-kind cont)
+ (:deleted)
+ ((:block-start :deleted-block-start)
+ (let ((uses (delete node (block-start-uses block))))
+ (setf (block-start-uses block) uses)
+ (setf (continuation-use cont)
+ (if (cdr uses) nil (car uses)))))
+ (:inside-block
+ (setf (continuation-kind cont) :unused)
+ (setf (continuation-block cont) nil)
+ (setf (continuation-use cont) nil)
+ (setf (continuation-next cont) nil)))
+ (setf (node-cont node) nil))
+ (values))
+
+;;; Update continuation use information so that Node uses Cont. If
+;;; Cont is :Unused, then we set its block to Node's Node-Block (which
+;;; must be set.)
+;;;
+;;; Note: if you call this function, you may have to do a
+;;; REOPTIMIZE-CONTINUATION to inform IR1 optimization that something
+;;; has changed.
+(declaim (ftype (function (node continuation) (values)) add-continuation-use))
+(defun add-continuation-use (node cont)
+ (assert (not (node-cont node)))
+ (let ((block (continuation-block cont)))
+ (ecase (continuation-kind cont)
+ (:deleted)
+ (:unused
+ (assert (not block))
+ (let ((block (node-block node)))
+ (assert block)
+ (setf (continuation-block cont) block))
+ (setf (continuation-kind cont) :inside-block)
+ (setf (continuation-use cont) node))
+ ((:block-start :deleted-block-start)
+ (let ((uses (cons node (block-start-uses block))))
+ (setf (block-start-uses block) uses)
+ (setf (continuation-use cont)
+ (if (cdr uses) nil (car uses)))))))
+ (setf (node-cont node) cont)
+ (values))
+
+;;; Return true if Cont is the Node-Cont for Node and Cont is transferred to
+;;; immediately after the evaluation of Node.
+(defun immediately-used-p (cont node)
+ (declare (type continuation cont) (type node node))
+ (and (eq (node-cont node) cont)
+ (not (eq (continuation-kind cont) :deleted))
+ (let ((cblock (continuation-block cont))
+ (nblock (node-block node)))
+ (or (eq cblock nblock)
+ (let ((succ (block-succ nblock)))
+ (and (= (length succ) 1)
+ (eq (first succ) cblock)))))))
+\f
+;;;; continuation substitution
+
+;;; In Old's Dest, replace Old with New. New's Dest must initially be NIL.
+;;; When we are done, we call Flush-Dest on Old to clear its Dest and to note
+;;; potential optimization opportunities.
+(defun substitute-continuation (new old)
+ (declare (type continuation old new))
+ (assert (not (continuation-dest new)))
+ (let ((dest (continuation-dest old)))
+ (etypecase dest
+ ((or ref bind))
+ (cif (setf (if-test dest) new))
+ (cset (setf (set-value dest) new))
+ (creturn (setf (return-result dest) new))
+ (exit (setf (exit-value dest) new))
+ (basic-combination
+ (if (eq old (basic-combination-fun dest))
+ (setf (basic-combination-fun dest) new)
+ (setf (basic-combination-args dest)
+ (nsubst new old (basic-combination-args dest))))))
+
+ (flush-dest old)
+ (setf (continuation-dest new) dest))
+ (values))
+
+;;; Replace all uses of Old with uses of New, where New has an arbitary
+;;; number of uses. If New will end up with more than one use, then we must
+;;; arrange for it to start a block if it doesn't already.
+(defun substitute-continuation-uses (new old)
+ (declare (type continuation old new))
+ (unless (and (eq (continuation-kind new) :unused)
+ (eq (continuation-kind old) :inside-block))
+ (ensure-block-start new))
+
+ (do-uses (node old)
+ (delete-continuation-use node)
+ (add-continuation-use node new))
+
+ (reoptimize-continuation new)
+ (values))
+\f
+;;;; block starting/creation
+
+;;; Return the block that Continuation is the start of, making a block if
+;;; necessary. This function is called by IR1 translators which may cause a
+;;; continuation to be used more than once. Every continuation which may be
+;;; used more than once must start a block by the time that anyone does a
+;;; Use-Continuation on it.
+;;;
+;;; We also throw the block into the next/prev list for the
+;;; *current-component* so that we keep track of which blocks we have made.
+(defun continuation-starts-block (cont)
+ (declare (type continuation cont))
+ (ecase (continuation-kind cont)
+ (:unused
+ (assert (not (continuation-block cont)))
+ (let* ((head (component-head *current-component*))
+ (next (block-next head))
+ (new-block (make-block cont)))
+ (setf (block-next new-block) next)
+ (setf (block-prev new-block) head)
+ (setf (block-prev next) new-block)
+ (setf (block-next head) new-block)
+ (setf (continuation-block cont) new-block)
+ (setf (continuation-use cont) nil)
+ (setf (continuation-kind cont) :block-start)
+ new-block))
+ (:block-start
+ (continuation-block cont))))
+
+;;; Ensure that Cont is the start of a block (or deleted) so that the use
+;;; set can be freely manipulated.
+;;; -- If the continuation is :Unused or is :Inside-Block and the Cont of Last
+;;; in its block, then we make it the start of a new deleted block.
+;;; -- If the continuation is :Inside-Block inside a block, then we split the
+;;; block using Node-Ends-Block, which makes the continuation be a
+;;; :Block-Start.
+(defun ensure-block-start (cont)
+ (declare (type continuation cont))
+ (let ((kind (continuation-kind cont)))
+ (ecase kind
+ ((:deleted :block-start :deleted-block-start))
+ ((:unused :inside-block)
+ (let ((block (continuation-block cont)))
+ (cond ((or (eq kind :unused)
+ (eq (node-cont (block-last block)) cont))
+ (setf (continuation-block cont)
+ (make-block-key :start cont
+ :component nil
+ :start-uses (find-uses cont)))
+ (setf (continuation-kind cont) :deleted-block-start))
+ (t
+ (node-ends-block (continuation-use cont))))))))
+ (values))
+\f
+;;;; miscellaneous shorthand functions
+
+;;; Return the home (i.e. enclosing non-let) lambda for Node. Since the
+;;; LEXENV-LAMBDA may be deleted, we must chain up the LAMBDA-CALL-LEXENV
+;;; thread until we find a lambda that isn't deleted, and then return its home.
+(declaim (maybe-inline node-home-lambda))
+(defun node-home-lambda (node)
+ (declare (type node node))
+ (do ((fun (lexenv-lambda (node-lexenv node))
+ (lexenv-lambda (lambda-call-lexenv fun))))
+ ((not (eq (functional-kind fun) :deleted))
+ (lambda-home fun))
+ (when (eq (lambda-home fun) fun)
+ (return fun))))
+
+#!-sb-fluid (declaim (inline node-block node-tlf-number))
+(declaim (maybe-inline node-environment))
+(defun node-block (node)
+ (declare (type node node))
+ (the cblock (continuation-block (node-prev node))))
+(defun node-environment (node)
+ (declare (type node node))
+ #!-sb-fluid (declare (inline node-home-lambda))
+ (the environment (lambda-environment (node-home-lambda node))))
+
+;;; Return the enclosing cleanup for environment of the first or last node
+;;; in Block.
+(defun block-start-cleanup (block)
+ (declare (type cblock block))
+ (node-enclosing-cleanup (continuation-next (block-start block))))
+(defun block-end-cleanup (block)
+ (declare (type cblock block))
+ (node-enclosing-cleanup (block-last block)))
+
+;;; Return the non-let lambda that holds Block's code.
+(defun block-home-lambda (block)
+ (declare (type cblock block))
+ #!-sb-fluid (declare (inline node-home-lambda))
+ (node-home-lambda (block-last block)))
+
+;;; Return the IR1 environment for Block.
+(defun block-environment (block)
+ (declare (type cblock block))
+ #!-sb-fluid (declare (inline node-home-lambda))
+ (lambda-environment (node-home-lambda (block-last block))))
+
+;;; Return the Top Level Form number of path, i.e. the ordinal number of
+;;; its orignal source's top-level form in its compilation unit.
+(defun source-path-tlf-number (path)
+ (declare (list path))
+ (car (last path)))
+
+;;; Return the (reversed) list for the path in the orignal source (with the
+;;; TLF number last.)
+(defun source-path-original-source (path)
+ (declare (list path) (inline member))
+ (cddr (member 'original-source-start path :test #'eq)))
+
+;;; Return the Form Number of Path's orignal source inside the Top Level
+;;; Form that contains it. This is determined by the order that we walk the
+;;; subforms of the top level source form.
+(defun source-path-form-number (path)
+ (declare (list path) (inline member))
+ (cadr (member 'original-source-start path :test #'eq)))
+
+;;; Return a list of all the enclosing forms not in the original source that
+;;; converted to get to this form, with the immediate source for node at the
+;;; start of the list.
+(defun source-path-forms (path)
+ (subseq path 0 (position 'original-source-start path)))
+
+;;; Return the innermost source form for Node.
+(defun node-source-form (node)
+ (declare (type node node))
+ (let* ((path (node-source-path node))
+ (forms (source-path-forms path)))
+ (if forms
+ (first forms)
+ (values (find-original-source path)))))
+
+;;; Return NODE-SOURCE-FORM, T if continuation has a single use, otherwise
+;;; NIL, NIL.
+(defun continuation-source (cont)
+ (let ((use (continuation-use cont)))
+ (if use
+ (values (node-source-form use) t)
+ (values nil nil))))
+\f
+;;; Return a new LEXENV just like Default except for the specified slot
+;;; values. Values for the alist slots are NCONC'ed to the beginning of the
+;;; current value, rather than replacing it entirely.
+(defun make-lexenv (&key (default *lexenv*)
+ functions variables blocks tags type-restrictions
+ options
+ (lambda (lexenv-lambda default))
+ (cleanup (lexenv-cleanup default))
+ (cookie (lexenv-cookie default))
+ (interface-cookie (lexenv-interface-cookie default)))
+ (macrolet ((frob (var slot)
+ `(let ((old (,slot default)))
+ (if ,var
+ (nconc ,var old)
+ old))))
+ (internal-make-lexenv
+ (frob functions lexenv-functions)
+ (frob variables lexenv-variables)
+ (frob blocks lexenv-blocks)
+ (frob tags lexenv-tags)
+ (frob type-restrictions lexenv-type-restrictions)
+ lambda cleanup cookie interface-cookie
+ (frob options lexenv-options))))
+
+;;; Return a cookie that defaults any unsupplied optimize qualities in the
+;;; Interface-Cookie with the corresponding ones from the Cookie.
+(defun make-interface-cookie (lexenv)
+ (declare (type lexenv lexenv))
+ (let ((icookie (lexenv-interface-cookie lexenv))
+ (cookie (lexenv-cookie lexenv)))
+ (make-cookie
+ :speed (or (cookie-speed icookie) (cookie-speed cookie))
+ :space (or (cookie-space icookie) (cookie-space cookie))
+ :safety (or (cookie-safety icookie) (cookie-safety cookie))
+ :cspeed (or (cookie-cspeed icookie) (cookie-cspeed cookie))
+ :brevity (or (cookie-brevity icookie) (cookie-brevity cookie))
+ :debug (or (cookie-debug icookie) (cookie-debug cookie)))))
+\f
+;;;; flow/DFO/component hackery
+
+;;; Join Block1 and Block2.
+#!-sb-fluid (declaim (inline link-blocks))
+(defun link-blocks (block1 block2)
+ (declare (type cblock block1 block2))
+ (setf (block-succ block1)
+ (if (block-succ block1)
+ (%link-blocks block1 block2)
+ (list block2)))
+ (push block1 (block-pred block2))
+ (values))
+(defun %link-blocks (block1 block2)
+ (declare (type cblock block1 block2) (inline member))
+ (let ((succ1 (block-succ block1)))
+ (assert (not (member block2 succ1 :test #'eq)))
+ (cons block2 succ1)))
+
+;;; Like LINK-BLOCKS, but we separate BLOCK1 and BLOCK2. If this leaves a
+;;; successor with a single predecessor that ends in an IF, then set
+;;; BLOCK-TEST-MODIFIED so that any test constraint will now be able to be
+;;; propagated to the successor.
+(defun unlink-blocks (block1 block2)
+ (declare (type cblock block1 block2))
+ (let ((succ1 (block-succ block1)))
+ (if (eq block2 (car succ1))
+ (setf (block-succ block1) (cdr succ1))
+ (do ((succ (cdr succ1) (cdr succ))
+ (prev succ1 succ))
+ ((eq (car succ) block2)
+ (setf (cdr prev) (cdr succ)))
+ (assert succ))))
+
+ (let ((new-pred (delq block1 (block-pred block2))))
+ (setf (block-pred block2) new-pred)
+ (when (and new-pred (null (rest new-pred)))
+ (let ((pred-block (first new-pred)))
+ (when (if-p (block-last pred-block))
+ (setf (block-test-modified pred-block) t)))))
+ (values))
+
+;;; Swing the succ/pred link between Block and Old to be between Block and
+;;; New. If Block ends in an IF, then we have to fix up the
+;;; consequent/alternative blocks to point to New. We also set
+;;; BLOCK-TEST-MODIFIED so that any test constraint will be applied to the new
+;;; successor.
+(defun change-block-successor (block old new)
+ (declare (type cblock new old block) (inline member))
+ (unlink-blocks block old)
+ (let ((last (block-last block))
+ (comp (block-component block)))
+ (setf (component-reanalyze comp) t)
+ (typecase last
+ (cif
+ (setf (block-test-modified block) t)
+ (let* ((succ-left (block-succ block))
+ (new (if (and (eq new (component-tail comp))
+ succ-left)
+ (first succ-left)
+ new)))
+ (unless (member new succ-left :test #'eq)
+ (link-blocks block new))
+ (macrolet ((frob (slot)
+ `(when (eq (,slot last) old)
+ (setf (,slot last) new))))
+ (frob if-consequent)
+ (frob if-alternative))))
+ (t
+ (unless (member new (block-succ block) :test #'eq)
+ (link-blocks block new)))))
+
+ (values))
+
+;;; Unlink a block from the next/prev chain. We also null out the
+;;; Component.
+(declaim (ftype (function (cblock) (values)) remove-from-dfo))
+#!-sb-fluid (declaim (inline remove-from-dfo))
+(defun remove-from-dfo (block)
+ (let ((next (block-next block))
+ (prev (block-prev block)))
+ (setf (block-component block) nil)
+ (setf (block-next prev) next)
+ (setf (block-prev next) prev))
+ (values))
+
+;;; Add Block to the next/prev chain following After. We also set the
+;;; Component to be the same as for After.
+#!-sb-fluid (declaim (inline add-to-dfo))
+(defun add-to-dfo (block after)
+ (declare (type cblock block after))
+ (let ((next (block-next after))
+ (comp (block-component after)))
+ (assert (not (eq (component-kind comp) :deleted)))
+ (setf (block-component block) comp)
+ (setf (block-next after) block)
+ (setf (block-prev block) after)
+ (setf (block-next block) next)
+ (setf (block-prev next) block))
+ (values))
+
+;;; Set the Flag for all the blocks in Component to NIL, except for the head
+;;; and tail which are set to T.
+(declaim (ftype (function (component) (values)) clear-flags))
+(defun clear-flags (component)
+ (let ((head (component-head component))
+ (tail (component-tail component)))
+ (setf (block-flag head) t)
+ (setf (block-flag tail) t)
+ (do-blocks (block component)
+ (setf (block-flag block) nil)))
+ (values))
+
+;;; Make a component with no blocks in it. The Block-Flag is initially
+;;; true in the head and tail blocks.
+(declaim (ftype (function nil component) make-empty-component))
+(defun make-empty-component ()
+ (let* ((head (make-block-key :start nil :component nil))
+ (tail (make-block-key :start nil :component nil))
+ (res (make-component :head head :tail tail)))
+ (setf (block-flag head) t)
+ (setf (block-flag tail) t)
+ (setf (block-component head) res)
+ (setf (block-component tail) res)
+ (setf (block-next head) tail)
+ (setf (block-prev tail) head)
+ res))
+
+;;; Makes Node the Last node in its block, splitting the block if necessary.
+;;; The new block is added to the DFO immediately following Node's block.
+(defun node-ends-block (node)
+ (declare (type node node))
+ (let* ((block (node-block node))
+ (start (node-cont node))
+ (last (block-last block))
+ (last-cont (node-cont last)))
+ (unless (eq last node)
+ (assert (and (eq (continuation-kind start) :inside-block)
+ (not (block-delete-p block))))
+ (let* ((succ (block-succ block))
+ (new-block
+ (make-block-key :start start
+ :component (block-component block)
+ :start-uses (list (continuation-use start))
+ :succ succ :last last)))
+ (setf (continuation-kind start) :block-start)
+ (dolist (b succ)
+ (setf (block-pred b)
+ (cons new-block (remove block (block-pred b)))))
+ (setf (block-succ block) ())
+ (setf (block-last block) node)
+ (link-blocks block new-block)
+ (add-to-dfo new-block block)
+ (setf (component-reanalyze (block-component block)) t)
+
+ (do ((cont start (node-cont (continuation-next cont))))
+ ((eq cont last-cont)
+ (when (eq (continuation-kind last-cont) :inside-block)
+ (setf (continuation-block last-cont) new-block)))
+ (setf (continuation-block cont) new-block))
+
+ (setf (block-type-asserted block) t)
+ (setf (block-test-modified block) t))))
+
+ (values))
+\f
+;;;; deleting stuff
+
+;;; Deal with deleting the last (read) reference to a lambda-var. We
+;;; iterate over all local calls flushing the corresponding argument, allowing
+;;; the computation of the argument to be deleted. We also mark the let for
+;;; reoptimization, since it may be that we have deleted the last variable.
+;;;
+;;; The lambda-var may still have some sets, but this doesn't cause too much
+;;; difficulty, since we can efficiently implement write-only variables. We
+;;; iterate over the sets, marking their blocks for dead code flushing, since
+;;; we can delete sets whose value is unused.
+(defun delete-lambda-var (leaf)
+ (declare (type lambda-var leaf))
+ (let* ((fun (lambda-var-home leaf))
+ (n (position leaf (lambda-vars fun))))
+ (dolist (ref (leaf-refs fun))
+ (let* ((cont (node-cont ref))
+ (dest (continuation-dest cont)))
+ (when (and (combination-p dest)
+ (eq (basic-combination-fun dest) cont)
+ (eq (basic-combination-kind dest) :local))
+ (let* ((args (basic-combination-args dest))
+ (arg (elt args n)))
+ (reoptimize-continuation arg)
+ (flush-dest arg)
+ (setf (elt args n) nil))))))
+
+ (dolist (set (lambda-var-sets leaf))
+ (setf (block-flush-p (node-block set)) t))
+
+ (values))
+
+;;; Note that something interesting has happened to Var. We only deal with
+;;; LET variables, marking the corresponding initial value arg as needing to be
+;;; reoptimized.
+(defun reoptimize-lambda-var (var)
+ (declare (type lambda-var var))
+ (let ((fun (lambda-var-home var)))
+ (when (and (eq (functional-kind fun) :let)
+ (leaf-refs var))
+ (do ((args (basic-combination-args
+ (continuation-dest
+ (node-cont
+ (first (leaf-refs fun)))))
+ (cdr args))
+ (vars (lambda-vars fun) (cdr vars)))
+ ((eq (car vars) var)
+ (reoptimize-continuation (car args))))))
+ (values))
+
+;;; This function deletes functions that have no references. This need only
+;;; be called on functions that never had any references, since otherwise
+;;; DELETE-REF will handle the deletion.
+(defun delete-functional (fun)
+ (assert (and (null (leaf-refs fun))
+ (not (functional-entry-function fun))))
+ (etypecase fun
+ (optional-dispatch (delete-optional-dispatch fun))
+ (clambda (delete-lambda fun)))
+ (values))
+
+;;; Deal with deleting the last reference to a lambda. Since there is only
+;;; one way into a lambda, deleting the last reference to a lambda ensures that
+;;; there is no way to reach any of the code in it. So we just set the
+;;; Functional-Kind for Fun and its Lets to :Deleted, causing IR1 optimization
+;;; to delete blocks in that lambda.
+;;;
+;;; If the function isn't a Let, we unlink the function head and tail from
+;;; the component head and tail to indicate that the code is unreachable. We
+;;; also delete the function from Component-Lambdas (it won't be there before
+;;; local call analysis, but no matter.) If the lambda was never referenced,
+;;; we give a note.
+;;;
+;;; If the lambda is an XEP, then we null out the Entry-Function in its
+;;; Entry-Function so that people will know that it is not an entry point
+;;; anymore.
+(defun delete-lambda (leaf)
+ (declare (type clambda leaf))
+ (let ((kind (functional-kind leaf))
+ (bind (lambda-bind leaf)))
+ (assert (not (member kind '(:deleted :optional :top-level))))
+ (setf (functional-kind leaf) :deleted)
+ (setf (lambda-bind leaf) nil)
+ (dolist (let (lambda-lets leaf))
+ (setf (lambda-bind let) nil)
+ (setf (functional-kind let) :deleted))
+
+ (if (member kind '(:let :mv-let :assignment))
+ (let ((home (lambda-home leaf)))
+ (setf (lambda-lets home) (delete leaf (lambda-lets home))))
+ (let* ((bind-block (node-block bind))
+ (component (block-component bind-block))
+ (return (lambda-return leaf)))
+ (assert (null (leaf-refs leaf)))
+ (unless (leaf-ever-used leaf)
+ (let ((*compiler-error-context* bind))
+ (compiler-note "deleting unused function~:[.~;~:*~% ~S~]"
+ (leaf-name leaf))))
+ (unlink-blocks (component-head component) bind-block)
+ (when return
+ (unlink-blocks (node-block return) (component-tail component)))
+ (setf (component-reanalyze component) t)
+ (let ((tails (lambda-tail-set leaf)))
+ (setf (tail-set-functions tails)
+ (delete leaf (tail-set-functions tails)))
+ (setf (lambda-tail-set leaf) nil))
+ (setf (component-lambdas component)
+ (delete leaf (component-lambdas component)))))
+
+ (when (eq kind :external)
+ (let ((fun (functional-entry-function leaf)))
+ (setf (functional-entry-function fun) nil)
+ (when (optional-dispatch-p fun)
+ (delete-optional-dispatch fun)))))
+
+ (values))
+
+;;; Deal with deleting the last reference to an Optional-Dispatch. We have
+;;; to be a bit more careful than with lambdas, since Delete-Ref is used both
+;;; before and after local call analysis. Afterward, all references to
+;;; still-existing optional-dispatches have been moved to the XEP, leaving it
+;;; with no references at all. So we look at the XEP to see whether an
+;;; optional-dispatch is still really being used. But before local call
+;;; analysis, there are no XEPs, and all references are direct.
+;;;
+;;; When we do delete the optional-dispatch, we grovel all of its
+;;; entry-points, making them be normal lambdas, and then deleting the ones
+;;; with no references. This deletes any e-p lambdas that were either never
+;;; referenced, or couldn't be deleted when the last deference was deleted (due
+;;; to their :OPTIONAL kind.)
+;;;
+;;; Note that the last optional ep may alias the main entry, so when we process
+;;; the main entry, its kind may have been changed to NIL or even converted to
+;;; a let.
+(defun delete-optional-dispatch (leaf)
+ (declare (type optional-dispatch leaf))
+ (let ((entry (functional-entry-function leaf)))
+ (unless (and entry (leaf-refs entry))
+ (assert (or (not entry) (eq (functional-kind entry) :deleted)))
+ (setf (functional-kind leaf) :deleted)
+
+ (flet ((frob (fun)
+ (unless (eq (functional-kind fun) :deleted)
+ (assert (eq (functional-kind fun) :optional))
+ (setf (functional-kind fun) nil)
+ (let ((refs (leaf-refs fun)))
+ (cond ((null refs)
+ (delete-lambda fun))
+ ((null (rest refs))
+ (or (maybe-let-convert fun)
+ (maybe-convert-to-assignment fun)))
+ (t
+ (maybe-convert-to-assignment fun)))))))
+
+ (dolist (ep (optional-dispatch-entry-points leaf))
+ (frob ep))
+ (when (optional-dispatch-more-entry leaf)
+ (frob (optional-dispatch-more-entry leaf)))
+ (let ((main (optional-dispatch-main-entry leaf)))
+ (when (eq (functional-kind main) :optional)
+ (frob main))))))
+
+ (values))
+
+;;; Do stuff to delete the semantic attachments of a Ref node. When this
+;;; leaves zero or one reference, we do a type dispatch off of the leaf to
+;;; determine if a special action is appropriate.
+(defun delete-ref (ref)
+ (declare (type ref ref))
+ (let* ((leaf (ref-leaf ref))
+ (refs (delete ref (leaf-refs leaf))))
+ (setf (leaf-refs leaf) refs)
+
+ (cond ((null refs)
+ (typecase leaf
+ (lambda-var (delete-lambda-var leaf))
+ (clambda
+ (ecase (functional-kind leaf)
+ ((nil :let :mv-let :assignment :escape :cleanup)
+ (assert (not (functional-entry-function leaf)))
+ (delete-lambda leaf))
+ (:external
+ (delete-lambda leaf))
+ ((:deleted :optional))))
+ (optional-dispatch
+ (unless (eq (functional-kind leaf) :deleted)
+ (delete-optional-dispatch leaf)))))
+ ((null (rest refs))
+ (typecase leaf
+ (clambda (or (maybe-let-convert leaf)
+ (maybe-convert-to-assignment leaf)))
+ (lambda-var (reoptimize-lambda-var leaf))))
+ (t
+ (typecase leaf
+ (clambda (maybe-convert-to-assignment leaf))))))
+
+ (values))
+
+;;; This function is called by people who delete nodes; it provides a way to
+;;; indicate that the value of a continuation is no longer used. We null out
+;;; the Continuation-Dest, set Flush-P in the blocks containing uses of Cont
+;;; and set Component-Reoptimize. If the Prev of the use is deleted, then we
+;;; blow off reoptimization.
+;;;
+;;; If the continuation is :Deleted, then we don't do anything, since all
+;;; semantics have already been flushed. :Deleted-Block-Start start
+;;; continuations are treated just like :Block-Start; it is possible that the
+;;; continuation may be given a new dest (e.g. by SUBSTITUTE-CONTINUATION), so
+;;; we don't want to delete it.
+(defun flush-dest (cont)
+ (declare (type continuation cont))
+
+ (unless (eq (continuation-kind cont) :deleted)
+ (assert (continuation-dest cont))
+ (setf (continuation-dest cont) nil)
+ (do-uses (use cont)
+ (let ((prev (node-prev use)))
+ (unless (eq (continuation-kind prev) :deleted)
+ (let ((block (continuation-block prev)))
+ (setf (component-reoptimize (block-component block)) t)
+ (setf (block-attributep (block-flags block) flush-p type-asserted)
+ t))))))
+
+ (setf (continuation-%type-check cont) nil)
+
+ (values))
+
+;;; Do a graph walk backward from Block, marking all predecessor blocks with
+;;; the DELETE-P flag.
+(defun mark-for-deletion (block)
+ (declare (type cblock block))
+ (unless (block-delete-p block)
+ (setf (block-delete-p block) t)
+ (setf (component-reanalyze (block-component block)) t)
+ (dolist (pred (block-pred block))
+ (mark-for-deletion pred)))
+ (values))
+
+;;; Delete Cont, eliminating both control and value semantics. We set
+;;; FLUSH-P and COMPONENT-REOPTIMIZE similarly to in FLUSH-DEST. Here we must
+;;; get the component from the use block, since the continuation may be a
+;;; :DELETED-BLOCK-START.
+;;;
+;;; If Cont has DEST, then it must be the case that the DEST is unreachable,
+;;; since we can't compute the value desired. In this case, we call
+;;; MARK-FOR-DELETION to cause the DEST block and its predecessors to tell
+;;; people to ignore them, and to cause them to be deleted eventually.
+(defun delete-continuation (cont)
+ (declare (type continuation cont))
+ (assert (not (eq (continuation-kind cont) :deleted)))
+
+ (do-uses (use cont)
+ (let ((prev (node-prev use)))
+ (unless (eq (continuation-kind prev) :deleted)
+ (let ((block (continuation-block prev)))
+ (setf (block-attributep (block-flags block) flush-p type-asserted) t)
+ (setf (component-reoptimize (block-component block)) t)))))
+
+ (let ((dest (continuation-dest cont)))
+ (when dest
+ (let ((prev (node-prev dest)))
+ (when (and prev
+ (not (eq (continuation-kind prev) :deleted)))
+ (let ((block (continuation-block prev)))
+ (unless (block-delete-p block)
+ (mark-for-deletion block)))))))
+
+ (setf (continuation-kind cont) :deleted)
+ (setf (continuation-dest cont) nil)
+ (setf (continuation-next cont) nil)
+ (setf (continuation-asserted-type cont) *empty-type*)
+ (setf (continuation-%derived-type cont) *empty-type*)
+ (setf (continuation-use cont) nil)
+ (setf (continuation-block cont) nil)
+ (setf (continuation-reoptimize cont) nil)
+ (setf (continuation-%type-check cont) nil)
+ (setf (continuation-info cont) nil)
+
+ (values))
+
+;;; This function does what is necessary to eliminate the code in it from
+;;; the IR1 representation. This involves unlinking it from its predecessors
+;;; and successors and deleting various node-specific semantic information.
+;;;
+;;; We mark the Start as has having no next and remove the last node from
+;;; its Cont's uses. We also flush the DEST for all continuations whose values
+;;; are received by nodes in the block.
+(defun delete-block (block)
+ (declare (type cblock block))
+ (assert (block-component block) () "Block is already deleted.")
+ (note-block-deletion block)
+ (setf (block-delete-p block) t)
+
+ (let* ((last (block-last block))
+ (cont (node-cont last)))
+ (delete-continuation-use last)
+ (if (eq (continuation-kind cont) :unused)
+ (delete-continuation cont)
+ (reoptimize-continuation cont)))
+
+ (dolist (b (block-pred block))
+ (unlink-blocks b block))
+ (dolist (b (block-succ block))
+ (unlink-blocks block b))
+
+ (do-nodes (node cont block)
+ (typecase node
+ (ref (delete-ref node))
+ (cif
+ (flush-dest (if-test node)))
+ ;; The next two cases serve to maintain the invariant that a LET always
+ ;; has a well-formed COMBINATION, REF and BIND. We delete the lambda
+ ;; whenever we delete any of these, but we must be careful that this LET
+ ;; has not already been partially deleted.
+ (basic-combination
+ (when (and (eq (basic-combination-kind node) :local)
+ ;; Guards COMBINATION-LAMBDA agains the REF being deleted.
+ (continuation-use (basic-combination-fun node)))
+ (let ((fun (combination-lambda node)))
+ ;; If our REF was the 2'nd to last ref, and has been deleted, then
+ ;; Fun may be a LET for some other combination.
+ (when (and (member (functional-kind fun) '(:let :mv-let))
+ (eq (let-combination fun) node))
+ (delete-lambda fun))))
+ (flush-dest (basic-combination-fun node))
+ (dolist (arg (basic-combination-args node))
+ (when arg (flush-dest arg))))
+ (bind
+ (let ((lambda (bind-lambda node)))
+ (unless (eq (functional-kind lambda) :deleted)
+ (assert (member (functional-kind lambda)
+ '(:let :mv-let :assignment)))
+ (delete-lambda lambda))))
+ (exit
+ (let ((value (exit-value node))
+ (entry (exit-entry node)))
+ (when value
+ (flush-dest value))
+ (when entry
+ (setf (entry-exits entry)
+ (delete node (entry-exits entry))))))
+ (creturn
+ (flush-dest (return-result node))
+ (delete-return node))
+ (cset
+ (flush-dest (set-value node))
+ (let ((var (set-var node)))
+ (setf (basic-var-sets var)
+ (delete node (basic-var-sets var))))))
+
+ (delete-continuation (node-prev node)))
+
+ (remove-from-dfo block)
+ (values))
+
+;;; Do stuff to indicate that the return node Node is being deleted. We set
+;;; the RETURN to NIL.
+(defun delete-return (node)
+ (declare (type creturn node))
+ (let ((fun (return-lambda node)))
+ (assert (lambda-return fun))
+ (setf (lambda-return fun) nil))
+ (values))
+
+;;; If any of the Vars in fun were never referenced and was not declared
+;;; IGNORE, then complain.
+(defun note-unreferenced-vars (fun)
+ (declare (type clambda fun))
+ (dolist (var (lambda-vars fun))
+ (unless (or (leaf-ever-used var)
+ (lambda-var-ignorep var))
+ (let ((*compiler-error-context* (lambda-bind fun)))
+ (unless (policy *compiler-error-context* (= brevity 3))
+ ;; ANSI section "3.2.5 Exceptional Situations in the Compiler"
+ ;; requires this to be a STYLE-WARNING.
+ (compiler-style-warning "The variable ~S is defined but never used."
+ (leaf-name var)))
+ (setf (leaf-ever-used var) t))))
+ (values))
+
+(defvar *deletion-ignored-objects* '(t nil))
+
+;;; Return true if we can find Obj in Form, NIL otherwise. We bound our
+;;; recursion so that we don't get lost in circular structures. We ignore the
+;;; car of forms if they are a symbol (to prevent confusing function
+;;; referencess with variables), and we also ignore anything inside ' or #'.
+(defun present-in-form (obj form depth)
+ (declare (type (integer 0 20) depth))
+ (cond ((= depth 20) nil)
+ ((eq obj form) t)
+ ((atom form) nil)
+ (t
+ (let ((first (car form))
+ (depth (1+ depth)))
+ (if (member first '(quote function))
+ nil
+ (or (and (not (symbolp first))
+ (present-in-form obj first depth))
+ (do ((l (cdr form) (cdr l))
+ (n 0 (1+ n)))
+ ((or (atom l) (> n 100))
+ nil)
+ (declare (fixnum n))
+ (when (present-in-form obj (car l) depth)
+ (return t)))))))))
+
+;;; This function is called on a block immediately before we delete it. We
+;;; check to see whether any of the code about to die appeared in the original
+;;; source, and emit a note if so.
+;;;
+;;; If the block was in a lambda is now deleted, then we ignore the whole
+;;; block, since this case is picked off in DELETE-LAMBDA. We also ignore
+;;; the deletion of CRETURN nodes, since it is somewhat reasonable for a
+;;; function to not return, and there is a different note for that case anyway.
+;;;
+;;; If the actual source is an atom, then we use a bunch of heuristics to
+;;; guess whether this reference really appeared in the original source:
+;;; -- If a symbol, it must be interned and not a keyword.
+;;; -- It must not be an easily introduced constant (T or NIL, a fixnum or a
+;;; character.)
+;;; -- The atom must be "present" in the original source form, and present in
+;;; all intervening actual source forms.
+(defun note-block-deletion (block)
+ (let ((home (block-home-lambda block)))
+ (unless (eq (functional-kind home) :deleted)
+ (do-nodes (node cont block)
+ (let* ((path (node-source-path node))
+ (first (first path)))
+ (when (or (eq first 'original-source-start)
+ (and (atom first)
+ (or (not (symbolp first))
+ (let ((pkg (symbol-package first)))
+ (and pkg
+ (not (eq pkg (symbol-package :end))))))
+ (not (member first *deletion-ignored-objects*))
+ (not (typep first '(or fixnum character)))
+ (every #'(lambda (x)
+ (present-in-form first x 0))
+ (source-path-forms path))
+ (present-in-form first (find-original-source path)
+ 0)))
+ (unless (return-p node)
+ (let ((*compiler-error-context* node))
+ (compiler-note "deleting unreachable code")))
+ (return))))))
+ (values))
+
+;;; Delete a node from a block, deleting the block if there are no nodes
+;;; left. We remove the node from the uses of its CONT, but we don't deal with
+;;; cleaning up any type-specific semantic attachments. If the CONT is :UNUSED
+;;; after deleting this use, then we delete CONT. (Note :UNUSED is not the
+;;; same as no uses. A continuation will only become :UNUSED if it was
+;;; :INSIDE-BLOCK before.)
+;;;
+;;; If the node is the last node, there must be exactly one successor. We
+;;; link all of our precedessors to the successor and unlink the block. In
+;;; this case, we return T, otherwise NIL. If no nodes are left, and the block
+;;; is a successor of itself, then we replace the only node with a degenerate
+;;; exit node. This provides a way to represent the bodyless infinite loop,
+;;; given the prohibition on empty blocks in IR1.
+(defun unlink-node (node)
+ (declare (type node node))
+ (let* ((cont (node-cont node))
+ (next (continuation-next cont))
+ (prev (node-prev node))
+ (block (continuation-block prev))
+ (prev-kind (continuation-kind prev))
+ (last (block-last block)))
+
+ (unless (eq (continuation-kind cont) :deleted)
+ (delete-continuation-use node)
+ (when (eq (continuation-kind cont) :unused)
+ (assert (not (continuation-dest cont)))
+ (delete-continuation cont)))
+
+ (setf (block-type-asserted block) t)
+ (setf (block-test-modified block) t)
+
+ (cond ((or (eq prev-kind :inside-block)
+ (and (eq prev-kind :block-start)
+ (not (eq node last))))
+ (cond ((eq node last)
+ (setf (block-last block) (continuation-use prev))
+ (setf (continuation-next prev) nil))
+ (t
+ (setf (continuation-next prev) next)
+ (setf (node-prev next) prev)))
+ (setf (node-prev node) nil)
+ nil)
+ (t
+ (assert (eq prev-kind :block-start))
+ (assert (eq node last))
+ (let* ((succ (block-succ block))
+ (next (first succ)))
+ (assert (and succ (null (cdr succ))))
+ (cond
+ ((member block succ)
+ (with-ir1-environment node
+ (let ((exit (make-exit))
+ (dummy (make-continuation)))
+ (setf (continuation-next prev) nil)
+ (prev-link exit prev)
+ (add-continuation-use exit dummy)
+ (setf (block-last block) exit)))
+ (setf (node-prev node) nil)
+ nil)
+ (t
+ (assert (eq (block-start-cleanup block)
+ (block-end-cleanup block)))
+ (unlink-blocks block next)
+ (dolist (pred (block-pred block))
+ (change-block-successor pred block next))
+ (remove-from-dfo block)
+ (cond ((continuation-dest prev)
+ (setf (continuation-next prev) nil)
+ (setf (continuation-kind prev) :deleted-block-start))
+ (t
+ (delete-continuation prev)))
+ (setf (node-prev node) nil)
+ t)))))))
+
+;;; Return true if NODE has been deleted, false if it is still a valid part
+;;; of IR1.
+(defun node-deleted (node)
+ (declare (type node node))
+ (let ((prev (node-prev node)))
+ (not (and prev
+ (not (eq (continuation-kind prev) :deleted))
+ (let ((block (continuation-block prev)))
+ (and (block-component block)
+ (not (block-delete-p block))))))))
+
+;;; Delete all the blocks and functions in Component. We scan first marking
+;;; the blocks as delete-p to prevent weird stuff from being triggered by
+;;; deletion.
+(defun delete-component (component)
+ (declare (type component component))
+ (assert (null (component-new-functions component)))
+ (setf (component-kind component) :deleted)
+ (do-blocks (block component)
+ (setf (block-delete-p block) t))
+ (dolist (fun (component-lambdas component))
+ (setf (functional-kind fun) nil)
+ (setf (functional-entry-function fun) nil)
+ (setf (leaf-refs fun) nil)
+ (delete-functional fun))
+ (do-blocks (block component)
+ (delete-block block))
+ (values))
+
+;;; Convert code of the form
+;;; (FOO ... (FUN ...) ...)
+;;; to
+;;; (FOO ... ... ...).
+;;; In other words, replace the function combination FUN by its
+;;; arguments. If there are any problems with doing this, use GIVE-UP
+;;; to blow out of whatever transform called this. Note, as the number
+;;; of arguments changes, the transform must be prepared to return a
+;;; lambda with a new lambda-list with the correct number of
+;;; arguments.
+(defun extract-function-args (cont fun num-args)
+ #!+sb-doc
+ "If CONT is a call to FUN with NUM-ARGS args, change those arguments
+ to feed directly to the continuation-dest of CONT, which must be
+ a combination."
+ (declare (type continuation cont)
+ (type symbol fun)
+ (type index num-args))
+ (let ((outside (continuation-dest cont))
+ (inside (continuation-use cont)))
+ (assert (combination-p outside))
+ (unless (combination-p inside)
+ (give-up-ir1-transform))
+ (let ((inside-fun (combination-fun inside)))
+ (unless (eq (continuation-function-name inside-fun) fun)
+ (give-up-ir1-transform))
+ (let ((inside-args (combination-args inside)))
+ (unless (= (length inside-args) num-args)
+ (give-up-ir1-transform))
+ (let* ((outside-args (combination-args outside))
+ (arg-position (position cont outside-args))
+ (before-args (subseq outside-args 0 arg-position))
+ (after-args (subseq outside-args (1+ arg-position))))
+ (dolist (arg inside-args)
+ (setf (continuation-dest arg) outside))
+ (setf (combination-args inside) nil)
+ (setf (combination-args outside)
+ (append before-args inside-args after-args))
+ (change-ref-leaf (continuation-use inside-fun)
+ (find-free-function 'list "???"))
+ (setf (combination-kind inside) :full)
+ (setf (node-derived-type inside) *wild-type*)
+ (flush-dest cont)
+ (setf (continuation-asserted-type cont) *wild-type*)
+ (values))))))
+\f
+;;;; leaf hackery
+
+;;; Change the Leaf that a Ref refers to.
+(defun change-ref-leaf (ref leaf)
+ (declare (type ref ref) (type leaf leaf))
+ (unless (eq (ref-leaf ref) leaf)
+ (push ref (leaf-refs leaf))
+ (delete-ref ref)
+ (setf (ref-leaf ref) leaf)
+ (let ((ltype (leaf-type leaf)))
+ (if (function-type-p ltype)
+ (setf (node-derived-type ref) ltype)
+ (derive-node-type ref ltype)))
+ (reoptimize-continuation (node-cont ref)))
+ (values))
+
+;;; Change all Refs for Old-Leaf to New-Leaf.
+(defun substitute-leaf (new-leaf old-leaf)
+ (declare (type leaf new-leaf old-leaf))
+ (dolist (ref (leaf-refs old-leaf))
+ (change-ref-leaf ref new-leaf))
+ (values))
+
+;;; Like SUBSITIUTE-LEAF, only there is a predicate on the Ref to tell
+;;; whether to substitute.
+(defun substitute-leaf-if (test new-leaf old-leaf)
+ (declare (type leaf new-leaf old-leaf) (type function test))
+ (dolist (ref (leaf-refs old-leaf))
+ (when (funcall test ref)
+ (change-ref-leaf ref new-leaf)))
+ (values))
+
+;;; Return a LEAF which represents the specified constant object. If the
+;;; object is not in *CONSTANTS*, then we create a new constant LEAF and
+;;; enter it.
+#!-sb-fluid (declaim (maybe-inline find-constant))
+(defun find-constant (object)
+ (if (typep object '(or symbol number character instance))
+ (or (gethash object *constants*)
+ (setf (gethash object *constants*)
+ (make-constant :value object
+ :name nil
+ :type (ctype-of object)
+ :where-from :defined)))
+ (make-constant :value object
+ :name nil
+ :type (ctype-of object)
+ :where-from :defined)))
+\f
+;;; If there is a non-local exit noted in Entry's environment that exits to
+;;; Cont in that entry, then return it, otherwise return NIL.
+(defun find-nlx-info (entry cont)
+ (declare (type entry entry) (type continuation cont))
+ (let ((entry-cleanup (entry-cleanup entry)))
+ (dolist (nlx (environment-nlx-info (node-environment entry)) nil)
+ (when (and (eq (nlx-info-continuation nlx) cont)
+ (eq (nlx-info-cleanup nlx) entry-cleanup))
+ (return nlx)))))
+\f
+;;;; functional hackery
+
+;;; If Functional is a Lambda, just return it; if it is an
+;;; optional-dispatch, return the main-entry.
+(declaim (ftype (function (functional) clambda) main-entry))
+(defun main-entry (functional)
+ (etypecase functional
+ (clambda functional)
+ (optional-dispatch
+ (optional-dispatch-main-entry functional))))
+
+;;; Returns true if Functional is a thing that can be treated like
+;;; MV-Bind when it appears in an MV-Call. All fixed arguments must be
+;;; optional with null default and no supplied-p. There must be a rest
+;;; arg with no references.
+(declaim (ftype (function (functional) boolean) looks-like-an-mv-bind))
+(defun looks-like-an-mv-bind (functional)
+ (and (optional-dispatch-p functional)
+ (do ((arg (optional-dispatch-arglist functional) (cdr arg)))
+ ((null arg) nil)
+ (let ((info (lambda-var-arg-info (car arg))))
+ (unless info (return nil))
+ (case (arg-info-kind info)
+ (:optional
+ (when (or (arg-info-supplied-p info) (arg-info-default info))
+ (return nil)))
+ (:rest
+ (return (and (null (cdr arg)) (null (leaf-refs (car arg))))))
+ (t
+ (return nil)))))))
+
+;;; Return true if function is an XEP. This is true of normal XEPs
+;;; (:External kind) and top-level lambdas (:Top-Level kind.)
+#!-sb-fluid (declaim (inline external-entry-point-p))
+(defun external-entry-point-p (fun)
+ (declare (type functional fun))
+ (not (null (member (functional-kind fun) '(:external :top-level)))))
+
+;;; If Cont's only use is a non-notinline global function reference, then
+;;; return the referenced symbol, otherwise NIL. If Notinline-OK is true, then
+;;; we don't care if the leaf is notinline.
+(defun continuation-function-name (cont &optional notinline-ok)
+ (declare (type continuation cont))
+ (let ((use (continuation-use cont)))
+ (if (ref-p use)
+ (let ((leaf (ref-leaf use)))
+ (if (and (global-var-p leaf)
+ (eq (global-var-kind leaf) :global-function)
+ (or (not (defined-function-p leaf))
+ (not (eq (defined-function-inlinep leaf) :notinline))
+ notinline-ok))
+ (leaf-name leaf)
+ nil))
+ nil)))
+
+;;; Return the COMBINATION node that is the call to the let Fun.
+(defun let-combination (fun)
+ (declare (type clambda fun))
+ (assert (member (functional-kind fun) '(:let :mv-let)))
+ (continuation-dest (node-cont (first (leaf-refs fun)))))
+
+;;; Return the initial value continuation for a let variable or NIL if none.
+(defun let-var-initial-value (var)
+ (declare (type lambda-var var))
+ (let ((fun (lambda-var-home var)))
+ (elt (combination-args (let-combination fun))
+ (position-or-lose var (lambda-vars fun)))))
+
+;;; Return the LAMBDA that is called by the local Call.
+#!-sb-fluid (declaim (inline combination-lambda))
+(defun combination-lambda (call)
+ (declare (type basic-combination call))
+ (assert (eq (basic-combination-kind call) :local))
+ (ref-leaf (continuation-use (basic-combination-fun call))))
+
+(defvar *inline-expansion-limit* 200
+ #!+sb-doc
+ "An upper limit on the number of inline function calls that will be expanded
+ in any given code object (single function or block compilation.)")
+
+;;; Check whether Node's component has exceeded its inline expansion
+;;; limit, and warn if so, returning NIL.
+(defun inline-expansion-ok (node)
+ (let ((expanded (incf (component-inline-expansions
+ (block-component
+ (node-block node))))))
+ (cond ((> expanded *inline-expansion-limit*) nil)
+ ((= expanded *inline-expansion-limit*)
+ (let ((*compiler-error-context* node))
+ (compiler-note "*INLINE-EXPANSION-LIMIT* (~D) was exceeded, ~
+ probably trying to~% ~
+ inline a recursive function."
+ *inline-expansion-limit*))
+ nil)
+ (t t))))
+\f
+;;;; compiler error context determination
+
+(declaim (special *current-path*))
+
+;;; We bind print level and length when printing out messages so that we don't
+;;; dump huge amounts of garbage.
+(declaim (type (or unsigned-byte null)
+ *compiler-error-print-level*
+ *compiler-error-print-length*
+ *compiler-error-print-lines*))
+(defvar *compiler-error-print-level* 3
+ #!+sb-doc
+ "The value for *PRINT-LEVEL* when printing compiler error messages.")
+(defvar *compiler-error-print-length* 5
+ #!+sb-doc
+ "The value for *PRINT-LENGTH* when printing compiler error messages.")
+(defvar *compiler-error-print-lines* 5
+ #!+sb-doc
+ "The value for *PRINT-LINES* when printing compiler error messages.")
+
+(defvar *enclosing-source-cutoff* 1
+ #!+sb-doc
+ "The maximum number of enclosing non-original source forms (i.e. from
+ macroexpansion) that we print in full. For additional enclosing forms, we
+ print only the CAR.")
+(declaim (type unsigned-byte *enclosing-source-cutoff*))
+
+;;; We separate the determination of compiler error contexts from the actual
+;;; signalling of those errors by objectifying the error context. This allows
+;;; postponement of the determination of how (and if) to signal the error.
+;;;
+;;; We take care not to reference any of the IR1 so that pending potential
+;;; error messages won't prevent the IR1 from being GC'd. To this end, we
+;;; convert source forms to strings so that source forms that contain IR1
+;;; references (e.g. %DEFUN) don't hold onto the IR.
+(defstruct (compiler-error-context
+ #-no-ansi-print-object
+ (:print-object (lambda (x stream)
+ (print-unreadable-object (x stream :type t)))))
+ ;; A list of the stringified CARs of the enclosing non-original source forms
+ ;; exceeding the *enclosing-source-cutoff*.
+ (enclosing-source nil :type list)
+ ;; A list of stringified enclosing non-original source forms.
+ (source nil :type list)
+ ;; The stringified form in the original source that expanded into Source.
+ (original-source (required-argument) :type simple-string)
+ ;; A list of prefixes of "interesting" forms that enclose original-source.
+ (context nil :type list)
+ ;; The FILE-INFO-NAME for the relevant FILE-INFO.
+ (file-name (required-argument)
+ :type (or pathname (member :lisp :stream)))
+ ;; The file position at which the top-level form starts, if applicable.
+ (file-position nil :type (or index null))
+ ;; The original source part of the source path.
+ (original-source-path nil :type list))
+
+;;; If true, this is the node which is used as context in compiler warning
+;;; messages.
+(declaim (type (or null compiler-error-context node) *compiler-error-context*))
+(defvar *compiler-error-context* nil)
+
+;;; a hashtable mapping macro names to source context parsers. Each parser
+;;; function returns the source-context list for that form.
+(defvar *source-context-methods* (make-hash-table))
+
+;;; documentation originally from cmu-user.tex:
+;;; This macro defines how to extract an abbreviated source context from
+;;; the \var{name}d form when it appears in the compiler input.
+;;; \var{lambda-list} is a \code{defmacro} style lambda-list used to
+;;; parse the arguments. The \var{body} should return a list of
+;;; subforms that can be printed on about one line. There are
+;;; predefined methods for \code{defstruct}, \code{defmethod}, etc. If
+;;; no method is defined, then the first two subforms are returned.
+;;; Note that this facility implicitly determines the string name
+;;; associated with anonymous functions.
+;;; So even though SBCL itself only uses this macro within this file, it's a
+;;; reasonable thing to put in SB-EXT in case some dedicated user wants to do
+;;; some heavy tweaking to make SBCL give more informative output about his
+;;; code.
+(defmacro def-source-context (name lambda-list &body body)
+ #!+sb-doc
+ "DEF-SOURCE-CONTEXT Name Lambda-List Form*
+ This macro defines how to extract an abbreviated source context from the
+ Named form when it appears in the compiler input. Lambda-List is a DEFMACRO
+ style lambda-list used to parse the arguments. The Body should return a
+ list of subforms suitable for a \"~{~S ~}\" format string."
+ (let ((n-whole (gensym)))
+ `(setf (gethash ',name *source-context-methods*)
+ #'(lambda (,n-whole)
+ (destructuring-bind ,lambda-list ,n-whole ,@body)))))
+
+(def-source-context defstruct (name-or-options &rest slots)
+ (declare (ignore slots))
+ `(defstruct ,(if (consp name-or-options)
+ (car name-or-options)
+ name-or-options)))
+
+(def-source-context function (thing)
+ (if (and (consp thing) (eq (first thing) 'lambda) (consp (rest thing)))
+ `(lambda ,(second thing))
+ `(function ,thing)))
+
+;;; Return the first two elements of FORM if FORM is a list. Take the
+;;; CAR of the second form if appropriate.
+(defun source-form-context (form)
+ (cond ((atom form) nil)
+ ((>= (length form) 2)
+ (funcall (gethash (first form) *source-context-methods*
+ #'(lambda (x)
+ (declare (ignore x))
+ (list (first form) (second form))))
+ (rest form)))
+ (t
+ form)))
+
+;;; Given a source path, return the original source form and a description
+;;; of the interesting aspects of the context in which it appeared. The
+;;; context is a list of lists, one sublist per context form. The sublist is a
+;;; list of some of the initial subforms of the context form.
+;;;
+;;; For now, we use the first two subforms of each interesting form. A form is
+;;; interesting if the first element is a symbol beginning with "DEF" and it is
+;;; not the source form. If there is no DEF-mumble, then we use the outermost
+;;; containing form. If the second subform is a list, then in some cases we
+;;; return the car of that form rather than the whole form (i.e. don't show
+;;; defstruct options, etc.)
+(defun find-original-source (path)
+ (declare (list path))
+ (let* ((rpath (reverse (source-path-original-source path)))
+ (tlf (first rpath))
+ (root (find-source-root tlf *source-info*)))
+ (collect ((context))
+ (let ((form root)
+ (current (rest rpath)))
+ (loop
+ (when (atom form)
+ (assert (null current))
+ (return))
+ (let ((head (first form)))
+ (when (symbolp head)
+ (let ((name (symbol-name head)))
+ (when (and (>= (length name) 3) (string= name "DEF" :end1 3))
+ (context (source-form-context form))))))
+ (when (null current) (return))
+ (setq form (nth (pop current) form)))
+
+ (cond ((context)
+ (values form (context)))
+ ((and path root)
+ (let ((c (source-form-context root)))
+ (values form (if c (list c) nil))))
+ (t
+ (values '(unable to locate source)
+ '((some strange place)))))))))
+
+;;; Convert a source form to a string, formatted suitably for use in
+;;; compiler warnings.
+(defun stringify-form (form &optional (pretty t))
+ (let ((*print-level* *compiler-error-print-level*)
+ (*print-length* *compiler-error-print-length*)
+ (*print-lines* *compiler-error-print-lines*)
+ (*print-pretty* pretty))
+ (if pretty
+ (format nil " ~S~%" form)
+ (prin1-to-string form))))
+
+;;; Return a COMPILER-ERROR-CONTEXT structure describing the current error
+;;; context, or NIL if we can't figure anything out. ARGS is a list of things
+;;; that are going to be printed out in the error message, and can thus be
+;;; blown off when they appear in the source context.
+(defun find-error-context (args)
+ (let ((context *compiler-error-context*))
+ (if (compiler-error-context-p context)
+ context
+ (let ((path (or *current-path*
+ (if context
+ (node-source-path context)
+ nil))))
+ (when (and *source-info* path)
+ (multiple-value-bind (form src-context) (find-original-source path)
+ (collect ((full nil cons)
+ (short nil cons))
+ (let ((forms (source-path-forms path))
+ (n 0))
+ (dolist (src (if (member (first forms) args)
+ (rest forms)
+ forms))
+ (if (>= n *enclosing-source-cutoff*)
+ (short (stringify-form (if (consp src)
+ (car src)
+ src)
+ nil))
+ (full (stringify-form src)))
+ (incf n)))
+
+ (let* ((tlf (source-path-tlf-number path))
+ (file (find-file-info tlf *source-info*)))
+ (make-compiler-error-context
+ :enclosing-source (short)
+ :source (full)
+ :original-source (stringify-form form)
+ :context src-context
+ :file-name (file-info-name file)
+ :file-position
+ (multiple-value-bind (ignore pos)
+ (find-source-root tlf *source-info*)
+ (declare (ignore ignore))
+ pos)
+ :original-source-path
+ (source-path-original-source path))))))))))
+\f
+;;;; printing error messages
+
+;;; We save the context information that we printed out most recently so that
+;;; we don't print it out redundantly.
+
+;;; The last COMPILER-ERROR-CONTEXT that we printed.
+(defvar *last-error-context* nil)
+(declaim (type (or compiler-error-context null) *last-error-context*))
+
+;;; The format string and args for the last error we printed.
+(defvar *last-format-string* nil)
+(defvar *last-format-args* nil)
+(declaim (type (or string null) *last-format-string*))
+(declaim (type list *last-format-args*))
+
+;;; The number of times that the last error message has been emitted, so that
+;;; we can compress duplicate error messages.
+(defvar *last-message-count* 0)
+(declaim (type index *last-message-count*))
+
+;;; If the last message was given more than once, then print out an
+;;; indication of how many times it was repeated. We reset the message count
+;;; when we are done.
+(defun note-message-repeats (&optional (terpri t))
+ (cond ((= *last-message-count* 1)
+ (when terpri (terpri *error-output*)))
+ ((> *last-message-count* 1)
+ (format *error-output* "[Last message occurs ~D times.]~2%"
+ *last-message-count*)))
+ (setq *last-message-count* 0))
+
+;;; Print out the message, with appropriate context if we can find it. If
+;;; If the context is different from the context of the last message we
+;;; printed, then we print the context. If the original source is different
+;;; from the source we are working on, then we print the current source in
+;;; addition to the original source.
+;;;
+;;; We suppress printing of messages identical to the previous, but record
+;;; the number of times that the message is repeated.
+(defun print-compiler-message (format-string format-args)
+
+ (declare (type simple-string format-string))
+ (declare (type list format-args))
+
+ (let ((stream *error-output*)
+ (context (find-error-context format-args)))
+ (cond
+ (context
+ (let ((file (compiler-error-context-file-name context))
+ (in (compiler-error-context-context context))
+ (form (compiler-error-context-original-source context))
+ (enclosing (compiler-error-context-enclosing-source context))
+ (source (compiler-error-context-source context))
+ (last *last-error-context*))
+
+ (unless (and last
+ (equal file (compiler-error-context-file-name last)))
+ (when (pathnamep file)
+ (note-message-repeats)
+ (setq last nil)
+ (format stream "~2&file: ~A~%" (namestring file))))
+
+ (unless (and last
+ (equal in (compiler-error-context-context last)))
+ (note-message-repeats)
+ (setq last nil)
+ (format stream "~2&in:~{~<~% ~4:;~{ ~S~}~>~^ =>~}~%" in))
+
+ (unless (and last
+ (string= form
+ (compiler-error-context-original-source last)))
+ (note-message-repeats)
+ (setq last nil)
+ (write-string form stream))
+
+ (unless (and last
+ (equal enclosing
+ (compiler-error-context-enclosing-source last)))
+ (when enclosing
+ (note-message-repeats)
+ (setq last nil)
+ (format stream "--> ~{~<~%--> ~1:;~A~> ~}~%" enclosing)))
+
+ (unless (and last
+ (equal source (compiler-error-context-source last)))
+ (setq *last-format-string* nil)
+ (when source
+ (note-message-repeats)
+ (dolist (src source)
+ (write-line "==>" stream)
+ (write-string src stream))))))
+ (t
+ (note-message-repeats)
+ (setq *last-format-string* nil)
+ (format stream "~2&")))
+
+ (setq *last-error-context* context)
+
+ (unless (and (equal format-string *last-format-string*)
+ (tree-equal format-args *last-format-args*))
+ (note-message-repeats nil)
+ (setq *last-format-string* format-string)
+ (setq *last-format-args* format-args)
+ (let ((*print-level* *compiler-error-print-level*)
+ (*print-length* *compiler-error-print-length*)
+ (*print-lines* *compiler-error-print-lines*))
+ (format stream "~&~?~&" format-string format-args))))
+
+ (incf *last-message-count*)
+ (values))
+
+(defun print-compiler-condition (condition)
+ (declare (type condition condition))
+ (let (;; These different classes of conditions have different effects
+ ;; on the return codes of COMPILE-FILE, so it's nice for users to be
+ ;; able to pick them out by lexical search through the output.
+ (what (etypecase condition
+ (style-warning 'style-warning)
+ (warning 'warning)
+ (error 'error))))
+ (multiple-value-bind (format-string format-args)
+ (if (typep condition 'simple-condition)
+ (values (simple-condition-format-control condition)
+ (simple-condition-format-arguments condition))
+ (values "~A"
+ (list (with-output-to-string (s)
+ (princ condition s)))))
+ (print-compiler-message (format nil
+ "caught ~S:~% ~A"
+ what
+ format-string)
+ format-args)))
+ (values))
+
+;;; COMPILER-NOTE is vaguely like COMPILER-ERROR and the other
+;;; condition-signalling functions, but it just writes some output instead of
+;;; signalling. (In CMU CL, it did signal a condition, but this didn't seem to
+;;; work all that well; it was weird to have COMPILE-FILE return with
+;;; WARNINGS-P set when the only problem was that the compiler couldn't figure
+;;; out how to compile something as efficiently as it liked.)
+(defun compiler-note (format-string &rest format-args)
+ (unless (if *compiler-error-context*
+ (policy *compiler-error-context* (= brevity 3))
+ (policy nil (= brevity 3)))
+ (incf *compiler-note-count*)
+ (print-compiler-message (format nil "note: ~A" format-string)
+ format-args))
+ (values))
+
+;;; The politically correct way to print out progress messages and
+;;; such like. We clear the current error context so that we know that
+;;; it needs to be reprinted, and we also Force-Output so that the
+;;; message gets seen right away.
+(declaim (ftype (function (string &rest t) (values)) compiler-mumble))
+(defun compiler-mumble (format-string &rest format-args)
+ (note-message-repeats)
+ (setq *last-error-context* nil)
+ (apply #'format *error-output* format-string format-args)
+ (force-output *error-output*)
+ (values))
+
+;;; Return a string that somehow names the code in Component. We use
+;;; the source path for the bind node for an arbitrary entry point to
+;;; find the source context, then return that as a string.
+(declaim (ftype (function (component) simple-string) find-component-name))
+(defun find-component-name (component)
+ (let ((ep (first (block-succ (component-head component)))))
+ (assert ep () "no entry points?")
+ (multiple-value-bind (form context)
+ (find-original-source
+ (node-source-path (continuation-next (block-start ep))))
+ (declare (ignore form))
+ (let ((*print-level* 2)
+ (*print-pretty* nil))
+ (format nil "~{~{~S~^ ~}~^ => ~}" context)))))
+\f
+;;;; condition system interface
+
+;;; Keep track of how many times each kind of condition happens.
+(defvar *compiler-error-count*)
+(defvar *compiler-warning-count*)
+(defvar *compiler-style-warning-count*)
+(defvar *compiler-note-count*)
+
+;;; Keep track of whether any surrounding COMPILE or COMPILE-FILE call
+;;; should return WARNINGS-P or FAILURE-P.
+(defvar *failure-p*)
+(defvar *warnings-p*)
+
+;;; condition handlers established by the compiler. We re-signal the
+;;; condition, if it is not handled, we increment our warning counter
+;;; and print the error message.
+(defun compiler-error-handler (condition)
+ (signal condition)
+ (incf *compiler-error-count*)
+ (setf *warnings-p* t
+ *failure-p* t)
+ (print-compiler-condition condition)
+ (continue condition))
+(defun compiler-warning-handler (condition)
+ (signal condition)
+ (incf *compiler-warning-count*)
+ (setf *warnings-p* t
+ *failure-p* t)
+ (print-compiler-condition condition)
+ (muffle-warning condition))
+(defun compiler-style-warning-handler (condition)
+ (signal condition)
+ (incf *compiler-style-warning-count*)
+ (setf *warnings-p* t)
+ (print-compiler-condition condition)
+ (muffle-warning condition))
+\f
+;;;; undefined warnings
+
+(defvar *undefined-warning-limit* 3
+ #!+sb-doc
+ "If non-null, then an upper limit on the number of unknown function or type
+ warnings that the compiler will print for any given name in a single
+ compilation. This prevents excessive amounts of output when the real
+ problem is a missing definition (as opposed to a typo in the use.)")
+
+;;; Make an entry in the *UNDEFINED-WARNINGS* describing a reference
+;;; to Name of the specified Kind. If we have exceeded the warning
+;;; limit, then just increment the count, otherwise note the current
+;;; error context.
+;;;
+;;; Undefined types are noted by a condition handler in
+;;; WITH-COMPILATION-UNIT, which can potentially be invoked outside
+;;; the compiler, hence the BOUNDP check.
+(defun note-undefined-reference (name kind)
+ (unless (and (boundp '*lexenv*)
+ ;; FIXME: I'm pretty sure the BREVITY test below isn't
+ ;; a good idea; we should have BREVITY affect compiler
+ ;; notes, not STYLE-WARNINGs. And I'm not sure what the
+ ;; BOUNDP '*LEXENV* test above is for; it's likely
+ ;; a good idea, but it probably deserves an explanatory
+ ;; comment.
+ (policy nil (= brevity 3)))
+ (let* ((found (dolist (warning *undefined-warnings* nil)
+ (when (and (equal (undefined-warning-name warning) name)
+ (eq (undefined-warning-kind warning) kind))
+ (return warning))))
+ (res (or found
+ (make-undefined-warning :name name :kind kind))))
+ (unless found (push res *undefined-warnings*))
+ (when (or (not *undefined-warning-limit*)
+ (< (undefined-warning-count res) *undefined-warning-limit*))
+ (push (find-error-context (list name))
+ (undefined-warning-warnings res)))
+ (incf (undefined-warning-count res))))
+ (values))
+\f
+;;;; careful call
+
+;;; Apply a function to some arguments, returning a list of the values
+;;; resulting of the evaluation. If an error is signalled during the
+;;; application, then we print a warning message and return NIL as our
+;;; second value to indicate this. Node is used as the error context
+;;; for any error message, and Context is a string that is spliced
+;;; into the warning.
+(declaim (ftype (function ((or symbol function) list node string)
+ (values list boolean))
+ careful-call))
+(defun careful-call (function args node context)
+ (values
+ (multiple-value-list
+ (handler-case (apply function args)
+ (error (condition)
+ (let ((*compiler-error-context* node))
+ (compiler-warning "Lisp error during ~A:~%~A" context condition)
+ (return-from careful-call (values nil nil))))))
+ t))
+\f
+;;;; utilities used at run-time for parsing keyword args in IR1
+
+;;; This function is used by the result of Parse-Deftransform to find
+;;; the continuation for the value of the keyword argument Key in the
+;;; list of continuations Args. It returns the continuation if the
+;;; keyword is present, or NIL otherwise. The legality and
+;;; constantness of the keywords should already have been checked.
+(declaim (ftype (function (list keyword) (or continuation null))
+ find-keyword-continuation))
+(defun find-keyword-continuation (args key)
+ (do ((arg args (cddr arg)))
+ ((null arg) nil)
+ (when (eq (continuation-value (first arg)) key)
+ (return (second arg)))))
+
+;;; This function is used by the result of Parse-Deftransform to
+;;; verify that alternating continuations in Args are constant and
+;;; that there is an even number of args.
+(declaim (ftype (function (list) boolean) check-keywords-constant))
+(defun check-keywords-constant (args)
+ (do ((arg args (cddr arg)))
+ ((null arg) t)
+ (unless (and (rest arg)
+ (constant-continuation-p (first arg)))
+ (return nil))))
+
+;;; This function is used by the result of Parse-Deftransform to
+;;; verify that the list of continuations Args is a well-formed
+;;; keyword arglist and that only keywords present in the list Keys
+;;; are supplied.
+(declaim (ftype (function (list list) boolean) check-transform-keys))
+(defun check-transform-keys (args keys)
+ (and (check-keywords-constant args)
+ (do ((arg args (cddr arg)))
+ ((null arg) t)
+ (unless (member (continuation-value (first arg)) keys)
+ (return nil)))))
+\f
+;;;; miscellaneous
+
+;;; Called by the expansion of the EVENT macro.
+(declaim (ftype (function (event-info (or node null)) *) %event))
+(defun %event (info node)
+ (incf (event-info-count info))
+ (when (and (>= (event-info-level info) *event-note-threshold*)
+ (if node
+ (policy node (= brevity 0))
+ (policy nil (= brevity 0))))
+ (let ((*compiler-error-context* node))
+ (compiler-note (event-info-description info))))
+
+ (let ((action (event-info-action info)))
+ (when action (funcall action node))))
--- /dev/null
+;;;; This file contains the virtual-machine-independent parts of the
+;;;; code which does the actual translation of nodes to VOPs.
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!C")
+
+(file-comment
+ "$Header$")
+\f
+;;;; moves and type checks
+
+;;; Move X to Y unless they are EQ.
+(defun emit-move (node block x y)
+ (declare (type node node) (type ir2-block block) (type tn x y))
+ (unless (eq x y)
+ (vop move node block x y))
+ (values))
+
+;;; If there is any CHECK-xxx template for Type, then return it, otherwise
+;;; return NIL.
+(defun type-check-template (type)
+ (declare (type ctype type))
+ (multiple-value-bind (check-ptype exact) (primitive-type type)
+ (if exact
+ (primitive-type-check check-ptype)
+ (let ((name (hairy-type-check-template-name type)))
+ (if name
+ (template-or-lose name)
+ nil)))))
+
+;;; Emit code in Block to check that Value is of the specified Type,
+;;; yielding the checked result in Result. Value and result may be of any
+;;; primitive type. There must be CHECK-xxx VOP for Type. Any other type
+;;; checks should have been converted to an explicit type test.
+(defun emit-type-check (node block value result type)
+ (declare (type tn value result) (type node node) (type ir2-block block)
+ (type ctype type))
+ (emit-move-template node block (type-check-template type) value result)
+ (values))
+
+;;; Allocate an indirect value cell. Maybe do some clever stack allocation
+;;; someday.
+(defevent make-value-cell "Allocate heap value cell for lexical var.")
+(defun do-make-value-cell (node block value res)
+ (event make-value-cell node)
+ (vop make-value-cell node block value res))
+\f
+;;;; leaf reference
+
+;;; Return the TN that holds the value of Thing in the environment Env.
+(defun find-in-environment (thing env)
+ (declare (type (or nlx-info lambda-var) thing) (type environment env)
+ (values tn))
+ (or (cdr (assoc thing (ir2-environment-environment (environment-info env))))
+ (etypecase thing
+ (lambda-var
+ (assert (eq env (lambda-environment (lambda-var-home thing))))
+ (leaf-info thing))
+ (nlx-info
+ (assert (eq env (block-environment (nlx-info-target thing))))
+ (ir2-nlx-info-home (nlx-info-info thing))))))
+
+;;; If Leaf already has a constant TN, return that, otherwise make a TN for it.
+(defun constant-tn (leaf)
+ (declare (type constant leaf))
+ (or (leaf-info leaf)
+ (setf (leaf-info leaf)
+ (make-constant-tn leaf))))
+
+;;; Return a TN that represents the value of Leaf, or NIL if Leaf isn't
+;;; directly represented by a TN. Env is the environment that the reference is
+;;; done in.
+(defun leaf-tn (leaf env)
+ (declare (type leaf leaf) (type environment env))
+ (typecase leaf
+ (lambda-var
+ (unless (lambda-var-indirect leaf)
+ (find-in-environment leaf env)))
+ (constant (constant-tn leaf))
+ (t nil)))
+
+;;; Used to conveniently get a handle on a constant TN during IR2
+;;; conversion. Returns a constant TN representing the Lisp object Value.
+(defun emit-constant (value)
+ (constant-tn (find-constant value)))
+
+;;; Convert a Ref node. The reference must not be delayed.
+(defun ir2-convert-ref (node block)
+ (declare (type ref node) (type ir2-block block))
+ (let* ((cont (node-cont node))
+ (leaf (ref-leaf node))
+ (name (leaf-name leaf))
+ (locs (continuation-result-tns
+ cont (list (primitive-type (leaf-type leaf)))))
+ (res (first locs)))
+ (etypecase leaf
+ (lambda-var
+ (let ((tn (find-in-environment leaf (node-environment node))))
+ (if (lambda-var-indirect leaf)
+ (vop value-cell-ref node block tn res)
+ (emit-move node block tn res))))
+ (constant
+ (if (legal-immediate-constant-p leaf)
+ (emit-move node block (constant-tn leaf) res)
+ (let ((name-tn (emit-constant name)))
+ (if (policy node (zerop safety))
+ (vop fast-symbol-value node block name-tn res)
+ (vop symbol-value node block name-tn res)))))
+ (functional
+ (ir2-convert-closure node block leaf res))
+ (global-var
+ (let ((unsafe (policy node (zerop safety))))
+ (ecase (global-var-kind leaf)
+ ((:special :global :constant)
+ (assert (symbolp name))
+ (let ((name-tn (emit-constant name)))
+ (if unsafe
+ (vop fast-symbol-value node block name-tn res)
+ (vop symbol-value node block name-tn res))))
+ (:global-function
+ (let ((fdefn-tn (make-load-time-constant-tn :fdefinition name)))
+ (if unsafe
+ (vop fdefn-function node block fdefn-tn res)
+ (vop safe-fdefn-function node block fdefn-tn res))))))))
+ (move-continuation-result node block locs cont))
+ (values))
+
+;;; Emit code to load a function object representing Leaf into Res. This
+;;; gets interesting when the referenced function is a closure: we must make
+;;; the closure and move the closed over values into it.
+;;;
+;;; Leaf is either a :TOP-LEVEL-XEP functional or the XEP lambda for the called
+;;; function, since local call analysis converts all closure references. If a
+;;; TL-XEP, we know it is not a closure.
+;;;
+;;; If a closed-over lambda-var has no refs (is deleted), then we don't
+;;; initialize that slot. This can happen with closures over top-level
+;;; variables, where optimization of the closure deleted the variable. Since
+;;; we committed to the closure format when we pre-analyzed the top-level code,
+;;; we just leave an empty slot.
+(defun ir2-convert-closure (node block leaf res)
+ (declare (type ref node) (type ir2-block block)
+ (type functional leaf) (type tn res))
+ (unless (leaf-info leaf)
+ (setf (leaf-info leaf) (make-entry-info)))
+ (let ((entry (make-load-time-constant-tn :entry leaf))
+ (closure (etypecase leaf
+ (clambda
+ (environment-closure (get-lambda-environment leaf)))
+ (functional
+ (assert (eq (functional-kind leaf) :top-level-xep))
+ nil))))
+ (cond (closure
+ (let ((this-env (node-environment node)))
+ (vop make-closure node block entry (length closure) res)
+ (loop for what in closure and n from 0 do
+ (unless (and (lambda-var-p what)
+ (null (leaf-refs what)))
+ (vop closure-init node block
+ res
+ (find-in-environment what this-env)
+ n)))))
+ (t
+ (emit-move node block entry res))))
+ (values))
+
+;;; Convert a Set node. If the node's cont is annotated, then we also
+;;; deliver the value to that continuation. If the var is a lexical variable
+;;; with no refs, then we don't actually set anything, since the variable has
+;;; been deleted.
+(defun ir2-convert-set (node block)
+ (declare (type cset node) (type ir2-block block))
+ (let* ((cont (node-cont node))
+ (leaf (set-var node))
+ (val (continuation-tn node block (set-value node)))
+ (locs (if (continuation-info cont)
+ (continuation-result-tns
+ cont (list (primitive-type (leaf-type leaf))))
+ nil)))
+ (etypecase leaf
+ (lambda-var
+ (when (leaf-refs leaf)
+ (let ((tn (find-in-environment leaf (node-environment node))))
+ (if (lambda-var-indirect leaf)
+ (vop value-cell-set node block tn val)
+ (emit-move node block val tn)))))
+ (global-var
+ (ecase (global-var-kind leaf)
+ ((:special :global)
+ (assert (symbolp (leaf-name leaf)))
+ (vop set node block (emit-constant (leaf-name leaf)) val)))))
+ (when locs
+ (emit-move node block val (first locs))
+ (move-continuation-result node block locs cont)))
+ (values))
+\f
+;;;; utilities for receiving fixed values
+
+;;; Return a TN that can be referenced to get the value of Cont. Cont must
+;;; be LTN-Annotated either as a delayed leaf ref or as a fixed, single-value
+;;; continuation. If a type check is called for, do it.
+;;;
+;;; The primitive-type of the result will always be the same as the
+;;; ir2-continuation-primitive-type, ensuring that VOPs are always called with
+;;; TNs that satisfy the operand primitive-type restriction. We may have to
+;;; make a temporary of the desired type and move the actual continuation TN
+;;; into it. This happens when we delete a type check in unsafe code or when
+;;; we locally know something about the type of an argument variable.
+(defun continuation-tn (node block cont)
+ (declare (type node node) (type ir2-block block) (type continuation cont))
+ (let* ((2cont (continuation-info cont))
+ (cont-tn
+ (ecase (ir2-continuation-kind 2cont)
+ (:delayed
+ (let ((ref (continuation-use cont)))
+ (leaf-tn (ref-leaf ref) (node-environment ref))))
+ (:fixed
+ (assert (= (length (ir2-continuation-locs 2cont)) 1))
+ (first (ir2-continuation-locs 2cont)))))
+ (ptype (ir2-continuation-primitive-type 2cont)))
+
+ (cond ((and (eq (continuation-type-check cont) t)
+ (multiple-value-bind (check types)
+ (continuation-check-types cont)
+ (assert (eq check :simple))
+ ;; If the proven type is a subtype of the possibly
+ ;; weakened type check then it's always True and is
+ ;; flushed.
+ (unless (values-subtypep (continuation-proven-type cont)
+ (first types))
+ (let ((temp (make-normal-tn ptype)))
+ (emit-type-check node block cont-tn temp
+ (first types))
+ temp)))))
+ ((eq (tn-primitive-type cont-tn) ptype) cont-tn)
+ (t
+ (let ((temp (make-normal-tn ptype)))
+ (emit-move node block cont-tn temp)
+ temp)))))
+
+;;; Similar to CONTINUATION-TN, but hacks multiple values. We return
+;;; continuations holding the values of Cont with Ptypes as their primitive
+;;; types. Cont must be annotated for the same number of fixed values are
+;;; there are Ptypes.
+;;;
+;;; If the continuation has a type check, check the values into temps and
+;;; return the temps. When we have more values than assertions, we move the
+;;; extra values with no check.
+(defun continuation-tns (node block cont ptypes)
+ (declare (type node node) (type ir2-block block)
+ (type continuation cont) (list ptypes))
+ (let* ((locs (ir2-continuation-locs (continuation-info cont)))
+ (nlocs (length locs)))
+ (assert (= nlocs (length ptypes)))
+ (if (eq (continuation-type-check cont) t)
+ (multiple-value-bind (check types) (continuation-check-types cont)
+ (assert (eq check :simple))
+ (let ((ntypes (length types)))
+ (mapcar #'(lambda (from to-type assertion)
+ (let ((temp (make-normal-tn to-type)))
+ (if assertion
+ (emit-type-check node block from temp assertion)
+ (emit-move node block from temp))
+ temp))
+ locs ptypes
+ (if (< ntypes nlocs)
+ (append types (make-list (- nlocs ntypes)
+ :initial-element nil))
+ types))))
+ (mapcar #'(lambda (from to-type)
+ (if (eq (tn-primitive-type from) to-type)
+ from
+ (let ((temp (make-normal-tn to-type)))
+ (emit-move node block from temp)
+ temp)))
+ locs
+ ptypes))))
+\f
+;;;; utilities for delivering values to continuations
+
+;;; Return a list of TNs with the specifier Types that can be used as result
+;;; TNs to evaluate an expression into the continuation Cont. This is used
+;;; together with Move-Continuation-Result to deliver fixed values to a
+;;; continuation.
+;;;
+;;; If the continuation isn't annotated (meaning the values are discarded)
+;;; or is unknown-values, the then we make temporaries for each supplied value,
+;;; providing a place to compute the result in until we decide what to do with
+;;; it (if anything.)
+;;;
+;;; If the continuation is fixed-values, and wants the same number of values
+;;; as the user wants to deliver, then we just return the
+;;; IR2-Continuation-Locs. Otherwise we make a new list padded as necessary by
+;;; discarded TNs. We always return a TN of the specified type, using the
+;;; continuation locs only when they are of the correct type.
+(defun continuation-result-tns (cont types)
+ (declare (type continuation cont) (type list types))
+ (let ((2cont (continuation-info cont)))
+ (if (not 2cont)
+ (mapcar #'make-normal-tn types)
+ (ecase (ir2-continuation-kind 2cont)
+ (:fixed
+ (let* ((locs (ir2-continuation-locs 2cont))
+ (nlocs (length locs))
+ (ntypes (length types)))
+ (if (and (= nlocs ntypes)
+ (do ((loc locs (cdr loc))
+ (type types (cdr type)))
+ ((null loc) t)
+ (unless (eq (tn-primitive-type (car loc)) (car type))
+ (return nil))))
+ locs
+ (mapcar #'(lambda (loc type)
+ (if (eq (tn-primitive-type loc) type)
+ loc
+ (make-normal-tn type)))
+ (if (< nlocs ntypes)
+ (append locs
+ (mapcar #'make-normal-tn
+ (subseq types nlocs)))
+ locs)
+ types))))
+ (:unknown
+ (mapcar #'make-normal-tn types))))))
+
+;;; Make the first N standard value TNs, returning them in a list.
+(defun make-standard-value-tns (n)
+ (declare (type unsigned-byte n))
+ (collect ((res))
+ (dotimes (i n)
+ (res (standard-argument-location i)))
+ (res)))
+
+;;; Return a list of TNs wired to the standard value passing conventions
+;;; that can be used to receive values according to the unknown-values
+;;; convention. This is used with together Move-Continuation-Result for
+;;; delivering unknown values to a fixed values continuation.
+;;;
+;;; If the continuation isn't annotated, then we treat as 0-values,
+;;; returning an empty list of temporaries.
+;;;
+;;; If the continuation is annotated, then it must be :Fixed.
+(defun standard-result-tns (cont)
+ (declare (type continuation cont))
+ (let ((2cont (continuation-info cont)))
+ (if 2cont
+ (ecase (ir2-continuation-kind 2cont)
+ (:fixed
+ (make-standard-value-tns (length (ir2-continuation-locs 2cont)))))
+ ())))
+
+;;; Just move each Src TN into the corresponding Dest TN, defaulting any
+;;; unsupplied source values to NIL. We let Emit-Move worry about doing the
+;;; appropriate coercions.
+(defun move-results-coerced (node block src dest)
+ (declare (type node node) (type ir2-block block) (list src dest))
+ (let ((nsrc (length src))
+ (ndest (length dest)))
+ (mapc #'(lambda (from to)
+ (unless (eq from to)
+ (emit-move node block from to)))
+ (if (> ndest nsrc)
+ (append src (make-list (- ndest nsrc)
+ :initial-element (emit-constant nil)))
+ src)
+ dest))
+ (values))
+
+;;; If necessary, emit coercion code needed to deliver the
+;;; Results to the specified continuation. Node and block provide context for
+;;; emitting code. Although usually obtained from Standard-Result-TNs or
+;;; Continuation-Result-TNs, Results my be a list of any type or number of TNs.
+;;;
+;;; If the continuation is fixed values, then move the results into the
+;;; continuation locations. If the continuation is unknown values, then do the
+;;; moves into the standard value locations, and use Push-Values to put the
+;;; values on the stack.
+(defun move-continuation-result (node block results cont)
+ (declare (type node node) (type ir2-block block)
+ (list results) (type continuation cont))
+ (let* ((2cont (continuation-info cont)))
+ (when 2cont
+ (ecase (ir2-continuation-kind 2cont)
+ (:fixed
+ (let ((locs (ir2-continuation-locs 2cont)))
+ (unless (eq locs results)
+ (move-results-coerced node block results locs))))
+ (:unknown
+ (let* ((nvals (length results))
+ (locs (make-standard-value-tns nvals)))
+ (move-results-coerced node block results locs)
+ (vop* push-values node block
+ ((reference-tn-list locs nil))
+ ((reference-tn-list (ir2-continuation-locs 2cont) t))
+ nvals))))))
+ (values))
+\f
+;;;; template conversion
+
+;;; Build a TN-Refs list that represents access to the values of the
+;;; specified list of continuations Args for Template. Any :CONSTANT arguments
+;;; are returned in the second value as a list rather than being accessed as a
+;;; normal argument. Node and Block provide the context for emitting any
+;;; necessary type-checking code.
+(defun reference-arguments (node block args template)
+ (declare (type node node) (type ir2-block block) (list args)
+ (type template template))
+ (collect ((info-args))
+ (let ((last nil)
+ (first nil))
+ (do ((args args (cdr args))
+ (types (template-arg-types template) (cdr types)))
+ ((null args))
+ (let ((type (first types))
+ (arg (first args)))
+ (if (and (consp type) (eq (car type) ':constant))
+ (info-args (continuation-value arg))
+ (let ((ref (reference-tn (continuation-tn node block arg) nil)))
+ (if last
+ (setf (tn-ref-across last) ref)
+ (setf first ref))
+ (setq last ref)))))
+
+ (values (the (or tn-ref null) first) (info-args)))))
+
+;;; Convert a conditional template. We try to exploit any drop-through, but
+;;; emit an unconditional branch afterward if we fail. Not-P is true if the
+;;; sense of the Template's test should be negated.
+(defun ir2-convert-conditional (node block template args info-args if not-p)
+ (declare (type node node) (type ir2-block block)
+ (type template template) (type (or tn-ref null) args)
+ (list info-args) (type cif if) (type boolean not-p))
+ (assert (= (template-info-arg-count template) (+ (length info-args) 2)))
+ (let ((consequent (if-consequent if))
+ (alternative (if-alternative if)))
+ (cond ((drop-thru-p if consequent)
+ (emit-template node block template args nil
+ (list* (block-label alternative) (not not-p)
+ info-args)))
+ (t
+ (emit-template node block template args nil
+ (list* (block-label consequent) not-p info-args))
+ (unless (drop-thru-p if alternative)
+ (vop branch node block (block-label alternative)))))))
+
+;;; Convert an IF that isn't the DEST of a conditional template.
+(defun ir2-convert-if (node block)
+ (declare (type ir2-block block) (type cif node))
+ (let* ((test (if-test node))
+ (test-ref (reference-tn (continuation-tn node block test) nil))
+ (nil-ref (reference-tn (emit-constant nil) nil)))
+ (setf (tn-ref-across test-ref) nil-ref)
+ (ir2-convert-conditional node block (template-or-lose 'if-eq)
+ test-ref () node t)))
+
+;;; Return a list of primitive-types that we can pass to
+;;; CONTINUATION-RESULT-TNS describing the result types we want for a template
+;;; call. We duplicate here the determination of output type that was done in
+;;; initially selecting the template, so we know that the types we find are
+;;; allowed by the template output type restrictions.
+(defun find-template-result-types (call cont template rtypes)
+ (declare (type combination call) (type continuation cont)
+ (type template template) (list rtypes))
+ (let* ((dtype (node-derived-type call))
+ (type (if (and (or (eq (template-policy template) :safe)
+ (policy call (= safety 0)))
+ (continuation-type-check cont))
+ (values-type-intersection
+ dtype
+ (continuation-asserted-type cont))
+ dtype))
+ (types (mapcar #'primitive-type
+ (if (values-type-p type)
+ (append (values-type-required type)
+ (values-type-optional type))
+ (list type)))))
+ (let ((nvals (length rtypes))
+ (ntypes (length types)))
+ (cond ((< ntypes nvals)
+ (append types
+ (make-list (- nvals ntypes)
+ :initial-element *backend-t-primitive-type*)))
+ ((> ntypes nvals)
+ (subseq types 0 nvals))
+ (t
+ types)))))
+
+;;; Return a list of TNs usable in a Call to Template delivering values to
+;;; Cont. As an efficiency hack, we pick off the common case where the
+;;; continuation is fixed values and has locations that satisfy the result
+;;; restrictions. This can fail when there is a type check or a values count
+;;; mismatch.
+(defun make-template-result-tns (call cont template rtypes)
+ (declare (type combination call) (type continuation cont)
+ (type template template) (list rtypes))
+ (let ((2cont (continuation-info cont)))
+ (if (and 2cont (eq (ir2-continuation-kind 2cont) :fixed))
+ (let ((locs (ir2-continuation-locs 2cont)))
+ (if (and (= (length rtypes) (length locs))
+ (do ((loc locs (cdr loc))
+ (rtype rtypes (cdr rtype)))
+ ((null loc) t)
+ (unless (operand-restriction-ok
+ (car rtype)
+ (tn-primitive-type (car loc))
+ :t-ok nil)
+ (return nil))))
+ locs
+ (continuation-result-tns
+ cont
+ (find-template-result-types call cont template rtypes))))
+ (continuation-result-tns
+ cont
+ (find-template-result-types call cont template rtypes)))))
+
+;;; Get the operands into TNs, make TN-Refs for them, and then call the
+;;; template emit function.
+(defun ir2-convert-template (call block)
+ (declare (type combination call) (type ir2-block block))
+ (let* ((template (combination-info call))
+ (cont (node-cont call))
+ (rtypes (template-result-types template)))
+ (multiple-value-bind (args info-args)
+ (reference-arguments call block (combination-args call) template)
+ (assert (not (template-more-results-type template)))
+ (if (eq rtypes :conditional)
+ (ir2-convert-conditional call block template args info-args
+ (continuation-dest cont) nil)
+ (let* ((results (make-template-result-tns call cont template rtypes))
+ (r-refs (reference-tn-list results t)))
+ (assert (= (length info-args)
+ (template-info-arg-count template)))
+ (if info-args
+ (emit-template call block template args r-refs info-args)
+ (emit-template call block template args r-refs))
+ (move-continuation-result call block results cont)))))
+ (values))
+
+;;; We don't have to do much because operand count checking is done by IR1
+;;; conversion. The only difference between this and the function case of
+;;; IR2-Convert-Template is that there can be codegen-info arguments.
+(defoptimizer (%%primitive ir2-convert) ((template info &rest args) call block)
+ (let* ((template (continuation-value template))
+ (info (continuation-value info))
+ (cont (node-cont call))
+ (rtypes (template-result-types template))
+ (results (make-template-result-tns call cont template rtypes))
+ (r-refs (reference-tn-list results t)))
+ (multiple-value-bind (args info-args)
+ (reference-arguments call block (cddr (combination-args call))
+ template)
+ (assert (not (template-more-results-type template)))
+ (assert (not (eq rtypes :conditional)))
+ (assert (null info-args))
+
+ (if info
+ (emit-template call block template args r-refs info)
+ (emit-template call block template args r-refs))
+
+ (move-continuation-result call block results cont)))
+ (values))
+\f
+;;;; local call
+
+;;; Convert a let by moving the argument values into the variables. Since a
+;;; a let doesn't have any passing locations, we move the arguments directly
+;;; into the variables. We must also allocate any indirect value cells, since
+;;; there is no function prologue to do this.
+(defun ir2-convert-let (node block fun)
+ (declare (type combination node) (type ir2-block block) (type clambda fun))
+ (mapc #'(lambda (var arg)
+ (when arg
+ (let ((src (continuation-tn node block arg))
+ (dest (leaf-info var)))
+ (if (lambda-var-indirect var)
+ (do-make-value-cell node block src dest)
+ (emit-move node block src dest)))))
+ (lambda-vars fun) (basic-combination-args node))
+ (values))
+
+;;; Emit any necessary moves into assignment temps for a local call to Fun.
+;;; We return two lists of TNs: TNs holding the actual argument values, and
+;;; (possibly EQ) TNs that are the actual destination of the arguments. When
+;;; necessary, we allocate temporaries for arguments to preserve parallel
+;;; assignment semantics. These lists exclude unused arguments and include
+;;; implicit environment arguments, i.e. they exactly correspond to the
+;;; arguments passed.
+;;;
+;;; OLD-FP is the TN currently holding the value we want to pass as OLD-FP. If
+;;; null, then the call is to the same environment (an :ASSIGNMENT), so we
+;;; only move the arguments, and leave the environment alone.
+(defun emit-psetq-moves (node block fun old-fp)
+ (declare (type combination node) (type ir2-block block) (type clambda fun)
+ (type (or tn null) old-fp))
+ (let* ((called-env (environment-info (lambda-environment fun)))
+ (this-1env (node-environment node))
+ (actuals (mapcar #'(lambda (x)
+ (when x
+ (continuation-tn node block x)))
+ (combination-args node))))
+ (collect ((temps)
+ (locs))
+ (dolist (var (lambda-vars fun))
+ (let ((actual (pop actuals))
+ (loc (leaf-info var)))
+ (when actual
+ (cond
+ ((lambda-var-indirect var)
+ (let ((temp
+ (make-normal-tn *backend-t-primitive-type*)))
+ (do-make-value-cell node block actual temp)
+ (temps temp)))
+ ((member actual (locs))
+ (let ((temp (make-normal-tn (tn-primitive-type loc))))
+ (emit-move node block actual temp)
+ (temps temp)))
+ (t
+ (temps actual)))
+ (locs loc))))
+
+ (when old-fp
+ (dolist (thing (ir2-environment-environment called-env))
+ (temps (find-in-environment (car thing) this-1env))
+ (locs (cdr thing)))
+
+ (temps old-fp)
+ (locs (ir2-environment-old-fp called-env)))
+
+ (values (temps) (locs)))))
+
+;;; A tail-recursive local call is done by emitting moves of stuff into the
+;;; appropriate passing locations. After setting up the args and environment,
+;;; we just move our return-pc into the called function's passing
+;;; location.
+(defun ir2-convert-tail-local-call (node block fun)
+ (declare (type combination node) (type ir2-block block) (type clambda fun))
+ (let ((this-env (environment-info (node-environment node))))
+ (multiple-value-bind (temps locs)
+ (emit-psetq-moves node block fun (ir2-environment-old-fp this-env))
+
+ (mapc #'(lambda (temp loc)
+ (emit-move node block temp loc))
+ temps locs))
+
+ (emit-move node block
+ (ir2-environment-return-pc this-env)
+ (ir2-environment-return-pc-pass
+ (environment-info
+ (lambda-environment fun)))))
+
+ (values))
+
+;;; Convert an :ASSIGNMENT call. This is just like a tail local call,
+;;; except that the caller and callee environment are the same, so we don't
+;;; need to mess with the environment locations, return PC, etc.
+(defun ir2-convert-assignment (node block fun)
+ (declare (type combination node) (type ir2-block block) (type clambda fun))
+ (multiple-value-bind (temps locs) (emit-psetq-moves node block fun nil)
+
+ (mapc #'(lambda (temp loc)
+ (emit-move node block temp loc))
+ temps locs))
+ (values))
+
+;;; Do stuff to set up the arguments to a non-tail local call (including
+;;; implicit environment args.) We allocate a frame (returning the FP and
+;;; NFP), and also compute the TN-Refs list for the values to pass and the list
+;;; of passing location TNs.
+(defun ir2-convert-local-call-args (node block fun)
+ (declare (type combination node) (type ir2-block block) (type clambda fun))
+ (let ((fp (make-stack-pointer-tn))
+ (nfp (make-number-stack-pointer-tn))
+ (old-fp (make-stack-pointer-tn)))
+ (multiple-value-bind (temps locs)
+ (emit-psetq-moves node block fun old-fp)
+ (vop current-fp node block old-fp)
+ (vop allocate-frame node block
+ (environment-info (lambda-environment fun))
+ fp nfp)
+ (values fp nfp temps (mapcar #'make-alias-tn locs)))))
+
+;;; Handle a non-TR known-values local call. We Emit the call, then move
+;;; the results to the continuation's destination.
+(defun ir2-convert-local-known-call (node block fun returns cont start)
+ (declare (type node node) (type ir2-block block) (type clambda fun)
+ (type return-info returns) (type continuation cont)
+ (type label start))
+ (multiple-value-bind (fp nfp temps arg-locs)
+ (ir2-convert-local-call-args node block fun)
+ (let ((locs (return-info-locations returns)))
+ (vop* known-call-local node block
+ (fp nfp (reference-tn-list temps nil))
+ ((reference-tn-list locs t))
+ arg-locs (environment-info (lambda-environment fun)) start)
+ (move-continuation-result node block locs cont)))
+ (values))
+
+;;; Handle a non-TR unknown-values local call. We do different things
+;;; depending on what kind of values the continuation wants.
+;;;
+;;; If Cont is :Unknown, then we use the "Multiple-" variant, directly
+;;; specifying the continuation's Locs as the VOP results so that we don't have
+;;; to do anything after the call.
+;;;
+;;; Otherwise, we use Standard-Result-Tns to get wired result TNs, and
+;;; then call Move-Continuation-Result to do any necessary type checks or
+;;; coercions.
+(defun ir2-convert-local-unknown-call (node block fun cont start)
+ (declare (type node node) (type ir2-block block) (type clambda fun)
+ (type continuation cont) (type label start))
+ (multiple-value-bind (fp nfp temps arg-locs)
+ (ir2-convert-local-call-args node block fun)
+ (let ((2cont (continuation-info cont))
+ (env (environment-info (lambda-environment fun)))
+ (temp-refs (reference-tn-list temps nil)))
+ (if (and 2cont (eq (ir2-continuation-kind 2cont) :unknown))
+ (vop* multiple-call-local node block (fp nfp temp-refs)
+ ((reference-tn-list (ir2-continuation-locs 2cont) t))
+ arg-locs env start)
+ (let ((locs (standard-result-tns cont)))
+ (vop* call-local node block
+ (fp nfp temp-refs)
+ ((reference-tn-list locs t))
+ arg-locs env start (length locs))
+ (move-continuation-result node block locs cont)))))
+ (values))
+
+;;; Dispatch to the appropriate function, depending on whether we have a
+;;; let, tail or normal call. If the function doesn't return, call it using
+;;; the unknown-value convention. We could compile it as a tail call, but that
+;;; might seem confusing in the debugger.
+(defun ir2-convert-local-call (node block)
+ (declare (type combination node) (type ir2-block block))
+ (let* ((fun (ref-leaf (continuation-use (basic-combination-fun node))))
+ (kind (functional-kind fun)))
+ (cond ((eq kind :let)
+ (ir2-convert-let node block fun))
+ ((eq kind :assignment)
+ (ir2-convert-assignment node block fun))
+ ((node-tail-p node)
+ (ir2-convert-tail-local-call node block fun))
+ (t
+ (let ((start (block-label (node-block (lambda-bind fun))))
+ (returns (tail-set-info (lambda-tail-set fun)))
+ (cont (node-cont node)))
+ (ecase (if returns
+ (return-info-kind returns)
+ :unknown)
+ (:unknown
+ (ir2-convert-local-unknown-call node block fun cont start))
+ (:fixed
+ (ir2-convert-local-known-call node block fun returns
+ cont start)))))))
+ (values))
+\f
+;;;; full call
+
+;;; Given a function continuation Fun, return as values a TN holding the
+;;; thing that we call and true if the thing is named (false if it is a
+;;; function). There are two interesting non-named cases:
+;;; -- Known to be a function, no check needed: return the continuation loc.
+;;; -- Not known what it is.
+(defun function-continuation-tn (node block cont)
+ (declare (type continuation cont))
+ (let ((2cont (continuation-info cont)))
+ (if (eq (ir2-continuation-kind 2cont) :delayed)
+ (let ((name (continuation-function-name cont t)))
+ (assert name)
+ (values (make-load-time-constant-tn :fdefinition name) t))
+ (let* ((locs (ir2-continuation-locs 2cont))
+ (loc (first locs))
+ (check (continuation-type-check cont))
+ (function-ptype (primitive-type-or-lose 'function)))
+ (assert (and (eq (ir2-continuation-kind 2cont) :fixed)
+ (= (length locs) 1)))
+ (cond ((eq (tn-primitive-type loc) function-ptype)
+ (assert (not (eq check t)))
+ (values loc nil))
+ (t
+ (let ((temp (make-normal-tn function-ptype)))
+ (assert (and (eq (ir2-continuation-primitive-type 2cont)
+ function-ptype)
+ (eq check t)))
+ (emit-type-check node block loc temp
+ (specifier-type 'function))
+ (values temp nil))))))))
+
+;;; Set up the args to Node in the current frame, and return a tn-ref list
+;;; for the passing locations.
+(defun move-tail-full-call-args (node block)
+ (declare (type combination node) (type ir2-block block))
+ (let ((args (basic-combination-args node))
+ (last nil)
+ (first nil))
+ (dotimes (num (length args))
+ (let ((loc (standard-argument-location num)))
+ (emit-move node block (continuation-tn node block (elt args num)) loc)
+ (let ((ref (reference-tn loc nil)))
+ (if last
+ (setf (tn-ref-across last) ref)
+ (setf first ref))
+ (setq last ref))))
+ first))
+
+;;; Move the arguments into the passing locations and do a (possibly named)
+;;; tail call.
+(defun ir2-convert-tail-full-call (node block)
+ (declare (type combination node) (type ir2-block block))
+ (let* ((env (environment-info (node-environment node)))
+ (args (basic-combination-args node))
+ (nargs (length args))
+ (pass-refs (move-tail-full-call-args node block))
+ (old-fp (ir2-environment-old-fp env))
+ (return-pc (ir2-environment-return-pc env)))
+
+ (multiple-value-bind (fun-tn named)
+ (function-continuation-tn node block (basic-combination-fun node))
+ (if named
+ (vop* tail-call-named node block
+ (fun-tn old-fp return-pc pass-refs)
+ (nil)
+ nargs)
+ (vop* tail-call node block
+ (fun-tn old-fp return-pc pass-refs)
+ (nil)
+ nargs))))
+
+ (values))
+
+;;; Like IR2-CONVERT-LOCAL-CALL-ARGS, only different.
+(defun ir2-convert-full-call-args (node block)
+ (declare (type combination node) (type ir2-block block))
+ (let* ((args (basic-combination-args node))
+ (fp (make-stack-pointer-tn))
+ (nargs (length args)))
+ (vop allocate-full-call-frame node block nargs fp)
+ (collect ((locs))
+ (let ((last nil)
+ (first nil))
+ (dotimes (num nargs)
+ (locs (standard-argument-location num))
+ (let ((ref (reference-tn (continuation-tn node block (elt args num))
+ nil)))
+ (if last
+ (setf (tn-ref-across last) ref)
+ (setf first ref))
+ (setq last ref)))
+
+ (values fp first (locs) nargs)))))
+
+;;; Do full call when a fixed number of values are desired. We make
+;;; Standard-Result-TNs for our continuation, then deliver the result using
+;;; Move-Continuation-Result. We do named or normal call, as appropriate.
+(defun ir2-convert-fixed-full-call (node block)
+ (declare (type combination node) (type ir2-block block))
+ (multiple-value-bind (fp args arg-locs nargs)
+ (ir2-convert-full-call-args node block)
+ (let* ((cont (node-cont node))
+ (locs (standard-result-tns cont))
+ (loc-refs (reference-tn-list locs t))
+ (nvals (length locs)))
+ (multiple-value-bind (fun-tn named)
+ (function-continuation-tn node block (basic-combination-fun node))
+ (if named
+ (vop* call-named node block (fp fun-tn args) (loc-refs)
+ arg-locs nargs nvals)
+ (vop* call node block (fp fun-tn args) (loc-refs)
+ arg-locs nargs nvals))
+ (move-continuation-result node block locs cont))))
+ (values))
+
+;;; Do full call when unknown values are desired.
+(defun ir2-convert-multiple-full-call (node block)
+ (declare (type combination node) (type ir2-block block))
+ (multiple-value-bind (fp args arg-locs nargs)
+ (ir2-convert-full-call-args node block)
+ (let* ((cont (node-cont node))
+ (locs (ir2-continuation-locs (continuation-info cont)))
+ (loc-refs (reference-tn-list locs t)))
+ (multiple-value-bind (fun-tn named)
+ (function-continuation-tn node block (basic-combination-fun node))
+ (if named
+ (vop* multiple-call-named node block (fp fun-tn args) (loc-refs)
+ arg-locs nargs)
+ (vop* multiple-call node block (fp fun-tn args) (loc-refs)
+ arg-locs nargs)))))
+ (values))
+
+;;; These came in handy when troubleshooting cold boot after making
+;;; major changes in the package structure: various transforms and
+;;; VOPs and stuff got attached to the wrong symbol, so that
+;;; references to the right symbol were bogusly translated as full
+;;; calls instead of primitives, sending the system off into infinite
+;;; space. Having a report on all full calls generated makes it easier
+;;; to figure out what form caused the problem this time.
+#!+sb-show (defvar *show-full-called-fnames-p* nil)
+#!+sb-show (defvar *full-called-fnames* (make-hash-table :test 'equal))
+
+;;; If the call is in a tail recursive position and the return
+;;; convention is standard, then do a tail full call. If one or fewer
+;;; values are desired, then use a single-value call, otherwise use a
+;;; multiple-values call.
+(defun ir2-convert-full-call (node block)
+ (declare (type combination node) (type ir2-block block))
+
+ (let* ((cont (basic-combination-fun node))
+ (fname (continuation-function-name cont t)))
+ (declare (type (or symbol cons) fname))
+
+ #!+sb-show (unless (gethash fname *full-called-fnames*)
+ (setf (gethash fname *full-called-fnames*) t))
+ #!+sb-show (when *show-full-called-fnames-p*
+ (/show "converting full call to named function" fname)
+ (/show (basic-combination-args node))
+ (let ((arg-types (mapcar (lambda (maybe-continuation)
+ (when maybe-continuation
+ (type-specifier
+ (continuation-type
+ maybe-continuation))))
+ (basic-combination-args node))))
+ (/show arg-types)))
+
+ (when (consp fname)
+ (destructuring-bind (setf stem) fname
+ (assert (eq setf 'setf))
+ (setf (gethash stem *setf-assumed-fboundp*) t))))
+
+ (let ((2cont (continuation-info (node-cont node))))
+ (cond ((node-tail-p node)
+ (ir2-convert-tail-full-call node block))
+ ((and 2cont
+ (eq (ir2-continuation-kind 2cont) :unknown))
+ (ir2-convert-multiple-full-call node block))
+ (t
+ (ir2-convert-fixed-full-call node block))))
+
+ (values))
+\f
+;;;; entering functions
+
+;;; Do all the stuff that needs to be done on XEP entry:
+;;; -- Create frame
+;;; -- Copy any more arg
+;;; -- Set up the environment, accessing any closure variables
+;;; -- Move args from the standard passing locations to their internal
+;;; locations.
+(defun init-xep-environment (node block fun)
+ (declare (type bind node) (type ir2-block block) (type clambda fun))
+ (let ((start-label (entry-info-offset (leaf-info fun)))
+ (env (environment-info (node-environment node))))
+ (let ((ef (functional-entry-function fun)))
+ (cond ((and (optional-dispatch-p ef) (optional-dispatch-more-entry ef))
+ ;; Special case the xep-allocate-frame + copy-more-arg case.
+ (vop xep-allocate-frame node block start-label t)
+ (vop copy-more-arg node block (optional-dispatch-max-args ef)))
+ (t
+ ;; No more args, so normal entry.
+ (vop xep-allocate-frame node block start-label nil)))
+ (if (ir2-environment-environment env)
+ (let ((closure (make-normal-tn *backend-t-primitive-type*)))
+ (vop setup-closure-environment node block start-label closure)
+ (when (getf (functional-plist ef) :fin-function)
+ (vop funcallable-instance-lexenv node block closure closure))
+ (let ((n -1))
+ (dolist (loc (ir2-environment-environment env))
+ (vop closure-ref node block closure (incf n) (cdr loc)))))
+ (vop setup-environment node block start-label)))
+
+ (unless (eq (functional-kind fun) :top-level)
+ (let ((vars (lambda-vars fun))
+ (n 0))
+ (when (leaf-refs (first vars))
+ (emit-move node block (make-argument-count-location)
+ (leaf-info (first vars))))
+ (dolist (arg (rest vars))
+ (when (leaf-refs arg)
+ (let ((pass (standard-argument-location n))
+ (home (leaf-info arg)))
+ (if (lambda-var-indirect arg)
+ (do-make-value-cell node block pass home)
+ (emit-move node block pass home))))
+ (incf n))))
+
+ (emit-move node block (make-old-fp-passing-location t)
+ (ir2-environment-old-fp env)))
+
+ (values))
+
+;;; Emit function prolog code. This is only called on bind nodes for
+;;; functions that allocate environments. All semantics of let calls are
+;;; handled by IR2-Convert-Let.
+;;;
+;;; If not an XEP, all we do is move the return PC from its passing
+;;; location, since in a local call, the caller allocates the frame and sets up
+;;; the arguments.
+(defun ir2-convert-bind (node block)
+ (declare (type bind node) (type ir2-block block))
+ (let* ((fun (bind-lambda node))
+ (env (environment-info (lambda-environment fun))))
+ (assert (member (functional-kind fun)
+ '(nil :external :optional :top-level :cleanup)))
+
+ (when (external-entry-point-p fun)
+ (init-xep-environment node block fun)
+ #!+sb-dyncount
+ (when *collect-dynamic-statistics*
+ (vop count-me node block *dynamic-counts-tn*
+ (block-number (ir2-block-block block)))))
+
+ (emit-move node block (ir2-environment-return-pc-pass env)
+ (ir2-environment-return-pc env))
+
+ (let ((lab (gen-label)))
+ (setf (ir2-environment-environment-start env) lab)
+ (vop note-environment-start node block lab)))
+
+ (values))
+\f
+;;;; function return
+
+;;; Do stuff to return from a function with the specified values and
+;;; convention. If the return convention is :Fixed and we aren't returning
+;;; from an XEP, then we do a known return (letting representation selection
+;;; insert the correct move-arg VOPs.) Otherwise, we use the unknown-values
+;;; convention. If there is a fixed number of return values, then use Return,
+;;; otherwise use Return-Multiple.
+(defun ir2-convert-return (node block)
+ (declare (type creturn node) (type ir2-block block))
+ (let* ((cont (return-result node))
+ (2cont (continuation-info cont))
+ (cont-kind (ir2-continuation-kind 2cont))
+ (fun (return-lambda node))
+ (env (environment-info (lambda-environment fun)))
+ (old-fp (ir2-environment-old-fp env))
+ (return-pc (ir2-environment-return-pc env))
+ (returns (tail-set-info (lambda-tail-set fun))))
+ (cond
+ ((and (eq (return-info-kind returns) :fixed)
+ (not (external-entry-point-p fun)))
+ (let ((locs (continuation-tns node block cont
+ (return-info-types returns))))
+ (vop* known-return node block
+ (old-fp return-pc (reference-tn-list locs nil))
+ (nil)
+ (return-info-locations returns))))
+ ((eq cont-kind :fixed)
+ (let* ((types (mapcar #'tn-primitive-type (ir2-continuation-locs 2cont)))
+ (cont-locs (continuation-tns node block cont types))
+ (nvals (length cont-locs))
+ (locs (make-standard-value-tns nvals)))
+ (mapc #'(lambda (val loc)
+ (emit-move node block val loc))
+ cont-locs
+ locs)
+ (if (= nvals 1)
+ (vop return-single node block old-fp return-pc (car locs))
+ (vop* return node block
+ (old-fp return-pc (reference-tn-list locs nil))
+ (nil)
+ nvals))))
+ (t
+ (assert (eq cont-kind :unknown))
+ (vop* return-multiple node block
+ (old-fp return-pc
+ (reference-tn-list (ir2-continuation-locs 2cont) nil))
+ (nil)))))
+
+ (values))
+\f
+;;;; debugger hooks
+
+;;; This is used by the debugger to find the top function on the stack. It
+;;; returns the OLD-FP and RETURN-PC for the current function as multiple
+;;; values.
+(defoptimizer (sb!kernel:%caller-frame-and-pc ir2-convert) (() node block)
+ (let ((env (environment-info (node-environment node))))
+ (move-continuation-result node block
+ (list (ir2-environment-old-fp env)
+ (ir2-environment-return-pc env))
+ (node-cont node))))
+\f
+;;;; multiple values
+
+;;; Almost identical to IR2-Convert-Let. Since LTN annotates the
+;;; continuation for the correct number of values (with the continuation user
+;;; responsible for defaulting), we can just pick them up from the
+;;; continuation.
+(defun ir2-convert-mv-bind (node block)
+ (declare (type mv-combination node) (type ir2-block block))
+ (let* ((cont (first (basic-combination-args node)))
+ (fun (ref-leaf (continuation-use (basic-combination-fun node))))
+ (vars (lambda-vars fun)))
+ (assert (eq (functional-kind fun) :mv-let))
+ (mapc #'(lambda (src var)
+ (when (leaf-refs var)
+ (let ((dest (leaf-info var)))
+ (if (lambda-var-indirect var)
+ (do-make-value-cell node block src dest)
+ (emit-move node block src dest)))))
+ (continuation-tns node block cont
+ (mapcar #'(lambda (x)
+ (primitive-type (leaf-type x)))
+ vars))
+ vars))
+ (values))
+
+;;; Emit the appropriate fixed value, unknown value or tail variant of
+;;; Call-Variable. Note that we only need to pass the values start for the
+;;; first argument: all the other argument continuation TNs are ignored. This
+;;; is because we require all of the values globs to be contiguous and on stack
+;;; top.
+(defun ir2-convert-mv-call (node block)
+ (declare (type mv-combination node) (type ir2-block block))
+ (assert (basic-combination-args node))
+ (let* ((start-cont (continuation-info (first (basic-combination-args node))))
+ (start (first (ir2-continuation-locs start-cont)))
+ (tails (and (node-tail-p node)
+ (lambda-tail-set (node-home-lambda node))))
+ (cont (node-cont node))
+ (2cont (continuation-info cont)))
+ (multiple-value-bind (fun named)
+ (function-continuation-tn node block (basic-combination-fun node))
+ (assert (and (not named)
+ (eq (ir2-continuation-kind start-cont) :unknown)))
+ (cond
+ (tails
+ (let ((env (environment-info (node-environment node))))
+ (vop tail-call-variable node block start fun
+ (ir2-environment-old-fp env)
+ (ir2-environment-return-pc env))))
+ ((and 2cont
+ (eq (ir2-continuation-kind 2cont) :unknown))
+ (vop* multiple-call-variable node block (start fun nil)
+ ((reference-tn-list (ir2-continuation-locs 2cont) t))))
+ (t
+ (let ((locs (standard-result-tns cont)))
+ (vop* call-variable node block (start fun nil)
+ ((reference-tn-list locs t)) (length locs))
+ (move-continuation-result node block locs cont)))))))
+
+;;; Reset the stack pointer to the start of the specified unknown-values
+;;; continuation (discarding it and all values globs on top of it.)
+(defoptimizer (%pop-values ir2-convert) ((continuation) node block)
+ (let ((2cont (continuation-info (continuation-value continuation))))
+ (assert (eq (ir2-continuation-kind 2cont) :unknown))
+ (vop reset-stack-pointer node block
+ (first (ir2-continuation-locs 2cont)))))
+
+;;; Deliver the values TNs to Cont using Move-Continuation-Result.
+(defoptimizer (values ir2-convert) ((&rest values) node block)
+ (let ((tns (mapcar #'(lambda (x)
+ (continuation-tn node block x))
+ values)))
+ (move-continuation-result node block tns (node-cont node))))
+
+;;; In the normal case where unknown values are desired, we use the
+;;; Values-List VOP. In the relatively unimportant case of Values-List for a
+;;; fixed number of values, we punt by doing a full call to the Values-List
+;;; function. This gets the full call VOP to deal with defaulting any
+;;; unsupplied values. It seems unworthwhile to optimize this case.
+(defoptimizer (values-list ir2-convert) ((list) node block)
+ (let* ((cont (node-cont node))
+ (2cont (continuation-info cont)))
+ (when 2cont
+ (ecase (ir2-continuation-kind 2cont)
+ (:fixed (ir2-convert-full-call node block))
+ (:unknown
+ (let ((locs (ir2-continuation-locs 2cont)))
+ (vop* values-list node block
+ ((continuation-tn node block list) nil)
+ ((reference-tn-list locs t)))))))))
+
+(defoptimizer (%more-arg-values ir2-convert) ((context start count) node block)
+ (let* ((cont (node-cont node))
+ (2cont (continuation-info cont)))
+ (when 2cont
+ (ecase (ir2-continuation-kind 2cont)
+ (:fixed (ir2-convert-full-call node block))
+ (:unknown
+ (let ((locs (ir2-continuation-locs 2cont)))
+ (vop* %more-arg-values node block
+ ((continuation-tn node block context)
+ (continuation-tn node block start)
+ (continuation-tn node block count)
+ nil)
+ ((reference-tn-list locs t)))))))))
+\f
+;;;; special binding
+
+;;; Trivial, given our assumption of a shallow-binding implementation.
+(defoptimizer (%special-bind ir2-convert) ((var value) node block)
+ (let ((name (leaf-name (continuation-value var))))
+ (vop bind node block (continuation-tn node block value)
+ (emit-constant name))))
+(defoptimizer (%special-unbind ir2-convert) ((var) node block)
+ (vop unbind node block))
+
+;;; ### Not clear that this really belongs in this file, or should really be
+;;; done this way, but this is the least violation of abstraction in the
+;;; current setup. We don't want to wire shallow-binding assumptions into
+;;; IR1tran.
+(def-ir1-translator progv ((vars vals &body body) start cont)
+ (ir1-convert
+ start cont
+ (if (or *converting-for-interpreter* (byte-compiling))
+ `(%progv ,vars ,vals #'(lambda () ,@body))
+ (once-only ((n-save-bs '(%primitive current-binding-pointer)))
+ `(unwind-protect
+ (progn
+ (mapc #'(lambda (var val)
+ (%primitive bind val var))
+ ,vars
+ ,vals)
+ ,@body)
+ (%primitive unbind-to-here ,n-save-bs))))))
+\f
+;;;; non-local exit
+
+;;; Convert a non-local lexical exit. First find the NLX-Info in our
+;;; environment. Note that this is never called on the escape exits for Catch
+;;; and Unwind-Protect, since the escape functions aren't IR2 converted.
+(defun ir2-convert-exit (node block)
+ (declare (type exit node) (type ir2-block block))
+ (let ((loc (find-in-environment (find-nlx-info (exit-entry node)
+ (node-cont node))
+ (node-environment node)))
+ (temp (make-stack-pointer-tn))
+ (value (exit-value node)))
+ (vop value-cell-ref node block loc temp)
+ (if value
+ (let ((locs (ir2-continuation-locs (continuation-info value))))
+ (vop unwind node block temp (first locs) (second locs)))
+ (let ((0-tn (emit-constant 0)))
+ (vop unwind node block temp 0-tn 0-tn))))
+
+ (values))
+
+;;; Cleanup-point doesn't to anything except prevent the body from being
+;;; entirely deleted.
+(defoptimizer (%cleanup-point ir2-convert) (() node block) node block)
+
+;;; This function invalidates a lexical exit on exiting from the dynamic
+;;; extent. This is done by storing 0 into the indirect value cell that holds
+;;; the closed unwind block.
+(defoptimizer (%lexical-exit-breakup ir2-convert) ((info) node block)
+ (vop value-cell-set node block
+ (find-in-environment (continuation-value info) (node-environment node))
+ (emit-constant 0)))
+
+;;; We have to do a spurious move of no values to the result continuation so
+;;; that lifetime analysis won't get confused.
+(defun ir2-convert-throw (node block)
+ (declare (type mv-combination node) (type ir2-block block))
+ (let ((args (basic-combination-args node)))
+ (vop* throw node block
+ ((continuation-tn node block (first args))
+ (reference-tn-list
+ (ir2-continuation-locs (continuation-info (second args)))
+ nil))
+ (nil)))
+
+ (move-continuation-result node block () (node-cont node))
+ (values))
+
+;;; Emit code to set up a non-local-exit. Info is the NLX-Info for the
+;;; exit, and Tag is the continuation for the catch tag (if any.) We get at
+;;; the target PC by passing in the label to the vop. The vop is responsible
+;;; for building a return-PC object.
+(defun emit-nlx-start (node block info tag)
+ (declare (type node node) (type ir2-block block) (type nlx-info info)
+ (type (or continuation null) tag))
+ (let* ((2info (nlx-info-info info))
+ (kind (cleanup-kind (nlx-info-cleanup info)))
+ (block-tn (environment-live-tn
+ (make-normal-tn (primitive-type-or-lose 'catch-block))
+ (node-environment node)))
+ (res (make-stack-pointer-tn))
+ (target-label (ir2-nlx-info-target 2info)))
+
+ (vop current-binding-pointer node block
+ (car (ir2-nlx-info-dynamic-state 2info)))
+ (vop* save-dynamic-state node block
+ (nil)
+ ((reference-tn-list (cdr (ir2-nlx-info-dynamic-state 2info)) t)))
+ (vop current-stack-pointer node block (ir2-nlx-info-save-sp 2info))
+
+ (ecase kind
+ (:catch
+ (vop make-catch-block node block block-tn
+ (continuation-tn node block tag) target-label res))
+ ((:unwind-protect :block :tagbody)
+ (vop make-unwind-block node block block-tn target-label res)))
+
+ (ecase kind
+ ((:block :tagbody)
+ (do-make-value-cell node block res (ir2-nlx-info-home 2info)))
+ (:unwind-protect
+ (vop set-unwind-protect node block block-tn))
+ (:catch)))
+
+ (values))
+
+;;; Scan each of Entry's exits, setting up the exit for each lexical exit.
+(defun ir2-convert-entry (node block)
+ (declare (type entry node) (type ir2-block block))
+ (dolist (exit (entry-exits node))
+ (let ((info (find-nlx-info node (node-cont exit))))
+ (when (and info
+ (member (cleanup-kind (nlx-info-cleanup info))
+ '(:block :tagbody)))
+ (emit-nlx-start node block info nil))))
+ (values))
+
+;;; Set up the unwind block for these guys.
+(defoptimizer (%catch ir2-convert) ((info-cont tag) node block)
+ (emit-nlx-start node block (continuation-value info-cont) tag))
+(defoptimizer (%unwind-protect ir2-convert) ((info-cont cleanup) node block)
+ (emit-nlx-start node block (continuation-value info-cont) nil))
+
+;;; Emit the entry code for a non-local exit. We receive values and restore
+;;; dynamic state.
+;;;
+;;; In the case of a lexical exit or Catch, we look at the exit continuation's
+;;; kind to determine which flavor of entry VOP to emit. If unknown values,
+;;; emit the xxx-MULTIPLE variant to the continuation locs. If fixed values,
+;;; make the appropriate number of temps in the standard values locations and
+;;; use the other variant, delivering the temps to the continuation using
+;;; Move-Continuation-Result.
+;;;
+;;; In the Unwind-Protect case, we deliver the first register argument, the
+;;; argument count and the argument pointer to our continuation as multiple
+;;; values. These values are the block exited to and the values start and
+;;; count.
+;;;
+;;; After receiving values, we restore dynamic state. Except in the
+;;; Unwind-Protect case, the values receiving restores the stack pointer. In
+;;; an Unwind-Protect cleanup, we want to leave the stack pointer alone, since
+;;; the thrown values are still out there.
+(defoptimizer (%nlx-entry ir2-convert) ((info-cont) node block)
+ (let* ((info (continuation-value info-cont))
+ (cont (nlx-info-continuation info))
+ (2cont (continuation-info cont))
+ (2info (nlx-info-info info))
+ (top-loc (ir2-nlx-info-save-sp 2info))
+ (start-loc (make-nlx-entry-argument-start-location))
+ (count-loc (make-argument-count-location))
+ (target (ir2-nlx-info-target 2info)))
+
+ (ecase (cleanup-kind (nlx-info-cleanup info))
+ ((:catch :block :tagbody)
+ (if (and 2cont (eq (ir2-continuation-kind 2cont) :unknown))
+ (vop* nlx-entry-multiple node block
+ (top-loc start-loc count-loc nil)
+ ((reference-tn-list (ir2-continuation-locs 2cont) t))
+ target)
+ (let ((locs (standard-result-tns cont)))
+ (vop* nlx-entry node block
+ (top-loc start-loc count-loc nil)
+ ((reference-tn-list locs t))
+ target
+ (length locs))
+ (move-continuation-result node block locs cont))))
+ (:unwind-protect
+ (let ((block-loc (standard-argument-location 0)))
+ (vop uwp-entry node block target block-loc start-loc count-loc)
+ (move-continuation-result
+ node block
+ (list block-loc start-loc count-loc)
+ cont))))
+
+ #!+sb-dyncount
+ (when *collect-dynamic-statistics*
+ (vop count-me node block *dynamic-counts-tn*
+ (block-number (ir2-block-block block))))
+
+ (vop* restore-dynamic-state node block
+ ((reference-tn-list (cdr (ir2-nlx-info-dynamic-state 2info)) nil))
+ (nil))
+ (vop unbind-to-here node block
+ (car (ir2-nlx-info-dynamic-state 2info)))))
+\f
+;;;; n-argument functions
+
+(macrolet ((frob (name)
+ `(defoptimizer (,name ir2-convert) ((&rest args) node block)
+ (let* ((refs (move-tail-full-call-args node block))
+ (cont (node-cont node))
+ (res (continuation-result-tns
+ cont
+ (list (primitive-type (specifier-type 'list))))))
+ (vop* ,name node block (refs) ((first res) nil)
+ (length args))
+ (move-continuation-result node block res cont)))))
+ (frob list)
+ (frob list*))
+\f
+;;;; structure accessors
+;;;;
+;;;; These guys have to bizarrely determine the slot offset by looking at the
+;;;; called function.
+
+(defoptimizer (%slot-accessor ir2-convert) ((str) node block)
+ (let* ((cont (node-cont node))
+ (res (continuation-result-tns cont
+ (list *backend-t-primitive-type*))))
+ (vop instance-ref node block
+ (continuation-tn node block str)
+ (dsd-index
+ (slot-accessor-slot
+ (ref-leaf
+ (continuation-use
+ (combination-fun node)))))
+ (first res))
+ (move-continuation-result node block res cont)))
+
+(defoptimizer (%slot-setter ir2-convert) ((value str) node block)
+ (let ((val (continuation-tn node block value)))
+ (vop instance-set node block
+ (continuation-tn node block str)
+ val
+ (dsd-index
+ (slot-accessor-slot
+ (ref-leaf
+ (continuation-use
+ (combination-fun node))))))
+
+ (move-continuation-result node block (list val) (node-cont node))))
+\f
+;;; Convert the code in a component into VOPs.
+(defun ir2-convert (component)
+ (declare (type component component))
+ (let (#!+sb-dyncount
+ (*dynamic-counts-tn*
+ (when *collect-dynamic-statistics*
+ (let* ((blocks
+ (block-number (block-next (component-head component))))
+ (counts (make-array blocks
+ :element-type '(unsigned-byte 32)
+ :initial-element 0))
+ (info (make-dyncount-info
+ :for (component-name component)
+ :costs (make-array blocks
+ :element-type '(unsigned-byte 32)
+ :initial-element 0)
+ :counts counts)))
+ (setf (ir2-component-dyncount-info (component-info component))
+ info)
+ (emit-constant info)
+ (emit-constant counts)))))
+ (let ((num 0))
+ (declare (type index num))
+ (do-ir2-blocks (2block component)
+ (let ((block (ir2-block-block 2block)))
+ (when (block-start block)
+ (setf (block-number block) num)
+ #!+sb-dyncount
+ (when *collect-dynamic-statistics*
+ (let ((first-node (continuation-next (block-start block))))
+ (unless (or (and (bind-p first-node)
+ (external-entry-point-p
+ (bind-lambda first-node)))
+ (eq (continuation-function-name
+ (node-cont first-node))
+ '%nlx-entry))
+ (vop count-me
+ first-node
+ 2block
+ #!+sb-dyncount *dynamic-counts-tn* #!-sb-dyncount nil
+ num))))
+ (ir2-convert-block block)
+ (incf num))))))
+ (values))
+
+;;; If necessary, emit a terminal unconditional branch to go to the
+;;; successor block. If the successor is the component tail, then there isn't
+;;; really any successor, but if the end is an unknown, non-tail call, then we
+;;; emit an error trap just in case the function really does return.
+(defun finish-ir2-block (block)
+ (declare (type cblock block))
+ (let* ((2block (block-info block))
+ (last (block-last block))
+ (succ (block-succ block)))
+ (unless (if-p last)
+ (assert (and succ (null (rest succ))))
+ (let ((target (first succ)))
+ (cond ((eq target (component-tail (block-component block)))
+ (when (and (basic-combination-p last)
+ (eq (basic-combination-kind last) :full))
+ (let* ((fun (basic-combination-fun last))
+ (use (continuation-use fun))
+ (name (and (ref-p use) (leaf-name (ref-leaf use)))))
+ (unless (or (node-tail-p last)
+ (info :function :info name)
+ (policy last (zerop safety)))
+ (vop nil-function-returned-error last 2block
+ (if name
+ (emit-constant name)
+ (multiple-value-bind (tn named)
+ (function-continuation-tn last 2block fun)
+ (assert (not named))
+ tn)))))))
+ ((not (eq (ir2-block-next 2block) (block-info target)))
+ (vop branch last 2block (block-label target)))))))
+
+ (values))
+
+;;; Convert the code in a block into VOPs.
+(defun ir2-convert-block (block)
+ (declare (type cblock block))
+ (let ((2block (block-info block)))
+ (do-nodes (node cont block)
+ (etypecase node
+ (ref
+ (let ((2cont (continuation-info cont)))
+ (when (and 2cont
+ (not (eq (ir2-continuation-kind 2cont) :delayed)))
+ (ir2-convert-ref node 2block))))
+ (combination
+ (let ((kind (basic-combination-kind node)))
+ (case kind
+ (:local
+ (ir2-convert-local-call node 2block))
+ (:full
+ (ir2-convert-full-call node 2block))
+ (t
+ (let ((fun (function-info-ir2-convert kind)))
+ (cond (fun
+ (funcall fun node 2block))
+ ((eq (basic-combination-info node) :full)
+ (ir2-convert-full-call node 2block))
+ (t
+ (ir2-convert-template node 2block))))))))
+ (cif
+ (when (continuation-info (if-test node))
+ (ir2-convert-if node 2block)))
+ (bind
+ (let ((fun (bind-lambda node)))
+ (when (eq (lambda-home fun) fun)
+ (ir2-convert-bind node 2block))))
+ (creturn
+ (ir2-convert-return node 2block))
+ (cset
+ (ir2-convert-set node 2block))
+ (mv-combination
+ (cond
+ ((eq (basic-combination-kind node) :local)
+ (ir2-convert-mv-bind node 2block))
+ ((eq (continuation-function-name (basic-combination-fun node))
+ '%throw)
+ (ir2-convert-throw node 2block))
+ (t
+ (ir2-convert-mv-call node 2block))))
+ (exit
+ (when (exit-entry node)
+ (ir2-convert-exit node 2block)))
+ (entry
+ (ir2-convert-entry node 2block)))))
+
+ (finish-ir2-block block)
+
+ (values))
--- /dev/null
+;;;; This file contains stuff for maintaining a database of special
+;;;; information about functions known to the compiler. This includes
+;;;; semantic information such as side-effects and type inference
+;;;; functions as well as transforms and IR2 translators.
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!C")
+
+(file-comment
+ "$Header$")
+
+;;; IR1 boolean function attributes
+;;;
+;;; There are a number of boolean attributes of known functions which we like
+;;; to have in IR1. This information is mostly side effect information of a
+;;; sort, but it is different from the kind of information we want in IR2. We
+;;; aren't interested in a fine breakdown of side effects, since we do very
+;;; little code motion on IR1. We are interested in some deeper semantic
+;;; properties such as whether it is safe to pass stack closures to.
+(def-boolean-attribute ir1
+ ;; May call functions that are passed as arguments. In order to determine
+ ;; what other effects are present, we must find the effects of all arguments
+ ;; that may be functions.
+ call
+ ;; May incorporate function or number arguments into the result or somehow
+ ;; pass them upward. Note that this applies to any argument that *might* be
+ ;; a function or number, not just the arguments that always are.
+ unsafe
+ ;; May fail to return during correct execution. Errors are O.K.
+ unwind
+ ;; The (default) worst case. Includes all the other bad things, plus any
+ ;; other possible bad thing. If this is present, the above bad attributes
+ ;; will be explicitly present as well.
+ any
+ ;; May be constant-folded. The function has no side effects, but may be
+ ;; affected by side effects on the arguments. e.g. SVREF, MAPC. Functions
+ ;; that side-effect their arguments are not considered to be foldable.
+ ;; Although it would be "legal" to constant fold them (since it "is an error"
+ ;; to modify a constant), we choose not to mark these functions as foldable
+ ;; in this database.
+ foldable
+ ;; May be eliminated if value is unused. The function has no side effects
+ ;; except possibly CONS. If a function is defined to signal errors, then it
+ ;; is not flushable even if it is movable or foldable.
+ flushable
+ ;; May be moved with impunity. Has no side effects except possibly CONS, and
+ ;; is affected only by its arguments.
+ movable
+ ;; Function is a true predicate likely to be open-coded. Convert any
+ ;; non-conditional uses into (IF <pred> T NIL).
+ predicate
+ ;; Inhibit any warning for compiling a recursive definition. (Normally the
+ ;; compiler warns when compiling a recursive definition for a known function,
+ ;; since it might be a botched interpreter stub.)
+ recursive
+ ;; Function does explicit argument type checking, so the declared type should
+ ;; not be asserted when a definition is compiled.
+ explicit-check)
+
+(defstruct (function-info #-sb-xc-host (:pure t))
+ ;; Boolean attributes of this function.
+ (attributes (required-argument) :type attributes)
+ ;; A list of Transform structures describing transforms for this function.
+ (transforms () :type list)
+ ;; A function which computes the derived type for a call to this function by
+ ;; examining the arguments. This is null when there is no special method for
+ ;; this function.
+ (derive-type nil :type (or function null))
+ ;; A function that does various unspecified code transformations by directly
+ ;; hacking the IR. Returns true if further optimizations of the call
+ ;; shouldn't be attempted.
+ ;;
+ ;; KLUDGE: This return convention (non-NIL if you shouldn't do further
+ ;; optimiz'ns) is backwards from the return convention for transforms.
+ ;; -- WHN 19990917
+ (optimizer nil :type (or function null))
+ ;; If true, a special-case LTN annotation method that is used in place of the
+ ;; standard type/policy template selection. It may use arbitrary code to
+ ;; choose a template, decide to do a full call, or conspire with the
+ ;; IR2-Convert method to do almost anything. The Combination node is passed
+ ;; as the argument.
+ (ltn-annotate nil :type (or function null))
+ ;; If true, the special-case IR2 conversion method for this function. This
+ ;; deals with funny functions, and anything else that can't be handled using
+ ;; the template mechanism. The Combination node and the IR2-Block are passed
+ ;; as arguments.
+ (ir2-convert nil :type (or function null))
+ ;; A list of all the templates that could be used to translate this function
+ ;; into IR2, sorted by increasing cost.
+ (templates nil :type list)
+ ;; If non-null, then this function is a unary type predicate for this type.
+ (predicate-type nil :type (or ctype null))
+ ;; If non-null, use this function to annotate the known call for the byte
+ ;; compiler. If it returns NIL, then change the call to :full.
+ (byte-annotate nil :type (or function null))
+ ;; If non-null, use this function to generate the byte code for this known
+ ;; call. This function can only give up if there is a byte-annotate function
+ ;; that arranged for the functional to be pushed onto the stack.
+ (byte-compile nil :type (or function null)))
+
+(defprinter (function-info)
+ (transforms :test transforms)
+ (derive-type :test derive-type)
+ (optimizer :test optimizer)
+ (ltn-annotate :test ltn-annotate)
+ (ir2-convert :test ir2-convert)
+ (templates :test templates)
+ (predicate-type :test predicate-type)
+ (byte-annotate :test byte-annotate)
+ (byte-compile :test byte-compile))
+\f
+;;;; interfaces to defining macros
+
+;;; The TRANSFORM structure represents an IR1 transform.
+(defstruct transform
+ ;; The function-type which enables this transform.
+ (type (required-argument) :type ctype)
+ ;; The transformation function. Takes the Combination node and Returns a
+ ;; lambda, or throws out.
+ (function (required-argument) :type function)
+ ;; String used in efficency notes.
+ (note (required-argument) :type string)
+ ;; T if we should spew a failure note even if speed=brevity.
+ (important nil :type (member t nil))
+ ;; Usable for byte code, native code, or both.
+ (when :native :type (member :byte :native :both)))
+
+(defprinter (transform) type note important when)
+
+;;; Grab the FUNCTION-INFO and enter the function, replacing any old
+;;; one with the same type and note.
+(declaim (ftype (function (t list function &optional (or string null)
+ (member t nil) (member :native :byte :both))
+ *)
+ %deftransform))
+(defun %deftransform (name type fun &optional note important (when :native))
+ (let* ((ctype (specifier-type type))
+ (note (or note "optimize"))
+ (info (function-info-or-lose name))
+ (old (find-if (lambda (x)
+ (and (type= (transform-type x) ctype)
+ (string-equal (transform-note x) note)
+ (eq (transform-important x) important)
+ (eq (transform-when x) when)))
+ (function-info-transforms info))))
+ (if old
+ (setf (transform-function old) fun (transform-note old) note)
+ (push (make-transform :type ctype :function fun :note note
+ :important important :when when)
+ (function-info-transforms info)))
+ name))
+
+;;; Make a FUNCTION-INFO structure with the specified type, attributes
+;;; and optimizers.
+(declaim (ftype (function (list list attributes &key
+ (:derive-type (or function null))
+ (:optimizer (or function null)))
+ *)
+ %defknown))
+(defun %defknown (names type attributes &key derive-type optimizer)
+ (let ((ctype (specifier-type type))
+ (info (make-function-info :attributes attributes
+ :derive-type derive-type
+ :optimizer optimizer))
+ (target-env (or *backend-info-environment* *info-environment*)))
+ (dolist (name names)
+ (setf (info :function :type name target-env) ctype)
+ (setf (info :function :where-from name target-env) :declared)
+ (setf (info :function :kind name target-env) :function)
+ (setf (info :function :info name target-env) info)))
+ names)
+
+;;; Return the FUNCTION-INFO for NAME or die trying. Since this is
+;;; used by people who want to modify the info, and the info may be
+;;; shared, we copy it. We don't have to copy the lists, since each
+;;; function that has generators or transforms has already been
+;;; through here.
+(declaim (ftype (function (t) function-info) function-info-or-lose))
+(defun function-info-or-lose (name)
+ (let ((*info-environment* (or *backend-info-environment*
+ *info-environment*)))
+ (let ((old (info :function :info name)))
+ (unless old (error "~S is not a known function." name))
+ (setf (info :function :info name) (copy-function-info old)))))
+\f
+;;;; generic type inference methods
+
+;;; Derive the type to be the type of the xxx'th arg. This can normally
+;;; only be done when the result value is that argument.
+(defun result-type-first-arg (call)
+ (declare (type combination call))
+ (let ((cont (first (combination-args call))))
+ (when cont (continuation-type cont))))
+(defun result-type-last-arg (call)
+ (declare (type combination call))
+ (let ((cont (car (last (combination-args call)))))
+ (when cont (continuation-type cont))))
+
+;;; Derive the result type according to the float contagion rules, but
+;;; always return a float. This is used for irrational functions that preserve
+;;; realness of their arguments.
+(defun result-type-float-contagion (call)
+ (declare (type combination call))
+ (reduce #'numeric-contagion (combination-args call)
+ :key #'continuation-type
+ :initial-value (specifier-type 'single-float)))
+
+;;; Return a closure usable as a derive-type method for accessing the N'th
+;;; argument. If arg is a list, result is a list. If arg is a vector, result
+;;; is a vector with the same element type.
+(defun sequence-result-nth-arg (n)
+ #'(lambda (call)
+ (declare (type combination call))
+ (let ((cont (nth (1- n) (combination-args call))))
+ (when cont
+ (let ((type (continuation-type cont)))
+ (if (array-type-p type)
+ (specifier-type
+ `(vector ,(type-specifier (array-type-element-type type))))
+ (let ((ltype (specifier-type 'list)))
+ (when (csubtypep type ltype)
+ ltype))))))))
+
+;;; Derive the type to be the type specifier which is the N'th arg.
+(defun result-type-specifier-nth-arg (n)
+ (lambda (call)
+ (declare (type combination call))
+ (let ((cont (nth (1- n) (combination-args call))))
+ (when (and cont (constant-continuation-p cont))
+ (specifier-type (continuation-value cont))))))
--- /dev/null
+;;;; macros which use GET-SETF-EXPANSION in their macroexpander code,
+;;;; and hence need special treatment. Currently (19990806) this
+;;;; special treatment involves bare calls to SB!XC:DEFMACRO, and so
+;;;; this code can't appear in the build sequence until after
+;;;; SB!XC:DEFMACRO has been defined, and so this stuff is separated
+;;;; out of the main compiler/macros.lisp file (which has to appear
+;;;; earlier)
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!C")
+
+(file-comment
+ "$Header$")
+
+#+sb-xc-host
+(sb!xc:defmacro def-boolean-attribute (name &rest attribute-names)
+ #!+sb-doc
+ "Def-Boolean-Attribute Name Attribute-Name*
+ Define a new class of boolean attributes, with the attributes having the
+ specified Attribute-Names. Name is the name of the class, which is used to
+ generate some macros to manipulate sets of the attributes:
+
+ NAME-attributep attributes attribute-name*
+ Return true if one of the named attributes is present, false otherwise.
+ When set with SETF, updates the place Attributes setting or clearing the
+ specified attributes.
+
+ NAME-attributes attribute-name*
+ Return a set of the named attributes."
+
+ (let ((const-name (symbolicate name "-ATTRIBUTE-TRANSLATIONS"))
+ (test-name (symbolicate name "-ATTRIBUTEP")))
+ (collect ((alist))
+ (do ((mask 1 (ash mask 1))
+ (names attribute-names (cdr names)))
+ ((null names))
+ (alist (cons (car names) mask)))
+
+ `(progn
+ (eval-when (:compile-toplevel :load-toplevel :execute)
+ (defconstant ,const-name ',(alist)))
+
+ (defmacro ,test-name (attributes &rest attribute-names)
+ "Automagically generated boolean attribute test function. See
+ Def-Boolean-Attribute."
+ `(logtest ,(compute-attribute-mask attribute-names ,const-name)
+ (the attributes ,attributes)))
+
+ (define-setf-expander ,test-name (place &rest attributes
+ &environment env)
+ "Automagically generated boolean attribute setter. See
+ Def-Boolean-Attribute."
+ (boolean-attribute-setter--target place
+ attributes
+ env
+ (compute-attribute-mask
+ attributes
+ ,const-name
+ )
+ ',test-name))
+
+ (defmacro ,(symbolicate name "-ATTRIBUTES") (&rest attribute-names)
+ "Automagically generated boolean attribute creation function. See
+ Def-Boolean-Attribute."
+ (compute-attribute-mask attribute-names ,const-name))))))
+
+;;; a helper function for the cross-compilation target Lisp code which
+;;; DEF-BOOLEAN-ATTRIBUTE expands into
+;;;
+;;; KLUDGE: Eventually I'd like to rewrite the mainstream DEF-BOOLEAN-ATTRIBUTE
+;;; to use code like this, to factor out some shared functionality for clarity
+;;; and for economy. But the motivation for splitting out this code here is
+;;; much weirder. In the current version of the code, the cross-compiler calls
+;;; UNCROSS on each top-level form before processing it. Ordinarily, UNCROSS
+;;; isn't called on macro expansions, but since DEF-BOOLEAN-ATTRIBUTE expands
+;;; into a PROGN, the cross-compiler does end up calling UNCROSS on (the
+;;; components of) its macroexpansion, since they're separate top-level forms.
+;;; In the classic CMU CL macroexpansion, the call to GET-SETF-EXPANSION is in
+;;; the macroexpansion, and even when I translate it to
+;;; SB!XC:GET-SETF-MACROEXPANSION so that it will work on target code, my
+;;; damned, damned UNCROSS kludge unconverts it before processing it. Moving
+;;; this shared logic (which includes the troublesome
+;;; SB!XC:GET-SETF-EXPANSION code) out of the macroexpansion and into this
+;;; helper function works around this problem. -- WHN 19990812
+(defun boolean-attribute-setter--target (place attributes env mask test-name)
+ (multiple-value-bind (temps values stores set get)
+ (sb!xc:get-setf-expansion place env)
+ (when (cdr stores)
+ (error "multiple store variables for ~S" place))
+ (let ((newval (gensym))
+ (n-place (gensym)))
+ (values `(,@temps ,n-place)
+ `(,@values ,get)
+ `(,newval)
+ `(let ((,(first stores)
+ (if ,newval
+ (logior ,n-place ,mask)
+ (logand ,n-place ,(lognot mask)))))
+ ,set
+ ,newval)
+ `(,test-name ,n-place ,@attributes)))))
+
+#+sb-xc-host
+(sb!xc:defmacro deletef-in (next place item &environment env)
+ (multiple-value-bind (temps vals stores store access)
+ (sb!xc:get-setf-expansion place env)
+ (when (cdr stores)
+ (error "multiple store variables for ~S" place))
+ (let ((n-item (gensym))
+ (n-place (gensym))
+ (n-current (gensym))
+ (n-prev (gensym)))
+ `(let* (,@(mapcar #'list temps vals)
+ (,n-place ,access)
+ (,n-item ,item))
+ (if (eq ,n-place ,n-item)
+ (let ((,(first stores) (,next ,n-place)))
+ ,store)
+ (do ((,n-prev ,n-place ,n-current)
+ (,n-current (,next ,n-place)
+ (,next ,n-current)))
+ ((eq ,n-current ,n-item)
+ (setf (,next ,n-prev)
+ (,next ,n-current)))))
+ (values)))))
+
+#+sb-xc-host
+(sb!xc:defmacro push-in (next item place &environment env)
+ #!+sb-doc
+ "Push Item onto a list linked by the accessor function Next that is stored in
+ Place."
+ (multiple-value-bind (temps vals stores store access)
+ (sb!xc:get-setf-expansion place env)
+ (when (cdr stores)
+ (error "multiple store variables for ~S" place))
+ `(let (,@(mapcar #'list temps vals)
+ (,(first stores) ,item))
+ (setf (,next ,(first stores)) ,access)
+ ,store
+ (values))))
--- /dev/null
+;;;; a few things from the classic CMU CL "src/compiler/vmdef.lisp"
+;;;; file which couldn't be compiled early
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!C")
+
+(file-comment
+ "$Header$")
+
+(defun note-this-location (vop kind)
+ #!+sb-doc
+ "NOTE-THIS-LOCATION VOP Kind
+ Note that the current code location is an interesting (to the debugger)
+ location of the specified Kind. VOP is the VOP responsible for this code.
+ This VOP must specify some non-null :SAVE-P value (perhaps :COMPUTE-ONLY) so
+ that the live set is computed."
+ (let ((lab (gen-label)))
+ (emit-label lab)
+ (note-debug-location vop lab kind)))
+
+(defun note-next-instruction (vop kind)
+ #!+sb-doc
+ "NOTE-NEXT-INSTRUCTION VOP Kind
+ Similar to NOTE-THIS-LOCATION, except the use the location of the next
+ instruction for the code location, wherever the scheduler decided to put
+ it."
+ (let ((loc (note-debug-location vop nil kind)))
+ (sb!assem:emit-postit (lambda (segment posn)
+ (declare (ignore segment))
+ (setf (location-info-label loc) posn))))
+ (values))
--- /dev/null
+;;;; the representation of a lexical environment
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!C")
+
+(file-comment
+ "$Header$")
+
+#!-sb-fluid (declaim (inline internal-make-lexenv)) ; only called in one place
+
+;;; The LEXENV represents the lexical environment used for IR1 conversion.
+;;; (This is also what shows up as an ENVIRONMENT value in macroexpansion.)
+#!-sb-fluid (declaim (inline internal-make-lexenv)) ; only called in one place
+(def!struct (lexenv
+ ;; FIXME: should probably be called MAKE-EMPTY-LEXENV or
+ ;; MAKE-NULL-LEXENV
+ (:constructor make-null-lexenv ())
+ (:constructor internal-make-lexenv
+ (functions variables blocks tags type-restrictions
+ lambda cleanup cookie
+ interface-cookie options)))
+ ;; Alist (name . what), where What is either a Functional (a local function),
+ ;; a DEFINED-FUNCTION, representing an INLINE/NOTINLINE declaration, or
+ ;; a list (MACRO . <function>) (a local macro, with the specifier
+ ;; expander.) Note that Name may be a (SETF <name>) function.
+ (functions nil :type list)
+ ;; An alist translating variable names to Leaf structures. A special binding
+ ;; is indicated by a :Special Global-Var leaf. Each special binding within
+ ;; the code gets a distinct leaf structure, as does the current "global"
+ ;; value on entry to the code compiled. (locally (special ...)) is handled
+ ;; by adding the most recent special binding to the front of the list.
+ ;;
+ ;; If the CDR is (MACRO . <exp>), then <exp> is the expansion of a symbol
+ ;; macro.
+ (variables nil :type list)
+ ;; Blocks and Tags are alists from block and go-tag names to 2-lists of the
+ ;; form (<entry> <continuation>), where <continuation> is the continuation to
+ ;; exit to, and <entry> is the corresponding Entry node.
+ (blocks nil :type list)
+ (tags nil :type list)
+ ;; An alist (Thing . CType) which is used to keep track of "pervasive" type
+ ;; declarations. When Thing is a leaf, this is for type declarations that
+ ;; pertain to the type in a syntactic extent which does not correspond to a
+ ;; binding of the affected name. When Thing is a continuation, this is used
+ ;; to track the innermost THE type declaration.
+ (type-restrictions nil :type list)
+ ;; The lexically enclosing lambda, if any.
+ ;;
+ ;; FIXME: This should be :TYPE (OR CLAMBDA NULL), but it was too hard
+ ;; to get CLAMBDA defined in time for the cross-compiler.
+ (lambda nil)
+ ;; The lexically enclosing cleanup, or NIL if none enclosing within Lambda.
+ ;;
+ ;; FIXME: This should be :TYPE (OR CLEANUP NULL), but it was too hard
+ ;; to get CLEANUP defined in time for the cross-compiler.
+ (cleanup nil)
+ ;; The representation of the current OPTIMIZE policy.
+ (cookie *default-cookie* :type cookie)
+ ;; The policy that takes effect in XEPs and related syntax parsing functions.
+ ;; Slots in this cookie may be null to indicate that the normal value in
+ ;; effect.
+ (interface-cookie *default-interface-cookie* :type cookie)
+ ;; an alist of miscellaneous options that are associated with the lexical
+ ;; environment
+ (options nil :type list))
--- /dev/null
+;;;; This file contains the lifetime analysis phase in the compiler.
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!C")
+
+(file-comment
+ "$Header$")
+\f
+;;;; utilities
+
+;;; Link in a global-conflicts structure for TN in Block with Number as the
+;;; LTN number. The conflict is inserted in the per-TN Global-Conflicts thread
+;;; after the TN's Current-Conflict. We change the Current-Conflict to point
+;;; to the new conflict. Since we scan the blocks in reverse DFO, this list is
+;;; automatically built in order. We have to actually scan the current
+;;; Global-TNs for the block in order to keep that thread sorted.
+(defun add-global-conflict (kind tn block number)
+ (declare (type (member :read :write :read-only :live) kind)
+ (type tn tn) (type ir2-block block)
+ (type (or local-tn-number null) number))
+ (let ((new (make-global-conflicts kind tn block number)))
+ (let ((last (tn-current-conflict tn)))
+ (if last
+ (shiftf (global-conflicts-tn-next new)
+ (global-conflicts-tn-next last)
+ new)
+ (shiftf (global-conflicts-tn-next new)
+ (tn-global-conflicts tn)
+ new)))
+ (setf (tn-current-conflict tn) new)
+
+ (insert-block-global-conflict new block))
+ (values))
+
+;;; Do the actual insertion of the conflict New into Block's global conflicts.
+(defun insert-block-global-conflict (new block)
+ (let ((global-num (tn-number (global-conflicts-tn new))))
+ (do ((prev nil conf)
+ (conf (ir2-block-global-tns block)
+ (global-conflicts-next conf)))
+ ((or (null conf)
+ (> (tn-number (global-conflicts-tn conf)) global-num))
+ (if prev
+ (setf (global-conflicts-next prev) new)
+ (setf (ir2-block-global-tns block) new))
+ (setf (global-conflicts-next new) conf))))
+ (values))
+
+;;; Reset the Current-Conflict slot in all packed TNs to point to the head
+;;; of the Global-Conflicts thread.
+(defun reset-current-conflict (component)
+ (do-packed-tns (tn component)
+ (setf (tn-current-conflict tn) (tn-global-conflicts tn))))
+\f
+;;;; pre-pass
+
+;;; Convert TN (currently local) to be a global TN, since we discovered that
+;;; it is referenced in more than one block. We just add a global-conflicts
+;;; structure with a kind derived from the Kill and Live sets.
+(defun convert-to-global (tn)
+ (declare (type tn tn))
+ (let ((block (tn-local tn))
+ (num (tn-local-number tn)))
+ (add-global-conflict
+ (if (zerop (sbit (ir2-block-written block) num))
+ :read-only
+ (if (zerop (sbit (ir2-block-live-out block) num))
+ :write
+ :read))
+ tn block num))
+ (values))
+
+;;; Scan all references to packed TNs in block. We assign LTN numbers to
+;;; each referenced TN, and also build the Kill and Live sets that summarize
+;;; the references to each TN for purposes of lifetime analysis.
+;;;
+;;; It is possible that we will run out of LTN numbers. If this happens,
+;;; then we return the VOP that we were processing at the time we ran out,
+;;; otherwise we return NIL.
+;;;
+;;; If a TN is referenced in more than one block, then we must represent
+;;; references using Global-Conflicts structures. When we first see a TN, we
+;;; assume it will be local. If we see a reference later on in a different
+;;; block, then we go back and fix the TN to global.
+;;;
+;;; We must globalize TNs that have a block other than the current one in
+;;; their Local slot and have no Global-Conflicts. The latter condition is
+;;; necessary because we always set Local and Local-Number when we process a
+;;; reference to a TN, even when the TN is already known to be global.
+;;;
+;;; When we see reference to global TNs during the scan, we add the
+;;; global-conflict as :Read-Only, since we don't know the correct kind until
+;;; we are done scanning the block.
+(defun find-local-references (block)
+ (declare (type ir2-block block))
+ (let ((kill (ir2-block-written block))
+ (live (ir2-block-live-out block))
+ (tns (ir2-block-local-tns block)))
+ (let ((ltn-num (ir2-block-local-tn-count block)))
+ (do ((vop (ir2-block-last-vop block)
+ (vop-prev vop)))
+ ((null vop))
+ (do ((ref (vop-refs vop) (tn-ref-next-ref ref)))
+ ((null ref))
+ (let* ((tn (tn-ref-tn ref))
+ (local (tn-local tn))
+ (kind (tn-kind tn)))
+ (unless (member kind '(:component :environment :constant))
+ (unless (eq local block)
+ (when (= ltn-num local-tn-limit)
+ (return-from find-local-references vop))
+ (when local
+ (unless (tn-global-conflicts tn)
+ (convert-to-global tn))
+ (add-global-conflict :read-only tn block ltn-num))
+
+ (setf (tn-local tn) block)
+ (setf (tn-local-number tn) ltn-num)
+ (setf (svref tns ltn-num) tn)
+ (incf ltn-num))
+
+ (let ((num (tn-local-number tn)))
+ (if (tn-ref-write-p ref)
+ (setf (sbit kill num) 1 (sbit live num) 0)
+ (setf (sbit live num) 1)))))))
+
+ (setf (ir2-block-local-tn-count block) ltn-num)))
+ nil)
+
+;;; Finish up the global conflicts for TNs referenced in Block according to
+;;; the local Kill and Live sets.
+;;;
+;;; We set the kind for TNs already in the global-TNs. If not written at
+;;; all, then is :Read-Only, the default. Must have been referenced somehow,
+;;; or we wouldn't have conflicts for it.
+;;;
+;;; We also iterate over all the local TNs, looking for TNs local to this
+;;; block that are still live at the block beginning, and thus must be global.
+;;; This case is only important when a TN is read in a block but not written in
+;;; any other, since otherwise the write would promote the TN to global. But
+;;; this does happen with various passing-location TNs that are magically
+;;; written. This also serves to propagate the lives of erroneously
+;;; uninitialized TNs so that consistency checks can detect them.
+(defun init-global-conflict-kind (block)
+ (declare (type ir2-block block))
+ (let ((live (ir2-block-live-out block)))
+ (let ((kill (ir2-block-written block)))
+ (do ((conf (ir2-block-global-tns block)
+ (global-conflicts-next conf)))
+ ((null conf))
+ (let ((num (global-conflicts-number conf)))
+ (unless (zerop (sbit kill num))
+ (setf (global-conflicts-kind conf)
+ (if (zerop (sbit live num))
+ :write
+ :read))))))
+
+ (let ((ltns (ir2-block-local-tns block)))
+ (dotimes (i (ir2-block-local-tn-count block))
+ (let ((tn (svref ltns i)))
+ (unless (or (eq tn :more)
+ (tn-global-conflicts tn)
+ (zerop (sbit live i)))
+ (convert-to-global tn))))))
+
+ (values))
+
+(defevent split-ir2-block "Split an IR2 block to meet Local-TN-Limit.")
+
+;;; Move the code after the VOP Lose in 2block into its own block. The
+;;; block is linked into the emit order following 2block. Number is the block
+;;; number assigned to the new block. We return the new block.
+(defun split-ir2-blocks (2block lose number)
+ (declare (type ir2-block 2block) (type vop lose)
+ (type unsigned-byte number))
+ (event split-ir2-block (vop-node lose))
+ (let ((new (make-ir2-block (ir2-block-block 2block)))
+ (new-start (vop-next lose)))
+ (setf (ir2-block-number new) number)
+ (add-to-emit-order new 2block)
+
+ (do ((vop new-start (vop-next vop)))
+ ((null vop))
+ (setf (vop-block vop) new))
+
+ (setf (ir2-block-start-vop new) new-start)
+ (shiftf (ir2-block-last-vop new) (ir2-block-last-vop 2block) lose)
+
+ (setf (vop-next lose) nil)
+ (setf (vop-prev new-start) nil)
+
+ new))
+
+;;; Clear the global and local conflict info in Block so that we can
+;;; recompute it without any old cruft being retained. It is assumed that all
+;;; LTN numbers are in use.
+;;;
+;;; First we delete all the global conflicts. The conflict we are deleting
+;;; must be the last in the TN's global-conflicts, but we must scan for it in
+;;; order to find the previous conflict.
+;;;
+;;; Next, we scan the local TNs, nulling out the Local slot in all TNs with
+;;; no global conflicts. This allows these TNs to be treated as local when we
+;;; scan the block again.
+;;;
+;;; If there are conflicts, then we set Local to one of the conflicting
+;;; blocks. This ensures that Local doesn't hold over Block as its value,
+;;; causing the subsequent reanalysis to think that the TN has already been
+;;; seen in that block.
+;;;
+;;; This function must not be called on blocks that have :More TNs.
+(defun clear-lifetime-info (block)
+ (declare (type ir2-block block))
+ (setf (ir2-block-local-tn-count block) 0)
+
+ (do ((conf (ir2-block-global-tns block)
+ (global-conflicts-next conf)))
+ ((null conf)
+ (setf (ir2-block-global-tns block) nil))
+ (let ((tn (global-conflicts-tn conf)))
+ (assert (eq (tn-current-conflict tn) conf))
+ (assert (null (global-conflicts-tn-next conf)))
+ (do ((current (tn-global-conflicts tn)
+ (global-conflicts-tn-next current))
+ (prev nil current))
+ ((eq current conf)
+ (if prev
+ (setf (global-conflicts-tn-next prev) nil)
+ (setf (tn-global-conflicts tn) nil))
+ (setf (tn-current-conflict tn) prev)))))
+
+ (fill (ir2-block-written block) 0)
+ (let ((ltns (ir2-block-local-tns block)))
+ (dotimes (i local-tn-limit)
+ (let ((tn (svref ltns i)))
+ (assert (not (eq tn :more)))
+ (let ((conf (tn-global-conflicts tn)))
+ (setf (tn-local tn)
+ (if conf
+ (global-conflicts-block conf)
+ nil))))))
+
+ (values))
+
+;;; This provides a panic mode for assigning LTN numbers when there is a VOP
+;;; with so many more operands that they can't all be assigned distinct
+;;; numbers. When this happens, we recover by assigning all the more operands
+;;; the same LTN number. We can get away with this, since all more args (and
+;;; results) are referenced simultaneously as far as conflict analysis is
+;;; concerned.
+;;;
+;;; Block is the IR2-Block that the more VOP is at the end of. Ops is the
+;;; full argument or result TN-Ref list. Fixed is the types of the fixed
+;;; operands (used only to skip those operands.)
+;;;
+;;; What we do is grab a LTN number, then make a :Read-Only global conflict
+;;; for each more operand TN. We require that there be no existing global
+;;; conflict in Block for any of the operands. Since conflicts must be cleared
+;;; before the first call, this only prohibits the same TN being used both as a
+;;; more operand and as any other operand to the same VOP.
+;;;
+;;; We don't have to worry about getting the correct conflict kind, since
+;;; Init-Global-Conflict-Kind will fix things up. Similarly,
+;;; FIND-LOCAL-REFERENCES will set the local conflict bit corresponding to this
+;;; call.
+;;;
+;;; We also set the Local and Local-Number slots in each TN. It is
+;;; possible that there are no operands in any given call to this function, but
+;;; there had better be either some more args or more results.
+(defun coalesce-more-ltn-numbers (block ops fixed)
+ (declare (type ir2-block block) (type (or tn-ref null) ops) (list fixed))
+ (let ((num (ir2-block-local-tn-count block)))
+ (assert (< num local-tn-limit))
+ (incf (ir2-block-local-tn-count block))
+ (setf (svref (ir2-block-local-tns block) num) :more)
+
+ (do ((op (do ((op ops (tn-ref-across op))
+ (i 0 (1+ i)))
+ ((= i (length fixed)) op)
+ (declare (type index i)))
+ (tn-ref-across op)))
+ ((null op))
+ (let ((tn (tn-ref-tn op)))
+ (assert
+ (flet ((frob (refs)
+ (do ((ref refs (tn-ref-next ref)))
+ ((null ref) t)
+ (when (and (eq (vop-block (tn-ref-vop ref)) block)
+ (not (eq ref op)))
+ (return nil)))))
+ (and (frob (tn-reads tn)) (frob (tn-writes tn))))
+ () "More operand ~S used more than once in its VOP." op)
+ (assert (not (find-in #'global-conflicts-next tn
+ (ir2-block-global-tns block)
+ :key #'global-conflicts-tn)))
+
+ (add-global-conflict :read-only tn block num)
+ (setf (tn-local tn) block)
+ (setf (tn-local-number tn) num))))
+ (values))
+
+(defevent coalesce-more-ltn-numbers
+ "Coalesced LTN numbers for a more operand to meet Local-TN-Limit.")
+
+;;; Loop over the blocks in Component, assigning LTN numbers and recording
+;;; TN birth and death. The only interesting action is when we run out of
+;;; local TN numbers while finding local references.
+;;;
+;;; If we run out of LTN numbers while processing a VOP within the block,
+;;; then we just split off the VOPs we have successfully processed into their
+;;; own block.
+;;;
+;;; If we run out of LTN numbers while processing the our first VOP (the
+;;; last in the block), then it must be the case that this VOP has large more
+;;; operands. We split the VOP into its own block, and then call
+;;; Coalesce-More-Ltn-Numbers to assign all the more args/results the same LTN
+;;; number(s).
+;;;
+;;; In either case, we clear the lifetime information that we computed so
+;;; far, recomputing it after taking corrective action.
+;;;
+;;; Whenever we split a block, we finish the pre-pass on the split-off block
+;;; by doing Find-Local-References and Init-Global-Conflict-Kind. This can't
+;;; run out of LTN numbers.
+(defun lifetime-pre-pass (component)
+ (declare (type component component))
+ (let ((counter -1))
+ (declare (type fixnum counter))
+ (do-blocks-backwards (block component)
+ (let ((2block (block-info block)))
+ (do ((lose (find-local-references 2block)
+ (find-local-references 2block))
+ (last-lose nil lose)
+ (coalesced nil))
+ ((not lose)
+ (init-global-conflict-kind 2block)
+ (setf (ir2-block-number 2block) (incf counter)))
+
+ (clear-lifetime-info 2block)
+
+ (cond
+ ((vop-next lose)
+ (assert (not (eq last-lose lose)))
+ (let ((new (split-ir2-blocks 2block lose (incf counter))))
+ (assert (not (find-local-references new)))
+ (init-global-conflict-kind new)))
+ (t
+ (assert (not (eq lose coalesced)))
+ (setq coalesced lose)
+ (event coalesce-more-ltn-numbers (vop-node lose))
+ (let ((info (vop-info lose))
+ (new (if (vop-prev lose)
+ (split-ir2-blocks 2block (vop-prev lose)
+ (incf counter))
+ 2block)))
+ (coalesce-more-ltn-numbers new (vop-args lose)
+ (vop-info-arg-types info))
+ (coalesce-more-ltn-numbers new (vop-results lose)
+ (vop-info-result-types info))
+ (let ((lose (find-local-references new)))
+ (assert (not lose)))
+ (init-global-conflict-kind new))))))))
+
+ (values))
+\f
+;;;; environment TN stuff
+
+;;; Add a :LIVE global conflict for TN in 2block if there is none present.
+;;; If Debug-P is false (a :ENVIRONMENT TN), then modify any existing conflict
+;;; to be :LIVE.
+(defun setup-environment-tn-conflict (tn 2block debug-p)
+ (declare (type tn tn) (type ir2-block 2block))
+ (let ((block-num (ir2-block-number 2block)))
+ (do ((conf (tn-current-conflict tn) (global-conflicts-tn-next conf))
+ (prev nil conf))
+ ((or (null conf)
+ (> (ir2-block-number (global-conflicts-block conf)) block-num))
+ (setf (tn-current-conflict tn) prev)
+ (add-global-conflict :live tn 2block nil))
+ (when (eq (global-conflicts-block conf) 2block)
+ (unless (or debug-p
+ (eq (global-conflicts-kind conf) :live))
+ (setf (global-conflicts-kind conf) :live)
+ (setf (svref (ir2-block-local-tns 2block)
+ (global-conflicts-number conf))
+ nil)
+ (setf (global-conflicts-number conf) nil))
+ (setf (tn-current-conflict tn) conf)
+ (return))))
+ (values))
+
+;;; Iterate over all the blocks in Env, setting up :LIVE conflicts for TN.
+;;; We make the TN global if it isn't already. The TN must have at least one
+;;; reference.
+(defun setup-environment-tn-conflicts (component tn env debug-p)
+ (declare (type component component) (type tn tn) (type environment env))
+ (when (and debug-p
+ (not (tn-global-conflicts tn))
+ (tn-local tn))
+ (convert-to-global tn))
+ (setf (tn-current-conflict tn) (tn-global-conflicts tn))
+ (do-blocks-backwards (block component)
+ (when (eq (block-environment block) env)
+ (let* ((2block (block-info block))
+ (last (do ((b (ir2-block-next 2block) (ir2-block-next b))
+ (prev 2block b))
+ ((not (eq (ir2-block-block b) block))
+ prev))))
+ (do ((b last (ir2-block-prev b)))
+ ((not (eq (ir2-block-block b) block)))
+ (setup-environment-tn-conflict tn b debug-p)))))
+ (values))
+
+;;; Iterate over all the environment TNs, adding always-live conflicts as
+;;; appropriate.
+(defun setup-environment-live-conflicts (component)
+ (declare (type component component))
+ (dolist (fun (component-lambdas component))
+ (let* ((env (lambda-environment fun))
+ (2env (environment-info env)))
+ (dolist (tn (ir2-environment-live-tns 2env))
+ (setup-environment-tn-conflicts component tn env nil))
+ (dolist (tn (ir2-environment-debug-live-tns 2env))
+ (setup-environment-tn-conflicts component tn env t))))
+ (values))
+
+;;; Convert a :NORMAL or :DEBUG-ENVIRONMENT TN to an :ENVIRONMENT TN. This
+;;; requires adding :LIVE conflicts to all blocks in TN-ENV.
+(defun convert-to-environment-tn (tn tn-env)
+ (declare (type tn tn) (type environment tn-env))
+ (assert (member (tn-kind tn) '(:normal :debug-environment)))
+ (when (eq (tn-kind tn) :debug-environment)
+ (assert (eq (tn-environment tn) tn-env))
+ (let ((2env (environment-info tn-env)))
+ (setf (ir2-environment-debug-live-tns 2env)
+ (delete tn (ir2-environment-debug-live-tns 2env)))))
+ (setup-environment-tn-conflicts *component-being-compiled* tn tn-env nil)
+ (setf (tn-local tn) nil)
+ (setf (tn-local-number tn) nil)
+ (setf (tn-kind tn) :environment)
+ (setf (tn-environment tn) tn-env)
+ (push tn (ir2-environment-live-tns (environment-info tn-env)))
+ (values))
+\f
+;;;; flow analysis
+
+;;; For each Global-TN in Block2 that is :Live, :Read or :Read-Only, ensure
+;;; that there is a corresponding Global-Conflict in Block1. If there is none,
+;;; make a :Live Global-Conflict. If there is a :Read-Only conflict, promote
+;;; it to :Live.
+;;;
+;;; If we did added a new conflict, return true, otherwise false. We don't
+;;; need to return true when we promote a :Read-Only conflict, since it doesn't
+;;; reveal any new information to predecessors of Block1.
+;;;
+;;; We use the Tn-Current-Conflict to walk through the global
+;;; conflicts. Since the global conflicts for a TN are ordered by block, we
+;;; can be sure that the Current-Conflict always points at or before the block
+;;; that we are looking at. This allows us to quickly determine if there is a
+;;; global conflict for a given TN in Block1.
+;;;
+;;; When we scan down the conflicts, we know that there must be at least one
+;;; conflict for TN, since we got our hands on TN by picking it out of a
+;;; conflict in Block2.
+;;;
+;;; We leave the Current-Conflict pointing to the conflict for Block1. The
+;;; Current-Conflict must be initialized to the head of the Global-Conflicts
+;;; for the TN between each flow analysis iteration.
+(defun propagate-live-tns (block1 block2)
+ (declare (type ir2-block block1 block2))
+ (let ((live-in (ir2-block-live-in block1))
+ (did-something nil))
+ (do ((conf2 (ir2-block-global-tns block2)
+ (global-conflicts-next conf2)))
+ ((null conf2))
+ (ecase (global-conflicts-kind conf2)
+ ((:live :read :read-only)
+ (let* ((tn (global-conflicts-tn conf2))
+ (tn-conflicts (tn-current-conflict tn))
+ (number1 (ir2-block-number block1)))
+ (assert tn-conflicts)
+ (do ((current tn-conflicts (global-conflicts-tn-next current))
+ (prev nil current))
+ ((or (null current)
+ (> (ir2-block-number (global-conflicts-block current))
+ number1))
+ (setf (tn-current-conflict tn) prev)
+ (add-global-conflict :live tn block1 nil)
+ (setq did-something t))
+ (when (eq (global-conflicts-block current) block1)
+ (case (global-conflicts-kind current)
+ (:live)
+ (:read-only
+ (setf (global-conflicts-kind current) :live)
+ (setf (svref (ir2-block-local-tns block1)
+ (global-conflicts-number current))
+ nil)
+ (setf (global-conflicts-number current) nil)
+ (setf (tn-current-conflict tn) current))
+ (t
+ (setf (sbit live-in (global-conflicts-number current)) 1)))
+ (return)))))
+ (:write)))
+ did-something))
+
+;;; Do backward global flow analysis to find all TNs live at each block
+;;; boundary.
+(defun lifetime-flow-analysis (component)
+ (loop
+ (reset-current-conflict component)
+ (let ((did-something nil))
+ (do-blocks-backwards (block component)
+ (let* ((2block (block-info block))
+ (last (do ((b (ir2-block-next 2block) (ir2-block-next b))
+ (prev 2block b))
+ ((not (eq (ir2-block-block b) block))
+ prev))))
+
+ (dolist (b (block-succ block))
+ (when (and (block-start b)
+ (propagate-live-tns last (block-info b)))
+ (setq did-something t)))
+
+ (do ((b (ir2-block-prev last) (ir2-block-prev b))
+ (prev last b))
+ ((not (eq (ir2-block-block b) block)))
+ (when (propagate-live-tns b prev)
+ (setq did-something t)))))
+
+ (unless did-something (return))))
+
+ (values))
+\f
+;;;; post-pass
+
+;;; Note that TN conflicts with all current live TNs. Num is TN's LTN
+;;; number. We bit-ior Live-Bits with TN's Local-Conflicts, and set TN's
+;;; number in the conflicts of all TNs in Live-List.
+(defun note-conflicts (live-bits live-list tn num)
+ (declare (type tn tn) (type (or tn null) live-list)
+ (type local-tn-bit-vector live-bits)
+ (type local-tn-number num))
+ (let ((lconf (tn-local-conflicts tn)))
+ (bit-ior live-bits lconf lconf))
+ (do ((live live-list (tn-next* live)))
+ ((null live))
+ (setf (sbit (tn-local-conflicts live) num) 1))
+ (values))
+
+;;; Compute a bit vector of the TNs live after VOP that aren't results.
+(defun compute-save-set (vop live-bits)
+ (declare (type vop vop) (type local-tn-bit-vector live-bits))
+ (let ((live (bit-vector-copy live-bits)))
+ (do ((r (vop-results vop) (tn-ref-across r)))
+ ((null r))
+ (let ((tn (tn-ref-tn r)))
+ (ecase (tn-kind tn)
+ ((:normal :debug-environment)
+ (setf (sbit live (tn-local-number tn)) 0))
+ (:environment :component))))
+ live))
+
+;;; Used to determine whether a :DEBUG-ENVIRONMENT TN should be considered
+;;; live at block end. We return true if a VOP with non-null SAVE-P appears
+;;; before the first read of TN (hence is seen first in our backward scan.)
+(defun saved-after-read (tn block)
+ (do ((vop (ir2-block-last-vop block) (vop-prev vop)))
+ ((null vop) t)
+ (when (vop-info-save-p (vop-info vop)) (return t))
+ (when (find-in #'tn-ref-across tn (vop-args vop) :key #'tn-ref-tn)
+ (return nil))))
+
+;;; If the block has no successors, or its successor is the component tail,
+;;; then all :DEBUG-ENVIRONMENT TNs are always added, regardless of whether
+;;; they appeared to be live. This ensures that these TNs are considered to be
+;;; live throughout blocks that read them, but don't have any interesting
+;;; successors (such as a return or tail call.) In this case, we set the
+;;; corresponding bit in LIVE-IN as well.
+(defun make-debug-environment-tns-live (block live-bits live-list)
+ (let* ((1block (ir2-block-block block))
+ (live-in (ir2-block-live-in block))
+ (succ (block-succ 1block))
+ (next (ir2-block-next block)))
+ (when (and next
+ (not (eq (ir2-block-block next) 1block))
+ (or (null succ)
+ (eq (first succ)
+ (component-tail (block-component 1block)))))
+ (do ((conf (ir2-block-global-tns block)
+ (global-conflicts-next conf)))
+ ((null conf))
+ (let* ((tn (global-conflicts-tn conf))
+ (num (global-conflicts-number conf)))
+ (when (and num (zerop (sbit live-bits num))
+ (eq (tn-kind tn) :debug-environment)
+ (eq (tn-environment tn) (block-environment 1block))
+ (saved-after-read tn block))
+ (note-conflicts live-bits live-list tn num)
+ (setf (sbit live-bits num) 1)
+ (push-in tn-next* tn live-list)
+ (setf (sbit live-in num) 1))))))
+
+ (values live-bits live-list))
+
+;;; Return as values, a LTN bit-vector and a list (threaded by TN-Next*)
+;;; representing the TNs live at the end of Block (exclusive of :Live TNs).
+;;;
+;;; We iterate over the TNs in the global conflicts that are live at the block
+;;; end, setting up the TN-Local-Conflicts and TN-Local-Number, and adding the
+;;; TN to the live list.
+;;;
+;;; If a :MORE result is not live, we effectively fake a read to it. This is
+;;; part of the action described in ENSURE-RESULTS-LIVE.
+;;;
+;;; At the end, we call MAKE-DEBUG-ENVIRONEMNT-TNS-LIVE to make debug
+;;; environment TNs appear live when appropriate, even when they aren't.
+;;;
+;;; ### Note: we alias the global-conflicts-conflicts here as the
+;;; tn-local-conflicts.
+(defun compute-initial-conflicts (block)
+ (declare (type ir2-block block))
+ (let* ((live-in (ir2-block-live-in block))
+ (ltns (ir2-block-local-tns block))
+ (live-bits (bit-vector-copy live-in))
+ (live-list nil))
+
+ (do ((conf (ir2-block-global-tns block)
+ (global-conflicts-next conf)))
+ ((null conf))
+ (let ((bits (global-conflicts-conflicts conf))
+ (tn (global-conflicts-tn conf))
+ (num (global-conflicts-number conf))
+ (kind (global-conflicts-kind conf)))
+ (setf (tn-local-number tn) num)
+ (unless (eq kind :live)
+ (cond ((not (zerop (sbit live-bits num)))
+ (bit-vector-replace bits live-bits)
+ (setf (sbit bits num) 0)
+ (push-in tn-next* tn live-list))
+ ((and (eq (svref ltns num) :more)
+ (eq kind :write))
+ (note-conflicts live-bits live-list tn num)
+ (setf (sbit live-bits num) 1)
+ (push-in tn-next* tn live-list)
+ (setf (sbit live-in num) 1)))
+
+ (setf (tn-local-conflicts tn) bits))))
+
+ (make-debug-environment-tns-live block live-bits live-list)))
+
+;;; A function called in Conflict-Analyze-1-Block when we have a VOP with
+;;; SAVE-P true. We compute the save-set, and if :FORCE-TO-STACK, force all
+;;; the live TNs to be stack environment TNs.
+(defun do-save-p-stuff (vop block live-bits)
+ (declare (type vop vop) (type ir2-block block)
+ (type local-tn-bit-vector live-bits))
+ (let ((ss (compute-save-set vop live-bits)))
+ (setf (vop-save-set vop) ss)
+ (when (eq (vop-info-save-p (vop-info vop)) :force-to-stack)
+ (do-live-tns (tn ss block)
+ (unless (eq (tn-kind tn) :component)
+ (force-tn-to-stack tn)
+ (unless (eq (tn-kind tn) :environment)
+ (convert-to-environment-tn
+ tn
+ (block-environment (ir2-block-block block))))))))
+ (values))
+
+;;; FIXME: The next 3 macros aren't needed in the target runtime.
+;;; Figure out some way to make them only at build time. (Just
+;;; (EVAL-WHEN (:COMPILE-TOPLEVEL :EXECUTE) (DEFMACRO ..)) isn't good enough,
+;;; since we need CL:DEFMACRO at build-the-cross-compiler time and
+;;; SB!XC:DEFMACRO at run-the-cross-compiler time.)
+
+;;; Used in SCAN-VOP-REFS to simultaneously do something to all of the TNs
+;;; referenced by a big more arg. We have to treat these TNs specially, since
+;;; when we set or clear the bit in the live TNs, the represents a change in
+;;; the liveness of all the more TNs. If we iterated as normal, the next more
+;;; ref would be thought to be not live when it was, etc. We update Ref to be
+;;; the last :more ref we scanned, so that the main loop will step to the next
+;;; non-more ref.
+(defmacro frob-more-tns (action)
+ `(when (eq (svref ltns num) :more)
+ (let ((prev ref))
+ (do ((mref (tn-ref-next-ref ref) (tn-ref-next-ref mref)))
+ ((null mref))
+ (let ((mtn (tn-ref-tn mref)))
+ (unless (eql (tn-local-number mtn) num)
+ (return))
+ ,action)
+ (setq prev mref))
+ (setq ref prev))))
+
+;;; Handle the part of CONFLICT-ANALYZE-1-BLOCK that scans the REFs for the
+;;; current VOP. This macro shamelessly references free variables in C-A-1-B.
+(defmacro scan-vop-refs ()
+ '(do ((ref (vop-refs vop) (tn-ref-next-ref ref)))
+ ((null ref))
+ (let* ((tn (tn-ref-tn ref))
+ (num (tn-local-number tn)))
+ (cond
+ ((not num))
+ ((not (zerop (sbit live-bits num)))
+ (when (tn-ref-write-p ref)
+ (setf (sbit live-bits num) 0)
+ (deletef-in tn-next* live-list tn)
+ (frob-more-tns (deletef-in tn-next* live-list mtn))))
+ (t
+ (assert (not (tn-ref-write-p ref)))
+ (note-conflicts live-bits live-list tn num)
+ (frob-more-tns (note-conflicts live-bits live-list mtn num))
+ (setf (sbit live-bits num) 1)
+ (push-in tn-next* tn live-list)
+ (frob-more-tns (push-in tn-next* mtn live-list)))))))
+
+;;; This macro is called by CONFLICT-ANALYZE-1-BLOCK to scan the current
+;;; VOP's results, and make any dead ones live. This is necessary, since even
+;;; though a result is dead after the VOP, it may be in use for an extended
+;;; period within the VOP (especially if it has :FROM specified.) During this
+;;; interval, temporaries must be noted to conflict with the result. More
+;;; results are finessed in COMPUTE-INITIAL-CONFLICTS, so we ignore them here.
+(defmacro ensure-results-live ()
+ '(do ((res (vop-results vop) (tn-ref-across res)))
+ ((null res))
+ (let* ((tn (tn-ref-tn res))
+ (num (tn-local-number tn)))
+ (when (and num (zerop (sbit live-bits num)))
+ (unless (eq (svref ltns num) :more)
+ (note-conflicts live-bits live-list tn num)
+ (setf (sbit live-bits num) 1)
+ (push-in tn-next* tn live-list))))))
+
+;;; Compute the block-local conflict information for Block. We iterate over
+;;; all the TN-Refs in a block in reference order, maintaining the set of live
+;;; TNs in both a list and a bit-vector representation.
+(defun conflict-analyze-1-block (block)
+ (declare (type ir2-block block))
+ (multiple-value-bind (live-bits live-list)
+ (compute-initial-conflicts block)
+ (let ((ltns (ir2-block-local-tns block)))
+ (do ((vop (ir2-block-last-vop block)
+ (vop-prev vop)))
+ ((null vop))
+ (when (vop-info-save-p (vop-info vop))
+ (do-save-p-stuff vop block live-bits))
+ (ensure-results-live)
+ (scan-vop-refs)))))
+
+;;; Conflict analyze each block, and also add it.
+(defun lifetime-post-pass (component)
+ (declare (type component component))
+ (do-ir2-blocks (block component)
+ (conflict-analyze-1-block block)))
+\f
+;;;; alias TN stuff
+
+;;; Destructively modify Oconf to include the conflict information in Conf.
+(defun merge-alias-block-conflicts (conf oconf)
+ (declare (type global-conflicts conf oconf))
+ (let* ((kind (global-conflicts-kind conf))
+ (num (global-conflicts-number conf))
+ (okind (global-conflicts-kind oconf))
+ (onum (global-conflicts-number oconf))
+ (block (global-conflicts-block oconf))
+ (ltns (ir2-block-local-tns block)))
+ (cond
+ ((eq okind :live))
+ ((eq kind :live)
+ (setf (global-conflicts-kind oconf) :live)
+ (setf (svref ltns onum) nil)
+ (setf (global-conflicts-number oconf) nil))
+ (t
+ (unless (eq kind okind)
+ (setf (global-conflicts-kind oconf) :read))
+ ;; Make original conflict with all the local TNs the alias conflicted
+ ;; with.
+ (bit-ior (global-conflicts-conflicts oconf)
+ (global-conflicts-conflicts conf)
+ t)
+ (flet ((frob (x)
+ (unless (zerop (sbit x num))
+ (setf (sbit x onum) 1))))
+ ;; Make all the local TNs that conflicted with the alias conflict
+ ;; with the original.
+ (dotimes (i (ir2-block-local-tn-count block))
+ (let ((tn (svref ltns i)))
+ (when (and tn (not (eq tn :more))
+ (null (tn-global-conflicts tn)))
+ (frob (tn-local-conflicts tn)))))
+ ;; Same for global TNs...
+ (do ((current (ir2-block-global-tns block)
+ (global-conflicts-next current)))
+ ((null current))
+ (unless (eq (global-conflicts-kind current) :live)
+ (frob (global-conflicts-conflicts current))))
+ ;; Make the original TN live everywhere that the alias was live.
+ (frob (ir2-block-written block))
+ (frob (ir2-block-live-in block))
+ (frob (ir2-block-live-out block))
+ (do ((vop (ir2-block-start-vop block)
+ (vop-next vop)))
+ ((null vop))
+ (let ((sset (vop-save-set vop)))
+ (when sset (frob sset)))))))
+ ;; Delete the alias's conflict info.
+ (when num
+ (setf (svref ltns num) nil))
+ (deletef-in global-conflicts-next (ir2-block-global-tns block) conf))
+
+ (values))
+
+;;; Co-opt Conf to be a conflict for TN.
+(defun change-global-conflicts-tn (conf new)
+ (declare (type global-conflicts conf) (type tn new))
+ (setf (global-conflicts-tn conf) new)
+ (let ((ltn-num (global-conflicts-number conf))
+ (block (global-conflicts-block conf)))
+ (deletef-in global-conflicts-next (ir2-block-global-tns block) conf)
+ (setf (global-conflicts-next conf) nil)
+ (insert-block-global-conflict conf block)
+ (when ltn-num
+ (setf (svref (ir2-block-local-tns block) ltn-num) new)))
+ (values))
+
+;;; Do CONVERT-TO-GLOBAL on TN if it has no global conflicts. Copy the
+;;; local conflicts into the global bit vector.
+(defun ensure-global-tn (tn)
+ (declare (type tn tn))
+ (cond ((tn-global-conflicts tn))
+ ((tn-local tn)
+ (convert-to-global tn)
+ (bit-ior (global-conflicts-conflicts (tn-global-conflicts tn))
+ (tn-local-conflicts tn)
+ t))
+ (t
+ (assert (and (null (tn-reads tn)) (null (tn-writes tn))))))
+ (values))
+
+;;; For each :ALIAS TN, destructively merge the conflict info into the
+;;; original TN and replace the uses of the alias.
+;;;
+;;; For any block that uses only the alias TN, just insert that conflict into
+;;; the conflicts for the original TN, changing the LTN map to refer to the
+;;; original TN. This gives a result indistinguishable from the what there
+;;; would have been if the original TN had always been referenced. This leaves
+;;; no sign that an alias TN was ever involved.
+;;;
+;;; If a block has references to both the alias and the original TN, then we
+;;; call MERGE-ALIAS-BLOCK-CONFLICTS to combine the conflicts into the original
+;;; conflict.
+(defun merge-alias-conflicts (component)
+ (declare (type component component))
+ (do ((tn (ir2-component-alias-tns (component-info component))
+ (tn-next tn)))
+ ((null tn))
+ (let ((original (tn-save-tn tn)))
+ (ensure-global-tn tn)
+ (ensure-global-tn original)
+ (let ((conf (tn-global-conflicts tn))
+ (oconf (tn-global-conflicts original))
+ (oprev nil))
+ (loop
+ (unless oconf
+ (if oprev
+ (setf (global-conflicts-tn-next oprev) conf)
+ (setf (tn-global-conflicts original) conf))
+ (do ((current conf (global-conflicts-tn-next current)))
+ ((null current))
+ (change-global-conflicts-tn current original))
+ (return))
+ (let* ((block (global-conflicts-block conf))
+ (num (ir2-block-number block))
+ (onum (ir2-block-number (global-conflicts-block oconf))))
+
+ (cond ((< onum num)
+ (shiftf oprev oconf (global-conflicts-tn-next oconf)))
+ ((> onum num)
+ (if oprev
+ (setf (global-conflicts-tn-next oprev) conf)
+ (setf (tn-global-conflicts original) conf))
+ (change-global-conflicts-tn conf original)
+ (shiftf oprev conf (global-conflicts-tn-next conf) oconf))
+ (t
+ (merge-alias-block-conflicts conf oconf)
+ (shiftf oprev oconf (global-conflicts-tn-next oconf))
+ (setf conf (global-conflicts-tn-next conf)))))
+ (unless conf (return))))
+
+ (flet ((frob (refs)
+ (let ((ref refs)
+ (next nil))
+ (loop
+ (unless ref (return))
+ (setq next (tn-ref-next ref))
+ (change-tn-ref-tn ref original)
+ (setq ref next)))))
+ (frob (tn-reads tn))
+ (frob (tn-writes tn)))
+ (setf (tn-global-conflicts tn) nil)))
+
+ (values))
+\f
+(defun lifetime-analyze (component)
+ (lifetime-pre-pass component)
+ (setup-environment-live-conflicts component)
+ (lifetime-flow-analysis component)
+ (lifetime-post-pass component)
+ (merge-alias-conflicts component))
+\f
+;;;; conflict testing
+
+;;; Test for a conflict between the local TN X and the global TN Y. We just
+;;; look for a global conflict of Y in X's block, and then test for conflict in
+;;; that block.
+;;; [### Might be more efficient to scan Y's global conflicts. This depends on
+;;; whether there are more global TNs than blocks.]
+(defun tns-conflict-local-global (x y)
+ (let ((block (tn-local x)))
+ (do ((conf (ir2-block-global-tns block)
+ (global-conflicts-next conf)))
+ ((null conf) nil)
+ (when (eq (global-conflicts-tn conf) y)
+ (let ((num (global-conflicts-number conf)))
+ (return (or (not num)
+ (not (zerop (sbit (tn-local-conflicts x)
+ num))))))))))
+
+;;; Test for conflict between two global TNs X and Y.
+(defun tns-conflict-global-global (x y)
+ (declare (type tn x y))
+ (let* ((x-conf (tn-global-conflicts x))
+ (x-num (ir2-block-number (global-conflicts-block x-conf)))
+ (y-conf (tn-global-conflicts y))
+ (y-num (ir2-block-number (global-conflicts-block y-conf))))
+
+ (macrolet ((advance (n c)
+ `(progn
+ (setq ,c (global-conflicts-tn-next ,c))
+ (unless ,c (return-from tns-conflict-global-global nil))
+ (setq ,n (ir2-block-number (global-conflicts-block ,c)))))
+ (scan (g l lc)
+ `(do ()
+ ((>= ,g ,l))
+ (advance ,l ,lc))))
+
+ (loop
+ ;; x-conf, y-conf true, x-num, y-num corresponding block numbers.
+ (scan x-num y-num y-conf)
+ (scan y-num x-num x-conf)
+ (when (= x-num y-num)
+ (let ((ltn-num-x (global-conflicts-number x-conf)))
+ (unless (and ltn-num-x
+ (global-conflicts-number y-conf)
+ (zerop (sbit (global-conflicts-conflicts y-conf)
+ ltn-num-x)))
+ (return t))
+ (advance x-num x-conf)
+ (advance y-num y-conf)))))))
+
+;;; Return true if X and Y are distinct and the lifetimes of X and Y overlap
+;;; at any point.
+(defun tns-conflict (x y)
+ (declare (type tn x y))
+ (let ((x-kind (tn-kind x))
+ (y-kind (tn-kind y)))
+ (cond ((eq x y) nil)
+ ((or (eq x-kind :component) (eq y-kind :component)) t)
+ ((tn-global-conflicts x)
+ (if (tn-global-conflicts y)
+ (tns-conflict-global-global x y)
+ (tns-conflict-local-global y x)))
+ ((tn-global-conflicts y)
+ (tns-conflict-local-global x y))
+ (t
+ (and (eq (tn-local x) (tn-local y))
+ (not (zerop (sbit (tn-local-conflicts x)
+ (tn-local-number y)))))))))
--- /dev/null
+;;;; This file implements local call analysis. A local call is a
+;;;; function call between functions being compiled at the same time.
+;;;; If we can tell at compile time that such a call is legal, then we
+;;;; change the combination to call the correct lambda, mark it as
+;;;; local, and add this link to our call graph. Once a call is local,
+;;;; it is then eligible for let conversion, which places the body of
+;;;; the function inline.
+;;;;
+;;;; We cannot always do a local call even when we do have the
+;;;; function being called. Calls that cannot be shown to have legal
+;;;; arg counts are not converted.
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!C")
+
+(file-comment
+ "$Header$")
+
+;;; This function propagates information from the variables in the function
+;;; Fun to the actual arguments in Call. This is also called by the VALUES IR1
+;;; optimizer when it sleazily converts MV-BINDs to LETs.
+;;;
+;;; We flush all arguments to Call that correspond to unreferenced variables
+;;; in Fun. We leave NILs in the Combination-Args so that the remaining args
+;;; still match up with their vars.
+;;;
+;;; We also apply the declared variable type assertion to the argument
+;;; continuations.
+(defun propagate-to-args (call fun)
+ (declare (type combination call) (type clambda fun))
+ (do ((args (basic-combination-args call) (cdr args))
+ (vars (lambda-vars fun) (cdr vars)))
+ ((null args))
+ (let ((arg (car args))
+ (var (car vars)))
+ (cond ((leaf-refs var)
+ (assert-continuation-type arg (leaf-type var)))
+ (t
+ (flush-dest arg)
+ (setf (car args) nil)))))
+
+ (values))
+
+;;; This function handles merging the tail sets if Call is potentially
+;;; tail-recursive, and is a call to a function with a different TAIL-SET than
+;;; Call's Fun. This must be called whenever we alter IR1 so as to place a
+;;; local call in what might be a TR context. Note that any call which returns
+;;; its value to a RETURN is considered potentially TR, since any implicit
+;;; MV-PROG1 might be optimized away.
+;;;
+;;; We destructively modify the set for the calling function to represent both,
+;;; and then change all the functions in callee's set to reference the first.
+;;; If we do merge, we reoptimize the RETURN-RESULT continuation to cause
+;;; IR1-OPTIMIZE-RETURN to recompute the tail set type.
+(defun merge-tail-sets (call &optional (new-fun (combination-lambda call)))
+ (declare (type basic-combination call) (type clambda new-fun))
+ (let ((return (continuation-dest (node-cont call))))
+ (when (return-p return)
+ (let ((call-set (lambda-tail-set (node-home-lambda call)))
+ (fun-set (lambda-tail-set new-fun)))
+ (unless (eq call-set fun-set)
+ (let ((funs (tail-set-functions fun-set)))
+ (dolist (fun funs)
+ (setf (lambda-tail-set fun) call-set))
+ (setf (tail-set-functions call-set)
+ (nconc (tail-set-functions call-set) funs)))
+ (reoptimize-continuation (return-result return))
+ t)))))
+
+;;; Convert a combination into a local call. We PROPAGATE-TO-ARGS, set
+;;; the combination kind to :LOCAL, add FUN to the CALLS of the
+;;; function that the call is in, call MERGE-TAIL-SETS, then replace
+;;; the function in the REF node with the new function.
+;;;
+;;; We change the REF last, since changing the reference can trigger
+;;; LET conversion of the new function, but will only do so if the
+;;; call is local. Note that the replacement may trigger LET
+;;; conversion or other changes in IR1. We must call MERGE-TAIL-SETS
+;;; with NEW-FUN before the substitution, since after the substitution
+;;; (and LET conversion), the call may no longer be recognizable as
+;;; tail-recursive.
+(defun convert-call (ref call fun)
+ (declare (type ref ref) (type combination call) (type clambda fun))
+ (propagate-to-args call fun)
+ (setf (basic-combination-kind call) :local)
+ (pushnew fun (lambda-calls (node-home-lambda call)))
+ (merge-tail-sets call fun)
+ (change-ref-leaf ref fun)
+ (values))
+\f
+;;;; external entry point creation
+
+;;; Return a Lambda form that can be used as the definition of the XEP for Fun.
+;;;
+;;; If Fun is a lambda, then we check the number of arguments (conditional
+;;; on policy) and call Fun with all the arguments.
+;;;
+;;; If Fun is an Optional-Dispatch, then we dispatch off of the number of
+;;; supplied arguments by doing do an = test for each entry-point, calling the
+;;; entry with the appropriate prefix of the passed arguments.
+;;;
+;;; If there is a more arg, then there are a couple of optimizations that we
+;;; make (more for space than anything else):
+;;; -- If Min-Args is 0, then we make the more entry a T clause, since no
+;;; argument count error is possible.
+;;; -- We can omit the = clause for the last entry-point, allowing the case of
+;;; 0 more args to fall through to the more entry.
+;;;
+;;; We don't bother to policy conditionalize wrong arg errors in optional
+;;; dispatches, since the additional overhead is negligible compared to the
+;;; other hair going down.
+;;;
+;;; Note that if policy indicates it, argument type declarations in Fun will
+;;; be verified. Since nothing is known about the type of the XEP arg vars,
+;;; type checks will be emitted when the XEP's arg vars are passed to the
+;;; actual function.
+(defun make-xep-lambda (fun)
+ (declare (type functional fun))
+ (etypecase fun
+ (clambda
+ (let ((nargs (length (lambda-vars fun)))
+ (n-supplied (gensym)))
+ (collect ((temps))
+ (dotimes (i nargs)
+ (temps (gensym)))
+ `(lambda (,n-supplied ,@(temps))
+ (declare (type index ,n-supplied))
+ ,(if (policy nil (zerop safety))
+ `(declare (ignore ,n-supplied))
+ `(%verify-argument-count ,n-supplied ,nargs))
+ (%funcall ,fun ,@(temps))))))
+ (optional-dispatch
+ (let* ((min (optional-dispatch-min-args fun))
+ (max (optional-dispatch-max-args fun))
+ (more (optional-dispatch-more-entry fun))
+ (n-supplied (gensym)))
+ (collect ((temps)
+ (entries))
+ (dotimes (i max)
+ (temps (gensym)))
+
+ (do ((eps (optional-dispatch-entry-points fun) (rest eps))
+ (n min (1+ n)))
+ ((null eps))
+ (entries `((= ,n-supplied ,n)
+ (%funcall ,(first eps) ,@(subseq (temps) 0 n)))))
+
+ `(lambda (,n-supplied ,@(temps))
+ ;; FIXME: Make sure that INDEX type distinguishes between target
+ ;; and host. (Probably just make the SB!XC:DEFTYPE different from
+ ;; CL:DEFTYPE.)
+ (declare (type index ,n-supplied))
+ (cond
+ ,@(if more (butlast (entries)) (entries))
+ ,@(when more
+ `((,(if (zerop min) 't `(>= ,n-supplied ,max))
+ ,(let ((n-context (gensym))
+ (n-count (gensym)))
+ `(multiple-value-bind (,n-context ,n-count)
+ (%more-arg-context ,n-supplied ,max)
+ (%funcall ,more ,@(temps) ,n-context ,n-count))))))
+ (t
+ (%argument-count-error ,n-supplied)))))))))
+
+;;; Make an external entry point (XEP) for Fun and return it. We
+;;; convert the result of Make-XEP-Lambda in the correct environment,
+;;; then associate this lambda with Fun as its XEP. After the
+;;; conversion, we iterate over the function's associated lambdas,
+;;; redoing local call analysis so that the XEP calls will get
+;;; converted. We also bind *LEXENV* to change the compilation policy
+;;; over to the interface policy.
+;;;
+;;; We set Reanalyze and Reoptimize in the component, just in case we
+;;; discover an XEP after the initial local call analyze pass.
+(defun make-external-entry-point (fun)
+ (declare (type functional fun))
+ (assert (not (functional-entry-function fun)))
+ (with-ir1-environment (lambda-bind (main-entry fun))
+ (let* ((*lexenv* (make-lexenv :cookie (make-interface-cookie *lexenv*)))
+ (res (ir1-convert-lambda (make-xep-lambda fun))))
+ (setf (functional-kind res) :external)
+ (setf (leaf-ever-used res) t)
+ (setf (functional-entry-function res) fun)
+ (setf (functional-entry-function fun) res)
+ (setf (component-reanalyze *current-component*) t)
+ (setf (component-reoptimize *current-component*) t)
+ (etypecase fun
+ (clambda (local-call-analyze-1 fun))
+ (optional-dispatch
+ (dolist (ep (optional-dispatch-entry-points fun))
+ (local-call-analyze-1 ep))
+ (when (optional-dispatch-more-entry fun)
+ (local-call-analyze-1 (optional-dispatch-more-entry fun)))))
+ res)))
+
+;;; Notice a Ref that is not in a local-call context. If the Ref is
+;;; already to an XEP, then do nothing, otherwise change it to the
+;;; XEP, making an XEP if necessary.
+;;;
+;;; If Ref is to a special :Cleanup or :Escape function, then we treat
+;;; it as though it was not an XEP reference (i.e. leave it alone.)
+(defun reference-entry-point (ref)
+ (declare (type ref ref))
+ (let ((fun (ref-leaf ref)))
+ (unless (or (external-entry-point-p fun)
+ (member (functional-kind fun) '(:escape :cleanup)))
+ (change-ref-leaf ref (or (functional-entry-function fun)
+ (make-external-entry-point fun))))))
+\f
+;;; Attempt to convert all references to Fun to local calls. The
+;;; reference must be the function for a call, and the function
+;;; continuation must be used only once, since otherwise we cannot be
+;;; sure what function is to be called. The call continuation would be
+;;; multiply used if there is hairy stuff such as conditionals in the
+;;; expression that computes the function.
+;;;
+;;; If we cannot convert a reference, then we mark the referenced
+;;; function as an entry-point, creating a new XEP if necessary. We
+;;; don't try to convert calls that are in error (:ERROR kind.)
+;;;
+;;; This is broken off from Local-Call-Analyze so that people can
+;;; force analysis of newly introduced calls. Note that we don't do
+;;; LET conversion here.
+(defun local-call-analyze-1 (fun)
+ (declare (type functional fun))
+ (let ((refs (leaf-refs fun))
+ (first-time t))
+ (dolist (ref refs)
+ (let* ((cont (node-cont ref))
+ (dest (continuation-dest cont)))
+ (cond ((and (basic-combination-p dest)
+ (eq (basic-combination-fun dest) cont)
+ (eq (continuation-use cont) ref))
+
+ (convert-call-if-possible ref dest)
+
+ (unless (eq (basic-combination-kind dest) :local)
+ (reference-entry-point ref)))
+ (t
+ (reference-entry-point ref))))
+ (setq first-time nil)))
+
+ (values))
+
+;;; We examine all New-Functions in component, attempting to convert
+;;; calls into local calls when it is legal. We also attempt to
+;;; convert each lambda to a LET. LET conversion is also triggered by
+;;; deletion of a function reference, but functions that start out
+;;; eligible for conversion must be noticed sometime.
+;;;
+;;; Note that there is a lot of action going on behind the scenes
+;;; here, triggered by reference deletion. In particular, the
+;;; COMPONENT-LAMBDAS are being hacked to remove newly deleted and let
+;;; converted lambdas, so it is important that the lambda is added to
+;;; the COMPONENT-LAMBDAS when it is. Also, the
+;;; COMPONENT-NEW-FUNCTIONS may contain all sorts of drivel, since it
+;;; is not updated when we delete functions, etc. Only
+;;; COMPONENT-LAMBDAS is updated.
+;;;
+;;; COMPONENT-REANALYZE-FUNCTIONS is treated similarly to
+;;; NEW-FUNCTIONS, but we don't add lambdas to the LAMBDAS.
+(defun local-call-analyze (component)
+ (declare (type component component))
+ (loop
+ (let* ((new (pop (component-new-functions component)))
+ (fun (or new (pop (component-reanalyze-functions component)))))
+ (unless fun (return))
+ (let ((kind (functional-kind fun)))
+ (cond ((member kind '(:deleted :let :mv-let :assignment)))
+ ((and (null (leaf-refs fun)) (eq kind nil)
+ (not (functional-entry-function fun)))
+ (delete-functional fun))
+ (t
+ (when (and new (lambda-p fun))
+ (push fun (component-lambdas component)))
+ (local-call-analyze-1 fun)
+ (when (lambda-p fun)
+ (maybe-let-convert fun)))))))
+
+ (values))
+
+;;; If policy is auspicious, Call is not in an XEP, and we don't seem
+;;; to be in an infinite recursive loop, then change the reference to
+;;; reference a fresh copy. We return whichever function we decide to
+;;; reference.
+(defun maybe-expand-local-inline (fun ref call)
+ (if (and (policy call (>= speed space) (>= speed cspeed))
+ (not (eq (functional-kind (node-home-lambda call)) :external))
+ (not *converting-for-interpreter*)
+ (inline-expansion-ok call))
+ (with-ir1-environment call
+ (let* ((*lexenv* (functional-lexenv fun))
+ (won nil)
+ (res (catch 'local-call-lossage
+ (prog1
+ (ir1-convert-lambda (functional-inline-expansion fun))
+ (setq won t)))))
+ (cond (won
+ (change-ref-leaf ref res)
+ res)
+ (t
+ (let ((*compiler-error-context* call))
+ (compiler-note "couldn't inline expand because expansion ~
+ calls this let-converted local function:~
+ ~% ~S"
+ (leaf-name res)))
+ fun))))
+ fun))
+
+;;; Dispatch to the appropriate function to attempt to convert a call. Ref
+;;; most be a reference to a FUNCTIONAL. This is called in IR1 optimize as
+;;; well as in local call analysis. If the call is is already :Local, we do
+;;; nothing. If the call is already scheduled for deletion, also do nothing
+;;; (in addition to saving time, this also avoids some problems with optimizing
+;;; collections of functions that are partially deleted.)
+;;;
+;;; This is called both before and after FIND-INITIAL-DFO runs. When called
+;;; on a :INITIAL component, we don't care whether the caller and callee are in
+;;; the same component. Afterward, we must stick with whatever component
+;;; division we have chosen.
+;;;
+;;; Before attempting to convert a call, we see whether the function is
+;;; supposed to be inline expanded. Call conversion proceeds as before
+;;; after any expansion.
+;;;
+;;; We bind *Compiler-Error-Context* to the node for the call so that
+;;; warnings will get the right context.
+(defun convert-call-if-possible (ref call)
+ (declare (type ref ref) (type basic-combination call))
+ (let* ((block (node-block call))
+ (component (block-component block))
+ (original-fun (ref-leaf ref)))
+ (assert (functional-p original-fun))
+ (unless (or (member (basic-combination-kind call) '(:local :error))
+ (block-delete-p block)
+ (eq (functional-kind (block-home-lambda block)) :deleted)
+ (member (functional-kind original-fun)
+ '(:top-level-xep :deleted))
+ (not (or (eq (component-kind component) :initial)
+ (eq (block-component
+ (node-block
+ (lambda-bind (main-entry original-fun))))
+ component))))
+ (let ((fun (if (external-entry-point-p original-fun)
+ (functional-entry-function original-fun)
+ original-fun))
+ (*compiler-error-context* call))
+
+ (when (and (eq (functional-inlinep fun) :inline)
+ (rest (leaf-refs original-fun)))
+ (setq fun (maybe-expand-local-inline fun ref call)))
+
+ (assert (member (functional-kind fun)
+ '(nil :escape :cleanup :optional)))
+ (cond ((mv-combination-p call)
+ (convert-mv-call ref call fun))
+ ((lambda-p fun)
+ (convert-lambda-call ref call fun))
+ (t
+ (convert-hairy-call ref call fun))))))
+
+ (values))
+
+;;; Attempt to convert a multiple-value call. The only interesting
+;;; case is a call to a function that Looks-Like-An-MV-Bind, has
+;;; exactly one reference and no XEP, and is called with one values
+;;; continuation.
+;;;
+;;; We change the call to be to the last optional entry point and
+;;; change the call to be local. Due to our preconditions, the call
+;;; should eventually be converted to a let, but we can't do that now,
+;;; since there may be stray references to the e-p lambda due to
+;;; optional defaulting code.
+;;;
+;;; We also use variable types for the called function to construct an
+;;; assertion for the values continuation.
+;;;
+;;; See CONVERT-CALL for additional notes on MERGE-TAIL-SETS, etc.
+(defun convert-mv-call (ref call fun)
+ (declare (type ref ref) (type mv-combination call) (type functional fun))
+ (when (and (looks-like-an-mv-bind fun)
+ (not (functional-entry-function fun))
+ (= (length (leaf-refs fun)) 1)
+ (= (length (basic-combination-args call)) 1))
+ (let ((ep (car (last (optional-dispatch-entry-points fun)))))
+ (setf (basic-combination-kind call) :local)
+ (pushnew ep (lambda-calls (node-home-lambda call)))
+ (merge-tail-sets call ep)
+ (change-ref-leaf ref ep)
+
+ (assert-continuation-type
+ (first (basic-combination-args call))
+ (make-values-type :optional (mapcar #'leaf-type (lambda-vars ep))
+ :rest *universal-type*))))
+ (values))
+
+;;; Attempt to convert a call to a lambda. If the number of args is
+;;; wrong, we give a warning and mark the call as :ERROR to remove it
+;;; from future consideration. If the argcount is O.K. then we just
+;;; convert it.
+(defun convert-lambda-call (ref call fun)
+ (declare (type ref ref) (type combination call) (type clambda fun))
+ (let ((nargs (length (lambda-vars fun)))
+ (call-args (length (combination-args call))))
+ (cond ((= call-args nargs)
+ (convert-call ref call fun))
+ (t
+ ;; FIXME: ANSI requires in "3.2.5 Exceptional Situations in the
+ ;; Compiler" that calling a function with "the wrong number of
+ ;; arguments" be only a STYLE-ERROR. I think, though, that this
+ ;; should only apply when the number of arguments is inferred
+ ;; from a previous definition. If the number of arguments
+ ;; is DECLAIMed, surely calling with the wrong number is a
+ ;; real WARNING. As long as SBCL continues to use CMU CL's
+ ;; non-ANSI DEFUN-is-a-DECLAIM policy, we're in violation here,
+ ;; but as long as we continue to use that policy, that's the
+ ;; not our biggest problem.:-| When we fix that policy, this
+ ;; should come back into compliance. (So fix that policy!)
+ (compiler-warning
+ "function called with ~R argument~:P, but wants exactly ~R"
+ call-args nargs)
+ (setf (basic-combination-kind call) :error)))))
+\f
+;;;; optional, more and keyword calls
+
+;;; Similar to Convert-Lambda-Call, but deals with Optional-Dispatches. If
+;;; only fixed args are supplied, then convert a call to the correct entry
+;;; point. If keyword args are supplied, then dispatch to a subfunction. We
+;;; don't convert calls to functions that have a more (or rest) arg.
+(defun convert-hairy-call (ref call fun)
+ (declare (type ref ref) (type combination call)
+ (type optional-dispatch fun))
+ (let ((min-args (optional-dispatch-min-args fun))
+ (max-args (optional-dispatch-max-args fun))
+ (call-args (length (combination-args call))))
+ (cond ((< call-args min-args)
+ ;; FIXME: ANSI requires in "3.2.5 Exceptional Situations in the
+ ;; Compiler" that calling a function with "the wrong number of
+ ;; arguments" be only a STYLE-ERROR. I think, though, that this
+ ;; should only apply when the number of arguments is inferred
+ ;; from a previous definition. If the number of arguments
+ ;; is DECLAIMed, surely calling with the wrong number is a
+ ;; real WARNING. As long as SBCL continues to use CMU CL's
+ ;; non-ANSI DEFUN-is-a-DECLAIM policy, we're in violation here,
+ ;; but as long as we continue to use that policy, that's the
+ ;; not our biggest problem.:-| When we fix that policy, this
+ ;; should come back into compliance. (So fix that policy!)
+ (compiler-warning
+ "function called with ~R argument~:P, but wants at least ~R"
+ call-args min-args)
+ (setf (basic-combination-kind call) :error))
+ ((<= call-args max-args)
+ (convert-call ref call
+ (elt (optional-dispatch-entry-points fun)
+ (- call-args min-args))))
+ ((optional-dispatch-more-entry fun)
+ (convert-more-call ref call fun))
+ (t
+ ;; FIXME: ANSI requires in "3.2.5 Exceptional Situations in the
+ ;; Compiler" that calling a function with "the wrong number of
+ ;; arguments" be only a STYLE-ERROR. I think, though, that this
+ ;; should only apply when the number of arguments is inferred
+ ;; from a previous definition. If the number of arguments
+ ;; is DECLAIMed, surely calling with the wrong number is a
+ ;; real WARNING. As long as SBCL continues to use CMU CL's
+ ;; non-ANSI DEFUN-is-a-DECLAIM policy, we're in violation here,
+ ;; but as long as we continue to use that policy, that's the
+ ;; not our biggest problem.:-| When we fix that policy, this
+ ;; should come back into compliance. (So fix that policy!)
+ (compiler-warning
+ "function called with ~R argument~:P, but wants at most ~R"
+ call-args max-args)
+ (setf (basic-combination-kind call) :error))))
+ (values))
+
+;;; This function is used to convert a call to an entry point when complex
+;;; transformations need to be done on the original arguments. Entry is the
+;;; entry point function that we are calling. Vars is a list of variable names
+;;; which are bound to the original call arguments. Ignores is the subset of
+;;; Vars which are ignored. Args is the list of arguments to the entry point
+;;; function.
+;;;
+;;; In order to avoid gruesome graph grovelling, we introduce a new function
+;;; that rearranges the arguments and calls the entry point. We analyze the
+;;; new function and the entry point immediately so that everything gets
+;;; converted during the single pass.
+(defun convert-hairy-fun-entry (ref call entry vars ignores args)
+ (declare (list vars ignores args) (type ref ref) (type combination call)
+ (type clambda entry))
+ (let ((new-fun
+ (with-ir1-environment call
+ (ir1-convert-lambda
+ `(lambda ,vars
+ (declare (ignorable . ,ignores))
+ (%funcall ,entry . ,args))))))
+ (convert-call ref call new-fun)
+ (dolist (ref (leaf-refs entry))
+ (convert-call-if-possible ref (continuation-dest (node-cont ref))))))
+
+;;; Use Convert-Hairy-Fun-Entry to convert a more-arg call to a known
+;;; function into a local call to the Main-Entry.
+;;;
+;;; First we verify that all keywords are constant and legal. If there
+;;; aren't, then we warn the user and don't attempt to convert the call.
+;;;
+;;; We massage the supplied keyword arguments into the order expected by the
+;;; main entry. This is done by binding all the arguments to the keyword call
+;;; to variables in the introduced lambda, then passing these values variables
+;;; in the correct order when calling the main entry. Unused arguments
+;;; (such as the keywords themselves) are discarded simply by not passing them
+;;; along.
+;;;
+;;; If there is a rest arg, then we bundle up the args and pass them to LIST.
+(defun convert-more-call (ref call fun)
+ (declare (type ref ref) (type combination call) (type optional-dispatch fun))
+ (let* ((max (optional-dispatch-max-args fun))
+ (arglist (optional-dispatch-arglist fun))
+ (args (combination-args call))
+ (more (nthcdr max args))
+ (flame (policy call (or (> speed brevity) (> space brevity))))
+ (loser nil))
+ (collect ((temps)
+ (more-temps)
+ (ignores)
+ (supplied)
+ (key-vars))
+
+ (dolist (var arglist)
+ (let ((info (lambda-var-arg-info var)))
+ (when info
+ (ecase (arg-info-kind info)
+ (:keyword
+ (key-vars var))
+ ((:rest :optional))
+ ((:more-context :more-count)
+ (compiler-warning "can't local-call functions with &MORE args")
+ (setf (basic-combination-kind call) :error)
+ (return-from convert-more-call))))))
+
+ (dotimes (i max)
+ (temps (gensym "FIXED-ARG-TEMP-")))
+
+ (dotimes (i (length more))
+ (more-temps (gensym "MORE-ARG-TEMP-")))
+
+ (when (optional-dispatch-keyp fun)
+ (when (oddp (length more))
+ (compiler-warning "function called with odd number of ~
+ arguments in keyword portion")
+
+ (setf (basic-combination-kind call) :error)
+ (return-from convert-more-call))
+
+ (do ((key more (cddr key))
+ (temp (more-temps) (cddr temp)))
+ ((null key))
+ (let ((cont (first key)))
+ (unless (constant-continuation-p cont)
+ (when flame
+ (compiler-note "non-constant keyword in keyword call"))
+ (setf (basic-combination-kind call) :error)
+ (return-from convert-more-call))
+
+ (let ((name (continuation-value cont))
+ (dummy (first temp))
+ (val (second temp)))
+ (dolist (var (key-vars)
+ (progn
+ (ignores dummy val)
+ (setq loser name)))
+ (let ((info (lambda-var-arg-info var)))
+ (when (eq (arg-info-keyword info) name)
+ (ignores dummy)
+ (supplied (cons var val))
+ (return)))))))
+
+ (when (and loser (not (optional-dispatch-allowp fun)))
+ (compiler-warning "function called with unknown argument keyword ~S"
+ loser)
+ (setf (basic-combination-kind call) :error)
+ (return-from convert-more-call)))
+
+ (collect ((call-args))
+ (do ((var arglist (cdr var))
+ (temp (temps) (cdr temp)))
+ (())
+ (let ((info (lambda-var-arg-info (car var))))
+ (if info
+ (ecase (arg-info-kind info)
+ (:optional
+ (call-args (car temp))
+ (when (arg-info-supplied-p info)
+ (call-args t)))
+ (:rest
+ (call-args `(list ,@(more-temps)))
+ (return))
+ (:keyword
+ (return)))
+ (call-args (car temp)))))
+
+ (dolist (var (key-vars))
+ (let ((info (lambda-var-arg-info var))
+ (temp (cdr (assoc var (supplied)))))
+ (if temp
+ (call-args temp)
+ (call-args (arg-info-default info)))
+ (when (arg-info-supplied-p info)
+ (call-args (not (null temp))))))
+
+ (convert-hairy-fun-entry ref call (optional-dispatch-main-entry fun)
+ (append (temps) (more-temps))
+ (ignores) (call-args)))))
+
+ (values))
+\f
+;;;; LET conversion
+;;;;
+;;;; Converting to a LET has differing significance to various parts of the
+;;;; compiler:
+;;;; -- The body of a LET is spliced in immediately after the corresponding
+;;;; combination node, making the control transfer explicit and allowing
+;;;; LETs to be mashed together into a single block. The value of the LET is
+;;;; delivered directly to the original continuation for the call,
+;;;; eliminating the need to propagate information from the dummy result
+;;;; continuation.
+;;;; -- As far as IR1 optimization is concerned, it is interesting in that
+;;;; there is only one expression that the variable can be bound to, and
+;;;; this is easily substitited for.
+;;;; -- LETs are interesting to environment analysis and to the back end
+;;;; because in most ways a LET can be considered to be "the same function"
+;;;; as its home function.
+;;;; -- LET conversion has dynamic scope implications, since control transfers
+;;;; within the same environment are local. In a local control transfer,
+;;;; cleanup code must be emitted to remove dynamic bindings that are no
+;;;; longer in effect.
+
+;;; Set up the control transfer to the called lambda. We split the call
+;;; block immediately after the call, and link the head of FUN to the call
+;;; block. The successor block after splitting (where we return to) is
+;;; returned.
+;;;
+;;; If the lambda is is a different component than the call, then we call
+;;; JOIN-COMPONENTS. This only happens in block compilation before
+;;; FIND-INITIAL-DFO.
+(defun insert-let-body (fun call)
+ (declare (type clambda fun) (type basic-combination call))
+ (let* ((call-block (node-block call))
+ (bind-block (node-block (lambda-bind fun)))
+ (component (block-component call-block)))
+ (let ((fun-component (block-component bind-block)))
+ (unless (eq fun-component component)
+ (assert (eq (component-kind component) :initial))
+ (join-components component fun-component)))
+
+ (let ((*current-component* component))
+ (node-ends-block call))
+ ;; FIXME: Use PROPER-LIST-OF-LENGTH-P here, and look for other
+ ;; uses of '=.*length' which could also be converted to use
+ ;; PROPER-LIST-OF-LENGTH-P.
+ (assert (= (length (block-succ call-block)) 1))
+ (let ((next-block (first (block-succ call-block))))
+ (unlink-blocks call-block next-block)
+ (link-blocks call-block bind-block)
+ next-block)))
+
+;;; Handle the environment semantics of LET conversion. We add the lambda
+;;; and its LETs to lets for the Call's home function. We merge the calls for
+;;; Fun with the calls for the home function, removing Fun in the process. We
+;;; also merge the Entries.
+;;;
+;;; We also unlink the function head from the component head and set
+;;; Component-Reanalyze to true to indicate that the DFO should be recomputed.
+(defun merge-lets (fun call)
+ (declare (type clambda fun) (type basic-combination call))
+ (let ((component (block-component (node-block call))))
+ (unlink-blocks (component-head component) (node-block (lambda-bind fun)))
+ (setf (component-lambdas component)
+ (delete fun (component-lambdas component)))
+ (setf (component-reanalyze component) t))
+ (setf (lambda-call-lexenv fun) (node-lexenv call))
+ (let ((tails (lambda-tail-set fun)))
+ (setf (tail-set-functions tails)
+ (delete fun (tail-set-functions tails))))
+ (setf (lambda-tail-set fun) nil)
+ (let* ((home (node-home-lambda call))
+ (home-env (lambda-environment home)))
+ (push fun (lambda-lets home))
+ (setf (lambda-home fun) home)
+ (setf (lambda-environment fun) home-env)
+
+ (let ((lets (lambda-lets fun)))
+ (dolist (let lets)
+ (setf (lambda-home let) home)
+ (setf (lambda-environment let) home-env))
+
+ (setf (lambda-lets home) (nconc lets (lambda-lets home)))
+ (setf (lambda-lets fun) ()))
+
+ (setf (lambda-calls home)
+ (nunion (lambda-calls fun)
+ (delete fun (lambda-calls home))))
+ (setf (lambda-calls fun) ())
+
+ (setf (lambda-entries home)
+ (nconc (lambda-entries fun) (lambda-entries home)))
+ (setf (lambda-entries fun) ()))
+ (values))
+
+;;; Handle the value semantics of let conversion. Delete Fun's return node,
+;;; and change the control flow to transfer to Next-Block instead. Move all
+;;; the uses of the result continuation to Call's Cont.
+;;;
+;;; If the actual continuation is only used by the let call, then we
+;;; intersect the type assertion on the dummy continuation with the assertion
+;;; for the actual continuation; in all other cases assertions on the dummy
+;;; continuation are lost.
+;;;
+;;; We also intersect the derived type of the call with the derived type of
+;;; all the dummy continuation's uses. This serves mainly to propagate
+;;; TRULY-THE through lets.
+(defun move-return-uses (fun call next-block)
+ (declare (type clambda fun) (type basic-combination call)
+ (type cblock next-block))
+ (let* ((return (lambda-return fun))
+ (return-block (node-block return)))
+ (unlink-blocks return-block
+ (component-tail (block-component return-block)))
+ (link-blocks return-block next-block)
+ (unlink-node return)
+ (delete-return return)
+ (let ((result (return-result return))
+ (cont (node-cont call))
+ (call-type (node-derived-type call)))
+ (when (eq (continuation-use cont) call)
+ (assert-continuation-type cont (continuation-asserted-type result)))
+ (unless (eq call-type *wild-type*)
+ (do-uses (use result)
+ (derive-node-type use call-type)))
+ (substitute-continuation-uses cont result)))
+ (values))
+
+;;; Change all Cont for all the calls to Fun to be the start continuation
+;;; for the bind node. This allows the blocks to be joined if the caller count
+;;; ever goes to one.
+(defun move-let-call-cont (fun)
+ (declare (type clambda fun))
+ (let ((new-cont (node-prev (lambda-bind fun))))
+ (dolist (ref (leaf-refs fun))
+ (let ((dest (continuation-dest (node-cont ref))))
+ (delete-continuation-use dest)
+ (add-continuation-use dest new-cont))))
+ (values))
+
+;;; We are converting Fun to be a let when the call is in a non-tail
+;;; position. Any previously tail calls in Fun are no longer tail calls, and
+;;; must be restored to normal calls which transfer to Next-Block (Fun's
+;;; return point.) We can't do this by DO-USES on the RETURN-RESULT, because
+;;; the return might have been deleted (if all calls were TR.)
+;;;
+;;; The called function might be an assignment in the case where we are
+;;; currently converting that function. In steady-state, assignments never
+;;; appear in the lambda-calls.
+(defun unconvert-tail-calls (fun call next-block)
+ (dolist (called (lambda-calls fun))
+ (dolist (ref (leaf-refs called))
+ (let ((this-call (continuation-dest (node-cont ref))))
+ (when (and (node-tail-p this-call)
+ (eq (node-home-lambda this-call) fun))
+ (setf (node-tail-p this-call) nil)
+ (ecase (functional-kind called)
+ ((nil :cleanup :optional)
+ (let ((block (node-block this-call))
+ (cont (node-cont call)))
+ (ensure-block-start cont)
+ (unlink-blocks block (first (block-succ block)))
+ (link-blocks block next-block)
+ (delete-continuation-use this-call)
+ (add-continuation-use this-call cont)))
+ (:deleted)
+ (:assignment
+ (assert (eq called fun))))))))
+ (values))
+
+;;; Deal with returning from a let or assignment that we are converting.
+;;; FUN is the function we are calling, CALL is a call to FUN, and NEXT-BLOCK
+;;; is the return point for a non-tail call, or NULL if call is a tail call.
+;;;
+;;; If the call is not a tail call, then we must do UNCONVERT-TAIL-CALLS, since
+;;; a tail call is a call which returns its value out of the enclosing non-let
+;;; function. When call is non-TR, we must convert it back to an ordinary
+;;; local call, since the value must be delivered to the receiver of CALL's
+;;; value.
+;;;
+;;; We do different things depending on whether the caller and callee have
+;;; returns left:
+;;; -- If the callee has no return we just do MOVE-LET-CALL-CONT. Either the
+;;; function doesn't return, or all returns are via tail-recursive local
+;;; calls.
+;;; -- If CALL is a non-tail call, or if both have returns, then we
+;;; delete the callee's return, move its uses to the call's result
+;;; continuation, and transfer control to the appropriate return point.
+;;; -- If the callee has a return, but the caller doesn't, then we move the
+;;; return to the caller.
+(defun move-return-stuff (fun call next-block)
+ (declare (type clambda fun) (type basic-combination call)
+ (type (or cblock null) next-block))
+ (when next-block
+ (unconvert-tail-calls fun call next-block))
+ (let* ((return (lambda-return fun))
+ (call-fun (node-home-lambda call))
+ (call-return (lambda-return call-fun)))
+ (cond ((not return))
+ ((or next-block call-return)
+ (unless (block-delete-p (node-block return))
+ (move-return-uses fun call
+ (or next-block (node-block call-return)))))
+ (t
+ (assert (node-tail-p call))
+ (setf (lambda-return call-fun) return)
+ (setf (return-lambda return) call-fun))))
+ (move-let-call-cont fun)
+ (values))
+
+;;; Actually do LET conversion. We call subfunctions to do most of the
+;;; work. We change the CALL's cont to be the continuation heading the bind
+;;; block, and also do REOPTIMIZE-CONTINUATION on the args and Cont so that
+;;; let-specific IR1 optimizations get a chance. We blow away any entry for
+;;; the function in *FREE-FUNCTIONS* so that nobody will create new reference
+;;; to it.
+(defun let-convert (fun call)
+ (declare (type clambda fun) (type basic-combination call))
+ (let ((next-block (if (node-tail-p call)
+ nil
+ (insert-let-body fun call))))
+ (move-return-stuff fun call next-block)
+ (merge-lets fun call)))
+
+;;; Reoptimize all of Call's args and its result.
+(defun reoptimize-call (call)
+ (declare (type basic-combination call))
+ (dolist (arg (basic-combination-args call))
+ (when arg
+ (reoptimize-continuation arg)))
+ (reoptimize-continuation (node-cont call))
+ (values))
+
+;;; We also don't convert calls to named functions which appear in the initial
+;;; component, delaying this until optimization. This minimizes the likelyhood
+;;; that we well let-convert a function which may have references added due to
+;;; later local inline expansion
+(defun ok-initial-convert-p (fun)
+ (not (and (leaf-name fun)
+ (eq (component-kind
+ (block-component
+ (node-block (lambda-bind fun))))
+ :initial))))
+
+;;; This function is called when there is some reason to believe that
+;;; the lambda Fun might be converted into a let. This is done after local
+;;; call analysis, and also when a reference is deleted. We only convert to a
+;;; let when the function is a normal local function, has no XEP, and is
+;;; referenced in exactly one local call. Conversion is also inhibited if the
+;;; only reference is in a block about to be deleted. We return true if we
+;;; converted.
+;;;
+;;; These rules may seem unnecessarily restrictive, since there are some
+;;; cases where we could do the return with a jump that don't satisfy these
+;;; requirements. The reason for doing things this way is that it makes the
+;;; concept of a let much more useful at the level of IR1 semantics. The
+;;; :ASSIGNMENT function kind provides another way to optimize calls to
+;;; single-return/multiple call functions.
+;;;
+;;; We don't attempt to convert calls to functions that have an XEP, since
+;;; we might be embarrassed later when we want to convert a newly discovered
+;;; local call. Also, see OK-INITIAL-CONVERT-P.
+(defun maybe-let-convert (fun)
+ (declare (type clambda fun))
+ (let ((refs (leaf-refs fun)))
+ (when (and refs
+ (null (rest refs))
+ (member (functional-kind fun) '(nil :assignment))
+ (not (functional-entry-function fun)))
+ (let* ((ref-cont (node-cont (first refs)))
+ (dest (continuation-dest ref-cont)))
+ (when (and (basic-combination-p dest)
+ (eq (basic-combination-fun dest) ref-cont)
+ (eq (basic-combination-kind dest) :local)
+ (not (block-delete-p (node-block dest)))
+ (cond ((ok-initial-convert-p fun) t)
+ (t
+ (reoptimize-continuation ref-cont)
+ nil)))
+ (unless (eq (functional-kind fun) :assignment)
+ (let-convert fun dest))
+ (reoptimize-call dest)
+ (setf (functional-kind fun)
+ (if (mv-combination-p dest) :mv-let :let))))
+ t)))
+\f
+;;;; tail local calls and assignments
+
+;;; Return T if there are no cleanups between Block1 and Block2, or if they
+;;; definitely won't generate any cleanup code. Currently we recognize lexical
+;;; entry points that are only used locally (if at all).
+(defun only-harmless-cleanups (block1 block2)
+ (declare (type cblock block1 block2))
+ (or (eq block1 block2)
+ (let ((cleanup2 (block-start-cleanup block2)))
+ (do ((cleanup (block-end-cleanup block1)
+ (node-enclosing-cleanup (cleanup-mess-up cleanup))))
+ ((eq cleanup cleanup2) t)
+ (case (cleanup-kind cleanup)
+ ((:block :tagbody)
+ (unless (null (entry-exits (cleanup-mess-up cleanup)))
+ (return nil)))
+ (t (return nil)))))))
+
+;;; If a potentially TR local call really is TR, then convert it to jump
+;;; directly to the called function. We also call MAYBE-CONVERT-TO-ASSIGNMENT.
+;;; The first value is true if we tail-convert. The second is the value of
+;;; M-C-T-A. We can switch the succesor (potentially deleting the RETURN node)
+;;; unless:
+;;; -- The call has already been converted.
+;;; -- The call isn't TR (some implicit MV PROG1.)
+;;; -- The call is in an XEP (thus we might decide to make it non-tail so that
+;;; we can use known return inside the component.)
+;;; -- There is a change in the cleanup between the call in the return, so we
+;;; might need to introduce cleanup code.
+(defun maybe-convert-tail-local-call (call)
+ (declare (type combination call))
+ (let ((return (continuation-dest (node-cont call))))
+ (assert (return-p return))
+ (when (and (not (node-tail-p call))
+ (immediately-used-p (return-result return) call)
+ (not (eq (functional-kind (node-home-lambda call))
+ :external))
+ (only-harmless-cleanups (node-block call)
+ (node-block return)))
+ (node-ends-block call)
+ (let ((block (node-block call))
+ (fun (combination-lambda call)))
+ (setf (node-tail-p call) t)
+ (unlink-blocks block (first (block-succ block)))
+ (link-blocks block (node-block (lambda-bind fun)))
+ (values t (maybe-convert-to-assignment fun))))))
+
+;;; Called when we believe it might make sense to convert Fun to an
+;;; assignment. All this function really does is determine when a function
+;;; with more than one call can still be combined with the calling function's
+;;; environment. We can convert when:
+;;; -- The function is a normal, non-entry function, and
+;;; -- Except for one call, all calls must be tail recursive calls in the
+;;; called function (i.e. are self-recursive tail calls)
+;;; -- OK-INITIAL-CONVERT-P is true.
+;;;
+;;; There may be one outside call, and it need not be tail-recursive. Since
+;;; all tail local calls have already been converted to direct transfers, the
+;;; only control semantics needed are to splice in the body at the non-tail
+;;; call. If there is no non-tail call, then we need only merge the
+;;; environments. Both cases are handled by LET-CONVERT.
+;;;
+;;; ### It would actually be possible to allow any number of outside calls as
+;;; long as they all return to the same place (i.e. have the same conceptual
+;;; continuation.) A special case of this would be when all of the outside
+;;; calls are tail recursive.
+(defun maybe-convert-to-assignment (fun)
+ (declare (type clambda fun))
+ (when (and (not (functional-kind fun))
+ (not (functional-entry-function fun)))
+ (let ((non-tail nil)
+ (call-fun nil))
+ (when (and (dolist (ref (leaf-refs fun) t)
+ (let ((dest (continuation-dest (node-cont ref))))
+ (when (block-delete-p (node-block dest)) (return nil))
+ (let ((home (node-home-lambda ref)))
+ (unless (eq home fun)
+ (when call-fun (return nil))
+ (setq call-fun home))
+ (unless (node-tail-p dest)
+ (when (or non-tail (eq home fun)) (return nil))
+ (setq non-tail dest)))))
+ (ok-initial-convert-p fun))
+ (setf (functional-kind fun) :assignment)
+ (let-convert fun (or non-tail
+ (continuation-dest
+ (node-cont (first (leaf-refs fun))))))
+ (when non-tail (reoptimize-call non-tail))
+ t))))
--- /dev/null
+;;;; This file contains the LTN pass in the compiler. LTN allocates
+;;;; expression evaluation TNs, makes nearly all the implementation
+;;;; policy decisions, and also does a few other miscellaneous things.
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!C")
+
+(file-comment
+ "$Header$")
+\f
+;;;; utilities
+
+;;; Return the policies keyword indicated by the node policy.
+(defun translation-policy (node)
+ (declare (type node node))
+ (let* ((cookie (lexenv-cookie (node-lexenv node)))
+ (safety (cookie-safety cookie))
+ (space (max (cookie-space cookie)
+ (cookie-cspeed cookie)))
+ (speed (cookie-speed cookie)))
+ (if (zerop safety)
+ (if (>= speed space) :fast :small)
+ (if (>= speed space) :fast-safe :safe))))
+
+;;; Return true if Policy is a safe policy.
+#!-sb-fluid (declaim (inline policy-safe-p))
+(defun policy-safe-p (policy)
+ (declare (type policies policy))
+ (or (eq policy :safe) (eq policy :fast-safe)))
+
+;;; Called when an unsafe policy indicates that no type check should be done
+;;; on CONT. We delete the type check unless it is :ERROR (indicating a
+;;; compile-time type error.)
+#!-sb-fluid (declaim (inline flush-type-check))
+(defun flush-type-check (cont)
+ (declare (type continuation cont))
+ (when (member (continuation-type-check cont) '(t :no-check))
+ (setf (continuation-%type-check cont) :deleted))
+ (values))
+
+;;; An annotated continuation's primitive-type.
+#!-sb-fluid (declaim (inline continuation-ptype))
+(defun continuation-ptype (cont)
+ (declare (type continuation cont))
+ (ir2-continuation-primitive-type (continuation-info cont)))
+
+;;; Return true if a constant Leaf is of a type which we can legally
+;;; directly reference in code. Named constants with arbitrary pointer values
+;;; cannot, since we must preserve EQLness.
+(defun legal-immediate-constant-p (leaf)
+ (declare (type constant leaf))
+ (or (null (leaf-name leaf))
+ (typecase (constant-value leaf)
+ ((or number character) t)
+ (symbol (symbol-package (constant-value leaf)))
+ (t nil))))
+
+;;; If Cont is used only by a Ref to a leaf that can be delayed, then return
+;;; the leaf, otherwise return NIL.
+(defun continuation-delayed-leaf (cont)
+ (declare (type continuation cont))
+ (let ((use (continuation-use cont)))
+ (and (ref-p use)
+ (let ((leaf (ref-leaf use)))
+ (etypecase leaf
+ (lambda-var (if (null (lambda-var-sets leaf)) leaf nil))
+ (constant (if (legal-immediate-constant-p leaf) leaf nil))
+ ((or functional global-var) nil))))))
+
+;;; Annotate a normal single-value continuation. If its only use is a ref
+;;; that we are allowed to delay the evaluation of, then we mark the
+;;; continuation for delayed evaluation, otherwise we assign a TN to hold the
+;;; continuation's value. If the continuation has a type check, we make the TN
+;;; according to the proven type to ensure that the possibly erroneous value
+;;; can be represented.
+(defun annotate-1-value-continuation (cont)
+ (declare (type continuation cont))
+ (let ((info (continuation-info cont)))
+ (assert (eq (ir2-continuation-kind info) :fixed))
+ (cond
+ ((continuation-delayed-leaf cont)
+ (setf (ir2-continuation-kind info) :delayed))
+ ((member (continuation-type-check cont) '(:deleted nil))
+ (setf (ir2-continuation-locs info)
+ (list (make-normal-tn (ir2-continuation-primitive-type info)))))
+ (t
+ (setf (ir2-continuation-locs info)
+ (list (make-normal-tn
+ (primitive-type
+ (single-value-type (continuation-proven-type cont)))))))))
+ (values))
+
+;;; Make an IR2-Continuation corresponding to the continuation type and then
+;;; do Annotate-1-Value-Continuation. If Policy isn't a safe policy, then we
+;;; clear the type-check flag.
+(defun annotate-ordinary-continuation (cont policy)
+ (declare (type continuation cont)
+ (type policies policy))
+ (let ((info (make-ir2-continuation
+ (primitive-type (continuation-type cont)))))
+ (setf (continuation-info cont) info)
+ (unless (policy-safe-p policy) (flush-type-check cont))
+ (annotate-1-value-continuation cont))
+ (values))
+
+;;; Annotate the function continuation for a full call. If the only
+;;; reference is to a global function and Delay is true, then we delay
+;;; the reference, otherwise we annotate for a single value.
+;;;
+;;; Unlike for an argument, we only clear the type check flag when the policy
+;;; is unsafe, since the check for a valid function object must be done before
+;;; the call.
+(defun annotate-function-continuation (cont policy &optional (delay t))
+ (declare (type continuation cont) (type policies policy))
+ (unless (policy-safe-p policy) (flush-type-check cont))
+ (let* ((ptype (primitive-type (continuation-type cont)))
+ (tn-ptype (if (member (continuation-type-check cont) '(:deleted nil))
+ ptype
+ (primitive-type
+ (single-value-type
+ (continuation-proven-type cont)))))
+ (info (make-ir2-continuation ptype)))
+ (setf (continuation-info cont) info)
+ (let ((name (continuation-function-name cont t)))
+ (if (and delay name)
+ (setf (ir2-continuation-kind info) :delayed)
+ (setf (ir2-continuation-locs info)
+ (list (make-normal-tn tn-ptype))))))
+ (values))
+
+;;; If TAIL-P is true, then we check to see whether the call can really
+;;; be a tail call by seeing if this function's return convention is :UNKNOWN.
+;;; If so, we move the call block succssor link from the return block to
+;;; the component tail (after ensuring that they are in separate blocks.)
+;;; This allows the return to be deleted when there are no non-tail uses.
+(defun flush-full-call-tail-transfer (call)
+ (declare (type basic-combination call))
+ (let ((tails (and (node-tail-p call)
+ (lambda-tail-set (node-home-lambda call)))))
+ (when tails
+ (cond ((eq (return-info-kind (tail-set-info tails)) :unknown)
+ (node-ends-block call)
+ (let ((block (node-block call)))
+ (unlink-blocks block (first (block-succ block)))
+ (link-blocks block (component-tail (block-component block)))))
+ (t
+ (setf (node-tail-p call) nil)))))
+ (values))
+
+;;; We set the kind to :FULL or :FUNNY, depending on whether there is an
+;;; IR2-CONVERT method. If a funny function, then we inhibit tail recursion
+;;; and type check normally, since the IR2 convert method is going to want to
+;;; deliver values normally. We still annotate the function continuation,
+;;; since IR2tran might decide to call after all.
+;;;
+;;; If not funny, we always flush arg type checks, but do it after
+;;; annotation when the policy is safe, since we don't want to choose the TNs
+;;; according to a type assertions that may not hold.
+;;;
+;;; Note that args may already be annotated because template selection can
+;;; bail out to here.
+(defun ltn-default-call (call policy)
+ (declare (type combination call) (type policies policy))
+ (let ((kind (basic-combination-kind call)))
+ (annotate-function-continuation (basic-combination-fun call) policy)
+
+ (cond
+ ((and (function-info-p kind)
+ (function-info-ir2-convert kind))
+ (setf (basic-combination-info call) :funny)
+ (setf (node-tail-p call) nil)
+ (dolist (arg (basic-combination-args call))
+ (unless (continuation-info arg)
+ (setf (continuation-info arg)
+ (make-ir2-continuation
+ (primitive-type
+ (continuation-type arg)))))
+ (annotate-1-value-continuation arg)))
+ (t
+ (let ((safe-p (policy-safe-p policy)))
+ (dolist (arg (basic-combination-args call))
+ (unless safe-p (flush-type-check arg))
+ (unless (continuation-info arg)
+ (setf (continuation-info arg)
+ (make-ir2-continuation
+ (primitive-type
+ (continuation-type arg)))))
+ (annotate-1-value-continuation arg)
+ (when safe-p (flush-type-check arg))))
+ (when (eq kind :error)
+ (setf (basic-combination-kind call) :full))
+ (setf (basic-combination-info call) :full)
+ (flush-full-call-tail-transfer call))))
+
+ (values))
+
+;;; Annotate a continuation for unknown multiple values:
+;;; -- Delete any type check, regardless of policy, since we IR2 conversion
+;;; isn't prepared to check unknown-values continuations. If we delete a
+;;; type check when the policy is safe, then we emit a warning.
+;;; -- Add the continuation to the IR2-Block-Popped if it is used across a
+;;; block boundary.
+;;; -- Assign a :Unknown IR2-Continuation.
+;;;
+;;; Note: it is critical that this be called only during LTN analysis of Cont's
+;;; DEST, and called in the order that the continuations are received.
+;;; Otherwise the IR2-Block-Popped and IR2-Component-Values-XXX will get all
+;;; messed up.
+(defun annotate-unknown-values-continuation (cont policy)
+ (declare (type continuation cont) (type policies policy))
+ (when (eq (continuation-type-check cont) t)
+ (let* ((dest (continuation-dest cont))
+ (*compiler-error-context* dest))
+ (when (and (policy-safe-p policy)
+ (policy dest (>= safety brevity)))
+ (compiler-note "unable to check type assertion in unknown-values ~
+ context:~% ~S"
+ (continuation-asserted-type cont))))
+ (setf (continuation-%type-check cont) :deleted))
+
+ (let* ((block (node-block (continuation-dest cont)))
+ (use (continuation-use cont))
+ (2block (block-info block)))
+ (unless (and use (eq (node-block use) block))
+ (setf (ir2-block-popped 2block)
+ (nconc (ir2-block-popped 2block) (list cont)))))
+
+ (let ((2cont (make-ir2-continuation nil)))
+ (setf (ir2-continuation-kind 2cont) :unknown)
+ (setf (ir2-continuation-locs 2cont) (make-unknown-values-locations))
+ (setf (continuation-info cont) 2cont))
+
+ (values))
+
+;;; Annotate Cont for a fixed, but arbitrary number of values, of the
+;;; specified primitive Types. If the continuation has a type check, we
+;;; annotate for the number of values indicated by Types, but only use proven
+;;; type information.
+(defun annotate-fixed-values-continuation (cont policy types)
+ (declare (type continuation cont) (type policies policy) (list types))
+ (unless (policy-safe-p policy) (flush-type-check cont))
+
+ (let ((res (make-ir2-continuation nil)))
+ (if (member (continuation-type-check cont) '(:deleted nil))
+ (setf (ir2-continuation-locs res) (mapcar #'make-normal-tn types))
+ (let* ((proven (mapcar #'(lambda (x)
+ (make-normal-tn (primitive-type x)))
+ (values-types
+ (continuation-proven-type cont))))
+ (num-proven (length proven))
+ (num-types (length types)))
+ (setf (ir2-continuation-locs res)
+ (cond
+ ((< num-proven num-types)
+ (append proven
+ (make-n-tns (- num-types num-proven)
+ *backend-t-primitive-type*)))
+ ((> num-proven num-types)
+ (subseq proven 0 num-types))
+ (t
+ proven)))))
+ (setf (continuation-info cont) res))
+
+ (values))
+\f
+;;;; node-specific analysis functions
+
+;;; Annotate the result continuation for a function. We use the Return-Info
+;;; computed by GTN to determine how to represent the return values within the
+;;; function:
+;;; -- If the tail-set has a fixed values count, then use that many values.
+;;; -- If the actual uses of the result continuation in this function have a
+;;; fixed number of values (after intersection with the assertion), then use
+;;; that number. We throw out TAIL-P :FULL and :LOCAL calls, since we know
+;;; they will truly end up as TR calls. We can use the
+;;; BASIC-COMBINATION-INFO even though it is assigned by this phase, since
+;;; the initial value NIL doesn't look like a TR call.
+;;;
+;;; If there are *no* non-tail-call uses, then it falls out that we annotate
+;;; for one value (type is NIL), but the return will end up being deleted.
+;;;
+;;; In non-perverse code, the DFO walk will reach all uses of the result
+;;; continuation before it reaches the RETURN. In perverse code, we may
+;;; annotate for unknown values when we didn't have to.
+;;; -- Otherwise, we must annotate the continuation for unknown values.
+(defun ltn-analyze-return (node policy)
+ (declare (type creturn node) (type policies policy))
+ (let* ((cont (return-result node))
+ (fun (return-lambda node))
+ (returns (tail-set-info (lambda-tail-set fun)))
+ (types (return-info-types returns)))
+ (if (eq (return-info-count returns) :unknown)
+ (collect ((res *empty-type* values-type-union))
+ (do-uses (use (return-result node))
+ (unless (and (node-tail-p use)
+ (basic-combination-p use)
+ (member (basic-combination-info use) '(:local :full)))
+ (res (node-derived-type use))))
+
+ (let ((int (values-type-intersection
+ (res)
+ (continuation-asserted-type cont))))
+ (multiple-value-bind (types kind)
+ (values-types (if (eq int *empty-type*) (res) int))
+ (if (eq kind :unknown)
+ (annotate-unknown-values-continuation cont policy)
+ (annotate-fixed-values-continuation
+ cont policy
+ (mapcar #'primitive-type types))))))
+ (annotate-fixed-values-continuation cont policy types)))
+
+ (values))
+
+;;; Annotate the single argument continuation as a fixed-values
+;;; continuation. We look at the called lambda to determine number and type of
+;;; return values desired. It is assumed that only a function that
+;;; Looks-Like-An-MV-Bind will be converted to a local call.
+(defun ltn-analyze-mv-bind (call policy)
+ (declare (type mv-combination call)
+ (type policies policy))
+ (setf (basic-combination-kind call) :local)
+ (setf (node-tail-p call) nil)
+ (annotate-fixed-values-continuation
+ (first (basic-combination-args call)) policy
+ (mapcar #'(lambda (var)
+ (primitive-type (basic-var-type var)))
+ (lambda-vars
+ (ref-leaf
+ (continuation-use
+ (basic-combination-fun call))))))
+ (values))
+
+;;; We force all the argument continuations to use the unknown values
+;;; convention. The continuations are annotated in reverse order, since the
+;;; last argument is on top, thus must be popped first. We disallow delayed
+;;; evaluation of the function continuation to simplify IR2 conversion of MV
+;;; call.
+;;;
+;;; We could be cleverer when we know the number of values returned by the
+;;; continuations, but optimizations of MV-Call are probably unworthwhile.
+;;;
+;;; We are also responsible for handling THROW, which is represented in IR1
+;;; as an mv-call to the %THROW funny function. We annotate the tag
+;;; continuation for a single value and the values continuation for unknown
+;;; values.
+(defun ltn-analyze-mv-call (call policy)
+ (declare (type mv-combination call))
+ (let ((fun (basic-combination-fun call))
+ (args (basic-combination-args call)))
+ (cond ((eq (continuation-function-name fun) '%throw)
+ (setf (basic-combination-info call) :funny)
+ (annotate-ordinary-continuation (first args) policy)
+ (annotate-unknown-values-continuation (second args) policy)
+ (setf (node-tail-p call) nil))
+ (t
+ (setf (basic-combination-info call) :full)
+ (annotate-function-continuation (basic-combination-fun call)
+ policy nil)
+ (dolist (arg (reverse args))
+ (annotate-unknown-values-continuation arg policy))
+ (flush-full-call-tail-transfer call))))
+
+ (values))
+
+;;; Annotate the arguments as ordinary single-value continuations. And check
+;;; the successor.
+(defun ltn-analyze-local-call (call policy)
+ (declare (type combination call)
+ (type policies policy))
+ (setf (basic-combination-info call) :local)
+
+ (dolist (arg (basic-combination-args call))
+ (when arg
+ (annotate-ordinary-continuation arg policy)))
+
+ (when (node-tail-p call)
+ (set-tail-local-call-successor call))
+ (values))
+
+;;; Make sure that a tail local call is linked directly to the bind
+;;; node. Usually it will be, but calls from XEPs and calls that might have
+;;; needed a cleanup after them won't have been swung over yet, since we
+;;; weren't sure they would really be TR until now. Also called by byte
+;;; compiler.
+(defun set-tail-local-call-successor (call)
+ (let ((caller (node-home-lambda call))
+ (callee (combination-lambda call)))
+ (assert (eq (lambda-tail-set caller)
+ (lambda-tail-set (lambda-home callee))))
+ (node-ends-block call)
+ (let ((block (node-block call)))
+ (unlink-blocks block (first (block-succ block)))
+ (link-blocks block (node-block (lambda-bind callee)))))
+ (values))
+
+;;; Annotate the value continuation.
+(defun ltn-analyze-set (node policy)
+ (declare (type cset node) (type policies policy))
+ (setf (node-tail-p node) nil)
+ (annotate-ordinary-continuation (set-value node) policy)
+ (values))
+
+;;; If the only use of the Test continuation is a combination annotated with
+;;; a conditional template, then don't annotate the continuation so that IR2
+;;; conversion knows not to emit any code, otherwise annotate as an ordinary
+;;; continuation. Since we only use a conditional template if the call
+;;; immediately precedes the IF node in the same block, we know that any
+;;; predicate will already be annotated.
+(defun ltn-analyze-if (node policy)
+ (declare (type cif node) (type policies policy))
+ (setf (node-tail-p node) nil)
+ (let* ((test (if-test node))
+ (use (continuation-use test)))
+ (unless (and (combination-p use)
+ (let ((info (basic-combination-info use)))
+ (and (template-p info)
+ (eq (template-result-types info) :conditional))))
+ (annotate-ordinary-continuation test policy)))
+ (values))
+
+;;; If there is a value continuation, then annotate it for unknown values.
+;;; In this case, the exit is non-local, since all other exits are deleted or
+;;; degenerate by this point.
+(defun ltn-analyze-exit (node policy)
+ (setf (node-tail-p node) nil)
+ (let ((value (exit-value node)))
+ (when value
+ (annotate-unknown-values-continuation value policy)))
+ (values))
+
+;;; We need a special method for %Unwind-Protect that ignores the cleanup
+;;; function. We don't annotate either arg, since we don't need them at
+;;; run-time.
+;;;
+;;; [The default is o.k. for %Catch, since environment analysis converted the
+;;; reference to the escape function into a constant reference to the
+;;; NLX-Info.]
+(defoptimizer (%unwind-protect ltn-annotate) ((escape cleanup) node policy)
+ policy ; Ignore...
+ (setf (basic-combination-info node) :funny)
+ (setf (node-tail-p node) nil))
+
+;;; Both of these functions need special LTN-annotate methods, since we only
+;;; want to clear the Type-Check in unsafe policies. If we allowed the call to
+;;; be annotated as a full call, then no type checking would be done.
+;;;
+;;; We also need a special LTN annotate method for %Slot-Setter so that the
+;;; function is ignored. This is because the reference to a SETF function
+;;; can't be delayed, so IR2 conversion would have already emitted a call to
+;;; FDEFINITION by the time the IR2 convert method got control.
+(defoptimizer (%slot-accessor ltn-annotate) ((struct) node policy)
+ (setf (basic-combination-info node) :funny)
+ (setf (node-tail-p node) nil)
+ (annotate-ordinary-continuation struct policy))
+(defoptimizer (%slot-setter ltn-annotate) ((struct value) node policy)
+ (setf (basic-combination-info node) :funny)
+ (setf (node-tail-p node) nil)
+ (annotate-ordinary-continuation struct policy)
+ (annotate-ordinary-continuation value policy))
+\f
+;;;; known call annotation
+
+;;; Return true if Restr is satisfied by Type. If T-OK is true, then a T
+;;; restriction allows any operand type. This is also called by IR2tran when
+;;; it determines whether a result temporary needs to be made, and by
+;;; representation selection when it is deciding which move VOP to use.
+;;; Cont and TN are used to test for constant arguments.
+#!-sb-fluid (declaim (inline operand-restriction-ok))
+(defun operand-restriction-ok (restr type &key cont tn (t-ok t))
+ (declare (type (or (member *) cons) restr)
+ (type primitive-type type)
+ (type (or continuation null) cont)
+ (type (or tn null) tn))
+ (if (eq restr '*)
+ t
+ (ecase (first restr)
+ (:or
+ (dolist (mem (rest restr) nil)
+ (when (or (and t-ok (eq mem *backend-t-primitive-type*))
+ (eq mem type))
+ (return t))))
+ (:constant
+ (cond (cont
+ (and (constant-continuation-p cont)
+ (funcall (second restr) (continuation-value cont))))
+ (tn
+ (and (eq (tn-kind tn) :constant)
+ (funcall (second restr) (tn-value tn))))
+ (t
+ (error "Neither CONT nor TN supplied.")))))))
+
+;;; Check that the argument type restriction for Template are satisfied in
+;;; call. If an argument's TYPE-CHECK is :NO-CHECK and our policy is safe,
+;;; then only :SAFE templates are o.k.
+(defun template-args-ok (template call safe-p)
+ (declare (type template template)
+ (type combination call))
+ (let ((mtype (template-more-args-type template)))
+ (do ((args (basic-combination-args call) (cdr args))
+ (types (template-arg-types template) (cdr types)))
+ ((null types)
+ (cond ((null args) t)
+ ((not mtype) nil)
+ (t
+ (dolist (arg args t)
+ (unless (operand-restriction-ok mtype
+ (continuation-ptype arg))
+ (return nil))))))
+ (when (null args) (return nil))
+ (let ((arg (car args))
+ (type (car types)))
+ (when (and (eq (continuation-type-check arg) :no-check)
+ safe-p
+ (not (eq (template-policy template) :safe)))
+ (return nil))
+ (unless (operand-restriction-ok type (continuation-ptype arg)
+ :cont arg)
+ (return nil))))))
+
+;;; Check that Template can be used with the specifed Result-Type. Result
+;;; type checking is pretty different from argument type checking due to the
+;;; relaxed rules for values count. We succeed if for each required result,
+;;; there is a positional restriction on the value that is at least as good.
+;;; If we run out of result types before we run out of restrictions, then we
+;;; only succeed if the leftover restrictions are *. If we run out of
+;;; restrictions before we run out of result types, then we always win.
+(defun template-results-ok (template result-type)
+ (declare (type template template)
+ (type ctype result-type))
+ (when (template-more-results-type template)
+ (error "~S has :MORE results with :TRANSLATE." (template-name template)))
+ (let ((types (template-result-types template)))
+ (cond
+ ((values-type-p result-type)
+ (do ((ltypes (append (args-type-required result-type)
+ (args-type-optional result-type))
+ (rest ltypes))
+ (types types (rest types)))
+ ((null ltypes)
+ (dolist (type types t)
+ (unless (eq type '*)
+ (return nil))))
+ (when (null types) (return t))
+ (let ((type (first types)))
+ (unless (operand-restriction-ok type
+ (primitive-type (first ltypes)))
+ (return nil)))))
+ (types
+ (operand-restriction-ok (first types) (primitive-type result-type)))
+ (t t))))
+
+;;; Return true if Call is an ok use of Template according to Safe-P.
+;;; -- If the template has a Guard that isn't true, then we ignore the
+;;; template, not even considering it to be rejected.
+;;; -- If the argument type restrictions aren't satisfied, then we reject the
+;;; template.
+;;; -- If the template is :Conditional, then we accept it only when the
+;;; destination of the value is an immediately following IF node.
+;;; -- If either the template is safe or the policy is unsafe (i.e. we can
+;;; believe output assertions), then we test against the intersection of the
+;;; node derived type and the continuation asserted type. Otherwise, we
+;;; just use the node type. If TYPE-CHECK is null, there is no point in
+;;; doing the intersection, since the node type must be a subtype of the
+;;; assertion.
+;;;
+;;; If the template is *not* ok, then the second value is a keyword indicating
+;;; which aspect failed.
+(defun is-ok-template-use (template call safe-p)
+ (declare (type template template) (type combination call))
+ (let* ((guard (template-guard template))
+ (cont (node-cont call))
+ (atype (continuation-asserted-type cont))
+ (dtype (node-derived-type call)))
+ (cond ((and guard (not (funcall guard)))
+ (values nil :guard))
+ ((not (template-args-ok template call safe-p))
+ (values nil
+ (if (and safe-p (template-args-ok template call nil))
+ :arg-check
+ :arg-types)))
+ ((eq (template-result-types template) :conditional)
+ (let ((dest (continuation-dest cont)))
+ (if (and (if-p dest)
+ (immediately-used-p (if-test dest) call))
+ (values t nil)
+ (values nil :conditional))))
+ ((template-results-ok
+ template
+ (if (and (or (eq (template-policy template) :safe)
+ (not safe-p))
+ (continuation-type-check cont))
+ (values-type-intersection dtype atype)
+ dtype))
+ (values t nil))
+ (t
+ (values nil :result-types)))))
+
+;;; Use operand type information to choose a template from the list
+;;; Templates for a known Call. We return three values:
+;;; 1. The template we found.
+;;; 2. Some template that we rejected due to unsatisfied type restrictions, or
+;;; NIL if none.
+;;; 3. The tail of Templates for templates we haven't examined yet.
+;;;
+;;; We just call IS-OK-TEMPLATE-USE until it returns true.
+(defun find-template (templates call safe-p)
+ (declare (list templates) (type combination call))
+ (do ((templates templates (rest templates))
+ (rejected nil))
+ ((null templates)
+ (values nil rejected nil))
+ (let ((template (first templates)))
+ (when (is-ok-template-use template call safe-p)
+ (return (values template rejected (rest templates))))
+ (setq rejected template))))
+
+;;; Given a partially annotated known call and a translation policy, return
+;;; the appropriate template, or NIL if none can be found. We scan the
+;;; templates (ordered by increasing cost) looking for a template whose
+;;; restrictions are satisfied and that has our policy.
+;;;
+;;; If we find a template that doesn't have our policy, but has a legal
+;;; alternate policy, then we also record that to return as a last resort. If
+;;; our policy is safe, then only safe policies are O.K., otherwise anything
+;;; goes.
+;;;
+;;; If we find a template with :SAFE policy, then we return it, or any cheaper
+;;; fallback template. The theory behind this is that if it is cheapest, small
+;;; and safe, we can't lose. If it is not cheapest, then we use the fallback,
+;;; which won't have the desired policy, but :SAFE isn't desired either, so we
+;;; might as well go with the cheaper one. The main reason for doing this is
+;;; to make sure that cheap safe templates are used when they apply and the
+;;; current policy is something else. This is useful because :SAFE has the
+;;; additional semantics of implicit argument type checking, so we may be
+;;; forced to define a template with :SAFE policy when it is really small and
+;;; fast as well.
+(defun find-template-for-policy (call policy)
+ (declare (type combination call)
+ (type policies policy))
+ (let ((safe-p (policy-safe-p policy))
+ (current (function-info-templates (basic-combination-kind call)))
+ (fallback nil)
+ (rejected nil))
+ (loop
+ (multiple-value-bind (template this-reject more)
+ (find-template current call safe-p)
+ (unless rejected
+ (setq rejected this-reject))
+ (setq current more)
+ (unless template
+ (return (values fallback rejected)))
+
+ (let ((tpolicy (template-policy template)))
+ (cond ((eq tpolicy policy)
+ (return (values template rejected)))
+ ((eq tpolicy :safe)
+ (return (values (or fallback template) rejected)))
+ ((or (not safe-p) (eq tpolicy :fast-safe))
+ (unless fallback
+ (setq fallback template)))))))))
+
+(defvar *efficiency-note-limit* 2
+ #!+sb-doc
+ "This is the maximum number of possible optimization alternatives will be
+ mentioned in a particular efficiency note. NIL means no limit.")
+(declaim (type (or index null) *efficiency-note-limit*))
+
+(defvar *efficiency-note-cost-threshold* 5
+ #!+sb-doc
+ "This is the minumum cost difference between the chosen implementation and
+ the next alternative that justifies an efficiency note.")
+(declaim (type index *efficiency-note-cost-threshold*))
+
+;;; This function is called by NOTE-REJECTED-TEMPLATES when it can't figure
+;;; out any reason why Template was rejected. Users should never see these
+;;; messages, but they can happen in situations where the VM definition is
+;;; messed up somehow.
+(defun strange-template-failure (template call policy frob)
+ (declare (type template template) (type combination call)
+ (type policies policy) (type function frob))
+ (funcall frob "This shouldn't happen! Bug?")
+ (multiple-value-bind (win why)
+ (is-ok-template-use template call (policy-safe-p policy))
+ (assert (not win))
+ (ecase why
+ (:guard
+ (funcall frob "template guard failed"))
+ (:arg-check
+ (funcall frob "The template isn't safe, yet we were counting on it."))
+ (:arg-types
+ (funcall frob "argument types invalid")
+ (funcall frob "argument primitive types:~% ~S"
+ (mapcar #'(lambda (x)
+ (primitive-type-name
+ (continuation-ptype x)))
+ (combination-args call)))
+ (funcall frob "argument type assertions:~% ~S"
+ (mapcar #'(lambda (x)
+ (if (atom x)
+ x
+ (ecase (car x)
+ (:or `(:or .,(mapcar #'primitive-type-name
+ (cdr x))))
+ (:constant `(:constant ,(third x))))))
+ (template-arg-types template))))
+ (:conditional
+ (funcall frob "conditional in a non-conditional context"))
+ (:result-types
+ (funcall frob "result types invalid")))))
+
+;;; This function emits efficiency notes describing all of the templates
+;;; better (faster) than Template that we might have been able to use if there
+;;; were better type declarations. Template is null when we didn't find any
+;;; template, and thus must do a full call.
+;;;
+;;; In order to be worth complaining about, a template must:
+;;; -- be allowed by its guard,
+;;; -- be safe if the current policy is safe,
+;;; -- have argument/result type restrictions consistent with the known type
+;;; information, e.g. we don't consider float templates when an operand is
+;;; known to be an integer,
+;;; -- be disallowed by the stricter operand subtype test (which resembles, but
+;;; is not identical to the test done by Find-Template.)
+;;;
+;;; Note that there may not be any possibly applicable templates, since we are
+;;; called whenever any template is rejected. That template might have the
+;;; wrong policy or be inconsistent with the known type.
+;;;
+;;; We go to some trouble to make the whole multi-line output into a single
+;;; call to Compiler-Note so that repeat messages are suppressed, etc.
+(defun note-rejected-templates (call policy template)
+ (declare (type combination call) (type policies policy)
+ (type (or template null) template))
+
+ (collect ((losers))
+ (let ((safe-p (policy-safe-p policy))
+ (verbose-p (policy call (= brevity 0)))
+ (max-cost (- (template-cost
+ (or template
+ (template-or-lose 'call-named)))
+ *efficiency-note-cost-threshold*)))
+ (dolist (try (function-info-templates (basic-combination-kind call)))
+ (when (> (template-cost try) max-cost) (return))
+ (let ((guard (template-guard try)))
+ (when (and (or (not guard) (funcall guard))
+ (or (not safe-p)
+ (policy-safe-p (template-policy try)))
+ (or verbose-p
+ (and (template-note try)
+ (valid-function-use
+ call (template-type try)
+ :argument-test #'types-intersect
+ :result-test #'values-types-intersect))))
+ (losers try)))))
+
+ (when (losers)
+ (collect ((messages)
+ (count 0 +))
+ (flet ((frob (string &rest stuff)
+ (messages string)
+ (messages stuff)))
+ (dolist (loser (losers))
+ (when (and *efficiency-note-limit*
+ (>= (count) *efficiency-note-limit*))
+ (frob "etc.")
+ (return))
+ (let* ((type (template-type loser))
+ (valid (valid-function-use call type))
+ (strict-valid (valid-function-use call type
+ :strict-result t)))
+ (frob "unable to do ~A (cost ~D) because:"
+ (or (template-note loser) (template-name loser))
+ (template-cost loser))
+ (cond
+ ((and valid strict-valid)
+ (strange-template-failure loser call policy #'frob))
+ ((not valid)
+ (assert (not (valid-function-use call type
+ :error-function #'frob
+ :warning-function #'frob))))
+ (t
+ (assert (policy-safe-p policy))
+ (frob "can't trust output type assertion under safe policy")))
+ (count 1))))
+
+ (let ((*compiler-error-context* call))
+ (compiler-note "~{~?~^~&~6T~}"
+ (if template
+ `("forced to do ~A (cost ~D)"
+ (,(or (template-note template)
+ (template-name template))
+ ,(template-cost template))
+ . ,(messages))
+ `("forced to do full call"
+ nil
+ . ,(messages))))))))
+ (values))
+
+;;; Flush type checks according to policy. If the policy is
+;;; unsafe, then we never do any checks. If our policy is safe, and
+;;; we are using a safe template, then we can also flush arg and
+;;; result type checks. Result type checks are only flushed when the
+;;; continuation as a single use. Result type checks are not flush if
+;;; the policy is safe because the selection of template for results
+;;; readers assumes the type check is done (uses the derived type
+;;; which is the intersection of the proven and asserted types).
+(defun flush-type-checks-according-to-policy (call policy template)
+ (declare (type combination call) (type policies policy)
+ (type template template))
+ (let ((safe-op (eq (template-policy template) :safe)))
+ (when (or (not (policy-safe-p policy)) safe-op)
+ (dolist (arg (basic-combination-args call))
+ (flush-type-check arg)))
+ (when safe-op
+ (let ((cont (node-cont call)))
+ (when (and (eq (continuation-use cont) call)
+ (not (policy-safe-p policy)))
+ (flush-type-check cont)))))
+
+ (values))
+
+;;; If a function has a special-case annotation method use that, otherwise
+;;; annotate the argument continuations and try to find a template
+;;; corresponding to the type signature. If there is none, convert a full call.
+(defun ltn-analyze-known-call (call policy)
+ (declare (type combination call)
+ (type policies policy))
+ (let ((method (function-info-ltn-annotate (basic-combination-kind call)))
+ (args (basic-combination-args call)))
+ (when method
+ (funcall method call policy)
+ (return-from ltn-analyze-known-call (values)))
+
+ (dolist (arg args)
+ (setf (continuation-info arg)
+ (make-ir2-continuation (primitive-type (continuation-type arg)))))
+
+ (multiple-value-bind (template rejected)
+ (find-template-for-policy call policy)
+ ;; If we are unable to use some templates due to unsatisfied operand type
+ ;; restrictions and our policy enables efficiency notes, then we call
+ ;; Note-Rejected-Templates.
+ (when (and rejected
+ (policy call (> speed brevity)))
+ (note-rejected-templates call policy template))
+ ;; If we are forced to do a full call, we check to see whether the
+ ;; function called is the same as the current function. If so, we
+ ;; give a warning, as this is probably a botched interpreter stub.
+ (unless template
+ (when (and (eq (continuation-function-name (combination-fun call))
+ (leaf-name
+ (environment-function
+ (node-environment call))))
+ (let ((info (basic-combination-kind call)))
+ (not (or (function-info-ir2-convert info)
+ (ir1-attributep (function-info-attributes info)
+ recursive)))))
+ (let ((*compiler-error-context* call))
+ (compiler-warning "recursive known function definition")))
+ (ltn-default-call call policy)
+ (return-from ltn-analyze-known-call (values)))
+ (setf (basic-combination-info call) template)
+ (setf (node-tail-p call) nil)
+
+ (flush-type-checks-according-to-policy call policy template)
+
+ (dolist (arg args)
+ (annotate-1-value-continuation arg))))
+
+ (values))
+\f
+;;;; interfaces
+
+;;; We make the main per-block code in for LTN into a macro so that it can
+;;; be shared between LTN-Analyze and LTN-Analyze-Block, yet can cache policy
+;;; across blocks in the normal (full component) case.
+;;;
+;;; This code computes the policy and then dispatches to the appropriate
+;;; node-specific function.
+;;;
+;;; Note: we deliberately don't use the DO-NODES macro, since the block can be
+;;; split out from underneath us, and DO-NODES would scan past the block end in that
+;;; case.
+(macrolet ((frob ()
+ '(do* ((node (continuation-next (block-start block))
+ (continuation-next cont))
+ (cont (node-cont node) (node-cont node))
+ ;; KLUDGE: Since LEXENV and POLICY seem to be only used
+ ;; inside this FROB, why not define them in here instead of
+ ;; requiring them to be defined externally both in
+ ;; LTN-ANALYZE and LTN-ANALYZE-BLOCK? Or perhaps just
+ ;; define this whole FROB as an inline function? (Right now
+ ;; I don't want to make even a small unnecessary change
+ ;; like this, but'd prefer to wait until the system runs so
+ ;; that I can test it immediately after the change.)
+ ;; -- WHN 19990808
+ )
+ (())
+ (unless (eq (node-lexenv node) lexenv)
+ (setq policy (translation-policy node))
+ (setq lexenv (node-lexenv node)))
+
+ (etypecase node
+ (ref)
+ (combination
+ (case (basic-combination-kind node)
+ (:local (ltn-analyze-local-call node policy))
+ ((:full :error) (ltn-default-call node policy))
+ (t
+ (ltn-analyze-known-call node policy))))
+ (cif
+ (ltn-analyze-if node policy))
+ (creturn
+ (ltn-analyze-return node policy))
+ ((or bind entry))
+ (exit
+ (ltn-analyze-exit node policy))
+ (cset (ltn-analyze-set node policy))
+ (mv-combination
+ (ecase (basic-combination-kind node)
+ (:local (ltn-analyze-mv-bind node policy))
+ ((:full :error) (ltn-analyze-mv-call node policy)))))
+
+ (when (eq node (block-last block))
+ (return)))))
+
+;;; Loop over the blocks in Component, doing stuff to nodes that receive
+;;; values. In addition to the stuff done by FROB, we also see whether there
+;;; are any unknown values receivers, making notations in the components
+;;; Generators and Receivers as appropriate.
+;;;
+;;; If any unknown-values continations are received by this block (as
+;;; indicated by IR2-Block-Popped, then we add the block to the
+;;; IR2-Component-Values-Receivers.
+;;;
+;;; This is where we allocate IR2 blocks because it is the first place we
+;;; need them.
+(defun ltn-analyze (component)
+ (declare (type component component))
+ (let ((2comp (component-info component))
+ (lexenv nil)
+ policy)
+ (do-blocks (block component)
+ (assert (not (block-info block)))
+ (let ((2block (make-ir2-block block)))
+ (setf (block-info block) 2block)
+ (frob)
+ (let ((popped (ir2-block-popped 2block)))
+ (when popped
+ (push block (ir2-component-values-receivers 2comp)))))))
+ (values))
+
+;;; This function is used to analyze blocks that must be added to the flow
+;;; graph after the normal LTN phase runs. Such code is constrained not to
+;;; use weird unknown values (and probably in lots of other ways).
+(defun ltn-analyze-block (block)
+ (declare (type cblock block))
+ (let ((lexenv nil)
+ policy)
+ (frob))
+ (assert (not (ir2-block-popped (block-info block))))
+ (values))
+
+) ; MACROLET FROB
--- /dev/null
+;;;; This file implements LOAD-TIME-VALUE.
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!C")
+
+(file-comment
+ "$Header$")
+
+(defknown %load-time-value (t) t (flushable movable))
+
+(def-ir1-translator load-time-value ((form &optional read-only-p) start cont)
+ #!+sb-doc
+ "Arrange for FORM to be evaluated at load-time and use the value produced
+ as if it were a constant. If READ-ONLY-P is non-NIL, then the resultant
+ object is guaranteed to never be modified, so it can be put in read-only
+ storage."
+ (if (producing-fasl-file)
+ (multiple-value-bind (handle type)
+ (compile-load-time-value (if read-only-p
+ form
+ `(make-value-cell ,form)))
+ (declare (ignore type))
+ (ir1-convert start cont
+ (if read-only-p
+ `(%load-time-value ',handle)
+ `(value-cell-ref (%load-time-value ',handle)))))
+ (let ((value
+ (handler-case (eval form)
+ (error (condition)
+ (compiler-error "(during EVAL of LOAD-TIME-VALUE)~%~A"
+ condition)))))
+ (ir1-convert start cont
+ (if read-only-p
+ `',value
+ `(value-cell-ref ',(make-value-cell value)))))))
+
+(defoptimizer (%load-time-value ir2-convert) ((handle) node block)
+ (assert (constant-continuation-p handle))
+ (let ((cont (node-cont node))
+ (tn (make-load-time-value-tn (continuation-value handle)
+ *universal-type*)))
+ (move-continuation-result node block (list tn) cont)))
--- /dev/null
+;;;; miscellaneous types and macros used in writing the compiler
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!C")
+
+(file-comment
+ "$Header$")
+
+(declaim (special *wild-type* *universal-type* *compiler-error-context*))
+
+;;; An INLINEP value describes how a function is called. The values have these
+;;; meanings:
+;;; NIL No declaration seen: do whatever you feel like, but don't dump
+;;; an inline expansion.
+;;; :NOTINLINE NOTINLINE declaration seen: always do full function call.
+;;; :INLINE INLINE declaration seen: save expansion, expanding to it if
+;;; policy favors.
+;;; :MAYBE-INLINE
+;;; Retain expansion, but only use it opportunistically.
+(deftype inlinep () '(member :inline :maybe-inline :notinline nil))
+\f
+;;;; the POLICY macro
+
+(defparameter *policy-parameter-slots*
+ '((speed . cookie-speed) (space . cookie-space) (safety . cookie-safety)
+ (cspeed . cookie-cspeed) (brevity . cookie-brevity)
+ (debug . cookie-debug)))
+
+;;; Find all the policy parameters which are actually mentioned in Stuff,
+;;; returning the names in a list. We assume everything is evaluated.
+(eval-when (:compile-toplevel :load-toplevel :execute)
+(defun find-used-parameters (stuff)
+ (if (atom stuff)
+ (if (assoc stuff *policy-parameter-slots*) (list stuff) ())
+ (collect ((res () nunion))
+ (dolist (arg (cdr stuff) (res))
+ (res (find-used-parameters arg))))))
+) ; EVAL-WHEN
+
+;;; This macro provides some syntactic sugar for querying the settings of
+;;; the compiler policy parameters.
+(defmacro policy (node &rest conditions)
+ #!+sb-doc
+ "Policy Node Condition*
+ Test whether some conditions apply to the current compiler policy for Node.
+ Each condition is a predicate form which accesses the policy values by
+ referring to them as the variables SPEED, SPACE, SAFETY, CSPEED, BREVITY and
+ DEBUG. The results of all the conditions are combined with AND and returned
+ as the result.
+
+ Node is a form which is evaluated to obtain the node which the policy is for.
+ If Node is NIL, then we use the current policy as defined by *DEFAULT-COOKIE*
+ and *CURRENT-COOKIE*. This option is only well defined during IR1
+ conversion."
+ (let* ((form `(and ,@conditions))
+ (n-cookie (gensym))
+ (binds (mapcar
+ #'(lambda (name)
+ (let ((slot (cdr (assoc name *policy-parameter-slots*))))
+ `(,name (,slot ,n-cookie))))
+ (find-used-parameters form))))
+ `(let* ((,n-cookie (lexenv-cookie
+ ,(if node
+ `(node-lexenv ,node)
+ '*lexenv*)))
+ ,@binds)
+ ,form)))
+\f
+;;;; source-hacking defining forms
+
+;;; Passed to PARSE-DEFMACRO when we want compiler errors instead of real
+;;; errors.
+#!-sb-fluid (declaim (inline convert-condition-into-compiler-error))
+(defun convert-condition-into-compiler-error (datum &rest stuff)
+ (if (stringp datum)
+ (apply #'compiler-error datum stuff)
+ (compiler-error "~A"
+ (if (symbolp datum)
+ (apply #'make-condition datum stuff)
+ datum))))
+
+;;; Parse DEFMACRO-style lambda-list, setting things up so that a
+;;; compiler error happens if the syntax is invalid.
+(defmacro def-ir1-translator (name (lambda-list start-var cont-var
+ &key (kind :special-form))
+ &body body)
+ #!+sb-doc
+ "Def-IR1-Translator Name (Lambda-List Start-Var Cont-Var {Key Value}*)
+ [Doc-String] Form*
+ Define a function that converts a Special-Form or other magical thing into
+ IR1. Lambda-List is a defmacro style lambda list. Start-Var and Cont-Var
+ are bound to the start and result continuations for the resulting IR1.
+ This keyword is defined:
+ Kind
+ The function kind to associate with Name (default :special-form)."
+ (let ((fn-name (symbolicate "IR1-CONVERT-" name))
+ (n-form (gensym))
+ (n-env (gensym)))
+ (multiple-value-bind (body decls doc)
+ (parse-defmacro lambda-list n-form body name "special form"
+ :environment n-env
+ :error-fun 'convert-condition-into-compiler-error)
+ `(progn
+ (declaim (ftype (function (continuation continuation t) (values))
+ ,fn-name))
+ (defun ,fn-name (,start-var ,cont-var ,n-form)
+ (let ((,n-env *lexenv*))
+ ,@decls
+ ,body
+ (values)))
+ ,@(when doc
+ `((setf (fdocumentation ',name 'function) ,doc)))
+ ;; FIXME: Evidently "there can only be one!" -- we overwrite any
+ ;; other :IR1-CONVERT value. This deserves a warning, I think.
+ (setf (info :function :ir1-convert ',name) #',fn-name)
+ (setf (info :function :kind ',name) ,kind)
+ ;; It's nice to do this for error checking in the target
+ ;; SBCL, but it's not nice to do this when we're running in
+ ;; the cross-compilation host Lisp, which owns the
+ ;; SYMBOL-FUNCTION of its COMMON-LISP symbols.
+ #-sb-xc-host
+ ,@(when (eq kind :special-form)
+ `((setf (symbol-function ',name)
+ (lambda (&rest rest)
+ (declare (ignore rest))
+ (error "Can't FUNCALL the SYMBOL-FUNCTION of ~
+ special forms.")))))))))
+
+;;; Similar to DEF-IR1-TRANSLATOR, except that we pass if the syntax is
+;;; invalid.
+(defmacro def-source-transform (name lambda-list &body body)
+ #!+sb-doc
+ "Def-Source-Transform Name Lambda-List Form*
+ Define a macro-like source-to-source transformation for the function Name.
+ A source transform may \"pass\" by returning a non-nil second value. If the
+ transform passes, then the form is converted as a normal function call. If
+ the supplied arguments are not compatible with the specified lambda-list,
+ then the transform automatically passes.
+
+ Source-Transforms may only be defined for functions. Source transformation
+ is not attempted if the function is declared Notinline. Source transforms
+ should not examine their arguments. If it matters how the function is used,
+ then Deftransform should be used to define an IR1 transformation.
+
+ If the desirability of the transformation depends on the current Optimize
+ parameters, then the Policy macro should be used to determine when to pass."
+ (let ((fn-name
+ (if (listp name)
+ (collect ((pieces))
+ (dolist (piece name)
+ (pieces "-")
+ (pieces piece))
+ (apply #'symbolicate "SOURCE-TRANSFORM" (pieces)))
+ (symbolicate "SOURCE-TRANSFORM-" name)))
+ (n-form (gensym))
+ (n-env (gensym)))
+ (multiple-value-bind (body decls)
+ (parse-defmacro lambda-list n-form body name "form"
+ :environment n-env
+ :error-fun `(lambda (&rest stuff)
+ (declare (ignore stuff))
+ (return-from ,fn-name
+ (values nil t))))
+ `(progn
+ (defun ,fn-name (,n-form)
+ (let ((,n-env *lexenv*))
+ ,@decls
+ ,body))
+ (setf (info :function :source-transform ',name) #',fn-name)))))
+
+(defmacro def-primitive-translator (name lambda-list &body body)
+ #!+sb-doc
+ "DEF-PRIMITIVE-TRANSLATOR Name Lambda-List Form*
+ Define a function that converts a use of (%PRIMITIVE Name ...) into Lisp
+ code. Lambda-List is a DEFMACRO-style lambda list."
+ (let ((fn-name (symbolicate "PRIMITIVE-TRANSLATE-" name))
+ (n-form (gensym))
+ (n-env (gensym)))
+ (multiple-value-bind (body decls)
+ (parse-defmacro lambda-list n-form body name "%primitive"
+ :environment n-env
+ :error-fun 'convert-condition-into-compiler-error)
+ `(progn
+ (defun ,fn-name (,n-form)
+ (let ((,n-env *lexenv*))
+ ,@decls
+ ,body))
+ (setf (gethash ',name *primitive-translators*) ',fn-name)))))
+\f
+;;;; boolean attribute utilities
+;;;;
+;;;; We need to maintain various sets of boolean attributes for known
+;;;; functions and VOPs. To save space and allow for quick set
+;;;; operations, we represent the attributes as bits in a fixnum.
+
+(deftype attributes () 'fixnum)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+
+;;; Given a list of attribute names and an alist that translates them
+;;; to masks, return the OR of the masks.
+(defun compute-attribute-mask (names alist)
+ (collect ((res 0 logior))
+ (dolist (name names)
+ (let ((mask (cdr (assoc name alist))))
+ (unless mask
+ (error "Unknown attribute name: ~S." name))
+ (res mask)))
+ (res)))
+
+) ; EVAL-WHEN
+
+;;; Parse the specification and generate some accessor macros.
+;;;
+;;; KLUDGE: This is expanded out twice, by cut-and-paste, in a
+;;; (DEF!MACRO FOO (..) .. CL:GET-SETF-EXPANSION ..)
+;;; #+SB-XC-HOST
+;;; (SB!XC:DEFMACRO FOO (..) .. SB!XC:GET-SETF-EXPANSION ..)
+;;; arrangement, in order to get it to work in cross-compilation. This
+;;; duplication should be removed, perhaps by rewriting the macro in a
+;;; more cross-compiler-friendly way, or perhaps just by using some
+;;; (MACROLET ((FROB ..)) .. FROB .. FROB) form, but I don't want to
+;;; do it now, because the system isn't running yet, so it'd be too
+;;; hard to check that my changes were correct -- WHN 19990806
+(def!macro def-boolean-attribute (name &rest attribute-names)
+ #!+sb-doc
+ "Def-Boolean-Attribute Name Attribute-Name*
+ Define a new class of boolean attributes, with the attributes having the
+ specified Attribute-Names. Name is the name of the class, which is used to
+ generate some macros to manipulate sets of the attributes:
+
+ NAME-attributep attributes attribute-name*
+ Return true if one of the named attributes is present, false otherwise.
+ When set with SETF, updates the place Attributes setting or clearing the
+ specified attributes.
+
+ NAME-attributes attribute-name*
+ Return a set of the named attributes."
+
+ (let ((const-name (symbolicate name "-ATTRIBUTE-TRANSLATIONS"))
+ (test-name (symbolicate name "-ATTRIBUTEP")))
+ (collect ((alist))
+ (do ((mask 1 (ash mask 1))
+ (names attribute-names (cdr names)))
+ ((null names))
+ (alist (cons (car names) mask)))
+
+ `(progn
+ (eval-when (:compile-toplevel :load-toplevel :execute)
+ (defconstant ,const-name ',(alist)))
+
+ (defmacro ,test-name (attributes &rest attribute-names)
+ "Automagically generated boolean attribute test function. See
+ Def-Boolean-Attribute."
+ `(logtest ,(compute-attribute-mask attribute-names ,const-name)
+ (the attributes ,attributes)))
+
+ (define-setf-expander ,test-name (place &rest attributes
+ &environment env)
+ "Automagically generated boolean attribute setter. See
+ Def-Boolean-Attribute."
+ #-sb-xc-host (declare (type sb!c::lexenv env))
+ ;; FIXME: It would be better if &ENVIRONMENT arguments
+ ;; were automatically declared to have type LEXENV by the
+ ;; hairy-argument-handling code.
+ (multiple-value-bind (temps values stores set get)
+ (get-setf-expansion place env)
+ (when (cdr stores)
+ (error "multiple store variables for ~S" place))
+ (let ((newval (gensym))
+ (n-place (gensym))
+ (mask (compute-attribute-mask attributes ,const-name)))
+ (values `(,@temps ,n-place)
+ `(,@values ,get)
+ `(,newval)
+ `(let ((,(first stores)
+ (if ,newval
+ (logior ,n-place ,mask)
+ (logand ,n-place ,(lognot mask)))))
+ ,set
+ ,newval)
+ `(,',test-name ,n-place ,@attributes)))))
+
+ (defmacro ,(symbolicate name "-ATTRIBUTES") (&rest attribute-names)
+ "Automagically generated boolean attribute creation function. See
+ Def-Boolean-Attribute."
+ (compute-attribute-mask attribute-names ,const-name))))))
+;;; #+SB-XC-HOST SB!XC:DEFMACRO version is in late-macros.lisp. -- WHN 19990806
+
+;;; And now for some gratuitous pseudo-abstraction...
+(defmacro attributes-union (&rest attributes)
+ #!+sb-doc
+ "Returns the union of all the sets of boolean attributes which are its
+ arguments."
+ `(the attributes
+ (logior ,@(mapcar #'(lambda (x) `(the attributes ,x)) attributes))))
+(defmacro attributes-intersection (&rest attributes)
+ #!+sb-doc
+ "Returns the intersection of all the sets of boolean attributes which are its
+ arguments."
+ `(the attributes
+ (logand ,@(mapcar #'(lambda (x) `(the attributes ,x)) attributes))))
+(declaim (ftype (function (attributes attributes) boolean) attributes=))
+#!-sb-fluid (declaim (inline attributes=))
+(defun attributes= (attr1 attr2)
+ #!+sb-doc
+ "Returns true if the attributes present in Attr1 are identical to those in
+ Attr2."
+ (eql attr1 attr2))
+\f
+;;;; lambda-list parsing utilities
+;;;;
+;;;; IR1 transforms, optimizers and type inferencers need to be able
+;;;; to parse the IR1 representation of a function call using a
+;;;; standard function lambda-list.
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+
+;;; Given a DEFTRANSFORM-style lambda-list, generate code that parses
+;;; the arguments of a combination with respect to that lambda-list.
+;;; BODY is the the list of forms which are to be evaluated within the
+;;; bindings. ARGS is the variable that holds list of argument
+;;; continuations. ERROR-FORM is a form which is evaluated when the
+;;; syntax of the supplied arguments is incorrect or a non-constant
+;;; argument keyword is supplied. Defaults and other gunk are ignored.
+;;; The second value is a list of all the arguments bound. We make the
+;;; variables IGNORABLE so that we don't have to manually declare them
+;;; Ignore if their only purpose is to make the syntax work.
+(declaim (ftype (function (list list symbol t) list) parse-deftransform))
+(defun parse-deftransform (lambda-list body args error-form)
+ (multiple-value-bind (req opt restp rest keyp keys allowp)
+ (parse-lambda-list lambda-list)
+ (let* ((min-args (length req))
+ (max-args (+ min-args (length opt)))
+ (n-keys (gensym)))
+ (collect ((binds)
+ (vars)
+ (pos 0 +)
+ (keywords))
+ (dolist (arg req)
+ (vars arg)
+ (binds `(,arg (nth ,(pos) ,args)))
+ (pos 1))
+
+ (dolist (arg opt)
+ (let ((var (if (atom arg) arg (first arg))))
+ (vars var)
+ (binds `(,var (nth ,(pos) ,args)))
+ (pos 1)))
+
+ (when restp
+ (vars rest)
+ (binds `(,rest (nthcdr ,(pos) ,args))))
+
+ (dolist (spec keys)
+ (if (or (atom spec) (atom (first spec)))
+ (let* ((var (if (atom spec) spec (first spec)))
+ (key (intern (symbol-name var) "KEYWORD")))
+ (vars var)
+ (binds `(,var (find-keyword-continuation ,n-keys ,key)))
+ (keywords key))
+ (let* ((head (first spec))
+ (var (second head))
+ (key (first head)))
+ (vars var)
+ (binds `(,var (find-keyword-continuation ,n-keys ,key)))
+ (keywords key))))
+
+ (let ((n-length (gensym))
+ (limited-legal (not (or restp keyp))))
+ (values
+ `(let ((,n-length (length ,args))
+ ,@(when keyp `((,n-keys (nthcdr ,(pos) ,args)))))
+ (unless (and
+ ;; FIXME: should be PROPER-LIST-OF-LENGTH-P
+ ,(if limited-legal
+ `(<= ,min-args ,n-length ,max-args)
+ `(<= ,min-args ,n-length))
+ ,@(when keyp
+ (if allowp
+ `((check-keywords-constant ,n-keys))
+ `((check-transform-keys ,n-keys ',(keywords))))))
+ ,error-form)
+ (let ,(binds)
+ (declare (ignorable ,@(vars)))
+ ,@body))
+ (vars)))))))
+
+) ; EVAL-WHEN
+\f
+;;;; DEFTRANSFORM
+
+;;; Parse the lambda-list and generate code to test the policy and
+;;; automatically create the result lambda.
+(defmacro deftransform (name (lambda-list &optional (arg-types '*)
+ (result-type '*)
+ &key result policy node defun-only
+ eval-name important (when :native))
+ &body body-decls-doc)
+ #!+sb-doc
+ "Deftransform Name (Lambda-List [Arg-Types] [Result-Type] {Key Value}*)
+ Declaration* [Doc-String] Form*
+ Define an IR1 transformation for NAME. An IR1 transformation computes a
+ lambda that replaces the function variable reference for the call. A
+ transform may pass (decide not to transform the call) by calling the
+ GIVE-UP-IR1-TRANSFORM function. LAMBDA-LIST both determines how the
+ current call is parsed and specifies the LAMBDA-LIST for the resulting
+ lambda.
+
+ We parse the call and bind each of the lambda-list variables to the
+ continuation which represents the value of the argument. When parsing
+ the call, we ignore the defaults, and always bind the variables for
+ unsupplied arguments to NIL. If a required argument is missing, an
+ unknown keyword is supplied, or an argument keyword is not a constant,
+ then the transform automatically passes. The DECLARATIONS apply to the
+ bindings made by DEFTRANSFORM at transformation time, rather than to
+ the variables of the resulting lambda. Bound-but-not-referenced
+ warnings are suppressed for the lambda-list variables. The DOC-STRING
+ is used when printing efficiency notes about the defined transform.
+
+ Normally, the body evaluates to a form which becomes the body of an
+ automatically constructed lambda. We make LAMBDA-LIST the lambda-list
+ for the lambda, and automatically insert declarations of the argument
+ and result types. If the second value of the body is non-null, then it
+ is a list of declarations which are to be inserted at the head of the
+ lambda. Automatic lambda generation may be inhibited by explicitly
+ returning a lambda from the body.
+
+ The ARG-TYPES and RESULT-TYPE are used to create a function type
+ which the call must satisfy before transformation is attempted. The
+ function type specifier is constructed by wrapping (FUNCTION ...)
+ around these values, so the lack of a restriction may be specified by
+ omitting the argument or supplying *. The argument syntax specified in
+ the ARG-TYPES need not be the same as that in the LAMBDA-LIST, but the
+ transform will never happen if the syntaxes can't be satisfied
+ simultaneously. If there is an existing transform for the same
+ function that has the same type, then it is replaced with the new
+ definition.
+
+ These are the legal keyword options:
+ :Result - A variable which is bound to the result continuation.
+ :Node - A variable which is bound to the combination node for the call.
+ :Policy - A form which is supplied to the POLICY macro to determine whether
+ this transformation is appropriate. If the result is false, then
+ the transform automatically passes.
+ :Eval-Name
+ - The name and argument/result types are actually forms to be
+ evaluated. Useful for getting closures that transform similar
+ functions.
+ :Defun-Only
+ - Don't actually instantiate a transform, instead just DEFUN
+ Name with the specified transform definition function. This may
+ be later instantiated with %DEFTRANSFORM.
+ :Important
+ - If supplied and non-NIL, note this transform as ``important,''
+ which means efficiency notes will be generated when this
+ transform fails even if brevity=speed (but not if brevity>speed)
+ :When {:Native | :Byte | :Both}
+ - Indicates whether this transform applies to native code,
+ byte-code or both (default :native.)"
+
+ (when (and eval-name defun-only)
+ (error "can't specify both DEFUN-ONLY and EVAL-NAME"))
+ (multiple-value-bind (body decls doc) (parse-body body-decls-doc)
+ (let ((n-args (gensym))
+ (n-node (or node (gensym)))
+ (n-decls (gensym))
+ (n-lambda (gensym))
+ (decls-body `(,@decls ,@body)))
+ (multiple-value-bind (parsed-form vars)
+ (parse-deftransform lambda-list
+ (if policy
+ `((unless (policy ,n-node ,policy)
+ (give-up-ir1-transform))
+ ,@decls-body)
+ body)
+ n-args
+ '(give-up-ir1-transform))
+ (let ((stuff
+ `((,n-node)
+ (let* ((,n-args (basic-combination-args ,n-node))
+ ,@(when result
+ `((,result (node-cont ,n-node)))))
+ (multiple-value-bind (,n-lambda ,n-decls)
+ ,parsed-form
+ (if (and (consp ,n-lambda) (eq (car ,n-lambda) 'lambda))
+ ,n-lambda
+ `(lambda ,',lambda-list
+ (declare (ignorable ,@',vars))
+ ,@,n-decls
+ ,,n-lambda)))))))
+ (if defun-only
+ `(defun ,name ,@(when doc `(,doc)) ,@stuff)
+ `(%deftransform
+ ,(if eval-name name `',name)
+ ,(if eval-name
+ ``(function ,,arg-types ,,result-type)
+ `'(function ,arg-types ,result-type))
+ #'(lambda ,@stuff)
+ ,doc
+ ,(if important t nil)
+ ,when)))))))
+\f
+;;;; DEFKNOWN and DEFOPTIMIZER
+
+;;; This macro should be the way that all implementation independent
+;;; information about functions is made known to the compiler.
+;;;
+;;; FIXME: The comment above suggests that perhaps some of my added
+;;; FTYPE declarations are in poor taste. Should I change my
+;;; declarations, or change the comment, or what?
+;;;
+;;; FIXME: DEFKNOWN is needed only at build-the-system time. Figure
+;;; out some way to keep it from appearing in the target system.
+(defmacro defknown (name arg-types result-type &optional (attributes '(any))
+ &rest keys)
+ #!+sb-doc
+ "Defknown Name Arg-Types Result-Type [Attributes] {Key Value}*
+ Declare the function Name to be a known function. We construct a type
+ specifier for the function by wrapping (FUNCTION ...) around the Arg-Types
+ and Result-Type. Attributes is an unevaluated list of boolean
+ attributes of the function. These attributes are meaningful here:
+ call
+ May call functions that are passed as arguments. In order
+ to determine what other effects are present, we must find
+ the effects of all arguments that may be functions.
+
+ unsafe
+ May incorporate arguments in the result or somehow pass
+ them upward.
+
+ unwind
+ May fail to return during correct execution. Errors
+ are O.K.
+
+ any
+ The (default) worst case. Includes all the other bad
+ things, plus any other possible bad thing.
+
+ foldable
+ May be constant-folded. The function has no side effects,
+ but may be affected by side effects on the arguments. E.g.
+ SVREF, MAPC.
+
+ flushable
+ May be eliminated if value is unused. The function has
+ no side effects except possibly CONS. If a function is
+ defined to signal errors, then it is not flushable even
+ if it is movable or foldable.
+
+ movable
+ May be moved with impunity. Has no side effects except
+ possibly CONS,and is affected only by its arguments.
+
+ predicate
+ A true predicate likely to be open-coded. This is a
+ hint to IR1 conversion that it should ensure calls always
+ appear as an IF test. Not usually specified to Defknown,
+ since this is implementation dependent, and is usually
+ automatically set by the Define-VOP :Conditional option.
+
+ Name may also be a list of names, in which case the same information
+ is given to all the names. The keywords specify the initial values
+ for various optimizers that the function might have."
+ (when (and (intersection attributes '(any call unwind))
+ (intersection attributes '(movable)))
+ (error "Function cannot have both good and bad attributes: ~S" attributes))
+
+ `(%defknown ',(if (and (consp name)
+ (not (eq (car name) 'setf)))
+ name
+ (list name))
+ '(function ,arg-types ,result-type)
+ (ir1-attributes ,@(if (member 'any attributes)
+ (union '(call unsafe unwind) attributes)
+ attributes))
+ ,@keys))
+
+;;; Create a function which parses combination args according to
+;;; LAMBDA-LIST, optionally storing it in a FUNCTION-INFO slot.
+(defmacro defoptimizer (what (lambda-list &optional (n-node (gensym))
+ &rest vars)
+ &body body)
+ #!+sb-doc
+ "Defoptimizer (Function Kind) (Lambda-List [Node-Var] Var*)
+ Declaration* Form*
+ Define some Kind of optimizer for the named Function. Function must be a
+ known function. Lambda-List is used to parse the arguments to the
+ combination as in Deftransform. If the argument syntax is invalid or there
+ are non-constant keys, then we simply return NIL.
+
+ The function is DEFUN'ed as Function-Kind-OPTIMIZER. Possible kinds are
+ DERIVE-TYPE, OPTIMIZER, LTN-ANNOTATE and IR2-CONVERT. If a symbol is
+ specified instead of a (Function Kind) list, then we just do a DEFUN with the
+ symbol as its name, and don't do anything with the definition. This is
+ useful for creating optimizers to be passed by name to DEFKNOWN.
+
+ If supplied, Node-Var is bound to the combination node being optimized. If
+ additional Vars are supplied, then they are used as the rest of the optimizer
+ function's lambda-list. LTN-ANNOTATE methods are passed an additional POLICY
+ argument, and IR2-CONVERT methods are passed an additional IR2-BLOCK
+ argument."
+
+ (let ((name (if (symbolp what) what
+ (symbolicate (first what) "-" (second what) "-OPTIMIZER"))))
+
+ (let ((n-args (gensym)))
+ `(progn
+ (defun ,name (,n-node ,@vars)
+ (let ((,n-args (basic-combination-args ,n-node)))
+ ,(parse-deftransform lambda-list body n-args
+ `(return-from ,name nil))))
+ ,@(when (consp what)
+ `((setf (,(symbolicate "FUNCTION-INFO-" (second what))
+ (function-info-or-lose ',(first what)))
+ #',name)))))))
+\f
+;;;; IR groveling macros
+
+(defmacro do-blocks ((block-var component &optional ends result) &body body)
+ #!+sb-doc
+ "Do-Blocks (Block-Var Component [Ends] [Result-Form]) {Declaration}* {Form}*
+ Iterate over the blocks in a component, binding Block-Var to each block in
+ turn. The value of Ends determines whether to iterate over dummy head and
+ tail blocks:
+ NIL -- Skip Head and Tail (the default)
+ :Head -- Do head but skip tail
+ :Tail -- Do tail but skip head
+ :Both -- Do both head and tail
+
+ If supplied, Result-Form is the value to return."
+ (unless (member ends '(nil :head :tail :both))
+ (error "Losing Ends value: ~S." ends))
+ (let ((n-component (gensym))
+ (n-tail (gensym)))
+ `(let* ((,n-component ,component)
+ (,n-tail ,(if (member ends '(:both :tail))
+ nil
+ `(component-tail ,n-component))))
+ (do ((,block-var ,(if (member ends '(:both :head))
+ `(component-head ,n-component)
+ `(block-next (component-head ,n-component)))
+ (block-next ,block-var)))
+ ((eq ,block-var ,n-tail) ,result)
+ ,@body))))
+(defmacro do-blocks-backwards ((block-var component &optional ends result) &body body)
+ #!+sb-doc
+ "Do-Blocks-Backwards (Block-Var Component [Ends] [Result-Form]) {Declaration}* {Form}*
+ Like Do-Blocks, only iterate over the blocks in reverse order."
+ (unless (member ends '(nil :head :tail :both))
+ (error "Losing Ends value: ~S." ends))
+ (let ((n-component (gensym))
+ (n-head (gensym)))
+ `(let* ((,n-component ,component)
+ (,n-head ,(if (member ends '(:both :head))
+ nil
+ `(component-head ,n-component))))
+ (do ((,block-var ,(if (member ends '(:both :tail))
+ `(component-tail ,n-component)
+ `(block-prev (component-tail ,n-component)))
+ (block-prev ,block-var)))
+ ((eq ,block-var ,n-head) ,result)
+ ,@body))))
+
+;;; Could change it not to replicate the code someday perhaps...
+(defmacro do-uses ((node-var continuation &optional result) &body body)
+ #!+sb-doc
+ "Do-Uses (Node-Var Continuation [Result]) {Declaration}* {Form}*
+ Iterate over the uses of Continuation, binding Node to each one
+ successively."
+ (once-only ((n-cont continuation))
+ `(ecase (continuation-kind ,n-cont)
+ (:unused)
+ (:inside-block
+ (block nil
+ (let ((,node-var (continuation-use ,n-cont)))
+ ,@body
+ ,result)))
+ ((:block-start :deleted-block-start)
+ (dolist (,node-var (block-start-uses (continuation-block ,n-cont))
+ ,result)
+ ,@body)))))
+
+;;; In the forward case, we terminate on Last-Cont so that we don't
+;;; have to worry about our termination condition being changed when
+;;; new code is added during the iteration. In the backward case, we
+;;; do NODE-PREV before evaluating the body so that we can keep going
+;;; when the current node is deleted.
+;;;
+;;; When RESTART-P is supplied to DO-NODES, we start iterating over
+;;; again at the beginning of the block when we run into a
+;;; continuation whose block differs from the one we are trying to
+;;; iterate over, either beacuse the block was split, or because a
+;;; node was deleted out from under us (hence its block is NIL.) If
+;;; the block start is deleted, we just punt. With RESTART-P, we are
+;;; also more careful about termination, re-indirecting the BLOCK-LAST
+;;; each time.
+(defmacro do-nodes ((node-var cont-var block &key restart-p) &body body)
+ #!+sb-doc
+ "Do-Nodes (Node-Var Cont-Var Block {Key Value}*) {Declaration}* {Form}*
+ Iterate over the nodes in Block, binding Node-Var to the each node and
+ Cont-Var to the node's Cont. The only keyword option is Restart-P, which
+ causes iteration to be restarted when a node is deleted out from under us (if
+ not supplied, this is an error.)"
+ (let ((n-block (gensym))
+ (n-last-cont (gensym)))
+ `(let* ((,n-block ,block)
+ ,@(unless restart-p
+ `((,n-last-cont (node-cont (block-last ,n-block))))))
+ (do* ((,node-var (continuation-next (block-start ,n-block))
+ ,(if restart-p
+ `(cond
+ ((eq (continuation-block ,cont-var) ,n-block)
+ (assert (continuation-next ,cont-var))
+ (continuation-next ,cont-var))
+ (t
+ (let ((start (block-start ,n-block)))
+ (unless (eq (continuation-kind start)
+ :block-start)
+ (return nil))
+ (continuation-next start))))
+ `(continuation-next ,cont-var)))
+ (,cont-var (node-cont ,node-var) (node-cont ,node-var)))
+ (())
+ ,@body
+ (when ,(if restart-p
+ `(eq ,node-var (block-last ,n-block))
+ `(eq ,cont-var ,n-last-cont))
+ (return nil))))))
+(defmacro do-nodes-backwards ((node-var cont-var block) &body body)
+ #!+sb-doc
+ "Do-Nodes-Backwards (Node-Var Cont-Var Block) {Declaration}* {Form}*
+ Like Do-Nodes, only iterates in reverse order."
+ (let ((n-block (gensym))
+ (n-start (gensym))
+ (n-last (gensym))
+ (n-next (gensym)))
+ `(let* ((,n-block ,block)
+ (,n-start (block-start ,n-block))
+ (,n-last (block-last ,n-block)))
+ (do* ((,cont-var (node-cont ,n-last) ,n-next)
+ (,node-var ,n-last (continuation-use ,cont-var))
+ (,n-next (node-prev ,node-var) (node-prev ,node-var)))
+ (())
+ ,@body
+ (when (eq ,n-next ,n-start)
+ (return nil))))))
+
+;;; The lexical environment is presumably already null...
+(defmacro with-ir1-environment (node &rest forms)
+ #!+sb-doc
+ "With-IR1-Environment Node Form*
+ Bind the IR1 context variables so that IR1 conversion can be done after the
+ main conversion pass has finished."
+ (let ((n-node (gensym)))
+ `(let* ((,n-node ,node)
+ (*current-component* (block-component (node-block ,n-node)))
+ (*lexenv* (node-lexenv ,n-node))
+ (*current-path* (node-source-path ,n-node)))
+ ,@forms)))
+
+;;; Bind the hashtables used for keeping track of global variables,
+;;; functions, &c. Also establish condition handlers.
+(defmacro with-ir1-namespace (&body forms)
+ `(let ((*free-variables* (make-hash-table :test 'eq))
+ (*free-functions* (make-hash-table :test 'equal))
+ (*constants* (make-hash-table :test 'equal))
+ (*source-paths* (make-hash-table :test 'eq)))
+ (handler-bind ((compiler-error #'compiler-error-handler)
+ (style-warning #'compiler-style-warning-handler)
+ (warning #'compiler-warning-handler))
+ ,@forms)))
+
+(defmacro lexenv-find (name slot &key test)
+ #!+sb-doc
+ "LEXENV-FIND Name Slot {Key Value}*
+ Look up Name in the lexical environment namespace designated by Slot,
+ returning the <value, T>, or <NIL, NIL> if no entry. The :TEST keyword
+ may be used to determine the name equality predicate."
+ (once-only ((n-res `(assoc ,name (,(symbolicate "LEXENV-" slot) *lexenv*)
+ :test ,(or test '#'eq))))
+ `(if ,n-res
+ (values (cdr ,n-res) t)
+ (values nil nil))))
+\f
+;;; These functions are called by the expansion of the DEFPRINTER
+;;; macro to do the actual printing.
+(declaim (ftype (function (symbol t stream &optional t) (values))
+ defprinter-prin1 defprinter-princ))
+(defun defprinter-prin1 (name value stream &optional indent)
+ (declare (ignore indent))
+ (defprinter-prinx #'prin1 name value stream))
+(defun defprinter-princ (name value stream &optional indent)
+ (declare (ignore indent))
+ (defprinter-prinx #'princ name value stream))
+(defun defprinter-prinx (prinx name value stream)
+ (declare (type function prinx))
+ (write-char #\space stream)
+ (when *print-pretty*
+ (pprint-newline :linear stream))
+ (format stream ":~A " name)
+ (funcall prinx value stream)
+ (values))
+
+;; Define some kind of reasonable PRINT-OBJECT method for a STRUCTURE-OBJECT.
+;;
+;; NAME is the name of the structure class, and CONC-NAME is the same as in
+;; DEFSTRUCT.
+;;
+;; The SLOT-DESCS describe how each slot should be printed. Each SLOT-DESC can
+;; be a slot name, indicating that the slot should simply be printed. A
+;; SLOT-DESC may also be a list of a slot name and other stuff. The other stuff
+;; is composed of keywords followed by expressions. The expressions are
+;; evaluated with the variable which is the slot name bound to the value of the
+;; slot. These keywords are defined:
+;;
+;; :PRIN1 Print the value of the expression instead of the slot value.
+;; :PRINC Like :PRIN1, only princ the value
+;; :TEST Only print something if the test is true.
+;;
+;; If no printing thing is specified then the slot value is printed as PRIN1.
+;;
+;; The structure being printed is bound to STRUCTURE and the stream is bound to
+;; STREAM.
+(defmacro defprinter ((name &key (conc-name (concatenate 'simple-string
+ (symbol-name name)
+ "-")))
+ &rest slot-descs)
+ (flet ((sref (slot-name)
+ `(,(symbolicate conc-name slot-name) structure)))
+ (collect ((prints))
+ (dolist (slot-desc slot-descs)
+ (if (atom slot-desc)
+ (prints `(defprinter-prin1 ',slot-desc ,(sref slot-desc) stream))
+ (let ((sname (first slot-desc))
+ (test t))
+ (collect ((stuff))
+ (do ((option (rest slot-desc) (cddr option)))
+ ((null option)
+ (prints
+ `(let ((,sname ,(sref sname)))
+ (when ,test
+ ,@(or (stuff)
+ `((defprinter-prin1 ',sname ,sname
+ stream)))))))
+ (case (first option)
+ (:prin1
+ (stuff `(defprinter-prin1 ',sname ,(second option)
+ stream)))
+ (:princ
+ (stuff `(defprinter-princ ',sname ,(second option)
+ stream)))
+ (:test (setq test (second option)))
+ (t
+ (error "bad DEFPRINTER option: ~S" (first option)))))))))
+
+ `(def!method print-object ((structure ,name) stream)
+ (print-unreadable-object (structure stream :type t)
+ (pprint-logical-block (stream nil)
+ ;;(pprint-indent :current 2 stream)
+ ,@(prints)))))))
+\f
+;;;; the Event statistics/trace utility
+
+;;; FIXME: This seems to be useful for troubleshooting and
+;;; experimentation, not for ordinary use, so it should probably
+;;; become conditional on SB-SHOW.
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+
+(defstruct event-info
+ ;; The name of this event.
+ (name (required-argument) :type symbol)
+ ;; The string rescribing this event.
+ (description (required-argument) :type string)
+ ;; The name of the variable we stash this in.
+ (var (required-argument) :type symbol)
+ ;; The number of times this event has happened.
+ (count 0 :type fixnum)
+ ;; The level of significance of this event.
+ (level (required-argument) :type unsigned-byte)
+ ;; If true, a function that gets called with the node that the event
+ ;; happened to.
+ (action nil :type (or function null)))
+
+;;; A hashtable from event names to event-info structures.
+(defvar *event-info* (make-hash-table :test 'eq))
+
+;;; Return the event info for Name or die trying.
+(declaim (ftype (function (t) event-info) event-info-or-lose))
+(defun event-info-or-lose (name)
+ (let ((res (gethash name *event-info*)))
+ (unless res
+ (error "~S is not the name of an event." name))
+ res))
+
+) ; EVAL-WHEN
+
+(declaim (ftype (function (symbol) fixnum) event-count))
+(defun event-count (name)
+ #!+sb-doc
+ "Return the number of times that Event has happened."
+ (event-info-count (event-info-or-lose name)))
+
+(declaim (ftype (function (symbol) (or function null)) event-action))
+(defun event-action (name)
+ #!+sb-doc
+ "Return the function that is called when Event happens. If this is null,
+ there is no action. The function is passed the node to which the event
+ happened, or NIL if there is no relevant node. This may be set with SETF."
+ (event-info-action (event-info-or-lose name)))
+(declaim (ftype (function (symbol (or function null)) (or function null))
+ %set-event-action))
+(defun %set-event-action (name new-value)
+ (setf (event-info-action (event-info-or-lose name))
+ new-value))
+(defsetf event-action %set-event-action)
+
+(declaim (ftype (function (symbol) unsigned-byte) event-level))
+(defun event-level (name)
+ #!+sb-doc
+ "Return the non-negative integer which represents the level of significance
+ of the event Name. This is used to determine whether to print a message when
+ the event happens. This may be set with SETF."
+ (event-info-level (event-info-or-lose name)))
+(declaim (ftype (function (symbol unsigned-byte) unsigned-byte) %set-event-level))
+(defun %set-event-level (name new-value)
+ (setf (event-info-level (event-info-or-lose name))
+ new-value))
+(defsetf event-level %set-event-level)
+
+;;; Make an EVENT-INFO structure and stash it in a variable so we can
+;;; get at it quickly.
+(defmacro defevent (name description &optional (level 0))
+ #!+sb-doc
+ "Defevent Name Description
+ Define a new kind of event. Name is a symbol which names the event and
+ Description is a string which describes the event. Level (default 0) is the
+ level of significance associated with this event; it is used to determine
+ whether to print a Note when the event happens."
+ (let ((var-name (symbolicate "*" name "-EVENT-INFO*")))
+ `(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defvar ,var-name
+ (make-event-info :name ',name
+ :description ',description
+ :var ',var-name
+ :level ,level))
+ (setf (gethash ',name *event-info*) ,var-name)
+ ',name)))
+
+(declaim (type unsigned-byte *event-note-threshold*))
+(defvar *event-note-threshold* 1
+ #!+sb-doc
+ "This variable is a non-negative integer specifying the lowest level of
+ event that will print a note when it occurs.")
+
+;;; Increment the counter and do any action. Mumble about the event if
+;;; policy indicates.
+(defmacro event (name &optional node)
+ #!+sb-doc
+ "Event Name Node
+ Note that the event with the specified Name has happened. Node is evaluated
+ to determine the node to which the event happened."
+ `(%event ,(event-info-var (event-info-or-lose name)) ,node))
+
+(declaim (ftype (function (&optional unsigned-byte stream) (values)) event-statistics))
+(defun event-statistics (&optional (min-count 1) (stream *standard-output*))
+ #!+sb-doc
+ "Print a listing of events and their counts, sorted by the count. Events
+ that happened fewer than Min-Count times will not be printed. Stream is the
+ stream to write to."
+ (collect ((info))
+ (maphash #'(lambda (k v)
+ (declare (ignore k))
+ (when (>= (event-info-count v) min-count)
+ (info v)))
+ *event-info*)
+ (dolist (event (sort (info) #'> :key #'event-info-count))
+ (format stream "~6D: ~A~%" (event-info-count event)
+ (event-info-description event)))
+ (values))
+ (values))
+
+(declaim (ftype (function nil (values)) clear-event-statistics))
+(defun clear-event-statistics ()
+ (maphash #'(lambda (k v)
+ (declare (ignore k))
+ (setf (event-info-count v) 0))
+ *event-info*)
+ (values))
+\f
+;;;; functions on directly-linked lists (linked through specialized
+;;;; NEXT operations)
+
+#!-sb-fluid (declaim (inline find-in position-in map-in))
+
+(defun find-in (next
+ element
+ list
+ &key
+ (key #'identity)
+ (test #'eql test-p)
+ (test-not nil not-p))
+ #!+sb-doc
+ "Find Element in a null-terminated List linked by the accessor function
+ Next. Key, Test and Test-Not are the same as for generic sequence
+ functions."
+ (when (and test-p not-p)
+ (error "It's silly to supply both :Test and :Test-Not."))
+ (if not-p
+ (do ((current list (funcall next current)))
+ ((null current) nil)
+ (unless (funcall test-not (funcall key current) element)
+ (return current)))
+ (do ((current list (funcall next current)))
+ ((null current) nil)
+ (when (funcall test (funcall key current) element)
+ (return current)))))
+
+(defun position-in (next
+ element
+ list
+ &key
+ (key #'identity)
+ (test #'eql test-p)
+ (test-not nil not-p))
+ #!+sb-doc
+ "Return the position of Element (or NIL if absent) in a null-terminated List
+ linked by the accessor function Next. Key, Test and Test-Not are the same as
+ for generic sequence functions."
+ (when (and test-p not-p)
+ (error "Silly to supply both :Test and :Test-Not."))
+ (if not-p
+ (do ((current list (funcall next current))
+ (i 0 (1+ i)))
+ ((null current) nil)
+ (unless (funcall test-not (funcall key current) element)
+ (return i)))
+ (do ((current list (funcall next current))
+ (i 0 (1+ i)))
+ ((null current) nil)
+ (when (funcall test (funcall key current) element)
+ (return i)))))
+
+(defun map-in (next function list)
+ #!+sb-doc
+ "Map Function over the elements in a null-terminated List linked by the
+ accessor function Next, returning a list of the results."
+ (collect ((res))
+ (do ((current list (funcall next current)))
+ ((null current))
+ (res (funcall function current)))
+ (res)))
+
+;;; KLUDGE: This is expanded out twice, by cut-and-paste, in a
+;;; (DEF!MACRO FOO (..) .. CL:GET-SETF-EXPANSION ..)
+;;; #+SB-XC-HOST
+;;; (SB!XC:DEFMACRO FOO (..) .. SB!XC:GET-SETF-EXPANSION ..)
+;;; arrangement, in order to get it to work in cross-compilation. This
+;;; duplication should be removed, perhaps by rewriting the macro in a more
+;;; cross-compiler-friendly way, or perhaps just by using some (MACROLET ((FROB
+;;; ..)) .. FROB .. FROB) form, or perhaps by completely eliminating this macro
+;;; and its partner PUSH-IN, but I don't want to do it now, because the system
+;;; isn't running yet, so it'd be too hard to check that my changes were
+;;; correct -- WHN 19990806
+(def!macro deletef-in (next place item &environment env)
+ (multiple-value-bind (temps vals stores store access)
+ (get-setf-expansion place env)
+ (when (cdr stores)
+ (error "multiple store variables for ~S" place))
+ (let ((n-item (gensym))
+ (n-place (gensym))
+ (n-current (gensym))
+ (n-prev (gensym)))
+ `(let* (,@(mapcar #'list temps vals)
+ (,n-place ,access)
+ (,n-item ,item))
+ (if (eq ,n-place ,n-item)
+ (let ((,(first stores) (,next ,n-place)))
+ ,store)
+ (do ((,n-prev ,n-place ,n-current)
+ (,n-current (,next ,n-place)
+ (,next ,n-current)))
+ ((eq ,n-current ,n-item)
+ (setf (,next ,n-prev)
+ (,next ,n-current)))))
+ (values)))))
+;;; #+SB-XC-HOST SB!XC:DEFMACRO version is in late-macros.lisp. -- WHN 19990806
+
+;;; KLUDGE: This is expanded out twice, by cut-and-paste, in a
+;;; (DEF!MACRO FOO (..) .. CL:GET-SETF-EXPANSION ..)
+;;; #+SB-XC-HOST
+;;; (SB!XC:DEFMACRO FOO (..) .. SB!XC:GET-SETF-EXPANSION ..)
+;;; arrangement, in order to get it to work in cross-compilation. This
+;;; duplication should be removed, perhaps by rewriting the macro in a more
+;;; cross-compiler-friendly way, or perhaps just by using some (MACROLET ((FROB
+;;; ..)) .. FROB .. FROB) form, or perhaps by completely eliminating this macro
+;;; and its partner DELETEF-IN, but I don't want to do it now, because the
+;;; system isn't running yet, so it'd be too hard to check that my changes were
+;;; correct -- WHN 19990806
+(def!macro push-in (next item place &environment env)
+ #!+sb-doc
+ "Push Item onto a list linked by the accessor function Next that is stored in
+ Place."
+ (multiple-value-bind (temps vals stores store access)
+ (get-setf-expansion place env)
+ (when (cdr stores)
+ (error "multiple store variables for ~S" place))
+ `(let (,@(mapcar #'list temps vals)
+ (,(first stores) ,item))
+ (setf (,next ,(first stores)) ,access)
+ ,store
+ (values))))
+;;; #+SB-XC-HOST SB!XC:DEFMACRO version is in late-macros.lisp. -- WHN 19990806
+
+(defmacro position-or-lose (&rest args)
+ `(or (position ,@args)
+ (error "Shouldn't happen?")))
--- /dev/null
+;;;; the top-level interfaces to the compiler
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!C")
+
+(file-comment
+ "$Header$")
+
+;;; FIXME: Doesn't this belong somewhere else, like early-c.lisp?
+(declaim (special *constants* *free-variables* *component-being-compiled*
+ *code-vector* *next-location* *result-fixups*
+ *free-functions* *source-paths*
+ *seen-blocks* *seen-functions* *list-conflicts-table*
+ *continuation-number* *continuation-numbers*
+ *number-continuations* *tn-id* *tn-ids* *id-tns*
+ *label-ids* *label-id* *id-labels*
+ *undefined-warnings* *compiler-error-count*
+ *compiler-warning-count* *compiler-style-warning-count*
+ *compiler-note-count*
+ *compiler-error-bailout*
+ #!+sb-show *compiler-trace-output*
+ *last-source-context* *last-original-source*
+ *last-source-form* *last-format-string* *last-format-args*
+ *last-message-count* *lexenv*))
+
+(defvar *byte-compile-default* :maybe
+ #!+sb-doc
+ "the default value for the :BYTE-COMPILE argument to COMPILE-FILE")
+
+(defvar *byte-compile-top-level*
+ #-sb-xc-host t
+ #+sb-xc-host nil ; since the byte compiler isn't supported in cross-compiler
+ #!+sb-doc
+ "Similar to *BYTE-COMPILE-DEFAULT*, but controls the compilation of top-level
+ forms (evaluated at load-time) when the :BYTE-COMPILE argument is :MAYBE
+ (the default.) When true, we decide to byte-compile.")
+
+;;; default value of the :BYTE-COMPILE argument to the compiler
+(defvar *byte-compile* :maybe)
+
+;;; Bound by COMPILE-COMPONENT to T when byte-compiling, and NIL when
+;;; native compiling. During IR1 conversion this can also be :MAYBE,
+;;; in which case we must look at the policy, see (byte-compiling).
+(defvar *byte-compiling* :maybe)
+(declaim (type (member t nil :maybe) *byte-compile* *byte-compiling*
+ *byte-compile-default*))
+
+(defvar *check-consistency* nil)
+(defvar *all-components*)
+
+;;; Bind this to a stream to capture various internal debugging output.
+#!+sb-show
+(defvar *compiler-trace-output* nil)
+
+;;; The current block compilation state. These are initialized to the
+;;; :BLOCK-COMPILE and :ENTRY-POINTS arguments that COMPILE-FILE was
+;;; called with.
+;;;
+;;; *BLOCK-COMPILE-ARGUMENT* holds the original value of the
+;;; :BLOCK-COMPILE argument, which overrides any internal
+;;; declarations.
+(defvar *block-compile*)
+(defvar *block-compile-argument*)
+(declaim (type (member nil t :specified)
+ *block-compile* *block-compile-argument*))
+(defvar *entry-points*)
+(declaim (list *entry-points*))
+
+;;; When block compiling, used by PROCESS-FORM to accumulate top-level
+;;; lambdas resulting from compiling subforms. (In reverse order.)
+(defvar *top-level-lambdas*)
+(declaim (list *top-level-lambdas*))
+
+(defvar sb!xc:*compile-verbose* t
+ #!+sb-doc
+ "The default for the :VERBOSE argument to COMPILE-FILE.")
+(defvar sb!xc:*compile-print* t
+ #!+sb-doc
+ "The default for the :PRINT argument to COMPILE-FILE.")
+(defvar *compile-progress* nil
+ #!+sb-doc
+ "When this is true, the compiler prints to *ERROR-OUTPUT* progress
+ information about the phases of compilation of each function. (This
+ is useful mainly in large block compilations.)")
+
+(defvar sb!xc:*compile-file-pathname* nil
+ #!+sb-doc
+ "The defaulted pathname of the file currently being compiled, or NIL if not
+ compiling.")
+(defvar sb!xc:*compile-file-truename* nil
+ #!+sb-doc
+ "The TRUENAME of the file currently being compiled, or NIL if not
+ compiling.")
+
+(declaim (type (or pathname null)
+ sb!xc:*compile-file-pathname*
+ sb!xc:*compile-file-truename*))
+
+;;; the values of *PACKAGE* and policy when compilation started
+(defvar *initial-package*)
+(defvar *initial-cookie*)
+(defvar *initial-interface-cookie*)
+
+;;; The source-info structure for the current compilation. This is null
+;;; globally to indicate that we aren't currently in any identifiable
+;;; compilation.
+(defvar *source-info* nil)
+
+;;; True if we are within a WITH-COMPILATION-UNIT form (which normally
+;;; causes nested uses to be no-ops).
+(defvar *in-compilation-unit* nil)
+
+;;; Count of the number of compilation units dynamically enclosed by
+;;; the current active WITH-COMPILATION-UNIT that were unwound out of.
+(defvar *aborted-compilation-unit-count*)
+
+;;; Mumble conditional on *COMPILE-PROGRESS*.
+(defun maybe-mumble (&rest foo)
+ (when *compile-progress*
+ (apply #'compiler-mumble foo)))
+
+(deftype object () '(or fasl-file core-object null))
+
+(defvar *compile-object* nil)
+(declaim (type object *compile-object*))
+\f
+;;;; WITH-COMPILATION-UNIT and WITH-COMPILATION-VALUES
+
+(defmacro sb!xc:with-compilation-unit (options &body body)
+ #!+sb-doc
+ "WITH-COMPILATION-UNIT ({Key Value}*) Form*
+ This form affects compilations that take place within its dynamic extent. It
+ is intended to be wrapped around the compilation of all files in the same
+ system. These keywords are defined:
+ :OVERRIDE Boolean-Form
+ One of the effects of this form is to delay undefined warnings
+ until the end of the form, instead of giving them at the end of each
+ compilation. If OVERRIDE is NIL (the default), then the outermost
+ WITH-COMPILATION-UNIT form grabs the undefined warnings. Specifying
+ OVERRIDE true causes that form to grab any enclosed warnings, even if
+ it is enclosed by another WITH-COMPILATION-UNIT."
+ `(%with-compilation-unit (lambda () ,@body) ,@options))
+
+(defun %with-compilation-unit (fn &key override)
+ (let ((succeeded-p nil))
+ (if (and *in-compilation-unit* (not override))
+ ;; Inside another WITH-COMPILATION-UNIT, a WITH-COMPILATION-UNIT is
+ ;; ordinarily (unless OVERRIDE) basically a no-op.
+ (unwind-protect
+ (multiple-value-prog1 (funcall fn) (setf succeeded-p t))
+ (unless succeeded-p
+ (incf *aborted-compilation-unit-count*)))
+ ;; FIXME: Now *COMPILER-FOO-COUNT* stuff is bound in more than
+ ;; one place. If we can get rid of the IR1 interpreter, this
+ ;; should be easier to clean up.
+ (let ((*aborted-compilation-unit-count* 0)
+ (*compiler-error-count* 0)
+ (*compiler-warning-count* 0)
+ (*compiler-style-warning-count* 0)
+ (*compiler-note-count* 0)
+ (*undefined-warnings* nil)
+ (*in-compilation-unit* t))
+ (handler-bind ((parse-unknown-type
+ (lambda (c)
+ (note-undefined-reference
+ (parse-unknown-type-specifier c)
+ :type))))
+ (unwind-protect
+ (multiple-value-prog1 (funcall fn) (setf succeeded-p t))
+ (unless succeeded-p
+ (incf *aborted-compilation-unit-count*))
+ (summarize-compilation-unit (not succeeded-p))))))))
+
+;;; This is to be called at the end of a compilation unit. It signals
+;;; any residual warnings about unknown stuff, then prints the total
+;;; error counts. ABORT-P should be true when the compilation unit was
+;;; aborted by throwing out. ABORT-COUNT is the number of dynamically
+;;; enclosed nested compilation units that were aborted.
+(defun summarize-compilation-unit (abort-p)
+ (unless abort-p
+ (handler-bind ((style-warning #'compiler-style-warning-handler)
+ (warning #'compiler-warning-handler))
+
+ (let ((undefs (sort *undefined-warnings* #'string<
+ :key #'(lambda (x)
+ (let ((x (undefined-warning-name x)))
+ (if (symbolp x)
+ (symbol-name x)
+ (prin1-to-string x)))))))
+ (unless *converting-for-interpreter*
+ (dolist (undef undefs)
+ (let ((name (undefined-warning-name undef))
+ (kind (undefined-warning-kind undef))
+ (warnings (undefined-warning-warnings undef))
+ (undefined-warning-count (undefined-warning-count undef)))
+ (dolist (*compiler-error-context* warnings)
+ (compiler-style-warning "undefined ~(~A~): ~S" kind name))
+
+ (let ((warn-count (length warnings)))
+ (when (and warnings (> undefined-warning-count warn-count))
+ (let ((more (- undefined-warning-count warn-count)))
+ (compiler-style-warning
+ "~D more use~:P of undefined ~(~A~) ~S"
+ more kind name)))))))
+
+ (dolist (kind '(:variable :function :type))
+ (let ((summary (mapcar #'undefined-warning-name
+ (remove kind undefs :test-not #'eq
+ :key #'undefined-warning-kind))))
+ (when summary
+ (compiler-style-warning
+ "~:[This ~(~A~) is~;These ~(~A~)s are~] undefined:~
+ ~% ~{~<~% ~1:;~S~>~^ ~}"
+ (cdr summary) kind summary)))))))
+
+ (unless (or *converting-for-interpreter*
+ (and (not abort-p)
+ (zerop *aborted-compilation-unit-count*)
+ (zerop *compiler-error-count*)
+ (zerop *compiler-warning-count*)
+ (zerop *compiler-style-warning-count*)
+ (zerop *compiler-note-count*)))
+ (compiler-mumble
+ "~2&compilation unit ~:[finished~;aborted~]~
+ ~[~:;~:*~& caught ~D fatal ERROR condition~:P~]~
+ ~[~:;~:*~& caught ~D ERROR condition~:P~]~
+ ~[~:;~:*~& caught ~D WARNING condition~:P~]~
+ ~[~:;~:*~& caught ~D STYLE-WARNING condition~:P~]~
+ ~[~:;~:*~& printed ~D note~:P~]~2%"
+ abort-p
+ *aborted-compilation-unit-count*
+ *compiler-error-count*
+ *compiler-warning-count*
+ *compiler-style-warning-count*
+ *compiler-note-count*)))
+
+;;; Evaluate BODY, then return (VALUES BODY-VALUE WARNINGS-P
+;;; FAILURE-P), where BODY-VALUE is the first value of the body, and
+;;; WARNINGS-P and FAILURE-P are as in CL:COMPILE or CL:COMPILE-FILE.
+;;; This also wraps up WITH-IR1-NAMESPACE functionality.
+(defmacro with-compilation-values (&body body)
+ `(with-ir1-namespace
+ (let ((*warnings-p* nil)
+ (*failure-p* nil))
+ (values (progn ,@body)
+ *warnings-p*
+ *failure-p*))))
+\f
+;;;; component compilation
+
+(defparameter *max-optimize-iterations* 3 ; ARB
+ #!+sb-doc
+ "The upper limit on the number of times that we will consecutively do IR1
+ optimization that doesn't introduce any new code. A finite limit is
+ necessary, since type inference may take arbitrarily long to converge.")
+
+(defevent ir1-optimize-until-done "IR1-OPTIMIZE-UNTIL-DONE called")
+(defevent ir1-optimize-maxed-out "hit *MAX-OPTIMIZE-ITERATIONS* limit")
+
+;;; Repeatedly optimize COMPONENT until no further optimizations can
+;;; be found or we hit our iteration limit. When we hit the limit, we
+;;; clear the component and block REOPTIMIZE flags to discourage the
+;;; next optimization attempt from pounding on the same code.
+(defun ir1-optimize-until-done (component)
+ (declare (type component component))
+ (maybe-mumble "opt")
+ (event ir1-optimize-until-done)
+ (let ((count 0)
+ (cleared-reanalyze nil))
+ (loop
+ (when (component-reanalyze component)
+ (setq count 0)
+ (setq cleared-reanalyze t)
+ (setf (component-reanalyze component) nil))
+ (setf (component-reoptimize component) nil)
+ (ir1-optimize component)
+ (unless (component-reoptimize component)
+ (maybe-mumble " ")
+ (return))
+ (incf count)
+ (when (= count *max-optimize-iterations*)
+ (event ir1-optimize-maxed-out)
+ (maybe-mumble "* ")
+ (setf (component-reoptimize component) nil)
+ (do-blocks (block component)
+ (setf (block-reoptimize block) nil))
+ (return))
+ (maybe-mumble "."))
+ (when cleared-reanalyze
+ (setf (component-reanalyze component) t)))
+ (values))
+
+(defparameter *constraint-propagate* t)
+(defparameter *reoptimize-after-type-check-max* 5)
+
+(defevent reoptimize-maxed-out
+ "*REOPTIMIZE-AFTER-TYPE-CHECK-MAX* exceeded.")
+
+;;; Iterate doing FIND-DFO until no new dead code is discovered.
+(defun dfo-as-needed (component)
+ (declare (type component component))
+ (when (component-reanalyze component)
+ (maybe-mumble "DFO")
+ (loop
+ (find-dfo component)
+ (unless (component-reanalyze component)
+ (maybe-mumble " ")
+ (return))
+ (maybe-mumble ".")))
+ (values))
+
+;;; Do all the IR1 phases for a non-top-level component.
+(defun ir1-phases (component)
+ (declare (type component component))
+ (let ((*constraint-number* 0)
+ (loop-count 1))
+ (declare (special *constraint-number*))
+ (loop
+ (ir1-optimize-until-done component)
+ (when (or (component-new-functions component)
+ (component-reanalyze-functions component))
+ (maybe-mumble "locall ")
+ (local-call-analyze component))
+ (dfo-as-needed component)
+ (when *constraint-propagate*
+ (maybe-mumble "constraint ")
+ (constraint-propagate component))
+ (maybe-mumble "type ")
+ ;; Delay the generation of type checks until the type
+ ;; constraints have had time to propagate, else the compiler can
+ ;; confuse itself.
+ (unless (and (or (component-reoptimize component)
+ (component-reanalyze component)
+ (component-new-functions component)
+ (component-reanalyze-functions component))
+ (< loop-count (- *reoptimize-after-type-check-max* 2)))
+ (generate-type-checks component)
+ (unless (or (component-reoptimize component)
+ (component-reanalyze component)
+ (component-new-functions component)
+ (component-reanalyze-functions component))
+ (return)))
+ (when (>= loop-count *reoptimize-after-type-check-max*)
+ (maybe-mumble "[reoptimize limit]")
+ (event reoptimize-maxed-out)
+ (return))
+ (incf loop-count)))
+
+ (ir1-finalize component)
+ (values))
+
+(defun native-compile-component (component)
+ (let ((*code-segment* nil)
+ (*elsewhere* nil))
+ (maybe-mumble "GTN ")
+ (gtn-analyze component)
+ (maybe-mumble "LTN ")
+ (ltn-analyze component)
+ (dfo-as-needed component)
+ (maybe-mumble "control ")
+ (control-analyze component #'make-ir2-block)
+
+ (when (ir2-component-values-receivers (component-info component))
+ (maybe-mumble "stack ")
+ (stack-analyze component)
+ ;; Assign BLOCK-NUMBER for any cleanup blocks introduced by
+ ;; stack analysis. There shouldn't be any unreachable code after
+ ;; control, so this won't delete anything.
+ (dfo-as-needed component))
+
+ (unwind-protect
+ (progn
+ (maybe-mumble "IR2tran ")
+ (init-assembler)
+ (entry-analyze component)
+ (ir2-convert component)
+
+ (when (policy nil (>= speed cspeed))
+ (maybe-mumble "copy ")
+ (copy-propagate component))
+
+ (select-representations component)
+
+ (when *check-consistency*
+ (maybe-mumble "check2 ")
+ (check-ir2-consistency component))
+
+ (delete-unreferenced-tns component)
+
+ (maybe-mumble "life ")
+ (lifetime-analyze component)
+
+ (when *compile-progress*
+ (compiler-mumble "") ; Sync before doing more output.
+ (pre-pack-tn-stats component *error-output*))
+
+ (when *check-consistency*
+ (maybe-mumble "check-life ")
+ (check-life-consistency component))
+
+ (maybe-mumble "pack ")
+ (pack component)
+
+ (when *check-consistency*
+ (maybe-mumble "check-pack ")
+ (check-pack-consistency component))
+
+ #!+sb-show
+ (when *compiler-trace-output*
+ (describe-component component *compiler-trace-output*)
+ (describe-ir2-component component *compiler-trace-output*))
+
+ (maybe-mumble "code ")
+ (multiple-value-bind (code-length trace-table fixups)
+ (generate-code component)
+
+ #!+sb-show
+ (when *compiler-trace-output*
+ (format *compiler-trace-output*
+ "~|~%disassembly of code for ~S~2%" component)
+ (sb!disassem:disassemble-assem-segment *code-segment*
+ *compiler-trace-output*))
+
+ (etypecase *compile-object*
+ (fasl-file
+ (maybe-mumble "fasl")
+ (fasl-dump-component component
+ *code-segment*
+ code-length
+ trace-table
+ fixups
+ *compile-object*))
+ (core-object
+ (maybe-mumble "core")
+ (make-core-component component
+ *code-segment*
+ code-length
+ trace-table
+ fixups
+ *compile-object*))
+ (null))))))
+
+ ;; We are done, so don't bother keeping anything around.
+ (setf (component-info component) nil)
+
+ (values))
+
+;;; Return our best guess for whether we will byte compile code
+;;; currently being IR1 converted. This is only a guess because the
+;;; decision is made on a per-component basis.
+;;;
+;;; FIXME: This should be called something more mnemonic, e.g.
+;;; PROBABLY-BYTE-COMPILING
+(defun byte-compiling ()
+ (if (eq *byte-compiling* :maybe)
+ (or (eq *byte-compile* t)
+ (policy nil (zerop speed) (<= debug 1)))
+ (and *byte-compile* *byte-compiling*)))
+
+;;; Delete components with no external entry points before we try to
+;;; generate code. Unreachable closures can cause IR2 conversion to puke on
+;;; itself, since it is the reference to the closure which normally causes the
+;;; components to be combined. This doesn't really cover all cases...
+(defun delete-if-no-entries (component)
+ (dolist (fun (component-lambdas component)
+ (delete-component component))
+ (case (functional-kind fun)
+ (:top-level (return))
+ (:external
+ (unless (every #'(lambda (ref)
+ (eq (block-component (node-block ref))
+ component))
+ (leaf-refs fun))
+ (return))))))
+
+(defun compile-component (component)
+ (let* ((*component-being-compiled* component)
+ (*byte-compiling*
+ (ecase *byte-compile*
+ ((t) t)
+ ((nil) nil)
+ (:maybe
+ (dolist (fun (component-lambdas component) t)
+ (unless (policy (lambda-bind fun)
+ (zerop speed) (<= debug 1))
+ (return nil)))))))
+
+ (when sb!xc:*compile-print*
+ (compiler-mumble "~&~:[~;byte ~]compiling ~A: "
+ *byte-compiling*
+ (component-name component)))
+
+ (ir1-phases component)
+
+ ;; FIXME: What is MAYBE-MUMBLE for? Do we need it any more?
+ (maybe-mumble "env ")
+ (environment-analyze component)
+ (dfo-as-needed component)
+
+ (delete-if-no-entries component)
+
+ (unless (eq (block-next (component-head component))
+ (component-tail component))
+ (if *byte-compiling*
+ (byte-compile-component component)
+ (native-compile-component component))))
+
+ (clear-constant-info)
+
+ (when sb!xc:*compile-print*
+ (compiler-mumble "~&"))
+
+ (values))
+\f
+;;;; clearing global data structures
+;;;;
+;;;; FIXME: Is it possible to get rid of this stuff, getting rid of
+;;;; global data structures entirely when possible and consing up the
+;;;; others from scratch instead of clearing and reusing them?
+
+;;; Clear the INFO in constants in the *FREE-VARIABLES*, etc. In
+;;; addition to allowing stuff to be reclaimed, this is required for
+;;; correct assignment of constant offsets, since we need to assign a
+;;; new offset for each component. We don't clear the FUNCTIONAL-INFO
+;;; slots, since they are used to keep track of functions across
+;;; component boundaries.
+(defun clear-constant-info ()
+ (maphash #'(lambda (k v)
+ (declare (ignore k))
+ (setf (leaf-info v) nil))
+ *constants*)
+ (maphash #'(lambda (k v)
+ (declare (ignore k))
+ (when (constant-p v)
+ (setf (leaf-info v) nil)))
+ *free-variables*)
+ (values))
+
+;;; Blow away the REFS for all global variables, and let COMPONENT
+;;; be recycled.
+(defun clear-ir1-info (component)
+ (declare (type component component))
+ (labels ((blast (x)
+ (maphash #'(lambda (k v)
+ (declare (ignore k))
+ (when (leaf-p v)
+ (setf (leaf-refs v)
+ (delete-if #'here-p (leaf-refs v)))
+ (when (basic-var-p v)
+ (setf (basic-var-sets v)
+ (delete-if #'here-p (basic-var-sets v))))))
+ x))
+ (here-p (x)
+ (eq (block-component (node-block x)) component)))
+ (blast *free-variables*)
+ (blast *free-functions*)
+ (blast *constants*))
+ (values))
+
+;;; Clear global variables used by the compiler.
+;;;
+;;; FIXME: It seems kinda nasty and unmaintainable to have to do this,
+;;; and it adds overhead even when people aren't using the compiler.
+;;; Perhaps we could make these global vars unbound except when
+;;; actually in use, so that this function could go away.
+(defun clear-stuff (&optional (debug-too t))
+
+ ;; Clear global tables.
+ (when (boundp '*free-functions*)
+ (clrhash *free-functions*)
+ (clrhash *free-variables*)
+ (clrhash *constants*))
+
+ ;; Clear debug counters and tables.
+ (clrhash *seen-blocks*)
+ (clrhash *seen-functions*)
+ (clrhash *list-conflicts-table*)
+
+ (when debug-too
+ (clrhash *continuation-numbers*)
+ (clrhash *number-continuations*)
+ (setq *continuation-number* 0)
+ (clrhash *tn-ids*)
+ (clrhash *id-tns*)
+ (setq *tn-id* 0)
+ (clrhash *label-ids*)
+ (clrhash *id-labels*)
+ (setq *label-id* 0)
+
+ ;; Clear some Pack data structures (for GC purposes only).
+ (assert (not *in-pack*))
+ (dolist (sb *backend-sb-list*)
+ (when (finite-sb-p sb)
+ (fill (finite-sb-live-tns sb) nil))))
+
+ ;; (Note: The CMU CL code used to set CL::*GENSYM-COUNTER* to zero here.
+ ;; Superficially, this seemed harmful -- the user could reasonably be
+ ;; surprised if *GENSYM-COUNTER* turned back to zero when something was
+ ;; compiled. A closer inspection showed that this actually turned out to be
+ ;; harmless in practice, because CLEAR-STUFF was only called from within
+ ;; forms which bound CL::*GENSYM-COUNTER* to zero. However, this means that
+ ;; even though zeroing CL::*GENSYM-COUNTER* here turned out to be harmless in
+ ;; practice, it was also useless in practice. So we don't do it any more.)
+
+ (values))
+\f
+;;;; trace output
+
+;;; Print out some useful info about Component to Stream.
+(defun describe-component (component *standard-output*)
+ (declare (type component component))
+ (format t "~|~%;;;; component: ~S~2%" (component-name component))
+ (print-blocks component)
+ (values))
+
+(defun describe-ir2-component (component *standard-output*)
+ (format t "~%~|~%;;;; IR2 component: ~S~2%" (component-name component))
+ (format t "entries:~%")
+ (dolist (entry (ir2-component-entries (component-info component)))
+ (format t "~4TL~D: ~S~:[~; [closure]~]~%"
+ (label-id (entry-info-offset entry))
+ (entry-info-name entry)
+ (entry-info-closure-p entry)))
+ (terpri)
+ (pre-pack-tn-stats component *standard-output*)
+ (terpri)
+ (print-ir2-blocks component)
+ (terpri)
+ (values))
+\f
+;;;; file reading
+;;;;
+;;;; When reading from a file, we have to keep track of some source
+;;;; information. We also exploit our ability to back up for printing
+;;;; the error context and for recovering from errors.
+;;;;
+;;;; The interface we provide to this stuff is the stream-oid
+;;;; Source-Info structure. The bookkeeping is done as a side-effect
+;;;; of getting the next source form.
+
+;;; The File-Info structure holds all the source information for a
+;;; given file.
+(defstruct file-info
+ ;; If a file, the truename of the corresponding source file. If from a Lisp
+ ;; form, :LISP, if from a stream, :STREAM.
+ (name (required-argument) :type (or pathname (member :lisp :stream)))
+ ;; The defaulted, but not necessarily absolute file name (i.e. prior to
+ ;; TRUENAME call.) Null if not a file. This is used to set
+ ;; *COMPILE-FILE-PATHNAME*, and if absolute, is dumped in the debug-info.
+ (untruename nil :type (or pathname null))
+ ;; The file's write date (if relevant.)
+ (write-date nil :type (or unsigned-byte null))
+ ;; This file's FILE-COMMENT, or NIL if none.
+ (comment nil :type (or simple-string null))
+ ;; The source path root number of the first form in this file (i.e. the
+ ;; total number of forms converted previously in this compilation.)
+ (source-root 0 :type unsigned-byte)
+ ;; Parallel vectors containing the forms read out of the file and the file
+ ;; positions that reading of each form started at (i.e. the end of the
+ ;; previous form.)
+ (forms (make-array 10 :fill-pointer 0 :adjustable t) :type (vector t))
+ (positions (make-array 10 :fill-pointer 0 :adjustable t) :type (vector t)))
+
+;;; The SOURCE-INFO structure provides a handle on all the source
+;;; information for an entire compilation.
+(defstruct (source-info
+ #-no-ansi-print-object
+ (:print-object (lambda (s stream)
+ (print-unreadable-object (s stream :type t)))))
+ ;; the UT that compilation started at
+ (start-time (get-universal-time) :type unsigned-byte)
+ ;; a list of the FILE-INFO structures for this compilation
+ (files nil :type list)
+ ;; the tail of the FILES for the file we are currently reading
+ (current-file nil :type list)
+ ;; the stream that we are using to read the CURRENT-FILE, or NIL if
+ ;; no stream has been opened yet
+ (stream nil :type (or stream null)))
+
+;;; Given a list of pathnames, return a SOURCE-INFO structure.
+(defun make-file-source-info (files)
+ (declare (list files))
+ (let ((file-info
+ (mapcar (lambda (x)
+ (make-file-info :name (truename x)
+ :untruename x
+ :write-date (file-write-date x)))
+ files)))
+
+ (make-source-info :files file-info
+ :current-file file-info)))
+
+;;; Return a SOURCE-INFO to describe the incremental compilation of
+;;; FORM. Also used by SB!EVAL:INTERNAL-EVAL.
+(defun make-lisp-source-info (form)
+ (make-source-info
+ :start-time (get-universal-time)
+ :files (list (make-file-info :name :lisp
+ :forms (vector form)
+ :positions '#(0)))))
+
+;;; Return a SOURCE-INFO which will read from Stream.
+(defun make-stream-source-info (stream)
+ (let ((files (list (make-file-info :name :stream))))
+ (make-source-info
+ :files files
+ :current-file files
+ :stream stream)))
+
+;;; Print an error message for a non-EOF error on STREAM. OLD-POS is a
+;;; preceding file position that hopefully comes before the beginning
+;;; of the line. Of course, this only works on streams that support
+;;; the file-position operation.
+(defun normal-read-error (stream old-pos condition)
+ (declare (type stream stream) (type unsigned-byte old-pos))
+ (let ((pos (file-position stream)))
+ (file-position stream old-pos)
+ (let ((start old-pos))
+ (loop
+ (let ((line (read-line stream nil))
+ (end (file-position stream)))
+ (when (>= end pos)
+ ;; FIXME: READER-ERROR also prints the file position. Do we really
+ ;; need to try to give position information here?
+ (compiler-abort "read error at ~D:~% \"~A/\\~A\"~%~A"
+ pos
+ (string-left-trim " "
+ (subseq line 0 (- pos start)))
+ (subseq line (- pos start))
+ condition)
+ (return))
+ (setq start end)))))
+ (values))
+
+;;; Back STREAM up to the position Pos, then read a form with
+;;; *READ-SUPPRESS* on, discarding the result. If an error happens
+;;; during this read, then bail out using COMPILER-ERROR (fatal in
+;;; this context).
+(defun ignore-error-form (stream pos)
+ (declare (type stream stream) (type unsigned-byte pos))
+ (file-position stream pos)
+ (handler-case (let ((*read-suppress* t))
+ (read stream))
+ (error (condition)
+ (declare (ignore condition))
+ (compiler-error "unable to recover from read error"))))
+
+;;; Print an error message giving some context for an EOF error. We
+;;; print the first line after POS that contains #\" or #\(, or
+;;; lacking that, the first non-empty line.
+(defun unexpected-eof-error (stream pos condition)
+ (declare (type stream stream) (type unsigned-byte pos))
+ (let ((res nil))
+ (file-position stream pos)
+ (loop
+ (let ((line (read-line stream nil nil)))
+ (unless line (return))
+ (when (or (find #\" line) (find #\( line))
+ (setq res line)
+ (return))
+ (unless (or res (zerop (length line)))
+ (setq res line))))
+ (compiler-abort "read error in form starting at ~D:~%~@[ \"~A\"~%~]~A"
+ pos
+ res
+ condition))
+ (file-position stream (file-length stream))
+ (values))
+
+;;; Read a form from STREAM, returning EOF at EOF. If a read error
+;;; happens, then attempt to recover if possible, returning a proxy
+;;; error form.
+;;;
+;;; FIXME: This seems like quite a lot of complexity, and it seems
+;;; impossible to get it quite right. (E.g. the `(CERROR ..) form
+;;; returned here won't do the right thing if it's not in a position
+;;; for an executable form.) I think it might be better to just stop
+;;; trying to recover from read errors, punting all this noise
+;;; (including UNEXPECTED-EOF-ERROR and IGNORE-ERROR-FORM) and doing a
+;;; COMPILER-ABORT instead.
+(defun careful-read (stream eof pos)
+ (handler-case (read stream nil eof)
+ (error (condition)
+ (let ((new-pos (file-position stream)))
+ (cond ((= new-pos (file-length stream))
+ (unexpected-eof-error stream pos condition))
+ (t
+ (normal-read-error stream pos condition)
+ (ignore-error-form stream pos))))
+ '(cerror "Skip this form."
+ "compile-time read error"))))
+
+;;; If Stream is present, return it, otherwise open a stream to the
+;;; current file. There must be a current file. When we open a new
+;;; file, we also reset *PACKAGE* and policy. This gives the effect of
+;;; rebinding around each file.
+;;;
+;;; FIXME: Since we now do the standard ANSI thing of only one file
+;;; per compile (unlike the CMU CL extended COMPILE-FILE) can't this
+;;; complexity (including ADVANCE-SOURCE-FILE) go away?
+(defun get-source-stream (info)
+ (declare (type source-info info))
+ (cond ((source-info-stream info))
+ (t
+ (setq *package* *initial-package*)
+ (setq *default-cookie* (copy-cookie *initial-cookie*))
+ (setq *default-interface-cookie*
+ (copy-cookie *initial-interface-cookie*))
+ (let* ((finfo (first (source-info-current-file info)))
+ (name (file-info-name finfo)))
+ (setq sb!xc:*compile-file-truename* name)
+ (setq sb!xc:*compile-file-pathname* (file-info-untruename finfo))
+ (setf (source-info-stream info)
+ (open name :direction :input))))))
+
+;;; Close the stream in INFO if it is open.
+(defun close-source-info (info)
+ (declare (type source-info info))
+ (let ((stream (source-info-stream info)))
+ (when stream (close stream)))
+ (setf (source-info-stream info) nil)
+ (values))
+
+;;; Advance INFO to the next source file. If there is no next source
+;;; file, return NIL, otherwise T.
+(defun advance-source-file (info)
+ (declare (type source-info info))
+ (close-source-info info)
+ (let ((prev (pop (source-info-current-file info))))
+ (if (source-info-current-file info)
+ (let ((current (first (source-info-current-file info))))
+ (setf (file-info-source-root current)
+ (+ (file-info-source-root prev)
+ (length (file-info-forms prev))))
+ t)
+ nil)))
+
+;;; Read the sources from the source files and process them.
+(defun process-sources (info)
+ (let* ((file (first (source-info-current-file info)))
+ (stream (get-source-stream info)))
+ (loop
+ (let* ((pos (file-position stream))
+ (eof '(*eof*))
+ (form (careful-read stream eof pos)))
+ (if (eq form eof)
+ (return)
+ (let* ((forms (file-info-forms file))
+ (current-idx (+ (fill-pointer forms)
+ (file-info-source-root file))))
+ (vector-push-extend form forms)
+ (vector-push-extend pos (file-info-positions file))
+ (clrhash *source-paths*)
+ (find-source-paths form current-idx)
+ (process-top-level-form form
+ `(original-source-start 0 ,current-idx))))))
+ (when (advance-source-file info)
+ (process-sources info))))
+
+;;; Return the FILE-INFO describing the INDEX'th form.
+(defun find-file-info (index info)
+ (declare (type index index) (type source-info info))
+ (dolist (file (source-info-files info))
+ (when (> (+ (length (file-info-forms file))
+ (file-info-source-root file))
+ index)
+ (return file))))
+
+;;; Return the INDEX'th source form read from INFO and the position
+;;; where it was read.
+(defun find-source-root (index info)
+ (declare (type source-info info) (type index index))
+ (let* ((file (find-file-info index info))
+ (idx (- index (file-info-source-root file))))
+ (values (aref (file-info-forms file) idx)
+ (aref (file-info-positions file) idx))))
+\f
+;;;; top-level form processing
+
+;;; This is called by top-level form processing when we are ready to
+;;; actually compile something. If *BLOCK-COMPILE* is T, then we still
+;;; convert the form, but delay compilation, pushing the result on
+;;; *TOP-LEVEL-LAMBDAS* instead.
+(defun convert-and-maybe-compile (form path)
+ (declare (list path))
+ (let* ((*lexenv* (make-lexenv :cookie *default-cookie*
+ :interface-cookie *default-interface-cookie*))
+ (tll (ir1-top-level form path nil)))
+ (cond ((eq *block-compile* t) (push tll *top-level-lambdas*))
+ (t (compile-top-level (list tll) nil)))))
+
+;;; Process a PROGN-like portion of a top-level form. Forms is a list of
+;;; the forms, and Path is source path of the form they came out of.
+(defun process-top-level-progn (forms path)
+ (declare (list forms) (list path))
+ (dolist (form forms)
+ (process-top-level-form form path)))
+
+;;; Macroexpand form in the current environment with an error handler.
+;;; We only expand one level, so that we retain all the intervening
+;;; forms in the source path.
+(defun preprocessor-macroexpand (form)
+ (handler-case (sb!xc:macroexpand-1 form *lexenv*)
+ (error (condition)
+ (compiler-error "(during macroexpansion)~%~A" condition))))
+
+;;; Process a top-level use of LOCALLY. We parse declarations and then
+;;; recursively process the body.
+;;;
+;;; Binding *DEFAULT-xxx-COOKIE* is pretty much of a hack, since it
+;;; causes LOCALLY to "capture" enclosed proclamations. It is
+;;; necessary because CONVERT-AND-MAYBE-COMPILE uses the value of
+;;; *DEFAULT-COOKIE* as the policy. The need for this hack is due to
+;;; the quirk that there is no way to represent in a cookie that an
+;;; optimize quality came from the default.
+(defun process-top-level-locally (form path)
+ (declare (list path))
+ (multiple-value-bind (forms decls) (sb!sys:parse-body (cdr form) nil)
+ (let* ((*lexenv*
+ (process-decls decls nil nil (make-continuation)))
+ (*default-cookie* (lexenv-cookie *lexenv*))
+ (*default-interface-cookie* (lexenv-interface-cookie *lexenv*)))
+ (process-top-level-progn forms path))))
+
+;;; Stash file comment in the FILE-INFO structure.
+(defun process-file-comment (form)
+ (unless (and (proper-list-of-length-p form 2)
+ (stringp (second form)))
+ (compiler-error "bad FILE-COMMENT form: ~S" form))
+ (let ((file (first (source-info-current-file *source-info*))))
+ (cond ((file-info-comment file)
+ (compiler-warning "ignoring extra file comment:~% ~S" form))
+ (t
+ (let ((comment (coerce (second form) 'simple-string)))
+ (setf (file-info-comment file) comment)
+ (when sb!xc:*compile-verbose*
+ (compiler-mumble "~&FILE-COMMENT: ~A~2&" comment)))))))
+
+;;; Force any pending top-level forms to be compiled and dumped so that they
+;;; will be evaluated in the correct package environment. Dump the form to be
+;;; evaled at (cold) load time, and if EVAL is true, eval the form immediately.
+(defun process-cold-load-form (form path eval)
+ (let ((object *compile-object*))
+ (etypecase object
+ (fasl-file
+ (compile-top-level-lambdas () t)
+ (fasl-dump-cold-load-form form object))
+ ((or null core-object)
+ (convert-and-maybe-compile form path)))
+ (when eval
+ (eval form))))
+
+(declaim (special *compiler-error-bailout*))
+
+;;; Process a top-level FORM with the specified source PATH.
+;;; * If this is a magic top-level form, then do stuff.
+;;; * If this is a macro, then expand it.
+;;; * Otherwise, just compile it.
+(defun process-top-level-form (form path)
+
+ (declare (list path))
+
+ (catch 'process-top-level-form-error-abort
+ (let* ((path (or (gethash form *source-paths*) (cons form path)))
+ (*compiler-error-bailout*
+ #'(lambda ()
+ (convert-and-maybe-compile
+ `(error "execution of a form compiled with errors:~% ~S"
+ ',form)
+ path)
+ (throw 'process-top-level-form-error-abort nil))))
+ (if (atom form)
+ (convert-and-maybe-compile form path)
+ (case (car form)
+ ;; FIXME: It's not clear to me why we would want this
+ ;; special case; it might have been needed for some
+ ;; variation of the old GENESIS system, but it certainly
+ ;; doesn't seem to be needed for ours. Sometime after the
+ ;; system is running I'd like to remove it tentatively and
+ ;; see whether anything breaks, and if nothing does break,
+ ;; remove it permanently. (And if we *do* want special
+ ;; treatment of all these, we probably want to treat WARN
+ ;; the same way..)
+ ((error cerror break signal)
+ (process-cold-load-form form path nil))
+ ;; FIXME: ANSI seems to encourage things like DEFSTRUCT to
+ ;; be done with EVAL-WHEN, without this kind of one-off
+ ;; compiler magic.
+ (sb!kernel:%compiler-defstruct
+ (convert-and-maybe-compile form path)
+ (compile-top-level-lambdas () t))
+ ((eval-when)
+ (unless (>= (length form) 2)
+ (compiler-error "EVAL-WHEN form is too short: ~S" form))
+ (do-eval-when-stuff
+ (cadr form) (cddr form)
+ #'(lambda (forms)
+ (process-top-level-progn forms path))))
+ ((macrolet)
+ (unless (>= (length form) 2)
+ (compiler-error "MACROLET form is too short: ~S" form))
+ (do-macrolet-stuff
+ (cadr form)
+ #'(lambda ()
+ (process-top-level-progn (cddr form) path))))
+ (locally (process-top-level-locally form path))
+ (progn (process-top-level-progn (cdr form) path))
+ (file-comment (process-file-comment form))
+ (t
+ (let* ((uform (uncross form))
+ (exp (preprocessor-macroexpand uform)))
+ (if (eq exp uform)
+ (convert-and-maybe-compile uform path)
+ (process-top-level-form exp path))))))))
+
+ (values))
+\f
+;;;; load time value support
+;;;;
+;;;; (See EMIT-MAKE-LOAD-FORM.)
+
+;;; Returns T iff we are currently producing a fasl-file and hence
+;;; constants need to be dumped carefully.
+(defun producing-fasl-file ()
+ (unless *converting-for-interpreter*
+ (fasl-file-p *compile-object*)))
+
+;;; Compile FORM and arrange for it to be called at load-time. Return
+;;; the dumper handle and our best guess at the type of the object.
+(defun compile-load-time-value
+ (form &optional
+ (name (let ((*print-level* 2) (*print-length* 3))
+ (format nil "load time value of ~S"
+ (if (and (listp form)
+ (eq (car form) 'make-value-cell))
+ (second form)
+ form)))))
+ (let ((lambda (compile-load-time-stuff form name t)))
+ (values
+ (fasl-dump-load-time-value-lambda lambda *compile-object*)
+ (let ((type (leaf-type lambda)))
+ (if (function-type-p type)
+ (single-value-type (function-type-returns type))
+ *wild-type*)))))
+
+;;; Compile the FORMS and arrange for them to be called (for effect,
+;;; not value) at load time.
+(defun compile-make-load-form-init-forms (forms name)
+ (let ((lambda (compile-load-time-stuff `(progn ,@forms) name nil)))
+ (fasl-dump-top-level-lambda-call lambda *compile-object*)))
+
+;;; Does the actual work of COMPILE-LOAD-TIME-VALUE or
+;;; COMPILE-MAKE-LOAD-FORM- INIT-FORMS.
+(defun compile-load-time-stuff (form name for-value)
+ (with-ir1-namespace
+ (let* ((*lexenv* (make-null-lexenv))
+ (lambda (ir1-top-level form *current-path* for-value)))
+ (setf (leaf-name lambda) name)
+ (compile-top-level (list lambda) t)
+ lambda)))
+
+;;; Called by COMPILE-TOP-LEVEL when it was pased T for
+;;; LOAD-TIME-VALUE-P (which happens in COMPILE-LOAD-TIME-STUFF). We
+;;; don't try to combine this component with anything else and frob
+;;; the name. If not in a :TOP-LEVEL component, then don't bother
+;;; compiling, because it was merged with a run-time component.
+(defun compile-load-time-value-lambda (lambdas)
+ (assert (null (cdr lambdas)))
+ (let* ((lambda (car lambdas))
+ (component (block-component (node-block (lambda-bind lambda)))))
+ (when (eq (component-kind component) :top-level)
+ (setf (component-name component) (leaf-name lambda))
+ (compile-component component)
+ (clear-ir1-info component))))
+
+;;; The entry point for MAKE-LOAD-FORM support. When IR1 conversion
+;;; finds a constant structure, it invokes this to arrange for proper
+;;; dumping. If it turns out that the constant has already been
+;;; dumped, then we don't need to do anything.
+;;;
+;;; If the constant hasn't been dumped, then we check to see whether
+;;; we are in the process of creating it. We detect this by
+;;; maintaining the special *CONSTANTS-BEING-CREATED* as a list of all
+;;; the constants we are in the process of creating. Actually, each
+;;; entry is a list of the constant and any init forms that need to be
+;;; processed on behalf of that constant.
+;;;
+;;; It's not necessarily an error for this to happen. If we are
+;;; processing the init form for some object that showed up *after*
+;;; the original reference to this constant, then we just need to
+;;; defer the processing of that init form. To detect this, we
+;;; maintain *CONSTANTS-CREATED-SINCE-LAST-INIT* as a list of the
+;;; constants created since the last time we started processing an
+;;; init form. If the constant passed to emit-make-load-form shows up
+;;; in this list, then there is a circular chain through creation
+;;; forms, which is an error.
+;;;
+;;; If there is some intervening init form, then we blow out of
+;;; processing it by throwing to the tag PENDING-INIT. The value we
+;;; throw is the entry from *CONSTANTS-BEING-CREATED*. This is so the
+;;; offending init form can be tacked onto the init forms for the
+;;; circular object.
+;;;
+;;; If the constant doesn't show up in *CONSTANTS-BEING-CREATED*, then
+;;; we have to create it. We call MAKE-LOAD-FORM and check to see
+;;; whether the creation form is the magic value
+;;; :JUST-DUMP-IT-NORMALLY. If it is, then we don't do anything. The
+;;; dumper will eventually get its hands on the object and use the
+;;; normal structure dumping noise on it.
+;;;
+;;; Otherwise, we bind *CONSTANTS-BEING-CREATED* and
+;;; *CONSTANTS-CREATED-SINCE- LAST-INIT* and compile the creation form
+;;; a la LOAD-TIME-VALUE. When this finishes, we tell the dumper to
+;;; use that result instead whenever it sees this constant.
+;;;
+;;; Now we try to compile the init form. We bind
+;;; *CONSTANTS-CREATED-SINCE- LAST-INIT* to NIL and compile the init
+;;; form (and any init forms that were added because of circularity
+;;; detection). If this works, great. If not, we add the init forms to
+;;; the init forms for the object that caused the problems and let it
+;;; deal with it.
+(defvar *constants-being-created* nil)
+(defvar *constants-created-since-last-init* nil)
+;;; FIXME: Shouldn't these^ variables be bound in LET forms?
+(defun emit-make-load-form (constant)
+ (assert (fasl-file-p *compile-object*))
+ (unless (or (fasl-constant-already-dumped constant *compile-object*)
+ ;; KLUDGE: This special hack is because I was too lazy
+ ;; to rework DEF!STRUCT so that the MAKE-LOAD-FORM
+ ;; function of LAYOUT returns nontrivial forms when
+ ;; building the cross-compiler but :IGNORE-IT when
+ ;; cross-compiling or running under the target Lisp. --
+ ;; WHN 19990914
+ #+sb-xc-host (typep constant 'layout))
+ (let ((circular-ref (assoc constant *constants-being-created* :test #'eq)))
+ (when circular-ref
+ (when (find constant *constants-created-since-last-init* :test #'eq)
+ (throw constant t))
+ (throw 'pending-init circular-ref)))
+ (multiple-value-bind (creation-form init-form)
+ (handler-case
+ (sb!xc:make-load-form constant (make-null-lexenv))
+ (error (condition)
+ (compiler-error "(while making load form for ~S)~%~A"
+ constant
+ condition)))
+ (case creation-form
+ (:just-dump-it-normally
+ (fasl-validate-structure constant *compile-object*)
+ t)
+ (:ignore-it
+ nil)
+ (t
+ (compile-top-level-lambdas () t)
+ (when (fasl-constant-already-dumped constant *compile-object*)
+ (return-from emit-make-load-form nil))
+ (let* ((name (let ((*print-level* 1) (*print-length* 2))
+ (with-output-to-string (stream)
+ (write constant :stream stream))))
+ (info (if init-form
+ (list constant name init-form)
+ (list constant))))
+ (let ((*constants-being-created*
+ (cons info *constants-being-created*))
+ (*constants-created-since-last-init*
+ (cons constant *constants-created-since-last-init*)))
+ (when
+ (catch constant
+ (fasl-note-handle-for-constant
+ constant
+ (compile-load-time-value
+ creation-form
+ (format nil "creation form for ~A" name))
+ *compile-object*)
+ nil)
+ (compiler-error "circular references in creation form for ~S"
+ constant)))
+ (when (cdr info)
+ (let* ((*constants-created-since-last-init* nil)
+ (circular-ref
+ (catch 'pending-init
+ (loop for (name form) on (cdr info) by #'cddr
+ collect name into names
+ collect form into forms
+ finally
+ (compile-make-load-form-init-forms
+ forms
+ (format nil "init form~:[~;s~] for ~{~A~^, ~}"
+ (cdr forms) names)))
+ nil)))
+ (when circular-ref
+ (setf (cdr circular-ref)
+ (append (cdr circular-ref) (cdr info))))))))))))
+\f
+;;;; COMPILE-FILE
+
+;;; We build a list of top-level lambdas, and then periodically smash
+;;; them together into a single component and compile it.
+(defvar *pending-top-level-lambdas*)
+
+;;; The maximum number of top-level lambdas we put in a single
+;;; top-level component.
+;;;
+;;; CMU CL 18b used this nontrivially by default (setting it to 10)
+;;; but consequently suffered from the inability to execute some
+;;; troublesome constructs correctly, e.g. inability to load a fasl
+;;; file compiled from the source file
+;;; (defpackage "FOO" (:use "CL"))
+;;; (print 'foo::bar)
+;;; because it would dump data-setup fops (including a FOP-PACKAGE for
+;;; "FOO") for the second form before dumping the the code in the
+;;; first form, or the fop to execute the code in the first form. By
+;;; setting this value to 0 by default, we avoid this badness. This
+;;; increases the number of toplevel form functions, and so increases
+;;; the size of object files.
+;;;
+;;; The variable is still supported because when we are compiling the
+;;; SBCL system itself, which is known not contain any troublesome
+;;; constructs, we can set it to a nonzero value, which reduces the
+;;; number of toplevel form objects, reducing the peak memory usage in
+;;; GENESIS, which is desirable, since at least for SBCL version
+;;; 0.6.7, this is the high water mark for memory usage during system
+;;; construction.
+(defparameter *top-level-lambda-max* 0)
+
+(defun object-call-top-level-lambda (tll)
+ (declare (type functional tll))
+ (let ((object *compile-object*))
+ (etypecase object
+ (fasl-file
+ (fasl-dump-top-level-lambda-call tll object))
+ (core-object
+ (core-call-top-level-lambda tll object))
+ (null))))
+
+;;; Add LAMBDAS to the pending lambdas. If this leaves more than
+;;; *TOP-LEVEL-LAMBDA-MAX* lambdas in the list, or if FORCE-P is true,
+;;; then smash the lambdas into a single component, compile it, and
+;;; call the resulting function.
+(defun sub-compile-top-level-lambdas (lambdas force-p)
+ (declare (list lambdas))
+ (setq *pending-top-level-lambdas*
+ (append *pending-top-level-lambdas* lambdas))
+ (let ((pending *pending-top-level-lambdas*))
+ (when (and pending
+ (or (> (length pending) *top-level-lambda-max*)
+ force-p))
+ (multiple-value-bind (component tll) (merge-top-level-lambdas pending)
+ (setq *pending-top-level-lambdas* ())
+ (let ((*byte-compile* (if (eq *byte-compile* :maybe)
+ *byte-compile-top-level*
+ *byte-compile*)))
+ (compile-component component))
+ (clear-ir1-info component)
+ (object-call-top-level-lambda tll))))
+ (values))
+
+;;; Compile top-level code and call the top-level lambdas. We pick off
+;;; top-level lambdas in non-top-level components here, calling
+;;; SUB-c-t-l-l on each subsequence of normal top-level lambdas.
+(defun compile-top-level-lambdas (lambdas force-p)
+ (declare (list lambdas))
+ (let ((len (length lambdas)))
+ (flet ((loser (start)
+ (or (position-if #'(lambda (x)
+ (not (eq (component-kind
+ (block-component
+ (node-block
+ (lambda-bind x))))
+ :top-level)))
+ lambdas
+ :start start)
+ len)))
+ (do* ((start 0 (1+ loser))
+ (loser (loser start) (loser start)))
+ ((>= start len)
+ (when force-p
+ (sub-compile-top-level-lambdas nil t)))
+ (sub-compile-top-level-lambdas (subseq lambdas start loser)
+ (or force-p (/= loser len)))
+ (unless (= loser len)
+ (object-call-top-level-lambda (elt lambdas loser))))))
+ (values))
+
+;;; Compile LAMBDAS (a list of the lambdas for top-level forms) into
+;;; the object file. We loop doing local call analysis until it
+;;; converges, since a single pass might miss something due to
+;;; components being joined by LET conversion.
+;;;
+;;; LOAD-TIME-VALUE-P seems to control whether it's MAKE-LOAD-FORM and
+;;; COMPILE-LOAD-TIME-VALUE stuff. -- WHN 20000201
+(defun compile-top-level (lambdas load-time-value-p)
+ (declare (list lambdas))
+ (maybe-mumble "locall ")
+ (loop
+ (let ((did-something nil))
+ (dolist (lambda lambdas)
+ (let* ((component (block-component (node-block (lambda-bind lambda))))
+ (*all-components* (list component)))
+ (when (component-new-functions component)
+ (setq did-something t)
+ (local-call-analyze component))))
+ (unless did-something (return))))
+
+ (maybe-mumble "IDFO ")
+ (multiple-value-bind (components top-components hairy-top)
+ (find-initial-dfo lambdas)
+ (let ((*all-components* (append components top-components))
+ (top-level-closure nil))
+ (when *check-consistency*
+ (maybe-mumble "[check]~%")
+ (check-ir1-consistency *all-components*))
+
+ (dolist (component (append hairy-top top-components))
+ (when (pre-environment-analyze-top-level component)
+ (setq top-level-closure t)))
+
+ (let ((*byte-compile*
+ (if (and top-level-closure (eq *byte-compile* :maybe))
+ nil
+ *byte-compile*)))
+ (dolist (component components)
+ (compile-component component)
+ (when (replace-top-level-xeps component)
+ (setq top-level-closure t)))
+
+ (when *check-consistency*
+ (maybe-mumble "[check]~%")
+ (check-ir1-consistency *all-components*))
+
+ (if load-time-value-p
+ (compile-load-time-value-lambda lambdas)
+ (compile-top-level-lambdas lambdas top-level-closure)))
+
+ (dolist (component components)
+ (clear-ir1-info component))
+ (clear-stuff)))
+ (values))
+
+;;; Actually compile any stuff that has been queued up for block
+;;; compilation.
+(defun finish-block-compilation ()
+ (when *block-compile*
+ (when *top-level-lambdas*
+ (compile-top-level (nreverse *top-level-lambdas*) nil)
+ (setq *top-level-lambdas* ()))
+ (setq *block-compile* nil)
+ (setq *entry-points* nil)))
+
+;;; Read all forms from INFO and compile them, with output to OBJECT.
+;;; Return (VALUES NIL WARNINGS-P FAILURE-P).
+(defun sub-compile-file (info &optional d-s-info)
+ (declare (type source-info info))
+ (let* (;; These are bound in WITH-COMPILATION-UNIT now. -- WHN 20000308
+ #+nil (*compiler-error-count* 0)
+ #+nil (*compiler-warning-count* 0)
+ #+nil (*compiler-style-warning-count* 0)
+ #+nil (*compiler-note-count* 0)
+ (*block-compile* *block-compile-argument*)
+ (*package* *package*)
+ (*initial-package* *package*)
+ (*initial-cookie* *default-cookie*)
+ (*initial-interface-cookie* *default-interface-cookie*)
+ (*default-cookie* (copy-cookie *initial-cookie*))
+ (*default-interface-cookie*
+ (copy-cookie *initial-interface-cookie*))
+ (*lexenv* (make-null-lexenv))
+ (*converting-for-interpreter* nil)
+ (*source-info* info)
+ (sb!xc:*compile-file-pathname* nil)
+ (sb!xc:*compile-file-truename* nil)
+ (*top-level-lambdas* ())
+ (*pending-top-level-lambdas* ())
+ (*compiler-error-bailout*
+ #'(lambda ()
+ (compiler-mumble
+ "~2&fatal error, aborting compilation~%")
+ (return-from sub-compile-file (values nil t t))))
+ (*current-path* nil)
+ (*last-source-context* nil)
+ (*last-original-source* nil)
+ (*last-source-form* nil)
+ (*last-format-string* nil)
+ (*last-format-args* nil)
+ (*last-message-count* 0)
+ (*info-environment* (or *backend-info-environment*
+ *info-environment*))
+ (*gensym-counter* 0))
+ (with-compilation-values
+ (sb!xc:with-compilation-unit ()
+ (clear-stuff)
+
+ (process-sources info)
+
+ (finish-block-compilation)
+ (compile-top-level-lambdas () t)
+ (let ((object *compile-object*))
+ (etypecase object
+ (fasl-file (fasl-dump-source-info info object))
+ (core-object (fix-core-source-info info object d-s-info))
+ (null)))
+ nil))))
+
+;;; Return a list of pathnames for the named files. All the files must
+;;; exist.
+(defun verify-source-files (stuff)
+ (let* ((stuff (if (listp stuff) stuff (list stuff)))
+ (default-host (make-pathname
+ :host (pathname-host (pathname (first stuff))))))
+ (flet ((try-with-type (path type error-p)
+ (let ((new (merge-pathnames
+ path (make-pathname :type type
+ :defaults default-host))))
+ (if (probe-file new)
+ new
+ (and error-p (truename new))))))
+ (unless stuff
+ (error "can't compile with no source files"))
+ (mapcar #'(lambda (x)
+ (let ((x (pathname x)))
+ (cond ((typep x 'logical-pathname)
+ (try-with-type x "LISP" t))
+ ((probe-file x) x)
+ ((try-with-type x "lisp" nil))
+ ((try-with-type x "lisp" t)))))
+ stuff))))
+
+(defun elapsed-time-to-string (tsec)
+ (multiple-value-bind (tmin sec) (truncate tsec 60)
+ (multiple-value-bind (thr min) (truncate tmin 60)
+ (format nil "~D:~2,'0D:~2,'0D" thr min sec))))
+
+;;; Print some junk at the beginning and end of compilation.
+(defun start-error-output (source-info)
+ (declare (type source-info source-info))
+ (dolist (x (source-info-files source-info))
+ (compiler-mumble "compiling file ~S (written ~A):~%"
+ (namestring (file-info-name x))
+ (sb!int:format-universal-time nil
+ (file-info-write-date x)
+ :style :government
+ :print-weekday nil
+ :print-timezone nil)))
+ (compiler-mumble "~%")
+ (values))
+(defun finish-error-output (source-info won)
+ (declare (type source-info source-info))
+ (compiler-mumble "~&compilation ~:[aborted after~;finished in~] ~A~&"
+ won
+ (elapsed-time-to-string
+ (- (get-universal-time)
+ (source-info-start-time source-info))))
+ (values))
+
+;;; Open some files and call SUB-COMPILE-FILE. If something unwinds
+;;; out of the compile, then abort the writing of the output file, so
+;;; we don't overwrite it with known garbage.
+(defun sb!xc:compile-file
+ (source
+ &key
+ (output-file t) ; FIXME: ANSI says this should be a pathname designator.
+ ;; FIXME: ANSI doesn't seem to say anything about
+ ;; *COMPILE-VERBOSE* and *COMPILE-PRINT* being rebound by this
+ ;; function..
+ ((:verbose sb!xc:*compile-verbose*) sb!xc:*compile-verbose*)
+ ((:print sb!xc:*compile-print*) sb!xc:*compile-print*)
+ (external-format :default)
+ ((:block-compile *block-compile-argument*) nil)
+ ((:entry-points *entry-points*) nil)
+ ((:byte-compile *byte-compile*) *byte-compile-default*))
+ #!+sb-doc
+ "Compile SOURCE, producing a corresponding FASL file.
+ :Output-File
+ The name of the fasl to output, NIL for none, T for the default.
+ :Block-Compile
+ Determines whether multiple functions are compiled together as a unit,
+ resolving function references at compile time. NIL means that global
+ function names are never resolved at compilation time.
+ :Entry-Points
+ This specifies a list of function names for functions in the file(s) that
+ must be given global definitions. This only applies to block
+ compilation. If the value is NIL (the default) then all functions
+ will be globally defined.
+ :Byte-Compile {T | NIL | :MAYBE}
+ Determines whether to compile into interpreted byte code instead of
+ machine instructions. Byte code is several times smaller, but much
+ slower. If :MAYBE, then only byte-compile when SPEED is 0 and
+ DEBUG <= 1. The default is the value of SB-EXT:*BYTE-COMPILE-DEFAULT*,
+ which is initially :MAYBE."
+ (unless (eq external-format :default)
+ (error "Non-:DEFAULT EXTERNAL-FORMAT values are not supported."))
+ (let* ((fasl-file nil)
+ (output-file-name nil)
+ (compile-won nil)
+ (warnings-p nil)
+ (failure-p t) ; T in case error keeps this from being set later
+
+ ;; KLUDGE: The listifying and unlistifying in the next calls
+ ;; is to interface to old CMU CL code which accepted and
+ ;; returned lists of multiple source files. It would be
+ ;; cleaner to redo VERIFY-SOURCE-FILES and as
+ ;; VERIFY-SOURCE-FILE, accepting a single source file, and
+ ;; do a similar transformation on MAKE-FILE-SOURCE-INFO too.
+ ;; -- WHN 20000201
+ (source (first (verify-source-files (list source))))
+ (source-info (make-file-source-info (list source))))
+ (unwind-protect
+ (progn
+ (when output-file
+ (setq output-file-name
+ (sb!xc:compile-file-pathname source
+ :output-file output-file
+ :byte-compile *byte-compile*))
+ (setq fasl-file
+ (open-fasl-file output-file-name
+ (namestring source)
+ (eq *byte-compile* t))))
+
+ (when sb!xc:*compile-verbose*
+ (start-error-output source-info))
+ (let ((*compile-object* fasl-file)
+ dummy)
+ (multiple-value-setq (dummy warnings-p failure-p)
+ (sub-compile-file source-info)))
+ (setq compile-won t))
+
+ (close-source-info source-info)
+
+ (when fasl-file
+ (close-fasl-file fasl-file (not compile-won))
+ (setq output-file-name (pathname (fasl-file-stream fasl-file)))
+ (when (and compile-won sb!xc:*compile-verbose*)
+ (compiler-mumble "~2&~A written~%" (namestring output-file-name))))
+
+ (when sb!xc:*compile-verbose*
+ (finish-error-output source-info compile-won)))
+
+ (values (if output-file
+ ;; Hack around filesystem race condition...
+ (or (probe-file output-file-name) output-file-name)
+ nil)
+ warnings-p
+ failure-p)))
+\f
+(defun sb!xc:compile-file-pathname (file-path
+ &key (output-file t) byte-compile
+ &allow-other-keys)
+ #!+sb-doc
+ "Return a pathname describing what file COMPILE-FILE would write to given
+ these arguments."
+ (declare (values (or null pathname)))
+ (let ((pathname (pathname file-path)))
+ (cond ((not (eq output-file t))
+ (when output-file
+ (translate-logical-pathname (pathname output-file))))
+ ((and (typep pathname 'logical-pathname) (not (eq byte-compile t)))
+ (make-pathname :type "FASL" :defaults pathname
+ :case :common))
+ (t
+ (make-pathname :defaults (translate-logical-pathname pathname)
+ :type (if (eq byte-compile t)
+ (backend-byte-fasl-file-type)
+ *backend-fasl-file-type*))))))
--- /dev/null
+;;;; This file contains the implementation-independent facilities used
+;;;; for defining the compiler's interface to the VM in a given
+;;;; implementation that are needed at meta-compile time. They are
+;;;; separated out from vmdef.lisp so that they can be compiled and
+;;;; loaded without trashing the running compiler.
+;;;;
+;;;; FIXME: The "trashing the running [CMU CL] compiler" motivation no
+;;;; longer makes sense in SBCL, since we can cross-compile cleanly.
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!C")
+
+(file-comment
+ "$Header$")
+\f
+;;;; storage class and storage base definition
+
+;;; Enter the basic structure at meta-compile time, and then fill in the
+;;; missing slots at load time.
+(defmacro define-storage-base (name kind &key size)
+ #!+sb-doc
+ "Define-Storage-Base Name Kind {Key Value}*
+ Define a storage base having the specified Name. Kind may be :Finite,
+ :Unbounded or :Non-Packed. The following keywords are legal:
+
+ :Size <Size>
+ Specify the number of locations in a :Finite SB or the initial size of a
+ :Unbounded SB."
+
+ ;; FIXME: Replace with DECLARE.
+ (check-type name symbol)
+ (check-type kind (member :finite :unbounded :non-packed))
+
+ ;; SIZE is either mandatory or forbidden.
+ (ecase kind
+ (:non-packed
+ (when size
+ (error "A size specification is meaningless in a ~S SB." kind)))
+ ((:finite :unbounded)
+ (unless size (error "Size is not specified in a ~S SB." kind))
+ (check-type size unsigned-byte)))
+
+ (let ((res (if (eq kind :non-packed)
+ (make-sb :name name :kind kind)
+ (make-finite-sb :name name :kind kind :size size))))
+ `(progn
+ (eval-when (:compile-toplevel :load-toplevel :execute)
+ (/show0 "about to SETF GETHASH META-SB-NAMES in DEFINE-STORAGE-BASE")
+ (setf (gethash ',name *backend-meta-sb-names*)
+ ',res))
+ (/show0 "about to SETF GETHASH SB-NAMES in DEFINE-STORAGE-BASE")
+ ,(if (eq kind :non-packed)
+ `(setf (gethash ',name *backend-sb-names*)
+ (copy-sb ',res))
+ `(let ((res (copy-finite-sb ',res)))
+ (/show0 "not :NON-PACKED, i.e. hairy case")
+ (setf (finite-sb-always-live res)
+ (make-array ',size
+ :initial-element
+ #-(or sb-xc sb-xc-host) #*
+ ;; The cross-compiler isn't very good at
+ ;; dumping specialized arrays; we work around
+ ;; that by postponing generation of the
+ ;; specialized array 'til runtime.
+ #+(or sb-xc sb-xc-host)
+ (make-array 0 :element-type 'bit)))
+ (/show0 "doing second SETF")
+ (setf (finite-sb-conflicts res)
+ (make-array ',size :initial-element '#()))
+ (/show0 "doing third SETF")
+ (setf (finite-sb-live-tns res)
+ (make-array ',size :initial-element nil))
+ (/show0 "doing fourth and final SETF")
+ (setf (gethash ',name *backend-sb-names*)
+ res)))
+
+ (/show0 "about to put SB onto/into SB-LIST")
+ (setf *backend-sb-list*
+ (cons (sb-or-lose ',name)
+ (remove ',name *backend-sb-list* :key #'sb-name)))
+ (/show0 "finished with DEFINE-STORAGE-BASE expansion")
+ ',name)))
+
+(defmacro define-storage-class (name number sb-name &key (element-size '1)
+ (alignment '1) locations reserve-locations
+ save-p alternate-scs constant-scs)
+ #!+sb-doc
+ "Define-Storage-Class Name Number Storage-Base {Key Value}*
+ Define a storage class Name that uses the named Storage-Base. Number is a
+ small, non-negative integer that is used as an alias. The following
+ keywords are defined:
+
+ :Element-Size Size
+ The size of objects in this SC in whatever units the SB uses. This
+ defaults to 1.
+
+ :Alignment Size
+ The alignment restrictions for this SC. TNs will only be allocated at
+ offsets that are an even multiple of this number. Defaults to 1.
+
+ :Locations (Location*)
+ If the SB is :Finite, then this is a list of the offsets within the SB
+ that are in this SC.
+
+ :Reserve-Locations (Location*)
+ A subset of the Locations that the register allocator should try to
+ reserve for operand loading (instead of to hold variable values.)
+
+ :Save-P {T | NIL}
+ If T, then values stored in this SC must be saved in one of the
+ non-save-p :Alternate-SCs across calls.
+
+ :Alternate-SCs (SC*)
+ Indicates other SCs that can be used to hold values from this SC across
+ calls or when storage in this SC is exhausted. The SCs should be
+ specified in order of decreasing \"goodness\". There must be at least
+ one SC in an unbounded SB, unless this SC is only used for restricted or
+ wired TNs.
+
+ :Constant-SCs (SC*)
+ A list of the names of all the constant SCs that can be loaded into this
+ SC by a move function."
+
+ (check-type name symbol)
+ (check-type number sc-number)
+ (check-type sb-name symbol)
+ (check-type locations list)
+ (check-type reserve-locations list)
+ (check-type save-p boolean)
+ (check-type alternate-scs list)
+ (check-type constant-scs list)
+ (unless (= (logcount alignment) 1)
+ (error "alignment not a power of two: ~D" alignment))
+
+ (let ((sb (meta-sb-or-lose sb-name)))
+ (if (eq (sb-kind sb) :finite)
+ (let ((size (sb-size sb))
+ (element-size (eval element-size)))
+ (check-type element-size unsigned-byte)
+ (dolist (el locations)
+ (check-type el unsigned-byte)
+ (unless (<= 1 (+ el element-size) size)
+ (error "SC element ~D out of bounds for ~S" el sb))))
+ (when locations
+ (error ":LOCATIONS is meaningless in a ~S SB." (sb-kind sb))))
+
+ (unless (subsetp reserve-locations locations)
+ (error "RESERVE-LOCATIONS not a subset of LOCATIONS."))
+
+ (when (and (or alternate-scs constant-scs)
+ (eq (sb-kind sb) :non-packed))
+ (error
+ "It's meaningless to specify alternate or constant SCs in a ~S SB."
+ (sb-kind sb))))
+
+ (let ((nstack-p
+ (if (or (eq sb-name 'non-descriptor-stack)
+ (find 'non-descriptor-stack
+ (mapcar #'meta-sc-or-lose alternate-scs)
+ :key #'(lambda (x)
+ (sb-name (sc-sb x)))))
+ t nil)))
+ `(progn
+ (eval-when (:compile-toplevel :load-toplevel :execute)
+ (let ((res (make-sc :name ',name :number ',number
+ :sb (meta-sb-or-lose ',sb-name)
+ :element-size ,element-size
+ :alignment ,alignment
+ :locations ',locations
+ :reserve-locations ',reserve-locations
+ :save-p ',save-p
+ :number-stack-p ,nstack-p
+ :alternate-scs (mapcar #'meta-sc-or-lose
+ ',alternate-scs)
+ :constant-scs (mapcar #'meta-sc-or-lose
+ ',constant-scs))))
+ (setf (gethash ',name *backend-meta-sc-names*) res)
+ (setf (svref *backend-meta-sc-numbers* ',number) res)
+ (setf (svref (sc-load-costs res) ',number) 0)))
+
+ (let ((old (svref *backend-sc-numbers* ',number)))
+ (when (and old (not (eq (sc-name old) ',name)))
+ (warn "redefining SC number ~D from ~S to ~S" ',number
+ (sc-name old) ',name)))
+
+ (setf (svref *backend-sc-numbers* ',number)
+ (meta-sc-or-lose ',name))
+ (setf (gethash ',name *backend-sc-names*)
+ (meta-sc-or-lose ',name))
+ (setf (sc-sb (sc-or-lose ',name)) (sb-or-lose ',sb-name))
+ ',name)))
+\f
+;;;; move/coerce definition
+
+;;; Given a list of pairs of lists of SCs (as given to DEFINE-MOVE-VOP,
+;;; etc.), bind TO-SC and FROM-SC to all the combinations.
+(defmacro do-sc-pairs ((from-sc-var to-sc-var scs) &body body)
+ `(do ((froms ,scs (cddr froms))
+ (tos (cdr ,scs) (cddr tos)))
+ ((null froms))
+ (dolist (from (car froms))
+ (let ((,from-sc-var (meta-sc-or-lose from)))
+ (dolist (to (car tos))
+ (let ((,to-sc-var (meta-sc-or-lose to)))
+ ,@body))))))
+
+(defmacro define-move-function ((name cost) lambda-list scs &body body)
+ #!+sb-doc
+ "Define-Move-Function (Name Cost) lambda-list ({(From-SC*) (To-SC*)}*) form*
+ Define the function Name and note it as the function used for moving operands
+ from the From-SCs to the To-SCs. Cost is the cost of this move operation.
+ The function is called with three arguments: the VOP (for context), and the
+ source and destination TNs. An ASSEMBLE form is wrapped around the body.
+ All uses of DEFINE-MOVE-FUNCTION should be compiled before any uses of
+ DEFINE-VOP."
+ (when (or (oddp (length scs)) (null scs))
+ (error "malformed SCs spec: ~S" scs))
+ (check-type cost index)
+ `(progn
+ (eval-when (:compile-toplevel :load-toplevel :execute)
+ (do-sc-pairs (from-sc to-sc ',scs)
+ (unless (eq from-sc to-sc)
+ (let ((num (sc-number from-sc)))
+ (setf (svref (sc-move-functions to-sc) num) ',name)
+ (setf (svref (sc-load-costs to-sc) num) ',cost)))))
+
+ (defun ,name ,lambda-list
+ (sb!assem:assemble (*code-segment* ,(first lambda-list))
+ ,@body))))
+
+(defconstant sc-vop-slots '((:move . sc-move-vops)
+ (:move-argument . sc-move-arg-vops)))
+
+;;; We record the VOP and costs for all SCs that we can move between
+;;; (including implicit loading).
+(defmacro define-move-vop (name kind &rest scs)
+ #!+sb-doc
+ "Define-Move-VOP Name {:Move | :Move-Argument} {(From-SC*) (To-SC*)}*
+ Make Name be the VOP used to move values in the specified From-SCs to the
+ representation of the To-SCs. If kind is :Move-Argument, then the VOP takes
+ an extra argument, which is the frame pointer of the frame to move into."
+ (when (or (oddp (length scs)) (null scs))
+ (error "malformed SCs spec: ~S" scs))
+ (let ((accessor (or (cdr (assoc kind sc-vop-slots))
+ (error "unknown kind ~S" kind))))
+ `(progn
+ ,@(when (eq kind :move)
+ `((eval-when (:compile-toplevel :load-toplevel :execute)
+ (do-sc-pairs (from-sc to-sc ',scs)
+ (compute-move-costs from-sc to-sc
+ ,(vop-parse-cost
+ (vop-parse-or-lose name)))))))
+
+ (let ((vop (template-or-lose ',name)))
+ (do-sc-pairs (from-sc to-sc ',scs)
+ (dolist (dest-sc (cons to-sc (sc-alternate-scs to-sc)))
+ (let ((vec (,accessor dest-sc)))
+ (let ((scn (sc-number from-sc)))
+ (setf (svref vec scn)
+ (adjoin-template vop (svref vec scn))))
+ (dolist (sc (append (sc-alternate-scs from-sc)
+ (sc-constant-scs from-sc)))
+ (let ((scn (sc-number sc)))
+ (setf (svref vec scn)
+ (adjoin-template vop (svref vec scn))))))))))))
+\f
+;;;; primitive type definition
+
+(defun meta-primitive-type-or-lose (name)
+ (the primitive-type
+ (or (gethash name *backend-meta-primitive-type-names*)
+ (error "~S is not a defined primitive type." name))))
+
+;;; If the primitive-type structure already exists, we destructively modify
+;;; it so that existing references in templates won't be invalidated.
+(defmacro def-primitive-type (name scs &key (type name))
+ #!+sb-doc
+ "Def-Primitive-Type Name (SC*) {Key Value}*
+ Define a primitive type Name. Each SC specifies a Storage Class that values
+ of this type may be allocated in. The following keyword options are
+ defined:
+
+ :Type
+ The type descriptor for the Lisp type that is equivalent to this type
+ (defaults to Name.)"
+ (check-type name symbol)
+ (check-type scs list)
+ (let ((scns (mapcar #'meta-sc-number-or-lose scs))
+ (get-type `(specifier-type ',type)))
+ `(progn
+ (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
+ (setf (gethash ',name *backend-meta-primitive-type-names*)
+ (make-primitive-type :name ',name
+ :scs ',scns
+ :type ,get-type)))
+ ,(once-only ((n-old `(gethash ',name *backend-primitive-type-names*))
+ (n-type get-type))
+ `(progn
+ (cond (,n-old
+ (setf (primitive-type-scs ,n-old) ',scns)
+ (setf (primitive-type-type ,n-old) ,n-type))
+ (t
+ (setf (gethash ',name *backend-primitive-type-names*)
+ (make-primitive-type :name ',name
+ :scs ',scns
+ :type ,n-type))))
+ ',name)))))
+
+;;; Just record the translation.
+(defmacro def-primitive-type-alias (name result)
+ #!+sb-doc
+ "DEF-PRIMITIVE-TYPE-ALIAS Name Result
+ Define name to be an alias for Result in VOP operand type restrictions."
+ `(eval-when (:compile-toplevel :load-toplevel :execute)
+ (setf (gethash ',name *backend-primitive-type-aliases*) ',result)
+ ',name))
+
+(defparameter *primitive-type-slot-alist*
+ '((:check . primitive-type-check)))
+
+(defmacro primitive-type-vop (vop kinds &rest types)
+ #!+sb-doc
+ "Primitive-Type-VOP Vop (Kind*) Type*
+ Annotate all the specified primitive Types with the named VOP under each of
+ the specified kinds:
+
+ :Check
+ A one argument one result VOP that moves the argument to the result,
+ checking that the value is of this type in the process."
+ (let ((n-vop (gensym))
+ (n-type (gensym)))
+ `(let ((,n-vop (template-or-lose ',vop)))
+ ,@(mapcar
+ #'(lambda (type)
+ `(let ((,n-type (primitive-type-or-lose ',type)))
+ ,@(mapcar
+ #'(lambda (kind)
+ (let ((slot (or (cdr (assoc kind
+ *primitive-type-slot-alist*))
+ (error "unknown kind: ~S" kind))))
+ `(setf (,slot ,n-type) ,n-vop)))
+ kinds)))
+ types)
+ nil)))
+
+;;; Return true if SC is either one of Ptype's SC's, or one of those SC's
+;;; alternate or constant SCs.
+(defun meta-sc-allowed-by-primitive-type (sc ptype)
+ (declare (type sc sc) (type primitive-type ptype))
+ (let ((scn (sc-number sc)))
+ (dolist (allowed (primitive-type-scs ptype) nil)
+ (when (eql allowed scn)
+ (return t))
+ (let ((allowed-sc (svref *backend-meta-sc-numbers* allowed)))
+ (when (or (member sc (sc-alternate-scs allowed-sc))
+ (member sc (sc-constant-scs allowed-sc)))
+ (return t))))))
+\f
+;;;; VOP definition structures
+;;;;
+;;;; Define-VOP uses some fairly complex data structures at meta-compile
+;;;; time, both to hold the results of parsing the elaborate syntax and to
+;;;; retain the information so that it can be inherited by other VOPs.
+
+;;; The VOP-Parse structure holds everything we need to know about a VOP at
+;;; meta-compile time.
+(def!struct (vop-parse
+ (:make-load-form-fun just-dump-it-normally)
+ #-sb-xc-host (:pure t))
+ ;; The name of this VOP.
+ (name nil :type symbol)
+ ;; If true, then the name of the VOP we inherit from.
+ (inherits nil :type (or symbol null))
+ ;; Lists of Operand-Parse structures describing the arguments, results and
+ ;; temporaries of the VOP.
+ (args nil :type list)
+ (results nil :type list)
+ (temps nil :type list)
+ ;; Operand-Parse structures containing information about more args and
+ ;; results. If null, then there there are no more operands of that kind.
+ (more-args nil :type (or operand-parse null))
+ (more-results nil :type (or operand-parse null))
+ ;; A list of all the above together.
+ (operands nil :type list)
+ ;; Names of variables that should be declared ignore.
+ (ignores () :type list)
+ ;; True if this is a :Conditional VOP.
+ (conditional-p nil)
+ ;; Argument and result primitive types. These are pulled out of the
+ ;; operands, since we often want to change them without respecifying the
+ ;; operands.
+ (arg-types :unspecified :type (or (member :unspecified) list))
+ (result-types :unspecified :type (or (member :unspecified) list))
+ ;; The guard expression specified, or NIL if none.
+ (guard nil)
+ ;; The cost of and body code for the generator.
+ (cost 0 :type unsigned-byte)
+ (body :unspecified :type (or (member :unspecified) list))
+ ;; Info for VOP variants. The list of forms to be evaluated to get the
+ ;; variant args for this VOP, and the list of variables to be bound to the
+ ;; variant args.
+ (variant () :type list)
+ (variant-vars () :type list)
+ ;; Variables bound to the VOP and Vop-Node when in the generator body.
+ (vop-var (gensym) :type symbol)
+ (node-var nil :type (or symbol null))
+ ;; A list of the names of the codegen-info arguments to this VOP.
+ (info-args () :type list)
+ ;; An efficiency note associated with this VOP.
+ (note nil :type (or string null))
+ ;; A list of the names of the Effects and Affected attributes for this VOP.
+ (effects '(any) :type list)
+ (affected '(any) :type list)
+ ;; A list of the names of functions this VOP is a translation of and the
+ ;; policy that allows this translation to be done. :Fast is a safe default,
+ ;; since it isn't a safe policy.
+ (translate () :type list)
+ (policy :fast :type policies)
+ ;; Stuff used by life analysis.
+ (save-p nil :type (member t nil :compute-only :force-to-stack))
+ ;; Info about how to emit move-argument VOPs for the more operand in
+ ;; call/return VOPs.
+ (move-args nil :type (member nil :local-call :full-call :known-return)))
+
+(defprinter (vop-parse)
+ name
+ (inherits :test inherits)
+ args
+ results
+ temps
+ (more-args :test more-args)
+ (more-results :test more-results)
+ (conditional-p :test conditional-p)
+ ignores
+ arg-types
+ result-types
+ cost
+ body
+ (variant :test variant)
+ (variant-vars :test variant-vars)
+ (info-args :test info-args)
+ (note :test note)
+ effects
+ affected
+ translate
+ policy
+ (save-p :test save-p)
+ (move-args :test move-args))
+
+;;; An OPERAND-PARSE object contains stuff we need to know about an operand or
+;;; temporary at meta-compile time. Besides the obvious stuff, we also store
+;;; the names of per-operand temporaries here.
+(def!struct (operand-parse
+ (:make-load-form-fun just-dump-it-normally)
+ #-sb-xc-host (:pure t))
+ ;; Name of the operand (which we bind to the TN).
+ (name nil :type symbol)
+ ;; The way this operand is used:
+ (kind (required-argument)
+ :type (member :argument :result :temporary
+ :more-argument :more-result))
+ ;; If true, the name of an operand that this operand is targeted to. This is
+ ;; only meaningful in :Argument and :Temporary operands.
+ (target nil :type (or symbol null))
+ ;; Temporary that holds the TN-Ref for this operand. Temp-Temp holds the
+ ;; write reference that begins a temporary's lifetime.
+ (temp (gensym) :type symbol)
+ (temp-temp nil :type (or symbol null))
+ ;; The time that this operand is first live and the time at which it becomes
+ ;; dead again. These are time-specs, as returned by parse-time-spec.
+ born
+ dies
+ ;; A list of the names of the SCs that this operand is allowed into. If
+ ;; false, there is no restriction.
+ (scs nil :type list)
+ ;; Variable that is bound to the load TN allocated for this operand, or to
+ ;; NIL if no load-TN was allocated.
+ (load-tn (gensym) :type symbol)
+ ;; An expression that tests whether to do automatic operand loading.
+ (load t)
+ ;; In a wired or restricted temporary this is the SC the TN is to be packed
+ ;; in. Null otherwise.
+ (sc nil :type (or symbol null))
+ ;; If non-null, we are a temp wired to this offset in SC.
+ (offset nil :type (or unsigned-byte null)))
+
+(defprinter (operand-parse)
+ name
+ kind
+ (target :test target)
+ born
+ dies
+ (scs :test scs)
+ (load :test load)
+ (sc :test sc)
+ (offset :test offset))
+\f
+;;;; miscellaneous utilities
+
+;;; Find the operand or temporary with the specifed Name in the VOP Parse.
+;;; If there is no such operand, signal an error. Also error if the operand
+;;; kind isn't one of the specified Kinds. If Error-P is NIL, just return NIL
+;;; if there is no such operand.
+(defun find-operand (name parse &optional
+ (kinds '(:argument :result :temporary))
+ (error-p t))
+ (declare (symbol name) (type vop-parse parse) (list kinds))
+ (let ((found (find name (vop-parse-operands parse)
+ :key #'operand-parse-name)))
+ (if found
+ (unless (member (operand-parse-kind found) kinds)
+ (error "Operand ~S isn't one of these kinds: ~S." name kinds))
+ (when error-p
+ (error "~S is not an operand to ~S." name (vop-parse-name parse))))
+ found))
+
+;;; Get the VOP-Parse structure for NAME or die trying. For all
+;;; meta-compile time uses, the VOP-Parse should be used instead of the
+;;; VOP-Info.
+(defun vop-parse-or-lose (name)
+ (the vop-parse
+ (or (gethash name *backend-parsed-vops*)
+ (error "~S is not the name of a defined VOP." name))))
+
+;;; Return a list of let-forms to parse a tn-ref list into a the temps
+;;; specified by the operand-parse structures. More-Operand is the
+;;; Operand-Parse describing any more operand, or NIL if none. Refs is an
+;;; expression that evaluates into the first tn-ref.
+(defun access-operands (operands more-operand refs)
+ (declare (list operands))
+ (collect ((res))
+ (let ((prev refs))
+ (dolist (op operands)
+ (let ((n-ref (operand-parse-temp op)))
+ (res `(,n-ref ,prev))
+ (setq prev `(tn-ref-across ,n-ref))))
+
+ (when more-operand
+ (res `(,(operand-parse-name more-operand) ,prev))))
+ (res)))
+
+;;; Used with Access-Operands to prevent warnings for TN-Ref temps not used
+;;; by some particular function. It returns the name of the last operand, or
+;;; NIL if Operands is NIL.
+(defun ignore-unreferenced-temps (operands)
+ (when operands
+ (operand-parse-temp (car (last operands)))))
+
+;;; Grab an arg out of a VOP spec, checking the type and syntax and stuff.
+(defun vop-spec-arg (spec type &optional (n 1) (last t))
+ (let ((len (length spec)))
+ (when (<= len n)
+ (error "~:R argument missing: ~S" n spec))
+ (when (and last (> len (1+ n)))
+ (error "extra junk at end of ~S" spec))
+ (let ((thing (elt spec n)))
+ (unless (typep thing type)
+ (error "~:R argument is not a ~S: ~S" n type spec))
+ thing)))
+\f
+;;;; time specs
+
+;;; Return a time spec describing a time during the evaluation of a VOP,
+;;; used to delimit operand and temporary lifetimes. The representation is a
+;;; cons whose CAR is the number of the evaluation phase and the CDR is the
+;;; sub-phase. The sub-phase is 0 in the :Load and :Save phases.
+(defun parse-time-spec (spec)
+ (let ((dspec (if (atom spec) (list spec 0) spec)))
+ (unless (and (= (length dspec) 2)
+ (typep (second dspec) 'unsigned-byte))
+ (error "malformed time specifier: ~S" spec))
+
+ (cons (case (first dspec)
+ (:load 0)
+ (:argument 1)
+ (:eval 2)
+ (:result 3)
+ (:save 4)
+ (t
+ (error "unknown phase in time specifier: ~S" spec)))
+ (second dspec))))
+
+;;; Return true if the time spec X is the same or later time than Y.
+(defun time-spec-order (x y)
+ (or (> (car x) (car y))
+ (and (= (car x) (car y))
+ (>= (cdr x) (cdr y)))))
+\f
+;;;; generation of emit functions
+
+(defun compute-temporaries-description (parse)
+ (let ((temps (vop-parse-temps parse))
+ (element-type '(unsigned-byte 16)))
+ (when temps
+ (let ((results (make-specializable-array
+ (length temps)
+ :element-type element-type))
+ (index 0))
+ (dolist (temp temps)
+ (declare (type operand-parse temp))
+ (let ((sc (operand-parse-sc temp))
+ (offset (operand-parse-offset temp)))
+ (assert sc)
+ (setf (aref results index)
+ (if offset
+ (+ (ash offset (1+ sc-bits))
+ (ash (meta-sc-number-or-lose sc) 1)
+ 1)
+ (ash (meta-sc-number-or-lose sc) 1))))
+ (incf index))
+ ;; KLUDGE: As in the other COERCEs wrapped around with
+ ;; MAKE-SPECIALIZABLE-ARRAY results in COMPUTE-REF-ORDERING, this
+ ;; coercion could be removed by a sufficiently smart compiler, but I
+ ;; dunno whether Python is that smart. It would be good to check this
+ ;; and help it if it's not smart enough to remove it for itself.
+ ;; However, it's probably not urgent, since the overhead of an extra
+ ;; no-op conversion is unlikely to be large compared to consing and
+ ;; corresponding GC. -- WHN ca. 19990701
+ `(coerce ,results '(specializable-vector ,element-type))))))
+
+(defun compute-ref-ordering (parse)
+ (let* ((num-args (+ (length (vop-parse-args parse))
+ (if (vop-parse-more-args parse) 1 0)))
+ (num-results (+ (length (vop-parse-results parse))
+ (if (vop-parse-more-results parse) 1 0)))
+ (index 0))
+ (collect ((refs) (targets))
+ (dolist (op (vop-parse-operands parse))
+ (when (operand-parse-target op)
+ (unless (member (operand-parse-kind op) '(:argument :temporary))
+ (error "cannot target a ~S operand: ~S" (operand-parse-kind op)
+ (operand-parse-name op)))
+ (let ((target (find-operand (operand-parse-target op) parse
+ '(:temporary :result))))
+ (targets (+ (* index max-vop-tn-refs)
+ (ecase (operand-parse-kind target)
+ (:result
+ (+ (position-or-lose target
+ (vop-parse-results parse))
+ num-args))
+ (:temporary
+ (+ (* (position-or-lose target
+ (vop-parse-temps parse))
+ 2)
+ num-args num-results)))))))
+ (let ((born (operand-parse-born op))
+ (dies (operand-parse-dies op)))
+ (ecase (operand-parse-kind op)
+ (:argument
+ (refs (cons (cons dies nil) index)))
+ (:more-argument
+ (refs (cons (cons dies nil) index)))
+ (:result
+ (refs (cons (cons born t) index)))
+ (:more-result
+ (refs (cons (cons born t) index)))
+ (:temporary
+ (refs (cons (cons dies nil) index))
+ (incf index)
+ (refs (cons (cons born t) index))))
+ (incf index)))
+ (let* ((sorted (sort (refs)
+ #'(lambda (x y)
+ (let ((x-time (car x))
+ (y-time (car y)))
+ (if (time-spec-order x-time y-time)
+ (if (time-spec-order y-time x-time)
+ (and (not (cdr x)) (cdr y))
+ nil)
+ t)))
+ :key #'car))
+ (oe-type '(mod #.max-vop-tn-refs)) ; :REF-ORDERING element type
+ (te-type '(mod #.(* max-vop-tn-refs 2))) ; :TARGETS element type
+ (ordering (make-specializable-array
+ (length sorted)
+ :element-type oe-type)))
+ (let ((index 0))
+ (dolist (ref sorted)
+ (setf (aref ordering index) (cdr ref))
+ (incf index)))
+ `(:num-args ,num-args
+ :num-results ,num-results
+ ;; KLUDGE: The (COERCE .. (SPECIALIZABLE-VECTOR ..)) wrapper here
+ ;; around the result returned by MAKE-SPECIALIZABLE-ARRAY above was
+ ;; of course added to help with cross-compilation. "A sufficiently
+ ;; smart compiler" should be able to optimize all this away in the
+ ;; final target Lisp, leaving a single MAKE-ARRAY with no subsequent
+ ;; coercion. However, I don't know whether Python is that smart. (Can
+ ;; it figure out the return type of MAKE-ARRAY? Does it know that
+ ;; COERCE can be optimized away if the input type is known to be the
+ ;; same as the COERCEd-to type?) At some point it would be good to
+ ;; test to see whether this construct is in fact causing run-time
+ ;; overhead, and fix it if so. (Some declarations of the types
+ ;; returned by MAKE-ARRAY might be enough to fix it.) However, it's
+ ;; probably not urgent to fix this, since it's hard to imagine that
+ ;; any overhead caused by calling COERCE and letting it decide to
+ ;; bail out could be large compared to the cost of consing and GCing
+ ;; the vectors in the first place. -- WHN ca. 19990701
+ :ref-ordering (coerce ',ordering
+ '(specializable-vector ,oe-type))
+ ,@(when (targets)
+ `(:targets (coerce ',(targets)
+ '(specializable-vector ,te-type)))))))))
+
+(defun make-emit-function-and-friends (parse)
+ `(:emit-function #'emit-generic-vop
+ :temps ,(compute-temporaries-description parse)
+ ,@(compute-ref-ordering parse)))
+\f
+;;;; generator functions
+
+;;; Return an alist that translates from lists of SCs we can load OP from to
+;;; the move function used for loading those SCs. We quietly ignore
+;;; restrictions to :non-packed (constant) and :unbounded SCs, since we don't
+;;; load into those SCs.
+(defun find-move-functions (op load-p)
+ (collect ((funs))
+ (dolist (sc-name (operand-parse-scs op))
+ (let* ((sc (meta-sc-or-lose sc-name))
+ (scn (sc-number sc))
+ (load-scs (append (when load-p
+ (sc-constant-scs sc))
+ (sc-alternate-scs sc))))
+ (cond
+ (load-scs
+ (dolist (alt load-scs)
+ (unless (member (sc-name alt) (operand-parse-scs op) :test #'eq)
+ (let* ((altn (sc-number alt))
+ (name (if load-p
+ (svref (sc-move-functions sc) altn)
+ (svref (sc-move-functions alt) scn)))
+ (found (or (assoc alt (funs) :test #'member)
+ (rassoc name (funs)))))
+ (unless name
+ (error "no move function defined to ~:[save~;load~] SC ~S ~
+ with ~S ~:[to~;from~] from SC ~S"
+ load-p sc-name load-p (sc-name alt)))
+
+ (cond (found
+ (unless (eq (cdr found) name)
+ (error "can't tell whether to ~:[save~;load~]~@
+ or ~S when operand is in SC ~S"
+ load-p name (cdr found) (sc-name alt)))
+ (pushnew alt (car found)))
+ (t
+ (funs (cons (list alt) name))))))))
+ ((member (sb-kind (sc-sb sc)) '(:non-packed :unbounded)))
+ (t
+ (error "SC ~S has no alternate~:[~; or constant~] SCs, yet it is~@
+ mentioned in the restriction for operand ~S"
+ sc-name load-p (operand-parse-name op))))))
+ (funs)))
+
+;;; Return a form to load/save the specified operand when it has a load TN.
+;;; For any given SC that we can load from, there must be a unique load
+;;; function. If all SCs we can load from have the same move function, then we
+;;; just call that when there is a load TN. If there are multiple possible
+;;; move functions, then we dispatch off of the operand TN's type to see which
+;;; move function to use.
+(defun call-move-function (parse op load-p)
+ (let ((funs (find-move-functions op load-p))
+ (load-tn (operand-parse-load-tn op)))
+ (if funs
+ (let* ((tn `(tn-ref-tn ,(operand-parse-temp op)))
+ (n-vop (or (vop-parse-vop-var parse)
+ (setf (vop-parse-vop-var parse) (gensym))))
+ (form (if (rest funs)
+ `(sc-case ,tn
+ ,@(mapcar #'(lambda (x)
+ `(,(mapcar #'sc-name (car x))
+ ,(if load-p
+ `(,(cdr x) ,n-vop ,tn
+ ,load-tn)
+ `(,(cdr x) ,n-vop ,load-tn
+ ,tn))))
+ funs))
+ (if load-p
+ `(,(cdr (first funs)) ,n-vop ,tn ,load-tn)
+ `(,(cdr (first funs)) ,n-vop ,load-tn ,tn)))))
+ (if (eq (operand-parse-load op) t)
+ `(when ,load-tn ,form)
+ `(when (eq ,load-tn ,(operand-parse-name op))
+ ,form)))
+ `(when ,load-tn
+ (error "load TN allocated, but no move function?~@
+ VM definition is inconsistent, recompile and try again.")))))
+
+;;; Return the TN that we should bind to the operand's var in the generator
+;;; body. In general, this involves evaluating the :LOAD-IF test expression.
+(defun decide-to-load (parse op)
+ (let ((load (operand-parse-load op))
+ (load-tn (operand-parse-load-tn op))
+ (temp (operand-parse-temp op)))
+ (if (eq load t)
+ `(or ,load-tn (tn-ref-tn ,temp))
+ (collect ((binds)
+ (ignores))
+ (dolist (x (vop-parse-operands parse))
+ (when (member (operand-parse-kind x) '(:argument :result))
+ (let ((name (operand-parse-name x)))
+ (binds `(,name (tn-ref-tn ,(operand-parse-temp x))))
+ (ignores name))))
+ `(if (and ,load-tn
+ (let ,(binds)
+ (declare (ignorable ,@(ignores)))
+ ,load))
+ ,load-tn
+ (tn-ref-tn ,temp))))))
+
+;;; Make a lambda that parses the VOP TN-Refs, does automatic operand
+;;; loading, and runs the appropriate code generator.
+(defun make-generator-function (parse)
+ (declare (type vop-parse parse))
+ (let ((n-vop (vop-parse-vop-var parse))
+ (operands (vop-parse-operands parse))
+ (n-info (gensym)) (n-variant (gensym)))
+ (collect ((binds)
+ (loads)
+ (saves))
+ (dolist (op operands)
+ (ecase (operand-parse-kind op)
+ ((:argument :result)
+ (let ((temp (operand-parse-temp op))
+ (name (operand-parse-name op)))
+ (cond ((and (operand-parse-load op) (operand-parse-scs op))
+ (binds `(,(operand-parse-load-tn op)
+ (tn-ref-load-tn ,temp)))
+ (binds `(,name ,(decide-to-load parse op)))
+ (if (eq (operand-parse-kind op) :argument)
+ (loads (call-move-function parse op t))
+ (saves (call-move-function parse op nil))))
+ (t
+ (binds `(,name (tn-ref-tn ,temp)))))))
+ (:temporary
+ (binds `(,(operand-parse-name op)
+ (tn-ref-tn ,(operand-parse-temp op)))))
+ ((:more-argument :more-result))))
+
+ `#'(lambda (,n-vop)
+ (let* (,@(access-operands (vop-parse-args parse)
+ (vop-parse-more-args parse)
+ `(vop-args ,n-vop))
+ ,@(access-operands (vop-parse-results parse)
+ (vop-parse-more-results parse)
+ `(vop-results ,n-vop))
+ ,@(access-operands (vop-parse-temps parse) nil
+ `(vop-temps ,n-vop))
+ ,@(when (vop-parse-info-args parse)
+ `((,n-info (vop-codegen-info ,n-vop))
+ ,@(mapcar #'(lambda (x) `(,x (pop ,n-info)))
+ (vop-parse-info-args parse))))
+ ,@(when (vop-parse-variant-vars parse)
+ `((,n-variant (vop-info-variant (vop-info ,n-vop)))
+ ,@(mapcar #'(lambda (x) `(,x (pop ,n-variant)))
+ (vop-parse-variant-vars parse))))
+ ,@(when (vop-parse-node-var parse)
+ `((,(vop-parse-node-var parse) (vop-node ,n-vop))))
+ ,@(binds))
+ (declare (ignore ,@(vop-parse-ignores parse)))
+ ,@(loads)
+ (sb!assem:assemble (*code-segment* ,n-vop)
+ ,@(vop-parse-body parse))
+ ,@(saves))))))
+\f
+;;; Given a list of operand specifications as given to Define-VOP, return a
+;;; list of Operand-Parse structures describing the fixed operands, and a
+;;; single Operand-Parse describing any more operand. If we are inheriting a
+;;; VOP, we default attributes to the inherited operand of the same name.
+(defun parse-operands (parse specs kind)
+ (declare (list specs)
+ (type (member :argument :result) kind))
+ (let ((num -1)
+ (more nil))
+ (collect ((operands))
+ (dolist (spec specs)
+ (unless (and (consp spec) (symbolp (first spec)) (oddp (length spec)))
+ (error "malformed operand specifier: ~S" spec))
+ (when more
+ (error "The MORE operand isn't the last operand: ~S" specs))
+ (let* ((name (first spec))
+ (old (if (vop-parse-inherits parse)
+ (find-operand name
+ (vop-parse-or-lose
+ (vop-parse-inherits parse))
+ (list kind)
+ nil)
+ nil))
+ (res (if old
+ (make-operand-parse
+ :name name
+ :kind kind
+ :target (operand-parse-target old)
+ :born (operand-parse-born old)
+ :dies (operand-parse-dies old)
+ :scs (operand-parse-scs old)
+ :load-tn (operand-parse-load-tn old)
+ :load (operand-parse-load old))
+ (ecase kind
+ (:argument
+ (make-operand-parse
+ :name (first spec)
+ :kind :argument
+ :born (parse-time-spec :load)
+ :dies (parse-time-spec `(:argument ,(incf num)))))
+ (:result
+ (make-operand-parse
+ :name (first spec)
+ :kind :result
+ :born (parse-time-spec `(:result ,(incf num)))
+ :dies (parse-time-spec :save)))))))
+ (do ((key (rest spec) (cddr key)))
+ ((null key))
+ (let ((value (second key)))
+ (case (first key)
+ (:scs
+ (check-type value list)
+ (setf (operand-parse-scs res) (remove-duplicates value)))
+ (:load-tn
+ (check-type value symbol)
+ (setf (operand-parse-load-tn res) value))
+ (:load-if
+ (setf (operand-parse-load res) value))
+ (:more
+ (check-type value boolean)
+ (setf (operand-parse-kind res)
+ (if (eq kind :argument) :more-argument :more-result))
+ (setf (operand-parse-load res) nil)
+ (setq more res))
+ (:target
+ (check-type value symbol)
+ (setf (operand-parse-target res) value))
+ (:from
+ (unless (eq kind :result)
+ (error "can only specify :FROM in a result: ~S" spec))
+ (setf (operand-parse-born res) (parse-time-spec value)))
+ (:to
+ (unless (eq kind :argument)
+ (error "can only specify :TO in an argument: ~S" spec))
+ (setf (operand-parse-dies res) (parse-time-spec value)))
+ (t
+ (error "unknown keyword in operand specifier: ~S" spec)))))
+
+ (cond ((not more)
+ (operands res))
+ ((operand-parse-target more)
+ (error "cannot specify :TARGET in a :MORE operand"))
+ ((operand-parse-load more)
+ (error "cannot specify :LOAD-IF in a :MORE operand")))))
+ (values (the list (operands)) more))))
+\f
+;;; Parse a temporary specification, entering the Operand-Parse structures
+;;; in the Parse structure.
+(defun parse-temporary (spec parse)
+ (declare (list spec)
+ (type vop-parse parse))
+ (let ((len (length spec)))
+ (unless (>= len 2)
+ (error "malformed temporary spec: ~S" spec))
+ (unless (listp (second spec))
+ (error "malformed options list: ~S" (second spec)))
+ (unless (evenp (length (second spec)))
+ (error "odd number of arguments in keyword options: ~S" spec))
+ (unless (consp (cddr spec))
+ (warn "temporary spec allocates no temps:~% ~S" spec))
+ (dolist (name (cddr spec))
+ (unless (symbolp name)
+ (error "bad temporary name: ~S" name))
+ (let ((res (make-operand-parse :name name
+ :kind :temporary
+ :temp-temp (gensym)
+ :born (parse-time-spec :load)
+ :dies (parse-time-spec :save))))
+ (do ((opt (second spec) (cddr opt)))
+ ((null opt))
+ (case (first opt)
+ (:target
+ (setf (operand-parse-target res)
+ (vop-spec-arg opt 'symbol 1 nil)))
+ (:sc
+ (setf (operand-parse-sc res)
+ (vop-spec-arg opt 'symbol 1 nil)))
+ (:offset
+ (let ((offset (eval (second opt))))
+ (check-type offset unsigned-byte)
+ (setf (operand-parse-offset res) offset)))
+ (:from
+ (setf (operand-parse-born res) (parse-time-spec (second opt))))
+ (:to
+ (setf (operand-parse-dies res) (parse-time-spec (second opt))))
+ ;; Backward compatibility...
+ (:scs
+ (let ((scs (vop-spec-arg opt 'list 1 nil)))
+ (unless (= (length scs) 1)
+ (error "must specify exactly one SC for a temporary"))
+ (setf (operand-parse-sc res) (first scs))))
+ (:type)
+ (t
+ (error "unknown temporary option: ~S" opt))))
+
+ (unless (and (time-spec-order (operand-parse-dies res)
+ (operand-parse-born res))
+ (not (time-spec-order (operand-parse-born res)
+ (operand-parse-dies res))))
+ (error "Temporary lifetime doesn't begin before it ends: ~S" spec))
+
+ (unless (operand-parse-sc res)
+ (error "must specify :SC for all temporaries: ~S" spec))
+
+ (setf (vop-parse-temps parse)
+ (cons res
+ (remove name (vop-parse-temps parse)
+ :key #'operand-parse-name))))))
+ (values))
+\f
+;;; Top-level parse function. Clobber Parse to represent the specified options.
+(defun parse-define-vop (parse specs)
+ (declare (type vop-parse parse) (list specs))
+ (dolist (spec specs)
+ (unless (consp spec)
+ (error "malformed option specification: ~S" spec))
+ (case (first spec)
+ (:args
+ (multiple-value-bind (fixed more)
+ (parse-operands parse (rest spec) :argument)
+ (setf (vop-parse-args parse) fixed)
+ (setf (vop-parse-more-args parse) more)))
+ (:results
+ (multiple-value-bind (fixed more)
+ (parse-operands parse (rest spec) :result)
+ (setf (vop-parse-results parse) fixed)
+ (setf (vop-parse-more-results parse) more))
+ (setf (vop-parse-conditional-p parse) nil))
+ (:conditional
+ (setf (vop-parse-result-types parse) ())
+ (setf (vop-parse-results parse) ())
+ (setf (vop-parse-more-results parse) nil)
+ (setf (vop-parse-conditional-p parse) t))
+ (:temporary
+ (parse-temporary spec parse))
+ (:generator
+ (setf (vop-parse-cost parse)
+ (vop-spec-arg spec 'unsigned-byte 1 nil))
+ (setf (vop-parse-body parse) (cddr spec)))
+ (:effects
+ (setf (vop-parse-effects parse) (rest spec)))
+ (:affected
+ (setf (vop-parse-affected parse) (rest spec)))
+ (:info
+ (setf (vop-parse-info-args parse) (rest spec)))
+ (:ignore
+ (setf (vop-parse-ignores parse) (rest spec)))
+ (:variant
+ (setf (vop-parse-variant parse) (rest spec)))
+ (:variant-vars
+ (let ((vars (rest spec)))
+ (setf (vop-parse-variant-vars parse) vars)
+ (setf (vop-parse-variant parse)
+ (make-list (length vars) :initial-element nil))))
+ (:variant-cost
+ (setf (vop-parse-cost parse) (vop-spec-arg spec 'unsigned-byte)))
+ (:vop-var
+ (setf (vop-parse-vop-var parse) (vop-spec-arg spec 'symbol)))
+ (:move-args
+ (setf (vop-parse-move-args parse)
+ (vop-spec-arg spec '(member nil :local-call :full-call
+ :known-return))))
+ (:node-var
+ (setf (vop-parse-node-var parse) (vop-spec-arg spec 'symbol)))
+ (:note
+ (setf (vop-parse-note parse) (vop-spec-arg spec '(or string null))))
+ (:arg-types
+ (setf (vop-parse-arg-types parse)
+ (parse-operand-types (rest spec) t)))
+ (:result-types
+ (setf (vop-parse-result-types parse)
+ (parse-operand-types (rest spec) nil)))
+ (:translate
+ (setf (vop-parse-translate parse) (rest spec)))
+ (:guard
+ (setf (vop-parse-guard parse) (vop-spec-arg spec t)))
+ (:policy
+ (setf (vop-parse-policy parse) (vop-spec-arg spec 'policies)))
+ (:save-p
+ (setf (vop-parse-save-p parse)
+ (vop-spec-arg spec
+ '(member t nil :compute-only :force-to-stack))))
+ (t
+ (error "unknown option specifier: ~S" (first spec)))))
+ (values))
+\f
+;;;; make costs and restrictions
+
+;;; Given an operand, returns two values:
+;;; 1. A SC-vector of the cost for the operand being in that SC, including both
+;;; the costs for move functions and coercion VOPs.
+;;; 2. A SC-vector holding the SC that we load into, for any SC that we can
+;;; directly load from.
+;;;
+;;; In both vectors, unused entries are NIL. Load-P specifies the direction:
+;;; if true, we are loading, if false we are saving.
+(defun compute-loading-costs (op load-p)
+ (declare (type operand-parse op))
+ (let ((scs (operand-parse-scs op))
+ (costs (make-array sc-number-limit :initial-element nil))
+ (load-scs (make-array sc-number-limit :initial-element nil)))
+ (dolist (sc-name scs)
+ (let* ((load-sc (meta-sc-or-lose sc-name))
+ (load-scn (sc-number load-sc)))
+ (setf (svref costs load-scn) 0)
+ (setf (svref load-scs load-scn) t)
+ (dolist (op-sc (append (when load-p
+ (sc-constant-scs load-sc))
+ (sc-alternate-scs load-sc)))
+ (let* ((op-scn (sc-number op-sc))
+ (load (if load-p
+ (aref (sc-load-costs load-sc) op-scn)
+ (aref (sc-load-costs op-sc) load-scn))))
+ (unless load
+ (error "no move function defined to move ~:[from~;to~] SC ~
+ ~S~%~:[to~;from~] alternate or constant SC ~S"
+ load-p sc-name load-p (sc-name op-sc)))
+
+ (let ((op-cost (svref costs op-scn)))
+ (when (or (not op-cost) (< load op-cost))
+ (setf (svref costs op-scn) load)))
+
+ (let ((op-load (svref load-scs op-scn)))
+ (unless (eq op-load t)
+ (pushnew load-scn (svref load-scs op-scn))))))
+
+ (dotimes (i sc-number-limit)
+ (unless (svref costs i)
+ (let ((op-sc (svref *backend-meta-sc-numbers* i)))
+ (when op-sc
+ (let ((cost (if load-p
+ (svref (sc-move-costs load-sc) i)
+ (svref (sc-move-costs op-sc) load-scn))))
+ (when cost
+ (setf (svref costs i) cost)))))))))
+
+ (values costs load-scs)))
+
+(defparameter *no-costs*
+ (make-array sc-number-limit :initial-element 0))
+
+(defparameter *no-loads*
+ (make-array sc-number-limit :initial-element 't))
+
+;;; Pick off the case of operands with no restrictions.
+(defun compute-loading-costs-if-any (op load-p)
+ (declare (type operand-parse op))
+ (if (operand-parse-scs op)
+ (compute-loading-costs op load-p)
+ (values *no-costs* *no-loads*)))
+
+(defun compute-costs-and-restrictions-list (ops load-p)
+ (declare (list ops))
+ (collect ((costs)
+ (scs))
+ (dolist (op ops)
+ (multiple-value-bind (costs scs) (compute-loading-costs-if-any op load-p)
+ (costs costs)
+ (scs scs)))
+ (values (costs) (scs))))
+
+(defun make-costs-and-restrictions (parse)
+ (multiple-value-bind (arg-costs arg-scs)
+ (compute-costs-and-restrictions-list (vop-parse-args parse) t)
+ (multiple-value-bind (result-costs result-scs)
+ (compute-costs-and-restrictions-list (vop-parse-results parse) nil)
+ `(
+ :cost ,(vop-parse-cost parse)
+
+ :arg-costs ',arg-costs
+ :arg-load-scs ',arg-scs
+ :result-costs ',result-costs
+ :result-load-scs ',result-scs
+
+ :more-arg-costs
+ ',(if (vop-parse-more-args parse)
+ (compute-loading-costs-if-any (vop-parse-more-args parse) t)
+ nil)
+
+ :more-result-costs
+ ',(if (vop-parse-more-results parse)
+ (compute-loading-costs-if-any (vop-parse-more-results parse) nil)
+ nil)))))
+\f
+;;;; operand checking and stuff
+
+;;; Given a list of arg/result restrictions, check for valid syntax and
+;;; convert to canonical form.
+(defun parse-operand-types (specs args-p)
+ (declare (list specs))
+ (labels ((parse-operand-type (spec)
+ (cond ((eq spec '*) spec)
+ ((symbolp spec)
+ (let ((alias (gethash spec
+ *backend-primitive-type-aliases*)))
+ (if alias
+ (parse-operand-type alias)
+ `(:or ,spec))))
+ ((atom spec)
+ (error "bad thing to be a operand type: ~S" spec))
+ (t
+ (case (first spec)
+ (:or
+ (collect ((results))
+ (results :or)
+ (dolist (item (cdr spec))
+ (unless (symbolp item)
+ (error "bad PRIMITIVE-TYPE name in ~S: ~S"
+ spec item))
+ (let ((alias
+ (gethash item
+ *backend-primitive-type-aliases*)))
+ (if alias
+ (let ((alias (parse-operand-type alias)))
+ (unless (eq (car alias) :or)
+ (error "can't include primitive-type ~
+ alias ~S in an :OR restriction: ~S"
+ item spec))
+ (dolist (x (cdr alias))
+ (results x)))
+ (results item))))
+ (remove-duplicates (results)
+ :test #'eq
+ :start 1)))
+ (:constant
+ (unless args-p
+ (error "can't :CONSTANT for a result"))
+ (unless (= (length spec) 2)
+ (error "bad :CONSTANT argument type spec: ~S" spec))
+ spec)
+ (t
+ (error "bad thing to be a operand type: ~S" spec)))))))
+ (mapcar #'parse-operand-type specs)))
+
+;;; Check the consistency of Op's Sc restrictions with the specified
+;;; primitive-type restriction. :CONSTANT operands have already been filtered
+;;; out, so only :OR and * restrictions are left.
+;;;
+;;; We check that every representation allowed by the type can be directly
+;;; loaded into some SC in the restriction, and that the type allows every SC
+;;; in the restriction. With *, we require that T satisfy the first test, and
+;;; omit the second.
+(defun check-operand-type-scs (parse op type load-p)
+ (declare (type vop-parse parse) (type operand-parse op))
+ (let ((ptypes (if (eq type '*) (list 't) (rest type)))
+ (scs (operand-parse-scs op)))
+ (when scs
+ (multiple-value-bind (costs load-scs) (compute-loading-costs op load-p)
+ (declare (ignore costs))
+ (dolist (ptype ptypes)
+ (unless (dolist (rep (primitive-type-scs
+ (meta-primitive-type-or-lose ptype))
+ nil)
+ (when (svref load-scs rep) (return t)))
+ (error "In the ~A ~:[result~;argument~] to VOP ~S,~@
+ none of the SCs allowed by the operand type ~S can ~
+ directly be loaded~@
+ into any of the restriction's SCs:~% ~S~:[~;~@
+ [* type operand must allow T's SCs.]~]"
+ (operand-parse-name op) load-p (vop-parse-name parse)
+ ptype
+ scs (eq type '*)))))
+
+ (dolist (sc scs)
+ (unless (or (eq type '*)
+ (dolist (ptype ptypes nil)
+ (when (meta-sc-allowed-by-primitive-type
+ (meta-sc-or-lose sc)
+ (meta-primitive-type-or-lose ptype))
+ (return t))))
+ (warn "~:[Result~;Argument~] ~A to VOP ~S~@
+ has SC restriction ~S which is ~
+ not allowed by the operand type:~% ~S"
+ load-p (operand-parse-name op) (vop-parse-name parse)
+ sc type)))))
+
+ (values))
+
+;;; If the operand types are specified, then check the number specified
+;;; against the number of defined operands.
+(defun check-operand-types (parse ops more-op types load-p)
+ (declare (type vop-parse parse) (list ops)
+ (type (or list (member :unspecified)) types)
+ (type (or operand-parse null) more-op))
+ (unless (eq types :unspecified)
+ (let ((num (+ (length ops) (if more-op 1 0))))
+ (unless (= (count-if-not #'(lambda (x)
+ (and (consp x)
+ (eq (car x) :constant)))
+ types)
+ num)
+ (error "expected ~D ~:[result~;argument~] type~P: ~S"
+ num load-p types num)))
+
+ (when more-op
+ (let ((mtype (car (last types))))
+ (when (and (consp mtype) (eq (first mtype) :constant))
+ (error "can't use :CONSTANT on VOP more args")))))
+
+ (when (vop-parse-translate parse)
+ (let ((types (specify-operand-types types ops more-op)))
+ (mapc #'(lambda (x y)
+ (check-operand-type-scs parse x y load-p))
+ (if more-op (butlast ops) ops)
+ (remove-if #'(lambda (x)
+ (and (consp x)
+ (eq (car x) ':constant)))
+ (if more-op (butlast types) types)))))
+
+ (values))
+
+;;; Compute stuff that can only be computed after we are done parsing
+;;; everying. We set the VOP-Parse-Operands, and do various error checks.
+(defun grovel-operands (parse)
+ (declare (type vop-parse parse))
+
+ (setf (vop-parse-operands parse)
+ (append (vop-parse-args parse)
+ (if (vop-parse-more-args parse)
+ (list (vop-parse-more-args parse)))
+ (vop-parse-results parse)
+ (if (vop-parse-more-results parse)
+ (list (vop-parse-more-results parse)))
+ (vop-parse-temps parse)))
+
+ (check-operand-types parse
+ (vop-parse-args parse)
+ (vop-parse-more-args parse)
+ (vop-parse-arg-types parse)
+ t)
+
+ (check-operand-types parse
+ (vop-parse-results parse)
+ (vop-parse-more-results parse)
+ (vop-parse-result-types parse)
+ nil)
+
+ (values))
+\f
+;;;; function translation stuff
+
+;;; Return forms to establish this VOP as a IR2 translation template for the
+;;; :Translate functions specified in the VOP-Parse. We also set the
+;;; Predicate attribute for each translated function when the VOP is
+;;; conditional, causing IR1 conversion to ensure that a call to the translated
+;;; is always used in a predicate position.
+(defun set-up-function-translation (parse n-template)
+ (declare (type vop-parse parse))
+ (mapcar #'(lambda (name)
+ `(let ((info (function-info-or-lose ',name)))
+ (setf (function-info-templates info)
+ (adjoin-template ,n-template
+ (function-info-templates info)))
+ ,@(when (vop-parse-conditional-p parse)
+ '((setf (function-info-attributes info)
+ (attributes-union
+ (ir1-attributes predicate)
+ (function-info-attributes info)))))))
+ (vop-parse-translate parse)))
+
+;;; Return a form that can be evaluated to get the TEMPLATE operand type
+;;; restriction from the given specification.
+(defun make-operand-type (type)
+ (cond ((eq type '*) ''*)
+ ((symbolp type)
+ ``(:or ,(primitive-type-or-lose ',type)))
+ (t
+ (ecase (first type)
+ (:or
+ ``(:or ,,@(mapcar #'(lambda (type)
+ `(primitive-type-or-lose ',type))
+ (rest type))))
+ (:constant
+ ``(:constant ,#'(lambda (x)
+ (typep x ',(second type)))
+ ,',(second type)))))))
+
+(defun specify-operand-types (types ops more-ops)
+ (if (eq types :unspecified)
+ (make-list (+ (length ops) (if more-ops 1 0)) :initial-element '*)
+ types))
+
+;;; Return a list of forms to use as keyword args to Make-VOP-Info for
+;;; setting up the template argument and result types. Here we make an initial
+;;; dummy Template-Type, since it is awkward to compute the type until the
+;;; template has been made.
+(defun make-vop-info-types (parse)
+ (let* ((more-args (vop-parse-more-args parse))
+ (all-args (specify-operand-types (vop-parse-arg-types parse)
+ (vop-parse-args parse)
+ more-args))
+ (args (if more-args (butlast all-args) all-args))
+ (more-arg (when more-args (car (last all-args))))
+ (more-results (vop-parse-more-results parse))
+ (all-results (specify-operand-types (vop-parse-result-types parse)
+ (vop-parse-results parse)
+ more-results))
+ (results (if more-results (butlast all-results) all-results))
+ (more-result (when more-results (car (last all-results))))
+ (conditional (vop-parse-conditional-p parse)))
+
+ `(
+ :type (specifier-type '(function () nil))
+ :arg-types (list ,@(mapcar #'make-operand-type args))
+ :more-args-type ,(when more-args (make-operand-type more-arg))
+ :result-types ,(if conditional
+ :conditional
+ `(list ,@(mapcar #'make-operand-type results)))
+ :more-results-type ,(when more-results
+ (make-operand-type more-result)))))
+\f
+;;;; setting up VOP-INFO
+
+(defconstant slot-inherit-alist
+ '((:generator-function . vop-info-generator-function)))
+
+;;; Something to help with inheriting VOP-Info slots. We return a
+;;; keyword/value pair that can be passed to the constructor. Slot is the
+;;; keyword name of the slot, Parse is a form that evaluates to the VOP-Parse
+;;; structure for the VOP inherited. If Parse is NIL, then we do nothing. If
+;;; the Test form evaluates to true, then we return a form that selects the
+;;; named slot from the VOP-Info structure corresponding to Parse. Otherwise,
+;;; we return the Form so that the slot is recomputed.
+(defmacro inherit-vop-info (slot parse test form)
+ `(if (and ,parse ,test)
+ (list ,slot `(,',(or (cdr (assoc slot slot-inherit-alist))
+ (error "unknown slot ~S" slot))
+ (template-or-lose ',(vop-parse-name ,parse))))
+ (list ,slot ,form)))
+
+;;; Return a form that creates a VOP-Info structure which describes VOP.
+(defun set-up-vop-info (iparse parse)
+ (declare (type vop-parse parse) (type (or vop-parse null) iparse))
+ (let ((same-operands
+ (and iparse
+ (equal (vop-parse-operands parse)
+ (vop-parse-operands iparse))
+ (equal (vop-parse-info-args iparse)
+ (vop-parse-info-args parse))))
+ (variant (vop-parse-variant parse)))
+
+ (let ((nvars (length (vop-parse-variant-vars parse))))
+ (unless (= (length variant) nvars)
+ (error "expected ~D variant values: ~S" nvars variant)))
+
+ `(make-vop-info
+ :name ',(vop-parse-name parse)
+ ,@(make-vop-info-types parse)
+ :guard ,(when (vop-parse-guard parse)
+ `#'(lambda () ,(vop-parse-guard parse)))
+ :note ',(vop-parse-note parse)
+ :info-arg-count ,(length (vop-parse-info-args parse))
+ :policy ',(vop-parse-policy parse)
+ :save-p ',(vop-parse-save-p parse)
+ :move-args ',(vop-parse-move-args parse)
+ :effects (vop-attributes ,@(vop-parse-effects parse))
+ :affected (vop-attributes ,@(vop-parse-affected parse))
+ ,@(make-costs-and-restrictions parse)
+ ,@(make-emit-function-and-friends parse)
+ ,@(inherit-vop-info :generator-function iparse
+ (and same-operands
+ (equal (vop-parse-body parse) (vop-parse-body iparse)))
+ (unless (eq (vop-parse-body parse) :unspecified)
+ (make-generator-function parse)))
+ :variant (list ,@variant))))
+\f
+;;; Parse the syntax into a VOP-Parse structure, and then expand into code
+;;; that creates the appropriate VOP-Info structure at load time. We implement
+;;; inheritance by copying the VOP-Parse structure for the inherited structure.
+(def!macro define-vop ((name &optional inherits) &rest specs)
+ #!+sb-doc
+ "Define-VOP (Name [Inherits]) Spec*
+ Define the symbol Name to be a Virtual OPeration in the compiler. If
+ specified, Inherits is the name of a VOP that we default unspecified
+ information from. Each Spec is a list beginning with a keyword indicating
+ the interpretation of the other forms in the Spec:
+
+ :Args {(Name {Key Value}*)}*
+ :Results {(Name {Key Value}*)}*
+ The Args and Results are specifications of the operand TNs passed to the
+ VOP. If there is an inherited VOP, any unspecified options are defaulted
+ from the inherited argument (or result) of the same name. The following
+ operand options are defined:
+
+ :SCs (SC*)
+ :SCs specifies good SCs for this operand. Other SCs will be
+ penalized according to move costs. A load TN will be allocated if
+ necessary, guaranteeing that the operand is always one of the
+ specified SCs.
+
+ :Load-TN Load-Name
+ Load-Name is bound to the load TN allocated for this operand, or to
+ NIL if no load TN was allocated.
+
+ :Load-If Expression
+ Controls whether automatic operand loading is done. Expression is
+ evaluated with the fixed operand TNs bound. If Expression is true,
+ then loading is done and the variable is bound to the load TN in
+ the generator body. Otherwise, loading is not done, and the variable
+ is bound to the actual operand.
+
+ :More T-or-NIL
+ If specified, Name is bound to the TN-Ref for the first argument or
+ result following the fixed arguments or results. A more operand must
+ appear last, and cannot be targeted or restricted.
+
+ :Target Operand
+ This operand is targeted to the named operand, indicating a desire to
+ pack in the same location. Not legal for results.
+
+ :From Time-Spec
+ :To Time-Spec
+ Specify the beginning or end of the operand's lifetime. :From can
+ only be used with results, and :To only with arguments. The default
+ for the N'th argument/result is (:ARGUMENT N)/(:RESULT N). These
+ options are necessary primarily when operands are read or written out
+ of order.
+
+ :Conditional
+ This is used in place of :RESULTS with conditional branch VOPs. There
+ are no result values: the result is a transfer of control. The target
+ label is passed as the first :INFO arg. The second :INFO arg is true if
+ the sense of the test should be negated. A side-effect is to set the
+ PREDICATE attribute for functions in the :TRANSLATE option.
+
+ :Temporary ({Key Value}*) Name*
+ Allocate a temporary TN for each Name, binding that variable to the TN
+ within the body of the generators. In addition to :Target (which is
+ is the same as for operands), the following options are
+ defined:
+
+ :SC SC-Name
+ :Offset SB-Offset
+ Force the temporary to be allocated in the specified SC with the
+ specified offset. Offset is evaluated at macroexpand time. If
+ Offset is emitted, the register allocator chooses a free location in
+ SC. If both SC and Offset are omitted, then the temporary is packed
+ according to its primitive type.
+
+ :From Time-Spec
+ :To Time-Spec
+ Similar to the argument/result option, this specifies the start and
+ end of the temporaries' lives. The defaults are :Load and :Save,
+ i.e. the duration of the VOP. The other intervening phases are
+ :Argument,:Eval and :Result. Non-zero sub-phases can be specified
+ by a list, e.g. by default the second argument's life ends at
+ (:Argument 1).
+
+ :Generator Cost Form*
+ Specifies the translation into assembly code. Cost is the estimated cost
+ of the code emitted by this generator. The body is arbitrary Lisp code
+ that emits the assembly language translation of the VOP. An Assemble
+ form is wrapped around the body, so code may be emitted by using the
+ local Inst macro. During the evaluation of the body, the names of the
+ operands and temporaries are bound to the actual TNs.
+
+ :Effects Effect*
+ :Affected Effect*
+ Specifies the side effects that this VOP has and the side effects that
+ effect its execution. If unspecified, these default to the worst case.
+
+ :Info Name*
+ Define some magic arguments that are passed directly to the code
+ generator. The corresponding trailing arguments to VOP or %Primitive are
+ stored in the VOP structure. Within the body of the generators, the
+ named variables are bound to these values. Except in the case of
+ :Conditional VOPs, :Info arguments cannot be specified for VOPS that are
+ the direct translation for a function (specified by :Translate).
+
+ :Ignore Name*
+ Causes the named variables to be declared IGNORE in the generator body.
+
+ :Variant Thing*
+ :Variant-Vars Name*
+ These options provide a way to parameterize families of VOPs that differ
+ only trivially. :Variant makes the specified evaluated Things be the
+ \"variant\" associated with this VOP. :Variant-Vars causes the named
+ variables to be bound to the corresponding Things within the body of the
+ generator.
+
+ :Variant-Cost Cost
+ Specifies the cost of this VOP, overriding the cost of any inherited
+ generator.
+
+ :Note {String | NIL}
+ A short noun-like phrase describing what this VOP \"does\", i.e. the
+ implementation strategy. If supplied, efficency notes will be generated
+ when type uncertainty prevents :TRANSLATE from working. NIL inhibits any
+ efficency note.
+
+ :Arg-Types {* | PType | (:OR PType*) | (:CONSTANT Type)}*
+ :Result-Types {* | PType | (:OR PType*)}*
+ Specify the template type restrictions used for automatic translation.
+ If there is a :More operand, the last type is the more type. :CONSTANT
+ specifies that the argument must be a compile-time constant of the
+ specified Lisp type. The constant values of :CONSTANT arguments are
+ passed as additional :INFO arguments rather than as :ARGS.
+
+ :Translate Name*
+ This option causes the VOP template to be entered as an IR2 translation
+ for the named functions.
+
+ :Policy {:Small | :Fast | :Safe | :Fast-Safe}
+ Specifies the policy under which this VOP is the best translation.
+
+ :Guard Form
+ Specifies a Form that is evaluated in the global environment. If
+ form returns NIL, then emission of this VOP is prohibited even when
+ all other restrictions are met.
+
+ :VOP-Var Name
+ :Node-Var Name
+ In the generator, bind the specified variable to the VOP or the Node that
+ generated this VOP.
+
+ :Save-P {NIL | T | :Compute-Only | :Force-To-Stack}
+ Indicates how a VOP wants live registers saved.
+
+ :Move-Args {NIL | :Full-Call | :Local-Call | :Known-Return}
+ Indicates if and how the more args should be moved into a different
+ frame."
+ (check-type name symbol)
+
+ (let* ((iparse (when inherits
+ (vop-parse-or-lose inherits)))
+ (parse (if inherits
+ (copy-vop-parse iparse)
+ (make-vop-parse)))
+ (n-res (gensym)))
+ (setf (vop-parse-name parse) name)
+ (setf (vop-parse-inherits parse) inherits)
+
+ (parse-define-vop parse specs)
+ (grovel-operands parse)
+
+ `(progn
+ (eval-when (:compile-toplevel :load-toplevel :execute)
+ (setf (gethash ',name *backend-parsed-vops*)
+ ',parse))
+
+ (let ((,n-res ,(set-up-vop-info iparse parse)))
+ (setf (gethash ',name *backend-template-names*) ,n-res)
+ (setf (template-type ,n-res)
+ (specifier-type (template-type-specifier ,n-res)))
+ ,@(set-up-function-translation parse n-res))
+ ',name)))
+\f
+;;;; emission macros
+
+;;; Return code to make a list of VOP arguments or results, linked by
+;;; TN-Ref-Across. The first value is code, the second value is LET* forms,
+;;; and the third value is a variable that evaluates to the head of the list,
+;;; or NIL if there are no operands. Fixed is a list of forms that evaluate to
+;;; TNs for the fixed operands. TN-Refs will be made for these operands
+;;; according using the specified value of Write-P. More is an expression that
+;;; evaluates to a list of TN-Refs that will be made the tail of the list. If
+;;; it is constant NIL, then we don't bother to set the tail.
+(defun make-operand-list (fixed more write-p)
+ (collect ((forms)
+ (binds))
+ (let ((n-head nil)
+ (n-prev nil))
+ (dolist (op fixed)
+ (let ((n-ref (gensym)))
+ (binds `(,n-ref (reference-tn ,op ,write-p)))
+ (if n-prev
+ (forms `(setf (tn-ref-across ,n-prev) ,n-ref))
+ (setq n-head n-ref))
+ (setq n-prev n-ref)))
+
+ (when more
+ (let ((n-more (gensym)))
+ (binds `(,n-more ,more))
+ (if n-prev
+ (forms `(setf (tn-ref-across ,n-prev) ,n-more))
+ (setq n-head n-more))))
+
+ (values (forms) (binds) n-head))))
+
+(defmacro emit-template (node block template args results &optional info)
+ #!+sb-doc
+ "Emit-Template Node Block Template Args Results [Info]
+ Call the emit function for Template, linking the result in at the end of
+ Block."
+ (let ((n-first (gensym))
+ (n-last (gensym)))
+ (once-only ((n-node node)
+ (n-block block)
+ (n-template template))
+ `(multiple-value-bind (,n-first ,n-last)
+ (funcall (template-emit-function ,n-template)
+ ,n-node ,n-block ,n-template ,args ,results
+ ,@(when info `(,info)))
+ (insert-vop-sequence ,n-first ,n-last ,n-block nil)))))
+
+(defmacro vop (name node block &rest operands)
+ #!+sb-doc
+ "VOP Name Node Block Arg* Info* Result*
+ Emit the VOP (or other template) Name at the end of the IR2-Block Block,
+ using Node for the source context. The interpretation of the remaining
+ arguments depends on the number of operands of various kinds that are
+ declared in the template definition. VOP cannot be used for templates that
+ have more-args or more-results, since the number of arguments and results is
+ indeterminate for these templates. Use VOP* instead.
+
+ Args and Results are the TNs that are to be referenced by the template
+ as arguments and results. If the template has codegen-info arguments, then
+ the appropriate number of Info forms following the Arguments are used for
+ codegen info."
+ (let* ((parse (vop-parse-or-lose name))
+ (arg-count (length (vop-parse-args parse)))
+ (result-count (length (vop-parse-results parse)))
+ (info-count (length (vop-parse-info-args parse)))
+ (noperands (+ arg-count result-count info-count))
+ (n-node (gensym))
+ (n-block (gensym))
+ (n-template (gensym)))
+
+ (when (or (vop-parse-more-args parse) (vop-parse-more-results parse))
+ (error "cannot use VOP with variable operand count templates"))
+ (unless (= noperands (length operands))
+ (error "called with ~D operands, but was expecting ~D"
+ (length operands) noperands))
+
+ (multiple-value-bind (acode abinds n-args)
+ (make-operand-list (subseq operands 0 arg-count) nil nil)
+ (multiple-value-bind (rcode rbinds n-results)
+ (make-operand-list (subseq operands (+ arg-count info-count)) nil t)
+
+ (collect ((ibinds)
+ (ivars))
+ (dolist (info (subseq operands arg-count (+ arg-count info-count)))
+ (let ((temp (gensym)))
+ (ibinds `(,temp ,info))
+ (ivars temp)))
+
+ `(let* ((,n-node ,node)
+ (,n-block ,block)
+ (,n-template (template-or-lose ',name))
+ ,@abinds
+ ,@(ibinds)
+ ,@rbinds)
+ ,@acode
+ ,@rcode
+ (emit-template ,n-node ,n-block ,n-template ,n-args
+ ,n-results
+ ,@(when (ivars)
+ `((list ,@(ivars)))))
+ (values)))))))
+
+(defmacro vop* (name node block args results &rest info)
+ #!+sb-doc
+ "VOP* Name Node Block (Arg* More-Args) (Result* More-Results) Info*
+ Like VOP, but allows for emission of templates with arbitrary numbers of
+ arguments, and for emission of templates using already-created TN-Ref lists.
+
+ The Arguments and Results are TNs to be referenced as the first arguments
+ and results to the template. More-Args and More-Results are heads of TN-Ref
+ lists that are added onto the end of the TN-Refs for the explicitly supplied
+ operand TNs. The TN-Refs for the more operands must have the TN and Write-P
+ slots correctly initialized.
+
+ As with VOP, the Info forms are evaluated and passed as codegen info
+ arguments."
+ (check-type args cons)
+ (check-type results cons)
+ (let* ((parse (vop-parse-or-lose name))
+ (arg-count (length (vop-parse-args parse)))
+ (result-count (length (vop-parse-results parse)))
+ (info-count (length (vop-parse-info-args parse)))
+ (fixed-args (butlast args))
+ (fixed-results (butlast results))
+ (n-node (gensym))
+ (n-block (gensym))
+ (n-template (gensym)))
+
+ (unless (or (vop-parse-more-args parse)
+ (<= (length fixed-args) arg-count))
+ (error "too many fixed arguments"))
+ (unless (or (vop-parse-more-results parse)
+ (<= (length fixed-results) result-count))
+ (error "too many fixed results"))
+ (unless (= (length info) info-count)
+ (error "expected ~D info args" info-count))
+
+ (multiple-value-bind (acode abinds n-args)
+ (make-operand-list fixed-args (car (last args)) nil)
+ (multiple-value-bind (rcode rbinds n-results)
+ (make-operand-list fixed-results (car (last results)) t)
+
+ `(let* ((,n-node ,node)
+ (,n-block ,block)
+ (,n-template (template-or-lose ',name))
+ ,@abinds
+ ,@rbinds)
+ ,@acode
+ ,@rcode
+ (emit-template ,n-node ,n-block ,n-template ,n-args ,n-results
+ ,@(when info
+ `((list ,@info))))
+ (values))))))
+\f
+;;;; miscellaneous macros
+
+(def!macro sc-case (tn &rest forms)
+ #!+sb-doc
+ "SC-Case TN {({(SC-Name*) | SC-Name | T} Form*)}*
+ Case off of TN's SC. The first clause containing TN's SC is evaluated,
+ returning the values of the last form. A clause beginning with T specifies a
+ default. If it appears, it must be last. If no default is specified, and no
+ clause matches, then an error is signalled."
+ (let ((n-sc (gensym))
+ (n-tn (gensym)))
+ (collect ((clauses))
+ (do ((cases forms (rest cases)))
+ ((null cases)
+ (clauses `(t (error "unknown SC to SC-Case for ~S:~% ~S" ,n-tn
+ (sc-name (tn-sc ,n-tn))))))
+ (let ((case (first cases)))
+ (when (atom case)
+ (error "illegal SC-Case clause: ~S" case))
+ (let ((head (first case)))
+ (when (eq head t)
+ (when (rest cases)
+ (error "T case is not last in SC-Case."))
+ (clauses `(t nil ,@(rest case)))
+ (return))
+ (clauses `((or ,@(mapcar #'(lambda (x)
+ `(eql ,(meta-sc-number-or-lose x)
+ ,n-sc))
+ (if (atom head) (list head) head)))
+ nil ,@(rest case))))))
+
+ `(let* ((,n-tn ,tn)
+ (,n-sc (sc-number (tn-sc ,n-tn))))
+ (cond ,@(clauses))))))
+
+(defmacro sc-is (tn &rest scs)
+ #!+sb-doc
+ "SC-Is TN SC*
+ Returns true if TNs SC is any of the named SCs, false otherwise."
+ (once-only ((n-sc `(sc-number (tn-sc ,tn))))
+ `(or ,@(mapcar #'(lambda (x)
+ `(eql ,n-sc ,(meta-sc-number-or-lose x)))
+ scs))))
+
+(defmacro do-ir2-blocks ((block-var component &optional result)
+ &body forms)
+ #!+sb-doc
+ "Do-IR2-Blocks (Block-Var Component [Result]) Form*
+ Iterate over the IR2 blocks in component, in emission order."
+ `(do ((,block-var (block-info (component-head ,component))
+ (ir2-block-next ,block-var)))
+ ((null ,block-var) ,result)
+ ,@forms))
+
+(defmacro do-live-tns ((tn-var live block &optional result) &body body)
+ #!+sb-doc
+ "DO-LIVE-TNS (TN-Var Live Block [Result]) Form*
+ Iterate over all the TNs live at some point, with the live set represented by
+ a local conflicts bit-vector and the IR2-Block containing the location."
+ (let ((n-conf (gensym))
+ (n-bod (gensym))
+ (i (gensym))
+ (ltns (gensym)))
+ (once-only ((n-live live)
+ (n-block block))
+ `(block nil
+ (flet ((,n-bod (,tn-var) ,@body))
+ ;; Do component-live TNs.
+ (dolist (,tn-var (ir2-component-component-tns
+ (component-info
+ (block-component
+ (ir2-block-block ,n-block)))))
+ (,n-bod ,tn-var))
+
+ (let ((,ltns (ir2-block-local-tns ,n-block)))
+ ;; Do TNs always-live in this block and live :More TNs.
+ (do ((,n-conf (ir2-block-global-tns ,n-block)
+ (global-conflicts-next ,n-conf)))
+ ((null ,n-conf))
+ (when (or (eq (global-conflicts-kind ,n-conf) :live)
+ (let ((,i (global-conflicts-number ,n-conf)))
+ (and (eq (svref ,ltns ,i) :more)
+ (not (zerop (sbit ,n-live ,i))))))
+ (,n-bod (global-conflicts-tn ,n-conf))))
+ ;; Do TNs locally live in the designated live set.
+ (dotimes (,i (ir2-block-local-tn-count ,n-block) ,result)
+ (unless (zerop (sbit ,n-live ,i))
+ (let ((,tn-var (svref ,ltns ,i)))
+ (when (and ,tn-var (not (eq ,tn-var :more)))
+ (,n-bod ,tn-var)))))))))))
+
+(defmacro do-environment-ir2-blocks ((block-var env &optional result)
+ &body body)
+ #!+sb-doc
+ "DO-ENVIRONMENT-IR2-BLOCKS (Block-Var Env [Result]) Form*
+ Iterate over all the IR2 blocks in the environment Env, in emit order."
+ (once-only ((n-env env))
+ (once-only ((n-first `(node-block
+ (lambda-bind
+ (environment-function ,n-env)))))
+ (once-only ((n-tail `(block-info
+ (component-tail
+ (block-component ,n-first)))))
+ `(do ((,block-var (block-info ,n-first)
+ (ir2-block-next ,block-var)))
+ ((or (eq ,block-var ,n-tail)
+ (not (eq (ir2-block-environment ,block-var) ,n-env)))
+ ,result)
+ ,@body)))))
--- /dev/null
+;;;; structures for the first intermediate representation in the
+;;;; compiler, IR1
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!C")
+
+(file-comment
+ "$Header$")
+
+;;; The front-end data structure (IR1) is composed of nodes and
+;;; continuations. The general idea is that continuations contain
+;;; top-down information and nodes contain bottom-up, derived
+;;; information. A continuation represents a place in the code, while
+;;; a node represents code that does something.
+;;;
+;;; This representation is more of a flow-graph than an augmented
+;;; syntax tree. The evaluation order is explicitly represented in the
+;;; linkage by continuations, rather than being implicit in the nodes
+;;; which receive the the results of evaluation. This allows us to
+;;; decouple the flow of results from the flow of control. A
+;;; continuation represents both, but the continuation can represent
+;;; the case of a discarded result by having no DEST.
+
+(def!struct (continuation
+ (:make-load-form-fun ignore-it)
+ (:constructor make-continuation (&optional dest)))
+ ;; An indication of the way that this continuation is currently used:
+ ;;
+ ;; :UNUSED
+ ;; A continuation for which all control-related slots have the default
+ ;; values. A continuation is unused during IR1 conversion until it is
+ ;; assigned a block, and may be also be temporarily unused during
+ ;; later manipulations of IR1. In a consistent state there should
+ ;; never be any mention of :UNUSED continuations. Next can have a
+ ;; non-null value if the next node has already been determined.
+ ;;
+ ;; :DELETED
+ ;; A continuation that has been deleted from IR1. Any pointers into
+ ;; IR1 are cleared. There are two conditions under which a deleted
+ ;; continuation may appear in code:
+ ;; -- The CONT of the LAST node in a block may be a deleted
+ ;; continuation when the original receiver of the continuation's
+ ;; value was deleted. Note that DEST in a deleted continuation is
+ ;; null, so it is easy to know not to attempt delivering any
+ ;; values to the continuation.
+ ;; -- Unreachable code that hasn't been deleted yet may receive
+ ;; deleted continuations. All such code will be in blocks that
+ ;; have DELETE-P set. All unreachable code is deleted by control
+ ;; optimization, so the backend doesn't have to worry about this.
+ ;;
+ ;; :BLOCK-START
+ ;; The continuation that is the START of BLOCK. This is the only kind
+ ;; of continuation that can have more than one use. The BLOCK's
+ ;; START-USES is a list of all the uses.
+ ;;
+ ;; :DELETED-BLOCK-START
+ ;; Like :BLOCK-START, but BLOCK has been deleted. A block starting
+ ;; continuation is made into a deleted block start when the block is
+ ;; deleted, but the continuation still may have value semantics.
+ ;; Since there isn't any code left, next is null.
+ ;;
+ ;; :INSIDE-BLOCK
+ ;; A continuation that is the CONT of some node in BLOCK.
+ (kind :unused :type (member :unused :deleted :inside-block :block-start
+ :deleted-block-start))
+ ;; The node which receives this value, if any. In a deleted continuation,
+ ;; this is null even though the node that receives this continuation may not
+ ;; yet be deleted.
+ (dest nil :type (or node null))
+ ;; If this is a NODE, then it is the node which is to be evaluated next.
+ ;; This is always null in :DELETED and :UNUSED continuations, and will be
+ ;; null in a :INSIDE-BLOCK continuation when this is the CONT of the LAST.
+ (next nil :type (or node null))
+ ;; An assertion on the type of this continuation's value.
+ (asserted-type *wild-type* :type ctype)
+ ;; Cached type of this continuation's value. If NIL, then this must be
+ ;; recomputed: see CONTINUATION-DERIVED-TYPE.
+ (%derived-type nil :type (or ctype null))
+ ;; Node where this continuation is used, if unique. This is always null in
+ ;; :DELETED and :UNUSED continuations, and is never null in :INSIDE-BLOCK
+ ;; continuations. In a :BLOCK-START continuation, the Block's START-USES
+ ;; indicate whether NIL means no uses or more than one use.
+ (use nil :type (or node null))
+ ;; Basic block this continuation is in. This is null only in :DELETED and
+ ;; :UNUSED continuations. Note that blocks that are unreachable but still in
+ ;; the DFO may receive deleted continuations, so it isn't o.k. to assume that
+ ;; any continuation that you pick up out of its DEST node has a BLOCK.
+ (block nil :type (or cblock null))
+ ;; Set to true when something about this continuation's value has changed.
+ ;; See REOPTIMIZE-CONTINUATION. This provides a way for IR1 optimize to
+ ;; determine which operands to a node have changed. If the optimizer for
+ ;; this node type doesn't care, it can elect not to clear this flag.
+ (reoptimize t :type boolean)
+ ;; An indication of what we have proven about how this contination's type
+ ;; assertion is satisfied:
+ ;;
+ ;; NIL
+ ;; No type check is necessary (proven type is a subtype of the assertion.)
+ ;;
+ ;; T
+ ;; A type check is needed.
+ ;;
+ ;; :DELETED
+ ;; Don't do a type check, but believe (intersect) the assertion. A T
+ ;; check can be changed to :DELETED if we somehow prove the check is
+ ;; unnecessary, or if we eliminate it through a policy decision.
+ ;;
+ ;; :NO-CHECK
+ ;; Type check generation sets the slot to this if a check is called for,
+ ;; but it believes it has proven that the check won't be done for
+ ;; policy reasons or because a safe implementation will be used. In the
+ ;; latter case, LTN must ensure that a safe implementation *is* be used.
+ ;;
+ ;; :ERROR
+ ;; There is a compile-time type error in some use of this continuation. A
+ ;; type check should still be generated, but be careful.
+ ;;
+ ;; This is computed lazily by CONTINUATION-DERIVED-TYPE, so use
+ ;; CONTINUATION-TYPE-CHECK instead of the %'ed slot accessor.
+ (%type-check t :type (member t nil :deleted :no-check :error))
+ ;; Something or other that the back end annotates this continuation with.
+ (info nil))
+(def!method print-object ((x continuation) stream)
+ (print-unreadable-object (x stream :type t :identity t)))
+
+(defstruct (node (:constructor nil))
+ ;; The bottom-up derived type for this node. This does not take into
+ ;; consideration output type assertions on this node (actually on its CONT).
+ (derived-type *wild-type* :type ctype)
+ ;; True if this node needs to be optimized. This is set to true whenever
+ ;; something changes about the value of a continuation whose DEST is this
+ ;; node.
+ (reoptimize t :type boolean)
+ ;; The continuation which receives the value of this node. This also
+ ;; indicates what we do controlwise after evaluating this node. This may be
+ ;; null during IR1 conversion.
+ (cont nil :type (or continuation null))
+ ;; The continuation that this node is the next of. This is null during
+ ;; IR1 conversion when we haven't linked the node in yet or in nodes that
+ ;; have been deleted from the IR1 by UNLINK-NODE.
+ (prev nil :type (or continuation null))
+ ;; The lexical environment this node was converted in.
+ (lexenv *lexenv* :type lexenv)
+ ;; A representation of the source code responsible for generating this node.
+ ;;
+ ;; For a form introduced by compilation (does not appear in the original
+ ;; source), the path begins with a list of all the enclosing introduced
+ ;; forms. This list is from the inside out, with the form immediately
+ ;; responsible for this node at the head of the list.
+ ;;
+ ;; Following the introduced forms is a representation of the location of the
+ ;; enclosing original source form. This transition is indicated by the magic
+ ;; ORIGINAL-SOURCE-START marker. The first element of the orignal source is
+ ;; the "form number", which is the ordinal number of this form in a
+ ;; depth-first, left-to-right walk of the truly top-level form in which this
+ ;; appears.
+ ;;
+ ;; Following is a list of integers describing the path taken through the
+ ;; source to get to this point:
+ ;; (K L M ...) => (NTH K (NTH L (NTH M ...)))
+ ;;
+ ;; The last element in the list is the top-level form number, which is the
+ ;; ordinal number (in this call to the compiler) of the truly top-level form
+ ;; containing the orignal source.
+ (source-path *current-path* :type list)
+ ;; If this node is in a tail-recursive position, then this is set to T. At
+ ;; the end of IR1 (in environment analysis) this is computed for all nodes
+ ;; (after cleanup code has been emitted). Before then, a non-null value
+ ;; indicates that IR1 optimization has converted a tail local call to a
+ ;; direct transfer.
+ ;;
+ ;; If the back-end breaks tail-recursion for some reason, then it can null
+ ;; out this slot.
+ (tail-p nil :type boolean))
+
+;;; Flags that are used to indicate various things about a block, such as what
+;;; optimizations need to be done on it:
+;;; -- REOPTIMIZE is set when something interesting happens the uses of a
+;;; continuation whose Dest is in this block. This indicates that the
+;;; value-driven (forward) IR1 optimizations should be done on this block.
+;;; -- FLUSH-P is set when code in this block becomes potentially flushable,
+;;; usually due to a continuation's DEST becoming null.
+;;; -- TYPE-CHECK is true when the type check phase should be run on this
+;;; block. IR1 optimize can introduce new blocks after type check has
+;;; already run. We need to check these blocks, but there is no point in
+;;; checking blocks we have already checked.
+;;; -- DELETE-P is true when this block is used to indicate that this block
+;;; has been determined to be unreachable and should be deleted. IR1
+;;; phases should not attempt to examine or modify blocks with DELETE-P
+;;; set, since they may:
+;;; - be in the process of being deleted, or
+;;; - have no successors, or
+;;; - receive :DELETED continuations.
+;;; -- TYPE-ASSERTED, TEST-MODIFIED
+;;; These flags are used to indicate that something in this block might be
+;;; of interest to constraint propagation. TYPE-ASSERTED is set when a
+;;; continuation type assertion is strengthened. TEST-MODIFIED is set
+;;; whenever the test for the ending IF has changed (may be true when there
+;;; is no IF.)
+(def-boolean-attribute block
+ reoptimize flush-p type-check delete-p type-asserted test-modified)
+
+(macrolet ((frob (slot)
+ `(defmacro ,(symbolicate "BLOCK-" slot) (block)
+ `(block-attributep (block-flags ,block) ,',slot))))
+ (frob reoptimize)
+ (frob flush-p)
+ (frob type-check)
+ (frob delete-p)
+ (frob type-asserted)
+ (frob test-modified))
+
+;;; The CBLOCK structure represents a basic block. We include SSET-ELEMENT so
+;;; that we can have sets of blocks. Initially the SSET-ELEMENT-NUMBER is
+;;; null, DFO analysis numbers in reverse DFO. During IR2 conversion, IR1
+;;; blocks are re-numbered in forward emit order. This latter numbering also
+;;; forms the basis of the block numbering in the debug-info (though that is
+;;; relative to the start of the function.)
+(defstruct (cblock (:include sset-element)
+ (:constructor make-block (start))
+ (:constructor make-block-key)
+ (:conc-name block-)
+ (:predicate block-p)
+ (:copier copy-block))
+ ;; A list of all the blocks that are predecessors/successors of this block.
+ ;; In well-formed IR1, most blocks will have one successor. The only
+ ;; exceptions are:
+ ;; 1. component head blocks (any number)
+ ;; 2. blocks ending in an IF (1 or 2)
+ ;; 3. blocks with DELETE-P set (zero)
+ (pred nil :type list)
+ (succ nil :type list)
+ ;; The continuation which heads this block (either a :Block-Start or
+ ;; :Deleted-Block-Start.) Null when we haven't made the start continuation
+ ;; yet (and in the dummy component head and tail blocks.)
+ (start nil :type (or continuation null))
+ ;; A list of all the nodes that have Start as their Cont.
+ (start-uses nil :type list)
+ ;; The last node in this block. This is null when we are in the process of
+ ;; building a block (and in the dummy component head and tail blocks.)
+ (last nil :type (or node null))
+ ;; The forward and backward links in the depth-first ordering of the blocks.
+ ;; These slots are null at beginning/end.
+ (next nil :type (or null cblock))
+ (prev nil :type (or null cblock))
+ ;; This block's attributes: see above.
+ (flags (block-attributes reoptimize flush-p type-check type-asserted
+ test-modified)
+ :type attributes)
+ ;; Some sets used by constraint propagation.
+ (kill nil)
+ (gen nil)
+ (in nil)
+ (out nil)
+ ;; The component this block is in. Null temporarily during IR1 conversion
+ ;; and in deleted blocks.
+ (component *current-component* :type (or component null))
+ ;; A flag used by various graph-walking code to determine whether this block
+ ;; has been processed already or what. We make this initially NIL so that
+ ;; Find-Initial-DFO doesn't have to scan the entire initial component just to
+ ;; clear the flags.
+ (flag nil)
+ ;; Some kind of info used by the back end.
+ (info nil)
+ ;; If true, then constraints that hold in this block and its successors by
+ ;; merit of being tested by its IF predecessor.
+ (test-constraint nil :type (or sset null)))
+(def!method print-object ((cblock cblock) stream)
+ (print-unreadable-object (cblock stream :type t :identity t)
+ (format stream ":START c~D" (cont-num (block-start cblock)))))
+
+;;; The Block-Annotation structure is shared (via :include) by different
+;;; block-info annotation structures so that code (specifically control
+;;; analysis) can be shared.
+(defstruct (block-annotation (:constructor nil))
+ ;; The IR1 block that this block is in the Info for.
+ (block (required-argument) :type cblock)
+ ;; The next and previous block in emission order (not DFO). This determines
+ ;; which block we drop though to, and also used to chain together overflow
+ ;; blocks that result from splitting of IR2 blocks in lifetime analysis.
+ (next nil :type (or block-annotation null))
+ (prev nil :type (or block-annotation null)))
+
+;;; The Component structure provides a handle on a connected piece of the flow
+;;; graph. Most of the passes in the compiler operate on components rather
+;;; than on the entire flow graph.
+(defstruct component
+ ;; The kind of component:
+ ;;
+ ;; NIL
+ ;; An ordinary component, containing non-top-level code.
+ ;;
+ ;; :Top-Level
+ ;; A component containing only load-time code.
+ ;;
+ ;; :Complex-Top-Level
+ ;; A component containing both top-level and run-time code.
+ ;;
+ ;; :Initial
+ ;; The result of initial IR1 conversion, on which component analysis has
+ ;; not been done.
+ ;;
+ ;; :Deleted
+ ;; Debris left over from component analysis.
+ (kind nil :type (member nil :top-level :complex-top-level :initial :deleted))
+ ;; The blocks that are the dummy head and tail of the DFO.
+ ;; Entry/exit points have these blocks as their
+ ;; predecessors/successors. Null temporarily. The start and return
+ ;; from each non-deleted function is linked to the component head
+ ;; and tail. Until environment analysis links NLX entry stubs to the
+ ;; component head, every successor of the head is a function start
+ ;; (i.e. begins with a Bind node.)
+ (head nil :type (or null cblock))
+ (tail nil :type (or null cblock))
+ ;; A list of the CLambda structures for all functions in this
+ ;; component. Optional-Dispatches are represented only by their XEP
+ ;; and other associated lambdas. This doesn't contain any deleted or
+ ;; let lambdas.
+ (lambdas () :type list)
+ ;; A list of Functional structures for functions that are newly
+ ;; converted, and haven't been local-call analyzed yet. Initially
+ ;; functions are not in the Lambdas list. LOCAL-CALL-ANALYZE moves
+ ;; them there (possibly as LETs, or implicitly as XEPs if an
+ ;; OPTIONAL-DISPATCH.) Between runs of LOCAL-CALL-ANALYZE there may
+ ;; be some debris of converted or even deleted functions in this
+ ;; list.
+ (new-functions () :type list)
+ ;; If true, then there is stuff in this component that could benefit
+ ;; from further IR1 optimization.
+ (reoptimize t :type boolean)
+ ;; If true, then the control flow in this component was messed up by
+ ;; IR1 optimizations. The DFO should be recomputed.
+ (reanalyze nil :type boolean)
+ ;; String that is some sort of name for the code in this component.
+ (name "<unknown>" :type simple-string)
+ ;; Some kind of info used by the back end.
+ (info nil)
+ ;; The Source-Info structure describing where this component was
+ ;; compiled from.
+ (source-info *source-info* :type source-info)
+ ;; Count of the number of inline expansions we have done while
+ ;; compiling this component, to detect infinite or exponential
+ ;; blowups.
+ (inline-expansions 0 :type index)
+ ;; A hashtable from combination nodes to things describing how an
+ ;; optimization of the node failed. The value is an alist (Transform
+ ;; . Args), where Transform is the structure describing the
+ ;; transform that failed, and Args is either a list of format
+ ;; arguments for the note, or the FUNCTION-TYPE that would have
+ ;; enabled the transformation but failed to match.
+ (failed-optimizations (make-hash-table :test 'eq) :type hash-table)
+ ;; Similar to NEW-FUNCTIONS, but is used when a function has already
+ ;; been analyzed, but new references have been added by inline
+ ;; expansion. Unlike NEW-FUNCTIONS, this is not disjoint from
+ ;; COMPONENT-LAMBDAS.
+ (reanalyze-functions nil :type list))
+(defprinter (component)
+ name
+ (reanalyze :test reanalyze))
+
+;;; The Cleanup structure represents some dynamic binding action.
+;;; Blocks are annotated with the current cleanup so that dynamic
+;;; bindings can be removed when control is transferred out of the
+;;; binding environment. We arrange for changes in dynamic bindings to
+;;; happen at block boundaries, so that cleanup code may easily be
+;;; inserted. The "mess-up" action is explicitly represented by a
+;;; funny function call or Entry node.
+;;;
+;;; We guarantee that cleanups only need to be done at block boundaries
+;;; by requiring that the exit continuations initially head their
+;;; blocks, and then by not merging blocks when there is a cleanup
+;;; change.
+(defstruct cleanup
+ ;; The kind of thing that has to be cleaned up.
+ (kind (required-argument)
+ :type (member :special-bind :catch :unwind-protect :block :tagbody))
+ ;; The node that messes things up. This is the last node in the
+ ;; non-messed-up environment. Null only temporarily. This could be
+ ;; deleted due to unreachability.
+ (mess-up nil :type (or node null))
+ ;; A list of all the NLX-Info structures whose NLX-Info-Cleanup is
+ ;; this cleanup. This is filled in by environment analysis.
+ (nlx-info nil :type list))
+(defprinter (cleanup)
+ kind
+ mess-up
+ (nlx-info :test nlx-info))
+
+;;; The Environment structure represents the result of Environment analysis.
+(defstruct environment
+ ;; The function that allocates this environment.
+ (function (required-argument) :type clambda)
+ ;; A list of all the Lambdas that allocate variables in this environment.
+ (lambdas nil :type list)
+ ;; A list of all the lambda-vars and NLX-Infos needed from enclosing
+ ;; environments by code in this environment.
+ (closure nil :type list)
+ ;; A list of NLX-Info structures describing all the non-local exits into this
+ ;; environment.
+ (nlx-info nil :type list)
+ ;; Some kind of info used by the back end.
+ (info nil))
+(defprinter (environment)
+ function
+ (closure :test closure)
+ (nlx-info :test nlx-info))
+
+;;; The Tail-Set structure is used to accmumlate information about
+;;; tail-recursive local calls. The "tail set" is effectively the transitive
+;;; closure of the "is called tail-recursively by" relation.
+;;;
+;;; All functions in the same tail set share the same Tail-Set structure.
+;;; Initially each function has its own Tail-Set, but when IR1-OPTIMIZE-RETURN
+;;; notices a tail local call, it joins the tail sets of the called function
+;;; and the calling function.
+;;;
+;;; The tail set is somewhat approximate, because it is too early to be sure
+;;; which calls will be TR. Any call that *might* end up TR causes tail-set
+;;; merging.
+(defstruct tail-set
+ ;; A list of all the lambdas in this tail set.
+ (functions nil :type list)
+ ;; Our current best guess of the type returned by these functions. This is
+ ;; the union across all the functions of the return node's Result-Type.
+ ;; excluding local calls.
+ (type *wild-type* :type ctype)
+ ;; Some info used by the back end.
+ (info nil))
+(defprinter (tail-set)
+ functions
+ type
+ (info :test info))
+
+;;; The NLX-Info structure is used to collect various information about
+;;; non-local exits. This is effectively an annotation on the Continuation,
+;;; although it is accessed by searching in the Environment-Nlx-Info.
+(def!struct (nlx-info (:make-load-form-fun ignore-it))
+ ;; The cleanup associated with this exit. In a catch or unwind-protect, this
+ ;; is the :Catch or :Unwind-Protect cleanup, and not the cleanup for the
+ ;; escape block. The Cleanup-Kind of this thus provides a good indication of
+ ;; what kind of exit is being done.
+ (cleanup (required-argument) :type cleanup)
+ ;; The continuation exited to (the CONT of the EXIT nodes.) If this exit is
+ ;; from an escape function (CATCH or UNWIND-PROTECT), then environment
+ ;; analysis deletes the escape function and instead has the %NLX-ENTRY use
+ ;; this continuation.
+ ;;
+ ;; This slot is primarily an indication of where this exit delivers its
+ ;; values to (if any), but it is also used as a sort of name to allow us to
+ ;; find the NLX-Info that corresponds to a given exit. For this purpose, the
+ ;; Entry must also be used to disambiguate, since exits to different places
+ ;; may deliver their result to the same continuation.
+ (continuation (required-argument) :type continuation)
+ ;; The entry stub inserted by environment analysis. This is a block
+ ;; containing a call to the %NLX-Entry funny function that has the original
+ ;; exit destination as its successor. Null only temporarily.
+ (target nil :type (or cblock null))
+ ;; Some kind of info used by the back end.
+ info)
+(defprinter (nlx-info)
+ continuation
+ target
+ info)
+\f
+;;;; LEAF structures
+
+;;; Variables, constants and functions are all represented by LEAF
+;;; structures. A reference to a LEAF is indicated by a REF node. This
+;;; allows us to easily substitute one for the other without actually
+;;; hacking the flow graph.
+(def!struct (leaf (:make-load-form-fun ignore-it)
+ (:constructor nil))
+ ;; Some name for this leaf. The exact significance of the name
+ ;; depends on what kind of leaf it is. In a Lambda-Var or
+ ;; Global-Var, this is the symbol name of the variable. In a
+ ;; functional that is from a DEFUN, this is the defined name. In
+ ;; other functionals, this is a descriptive string.
+ (name nil :type t)
+ ;; The type which values of this leaf must have.
+ (type *universal-type* :type ctype)
+ ;; Where the Type information came from:
+ ;; :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?)
+ (where-from :assumed :type (member :declared :assumed :defined))
+ ;; List of the Ref nodes for this leaf.
+ (refs () :type list)
+ ;; True if there was ever a Ref or Set node for this leaf. This may
+ ;; be true when Refs and Sets are null, since code can be deleted.
+ (ever-used nil :type boolean)
+ ;; Some kind of info used by the back end.
+ (info nil))
+
+;;; The Constant structure is used to represent known constant values.
+;;; If Name is not null, then it is the name of the named constant
+;;; which this leaf corresponds to, otherwise this is an anonymous
+;;; constant.
+(def!struct (constant (:include leaf))
+ ;; The value of the constant.
+ (value nil :type t))
+(defprinter (constant)
+ (name :test name)
+ value)
+
+;;; The Basic-Var structure represents information common to all
+;;; variables which don't correspond to known local functions.
+(def!struct (basic-var (:include leaf) (:constructor nil))
+ ;; Lists of the set nodes for this variable.
+ (sets () :type list))
+
+;;; The Global-Var structure represents a value hung off of the symbol
+;;; Name. We use a :Constant Var when we know that the thing is a
+;;; constant, but don't know what the value is at compile time.
+(def!struct (global-var (:include basic-var))
+ ;; Kind of variable described.
+ (kind (required-argument)
+ :type (member :special :global-function :constant :global)))
+(defprinter (global-var)
+ name
+ (type :test (not (eq type *universal-type*)))
+ (where-from :test (not (eq where-from :assumed)))
+ kind)
+
+;;; The Slot-Accessor structure represents slot accessor functions. It
+;;; is a subtype of Global-Var to make it look more like a normal
+;;; function.
+(def!struct (slot-accessor (:include global-var
+ (where-from :defined)
+ (kind :global-function)))
+ ;; The description of the structure that this is an accessor for.
+ (for (required-argument) :type sb!xc:class)
+ ;; The slot description of the slot.
+ (slot (required-argument)))
+(defprinter (slot-accessor)
+ name
+ for
+ slot)
+
+;;; The Defined-Function structure represents functions that are
+;;; 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.
+(def!struct (defined-function (:include global-var
+ (where-from :defined)
+ (kind :global-function)))
+ ;; The values of INLINEP and INLINE-EXPANSION initialized from the
+ ;; global environment.
+ (inlinep nil :type inlinep)
+ (inline-expansion nil :type (or cons null))
+ ;; The block-local definition of this function (either because it
+ ;; was semi-inline, or because it was defined in this block.) If
+ ;; this function is not an entry point, then this may be deleted or
+ ;; let-converted. Null if we haven't converted the expansion yet.
+ (functional nil :type (or functional null)))
+(defprinter (defined-function)
+ name
+ inlinep
+ (functional :test functional))
+\f
+;;;; function stuff
+
+;;; We default the WHERE-FROM and TYPE slots to :DEFINED and FUNCTION.
+;;; We don't normally manipulate function types for defined functions,
+;;; but if someone wants to know, an approximation is there.
+(def!struct (functional (:include leaf
+ (where-from :defined)
+ (type (specifier-type 'function))))
+ ;; Some information about how this function is used. These values are
+ ;; meaningful:
+ ;;
+ ;; Nil
+ ;; An ordinary function, callable using local call.
+ ;;
+ ;; :Let
+ ;; A lambda that is used in only one local call, and has in effect
+ ;; been substituted directly inline. The return node is deleted, and
+ ;; the result is computed with the actual result continuation for the
+ ;; call.
+ ;;
+ ;; :MV-Let
+ ;; Similar to :Let, but the call is an MV-Call.
+ ;;
+ ;; :Assignment
+ ;; Similar to a let, but can have other than one call as long as there
+ ;; is at most one non-tail call.
+ ;;
+ ;; :Optional
+ ;; A lambda that is an entry-point for an optional-dispatch. Similar
+ ;; to NIL, but requires greater caution, since local call analysis may
+ ;; create new references to this function. Also, the function cannot
+ ;; be deleted even if it has *no* references. The Optional-Dispatch
+ ;; is in the LAMDBA-OPTIONAL-DISPATCH.
+ ;;
+ ;; :External
+ ;; An external entry point lambda. The function it is an entry for is
+ ;; in the Entry-Function.
+ ;;
+ ;; :Top-Level
+ ;; A top-level lambda, holding a compiled top-level form. Compiled
+ ;; very much like NIL, but provides an indication of top-level
+ ;; context. A top-level lambda should have *no* references. Its
+ ;; Entry-Function is a self-pointer.
+ ;;
+ ;; :Top-Level-XEP
+ ;; After a component is compiled, we clobber any top-level code
+ ;; references to its non-closure XEPs with dummy FUNCTIONAL structures
+ ;; having this kind. This prevents the retained top-level code from
+ ;; holding onto the IR for the code it references.
+ ;;
+ ;; :Escape
+ ;; :Cleanup
+ ;; Special functions used internally by Catch and Unwind-Protect.
+ ;; These are pretty much like a normal function (NIL), but are treated
+ ;; specially by local call analysis and stuff. Neither kind should
+ ;; ever be given an XEP even though they appear as args to funny
+ ;; functions. An :Escape function is never actually called, and thus
+ ;; doesn't need to have code generated for it.
+ ;;
+ ;; :Deleted
+ ;; This function has been found to be uncallable, and has been
+ ;; marked for deletion.
+ (kind nil :type (member nil :optional :deleted :external :top-level :escape
+ :cleanup :let :mv-let :assignment
+ :top-level-xep))
+ ;; In a normal function, this is the external entry point (XEP)
+ ;; lambda for this function, if any. Each function that is used
+ ;; other than in a local call has an XEP, and all of the
+ ;; non-local-call references are replaced with references to the
+ ;; XEP.
+ ;;
+ ;; In an XEP lambda (indicated by the :External kind), this is the
+ ;; function that the XEP is an entry-point for. The body contains
+ ;; local calls to all the actual entry points in the function. In a
+ ;; :Top-Level lambda (which is its own XEP) this is a self-pointer.
+ ;;
+ ;; With all other kinds, this is null.
+ (entry-function nil :type (or functional null))
+ ;; The value of any inline/notinline declaration for a local function.
+ (inlinep nil :type inlinep)
+ ;; If we have a lambda that can be used as in inline expansion for this
+ ;; function, then this is it. If there is no source-level lambda
+ ;; corresponding to this function then this is Null (but then INLINEP will
+ ;; always be NIL as well.)
+ (inline-expansion nil :type list)
+ ;; The lexical environment that the inline-expansion should be converted in.
+ (lexenv *lexenv* :type lexenv)
+ ;; The original function or macro lambda list, or :UNSPECIFIED if this is a
+ ;; compiler created function.
+ (arg-documentation nil :type (or list (member :unspecified)))
+ ;; Various rare miscellaneous info that drives code generation & stuff.
+ (plist () :type list))
+(defprinter (functional)
+ name)
+
+;;; The Lambda only deals with required lexical arguments. Special,
+;;; optional, keyword and rest arguments are handled by transforming
+;;; into simpler stuff.
+(def!struct (clambda (:include functional)
+ (:conc-name lambda-)
+ (:predicate lambda-p)
+ (:constructor make-lambda)
+ (:copier copy-lambda))
+ ;; List of lambda-var descriptors for args.
+ (vars nil :type list)
+ ;; If this function was ever a :OPTIONAL function (an entry-point
+ ;; for an optional-dispatch), then this is that optional-dispatch.
+ ;; The optional dispatch will be :DELETED if this function is no
+ ;; longer :OPTIONAL.
+ (optional-dispatch nil :type (or optional-dispatch null))
+ ;; The Bind node for this Lambda. This node marks the beginning of
+ ;; the lambda, and serves to explicitly represent the lambda binding
+ ;; semantics within the flow graph representation. Null in deleted
+ ;; functions, and also in LETs where we deleted the call & bind
+ ;; (because there are no variables left), but have not yet actually
+ ;; deleted the lambda yet.
+ (bind nil :type (or bind null))
+ ;; The Return node for this Lambda, or NIL if it has been deleted.
+ ;; This marks the end of the lambda, receiving the result of the
+ ;; body. In a let, the return node is deleted, and the body delivers
+ ;; the value to the actual continuation. The return may also be
+ ;; deleted if it is unreachable.
+ (return nil :type (or creturn null))
+ ;; If this is a let, then the Lambda whose Lets list we are in,
+ ;; otherwise this is a self-pointer.
+ (home nil :type (or clambda null))
+ ;; A list of all the all the lambdas that have been let-substituted
+ ;; in this lambda. This is only non-null in lambdas that aren't
+ ;; lets.
+ (lets () :type list)
+ ;; A list of all the Entry nodes in this function and its lets. Null
+ ;; an a let.
+ (entries () :type list)
+ ;; A list of all the functions directly called from this function
+ ;; (or one of its lets) using a non-let local call. May include
+ ;; deleted functions because nobody bothers to clear them out.
+ (calls () :type list)
+ ;; The Tail-Set that this lambda is in. Null during creation and in
+ ;; let lambdas.
+ (tail-set nil :type (or tail-set null))
+ ;; The structure which represents the environment that this
+ ;; Function's variables are allocated in. This is filled in by
+ ;; environment analysis. In a let, this is EQ to our home's
+ ;; environment.
+ (environment nil :type (or environment null))
+ ;; In a LET, this is the NODE-LEXENV of the combination node. We
+ ;; retain it so that if the let is deleted (due to a lack of vars),
+ ;; we will still have caller's lexenv to figure out which cleanup is
+ ;; in effect.
+ (call-lexenv nil :type (or lexenv null)))
+(defprinter (clambda :conc-name lambda-)
+ name
+ (type :test (not (eq type *universal-type*)))
+ (where-from :test (not (eq where-from :assumed)))
+ (vars :prin1 (mapcar #'leaf-name vars)))
+
+;;; The Optional-Dispatch leaf is used to represent hairy lambdas. It
+;;; is a Functional, like Lambda. Each legal number of arguments has a
+;;; function which is called when that number of arguments is passed.
+;;; The function is called with all the arguments actually passed. If
+;;; additional arguments are legal, then the LEXPR style More-Entry
+;;; handles them. The value returned by the function is the value
+;;; which results from calling the Optional-Dispatch.
+;;;
+;;; The theory is that each entry-point function calls the next entry
+;;; point tail-recursively, passing all the arguments passed in and
+;;; the default for the argument the entry point is for. The last
+;;; entry point calls the real body of the function. In the presence
+;;; of supplied-p args and other hair, things are more complicated. In
+;;; general, there is a distinct internal function that takes the
+;;; supplied-p args as parameters. The preceding entry point calls
+;;; this function with NIL filled in for the supplied-p args, while
+;;; the current entry point calls it with T in the supplied-p
+;;; positions.
+;;;
+;;; Note that it is easy to turn a call with a known number of
+;;; arguments into a direct call to the appropriate entry-point
+;;; function, so functions that are compiled together can avoid doing
+;;; the dispatch.
+(def!struct (optional-dispatch (:include functional))
+ ;; The original parsed argument list, for anyone who cares.
+ (arglist nil :type list)
+ ;; True if &ALLOW-OTHER-KEYS was supplied.
+ (allowp nil :type boolean)
+ ;; True if &KEY was specified. (Doesn't necessarily mean that there
+ ;; are any keyword arguments...)
+ (keyp nil :type boolean)
+ ;; The number of required arguments. This is the smallest legal
+ ;; number of arguments.
+ (min-args 0 :type unsigned-byte)
+ ;; The total number of required and optional arguments. Args at
+ ;; positions >= to this are rest, key or illegal args.
+ (max-args 0 :type unsigned-byte)
+ ;; List of the Lambdas which are the entry points for non-rest,
+ ;; non-key calls. The entry for Min-Args is first, Min-Args+1
+ ;; second, ... Max-Args last. The last entry-point always calls the
+ ;; main entry; in simple cases it may be the main entry.
+ (entry-points nil :type list)
+ ;; An entry point which takes Max-Args fixed arguments followed by
+ ;; an argument context pointer and an argument count. This entry
+ ;; point deals with listifying rest args and parsing keywords. This
+ ;; is null when extra arguments aren't legal.
+ (more-entry nil :type (or clambda null))
+ ;; The main entry-point into the function, which takes all arguments
+ ;; including keywords as fixed arguments. The format of the
+ ;; arguments must be determined by examining the arglist. This may
+ ;; be used by callers that supply at least Max-Args arguments and
+ ;; know what they are doing.
+ (main-entry nil :type (or clambda null)))
+(defprinter (optional-dispatch)
+ name
+ (type :test (not (eq type *universal-type*)))
+ (where-from :test (not (eq where-from :assumed)))
+ arglist
+ allowp
+ keyp
+ min-args
+ max-args
+ (entry-points :test entry-points)
+ (more-entry :test more-entry)
+ main-entry)
+
+;;; The Arg-Info structure allows us to tack various information onto
+;;; Lambda-Vars during IR1 conversion. If we use one of these things,
+;;; then the var will have to be massaged a bit before it is simple
+;;; and lexical.
+(def!struct arg-info
+ ;; True if this arg is to be specially bound.
+ (specialp nil :type boolean)
+ ;; The kind of argument being described. Required args only have arg
+ ;; info structures if they are special.
+ (kind (required-argument) :type (member :required :optional :keyword :rest
+ :more-context :more-count))
+ ;; If true, the Var for supplied-p variable of a keyword or optional
+ ;; arg. This is true for keywords with non-constant defaults even
+ ;; when there is no user-specified supplied-p var.
+ (supplied-p nil :type (or lambda-var null))
+ ;; The default for a keyword or optional, represented as the
+ ;; original Lisp code. This is set to NIL in keyword arguments that
+ ;; are defaulted using the supplied-p arg.
+ (default nil :type t)
+ ;; The actual keyword for a keyword argument.
+ (keyword nil :type (or keyword null)))
+(defprinter (arg-info)
+ (specialp :test specialp)
+ kind
+ (supplied-p :test supplied-p)
+ (default :test default)
+ (keyword :test keyword))
+
+;;; The Lambda-Var structure represents a lexical lambda variable.
+;;; This structure is also used during IR1 conversion to describe
+;;; lambda arguments which may ultimately turn out not to be simple
+;;; and lexical.
+;;;
+;;; Lambda-Vars with no Refs are considered to be deleted; environment
+;;; analysis isn't done on these variables, so the back end must check
+;;; for and ignore unreferenced variables. Note that a deleted
+;;; lambda-var may have sets; in this case the back end is still
+;;; responsible for propagating the Set-Value to the set's Cont.
+(def!struct (lambda-var (:include basic-var))
+ ;; True if this variable has been declared Ignore.
+ (ignorep nil :type boolean)
+ ;; The Lambda that this var belongs to. This may be null when we are
+ ;; building a lambda during IR1 conversion.
+ (home nil :type (or null clambda))
+ ;; This is set by environment analysis if it chooses an indirect
+ ;; (value cell) representation for this variable because it is both
+ ;; set and closed over.
+ (indirect nil :type boolean)
+ ;; The following two slots are only meaningful during IR1 conversion
+ ;; of hairy lambda vars:
+ ;;
+ ;; The Arg-Info structure which holds information obtained from
+ ;; &keyword parsing.
+ (arg-info nil :type (or arg-info null))
+ ;; If true, the Global-Var structure for the special variable which
+ ;; is to be bound to the value of this argument.
+ (specvar nil :type (or global-var null))
+ ;; Set of the CONSTRAINTs on this variable. Used by constraint
+ ;; propagation. This is left null by the lambda pre-pass if it
+ ;; determine that this is a set closure variable, and is thus not a
+ ;; good subject for flow analysis.
+ (constraints nil :type (or sset null)))
+(defprinter (lambda-var)
+ name
+ (type :test (not (eq type *universal-type*)))
+ (where-from :test (not (eq where-from :assumed)))
+ (ignorep :test ignorep)
+ (arg-info :test arg-info)
+ (specvar :test specvar))
+\f
+;;;; basic node types
+
+;;; A Ref represents a reference to a leaf. Ref-Reoptimize is
+;;; initially (and forever) NIL, since Refs don't receive any values
+;;; and don't have any IR1 optimizer.
+(defstruct (ref (:include node (:reoptimize nil))
+ (:constructor make-ref (derived-type leaf)))
+ ;; The leaf referenced.
+ (leaf nil :type leaf))
+(defprinter (ref)
+ leaf)
+
+;;; Naturally, the IF node always appears at the end of a block.
+;;; Node-Cont is a dummy continuation, and is there only to keep
+;;; people happy.
+(defstruct (cif (:include node)
+ (:conc-name if-)
+ (:predicate if-p)
+ (:constructor make-if)
+ (:copier copy-if))
+ ;; Continuation for the predicate.
+ (test (required-argument) :type continuation)
+ ;; The blocks that we execute next in true and false case,
+ ;; respectively (may be the same.)
+ (consequent (required-argument) :type cblock)
+ (alternative (required-argument) :type cblock))
+(defprinter (cif :conc-name if-)
+ (test :prin1 (continuation-use test))
+ consequent
+ alternative)
+
+(defstruct (cset (:include node
+ (derived-type *universal-type*))
+ (:conc-name set-)
+ (:predicate set-p)
+ (:constructor make-set)
+ (:copier copy-set))
+ ;; Descriptor for the variable set.
+ (var (required-argument) :type basic-var)
+ ;; Continuation for the value form.
+ (value (required-argument) :type continuation))
+(defprinter (cset :conc-name set-)
+ var
+ (value :prin1 (continuation-use value)))
+
+;;; The Basic-Combination structure is used to represent both normal
+;;; and multiple value combinations. In a local function call, this
+;;; node appears at the end of its block and the body of the called
+;;; function appears as the successor. The NODE-CONT remains the
+;;; continuation which receives the value of the call.
+(defstruct (basic-combination (:include node)
+ (:constructor nil))
+ ;; Continuation for the function.
+ (fun (required-argument) :type continuation)
+ ;; List of continuations for the args. In a local call, an argument
+ ;; continuation may be replaced with NIL to indicate that the
+ ;; corresponding variable is unreferenced, and thus no argument
+ ;; value need be passed.
+ (args nil :type list)
+ ;; The kind of function call being made. :LOCAL means that this is a
+ ;; local call to a function in the same component, and that argument
+ ;; syntax checking has been done, etc. Calls to known global
+ ;; functions are represented by storing the FUNCTION-INFO for the
+ ;; function in this slot. :FULL is a call to an (as yet) unknown
+ ;; function. :ERROR is like :FULL, but means that we have discovered
+ ;; that the call contains an error, and should not be reconsidered
+ ;; for optimization.
+ (kind :full :type (or (member :local :full :error) function-info))
+ ;; Some kind of information attached to this node by the back end.
+ (info nil))
+
+;;; The COMBINATION node represents all normal function calls,
+;;; including FUNCALL. This is distinct from BASIC-COMBINATION so that
+;;; an MV-COMBINATION isn't COMBINATION-P.
+(defstruct (combination (:include basic-combination)
+ (:constructor make-combination (fun))))
+(defprinter (combination)
+ (fun :prin1 (continuation-use fun))
+ (args :prin1 (mapcar #'(lambda (x)
+ (if x
+ (continuation-use x)
+ "<deleted>"))
+ args)))
+
+;;; An MV-Combination is to Multiple-Value-Call as a Combination is to
+;;; Funcall. This is used to implement all the multiple-value
+;;; receiving forms.
+(defstruct (mv-combination (:include basic-combination)
+ (:constructor make-mv-combination (fun))))
+(defprinter (mv-combination)
+ (fun :prin1 (continuation-use fun))
+ (args :prin1 (mapcar #'continuation-use args)))
+
+;;; The Bind node marks the beginning of a lambda body and represents
+;;; the creation and initialization of the variables.
+(defstruct (bind (:include node))
+ ;; The lambda we are binding variables for. Null when we are
+ ;; creating the Lambda during IR1 translation.
+ (lambda nil :type (or clambda null)))
+(defprinter (bind)
+ lambda)
+
+;;; The Return node marks the end of a lambda body. It collects the
+;;; return values and represents the control transfer on return. This
+;;; is also where we stick information used for Tail-Set type
+;;; inference.
+(defstruct (creturn (:include node)
+ (:conc-name return-)
+ (:predicate return-p)
+ (:constructor make-return)
+ (:copier copy-return))
+ ;; The lambda we are returning from. Null temporarily during
+ ;; ir1tran.
+ (lambda nil :type (or clambda null))
+ ;; The continuation which yields the value of the lambda.
+ (result (required-argument) :type continuation)
+ ;; The union of the node-derived-type of all uses of the result
+ ;; other than by a local call, intersected with the result's
+ ;; asserted-type. If there are no non-call uses, this is
+ ;; *empty-type*.
+ (result-type *wild-type* :type ctype))
+(defprinter (creturn :conc-name return-)
+ lambda
+ result-type)
+\f
+;;;; non-local exit support
+;;;;
+;;;; In IR1, we insert special nodes to mark potentially non-local
+;;;; lexical exits.
+
+;;; The Entry node serves to mark the start of the dynamic extent of a
+;;; lexical exit. It is the mess-up node for the corresponding :Entry
+;;; cleanup.
+(defstruct (entry (:include node))
+ ;; All of the Exit nodes for potential non-local exits to this point.
+ (exits nil :type list)
+ ;; The cleanup for this entry. Null only temporarily.
+ (cleanup nil :type (or cleanup null)))
+(defprinter (entry))
+
+;;; The Exit node marks the place at which exit code would be emitted,
+;;; if necessary. This is interposed between the uses of the exit
+;;; continuation and the exit continuation's DEST. Instead of using
+;;; the returned value being delivered directly to the exit
+;;; continuation, it is delivered to our Value continuation. The
+;;; original exit continuation is the exit node's CONT.
+(defstruct (exit (:include node))
+ ;; The Entry node that this is an exit for. If null, this is a
+ ;; degenerate exit. A degenerate exit is used to "fill" an empty
+ ;; block (which isn't allowed in IR1.) In a degenerate exit, Value
+ ;; is always also null.
+ (entry nil :type (or entry null))
+ ;; The continuation yeilding the value we are to exit with. If NIL,
+ ;; then no value is desired (as in GO).
+ (value nil :type (or continuation null)))
+(defprinter (exit)
+ (entry :test entry)
+ (value :test value))
+\f
+;;;; miscellaneous IR1 structures
+
+(defstruct (undefined-warning
+ #-no-ansi-print-object
+ (:print-object (lambda (x s)
+ (print-unreadable-object (x s :type t)
+ (prin1 (undefined-warning-name x) s)))))
+ ;; The name of the unknown thing.
+ (name nil :type (or symbol list))
+ ;; The kind of reference to Name.
+ (kind (required-argument) :type (member :function :type :variable))
+ ;; The number of times this thing was used.
+ (count 0 :type unsigned-byte)
+ ;; A list of COMPILER-ERROR-CONTEXT structures describing places
+ ;; where this thing was used. Note that we only record the first
+ ;; *UNDEFINED-WARNING-LIMIT* calls.
+ (warnings () :type list))
+\f
+;;;; Freeze some structure types to speed type testing.
+
+#!-sb-fluid
+(declaim (freeze-type node leaf lexenv continuation cblock component cleanup
+ environment tail-set nlx-info))
--- /dev/null
+;;;; This file contains the implementation-independent code for Pack
+;;;; phase in the compiler. Pack is responsible for assigning TNs to
+;;;; storage allocations or "register allocation".
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!C")
+
+(file-comment
+ "$Header$")
+
+;;; for debugging: Some parameters controlling which optimizations we attempt.
+(defvar *pack-assign-costs* t)
+(defvar *pack-optimize-saves* t)
+;;; FIXME: Perhaps SB-FLUID should be renamed to SB-TWEAK and these should be
+;;; made conditional on SB-TWEAK.
+
+(declaim (ftype (function (component) index) ir2-block-count))
+\f
+;;;; conflict determination
+
+;;; Return true if the element at the specified offset in SB has a conflict
+;;; with TN:
+;;; -- If an component-live TN (:component kind), then iterate over all the
+;;; blocks. If the element at Offset is used anywhere in any of the
+;;; component's blocks (always-live /= 0), then there is a conflict.
+;;; -- If TN is global (Confs true), then iterate over the blocks TN is live in
+;;; (using TN-Global-Conflicts). If the TN is live everywhere in the block
+;;; (:Live), then there is a conflict if the element at offset is used
+;;; anywhere in the block (Always-Live /= 0). Otherwise, we use the local
+;;; TN number for TN in block to find whether TN has a conflict at Offset in
+;;; that block.
+;;; -- If TN is local, then we just check for a conflict in the block it is
+;;; local to.
+(defun offset-conflicts-in-sb (tn sb offset)
+ (declare (type tn tn) (type finite-sb sb) (type index offset))
+ (let ((confs (tn-global-conflicts tn))
+ (kind (tn-kind tn)))
+ (cond
+ ((eq kind :component)
+ (let ((loc-live (svref (finite-sb-always-live sb) offset)))
+ (dotimes (i (ir2-block-count *component-being-compiled*) nil)
+ (when (/= (sbit loc-live i) 0)
+ (return t)))))
+ (confs
+ (let ((loc-confs (svref (finite-sb-conflicts sb) offset))
+ (loc-live (svref (finite-sb-always-live sb) offset)))
+ (do ((conf confs (global-conflicts-tn-next conf)))
+ ((null conf)
+ nil)
+ (let* ((block (global-conflicts-block conf))
+ (num (ir2-block-number block)))
+ (if (eq (global-conflicts-kind conf) :live)
+ (when (/= (sbit loc-live num) 0)
+ (return t))
+ (when (/= (sbit (svref loc-confs num)
+ (global-conflicts-number conf))
+ 0)
+ (return t)))))))
+ (t
+ (/= (sbit (svref (svref (finite-sb-conflicts sb) offset)
+ (ir2-block-number (tn-local tn)))
+ (tn-local-number tn))
+ 0)))))
+
+;;; Return true if TN has a conflict in SC at the specified offset.
+(defun conflicts-in-sc (tn sc offset)
+ (declare (type tn tn) (type sc sc) (type index offset))
+ (let ((sb (sc-sb sc)))
+ (dotimes (i (sc-element-size sc) nil)
+ (when (offset-conflicts-in-sb tn sb (+ offset i))
+ (return t)))))
+
+;;; Add TN's conflicts into the conflicts for the location at Offset in SC.
+;;; We iterate over each location in TN, adding to the conflicts for that
+;;; location:
+;;; -- If TN is a :Component TN, then iterate over all the blocks, setting
+;;; all of the local conflict bits and the always-live bit. This records a
+;;; conflict with any TN that has a LTN number in the block, as well as with
+;;; :Always-Live and :Environment TNs.
+;;; -- If TN is global, then iterate over the blocks TN is live in. In
+;;; addition to setting the always-live bit to represent the conflict with
+;;; TNs live throughout the block, we also set bits in the local conflicts.
+;;; If TN is :Always-Live in the block, we set all the bits, otherwise we or
+;;; in the local conflict bits.
+;;; -- If the TN is local, then we just do the block it is local to, setting
+;;; always-live and OR'ing in the local conflicts.
+(defun add-location-conflicts (tn sc offset)
+ (declare (type tn tn) (type sc sc) (type index offset))
+ (let ((confs (tn-global-conflicts tn))
+ (sb (sc-sb sc))
+ (kind (tn-kind tn)))
+ (dotimes (i (sc-element-size sc))
+ (declare (type index i))
+ (let* ((this-offset (+ offset i))
+ (loc-confs (svref (finite-sb-conflicts sb) this-offset))
+ (loc-live (svref (finite-sb-always-live sb) this-offset)))
+ (cond
+ ((eq kind :component)
+ (dotimes (num (ir2-block-count *component-being-compiled*) nil)
+ (declare (type index num))
+ (setf (sbit loc-live num) 1)
+ (set-bit-vector (svref loc-confs num))))
+ (confs
+ (do ((conf confs (global-conflicts-tn-next conf)))
+ ((null conf))
+ (let* ((block (global-conflicts-block conf))
+ (num (ir2-block-number block))
+ (local-confs (svref loc-confs num)))
+ (declare (type local-tn-bit-vector local-confs))
+ (setf (sbit loc-live num) 1)
+ (if (eq (global-conflicts-kind conf) :live)
+ (set-bit-vector local-confs)
+ (bit-ior local-confs (global-conflicts-conflicts conf) t)))))
+ (t
+ (let ((num (ir2-block-number (tn-local tn))))
+ (setf (sbit loc-live num) 1)
+ (bit-ior (the local-tn-bit-vector (svref loc-confs num))
+ (tn-local-conflicts tn) t))))))))
+
+;;; Return the total number of IR2 blocks in Component.
+(defun ir2-block-count (component)
+ (declare (type component component))
+ (do ((2block (block-info (block-next (component-head component)))
+ (ir2-block-next 2block)))
+ ((null 2block)
+ (error "What? No ir2 blocks have a non-nil number?"))
+ (when (ir2-block-number 2block)
+ (return (1+ (ir2-block-number 2block))))))
+
+;;; Ensure that the conflicts vectors for each :Finite SB are large enough
+;;; for the number of blocks allocated. Also clear any old conflicts and reset
+;;; the current size to the initial size.
+(defun init-sb-vectors (component)
+ (let ((nblocks (ir2-block-count component)))
+ (dolist (sb *backend-sb-list*)
+ (unless (eq (sb-kind sb) :non-packed)
+ (let* ((conflicts (finite-sb-conflicts sb))
+ (always-live (finite-sb-always-live sb))
+ (max-locs (length conflicts))
+ (last-count (finite-sb-last-block-count sb)))
+ (unless (zerop max-locs)
+ (let ((current-size (length (the simple-vector
+ (svref conflicts 0)))))
+ (cond
+ ((> nblocks current-size)
+ (let ((new-size (max nblocks (* current-size 2))))
+ (declare (type index new-size))
+ (dotimes (i max-locs)
+ (declare (type index i))
+ (let ((new-vec (make-array new-size)))
+ (let ((old (svref conflicts i)))
+ (declare (simple-vector old))
+ (dotimes (j current-size)
+ (declare (type index j))
+ (setf (svref new-vec j)
+ (clear-bit-vector (svref old j)))))
+
+ (do ((j current-size (1+ j)))
+ ((= j new-size))
+ (declare (type index j))
+ (setf (svref new-vec j)
+ (make-array local-tn-limit :element-type 'bit
+ :initial-element 0)))
+ (setf (svref conflicts i) new-vec))
+ (setf (svref always-live i)
+ (make-array new-size :element-type 'bit
+ :initial-element 0)))))
+ (t
+ (dotimes (i (finite-sb-current-size sb))
+ (declare (type index i))
+ (let ((conf (svref conflicts i)))
+ (declare (simple-vector conf))
+ (dotimes (j last-count)
+ (declare (type index j))
+ (clear-bit-vector (svref conf j))))
+ (clear-bit-vector (svref always-live i)))))))
+
+ (setf (finite-sb-last-block-count sb) nblocks)
+ (setf (finite-sb-current-size sb) (sb-size sb))
+ (setf (finite-sb-last-offset sb) 0))))))
+
+;;; Expand the :Unbounded SB backing SC by either the initial size or the SC
+;;; element size, whichever is larger. If Needed-Size is larger, then use that
+;;; size.
+(defun grow-sc (sc &optional (needed-size 0))
+ (declare (type sc sc) (type index needed-size))
+ (let* ((sb (sc-sb sc))
+ (size (finite-sb-current-size sb))
+ (align-mask (1- (sc-alignment sc)))
+ (inc (max (sb-size sb)
+ (+ (sc-element-size sc)
+ (- (logandc2 (+ size align-mask) align-mask)
+ size))
+ (- needed-size size)))
+ (new-size (+ size inc))
+ (conflicts (finite-sb-conflicts sb))
+ (block-size (if (zerop (length conflicts))
+ (ir2-block-count *component-being-compiled*)
+ (length (the simple-vector (svref conflicts 0))))))
+ (declare (type index inc new-size))
+ (assert (eq (sb-kind sb) :unbounded))
+
+ (when (> new-size (length conflicts))
+ (let ((new-conf (make-array new-size)))
+ (replace new-conf conflicts)
+ (do ((i size (1+ i)))
+ ((= i new-size))
+ (declare (type index i))
+ (let ((loc-confs (make-array block-size)))
+ (dotimes (j block-size)
+ (setf (svref loc-confs j)
+ (make-array local-tn-limit
+ :initial-element 0
+ :element-type 'bit)))
+ (setf (svref new-conf i) loc-confs)))
+ (setf (finite-sb-conflicts sb) new-conf))
+
+ (let ((new-live (make-array new-size)))
+ (replace new-live (finite-sb-always-live sb))
+ (do ((i size (1+ i)))
+ ((= i new-size))
+ (setf (svref new-live i)
+ (make-array block-size
+ :initial-element 0
+ :element-type 'bit)))
+ (setf (finite-sb-always-live sb) new-live))
+
+ (let ((new-tns (make-array new-size :initial-element nil)))
+ (replace new-tns (finite-sb-live-tns sb))
+ (fill (finite-sb-live-tns sb) nil)
+ (setf (finite-sb-live-tns sb) new-tns)))
+
+ (setf (finite-sb-current-size sb) new-size))
+ (values))
+
+;;; This variable is true whenever we are in pack (and thus the per-SB
+;;; conflicts information is in use.)
+(defvar *in-pack* nil)
+
+;;; In order to prevent the conflict data structures from growing
+;;; arbitrarily large, we clear them whenever a GC happens and we aren't
+;;; currently in pack. We revert to the initial number of locations and 0
+;;; blocks.
+(defun pack-before-gc-hook ()
+ (unless *in-pack*
+ (dolist (sb *backend-sb-list*)
+ (unless (eq (sb-kind sb) :non-packed)
+ (let ((size (sb-size sb)))
+ (fill nil (finite-sb-always-live sb))
+ (setf (finite-sb-always-live sb)
+ (make-array size
+ :initial-element
+ #-sb-xc #*
+ ;; The cross-compiler isn't very good at dumping
+ ;; specialized arrays, so we delay construction of
+ ;; this SIMPLE-BIT-VECTOR until runtime.
+ #+sb-xc (make-array 0 :element-type 'bit)))
+
+ (fill nil (finite-sb-conflicts sb))
+ (setf (finite-sb-conflicts sb)
+ (make-array size :initial-element '#()))
+
+ (fill nil (finite-sb-live-tns sb))
+ (setf (finite-sb-live-tns sb)
+ (make-array size :initial-element nil))))))
+ (values))
+
+(pushnew 'pack-before-gc-hook sb!ext:*before-gc-hooks*)
+\f
+;;;; internal errors
+
+;;; Give someone a hard time because there isn't any load function defined
+;;; to move from Src to Dest.
+(defun no-load-function-error (src dest)
+ (let* ((src-sc (tn-sc src))
+ (src-name (sc-name src-sc))
+ (dest-sc (tn-sc dest))
+ (dest-name (sc-name dest-sc)))
+ (cond ((eq (sb-kind (sc-sb src-sc)) :non-packed)
+ (unless (member src-sc (sc-constant-scs dest-sc))
+ (error "loading from an invalid constant SC?~@
+ VM definition inconsistent, try recompiling."))
+ (error "no load function defined to load SC ~S ~
+ from its constant SC ~S"
+ dest-name src-name))
+ ((member src-sc (sc-alternate-scs dest-sc))
+ (error "no load function defined to load SC ~S from its ~
+ alternate SC ~S"
+ dest-name src-name))
+ ((member dest-sc (sc-alternate-scs src-sc))
+ (error "no load function defined to save SC ~S in its ~
+ alternate SC ~S"
+ src-name dest-name))
+ (t
+ ;; FIXME: "VM definition is inconsistent" shouldn't be a
+ ;; possibility in SBCL.
+ (error "loading to/from SCs that aren't alternates?~@
+ VM definition is inconsistent, try recompiling.")))))
+
+;;; Called when we failed to pack TN. If Restricted is true, then we we
+;;; restricted to pack TN in its SC.
+(defun failed-to-pack-error (tn restricted)
+ (declare (type tn tn))
+ (let* ((sc (tn-sc tn))
+ (scs (cons sc (sc-alternate-scs sc))))
+ (cond
+ (restricted
+ (error "Failed to pack restricted TN ~S in its SC ~S."
+ tn (sc-name sc)))
+ (t
+ (assert (not (find :unbounded scs
+ :key #'(lambda (x) (sb-kind (sc-sb x))))))
+ (let ((ptype (tn-primitive-type tn)))
+ (cond
+ (ptype
+ (assert (member (sc-number sc) (primitive-type-scs ptype)))
+ (error "SC ~S doesn't have any :Unbounded alternate SCs, but is~@
+ a SC for primitive-type ~S."
+ (sc-name sc) (primitive-type-name ptype)))
+ (t
+ (error "SC ~S doesn't have any :Unbounded alternate SCs."
+ (sc-name sc)))))))))
+
+;;; Return a list of format arguments describing how TN is used in Op's VOP.
+(defun describe-tn-use (loc tn op)
+ (let* ((vop (tn-ref-vop op))
+ (args (vop-args vop))
+ (results (vop-results vop))
+ (name (with-output-to-string (stream)
+ (print-tn tn stream)))
+ (2comp (component-info *component-being-compiled*))
+ temp)
+ (cond
+ ((setq temp (position-in #'tn-ref-across tn args :key #'tn-ref-tn))
+ `("~2D: ~A (~:R argument)" ,loc ,name ,(1+ temp)))
+ ((setq temp (position-in #'tn-ref-across tn results :key #'tn-ref-tn))
+ `("~2D: ~A (~:R result)" ,loc ,name ,(1+ temp)))
+ ((setq temp (position-in #'tn-ref-across tn args :key #'tn-ref-load-tn))
+ `("~2D: ~A (~:R argument load TN)" ,loc ,name ,(1+ temp)))
+ ((setq temp (position-in #'tn-ref-across tn results :key
+ #'tn-ref-load-tn))
+ `("~2D: ~A (~:R result load TN)" ,loc ,name ,(1+ temp)))
+ ((setq temp (position-in #'tn-ref-across tn (vop-temps vop)
+ :key #'tn-ref-tn))
+ `("~2D: ~A (temporary ~A)" ,loc ,name
+ ,(operand-parse-name (elt (vop-parse-temps
+ (vop-parse-or-lose
+ (vop-info-name (vop-info vop))))
+ temp))))
+ ((eq (tn-kind tn) :component)
+ `("~2D: ~A (component live)" ,loc ,name))
+ ((position-in #'tn-next tn (ir2-component-wired-tns 2comp))
+ `("~2D: ~A (wired)" ,loc ,name))
+ ((position-in #'tn-next tn (ir2-component-restricted-tns 2comp))
+ `("~2D: ~A (restricted)" ,loc ,name))
+ (t
+ `("~2D: not referenced?" ,loc)))))
+
+;;; If load TN packing fails, try to give a helpful error message. We find
+;;; a TN in each location that conflicts, and print it.
+(defun failed-to-pack-load-tn-error (scs op)
+ (declare (list scs) (type tn-ref op))
+ (collect ((used)
+ (unused))
+ (dolist (sc scs)
+ (let* ((sb (sc-sb sc))
+ (confs (finite-sb-live-tns sb)))
+ (assert (eq (sb-kind sb) :finite))
+ (dolist (el (sc-locations sc))
+ (declare (type index el))
+ (let ((conf (load-tn-conflicts-in-sc op sc el t)))
+ (if conf
+ (used (describe-tn-use el conf op))
+ (do ((i el (1+ i))
+ (end (+ el (sc-element-size sc))))
+ ((= i end)
+ (unused el))
+ (declare (type index i end))
+ (let ((victim (svref confs i)))
+ (when victim
+ (used (describe-tn-use el victim op))
+ (return t)))))))))
+
+ (multiple-value-bind (arg-p n more-p costs load-scs incon)
+ (get-operand-info op)
+ (declare (ignore costs load-scs))
+ (assert (not more-p))
+ (error "Unable to pack a Load-TN in SC ~{~A~#[~^~;, or ~:;,~]~} ~
+ for the ~:R ~:[result~;argument~] to~@
+ the ~S VOP,~@
+ ~:[since all SC elements are in use:~:{~%~@?~}~%~;~
+ ~:*but these SC elements are not in use:~% ~S~%Bug?~*~]~
+ ~:[~;~@
+ Current cost info inconsistent with that in effect at compile ~
+ time. Recompile.~%Compilation order may be incorrect.~]"
+ (mapcar #'sc-name scs)
+ n arg-p
+ (vop-info-name (vop-info (tn-ref-vop op)))
+ (unused) (used)
+ incon))))
+
+;;; Called when none of the SCs that we can load Op into are allowed by Op's
+;;; primitive-type.
+(defun no-load-scs-allowed-by-primitive-type-error (ref)
+ (declare (type tn-ref ref))
+ (let* ((tn (tn-ref-tn ref))
+ (ptype (tn-primitive-type tn)))
+ (multiple-value-bind (arg-p pos more-p costs load-scs incon)
+ (get-operand-info ref)
+ (declare (ignore costs))
+ (assert (not more-p))
+ (error "~S is not valid as the ~:R ~:[result~;argument~] to VOP:~
+ ~% ~S,~@
+ since the TN's primitive type ~S doesn't allow any of the SCs~@
+ allowed by the operand restriction:~% ~S~
+ ~:[~;~@
+ Current cost info inconsistent with that in effect at compile ~
+ time. Recompile.~%Compilation order may be incorrect.~]"
+ tn pos arg-p
+ (template-name (vop-info (tn-ref-vop ref)))
+ (primitive-type-name ptype)
+ (mapcar #'sc-name (listify-restrictions load-scs))
+ incon))))
+\f
+;;;; register saving
+
+;;; Do stuff to note that TN is spilled at VOP for the debugger's benefit.
+(defun note-spilled-tn (tn vop)
+ (when (and (tn-leaf tn) (vop-save-set vop))
+ (let ((2comp (component-info *component-being-compiled*)))
+ (setf (gethash tn (ir2-component-spilled-tns 2comp)) t)
+ (pushnew tn (gethash vop (ir2-component-spilled-vops 2comp)))))
+ (values))
+
+;;; Make a save TN for TN, pack it, and return it. We copy various conflict
+;;; information from the TN so that pack does the right thing.
+(defun pack-save-tn (tn)
+ (declare (type tn tn))
+ (let ((res (make-tn 0 :save nil nil)))
+ (dolist (alt (sc-alternate-scs (tn-sc tn))
+ (error "No unbounded alternate for SC ~S."
+ (sc-name (tn-sc tn))))
+ (when (eq (sb-kind (sc-sb alt)) :unbounded)
+ (setf (tn-save-tn tn) res)
+ (setf (tn-save-tn res) tn)
+ (setf (tn-sc res) alt)
+ (pack-tn res t)
+ (return res)))))
+
+;;; Find the load function for moving from Src to Dest and emit a
+;;; MOVE-OPERAND VOP with that function as its info arg.
+(defun emit-operand-load (node block src dest before)
+ (declare (type node node) (type ir2-block block)
+ (type tn src dest) (type (or vop null) before))
+ (emit-load-template node block
+ (template-or-lose 'move-operand)
+ src dest
+ (list (or (svref (sc-move-functions (tn-sc dest))
+ (sc-number (tn-sc src)))
+ (no-load-function-error src dest)))
+ before)
+ (values))
+
+;;; Find the preceding use of the VOP NAME in the emit order, starting with
+;;; VOP. We must find the VOP in the same IR1 block.
+(defun reverse-find-vop (name vop)
+ (do* ((block (vop-block vop) (ir2-block-prev block))
+ (last vop (ir2-block-last-vop block)))
+ (nil)
+ (assert (eq (ir2-block-block block) (ir2-block-block (vop-block vop))))
+ (do ((current last (vop-prev current)))
+ ((null current))
+ (when (eq (vop-info-name (vop-info current)) name)
+ (return-from reverse-find-vop current)))))
+
+;;; For TNs that have other than one writer, we save the TN before each
+;;; call. If a local call (MOVE-ARGS is :LOCAL-CALL), then we scan back for
+;;; the ALLOCATE-FRAME VOP, and emit the save there. This is necessary because
+;;; in a self-recursive local call, the registers holding the current arguments
+;;; may get trashed by setting up the call arguments. The ALLOCATE-FRAME VOP
+;;; marks a place at which the values are known to be good.
+(defun save-complex-writer-tn (tn vop)
+ (let ((save (or (tn-save-tn tn)
+ (pack-save-tn tn)))
+ (node (vop-node vop))
+ (block (vop-block vop))
+ (next (vop-next vop)))
+ (when (eq (tn-kind save) :specified-save)
+ (setf (tn-kind save) :save))
+ (assert (eq (tn-kind save) :save))
+ (emit-operand-load node block tn save
+ (if (eq (vop-info-move-args (vop-info vop))
+ :local-call)
+ (reverse-find-vop 'allocate-frame vop)
+ vop))
+ (emit-operand-load node block save tn next)))
+
+;;; Return a VOP after which is an o.k. place to save the value of TN. For
+;;; correctness, it is only required that this location be after any possible
+;;; write and before any possible restore location.
+;;;
+;;; In practice, we return the unique writer VOP, but give up if the TN is
+;;; ever read by a VOP with MOVE-ARGS :LOCAL-CALL. This prevents us from being
+;;; confused by non-tail local calls.
+;;;
+;;; When looking for writes, we have to ignore uses of MOVE-OPERAND, since they
+;;; will correspond to restores that we have already done.
+(defun find-single-writer (tn)
+ (declare (type tn tn))
+ (do ((write (tn-writes tn) (tn-ref-next write))
+ (res nil))
+ ((null write)
+ (when (and res
+ (do ((read (tn-reads tn) (tn-ref-next read)))
+ ((not read) t)
+ (when (eq (vop-info-move-args
+ (vop-info
+ (tn-ref-vop read)))
+ :local-call)
+ (return nil))))
+ (tn-ref-vop res)))
+
+ (unless (eq (vop-info-name (vop-info (tn-ref-vop write)))
+ 'move-operand)
+ (when res (return nil))
+ (setq res write))))
+
+;;; Try to save TN at a single location. If we succeed, return T, otherwise
+;;; NIL.
+(defun save-single-writer-tn (tn)
+ (declare (type tn tn))
+ (let* ((old-save (tn-save-tn tn))
+ (save (or old-save (pack-save-tn tn)))
+ (writer (find-single-writer tn)))
+ (when (and writer
+ (or (not old-save)
+ (eq (tn-kind old-save) :specified-save)))
+ (emit-operand-load (vop-node writer) (vop-block writer)
+ tn save (vop-next writer))
+ (setf (tn-kind save) :save-once)
+ t)))
+
+;;; Restore a TN with a :SAVE-ONCE save TN.
+(defun restore-single-writer-tn (tn vop)
+ (declare (type tn) (type vop vop))
+ (let ((save (tn-save-tn tn)))
+ (assert (eq (tn-kind save) :save-once))
+ (emit-operand-load (vop-node vop) (vop-block vop) save tn (vop-next vop)))
+ (values))
+
+;;; Save a single TN that needs to be saved, choosing save-once if
+;;; appropriate. This is also called by SPILL-AND-PACK-LOAD-TN.
+(defun basic-save-tn (tn vop)
+ (declare (type tn tn) (type vop vop))
+ (let ((save (tn-save-tn tn)))
+ (cond ((and save (eq (tn-kind save) :save-once))
+ (restore-single-writer-tn tn vop))
+ ((save-single-writer-tn tn)
+ (restore-single-writer-tn tn vop))
+ (t
+ (save-complex-writer-tn tn vop))))
+ (values))
+
+;;; Scan over the VOPs in Block, emiting saving code for TNs noted in the
+;;; codegen info that are packed into saved SCs.
+(defun emit-saves (block)
+ (declare (type ir2-block block))
+ (do ((vop (ir2-block-start-vop block) (vop-next vop)))
+ ((null vop))
+ (when (eq (vop-info-save-p (vop-info vop)) t)
+ (do-live-tns (tn (vop-save-set vop) block)
+ (when (and (sc-save-p (tn-sc tn))
+ (not (eq (tn-kind tn) :component)))
+ (basic-save-tn tn vop)))))
+
+ (values))
+\f
+;;;; optimized saving
+
+;;; Save TN if it isn't a single-writer TN that has already been saved. If
+;;; multi-write, we insert the save Before the specified VOP. Context is a VOP
+;;; used to tell which node/block to use for the new VOP.
+(defun save-if-necessary (tn before context)
+ (declare (type tn tn) (type (or vop null) before) (type vop context))
+ (let ((save (tn-save-tn tn)))
+ (when (eq (tn-kind save) :specified-save)
+ (setf (tn-kind save) :save))
+ (assert (member (tn-kind save) '(:save :save-once)))
+ (unless (eq (tn-kind save) :save-once)
+ (or (save-single-writer-tn tn)
+ (emit-operand-load (vop-node context) (vop-block context)
+ tn save before))))
+ (values))
+
+;;; Load the TN from its save location, allocating one if necessary. The
+;;; load is inserted Before the specifier VOP. Context is a VOP used to tell
+;;; which node/block to use for the new VOP.
+(defun restore-tn (tn before context)
+ (declare (type tn tn) (type (or vop null) before) (type vop context))
+ (let ((save (or (tn-save-tn tn) (pack-save-tn tn))))
+ (emit-operand-load (vop-node context) (vop-block context)
+ save tn before))
+ (values))
+
+(eval-when (:compile-toplevel :execute)
+
+;;; Do stuff to note a read of TN, for OPTIMIZED-EMIT-SAVES-BLOCK.
+(defmacro save-note-read (tn)
+ `(let* ((tn ,tn)
+ (num (tn-number tn)))
+ (when (and (sc-save-p (tn-sc tn))
+ (zerop (sbit restores num))
+ (not (eq (tn-kind tn) :component)))
+ (setf (sbit restores num) 1)
+ (push tn restores-list))))
+
+) ; EVAL-WHEN
+
+;;; Start scanning backward at the end of Block, looking which TNs are live
+;;; and looking for places where we have to save. We manipulate two sets:
+;;; SAVES and RESTORES.
+;;;
+;;; SAVES is a set of all the TNs that have to be saved because they are
+;;; restored after some call. We normally delay saving until the beginning of
+;;; the block, but we must save immediately if we see a write of the saved TN.
+;;; We also immediately save all TNs and exit when we see a
+;;; NOTE-ENVIRONMENT-START VOP, since saves can't be done before the
+;;; environment is properly initialized.
+;;;
+;;; RESTORES is a set of all the TNs read (and not written) between here and
+;;; the next call, i.e. the set of TNs that must be restored when we reach the
+;;; next (earlier) call VOP. Unlike SAVES, this set is cleared when we do
+;;; the restoring after a call. Any TNs that were in RESTORES are moved into
+;;; SAVES to ensure that they are saved at some point.
+;;;
+;;; SAVES and RESTORES are represented using both a list and a bit-vector so
+;;; that we can quickly iterate and test for membership. The incoming Saves
+;;; and Restores args are used for computing these sets (the initial contents
+;;; are ignored.)
+;;;
+;;; When we hit a VOP with :COMPUTE-ONLY Save-P (an internal error
+;;; location), we pretend that all live TNs were read, unless (= speed 3), in
+;;; which case we mark all the TNs that are live but not restored as spilled.
+(defun optimized-emit-saves-block (block saves restores)
+ (declare (type ir2-block block) (type simple-bit-vector saves restores))
+ (let ((1block (ir2-block-block block))
+ (saves-list ())
+ (restores-list ())
+ (skipping nil))
+ (declare (list saves-list restores-list))
+ (clear-bit-vector saves)
+ (clear-bit-vector restores)
+ (do-live-tns (tn (ir2-block-live-in block) block)
+ (when (and (sc-save-p (tn-sc tn))
+ (not (eq (tn-kind tn) :component)))
+ (let ((num (tn-number tn)))
+ (setf (sbit restores num) 1)
+ (push tn restores-list))))
+
+ (do ((block block (ir2-block-prev block))
+ (prev nil block))
+ ((not (eq (ir2-block-block block) 1block))
+ (assert (not skipping))
+ (dolist (save saves-list)
+ (let ((start (ir2-block-start-vop prev)))
+ (save-if-necessary save start start)))
+ prev)
+ (do ((vop (ir2-block-last-vop block) (vop-prev vop)))
+ ((null vop))
+ (let ((info (vop-info vop)))
+ (case (vop-info-name info)
+ (allocate-frame
+ (assert skipping)
+ (setq skipping nil))
+ (note-environment-start
+ (assert (not skipping))
+ (dolist (save saves-list)
+ (save-if-necessary save (vop-next vop) vop))
+ (return-from optimized-emit-saves-block block)))
+
+ (unless skipping
+ (do ((write (vop-results vop) (tn-ref-across write)))
+ ((null write))
+ (let* ((tn (tn-ref-tn write))
+ (num (tn-number tn)))
+ (unless (zerop (sbit restores num))
+ (setf (sbit restores num) 0)
+ (setq restores-list
+ (delete tn restores-list :test #'eq)))
+ (unless (zerop (sbit saves num))
+ (setf (sbit saves num) 0)
+ (save-if-necessary tn (vop-next vop) vop)
+ (setq saves-list
+ (delete tn saves-list :test #'eq))))))
+
+ (macrolet (;; Do stuff to note a read of TN, for
+ ;; OPTIMIZED-EMIT-SAVES-BLOCK.
+ (save-note-read (tn)
+ `(let* ((tn ,tn)
+ (num (tn-number tn)))
+ (when (and (sc-save-p (tn-sc tn))
+ (zerop (sbit restores num))
+ (not (eq (tn-kind tn) :component)))
+ (setf (sbit restores num) 1)
+ (push tn restores-list)))))
+
+ (case (vop-info-save-p info)
+ ((t)
+ (dolist (tn restores-list)
+ (restore-tn tn (vop-next vop) vop)
+ (let ((num (tn-number tn)))
+ (when (zerop (sbit saves num))
+ (push tn saves-list)
+ (setf (sbit saves num) 1))))
+ (setq restores-list nil)
+ (clear-bit-vector restores))
+ (:compute-only
+ (cond ((policy (vop-node vop) (= speed 3))
+ (do-live-tns (tn (vop-save-set vop) block)
+ (when (zerop (sbit restores (tn-number tn)))
+ (note-spilled-tn tn vop))))
+ (t
+ (do-live-tns (tn (vop-save-set vop) block)
+ (save-note-read tn))))))
+
+ (if (eq (vop-info-move-args info) :local-call)
+ (setq skipping t)
+ (do ((read (vop-args vop) (tn-ref-across read)))
+ ((null read))
+ (save-note-read (tn-ref-tn read))))))))))
+
+;;; Like EMIT-SAVES, only different. We avoid redundant saving within the
+;;; block, and don't restore values that aren't used before the next call.
+;;; This function is just the top-level loop over the blocks in the component,
+;;; which locates blocks that need saving done.
+(defun optimized-emit-saves (component)
+ (declare (type component component))
+ (let* ((gtn-count (1+ (ir2-component-global-tn-counter
+ (component-info component))))
+ (saves (make-array gtn-count :element-type 'bit))
+ (restores (make-array gtn-count :element-type 'bit))
+ (block (ir2-block-prev (block-info (component-tail component))))
+ (head (block-info (component-head component))))
+ (loop
+ (when (eq block head) (return))
+ (when (do ((vop (ir2-block-start-vop block) (vop-next vop)))
+ ((null vop) nil)
+ (when (eq (vop-info-save-p (vop-info vop)) t)
+ (return t)))
+ (setq block (optimized-emit-saves-block block saves restores)))
+ (setq block (ir2-block-prev block)))))
+
+;;; Iterate over the normal TNs, finding the cost of packing on the stack in
+;;; units of the number of references. We count all references as +1, and
+;;; subtract out REGISTER-SAVE-PENALTY for each place where we would have to
+;;; save a register.
+(defun assign-tn-costs (component)
+ (do-ir2-blocks (block component)
+ (do ((vop (ir2-block-start-vop block) (vop-next vop)))
+ ((null vop))
+ (when (eq (vop-info-save-p (vop-info vop)) t)
+ (do-live-tns (tn (vop-save-set vop) block)
+ (decf (tn-cost tn) *backend-register-save-penalty*)))))
+
+ (do ((tn (ir2-component-normal-tns (component-info component))
+ (tn-next tn)))
+ ((null tn))
+ (let ((cost (tn-cost tn)))
+ (declare (fixnum cost))
+ (do ((ref (tn-reads tn) (tn-ref-next ref)))
+ ((null ref))
+ (incf cost))
+ (do ((ref (tn-writes tn) (tn-ref-next ref)))
+ ((null ref))
+ (incf cost))
+ (setf (tn-cost tn) cost))))
+\f
+;;;; load TN packing
+
+;;; These variables indicate the last location at which we computed the
+;;; Live-TNs. They hold the Block and VOP values that were passed to
+;;; Compute-Live-TNs.
+(defvar *live-block*)
+(defvar *live-vop*)
+
+;;; If we unpack some TNs, then we mark all affected blocks by sticking them in
+;;; this hash-table. This is initially null. We create the hashtable if we do
+;;; any unpacking.
+(defvar *repack-blocks*)
+(declaim (type (or hash-table null) *repack-blocks*))
+
+;;; Set the Live-TNs vectors in all :Finite SBs to represent the TNs live at
+;;; the end of Block.
+(defun init-live-tns (block)
+ (dolist (sb *backend-sb-list*)
+ (when (eq (sb-kind sb) :finite)
+ (fill (finite-sb-live-tns sb) nil)))
+
+ (do-live-tns (tn (ir2-block-live-in block) block)
+ (let* ((sc (tn-sc tn))
+ (sb (sc-sb sc)))
+ (when (eq (sb-kind sb) :finite)
+ (do ((offset (tn-offset tn) (1+ offset))
+ (end (+ (tn-offset tn) (sc-element-size sc))))
+ ((= offset end))
+ (declare (type index offset end))
+ (setf (svref (finite-sb-live-tns sb) offset) tn)))))
+
+ (setq *live-block* block)
+ (setq *live-vop* (ir2-block-last-vop block))
+
+ (values))
+
+;;; Set the Live-TNs in :Finite SBs to represent the TNs live immediately
+;;; after the evaluation of VOP in Block, excluding results of the VOP. If VOP
+;;; is null, then compute the live TNs at the beginning of the block.
+;;; Sequential calls on the same block must be in reverse VOP order.
+(defun compute-live-tns (block vop)
+ (declare (type ir2-block block) (type vop vop))
+ (unless (eq block *live-block*)
+ (init-live-tns block))
+
+ (do ((current *live-vop* (vop-prev current)))
+ ((eq current vop)
+ (do ((res (vop-results vop) (tn-ref-across res)))
+ ((null res))
+ (let* ((tn (tn-ref-tn res))
+ (sc (tn-sc tn))
+ (sb (sc-sb sc)))
+ (when (eq (sb-kind sb) :finite)
+ (do ((offset (tn-offset tn) (1+ offset))
+ (end (+ (tn-offset tn) (sc-element-size sc))))
+ ((= offset end))
+ (declare (type index offset end))
+ (setf (svref (finite-sb-live-tns sb) offset) nil))))))
+ (do ((ref (vop-refs current) (tn-ref-next-ref ref)))
+ ((null ref))
+ (let ((ltn (tn-ref-load-tn ref)))
+ (when ltn
+ (let* ((sc (tn-sc ltn))
+ (sb (sc-sb sc)))
+ (when (eq (sb-kind sb) :finite)
+ (let ((tns (finite-sb-live-tns sb)))
+ (do ((offset (tn-offset ltn) (1+ offset))
+ (end (+ (tn-offset ltn) (sc-element-size sc))))
+ ((= offset end))
+ (declare (type index offset end))
+ (assert (null (svref tns offset)))))))))
+
+ (let* ((tn (tn-ref-tn ref))
+ (sc (tn-sc tn))
+ (sb (sc-sb sc)))
+ (when (eq (sb-kind sb) :finite)
+ (let ((tns (finite-sb-live-tns sb)))
+ (do ((offset (tn-offset tn) (1+ offset))
+ (end (+ (tn-offset tn) (sc-element-size sc))))
+ ((= offset end))
+ (declare (type index offset end))
+ (if (tn-ref-write-p ref)
+ (setf (svref tns offset) nil)
+ (let ((old (svref tns offset)))
+ (assert (or (null old) (eq old tn)) (old tn))
+ (setf (svref tns offset) tn)))))))))
+
+ (setq *live-vop* vop)
+ (values))
+
+;;; Kind of like Offset-Conflicts-In-SB, except that it uses the VOP refs to
+;;; determine whether a Load-TN for OP could be packed in the specified
+;;; location, disregarding conflicts with TNs not referenced by this VOP.
+;;; There is a conflict if either:
+;;; 1. The reference is a result, and the same location is either:
+;;; -- Used by some other result.
+;;; -- Used in any way after the reference (exclusive).
+;;; 2. The reference is an argument, and the same location is either:
+;;; -- Used by some other argument.
+;;; -- Used in any way before the reference (exclusive).
+;;;
+;;; In 1 (and 2) above, the first bullet corresponds to result-result
+;;; (and argument-argument) conflicts. We need this case because there aren't
+;;; any TN-REFs to represent the implicit reading of results or writing of
+;;; arguments.
+;;;
+;;; The second bullet corresponds conflicts with temporaries or between
+;;; arguments and results.
+;;;
+;;; We consider both the TN-REF-TN and the TN-REF-LOAD-TN (if any) to be
+;;; referenced simultaneously and in the same way. This causes load-TNs to
+;;; appear live to the beginning (or end) of the VOP, as appropriate.
+;;;
+;;; We return a conflicting TN if there is a conflict.
+(defun load-tn-offset-conflicts-in-sb (op sb offset)
+ (declare (type tn-ref op) (type finite-sb sb) (type index offset))
+ (assert (eq (sb-kind sb) :finite))
+ (let ((vop (tn-ref-vop op)))
+ (labels ((tn-overlaps (tn)
+ (let ((sc (tn-sc tn))
+ (tn-offset (tn-offset tn)))
+ (when (and (eq (sc-sb sc) sb)
+ (<= tn-offset offset)
+ (< offset
+ (the index
+ (+ tn-offset (sc-element-size sc)))))
+ tn)))
+ (same (ref)
+ (let ((tn (tn-ref-tn ref))
+ (ltn (tn-ref-load-tn ref)))
+ (or (tn-overlaps tn)
+ (and ltn (tn-overlaps ltn)))))
+ (is-op (ops)
+ (do ((ops ops (tn-ref-across ops)))
+ ((null ops) nil)
+ (let ((found (same ops)))
+ (when (and found (not (eq ops op)))
+ (return found)))))
+ (is-ref (refs end)
+ (do ((refs refs (tn-ref-next-ref refs)))
+ ((eq refs end) nil)
+ (let ((found (same refs)))
+ (when found (return found))))))
+ (declare (inline is-op is-ref tn-overlaps))
+ (if (tn-ref-write-p op)
+ (or (is-op (vop-results vop))
+ (is-ref (vop-refs vop) op))
+ (or (is-op (vop-args vop))
+ (is-ref (tn-ref-next-ref op) nil))))))
+
+;;; Iterate over all the elements in the SB that would be allocated by
+;;; allocating a TN in SC at Offset, checking for conflict with load-TNs or
+;;; other TNs (live in the LIVE-TNS, which must be set up.) We also return
+;;; true if there aren't enough locations after Offset to hold a TN in SC.
+;;; If Ignore-Live is true, then we ignore the live-TNs, considering only
+;;; references within Op's VOP.
+;;;
+;;; We return a conflicting TN, or :OVERFLOW if the TN won't fit.
+(defun load-tn-conflicts-in-sc (op sc offset ignore-live)
+ (let* ((sb (sc-sb sc))
+ (size (finite-sb-current-size sb)))
+ (do ((i offset (1+ i))
+ (end (+ offset (sc-element-size sc))))
+ ((= i end) nil)
+ (declare (type index i end))
+ (let ((res (or (when (>= i size) :overflow)
+ (and (not ignore-live)
+ (svref (finite-sb-live-tns sb) i))
+ (load-tn-offset-conflicts-in-sb op sb i))))
+ (when res (return res))))))
+
+;;; If a load-TN for Op is targeted to a legal location in SC, then return
+;;; the offset, otherwise return NIL. We see whether the target of the
+;;; operand is packed, and try that location. There isn't any need to chain
+;;; down the target path, since everything is packed now.
+;;;
+;;; We require the target to be in SC (and not merely to overlap with SC).
+;;; This prevents SC information from being lost in load TNs (we won't pack a
+;;; load TN in ANY-REG when it is targeted to a DESCRIPTOR-REG.) This
+;;; shouldn't hurt the code as long as all relevant overlapping SCs are allowed
+;;; in the operand SC restriction.
+(defun find-load-tn-target (op sc)
+ (declare (inline member))
+ (let ((target (tn-ref-target op)))
+ (when target
+ (let* ((tn (tn-ref-tn target))
+ (loc (tn-offset tn)))
+ (if (and (eq (tn-sc tn) sc)
+ (member (the index loc) (sc-locations sc))
+ (not (load-tn-conflicts-in-sc op sc loc nil)))
+ loc
+ nil)))))
+
+;;; Select a legal location for a load TN for Op in SC. We just iterate
+;;; over the SC's locations. If we can't find a legal location, return NIL.
+(defun select-load-tn-location (op sc)
+ (declare (type tn-ref op) (type sc sc))
+
+ ;; Check any target location first.
+ (let ((target (tn-ref-target op)))
+ (when target
+ (let* ((tn (tn-ref-tn target))
+ (loc (tn-offset tn)))
+ (when (and (eq (sc-sb sc) (sc-sb (tn-sc tn)))
+ (member (the index loc) (sc-locations sc))
+ (not (load-tn-conflicts-in-sc op sc loc nil)))
+ (return-from select-load-tn-location loc)))))
+
+ (dolist (loc (sc-locations sc) nil)
+ (unless (load-tn-conflicts-in-sc op sc loc nil)
+ (return loc))))
+
+(defevent unpack-tn "Unpacked a TN to satisfy operand SC restriction.")
+
+;;; Make TN's location the same as for its save TN (allocating a save TN if
+;;; necessary.) Delete any save/restore code that has been emitted thus far.
+;;; Mark all blocks containing references as needing to be repacked.
+(defun unpack-tn (tn)
+ (event unpack-tn)
+ (let ((stn (or (tn-save-tn tn)
+ (pack-save-tn tn))))
+ (setf (tn-sc tn) (tn-sc stn))
+ (setf (tn-offset tn) (tn-offset stn))
+ (flet ((zot (refs)
+ (do ((ref refs (tn-ref-next ref)))
+ ((null ref))
+ (let ((vop (tn-ref-vop ref)))
+ (if (eq (vop-info-name (vop-info vop)) 'move-operand)
+ (delete-vop vop)
+ (setf (gethash (vop-block vop) *repack-blocks*) t))))))
+ (zot (tn-reads tn))
+ (zot (tn-writes tn))))
+
+ (values))
+
+(defevent unpack-fallback "Unpacked some operand TN.")
+
+;;; Called by Pack-Load-TN where there isn't any location free that we can
+;;; pack into. What we do is move some live TN in one of the specified SCs to
+;;; memory, then mark this block all blocks that reference the TN as needing
+;;; repacking. If we succeed, we throw to UNPACKED-TN. If we fail, we return
+;;; NIL.
+;;;
+;;; We can unpack any live TN that appears in the NORMAL-TNs list (isn't wired
+;;; or restricted.) We prefer to unpack TNs that are not used by the VOP. If
+;;; we can't find any such TN, then we unpack some argument or result
+;;; TN. The only way we can fail is if all locations in SC are used by
+;;; load-TNs or temporaries in VOP.
+(defun unpack-for-load-tn (sc op)
+ (declare (type sc sc) (type tn-ref op))
+ (let ((sb (sc-sb sc))
+ (normal-tns (ir2-component-normal-tns
+ (component-info *component-being-compiled*)))
+ (node (vop-node (tn-ref-vop op)))
+ (fallback nil))
+ (flet ((unpack-em (victims)
+ (unless *repack-blocks*
+ (setq *repack-blocks* (make-hash-table :test 'eq)))
+ (setf (gethash (vop-block (tn-ref-vop op)) *repack-blocks*) t)
+ (dolist (victim victims)
+ (event unpack-tn node)
+ (unpack-tn victim))
+ (throw 'unpacked-tn nil)))
+ (dolist (loc (sc-locations sc))
+ (declare (type index loc))
+ (block SKIP
+ (collect ((victims nil adjoin))
+ (do ((i loc (1+ i))
+ (end (+ loc (sc-element-size sc))))
+ ((= i end))
+ (declare (type index i end))
+ (let ((victim (svref (finite-sb-live-tns sb) i)))
+ (when victim
+ (unless (find-in #'tn-next victim normal-tns)
+ (return-from SKIP))
+ (victims victim))))
+
+ (let ((conf (load-tn-conflicts-in-sc op sc loc t)))
+ (cond ((not conf)
+ (unpack-em (victims)))
+ ((eq conf :overflow))
+ ((not fallback)
+ (cond ((find conf (victims))
+ (setq fallback (victims)))
+ ((find-in #'tn-next conf normal-tns)
+ (setq fallback (list conf))))))))))
+
+ (when fallback
+ (event unpack-fallback node)
+ (unpack-em fallback))))
+
+ nil)
+
+;;; Try to pack a load TN in the SCs indicated by Load-SCs. If we run out
+;;; of SCs, then we unpack some TN and try again. We return the packed load
+;;; TN.
+;;;
+;;; Note: we allow a Load-TN to be packed in the target location even if that
+;;; location is in a SC not allowed by the primitive type. (The SC must still
+;;; be allowed by the operand restriction.) This makes move VOPs more
+;;; efficient, since we won't do a move from the stack into a non-descriptor
+;;; any-reg though a descriptor argument load-TN. This does give targeting
+;;; some real semantics, making it not a pure advisory to pack. It allows pack
+;;; to do some packing it wouldn't have done before.
+(defun pack-load-tn (load-scs op)
+ (declare (type sc-vector load-scs) (type tn-ref op))
+ (let ((vop (tn-ref-vop op)))
+ (compute-live-tns (vop-block vop) vop))
+
+ (let* ((tn (tn-ref-tn op))
+ (ptype (tn-primitive-type tn))
+ (scs (svref load-scs (sc-number (tn-sc tn)))))
+ (let ((current-scs scs)
+ (allowed ()))
+ (loop
+ (cond
+ ((null current-scs)
+ (unless allowed
+ (no-load-scs-allowed-by-primitive-type-error op))
+ (dolist (sc allowed)
+ (unpack-for-load-tn sc op))
+ (failed-to-pack-load-tn-error allowed op))
+ (t
+ (let* ((sc (svref *backend-sc-numbers* (pop current-scs)))
+ (target (find-load-tn-target op sc)))
+ (when (or target (sc-allowed-by-primitive-type sc ptype))
+ (let ((loc (or target
+ (select-load-tn-location op sc))))
+ (when loc
+ (let ((res (make-tn 0 :load nil sc)))
+ (setf (tn-offset res) loc)
+ (return res))))
+ (push sc allowed)))))))))
+
+;;; Scan a list of load-SCs vectors and a list of TN-Refs threaded by
+;;; TN-Ref-Across. When we find a reference whose TN doesn't satisfy the
+;;; restriction, we pack a Load-TN and load the operand into it. If a load-tn
+;;; has already been allocated, we can assume that the restriction is
+;;; satisfied.
+#!-sb-fluid (declaim (inline check-operand-restrictions))
+(defun check-operand-restrictions (scs ops)
+ (declare (list scs) (type (or tn-ref null) ops))
+
+ ;; Check the targeted operands first.
+ (do ((scs scs (cdr scs))
+ (op ops (tn-ref-across op)))
+ ((null scs))
+ (let ((target (tn-ref-target op)))
+ (when target
+ (let* ((load-tn (tn-ref-load-tn op))
+ (load-scs (svref (car scs)
+ (sc-number
+ (tn-sc (or load-tn (tn-ref-tn op)))))))
+ (if load-tn
+ (assert (eq load-scs t))
+ (unless (eq load-scs t)
+ (setf (tn-ref-load-tn op)
+ (pack-load-tn (car scs) op))))))))
+
+ (do ((scs scs (cdr scs))
+ (op ops (tn-ref-across op)))
+ ((null scs))
+ (let ((target (tn-ref-target op)))
+ (unless target
+ (let* ((load-tn (tn-ref-load-tn op))
+ (load-scs (svref (car scs)
+ (sc-number
+ (tn-sc (or load-tn (tn-ref-tn op)))))))
+ (if load-tn
+ (assert (eq load-scs t))
+ (unless (eq load-scs t)
+ (setf (tn-ref-load-tn op)
+ (pack-load-tn (car scs) op))))))))
+
+ (values))
+
+;;; Scan the VOPs in Block, looking for operands whose SC restrictions
+;;; aren't satisfied. We do the results first, since they are evaluated
+;;; later, and our conflict analysis is a backward scan.
+(defun pack-load-tns (block)
+ (catch 'unpacked-tn
+ (let ((*live-block* nil)
+ (*live-vop* nil))
+ (do ((vop (ir2-block-last-vop block) (vop-prev vop)))
+ ((null vop))
+ (let ((info (vop-info vop)))
+ (check-operand-restrictions (vop-info-result-load-scs info)
+ (vop-results vop))
+ (check-operand-restrictions (vop-info-arg-load-scs info)
+ (vop-args vop))))))
+ (values))
+\f
+;;;; location-selection, targeting & pack interface
+
+;;;; targeting
+
+;;; Link the TN-Refs Read and Write together using the TN-Ref-Target when
+;;; this seems like a good idea. Currently we always do, as this increases the
+;;; success of load-TN targeting.
+(defun target-if-desirable (read write)
+ (declare (type tn-ref read write))
+ (setf (tn-ref-target read) write)
+ (setf (tn-ref-target write) read))
+
+;;; If TN can be packed into SC so as to honor a preference to Target, then
+;;; return the offset to pack at, otherwise return NIL. Target must be already
+;;; packed. We can honor a preference if:
+;;; -- Target's location is in SC's locations.
+;;; -- The element sizes of the two SCs are the same.
+;;; -- TN doesn't conflict with target's location.
+(defun check-ok-target (target tn sc)
+ (declare (type tn target tn) (type sc sc) (inline member))
+ (let* ((loc (tn-offset target))
+ (target-sc (tn-sc target))
+ (target-sb (sc-sb target-sc)))
+ (declare (type index loc))
+ (if (and (eq target-sb (sc-sb sc))
+ (or (eq (sb-kind target-sb) :unbounded)
+ (member loc (sc-locations sc)))
+ (= (sc-element-size target-sc) (sc-element-size sc))
+ (not (conflicts-in-sc tn sc loc))
+ (zerop (mod loc (sc-alignment sc))))
+ loc
+ nil)))
+
+;;; Scan along the target path from TN, looking at readers or writers. When
+;;; we find a packed TN, return Check-OK-Target of that TN. If there is no
+;;; target, or if the TN has multiple readers (writers), then we return NIL.
+;;; We also always return NIL after 10 iterations to get around potential
+;;; circularity problems.
+(macrolet ((frob (slot)
+ `(let ((count 10)
+ (current tn))
+ (declare (type index count))
+ (loop
+ (let ((refs (,slot current)))
+ (unless (and (plusp count) refs (not (tn-ref-next refs)))
+ (return nil))
+ (let ((target (tn-ref-target refs)))
+ (unless target (return nil))
+ (setq current (tn-ref-tn target))
+ (when (tn-offset current)
+ (return (check-ok-target current tn sc)))
+ (decf count)))))))
+ (defun find-ok-target-offset (tn sc)
+ (declare (type tn tn) (type sc sc))
+ (or (frob tn-reads)
+ (frob tn-writes))))
+
+;;;; location selection
+
+;;; Select some location for TN in SC, returning the offset if we succeed,
+;;; and NIL if we fail. We start scanning at the Last-Offset in an attempt
+;;; to distribute the TNs across all storage.
+;;;
+;;; We call Offset-Conflicts-In-SB directly, rather than using Conflicts-In-SC.
+;;; This allows us to more efficient in packing multi-location TNs: we don't
+;;; have to multiply the number of tests by the TN size. This falls out
+;;; natually, since we have to be aware of TN size anyway so that we don't call
+;;; Conflicts-In-SC on a bogus offset.
+;;;
+;;; We give up on finding a location after our current pointer has wrapped
+;;; twice. This will result in testing some locations twice in the case that
+;;; we fail, but is simpler than trying to figure out the soonest failure
+;;; point.
+;;;
+;;; We also give up without bothering to wrap if the current size isn't large
+;;; enough to hold a single element of element-size without bothering to wrap.
+;;; If it doesn't fit this iteration, it won't fit next.
+;;;
+;;; ### Note that we actually try to pack as many consecutive TNs as possible
+;;; in the same location, since we start scanning at the same offset that the
+;;; last TN was successfully packed in. This is a weakening of the scattering
+;;; hueristic that was put in to prevent restricted VOP temps from hogging all
+;;; of the registers. This way, all of these temps probably end up in one
+;;; register.
+(defun select-location (tn sc &optional use-reserved-locs)
+ (declare (type tn tn) (type sc sc) (inline member))
+ (let* ((sb (sc-sb sc))
+ (element-size (sc-element-size sc))
+ (alignment (sc-alignment sc))
+ (align-mask (1- alignment))
+ (size (finite-sb-current-size sb))
+ (start-offset (finite-sb-last-offset sb)))
+ (let ((current-start
+ (logandc2 (the index (+ start-offset align-mask)) align-mask))
+ (wrap-p nil))
+ (declare (type index current-start))
+ (loop
+ (when (> (+ current-start element-size) size)
+ (cond ((or wrap-p (> element-size size))
+ (return nil))
+ (t
+ (setq current-start 0)
+ (setq wrap-p t))))
+
+ (if (or (eq (sb-kind sb) :unbounded)
+ (and (member current-start (sc-locations sc))
+ (or use-reserved-locs
+ (not (member current-start
+ (sc-reserve-locations sc))))))
+ (dotimes (i element-size
+ (return-from select-location current-start))
+ (declare (type index i))
+ (let ((offset (+ current-start i)))
+ (when (offset-conflicts-in-sb tn sb offset)
+ (setq current-start
+ (logandc2 (the index (+ (the index (1+ offset))
+ align-mask))
+ align-mask))
+ (return))))
+ (incf current-start alignment))))))
+
+;;; If a save TN, return the saved TN, otherwise return TN. Useful for
+;;; getting the conflicts of a TN that might be a save TN.
+(defun original-tn (tn)
+ (declare (type tn tn))
+ (if (member (tn-kind tn) '(:save :save-once :specified-save))
+ (tn-save-tn tn)
+ tn))
+
+;;;; pack interface
+
+;;; Attempt to pack TN in all possible SCs, first in the SC chosen by
+;;; representation selection, then in the alternate SCs in the order
+;;; they were specified in the SC definition. If the TN-COST is
+;;; negative, then we don't attempt to pack in SCs that must be saved.
+;;; If Restricted, then we can only pack in TN-SC, not in any
+;;; Alternate-SCs.
+;;;
+;;; If we are attempting to pack in the SC of the save TN for a TN
+;;; with a :SPECIFIED-SAVE TN, then we pack in that location, instead
+;;; of allocating a new stack location.
+(defun pack-tn (tn restricted)
+ (declare (type tn tn))
+ (let* ((original (original-tn tn))
+ (fsc (tn-sc tn))
+ (alternates (unless restricted (sc-alternate-scs fsc)))
+ (save (tn-save-tn tn))
+ (specified-save-sc
+ (when (and save
+ (eq (tn-kind save) :specified-save))
+ (tn-sc save))))
+
+ (do ((sc fsc (pop alternates)))
+ ((null sc)
+ (failed-to-pack-error tn restricted))
+ (when (eq sc specified-save-sc)
+ (unless (tn-offset save)
+ (pack-tn save nil))
+ (setf (tn-offset tn) (tn-offset save))
+ (setf (tn-sc tn) (tn-sc save))
+ (return))
+ (when (or restricted
+ (not (and (minusp (tn-cost tn)) (sc-save-p sc))))
+ (let ((loc (or (find-ok-target-offset original sc)
+ (select-location original sc)
+ (and restricted
+ (select-location original sc t))
+ (when (eq (sb-kind (sc-sb sc)) :unbounded)
+ (grow-sc sc)
+ (or (select-location original sc)
+ (error "Failed to pack after growing SC?"))))))
+ (when loc
+ (add-location-conflicts original sc loc)
+ (setf (tn-sc tn) sc)
+ (setf (tn-offset tn) loc)
+ (return))))))
+
+ (values))
+
+;;; Pack a wired TN, checking that the offset is in bounds for the SB, and
+;;; that the TN doesn't conflict with some other TN already packed in that
+;;; location. If the TN is wired to a location beyond the end of a :Unbounded
+;;; SB, then grow the SB enough to hold the TN.
+;;;
+;;; ### Checking for conflicts is disabled for :SPECIFIED-SAVE TNs. This is
+;;; kind of a hack to make specifying wired stack save locations for local call
+;;; arguments (such as OLD-FP) work, since the caller and callee OLD-FP save
+;;; locations may conflict when the save locations don't really (due to being
+;;; in different frames.)
+(defun pack-wired-tn (tn)
+ (declare (type tn tn))
+ (let* ((sc (tn-sc tn))
+ (sb (sc-sb sc))
+ (offset (tn-offset tn))
+ (end (+ offset (sc-element-size sc)))
+ (original (original-tn tn)))
+ (when (> end (finite-sb-current-size sb))
+ (unless (eq (sb-kind sb) :unbounded)
+ (error "~S is wired to a location that is out of bounds." tn))
+ (grow-sc sc end))
+
+ ;; For non-x86 ports the presence of a save-tn associated with a tn is used
+ ;; to identify the old-fp and return-pc tns. It depends on the old-fp and
+ ;; return-pc being passed in registers.
+ #!-x86
+ (when (and (not (eq (tn-kind tn) :specified-save))
+ (conflicts-in-sc original sc offset))
+ (error "~S is wired to a location that it conflicts with." tn))
+
+ ;; Use the above check, but only print a verbose warning. This can be
+ ;; helpful for debugging the x86 port.
+ #+nil
+ (when (and (not (eq (tn-kind tn) :specified-save))
+ (conflicts-in-sc original sc offset))
+ (format t "~&* Pack-wired-tn possible conflict:~% ~
+ tn: ~S; tn-kind: ~S~% ~
+ sc: ~S~% ~
+ sb: ~S; sb-name: ~S; sb-kind: ~S~% ~
+ offset: ~S; end: ~S~% ~
+ original ~S~% ~
+ tn-save-tn: ~S; tn-kind of tn-save-tn: ~S~%"
+ tn (tn-kind tn) sc
+ sb (sb-name sb) (sb-kind sb)
+ offset end
+ original
+ (tn-save-tn tn) (tn-kind (tn-save-tn tn))))
+
+ ;; On the x86 ports the old-fp and return-pc are often passed on the stack
+ ;; so the above hack for the other ports does not always work. Here the
+ ;; old-fp and return-pc tns are identified by being on the stack in their
+ ;; standard save locations.
+ #!+x86
+ (when (and (not (eq (tn-kind tn) :specified-save))
+ (not (and (string= (sb-name sb) "STACK")
+ (or (= offset 0)
+ (= offset 1))))
+ (conflicts-in-sc original sc offset))
+ (error "~S is wired to a location that it conflicts with." tn))
+
+ (add-location-conflicts original sc offset)))
+
+(defevent repack-block "Repacked a block due to TN unpacking.")
+
+(defun pack (component)
+ (assert (not *in-pack*))
+ (let ((*in-pack* t)
+ (optimize (policy nil (or (>= speed cspeed) (>= space cspeed))))
+ (2comp (component-info component)))
+ (init-sb-vectors component)
+
+ ;; Call the target functions.
+ (do-ir2-blocks (block component)
+ (do ((vop (ir2-block-start-vop block) (vop-next vop)))
+ ((null vop))
+ (let ((target-fun (vop-info-target-function (vop-info vop))))
+ (when target-fun
+ (funcall target-fun vop)))))
+
+
+ ;; Pack wired TNs first.
+ (do ((tn (ir2-component-wired-tns 2comp) (tn-next tn)))
+ ((null tn))
+ (pack-wired-tn tn))
+
+ ;; Pack restricted component TNs.
+ (do ((tn (ir2-component-restricted-tns 2comp) (tn-next tn)))
+ ((null tn))
+ (when (eq (tn-kind tn) :component)
+ (pack-tn tn t)))
+
+ ;; Pack other restricted TNs.
+ (do ((tn (ir2-component-restricted-tns 2comp) (tn-next tn)))
+ ((null tn))
+ (unless (tn-offset tn)
+ (pack-tn tn t)))
+
+ ;; Assign costs to normal TNs so we know which ones should always be
+ ;; packed on the stack.
+ (when (and optimize *pack-assign-costs*)
+ (assign-tn-costs component))
+
+ ;; Pack normal TNs in the order that they appear in the code. This
+ ;; should have some tendency to pack important TNs first, since control
+ ;; analysis favors the drop-through. This should also help targeting,
+ ;; since we will pack the target TN soon after we determine the location
+ ;; of the targeting TN.
+ (do-ir2-blocks (block component)
+ (let ((ltns (ir2-block-local-tns block)))
+ (do ((i (1- (ir2-block-local-tn-count block)) (1- i)))
+ ((minusp i))
+ (declare (fixnum i))
+ (let ((tn (svref ltns i)))
+ (unless (or (null tn) (eq tn :more) (tn-offset tn))
+ (pack-tn tn nil))))))
+
+ ;; Pack any leftover normal TNs. This is to deal with :MORE TNs, which
+ ;; could possibly not appear in any local TN map.
+ (do ((tn (ir2-component-normal-tns 2comp) (tn-next tn)))
+ ((null tn))
+ (unless (tn-offset tn)
+ (pack-tn tn nil)))
+
+ ;; Do load TN packing and emit saves.
+ (let ((*repack-blocks* nil))
+ (cond ((and optimize *pack-optimize-saves*)
+ (optimized-emit-saves component)
+ (do-ir2-blocks (block component)
+ (pack-load-tns block)))
+ (t
+ (do-ir2-blocks (block component)
+ (emit-saves block)
+ (pack-load-tns block))))
+ (when *repack-blocks*
+ (loop
+ (when (zerop (hash-table-count *repack-blocks*)) (return))
+ (maphash #'(lambda (block v)
+ (declare (ignore v))
+ (remhash block *repack-blocks*)
+ (event repack-block)
+ (pack-load-tns block))
+ *repack-blocks*)))))
+
+ (values))
--- /dev/null
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!C")
+
+(file-comment
+ "$Header$")
+
+;;; Break a lambda-list into its component parts. We return eleven
+;;; values:
+;;; 1. A list of the required args.
+;;; 2. A list of the optional arg specs.
+;;; 3. True if a rest arg was specified.
+;;; 4. The rest arg.
+;;; 5. A boolean indicating whether keywords args are present.
+;;; 6. A list of the keyword arg specs.
+;;; 7. True if &allow-other-keys was specified.
+;;; 8. A list of the &aux specifiers.
+;;; 9. True if a more arg was specified.
+;;; 10. The &more context var
+;;; 11. The &more count var
+;;;
+;;; The top-level lambda-list syntax is checked for validity, but the
+;;; arg specifiers are just passed through untouched. If something is
+;;; wrong, we use Compiler-Error, aborting compilation to the last
+;;; recovery point.
+(declaim (ftype (function (list)
+ (values list list boolean t boolean list boolean
+ list boolean t t))
+ parse-lambda-list))
+(defun parse-lambda-list (list)
+ (collect ((required)
+ (optional)
+ (keys)
+ (aux))
+ (let ((restp nil)
+ (rest nil)
+ (morep nil)
+ (more-context nil)
+ (more-count nil)
+ (keyp nil)
+ (allowp nil)
+ (state :required))
+ (declare (type (member :allow-other-keys :aux
+ :key
+ :more-context :more-count
+ :optional
+ :post-more :post-rest
+ :required :rest)
+ state))
+ (dolist (arg list)
+ (if (and (symbolp arg)
+ (let ((name (symbol-name arg)))
+ (and (plusp (length name))
+ (char= (char name 0) #\&))))
+ (case arg
+ (&optional
+ (unless (eq state :required)
+ (compiler-error "misplaced &OPTIONAL in lambda list: ~S"
+ list))
+ (setq state :optional))
+ (&rest
+ (unless (member state '(:required :optional))
+ (compiler-error "misplaced &REST in lambda list: ~S" list))
+ (setq state :rest))
+ (sb!c:&more
+ (unless (member state '(:required :optional))
+ (compiler-error "misplaced &MORE in lambda list: ~S" list))
+ (setq morep t
+ state :more-context))
+ (&key
+ (unless (member state
+ '(:required :optional :post-rest :post-more))
+ (compiler-error "misplaced &KEY in lambda list: ~S" list))
+ (setq keyp t
+ state :key))
+ (&allow-other-keys
+ (unless (eq state ':key)
+ (compiler-error "misplaced &ALLOW-OTHER-KEYS in ~
+ lambda list: ~S"
+ list))
+ (setq allowp t
+ state :allow-other-keys))
+ (&aux
+ (when (member state '(:rest :more-context :more-count))
+ (compiler-error "misplaced &AUX in lambda list: ~S" list))
+ (setq state :aux))
+ ;; FIXME: I don't think ANSI says this is an error. (It
+ ;; should certainly be good for a STYLE-WARNING,
+ ;; though.)
+ (t
+ (compiler-error "unknown &KEYWORD in lambda list: ~S" arg)))
+ (case state
+ (:required (required arg))
+ (:optional (optional arg))
+ (:rest
+ (setq restp t
+ rest arg
+ state :post-rest))
+ (:more-context
+ (setq more-context arg
+ state :more-count))
+ (:more-count
+ (setq more-count arg
+ state :post-more))
+ (:key (keys arg))
+ (:aux (aux arg))
+ (t
+ (compiler-error "found garbage in lambda list when expecting ~
+ a keyword: ~S"
+ arg)))))
+
+ (values (required) (optional) restp rest keyp (keys) allowp (aux)
+ morep more-context more-count))))
--- /dev/null
+;;;; This file contains load-time support for declaration processing.
+;;;; In CMU CL it was split off from the compiler so that the compiler
+;;;; doesn't have to be in the cold load, but in SBCL the compiler is
+;;;; in the cold load again, so this might not be valuable.
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!C")
+
+(file-comment
+ "$Header$")
+
+;;; !COLD-INIT calls this twice to initialize the cookies, once before
+;;; any toplevel forms are executed, then again to undo any lingering
+;;; effects of toplevel DECLAIMs.
+(!begin-collecting-cold-init-forms)
+(!cold-init-forms
+ (setf *default-cookie*
+ (make-cookie :safety 1
+ :speed 1
+ :space 1
+ :cspeed 1
+ :brevity 1
+ ;; Note: CMU CL had a default of 2 for DEBUG and 1 for all
+ ;; the other qualities. SBCL uses a default of 1 for every
+ ;; quality, because the ANSI documentation for the
+ ;; OPTIMIZE declaration says that 1 is "the neutral
+ ;; value", and it seems natural for the neutral value to
+ ;; be the default.
+ :debug 1))
+ (setf *default-interface-cookie*
+ (make-cookie)))
+(!defun-from-collected-cold-init-forms !set-sane-cookie-defaults)
+
+;;; A list of UNDEFINED-WARNING structures representing references to unknown
+;;; stuff which came up in a compilation unit.
+(defvar *undefined-warnings*)
+(declaim (list *undefined-warnings*))
+
+;;; Check that Name is a valid function name, returning the name if OK, and
+;;; doing an error if not. In addition to checking for basic well-formedness,
+;;; we also check that symbol names are not NIL or the name of a special form.
+(defun check-function-name (name)
+ (typecase name
+ (list
+ (unless (and (consp name) (consp (cdr name))
+ (null (cddr name)) (eq (car name) 'setf)
+ (symbolp (cadr name)))
+ (compiler-error "illegal function name: ~S" name))
+ name)
+ (symbol
+ (when (eq (info :function :kind name) :special-form)
+ (compiler-error "Special form is an illegal function name: ~S" name))
+ name)
+ (t
+ (compiler-error "illegal function name: ~S" name))))
+
+;;; Called to do something about SETF functions that overlap with SETF
+;;; macros. Perhaps we should interact with the user to see whether
+;;; the macro should be blown away, but for now just give a warning.
+;;; Due to the weak semantics of the (SETF FUNCTION) name, we can't
+;;; assume that they aren't just naming a function (SETF FOO) for the
+;;; heck of it. NAME is already known to be well-formed.
+(defun note-if-setf-function-and-macro (name)
+ (when (consp name)
+ (when (or (info :setf :inverse name)
+ (info :setf :expander name))
+ (compiler-style-warning
+ "defining as a SETF function a name that already has a SETF macro:~
+ ~% ~S"
+ name)))
+ (values))
+
+;;; Look up some symbols in *FREE-VARIABLES*, returning the var
+;;; structures for any which exist. If any of the names aren't
+;;; symbols, we complain.
+(declaim (ftype (function (list) list) get-old-vars))
+(defun get-old-vars (names)
+ (collect ((vars))
+ (dolist (name names (vars))
+ (unless (symbolp name)
+ (compiler-error "The name ~S is not a symbol." name))
+ (let ((old (gethash name *free-variables*)))
+ (when old (vars old))))))
+
+;;; Return a new cookie containing the policy information represented
+;;; by the optimize declaration SPEC. Any parameters not specified are
+;;; defaulted from COOKIE.
+(declaim (ftype (function (list cookie) cookie) process-optimize-declaration))
+(defun process-optimize-declaration (spec cookie)
+ (let ((res (copy-cookie cookie)))
+ (dolist (quality (cdr spec))
+ (let ((quality (if (atom quality) (list quality 3) quality)))
+ (if (and (consp (cdr quality)) (null (cddr quality))
+ (typep (second quality) 'real) (<= 0 (second quality) 3))
+ (let ((value (rational (second quality))))
+ (case (first quality)
+ (speed (setf (cookie-speed res) value))
+ (space (setf (cookie-space res) value))
+ (safety (setf (cookie-safety res) value))
+ (compilation-speed (setf (cookie-cspeed res) value))
+ ;; FIXME: BREVITY is an undocumented name for it,
+ ;; should go away. And INHIBIT-WARNINGS is a
+ ;; misleading name for it. Perhaps BREVITY would be
+ ;; better. But the ideal name would have connotations
+ ;; of suppressing only optimization-related notes,
+ ;; which I think is the behavior. Perhaps
+ ;; INHIBIT-NOTES?
+ ((inhibit-warnings brevity) (setf (cookie-brevity res) value))
+ ((debug-info debug) (setf (cookie-debug res) value))
+ (t
+ (compiler-warning "unknown optimization quality ~S in ~S"
+ (car quality) spec))))
+ (compiler-warning
+ "malformed optimization quality specifier ~S in ~S"
+ quality spec))))
+ res))
+
+(defun sb!xc:proclaim (form)
+ (unless (consp form)
+ (error "malformed PROCLAIM spec: ~S" form))
+ (let ((kind (first form))
+ (args (rest form)))
+ (case kind
+ (special
+ (dolist (name args)
+ (unless (symbolp name)
+ (error "can't declare a non-symbol as SPECIAL: ~S" name))
+ (clear-info :variable :constant-value name)
+ (setf (info :variable :kind name) :special)))
+ (type
+ (when *type-system-initialized*
+ (let ((type (specifier-type (first args))))
+ (dolist (name (rest args))
+ (unless (symbolp name)
+ (error "can't declare TYPE of a non-symbol: ~S" name))
+ (when (eq (info :variable :where-from name) :declared)
+ (let ((old-type (info :variable :type name)))
+ (when (type/= type old-type)
+ (style-warn "The new TYPE proclamation~% ~S~@
+ for ~S does not match the old TYPE~@
+ proclamation ~S"
+ type name old-type))))
+ (setf (info :variable :type name) type)
+ (setf (info :variable :where-from name) :declared)))))
+ (ftype
+ ;; FIXME: Since currently *TYPE-SYSTEM-INITIALIZED* is not set
+ ;; until many toplevel forms have run, this condition on
+ ;; PROCLAIM (FTYPE ..) (and on PROCLAIM (TYPE ..), above) means
+ ;; that valid PROCLAIMs in cold code could get lost. Probably
+ ;; the cleanest way to deal with this would be to initialize
+ ;; the type system completely in special cold init forms,
+ ;; before any ordinary toplevel forms run. Failing that, we
+ ;; could queue up PROCLAIMs to be done after the type system is
+ ;; initialized. Failing that, we could at least issue a warning
+ ;; when we have to ignore a PROCLAIM because the type system is
+ ;; uninitialized.
+ (when *type-system-initialized*
+ (let ((type (specifier-type (first args))))
+ (unless (csubtypep type (specifier-type 'function))
+ (error "not a function type: ~S" (first args)))
+ (dolist (name (rest args))
+ (cond ((info :function :accessor-for name)
+ (warn "ignoring FTYPE proclamation for slot accessor:~% ~S"
+ name))
+ (t
+
+ ;; KLUDGE: Something like the commented-out TYPE/=
+ ;; check here would be nice, but it has been
+ ;; commented out because TYPE/= doesn't support
+ ;; function types. It could probably be made to do
+ ;; so, but it might take some time, since function
+ ;; types involve values types, which aren't
+ ;; supported, and since the SUBTYPEP operator for
+ ;; FUNCTION types is rather broken, e.g.
+ ;; (SUBTYPEP '(FUNCTION (T BOOLEAN) NIL)
+ ;; '(FUNCTION (FIXNUM FIXNUM) NIL)) => T, T
+ ;; -- WHN 20000229
+ #+nil
+ (when (eq (info :function :where-from name) :declared)
+ (let ((old-type (info :function :type name)))
+ (when (type/= type old-type)
+ (style-warn "new FTYPE proclamation~@
+ ~S~@
+ for ~S does not match old FTYPE proclamation~@
+ ~S"
+ (list type name old-type)))))
+
+ (proclaim-as-function-name name)
+ (note-name-defined name :function)
+ (setf (info :function :type name) type
+ (info :function :where-from name) :declared)))))))
+ (freeze-type
+ (dolist (type args)
+ (let ((class (specifier-type type)))
+ (when (typep class 'class)
+ (setf (class-state class) :sealed)
+ (let ((subclasses (class-subclasses class)))
+ (when subclasses
+ (dohash (subclass layout subclasses)
+ (declare (ignore layout))
+ (setf (class-state subclass) :sealed))))))))
+ (optimize
+ (setq *default-cookie*
+ (process-optimize-declaration form *default-cookie*)))
+ (optimize-interface
+ (setq *default-interface-cookie*
+ (process-optimize-declaration form *default-interface-cookie*)))
+ ((inline notinline maybe-inline)
+ (dolist (name args)
+ (proclaim-as-function-name name)
+ (setf (info :function :inlinep name)
+ (case kind
+ (inline :inline)
+ (notinline :notinline)
+ (maybe-inline :maybe-inline)))))
+ (constant-function
+ (let ((info (make-function-info
+ :attributes (ir1-attributes movable foldable flushable
+ unsafe))))
+ (dolist (name args)
+ (proclaim-as-function-name name)
+ (setf (info :function :info name) info))))
+ (declaration
+ (dolist (decl args)
+ (unless (symbolp decl)
+ (error "The declaration to be recognized is not a symbol: ~S" decl))
+ (setf (info :declaration :recognized decl) t)))
+ (t
+ (cond ((member kind *standard-type-names*)
+ (sb!xc:proclaim `(type . ,form))) ; FIXME: ,@ instead of . ,
+ ((not (info :declaration :recognized kind))
+ (warn "unrecognized proclamation: ~S" form))))))
+ (values))
+
+;;; Keep the compiler from issuing warnings about SB!C::%%DEFMACRO
+;;; when it compiles code which expands into calls to the function
+;;; before it's actually compiled the function.
+;;;
+;;; (This can't be done in defmacro.lisp because PROCLAIM isn't
+;;; defined when defmacro.lisp is loaded.)
+#+sb-xc-host (sb!xc:proclaim '(ftype function sb!c::%%defmacro))
--- /dev/null
+;;;; This file contains definitions of VOPs used as internal markers by
+;;;; the compiler. Since they don't emit any code, they should be
+;;;; portable.
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!C")
+
+(file-comment
+ "$Header$")
+
+;;; This notes the place at which the environment is properly
+;;; initialized, for debug-info purposes.
+(define-vop (note-environment-start)
+ (:info start-lab)
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:generator 0
+ (emit-label start-lab)
+ (note-debug-location vop start-lab :non-local-entry)))
+
+;;; Call a move function. Used for register save/restore and spilling.
+(define-vop (move-operand)
+ (:args (x))
+ (:results (y))
+ (:info name)
+ (:vop-var vop)
+ (:generator 0
+ (funcall (symbol-function name) vop x y)))
--- /dev/null
+;;;; This file contains the implementation-independent code for the
+;;;; representation selection phase in the compiler. Representation
+;;;; selection decides whether to use non-descriptor representations
+;;;; for objects and emits the appropriate representation-specific move
+;;;; and coerce vops.
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!C")
+
+(file-comment
+ "$Header$")
+\f
+;;;; error routines
+;;;;
+;;;; Problems in the VM definition often show up here, so we try to be
+;;;; as implementor-friendly as possible.
+
+;;; Given a TN ref for a VOP argument or result, return these values:
+;;; 1. True if the operand is an argument, false otherwise.
+;;; 2. The ordinal position of the operand.
+;;; 3. True if the operand is a more operand, false otherwise.
+;;; 4. The costs for this operand.
+;;; 5. The load-scs vector for this operand (NIL if more-p.)
+;;; 6. True if the costs or SCs in the VOP-INFO are inconsistent with the
+;;; currently record ones.
+(defun get-operand-info (ref)
+ (declare (type tn-ref ref))
+ (let* ((arg-p (not (tn-ref-write-p ref)))
+ (vop (tn-ref-vop ref))
+ (info (vop-info vop)))
+ (flet ((frob (refs costs load more-cost)
+ (do ((refs refs (tn-ref-across refs))
+ (costs costs (cdr costs))
+ (load load (cdr load))
+ (n 0 (1+ n)))
+ ((null costs)
+ (assert more-cost)
+ (values arg-p
+ (+ n
+ (or (position-in #'tn-ref-across ref refs)
+ (error "couldn't find REF?"))
+ 1)
+ t
+ more-cost
+ nil
+ nil))
+ (when (eq refs ref)
+ (let ((parse (vop-parse-or-lose (vop-info-name info))))
+ (multiple-value-bind (ccosts cscs)
+ (compute-loading-costs
+ (elt (if arg-p
+ (vop-parse-args parse)
+ (vop-parse-results parse))
+ n)
+ arg-p)
+
+ (return
+ (values arg-p
+ (1+ n)
+ nil
+ (car costs)
+ (car load)
+ (not (and (equalp ccosts (car costs))
+ (equalp cscs (car load))))))))))))
+ (if arg-p
+ (frob (vop-args vop) (vop-info-arg-costs info)
+ (vop-info-arg-load-scs info)
+ (vop-info-more-arg-costs info))
+ (frob (vop-results vop) (vop-info-result-costs info)
+ (vop-info-result-load-scs info)
+ (vop-info-more-result-costs info))))))
+
+;;; Convert a load-costs vector to the list of SCs allowed by the operand
+;;; restriction.
+(defun listify-restrictions (restr)
+ (declare (type sc-vector restr))
+ (collect ((res))
+ (dotimes (i sc-number-limit)
+ (when (eq (svref restr i) t)
+ (res (svref *backend-sc-numbers* i))))
+ (res)))
+
+;;; Try to give a helpful error message when Ref has no cost specified for
+;;; some SC allowed by the TN's primitive-type.
+(defun bad-costs-error (ref)
+ (declare (type tn-ref ref))
+ (let* ((tn (tn-ref-tn ref))
+ (ptype (tn-primitive-type tn)))
+ (multiple-value-bind (arg-p pos more-p costs load-scs incon)
+ (get-operand-info ref)
+ (collect ((losers))
+ (dolist (scn (primitive-type-scs ptype))
+ (unless (svref costs scn)
+ (losers (svref *backend-sc-numbers* scn))))
+
+ (unless (losers)
+ (error "Representation selection flamed out for no obvious reason.~@
+ Try again after recompiling the VM definition."))
+
+ (error "~S is not valid as the ~:R ~:[result~;argument~] to the~@
+ ~S VOP, since the TN's primitive type ~S allows SCs:~% ~S~@
+ ~:[which cannot be coerced or loaded into the allowed SCs:~
+ ~% ~S~;~*~]~:[~;~@
+ Current cost info inconsistent with that in effect at compile ~
+ time. Recompile.~%Compilation order may be incorrect.~]"
+ tn pos arg-p
+ (template-name (vop-info (tn-ref-vop ref)))
+ (primitive-type-name ptype)
+ (mapcar #'sc-name (losers))
+ more-p
+ (unless more-p
+ (mapcar #'sc-name (listify-restrictions load-scs)))
+ incon)))))
+
+;;; Try to give a helpful error message when we fail to do a coercion
+;;; for some reason.
+(defun bad-coerce-error (op)
+ (declare (type tn-ref op))
+ (let* ((op-tn (tn-ref-tn op))
+ (op-sc (tn-sc op-tn))
+ (op-scn (sc-number op-sc))
+ (ptype (tn-primitive-type op-tn))
+ (write-p (tn-ref-write-p op)))
+ (multiple-value-bind (arg-p pos more-p costs load-scs incon)
+ (get-operand-info op)
+ (declare (ignore costs more-p))
+ (collect ((load-lose)
+ (no-move-scs)
+ (move-lose))
+ (dotimes (i sc-number-limit)
+ (let ((i-sc (svref *backend-sc-numbers* i)))
+ (when (eq (svref load-scs i) t)
+ (cond ((not (sc-allowed-by-primitive-type i-sc ptype))
+ (load-lose i-sc))
+ ((not (find-move-vop op-tn write-p i-sc ptype
+ #'sc-move-vops))
+ (let ((vops (if write-p
+ (svref (sc-move-vops op-sc) i)
+ (svref (sc-move-vops i-sc) op-scn))))
+ (if vops
+ (dolist (vop vops) (move-lose (template-name vop)))
+ (no-move-scs i-sc))))
+ (t
+ (error "Representation selection flamed out for no ~
+ obvious reason."))))))
+
+ (unless (or (load-lose) (no-move-scs) (move-lose))
+ (error "Representation selection flamed out for no obvious reason.~@
+ Try again after recompiling the VM definition."))
+
+ (error "~S is not valid as the ~:R ~:[result~;argument~] to VOP:~
+ ~% ~S~%Primitive type: ~S~@
+ SC restrictions:~% ~S~@
+ ~@[The primitive type disallows these loadable SCs:~% ~S~%~]~
+ ~@[No move VOPs are defined to coerce to these allowed SCs:~
+ ~% ~S~%~]~
+ ~@[These move VOPs couldn't be used due to operand type ~
+ restrictions:~% ~S~%~]~
+ ~:[~;~@
+ Current cost info inconsistent with that in effect at compile ~
+ time. Recompile.~%Compilation order may be incorrect.~]"
+ op-tn pos arg-p
+ (template-name (vop-info (tn-ref-vop op)))
+ (primitive-type-name ptype)
+ (mapcar #'sc-name (listify-restrictions load-scs))
+ (mapcar #'sc-name (load-lose))
+ (mapcar #'sc-name (no-move-scs))
+ (move-lose)
+ incon)))))
+
+(defun bad-move-arg-error (val pass)
+ (declare (type tn val pass))
+ (error "no :MOVE-ARGUMENT VOP defined to move ~S (SC ~S) to ~
+ ~S (SC ~S)"
+ val (sc-name (tn-sc val))
+ pass (sc-name (tn-sc pass))))
+\f
+;;;; VM consistency checking
+;;;;
+;;;; We do some checking of the consistency of the VM definition at load
+;;;; time.
+
+;;; FIXME: should probably be conditional on #!+SB-SHOW
+(defun check-move-function-consistency ()
+ (dotimes (i sc-number-limit)
+ (let ((sc (svref *backend-sc-numbers* i)))
+ (when sc
+ (let ((moves (sc-move-functions sc)))
+ (dolist (const (sc-constant-scs sc))
+ (unless (svref moves (sc-number const))
+ (warn "no move function defined to load SC ~S from constant ~
+ SC ~S"
+ (sc-name sc) (sc-name const))))
+
+ (dolist (alt (sc-alternate-scs sc))
+ (unless (svref moves (sc-number alt))
+ (warn "no move function defined to load SC ~S from alternate ~
+ SC ~S"
+ (sc-name sc) (sc-name alt)))
+ (unless (svref (sc-move-functions alt) i)
+ (warn "no move function defined to save SC ~S to alternate ~
+ SC ~S"
+ (sc-name sc) (sc-name alt)))))))))
+\f
+;;;; representation selection
+
+;;; VOPs that we ignore in initial cost computation. We ignore SET in the
+;;; hopes that nobody is setting specials inside of loops. We ignore
+;;; TYPE-CHECK-ERROR because we don't want the possibility of error to bias the
+;;; result. Notes are suppressed for T-C-E as well, since we don't need to
+;;; worry about the efficiency of that case.
+(defconstant ignore-cost-vops '(set type-check-error))
+(defconstant suppress-note-vops '(type-check-error))
+
+;;; We special-case the move VOP, since using this costs for the normal MOVE
+;;; would spuriously encourage descriptor representations. We won't actually
+;;; need to coerce to descriptor and back, since we will replace the MOVE with
+;;; a specialized move VOP. What we do is look at the other operand. If its
+;;; representation has already been chosen (e.g. if it is wired), then we use
+;;; the appropriate move costs, otherwise we just ignore the references.
+(defun add-representation-costs (refs scs costs
+ ops-slot costs-slot more-costs-slot
+ write-p)
+ (do ((ref refs (tn-ref-next ref)))
+ ((null ref))
+ (flet ((add-costs (cost)
+ (dolist (scn scs)
+ (let ((res (svref cost scn)))
+ (unless res
+ (bad-costs-error ref))
+ (incf (svref costs scn) res)))))
+ (let* ((vop (tn-ref-vop ref))
+ (info (vop-info vop)))
+ (case (vop-info-name info)
+ (#.ignore-cost-vops)
+ (move
+ (let ((rep (tn-sc
+ (tn-ref-tn
+ (if write-p
+ (vop-args vop)
+ (vop-results vop))))))
+ (when rep
+ (if write-p
+ (dolist (scn scs)
+ (let ((res (svref (sc-move-costs
+ (svref *backend-sc-numbers* scn))
+ (sc-number rep))))
+ (when res
+ (incf (svref costs scn) res))))
+ (dolist (scn scs)
+ (let ((res (svref (sc-move-costs rep) scn)))
+ (when res
+ (incf (svref costs scn) res))))))))
+ (t
+ (do ((cost (funcall costs-slot info) (cdr cost))
+ (op (funcall ops-slot vop) (tn-ref-across op)))
+ ((null cost)
+ (add-costs (funcall more-costs-slot info)))
+ (when (eq op ref)
+ (add-costs (car cost))
+ (return))))))))
+ (values))
+
+;;; Return the best representation for a normal TN. SCs is a list
+;;; of the SC numbers of the SCs to select from. Costs is a scratch
+;;; vector.
+;;;
+;;; What we do is sum the costs for each reference to TN in each of
+;;; the SCs, and then return the SC having the lowest cost. A second
+;;; value is returned which is true when the selection is unique which
+;;; is often not the case for the MOVE VOP.
+(defun select-tn-representation (tn scs costs)
+ (declare (type tn tn) (type sc-vector costs)
+ (inline add-representation-costs))
+ (dolist (scn scs)
+ (setf (svref costs scn) 0))
+
+ (add-representation-costs (tn-reads tn) scs costs
+ #'vop-args #'vop-info-arg-costs
+ #'vop-info-more-arg-costs
+ nil)
+ (add-representation-costs (tn-writes tn) scs costs
+ #'vop-results #'vop-info-result-costs
+ #'vop-info-more-result-costs
+ t)
+
+ (let ((min most-positive-fixnum)
+ (min-scn nil)
+ (unique nil))
+ (dolist (scn scs)
+ (let ((cost (svref costs scn)))
+ (cond ((= cost min)
+ (setf unique nil))
+ ((< cost min)
+ (setq min cost)
+ (setq min-scn scn)
+ (setq unique t)))))
+ (values (svref *backend-sc-numbers* min-scn) unique)))
+
+;;; Prepare for the possibility of a TN being allocated on the number stack by
+;;; setting NUMBER-STACK-P in all functions that TN is referenced in and in all
+;;; the functions in their tail sets. Refs is a TN-Refs list of references to
+;;; the TN.
+(defun note-number-stack-tn (refs)
+ (declare (type (or tn-ref null) refs))
+
+ (do ((ref refs (tn-ref-next ref)))
+ ((null ref))
+ (let* ((lambda (block-home-lambda
+ (ir2-block-block
+ (vop-block (tn-ref-vop ref)))))
+ (tails (lambda-tail-set lambda)))
+ (flet ((frob (fun)
+ (setf (ir2-environment-number-stack-p
+ (environment-info
+ (lambda-environment fun)))
+ t)))
+ (frob lambda)
+ (when tails
+ (dolist (fun (tail-set-functions tails))
+ (frob fun))))))
+
+ (values))
+
+;;; If TN is a variable, return the name. If TN is used by a VOP emitted
+;;; for a return, then return a string indicating this. Otherwise, return NIL.
+(defun get-operand-name (tn arg-p)
+ (declare (type tn tn))
+ (let* ((actual (if (eq (tn-kind tn) :alias) (tn-save-tn tn) tn))
+ (reads (tn-reads tn))
+ (leaf (tn-leaf actual)))
+ (cond ((lambda-var-p leaf) (leaf-name leaf))
+ ((and (not arg-p) reads
+ (return-p (vop-node (tn-ref-vop reads))))
+ "<return value>")
+ (t
+ nil))))
+
+;;; If policy indicates, give an efficiency note for doing the coercion
+;;; Vop, where Op is the operand we are coercing for and Dest-TN is the
+;;; distinct destination in a move.
+(defun do-coerce-efficiency-note (vop op dest-tn)
+ (declare (type vop-info vop) (type tn-ref op) (type (or tn null) dest-tn))
+ (let* ((note (or (template-note vop) (template-name vop)))
+ (cost (template-cost vop))
+ (op-vop (tn-ref-vop op))
+ (op-node (vop-node op-vop))
+ (op-tn (tn-ref-tn op))
+ (*compiler-error-context* op-node))
+ (cond ((eq (tn-kind op-tn) :constant))
+ ((policy op-node (<= speed brevity) (<= space brevity)))
+ ((member (template-name (vop-info op-vop)) suppress-note-vops))
+ ((null dest-tn)
+ (let* ((op-info (vop-info op-vop))
+ (op-note (or (template-note op-info)
+ (template-name op-info)))
+ (arg-p (not (tn-ref-write-p op)))
+ (name (get-operand-name op-tn arg-p))
+ (pos (1+ (or (position-in #'tn-ref-across op
+ (if arg-p
+ (vop-args op-vop)
+ (vop-results op-vop)))
+ (error "couldn't find op? bug!")))))
+ (compiler-note
+ "doing ~A (cost ~D)~:[~2*~; ~:[to~;from~] ~S~], for:~%~6T~
+ the ~:R ~:[result~;argument~] of ~A"
+ note cost name arg-p name
+ pos arg-p op-note)))
+ (t
+ (compiler-note "doing ~A (cost ~D)~@[ from ~S~]~@[ to ~S~]"
+ note cost (get-operand-name op-tn t)
+ (get-operand-name dest-tn nil)))))
+ (values))
+
+;;; Find a move VOP to move from the operand OP-TN to some other
+;;; representation corresponding to OTHER-SC and OTHER-PTYPE. Slot is the SC
+;;; slot that we grab from (move or move-argument). Write-P indicates that OP
+;;; is a VOP result, so OP is the move result and other is the arg, otherwise
+;;; OP is the arg and other is the result.
+;;;
+;;; If an operand is of primitive type T, then we use the type of the other
+;;; operand instead, effectively intersecting the argument and result type
+;;; assertions. This way, a move VOP can restrict whichever operand makes more
+;;; sense, without worrying about which operand has the type info.
+(defun find-move-vop (op-tn write-p other-sc other-ptype slot)
+ (declare (type tn op-tn) (type sc other-sc)
+ (type primitive-type other-ptype)
+ (type function slot))
+ (let* ((op-sc (tn-sc op-tn))
+ (op-scn (sc-number op-sc))
+ (other-scn (sc-number other-sc))
+ (any-ptype *backend-t-primitive-type*)
+ (op-ptype (tn-primitive-type op-tn)))
+ (let ((other-ptype (if (eq other-ptype any-ptype) op-ptype other-ptype))
+ (op-ptype (if (eq op-ptype any-ptype) other-ptype op-ptype)))
+ (dolist (info (if write-p
+ (svref (funcall slot op-sc) other-scn)
+ (svref (funcall slot other-sc) op-scn))
+ nil)
+ (when (and (operand-restriction-ok
+ (first (template-arg-types info))
+ (if write-p other-ptype op-ptype)
+ :tn op-tn :t-ok nil)
+ (operand-restriction-ok
+ (first (template-result-types info))
+ (if write-p op-ptype other-ptype)
+ :t-ok nil))
+ (return info))))))
+
+;;; Emit a coercion VOP for Op Before the specifed VOP or die trying. SCS
+;;; is the operand's LOAD-SCS vector, which we use to determine what SCs the
+;;; VOP will accept. We pick any acceptable coerce VOP, since it practice it
+;;; seems uninteresting to have more than one applicable.
+;;;
+;;; On the X86 port, stack SCs may be placed in the list of operand
+;;; preferred SCs, and to prevent these stack SCs being selected when
+;;; a register SC is available the non-stack SCs are searched first.
+;;;
+;;; What we do is look at each SC allowed by both the operand restriction
+;;; and the operand primitive-type, and see whether there is a move VOP
+;;; which moves between the operand's SC and load SC. If we find such a
+;;; VOP, then we make a TN having the load SC as the representation.
+;;;
+;;; Dest-TN is the TN that we are moving to, for a move or move-arg. This
+;;; is only for efficiency notes.
+;;;
+;;; If the TN is an unused result TN, then we don't actually emit the move;
+;;; we just change to the right kind of TN.
+(defun emit-coerce-vop (op dest-tn scs before)
+ (declare (type tn-ref op) (type sc-vector scs) (type (or vop null) before)
+ (type (or tn null) dest-tn))
+ (let* ((op-tn (tn-ref-tn op))
+ (ptype (tn-primitive-type op-tn))
+ (write-p (tn-ref-write-p op))
+ (vop (tn-ref-vop op))
+ (node (vop-node vop))
+ (block (vop-block vop)))
+ (flet ((check-sc (scn sc)
+ (when (sc-allowed-by-primitive-type sc ptype)
+ (let ((res (find-move-vop op-tn write-p sc ptype
+ #'sc-move-vops)))
+ (when res
+ (when (>= (vop-info-cost res)
+ *efficiency-note-cost-threshold*)
+ (do-coerce-efficiency-note res op dest-tn))
+ (let ((temp (make-representation-tn ptype scn)))
+ (change-tn-ref-tn op temp)
+ (cond
+ ((not write-p)
+ (emit-move-template node block res op-tn temp before))
+ ((and (null (tn-reads op-tn))
+ (eq (tn-kind op-tn) :normal)))
+ (t
+ (emit-move-template node block res temp op-tn
+ before))))
+ t)))))
+ ;; Search the non-stack load SCs first.
+ (dotimes (scn sc-number-limit)
+ (let ((sc (svref *backend-sc-numbers* scn)))
+ (when (and (eq (svref scs scn) t)
+ (not (eq (sb-kind (sc-sb sc)) :unbounded))
+ (check-sc scn sc))
+ (return-from emit-coerce-vop))))
+ ;; Search the stack SCs if the above failed.
+ (dotimes (scn sc-number-limit (bad-coerce-error op))
+ (let ((sc (svref *backend-sc-numbers* scn)))
+ (when (and (eq (svref scs scn) t)
+ (eq (sb-kind (sc-sb sc)) :unbounded)
+ (check-sc scn sc))
+ (return)))))))
+
+;;; Scan some operands and call EMIT-COERCE-VOP on any for which we can't
+;;; load the operand. The coerce VOP is inserted Before the specified VOP.
+;;; Dest-TN is the destination TN if we are doing a move or move-arg, and is
+;;; NIL otherwise. This is only used for efficiency notes.
+#!-sb-fluid (declaim (inline coerce-some-operands))
+(defun coerce-some-operands (ops dest-tn load-scs before)
+ (declare (type (or tn-ref null) ops) (list load-scs)
+ (type (or tn null) dest-tn) (type (or vop null) before))
+ (do ((op ops (tn-ref-across op))
+ (scs load-scs (cdr scs)))
+ ((null scs))
+ (unless (svref (car scs)
+ (sc-number (tn-sc (tn-ref-tn op))))
+ (emit-coerce-vop op dest-tn (car scs) before)))
+ (values))
+
+;;; Emit coerce VOPs for the args and results, as needed.
+(defun coerce-vop-operands (vop)
+ (declare (type vop vop))
+ (let ((info (vop-info vop)))
+ (coerce-some-operands (vop-args vop) nil (vop-info-arg-load-scs info) vop)
+ (coerce-some-operands (vop-results vop) nil (vop-info-result-load-scs info)
+ (vop-next vop)))
+ (values))
+
+;;; Iterate over the more operands to a call VOP, emitting move-arg VOPs and
+;;; any necessary coercions. We determine which FP to use by looking at the
+;;; MOVE-ARGS annotation. If the vop is a :LOCAL-CALL, we insert any needed
+;;; coercions before the ALLOCATE-FRAME so that lifetime analysis doesn't get
+;;; confused (since otherwise, only passing locations are written between A-F
+;;; and call.)
+(defun emit-arg-moves (vop)
+ (let* ((info (vop-info vop))
+ (node (vop-node vop))
+ (block (vop-block vop))
+ (how (vop-info-move-args info))
+ (args (vop-args vop))
+ (fp-tn (tn-ref-tn args))
+ (nfp-tn (if (eq how :local-call)
+ (tn-ref-tn (tn-ref-across args))
+ nil))
+ (pass-locs (first (vop-codegen-info vop)))
+ (prev (vop-prev vop)))
+ (do ((val (do ((arg args (tn-ref-across arg))
+ (req (template-arg-types info) (cdr req)))
+ ((null req) arg))
+ (tn-ref-across val))
+ (pass pass-locs (cdr pass)))
+ ((null val)
+ (assert (null pass)))
+ (let* ((val-tn (tn-ref-tn val))
+ (pass-tn (first pass))
+ (pass-sc (tn-sc pass-tn))
+ (res (find-move-vop val-tn nil pass-sc
+ (tn-primitive-type pass-tn)
+ #'sc-move-arg-vops)))
+ (unless res
+ (bad-move-arg-error val-tn pass-tn))
+
+ (change-tn-ref-tn val pass-tn)
+ (let* ((this-fp
+ (cond ((not (sc-number-stack-p pass-sc)) fp-tn)
+ (nfp-tn)
+ (t
+ (assert (eq how :known-return))
+ (setq nfp-tn (make-number-stack-pointer-tn))
+ (setf (tn-sc nfp-tn)
+ (svref *backend-sc-numbers*
+ (first (primitive-type-scs
+ (tn-primitive-type nfp-tn)))))
+ (emit-context-template
+ node block
+ (template-or-lose 'compute-old-nfp)
+ nfp-tn vop)
+ (assert (not (sc-number-stack-p (tn-sc nfp-tn))))
+ nfp-tn)))
+ (new (emit-move-arg-template node block res val-tn this-fp
+ pass-tn vop))
+ (after
+ (cond ((eq how :local-call)
+ (assert (eq (vop-info-name (vop-info prev))
+ 'allocate-frame))
+ prev)
+ (prev (vop-next prev))
+ (t
+ (ir2-block-start-vop block)))))
+ (coerce-some-operands (vop-args new) pass-tn
+ (vop-info-arg-load-scs res)
+ after)))))
+ (values))
+
+;;; Scan the IR2 looking for move operations that need to be replaced with
+;;; special-case VOPs and emitting coercion VOPs for operands of normal VOPs.
+;;; We delete moves to TNs that are never read at this point, rather than
+;;; possibly converting them to some expensive move operation.
+(defun emit-moves-and-coercions (block)
+ (declare (type ir2-block block))
+ (do ((vop (ir2-block-start-vop block)
+ (vop-next vop)))
+ ((null vop))
+ (let ((info (vop-info vop))
+ (node (vop-node vop))
+ (block (vop-block vop)))
+ (cond
+ ((eq (vop-info-name info) 'move)
+ (let* ((args (vop-args vop))
+ (x (tn-ref-tn args))
+ (y (tn-ref-tn (vop-results vop)))
+ (res (find-move-vop x nil (tn-sc y) (tn-primitive-type y)
+ #'sc-move-vops)))
+ (cond ((and (null (tn-reads y))
+ (eq (tn-kind y) :normal))
+ (delete-vop vop))
+ ((eq res info))
+ (res
+ (when (>= (vop-info-cost res)
+ *efficiency-note-cost-threshold*)
+ (do-coerce-efficiency-note res args y))
+ (emit-move-template node block res x y vop)
+ (delete-vop vop))
+ (t
+ (coerce-vop-operands vop)))))
+ ((vop-info-move-args info)
+ (emit-arg-moves vop))
+ (t
+ (coerce-vop-operands vop))))))
+
+;;; If TN is in a number stack SC, make all the right annotations. Note
+;;; that this should be called after TN has been referenced, since it must
+;;; iterate over the referencing environments.
+#!-sb-fluid (declaim (inline note-if-number-stack))
+(defun note-if-number-stack (tn 2comp restricted)
+ (declare (type tn tn) (type ir2-component 2comp))
+ (when (if restricted
+ (eq (sb-name (sc-sb (tn-sc tn))) 'non-descriptor-stack)
+ (sc-number-stack-p (tn-sc tn)))
+ (unless (ir2-component-nfp 2comp)
+ (setf (ir2-component-nfp 2comp) (make-nfp-tn)))
+ (note-number-stack-tn (tn-reads tn))
+ (note-number-stack-tn (tn-writes tn)))
+ (values))
+
+;;; Entry to representation selection. First we select the representation for
+;;; all normal TNs, setting the TN-SC. After selecting the TN representations,
+;;; we set the SC for all :ALIAS TNs to be the representation chosen for the
+;;; original TN. We then scan all the IR2, emitting any necessary coerce and
+;;; move-arg VOPs. Finally, we scan all TNs looking for ones that might be
+;;; placed on the number stack, noting this so that the number-FP can be
+;;; allocated. This must be done last, since references in new environments may
+;;; be introduced by MOVE-ARG insertion.
+(defun select-representations (component)
+ (let ((costs (make-array sc-number-limit))
+ (2comp (component-info component)))
+
+ ;; First pass; only allocate SCs where there is a distinct choice.
+ (do ((tn (ir2-component-normal-tns 2comp)
+ (tn-next tn)))
+ ((null tn))
+ (assert (tn-primitive-type tn))
+ (unless (tn-sc tn)
+ (let* ((scs (primitive-type-scs (tn-primitive-type tn))))
+ (cond ((rest scs)
+ (multiple-value-bind (sc unique)
+ (select-tn-representation tn scs costs)
+ (when unique
+ (setf (tn-sc tn) sc))))
+ (t
+ (setf (tn-sc tn)
+ (svref *backend-sc-numbers* (first scs))))))))
+
+ (do ((tn (ir2-component-normal-tns 2comp)
+ (tn-next tn)))
+ ((null tn))
+ (assert (tn-primitive-type tn))
+ (unless (tn-sc tn)
+ (let* ((scs (primitive-type-scs (tn-primitive-type tn)))
+ (sc (if (rest scs)
+ (select-tn-representation tn scs costs)
+ (svref *backend-sc-numbers* (first scs)))))
+ (assert sc)
+ (setf (tn-sc tn) sc))))
+
+ (do ((alias (ir2-component-alias-tns 2comp)
+ (tn-next alias)))
+ ((null alias))
+ (setf (tn-sc alias) (tn-sc (tn-save-tn alias))))
+
+ (do-ir2-blocks (block component)
+ (emit-moves-and-coercions block))
+
+ (macrolet ((frob (slot restricted)
+ `(do ((tn (,slot 2comp) (tn-next tn)))
+ ((null tn))
+ (note-if-number-stack tn 2comp ,restricted))))
+ (frob ir2-component-normal-tns nil)
+ (frob ir2-component-wired-tns t)
+ (frob ir2-component-restricted-tns t)))
+
+ (values))
--- /dev/null
+;;;; optimizations for SAP operations
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!C")
+
+(file-comment
+ "$Header$")
+\f
+;;;; DEFKNOWNs
+
+(defknown foreign-symbol-address (simple-string) system-area-pointer
+ (movable flushable))
+
+(defknown (sap< sap<= sap= sap>= sap>)
+ (system-area-pointer system-area-pointer) boolean
+ (movable flushable))
+
+(defknown sap+ (system-area-pointer integer) system-area-pointer
+ (movable flushable))
+(defknown sap- (system-area-pointer system-area-pointer) (signed-byte 32)
+ (movable flushable))
+
+(defknown sap-int (system-area-pointer) (unsigned-byte #!-alpha 32 #!+alpha 64)
+ (movable flushable))
+(defknown int-sap ((unsigned-byte #!-alpha 32 #!+alpha 64))
+ system-area-pointer (movable))
+
+(defknown sap-ref-8 (system-area-pointer fixnum) (unsigned-byte 8)
+ (flushable))
+(defknown %set-sap-ref-8 (system-area-pointer fixnum (unsigned-byte 8))
+ (unsigned-byte 8)
+ ())
+
+(defknown sap-ref-16 (system-area-pointer fixnum) (unsigned-byte 16)
+ (flushable))
+(defknown %set-sap-ref-16 (system-area-pointer fixnum (unsigned-byte 16))
+ (unsigned-byte 16)
+ ())
+
+(defknown sap-ref-32 (system-area-pointer fixnum) (unsigned-byte 32)
+ (flushable))
+(defknown %set-sap-ref-32 (system-area-pointer fixnum (unsigned-byte 32))
+ (unsigned-byte 32)
+ ())
+
+#!+alpha
+(defknown sap-ref-64 (system-area-pointer fixnum) (unsigned-byte 64)
+ (flushable))
+#!+alpha
+(defknown %set-sap-ref-64 (system-area-pointer fixnum (unsigned-byte 64))
+ (unsigned-byte 64)
+ ())
+
+(defknown signed-sap-ref-8 (system-area-pointer fixnum) (signed-byte 8)
+ (flushable))
+(defknown %set-signed-sap-ref-8 (system-area-pointer fixnum (signed-byte 8))
+ (signed-byte 8)
+ ())
+
+(defknown signed-sap-ref-16 (system-area-pointer fixnum) (signed-byte 16)
+ (flushable))
+(defknown %set-signed-sap-ref-16 (system-area-pointer fixnum (signed-byte 16))
+ (signed-byte 16)
+ ())
+
+(defknown signed-sap-ref-32 (system-area-pointer fixnum) (signed-byte 32)
+ (flushable))
+(defknown %set-signed-sap-ref-32 (system-area-pointer fixnum (signed-byte 32))
+ (signed-byte 32)
+ ())
+
+#!+alpha
+(defknown signed-sap-ref-64 (system-area-pointer fixnum) (signed-byte 64)
+ (flushable))
+#!+alpha
+(defknown %set-signed-sap-ref-64 (system-area-pointer fixnum (signed-byte 64))
+ (signed-byte 64)
+ ())
+
+(defknown sap-ref-sap (system-area-pointer fixnum) system-area-pointer
+ (flushable))
+(defknown %set-sap-ref-sap (system-area-pointer fixnum system-area-pointer)
+ system-area-pointer
+ ())
+
+(defknown sap-ref-single (system-area-pointer fixnum) single-float
+ (flushable))
+(defknown sap-ref-double (system-area-pointer fixnum) double-float
+ (flushable))
+#!+(or x86 long-float)
+(defknown sap-ref-long (system-area-pointer fixnum) long-float
+ (flushable))
+
+(defknown %set-sap-ref-single
+ (system-area-pointer fixnum single-float) single-float
+ ())
+(defknown %set-sap-ref-double
+ (system-area-pointer fixnum double-float) double-float
+ ())
+#!+long-float
+(defknown %set-sap-ref-long
+ (system-area-pointer fixnum long-float) long-float
+ ())
+\f
+;;;; transforms for converting sap relation operators
+
+(dolist (info '((sap< <) (sap<= <=) (sap= =) (sap>= >=) (sap> >)))
+ (destructuring-bind (sap-fun int-fun) info
+ (deftransform sap-fun ((x y) '* '* :eval-name t)
+ `(,int-fun (sap-int x) (sap-int y)))))
+\f
+;;;; transforms for optimizing SAP+
+
+(deftransform sap+ ((sap offset))
+ (cond ((and (constant-continuation-p offset)
+ (eql (continuation-value offset) 0))
+ 'sap)
+ (t
+ (extract-function-args sap 'sap+ 2)
+ '(lambda (sap offset1 offset2)
+ (sap+ sap (+ offset1 offset2))))))
+
+(dolist (fun '(sap-ref-8 %set-sap-ref-8
+ signed-sap-ref-8 %set-signed-sap-ref-8
+ sap-ref-16 %set-sap-ref-16
+ signed-sap-ref-16 %set-signed-sap-ref-16
+ sap-ref-32 %set-sap-ref-32
+ signed-sap-ref-32 %set-signed-sap-ref-32
+ sap-ref-sap %set-sap-ref-sap
+ sap-ref-single %set-sap-ref-single
+ sap-ref-double %set-sap-ref-double
+ #!+(or x86 long-float) sap-ref-long
+ #!+long-float %set-sap-ref-long))
+ (deftransform fun ((sap offset) '* '* :eval-name t)
+ (extract-function-args sap 'sap+ 2)
+ `(lambda (sap offset1 offset2)
+ (,fun sap (+ offset1 offset2)))))
--- /dev/null
+;;;; optimizers for list and sequence functions
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!C")
+
+(file-comment
+ "$Header$")
+\f
+;;;; mapping onto lists: the MAPFOO functions
+
+(defun mapfoo-transform (fn arglists accumulate take-car)
+ (collect ((do-clauses)
+ (args-to-fn)
+ (tests))
+ (let ((n-first (gensym)))
+ (dolist (a (if accumulate
+ arglists
+ `(,n-first ,@(rest arglists))))
+ (let ((v (gensym)))
+ (do-clauses `(,v ,a (cdr ,v)))
+ (tests `(endp ,v))
+ (args-to-fn (if take-car `(car ,v) v))))
+
+ (let ((call `(funcall ,fn . ,(args-to-fn)))
+ (endtest `(or ,@(tests))))
+ (ecase accumulate
+ (:nconc
+ (let ((temp (gensym))
+ (map-result (gensym)))
+ `(let ((,map-result (list nil)))
+ (do-anonymous ((,temp ,map-result) . ,(do-clauses))
+ (,endtest (cdr ,map-result))
+ (setq ,temp (last (nconc ,temp ,call)))))))
+ (:list
+ (let ((temp (gensym))
+ (map-result (gensym)))
+ `(let ((,map-result (list nil)))
+ (do-anonymous ((,temp ,map-result) . ,(do-clauses))
+ (,endtest (cdr ,map-result))
+ (rplacd ,temp (setq ,temp (list ,call)))))))
+ ((nil)
+ `(let ((,n-first ,(first arglists)))
+ (do-anonymous ,(do-clauses)
+ (,endtest ,n-first) ,call))))))))
+
+(def-source-transform mapc (function list &rest more-lists)
+ (mapfoo-transform function (cons list more-lists) nil t))
+
+(def-source-transform mapcar (function list &rest more-lists)
+ (mapfoo-transform function (cons list more-lists) :list t))
+
+(def-source-transform mapcan (function list &rest more-lists)
+ (mapfoo-transform function (cons list more-lists) :nconc t))
+
+(def-source-transform mapl (function list &rest more-lists)
+ (mapfoo-transform function (cons list more-lists) nil nil))
+
+(def-source-transform maplist (function list &rest more-lists)
+ (mapfoo-transform function (cons list more-lists) :list nil))
+
+(def-source-transform mapcon (function list &rest more-lists)
+ (mapfoo-transform function (cons list more-lists) :nconc nil))
+\f
+;;;; mapping onto sequences: the MAP function
+
+;;; Try to compile MAP efficiently when we can determine sequence
+;;; argument types at compile time.
+;;;
+;;; Note: This transform was written to allow open coding of
+;;; quantifiers by expressing them in terms of (MAP NIL ..). For
+;;; non-NIL values of RESULT-TYPE, it's still useful, but not
+;;; necessarily as efficient as possible. In particular, it will be
+;;; inefficient when RESULT-TYPE is a SIMPLE-ARRAY with specialized
+;;; numeric element types. It should be straightforward to make it
+;;; handle that case more efficiently, but it's left as an exercise to
+;;; the reader, because the code is complicated enough already and I
+;;; don't happen to need that functionality right now. -- WHN 20000410
+;;;
+;;; FIXME: Now that we have this transform, we should be able
+;;; to get rid of the macros MAP-TO-LIST, MAP-TO-SIMPLE,
+;;; and MAP-FOR-EFFECT.
+(deftransform map ((result-type fun &rest seqs) * *)
+ "open code"
+ (unless seqs (abort-ir1-transform "no sequence args"))
+ (unless (constant-continuation-p result-type)
+ (give-up-ir1-transform "RESULT-TYPE argument not constant"))
+ (labels (;; 1-valued SUBTYPEP, fails unless second value of SUBTYPEP is true
+ (fn-1subtypep (fn x y)
+ (multiple-value-bind (subtype-p valid-p) (funcall fn x y)
+ (if valid-p
+ subtype-p
+ (give-up-ir1-transform
+ "can't analyze sequence type relationship"))))
+ (1subtypep (x y) (fn-1subtypep #'sb!xc:subtypep x y))
+ (1csubtypep (x y) (fn-1subtypep #'csubtypep x y))
+ (seq-supertype (seq)
+ (let ((ctype (continuation-type seq)))
+ (cond ((1csubtypep ctype (specifier-type 'vector)) 'vector)
+ ((1csubtypep ctype (specifier-type 'list)) 'list)
+ (t
+ (give-up-ir1-transform
+ "can't determine sequence argument type"))))))
+ (let* ((result-type-value (continuation-value result-type))
+ (result-supertype (cond ((null result-type-value) 'null)
+ ((1subtypep result-type-value 'vector)
+ 'vector)
+ ((1subtypep result-type-value 'list)
+ 'list)
+ (t
+ (give-up-ir1-transform
+ "can't determine result type"))))
+ (seq-supertypes (mapcar #'seq-supertype seqs)))
+ (cond ((and result-type-value (= 1 (length seqs)))
+ ;; The consing arity-1 cases can be implemented
+ ;; reasonably efficiently as function calls, and the cost
+ ;; of consing should be significantly larger than
+ ;; function call overhead, so we always compile these
+ ;; cases as full calls regardless of speed-versus-space
+ ;; optimization policy.
+ (cond ((subtypep 'list result-type-value)
+ '(apply #'%map-to-list-arity-1 fun seqs))
+ (;; (This one can be inefficient due to COERCE, but
+ ;; the current open-coded implementation has the
+ ;; same problem.)
+ (subtypep result-type-value 'vector)
+ `(coerce (apply #'%map-to-simple-vector-arity-1 fun seqs)
+ ',result-type-value))
+ (t (give-up-ir1-transform
+ "internal error: unexpected sequence type"))))
+ (t
+ (let* ((seq-args (mapcar (lambda (seq)
+ (declare (ignore seq))
+ (gensym "SEQ"))
+ seqs))
+ (index-bindingoids
+ (mapcar (lambda (seq-arg seq-supertype)
+ (let ((i (gensym "I")))
+ (ecase seq-supertype
+ (vector `(,i 0 (1+ ,i)))
+ (list `(,i ,seq-arg (rest ,i))))))
+ seq-args seq-supertypes))
+ (indices (mapcar #'first index-bindingoids))
+ (index-decls (mapcar (lambda (index seq-supertype)
+ `(type ,(ecase seq-supertype
+ (vector 'index)
+ (list 'list))
+ ,index))
+ indices seq-supertypes))
+ (tests (mapcar (lambda (seq-arg seq-supertype index)
+ (ecase seq-supertype
+ (vector `(>= ,index (length ,seq-arg)))
+ (list `(endp ,index))))
+ seq-args seq-supertypes indices))
+ (values (mapcar (lambda (seq-arg seq-supertype index)
+ (ecase seq-supertype
+ (vector `(aref ,seq-arg ,index))
+ (list `(first ,index))))
+ seq-args seq-supertypes indices)))
+ (multiple-value-bind (push-dacc final-result)
+ (ecase result-supertype
+ (null (values nil nil))
+ (list (values `(push dacc acc) `(nreverse acc)))
+ (vector (values `(push dacc acc)
+ `(coerce (nreverse acc)
+ ',result-type-value))))
+ ;; (We use the same idiom, of returning a LAMBDA from
+ ;; DEFTRANSFORM, as is used in the DEFTRANSFORMs for
+ ;; FUNCALL and ALIEN-FUNCALL, and for the same
+ ;; reason: we need to get the runtime values of each
+ ;; of the &REST vars.)
+ `(lambda (result-type fun ,@seq-args)
+ (declare (ignore result-type))
+ (do ((really-fun (if (functionp fun)
+ fun
+ (%coerce-name-to-function fun)))
+ ,@index-bindingoids
+ (acc nil))
+ ((or ,@tests)
+ ,final-result)
+ (declare ,@index-decls)
+ (declare (type list acc))
+ (declare (ignorable acc))
+ (let ((dacc (funcall really-fun ,@values)))
+ (declare (ignorable dacc))
+ ,push-dacc))))))))))
+\f
+(deftransform elt ((s i) ((simple-array * (*)) *) * :when :both)
+ '(aref s i))
+
+(deftransform elt ((s i) (list *) * :when :both)
+ '(nth i s))
+
+(deftransform %setelt ((s i v) ((simple-array * (*)) * *) * :when :both)
+ '(%aset s i v))
+
+(deftransform %setelt ((s i v) (list * *))
+ '(setf (car (nthcdr i s)) v))
+
+;;; FIXME: I still think (DOLIST (..) (DEFTRANSFORM ..)) is weird.
+;;; For that matter, it would be nice to use DEF-FROB for these
+;;; sorts of things, so folks looking for the definitions of
+;;; FOO can search for '\(def.*\<foo\>' and have a chance in hell..
+(dolist (name '(member memq))
+ (deftransform name ((e l &key (test #'eql)) '* '* :node node :when :both
+ :eval-name t)
+ (unless (constant-continuation-p l)
+ (give-up-ir1-transform))
+
+ (let ((val (continuation-value l)))
+ (unless (policy node
+ (or (= speed 3)
+ (and (>= speed space)
+ (<= (length val) 5))))
+ (give-up-ir1-transform))
+
+ (labels ((frob (els)
+ (if els
+ `(if (funcall test e ',(car els))
+ ',els
+ ,(frob (cdr els)))
+ 'nil)))
+ (frob val)))))
+
+;;; FIXME: Rewrite this so that these definitions of DELETE, ASSOC, and MEMBER
+;;; are lexically findable:
+;;; (MACROLET ((DEF-FROB (X Y) ..))
+;;; (DEF-FROB DELETE DELQ)
+;;; (DEF-FROB ASSOC ASSQ)
+;;; (DEF-FROB MEMBER MEMQ))
+;;; And while I'm at it, I could save a few byte by implementing the
+;;; transform body as call to a shared function instead of duplicated
+;;; macroexpanded code.
+(dolist (x '((delete delq)
+ (assoc assq)
+ (member memq)))
+ (destructuring-bind (fun eq-fun) x
+ (deftransform fun ((item list &key test) '(t list &rest t) '*
+ :eval-name t)
+ "convert to EQ test"
+ ;; FIXME: The scope of this transformation could be widened somewhat,
+ ;; letting it work whenever the test is 'EQL and we know from the
+ ;; type of ITEM that it #'EQ works like #'EQL on it. (E.g. types
+ ;; FIXNUM, CHARACTER, and SYMBOL.)
+ ;; If TEST is EQ, apply transform, else
+ ;; if test is not EQL, then give up on transform, else
+ ;; if ITEM is not a NUMBER or is a FIXNUM, apply transform, else
+ ;; give up on transform.
+ (cond (test
+ (unless (continuation-function-is test '(eq))
+ (give-up-ir1-transform)))
+ ((types-intersect (continuation-type item)
+ (specifier-type 'number))
+ (give-up-ir1-transform "Item might be a number.")))
+ `(,eq-fun item list))))
+
+(deftransform delete-if ((pred list) (t list))
+ "open code"
+ '(do ((x list (cdr x))
+ (splice '()))
+ ((endp x) list)
+ (cond ((funcall pred (car x))
+ (if (null splice)
+ (setq list (cdr x))
+ (rplacd splice (cdr x))))
+ (T (setq splice x)))))
+
+(deftransform fill ((seq item &key (start 0) (end (length seq)))
+ (simple-array t &key (:start t) (:end index)))
+ "open code"
+ '(do ((i start (1+ i)))
+ ((= i end) seq)
+ (declare (type index i))
+ (setf (aref seq i) item)))
+
+(deftransform position ((item list &key (test #'eql)) (t list))
+ "open code"
+ '(do ((i 0 (1+ i))
+ (l list (cdr l)))
+ ((endp l) nil)
+ (declare (type index i))
+ (when (funcall test item (car l)) (return i))))
+
+(deftransform position ((item vec &key (test #'eql) (start 0)
+ (end (length vec)))
+ (t simple-array &key (:start t) (:end index)))
+ "open code"
+ '(do ((i start (1+ i)))
+ ((= i end) nil)
+ (declare (type index i))
+ (when (funcall test item (aref vec i)) (return i))))
+
+;;; names of predicates that compute the same value as CHAR= when
+;;; applied to characters
+(defconstant char=-functions '(eql equal char=))
+
+(deftransform search ((string1 string2 &key (start1 0) end1 (start2 0) end2
+ test)
+ (simple-string simple-string &rest t))
+ (unless (or (not test)
+ (continuation-function-is test char=-functions))
+ (give-up-ir1-transform))
+ '(sb!impl::%sp-string-search string1 start1 (or end1 (length string1))
+ string2 start2 (or end2 (length string2))))
+
+(deftransform position ((item sequence &key from-end test (start 0) end)
+ (t simple-string &rest t))
+ (unless (or (not test)
+ (continuation-function-is test char=-functions))
+ (give-up-ir1-transform))
+ `(and (typep item 'character)
+ (,(if (constant-value-or-lose from-end)
+ 'sb!impl::%sp-reverse-find-character
+ 'sb!impl::%sp-find-character)
+ sequence start (or end (length sequence))
+ item)))
+
+(deftransform find ((item sequence &key from-end (test #'eql) (start 0) end)
+ (t simple-string &rest t))
+ `(if (position item sequence
+ ,@(when from-end `(:from-end from-end))
+ :test test :start start :end end)
+ item
+ nil))
+\f
+;;;; utilities
+
+;;; Return true if Cont's only use is a non-notinline reference to a global
+;;; function with one of the specified Names.
+(defun continuation-function-is (cont names)
+ (declare (type continuation cont) (list names))
+ (let ((use (continuation-use cont)))
+ (and (ref-p use)
+ (let ((leaf (ref-leaf use)))
+ (and (global-var-p leaf)
+ (eq (global-var-kind leaf) :global-function)
+ (not (null (member (leaf-name leaf) names :test #'equal))))))))
+
+;;; If Cont is a constant continuation, the return the constant value. If
+;;; it is null, then return default, otherwise quietly GIVE-UP.
+;;; ### Probably should take an ARG and flame using the NAME.
+(defun constant-value-or-lose (cont &optional default)
+ (declare (type (or continuation null) cont))
+ (cond ((not cont) default)
+ ((constant-continuation-p cont)
+ (continuation-value cont))
+ (t
+ (give-up-ir1-transform))))
+
+#|
+;;; This is a frob whose job it is to make it easier to pass around the
+;;; arguments to IR1 transforms. It bundles together the name of the argument
+;;; (which should be referenced in any expansion), and the continuation for
+;;; that argument (or NIL if unsupplied.)
+(defstruct (arg (:constructor %make-arg (name cont)))
+ (name nil :type symbol)
+ (cont nil :type (or continuation null)))
+(defmacro make-arg (name)
+ `(%make-arg ',name ,name))
+
+;;; If Arg is null or its CONT is null, then return Default, otherwise
+;;; return Arg's NAME.
+(defun default-arg (arg default)
+ (declare (type (or arg null) arg))
+ (if (and arg (arg-cont arg))
+ (arg-name arg)
+ default))
+
+;;; If Arg is null or has no CONT, return the default. Otherwise, Arg's
+;;; CONT must be a constant continuation whose value we return. If not, we
+;;; give up.
+(defun arg-constant-value (arg default)
+ (declare (type (or arg null) arg))
+ (if (and arg (arg-cont arg))
+ (let ((cont (arg-cont arg)))
+ (unless (constant-continuation-p cont)
+ (give-up-ir1-transform "Argument is not constant: ~S."
+ (arg-name arg)))
+ (continuation-value from-end))
+ default))
+
+;;; If Arg is a constant and is EQL to X, then return T, otherwise NIL. If
+;;; Arg is NIL or its CONT is NIL, then compare to the default.
+(defun arg-eql (arg default x)
+ (declare (type (or arg null) x))
+ (if (and arg (arg-cont arg))
+ (let ((cont (arg-cont arg)))
+ (and (constant-continuation-p cont)
+ (eql (continuation-value cont) x)))
+ (eql default x)))
+
+(defstruct iterator
+ ;; The kind of iterator.
+ (kind nil (member :normal :result))
+ ;; A list of LET* bindings to create the initial state.
+ (binds nil :type list)
+ ;; A list of declarations for Binds.
+ (decls nil :type list)
+ ;; A form that returns the current value. This may be set with SETF to set
+ ;; the current value.
+ (current (error "Must specify CURRENT."))
+ ;; In a :Normal iterator, a form that tests whether there is a current value.
+ (done nil)
+ ;; In a :Result iterator, a form that truncates the result at the current
+ ;; position and returns it.
+ (result nil)
+ ;; A form that returns the initial total number of values. The result is
+ ;; undefined after NEXT has been evaluated.
+ (length (error "Must specify LENGTH."))
+ ;; A form that advances the state to the next value. It is an error to call
+ ;; this when the iterator is Done.
+ (next (error "Must specify NEXT.")))
+
+;;; Type of an index var that can go negative (in the from-end case.)
+(deftype neg-index ()
+ `(integer -1 ,most-positive-fixnum))
+
+;;; Return an ITERATOR structure describing how to iterate over an arbitrary
+;;; sequence. Sequence is a variable bound to the sequence, and Type is the
+;;; type of the sequence. If true, INDEX is a variable that should be bound to
+;;; the index of the current element in the sequence.
+;;;
+;;; If we can't tell whether the sequence is a list or a vector, or whether
+;;; the iteration is forward or backward, then GIVE-UP.
+(defun make-sequence-iterator (sequence type &key start end from-end index)
+ (declare (symbol sequence) (type ctype type)
+ (type (or arg null) start end from-end)
+ (type (or symbol null) index))
+ (let ((from-end (arg-constant-value from-end nil)))
+ (cond ((csubtypep type (specifier-type 'vector))
+ (let* ((n-stop (gensym))
+ (n-idx (or index (gensym)))
+ (start (default-arg 0 start))
+ (end (default-arg `(length ,sequence) end)))
+ (make-iterator
+ :kind :normal
+ :binds `((,n-idx ,(if from-end `(1- ,end) ,start))
+ (,n-stop ,(if from-end `(1- ,start) ,end)))
+ :decls `((type neg-index ,n-idx ,n-stop))
+ :current `(aref ,sequence ,n-idx)
+ :done `(,(if from-end '<= '>=) ,n-idx ,n-stop)
+ :next `(setq ,n-idx
+ ,(if from-end `(1- ,n-idx) `(1+ ,n-idx)))
+ :length (if from-end
+ `(- ,n-idx ,n-stop)
+ `(- ,n-stop ,n-idx)))))
+ ((csubtypep type (specifier-type 'list))
+ (let* ((n-stop (if (and end (not from-end)) (gensym) nil))
+ (n-current (gensym))
+ (start-p (not (arg-eql start 0 0)))
+ (end-p (not (arg-eql end nil nil)))
+ (start (default-arg start 0))
+ (end (default-arg end nil)))
+ (make-iterator
+ :binds `((,n-current
+ ,(if from-end
+ (if (or start-p end-p)
+ `(nreverse (subseq ,sequence ,start
+ ,@(when end `(,end))))
+ `(reverse ,sequence))
+ (if start-p
+ `(nthcdr ,start ,sequence)
+ sequence)))
+ ,@(when n-stop
+ `((,n-stop (nthcdr (the index
+ (- ,end ,start))
+ ,n-current))))
+ ,@(when index
+ `((,index ,(if from-end `(1- ,end) start)))))
+ :kind :normal
+ :decls `((list ,n-current ,n-end)
+ ,@(when index `((type neg-index ,index))))
+ :current `(car ,n-current)
+ :done `(eq ,n-current ,n-stop)
+ :length `(- ,(or end `(length ,sequence)) ,start)
+ :next `(progn
+ (setq ,n-current (cdr ,n-current))
+ ,@(when index
+ `((setq ,n-idx
+ ,(if from-end
+ `(1- ,index)
+ `(1+ ,index)))))))))
+ (t
+ (give-up-ir1-transform
+ "can't tell whether sequence is a list or a vector")))))
+
+;;; Make an iterator used for constructing result sequences. Name is a
+;;; variable to be bound to the result sequence. Type is the type of result
+;;; sequence to make. Length is an expression to be evaluated to get the
+;;; maximum length of the result (not evaluated in list case.)
+(defun make-result-sequence-iterator (name type length)
+ (declare (symbol name) (type ctype type))
+
+;;; Defines each Name as a local macro that will call the value of the
+;;; Fun-Arg with the given arguments. If the argument isn't known to be a
+;;; function, give them an efficiency note and reference a coerced version.
+(defmacro coerce-functions (specs &body body)
+ #!+sb-doc
+ "COERCE-FUNCTIONS ({(Name Fun-Arg Default)}*) Form*"
+ (collect ((binds)
+ (defs))
+ (dolist (spec specs)
+ `(let ((body (progn ,@body))
+ (n-fun (arg-name ,(second spec)))
+ (fun-cont (arg-cont ,(second spec))))
+ (cond ((not fun-cont)
+ `(macrolet ((,',(first spec) (&rest args)
+ `(,',',(third spec) ,@args)))
+ ,body))
+ ((not (csubtypep (continuation-type fun-cont)
+ (specifier-type 'function)))
+ (when (policy *compiler-error-context* (> speed brevity))
+ (compiler-note
+ "~S may not be a function, so must coerce at run-time."
+ n-fun))
+ (once-only ((n-fun `(if (functionp ,n-fun)
+ ,n-fun
+ (symbol-function ,n-fun))))
+ `(macrolet ((,',(first spec) (&rest args)
+ `(funcall ,',n-fun ,@args)))
+ ,body)))
+ (t
+ `(macrolet ((,',(first spec) (&rest args)
+ `(funcall ,',n-fun ,@args)))
+ ,body)))))))
+
+;;; Wrap code around the result of the body to define Name as a local macro
+;;; that returns true when its arguments satisfy the test according to the Args
+;;; Test and Test-Not. If both Test and Test-Not are supplied, abort the
+;;; transform.
+(defmacro with-sequence-test ((name test test-not) &body body)
+ `(let ((not-p (arg-cont ,test-not)))
+ (when (and (arg-cont ,test) not-p)
+ (abort-ir1-transform "Both ~S and ~S were supplied."
+ (arg-name ,test)
+ (arg-name ,test-not)))
+ (coerce-functions ((,name (if not-p ,test-not ,test) eql))
+ ,@body)))
+|#
+\f
+;;;; hairy sequence transforms
+
+;;; FIXME: no hairy sequence transforms in SBCL?
+\f
+;;;; string operations
+
+;;; We transform the case-sensitive string predicates into a non-keyword
+;;; version. This is an IR1 transform so that we don't have to worry about
+;;; changing the order of evaluation.
+(dolist (stuff '((string< string<*)
+ (string> string>*)
+ (string<= string<=*)
+ (string>= string>=*)
+ (string= string=*)
+ (string/= string/=*)))
+ (destructuring-bind (fun pred*) stuff
+ (deftransform fun ((string1 string2 &key (start1 0) end1
+ (start2 0) end2)
+ '* '* :eval-name t)
+ `(,pred* string1 string2 start1 end1 start2 end2))))
+
+;;; Return a form that tests the free variables STRING1 and STRING2 for the
+;;; ordering relationship specified by Lessp and Equalp. The start and end are
+;;; also gotten from the environment. Both strings must be simple strings.
+(dolist (stuff '((string<* t nil)
+ (string<=* t t)
+ (string>* nil nil)
+ (string>=* nil t)))
+ (destructuring-bind (name lessp equalp) stuff
+ (deftransform name ((string1 string2 start1 end1 start2 end2)
+ '(simple-string simple-string t t t t) '*
+ :eval-name t)
+ `(let* ((end1 (if (not end1) (length string1) end1))
+ (end2 (if (not end2) (length string2) end2))
+ (index (sb!impl::%sp-string-compare
+ string1 start1 end1 string2 start2 end2)))
+ (if index
+ (cond ((= index ,(if lessp 'end1 'end2)) index)
+ ((= index ,(if lessp 'end2 'end1)) nil)
+ ((,(if lessp 'char< 'char>)
+ (schar string1 index)
+ (schar string2
+ (truly-the index
+ (+ index
+ (truly-the fixnum
+ (- start2 start1))))))
+ index)
+ (t nil))
+ ,(if equalp 'end1 'nil))))))
+
+(dolist (stuff '((string=* not)
+ (string/=* identity)))
+ (destructuring-bind (name result-fun) stuff
+ (deftransform name ((string1 string2 start1 end1 start2 end2)
+ '(simple-string simple-string t t t t) '*
+ :eval-name t)
+ `(,result-fun
+ (sb!impl::%sp-string-compare
+ string1 start1 (or end1 (length string1))
+ string2 start2 (or end2 (length string2)))))))
--- /dev/null
+;;;; This file contains macro-like source transformations which
+;;;; convert uses of certain functions into the canonical form desired
+;;;; within the compiler. ### and other IR1 transforms and stuff.
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!C")
+
+(file-comment
+ "$Header$")
+
+;;; Convert into an IF so that IF optimizations will eliminate redundant
+;;; negations.
+(def-source-transform not (x) `(if ,x nil t))
+(def-source-transform null (x) `(if ,x nil t))
+
+;;; ENDP is just NULL with a LIST assertion.
+(def-source-transform endp (x) `(null (the list ,x)))
+;;; FIXME: Is THE LIST a strong enough assertion for ANSI's "should
+;;; return an error"? (THE LIST is optimized away when safety is low;
+;;; does that satisfy the spec?)
+
+;;; We turn IDENTITY into PROG1 so that it is obvious that it just
+;;; returns the first value of its argument. Ditto for VALUES with one
+;;; arg.
+(def-source-transform identity (x) `(prog1 ,x))
+(def-source-transform values (x) `(prog1 ,x))
+
+;;; Bind the values and make a closure that returns them.
+(def-source-transform constantly (value &rest values)
+ (let ((temps (loop repeat (1+ (length values))
+ collect (gensym)))
+ (dum (gensym)))
+ `(let ,(loop for temp in temps and
+ value in (list* value values)
+ collect `(,temp ,value))
+ #'(lambda (&rest ,dum)
+ (declare (ignore ,dum))
+ (values ,@temps)))))
+
+;;; If the function has a known number of arguments, then return a
+;;; lambda with the appropriate fixed number of args. If the
+;;; destination is a FUNCALL, then do the &REST APPLY thing, and let
+;;; MV optimization figure things out.
+(deftransform complement ((fun) * * :node node :when :both)
+ "open code"
+ (multiple-value-bind (min max)
+ (function-type-nargs (continuation-type fun))
+ (cond
+ ((and min (eql min max))
+ (let ((dums (loop repeat min collect (gensym))))
+ `#'(lambda ,dums (not (funcall fun ,@dums)))))
+ ((let* ((cont (node-cont node))
+ (dest (continuation-dest cont)))
+ (and (combination-p dest)
+ (eq (combination-fun dest) cont)))
+ '#'(lambda (&rest args)
+ (not (apply fun args))))
+ (t
+ (give-up-ir1-transform
+ "The function doesn't have a fixed argument count.")))))
+\f
+;;;; list hackery
+
+;;; Translate CxxR into CAR/CDR combos.
+
+(defun source-transform-cxr (form)
+ (if (or (byte-compiling) (/= (length form) 2))
+ (values nil t)
+ (let ((name (symbol-name (car form))))
+ (do ((i (- (length name) 2) (1- i))
+ (res (cadr form)
+ `(,(ecase (char name i)
+ (#\A 'car)
+ (#\D 'cdr))
+ ,res)))
+ ((zerop i) res)))))
+
+(do ((i 2 (1+ i))
+ (b '(1 0) (cons i b)))
+ ((= i 5))
+ (dotimes (j (ash 1 i))
+ (setf (info :function :source-transform
+ (intern (format nil "C~{~:[A~;D~]~}R"
+ (mapcar #'(lambda (x) (logbitp x j)) b))))
+ #'source-transform-cxr)))
+
+;;; Turn FIRST..FOURTH and REST into the obvious synonym, assuming
+;;; whatever is right for them is right for us. FIFTH..TENTH turn into
+;;; Nth, which can be expanded into a CAR/CDR later on if policy
+;;; favors it.
+(def-source-transform first (x) `(car ,x))
+(def-source-transform rest (x) `(cdr ,x))
+(def-source-transform second (x) `(cadr ,x))
+(def-source-transform third (x) `(caddr ,x))
+(def-source-transform fourth (x) `(cadddr ,x))
+(def-source-transform fifth (x) `(nth 4 ,x))
+(def-source-transform sixth (x) `(nth 5 ,x))
+(def-source-transform seventh (x) `(nth 6 ,x))
+(def-source-transform eighth (x) `(nth 7 ,x))
+(def-source-transform ninth (x) `(nth 8 ,x))
+(def-source-transform tenth (x) `(nth 9 ,x))
+
+;;; Translate RPLACx to LET and SETF.
+(def-source-transform rplaca (x y)
+ (once-only ((n-x x))
+ `(progn
+ (setf (car ,n-x) ,y)
+ ,n-x)))
+(def-source-transform rplacd (x y)
+ (once-only ((n-x x))
+ `(progn
+ (setf (cdr ,n-x) ,y)
+ ,n-x)))
+
+(def-source-transform nth (n l) `(car (nthcdr ,n ,l)))
+
+(defvar *default-nthcdr-open-code-limit* 6)
+(defvar *extreme-nthcdr-open-code-limit* 20)
+
+(deftransform nthcdr ((n l) (unsigned-byte t) * :node node)
+ "convert NTHCDR to CAxxR"
+ (unless (constant-continuation-p n)
+ (give-up-ir1-transform))
+ (let ((n (continuation-value n)))
+ (when (> n
+ (if (policy node (= speed 3) (= space 0))
+ *extreme-nthcdr-open-code-limit*
+ *default-nthcdr-open-code-limit*))
+ (give-up-ir1-transform))
+
+ (labels ((frob (n)
+ (if (zerop n)
+ 'l
+ `(cdr ,(frob (1- n))))))
+ (frob n))))
+\f
+;;;; arithmetic and numerology
+
+(def-source-transform plusp (x) `(> ,x 0))
+(def-source-transform minusp (x) `(< ,x 0))
+(def-source-transform zerop (x) `(= ,x 0))
+
+(def-source-transform 1+ (x) `(+ ,x 1))
+(def-source-transform 1- (x) `(- ,x 1))
+
+(def-source-transform oddp (x) `(not (zerop (logand ,x 1))))
+(def-source-transform evenp (x) `(zerop (logand ,x 1)))
+
+;;; Note that all the integer division functions are available for
+;;; inline expansion.
+
+;;; FIXME: DEF-FROB instead of FROB
+(macrolet ((frob (fun)
+ `(def-source-transform ,fun (x &optional (y nil y-p))
+ (declare (ignore y))
+ (if y-p
+ (values nil t)
+ `(,',fun ,x 1)))))
+ (frob truncate)
+ (frob round)
+ #!+propagate-float-type
+ (frob floor)
+ #!+propagate-float-type
+ (frob ceiling))
+
+(def-source-transform lognand (x y) `(lognot (logand ,x ,y)))
+(def-source-transform lognor (x y) `(lognot (logior ,x ,y)))
+(def-source-transform logandc1 (x y) `(logand (lognot ,x) ,y))
+(def-source-transform logandc2 (x y) `(logand ,x (lognot ,y)))
+(def-source-transform logorc1 (x y) `(logior (lognot ,x) ,y))
+(def-source-transform logorc2 (x y) `(logior ,x (lognot ,y)))
+(def-source-transform logtest (x y) `(not (zerop (logand ,x ,y))))
+(def-source-transform logbitp (index integer)
+ `(not (zerop (logand (ash 1 ,index) ,integer))))
+(def-source-transform byte (size position) `(cons ,size ,position))
+(def-source-transform byte-size (spec) `(car ,spec))
+(def-source-transform byte-position (spec) `(cdr ,spec))
+(def-source-transform ldb-test (bytespec integer)
+ `(not (zerop (mask-field ,bytespec ,integer))))
+
+;;; With the ratio and complex accessors, we pick off the "identity"
+;;; case, and use a primitive to handle the cell access case.
+(def-source-transform numerator (num)
+ (once-only ((n-num `(the rational ,num)))
+ `(if (ratiop ,n-num)
+ (%numerator ,n-num)
+ ,n-num)))
+(def-source-transform denominator (num)
+ (once-only ((n-num `(the rational ,num)))
+ `(if (ratiop ,n-num)
+ (%denominator ,n-num)
+ 1)))
+\f
+;;;; Interval arithmetic for computing bounds
+;;;; (toy@rtp.ericsson.se)
+;;;;
+;;;; This is a set of routines for operating on intervals. It
+;;;; implements a simple interval arithmetic package. Although SBCL
+;;;; has an interval type in numeric-type, we choose to use our own
+;;;; for two reasons:
+;;;;
+;;;; 1. This package is simpler than numeric-type
+;;;;
+;;;; 2. It makes debugging much easier because you can just strip
+;;;; out these routines and test them independently of SBCL. (a
+;;;; big win!)
+;;;;
+;;;; One disadvantage is a probable increase in consing because we
+;;;; have to create these new interval structures even though
+;;;; numeric-type has everything we want to know. Reason 2 wins for
+;;;; now.
+
+#-sb-xc-host ;(CROSS-FLOAT-INFINITY-KLUDGE, see base-target-features.lisp-expr)
+(progn
+#!+propagate-float-type
+(progn
+
+;;; The basic interval type. It can handle open and closed intervals.
+;;; A bound is open if it is a list containing a number, just like
+;;; Lisp says. NIL means unbounded.
+(defstruct (interval
+ (:constructor %make-interval))
+ low high)
+
+(defun make-interval (&key low high)
+ (labels ((normalize-bound (val)
+ (cond ((and (floatp val)
+ (float-infinity-p val))
+ ;; Handle infinities
+ nil)
+ ((or (numberp val)
+ (eq val nil))
+ ;; Handle any closed bounds
+ val)
+ ((listp val)
+ ;; We have an open bound. Normalize the numeric
+ ;; bound. If the normalized bound is still a number
+ ;; (not nil), keep the bound open. Otherwise, the
+ ;; bound is really unbounded, so drop the openness.
+ (let ((new-val (normalize-bound (first val))))
+ (when new-val
+ ;; Bound exists, so keep it open still
+ (list new-val))))
+ (t
+ (error "Unknown bound type in make-interval!")))))
+ (%make-interval :low (normalize-bound low)
+ :high (normalize-bound high))))
+
+#!-sb-fluid (declaim (inline bound-value set-bound))
+
+;;; Extract the numeric value of a bound. Return NIL, if X is NIL.
+(defun bound-value (x)
+ (if (consp x) (car x) x))
+
+;;; Given a number X, create a form suitable as a bound for an
+;;; interval. Make the bound open if OPEN-P is T. NIL remains NIL.
+(defun set-bound (x open-p)
+ (if (and x open-p) (list x) x))
+
+;;; Apply the function F to a bound X. If X is an open bound, then
+;;; the result will be open. IF X is NIL, the result is NIL.
+(defun bound-func (f x)
+ (and x
+ (with-float-traps-masked (:underflow :overflow :inexact :divide-by-zero)
+ ;; With these traps masked, we might get things like infinity
+ ;; or negative infinity returned. Check for this and return
+ ;; NIL to indicate unbounded.
+ (let ((y (funcall f (bound-value x))))
+ (if (and (floatp y)
+ (float-infinity-p y))
+ nil
+ (set-bound (funcall f (bound-value x)) (consp x)))))))
+
+;;; Apply a binary operator OP to two bounds X and Y. The result is
+;;; NIL if either is NIL. Otherwise bound is computed and the result
+;;; is open if either X or Y is open.
+;;;
+;;; FIXME: only used in this file, not needed in target runtime
+(defmacro bound-binop (op x y)
+ `(and ,x ,y
+ (with-float-traps-masked (:underflow :overflow :inexact :divide-by-zero)
+ (set-bound (,op (bound-value ,x)
+ (bound-value ,y))
+ (or (consp ,x) (consp ,y))))))
+
+;;; NUMERIC-TYPE->INTERVAL
+;;;
+;;; Convert a numeric-type object to an interval object.
+
+(defun numeric-type->interval (x)
+ (declare (type numeric-type x))
+ (make-interval :low (numeric-type-low x)
+ :high (numeric-type-high x)))
+
+(defun copy-interval-limit (limit)
+ (if (numberp limit)
+ limit
+ (copy-list limit)))
+
+(defun copy-interval (x)
+ (declare (type interval x))
+ (make-interval :low (copy-interval-limit (interval-low x))
+ :high (copy-interval-limit (interval-high x))))
+
+;;; INTERVAL-SPLIT
+;;;
+;;; Given a point P contained in the interval X, split X into two
+;;; interval at the point P. If CLOSE-LOWER is T, then the left
+;;; interval contains P. If CLOSE-UPPER is T, the right interval
+;;; contains P. You can specify both to be T or NIL.
+(defun interval-split (p x &optional close-lower close-upper)
+ (declare (type number p)
+ (type interval x))
+ (list (make-interval :low (copy-interval-limit (interval-low x))
+ :high (if close-lower p (list p)))
+ (make-interval :low (if close-upper (list p) p)
+ :high (copy-interval-limit (interval-high x)))))
+
+;;; INTERVAL-CLOSURE
+;;;
+;;; Return the closure of the interval. That is, convert open bounds
+;;; to closed bounds.
+(defun interval-closure (x)
+ (declare (type interval x))
+ (make-interval :low (bound-value (interval-low x))
+ :high (bound-value (interval-high x))))
+
+(defun signed-zero->= (x y)
+ (declare (real x y))
+ (or (> x y)
+ (and (= x y)
+ (>= (float-sign (float x))
+ (float-sign (float y))))))
+
+;;; INTERVAL-RANGE-INFO
+;;;
+;;; For an interval X, if X >= POINT, return '+. If X <= POINT, return
+;;; '-. Otherwise return NIL.
+#+nil
+(defun interval-range-info (x &optional (point 0))
+ (declare (type interval x))
+ (let ((lo (interval-low x))
+ (hi (interval-high x)))
+ (cond ((and lo (signed-zero->= (bound-value lo) point))
+ '+)
+ ((and hi (signed-zero->= point (bound-value hi)))
+ '-)
+ (t
+ nil))))
+(defun interval-range-info (x &optional (point 0))
+ (declare (type interval x))
+ (labels ((signed->= (x y)
+ (if (and (zerop x) (zerop y) (floatp x) (floatp y))
+ (>= (float-sign x) (float-sign y))
+ (>= x y))))
+ (let ((lo (interval-low x))
+ (hi (interval-high x)))
+ (cond ((and lo (signed->= (bound-value lo) point))
+ '+)
+ ((and hi (signed->= point (bound-value hi)))
+ '-)
+ (t
+ nil)))))
+
+;;; INTERVAL-BOUNDED-P
+;;;
+;;; Test to see whether the interval X is bounded. HOW determines the
+;;; test, and should be either ABOVE, BELOW, or BOTH.
+(defun interval-bounded-p (x how)
+ (declare (type interval x))
+ (ecase how
+ ('above
+ (interval-high x))
+ ('below
+ (interval-low x))
+ ('both
+ (and (interval-low x) (interval-high x)))))
+
+;;; Signed zero comparison functions. Use these functions if we need
+;;; to distinguish between signed zeroes.
+
+(defun signed-zero-< (x y)
+ (declare (real x y))
+ (or (< x y)
+ (and (= x y)
+ (< (float-sign (float x))
+ (float-sign (float y))))))
+(defun signed-zero-> (x y)
+ (declare (real x y))
+ (or (> x y)
+ (and (= x y)
+ (> (float-sign (float x))
+ (float-sign (float y))))))
+
+(defun signed-zero-= (x y)
+ (declare (real x y))
+ (and (= x y)
+ (= (float-sign (float x))
+ (float-sign (float y)))))
+
+(defun signed-zero-<= (x y)
+ (declare (real x y))
+ (or (< x y)
+ (and (= x y)
+ (<= (float-sign (float x))
+ (float-sign (float y))))))
+
+;;; INTERVAL-CONTAINS-P
+;;;
+;;; See whether the interval X contains the number P, taking into account
+;;; that the interval might not be closed.
+(defun interval-contains-p (p x)
+ (declare (type number p)
+ (type interval x))
+ ;; Does the interval X contain the number P? This would be a lot
+ ;; easier if all intervals were closed!
+ (let ((lo (interval-low x))
+ (hi (interval-high x)))
+ (cond ((and lo hi)
+ ;; The interval is bounded
+ (if (and (signed-zero-<= (bound-value lo) p)
+ (signed-zero-<= p (bound-value hi)))
+ ;; P is definitely in the closure of the interval.
+ ;; We just need to check the end points now.
+ (cond ((signed-zero-= p (bound-value lo))
+ (numberp lo))
+ ((signed-zero-= p (bound-value hi))
+ (numberp hi))
+ (t t))
+ nil))
+ (hi
+ ;; Interval with upper bound
+ (if (signed-zero-< p (bound-value hi))
+ t
+ (and (numberp hi) (signed-zero-= p hi))))
+ (lo
+ ;; Interval with lower bound
+ (if (signed-zero-> p (bound-value lo))
+ t
+ (and (numberp lo) (signed-zero-= p lo))))
+ (t
+ ;; Interval with no bounds
+ t))))
+
+;;; INTERVAL-INTERSECT-P
+;;;
+;;; Determine if two intervals X and Y intersect. Return T if so. If
+;;; CLOSED-INTERVALS-P is T, the treat the intervals as if they were
+;;; closed. Otherwise the intervals are treated as they are.
+;;;
+;;; Thus if X = [0, 1) and Y = (1, 2), then they do not intersect
+;;; because no element in X is in Y. However, if CLOSED-INTERVALS-P
+;;; is T, then they do intersect because we use the closure of X = [0,
+;;; 1] and Y = [1, 2] to determine intersection.
+(defun interval-intersect-p (x y &optional closed-intervals-p)
+ (declare (type interval x y))
+ (multiple-value-bind (intersect diff)
+ (interval-intersection/difference (if closed-intervals-p
+ (interval-closure x)
+ x)
+ (if closed-intervals-p
+ (interval-closure y)
+ y))
+ (declare (ignore diff))
+ intersect))
+
+;;; Are the two intervals adjacent? That is, is there a number
+;;; between the two intervals that is not an element of either
+;;; interval? If so, they are not adjacent. For example [0, 1) and
+;;; [1, 2] are adjacent but [0, 1) and (1, 2] are not because 1 lies
+;;; between both intervals.
+(defun interval-adjacent-p (x y)
+ (declare (type interval x y))
+ (flet ((adjacent (lo hi)
+ ;; Check to see whether lo and hi are adjacent. If either is
+ ;; nil, they can't be adjacent.
+ (when (and lo hi (= (bound-value lo) (bound-value hi)))
+ ;; The bounds are equal. They are adjacent if one of
+ ;; them is closed (a number). If both are open (consp),
+ ;; then there is a number that lies between them.
+ (or (numberp lo) (numberp hi)))))
+ (or (adjacent (interval-low y) (interval-high x))
+ (adjacent (interval-low x) (interval-high y)))))
+
+;;; INTERVAL-INTERSECTION/DIFFERENCE
+;;;
+;;; Compute the intersection and difference between two intervals.
+;;; Two values are returned: the intersection and the difference.
+;;;
+;;; Let the two intervals be X and Y, and let I and D be the two
+;;; values returned by this function. Then I = X intersect Y. If I
+;;; is NIL (the empty set), then D is X union Y, represented as the
+;;; list of X and Y. If I is not the empty set, then D is (X union Y)
+;;; - I, which is a list of two intervals.
+;;;
+;;; For example, let X = [1,5] and Y = [-1,3). Then I = [1,3) and D =
+;;; [-1,1) union [3,5], which is returned as a list of two intervals.
+(defun interval-intersection/difference (x y)
+ (declare (type interval x y))
+ (let ((x-lo (interval-low x))
+ (x-hi (interval-high x))
+ (y-lo (interval-low y))
+ (y-hi (interval-high y)))
+ (labels
+ ((opposite-bound (p)
+ ;; If p is an open bound, make it closed. If p is a closed
+ ;; bound, make it open.
+ (if (listp p)
+ (first p)
+ (list p)))
+ (test-number (p int)
+ ;; Test whether P is in the interval.
+ (when (interval-contains-p (bound-value p)
+ (interval-closure int))
+ (let ((lo (interval-low int))
+ (hi (interval-high int)))
+ ;; Check for endpoints
+ (cond ((and lo (= (bound-value p) (bound-value lo)))
+ (not (and (consp p) (numberp lo))))
+ ((and hi (= (bound-value p) (bound-value hi)))
+ (not (and (numberp p) (consp hi))))
+ (t t)))))
+ (test-lower-bound (p int)
+ ;; P is a lower bound of an interval.
+ (if p
+ (test-number p int)
+ (not (interval-bounded-p int 'below))))
+ (test-upper-bound (p int)
+ ;; P is an upper bound of an interval
+ (if p
+ (test-number p int)
+ (not (interval-bounded-p int 'above)))))
+ (let ((x-lo-in-y (test-lower-bound x-lo y))
+ (x-hi-in-y (test-upper-bound x-hi y))
+ (y-lo-in-x (test-lower-bound y-lo x))
+ (y-hi-in-x (test-upper-bound y-hi x)))
+ (cond ((or x-lo-in-y x-hi-in-y y-lo-in-x y-hi-in-x)
+ ;; Intervals intersect. Let's compute the intersection
+ ;; and the difference.
+ (multiple-value-bind (lo left-lo left-hi)
+ (cond (x-lo-in-y (values x-lo y-lo (opposite-bound x-lo)))
+ (y-lo-in-x (values y-lo x-lo (opposite-bound y-lo))))
+ (multiple-value-bind (hi right-lo right-hi)
+ (cond (x-hi-in-y
+ (values x-hi (opposite-bound x-hi) y-hi))
+ (y-hi-in-x
+ (values y-hi (opposite-bound y-hi) x-hi)))
+ (values (make-interval :low lo :high hi)
+ (list (make-interval :low left-lo :high left-hi)
+ (make-interval :low right-lo :high right-hi))))))
+ (t
+ (values nil (list x y))))))))
+
+;;; INTERVAL-MERGE-PAIR
+;;;
+;;; If intervals X and Y intersect, return a new interval that is the
+;;; union of the two. If they do not intersect, return NIL.
+(defun interval-merge-pair (x y)
+ (declare (type interval x y))
+ ;; If x and y intersect or are adjacent, create the union.
+ ;; Otherwise return nil
+ (when (or (interval-intersect-p x y)
+ (interval-adjacent-p x y))
+ (flet ((select-bound (x1 x2 min-op max-op)
+ (let ((x1-val (bound-value x1))
+ (x2-val (bound-value x2)))
+ (cond ((and x1 x2)
+ ;; Both bounds are finite. Select the right one.
+ (cond ((funcall min-op x1-val x2-val)
+ ;; x1 definitely better
+ x1)
+ ((funcall max-op x1-val x2-val)
+ ;; x2 definitely better
+ x2)
+ (t
+ ;; Bounds are equal. Select either
+ ;; value and make it open only if
+ ;; both were open.
+ (set-bound x1-val (and (consp x1) (consp x2))))))
+ (t
+ ;; At least one bound is not finite. The
+ ;; non-finite bound always wins.
+ nil)))))
+ (let* ((x-lo (copy-interval-limit (interval-low x)))
+ (x-hi (copy-interval-limit (interval-high x)))
+ (y-lo (copy-interval-limit (interval-low y)))
+ (y-hi (copy-interval-limit (interval-high y))))
+ (make-interval :low (select-bound x-lo y-lo #'< #'>)
+ :high (select-bound x-hi y-hi #'> #'<))))))
+
+;;; Basic arithmetic operations on intervals. We probably should do
+;;; true interval arithmetic here, but it's complicated because we
+;;; have float and integer types and bounds can be open or closed.
+
+;;; INTERVAL-NEG
+;;;
+;;; The negative of an interval
+(defun interval-neg (x)
+ (declare (type interval x))
+ (make-interval :low (bound-func #'- (interval-high x))
+ :high (bound-func #'- (interval-low x))))
+
+;;; INTERVAL-ADD
+;;;
+;;; Add two intervals
+(defun interval-add (x y)
+ (declare (type interval x y))
+ (make-interval :low (bound-binop + (interval-low x) (interval-low y))
+ :high (bound-binop + (interval-high x) (interval-high y))))
+
+;;; INTERVAL-SUB
+;;;
+;;; Subtract two intervals
+(defun interval-sub (x y)
+ (declare (type interval x y))
+ (make-interval :low (bound-binop - (interval-low x) (interval-high y))
+ :high (bound-binop - (interval-high x) (interval-low y))))
+
+;;; INTERVAL-MUL
+;;;
+;;; Multiply two intervals
+(defun interval-mul (x y)
+ (declare (type interval x y))
+ (flet ((bound-mul (x y)
+ (cond ((or (null x) (null y))
+ ;; Multiply by infinity is infinity
+ nil)
+ ((or (and (numberp x) (zerop x))
+ (and (numberp y) (zerop y)))
+ ;; Multiply by closed zero is special. The result
+ ;; is always a closed bound. But don't replace this
+ ;; with zero; we want the multiplication to produce
+ ;; the correct signed zero, if needed.
+ (* (bound-value x) (bound-value y)))
+ ((or (and (floatp x) (float-infinity-p x))
+ (and (floatp y) (float-infinity-p y)))
+ ;; Infinity times anything is infinity
+ nil)
+ (t
+ ;; General multiply. The result is open if either is open.
+ (bound-binop * x y)))))
+ (let ((x-range (interval-range-info x))
+ (y-range (interval-range-info y)))
+ (cond ((null x-range)
+ ;; Split x into two and multiply each separately
+ (destructuring-bind (x- x+) (interval-split 0 x t t)
+ (interval-merge-pair (interval-mul x- y)
+ (interval-mul x+ y))))
+ ((null y-range)
+ ;; Split y into two and multiply each separately
+ (destructuring-bind (y- y+) (interval-split 0 y t t)
+ (interval-merge-pair (interval-mul x y-)
+ (interval-mul x y+))))
+ ((eq x-range '-)
+ (interval-neg (interval-mul (interval-neg x) y)))
+ ((eq y-range '-)
+ (interval-neg (interval-mul x (interval-neg y))))
+ ((and (eq x-range '+) (eq y-range '+))
+ ;; If we are here, X and Y are both positive
+ (make-interval :low (bound-mul (interval-low x) (interval-low y))
+ :high (bound-mul (interval-high x) (interval-high y))))
+ (t
+ (error "This shouldn't happen!"))))))
+
+;;; INTERVAL-DIV
+;;;
+;;; Divide two intervals.
+(defun interval-div (top bot)
+ (declare (type interval top bot))
+ (flet ((bound-div (x y y-low-p)
+ ;; Compute x/y
+ (cond ((null y)
+ ;; Divide by infinity means result is 0. However,
+ ;; we need to watch out for the sign of the result,
+ ;; to correctly handle signed zeros. We also need
+ ;; to watch out for positive or negative infinity.
+ (if (floatp (bound-value x))
+ (if y-low-p
+ (- (float-sign (bound-value x) 0.0))
+ (float-sign (bound-value x) 0.0))
+ 0))
+ ((zerop (bound-value y))
+ ;; Divide by zero means result is infinity
+ nil)
+ ((and (numberp x) (zerop x))
+ ;; Zero divided by anything is zero.
+ x)
+ (t
+ (bound-binop / x y)))))
+ (let ((top-range (interval-range-info top))
+ (bot-range (interval-range-info bot)))
+ (cond ((null bot-range)
+ ;; The denominator contains zero, so anything goes!
+ (make-interval :low nil :high nil))
+ ((eq bot-range '-)
+ ;; Denominator is negative so flip the sign, compute the
+ ;; result, and flip it back.
+ (interval-neg (interval-div top (interval-neg bot))))
+ ((null top-range)
+ ;; Split top into two positive and negative parts, and
+ ;; divide each separately
+ (destructuring-bind (top- top+) (interval-split 0 top t t)
+ (interval-merge-pair (interval-div top- bot)
+ (interval-div top+ bot))))
+ ((eq top-range '-)
+ ;; Top is negative so flip the sign, divide, and flip the
+ ;; sign of the result.
+ (interval-neg (interval-div (interval-neg top) bot)))
+ ((and (eq top-range '+) (eq bot-range '+))
+ ;; The easy case
+ (make-interval :low (bound-div (interval-low top) (interval-high bot) t)
+ :high (bound-div (interval-high top) (interval-low bot) nil)))
+ (t
+ (error "This shouldn't happen!"))))))
+
+;;; INTERVAL-FUNC
+;;;
+;;; Apply the function F to the interval X. If X = [a, b], then the
+;;; result is [f(a), f(b)]. It is up to the user to make sure the
+;;; result makes sense. It will if F is monotonic increasing (or
+;;; non-decreasing).
+(defun interval-func (f x)
+ (declare (type interval x))
+ (let ((lo (bound-func f (interval-low x)))
+ (hi (bound-func f (interval-high x))))
+ (make-interval :low lo :high hi)))
+
+;;; INTERVAL-<
+;;;
+;;; Return T if X < Y. That is every number in the interval X is
+;;; always less than any number in the interval Y.
+(defun interval-< (x y)
+ (declare (type interval x y))
+ ;; X < Y only if X is bounded above, Y is bounded below, and they
+ ;; don't overlap.
+ (when (and (interval-bounded-p x 'above)
+ (interval-bounded-p y 'below))
+ ;; Intervals are bounded in the appropriate way. Make sure they
+ ;; don't overlap.
+ (let ((left (interval-high x))
+ (right (interval-low y)))
+ (cond ((> (bound-value left)
+ (bound-value right))
+ ;; Definitely overlap so result is NIL
+ nil)
+ ((< (bound-value left)
+ (bound-value right))
+ ;; Definitely don't touch, so result is T
+ t)
+ (t
+ ;; Limits are equal. Check for open or closed bounds.
+ ;; Don't overlap if one or the other are open.
+ (or (consp left) (consp right)))))))
+
+;;; INVTERVAL->=
+;;;
+;;; Return T if X >= Y. That is, every number in the interval X is
+;;; always greater than any number in the interval Y.
+(defun interval->= (x y)
+ (declare (type interval x y))
+ ;; X >= Y if lower bound of X >= upper bound of Y
+ (when (and (interval-bounded-p x 'below)
+ (interval-bounded-p y 'above))
+ (>= (bound-value (interval-low x)) (bound-value (interval-high y)))))
+
+;;; INTERVAL-ABS
+;;;
+;;; Return an interval that is the absolute value of X. Thus, if X =
+;;; [-1 10], the result is [0, 10].
+(defun interval-abs (x)
+ (declare (type interval x))
+ (case (interval-range-info x)
+ ('+
+ (copy-interval x))
+ ('-
+ (interval-neg x))
+ (t
+ (destructuring-bind (x- x+) (interval-split 0 x t t)
+ (interval-merge-pair (interval-neg x-) x+)))))
+
+;;; INTERVAL-SQR
+;;;
+;;; Compute the square of an interval.
+(defun interval-sqr (x)
+ (declare (type interval x))
+ (interval-func #'(lambda (x) (* x x))
+ (interval-abs x)))
+)) ; end PROGN's
+\f
+;;;; numeric derive-type methods
+
+;;; Utility for defining derive-type methods of integer operations. If the
+;;; types of both X and Y are integer types, then we compute a new integer type
+;;; with bounds determined Fun when applied to X and Y. Otherwise, we use
+;;; Numeric-Contagion.
+(defun derive-integer-type (x y fun)
+ (declare (type continuation x y) (type function fun))
+ (let ((x (continuation-type x))
+ (y (continuation-type y)))
+ (if (and (numeric-type-p x) (numeric-type-p y)
+ (eq (numeric-type-class x) 'integer)
+ (eq (numeric-type-class y) 'integer)
+ (eq (numeric-type-complexp x) :real)
+ (eq (numeric-type-complexp y) :real))
+ (multiple-value-bind (low high) (funcall fun x y)
+ (make-numeric-type :class 'integer
+ :complexp :real
+ :low low
+ :high high))
+ (numeric-contagion x y))))
+
+#!+(or propagate-float-type propagate-fun-type)
+(progn
+
+;; Simple utility to flatten a list
+(defun flatten-list (x)
+ (labels ((flatten-helper (x r);; 'r' is the stuff to the 'right'.
+ (cond ((null x) r)
+ ((atom x)
+ (cons x r))
+ (t (flatten-helper (car x)
+ (flatten-helper (cdr x) r))))))
+ (flatten-helper x nil)))
+
+;;; Take some type of continuation and massage it so that we get a
+;;; list of the constituent types. If ARG is *EMPTY-TYPE*, return NIL
+;;; to indicate failure.
+(defun prepare-arg-for-derive-type (arg)
+ (flet ((listify (arg)
+ (typecase arg
+ (numeric-type
+ (list arg))
+ (union-type
+ (union-type-types arg))
+ (t
+ (list arg)))))
+ (unless (eq arg *empty-type*)
+ ;; Make sure all args are some type of numeric-type. For member
+ ;; types, convert the list of members into a union of equivalent
+ ;; single-element member-type's.
+ (let ((new-args nil))
+ (dolist (arg (listify arg))
+ (if (member-type-p arg)
+ ;; Run down the list of members and convert to a list of
+ ;; member types.
+ (dolist (member (member-type-members arg))
+ (push (if (numberp member)
+ (make-member-type :members (list member))
+ *empty-type*)
+ new-args))
+ (push arg new-args)))
+ (unless (member *empty-type* new-args)
+ new-args)))))
+
+;;; Convert from the standard type convention for which -0.0 and 0.0
+;;; and equal to an intermediate convention for which they are
+;;; considered different which is more natural for some of the
+;;; optimisers.
+#!-negative-zero-is-not-zero
+(defun convert-numeric-type (type)
+ (declare (type numeric-type type))
+ ;;; Only convert real float interval delimiters types.
+ (if (eq (numeric-type-complexp type) :real)
+ (let* ((lo (numeric-type-low type))
+ (lo-val (bound-value lo))
+ (lo-float-zero-p (and lo (floatp lo-val) (= lo-val 0.0)))
+ (hi (numeric-type-high type))
+ (hi-val (bound-value hi))
+ (hi-float-zero-p (and hi (floatp hi-val) (= hi-val 0.0))))
+ (if (or lo-float-zero-p hi-float-zero-p)
+ (make-numeric-type
+ :class (numeric-type-class type)
+ :format (numeric-type-format type)
+ :complexp :real
+ :low (if lo-float-zero-p
+ (if (consp lo)
+ (list (float 0.0 lo-val))
+ (float -0.0 lo-val))
+ lo)
+ :high (if hi-float-zero-p
+ (if (consp hi)
+ (list (float -0.0 hi-val))
+ (float 0.0 hi-val))
+ hi))
+ type))
+ ;; Not real float.
+ type))
+
+;;; Convert back from the intermediate convention for which -0.0 and
+;;; 0.0 are considered different to the standard type convention for
+;;; which and equal.
+#!-negative-zero-is-not-zero
+(defun convert-back-numeric-type (type)
+ (declare (type numeric-type type))
+ ;;; Only convert real float interval delimiters types.
+ (if (eq (numeric-type-complexp type) :real)
+ (let* ((lo (numeric-type-low type))
+ (lo-val (bound-value lo))
+ (lo-float-zero-p
+ (and lo (floatp lo-val) (= lo-val 0.0)
+ (float-sign lo-val)))
+ (hi (numeric-type-high type))
+ (hi-val (bound-value hi))
+ (hi-float-zero-p
+ (and hi (floatp hi-val) (= hi-val 0.0)
+ (float-sign hi-val))))
+ (cond
+ ;; (float +0.0 +0.0) => (member 0.0)
+ ;; (float -0.0 -0.0) => (member -0.0)
+ ((and lo-float-zero-p hi-float-zero-p)
+ ;; Shouldn't have exclusive bounds here.
+ (assert (and (not (consp lo)) (not (consp hi))))
+ (if (= lo-float-zero-p hi-float-zero-p)
+ ;; (float +0.0 +0.0) => (member 0.0)
+ ;; (float -0.0 -0.0) => (member -0.0)
+ (specifier-type `(member ,lo-val))
+ ;; (float -0.0 +0.0) => (float 0.0 0.0)
+ ;; (float +0.0 -0.0) => (float 0.0 0.0)
+ (make-numeric-type :class (numeric-type-class type)
+ :format (numeric-type-format type)
+ :complexp :real
+ :low hi-val
+ :high hi-val)))
+ (lo-float-zero-p
+ (cond
+ ;; (float -0.0 x) => (float 0.0 x)
+ ((and (not (consp lo)) (minusp lo-float-zero-p))
+ (make-numeric-type :class (numeric-type-class type)
+ :format (numeric-type-format type)
+ :complexp :real
+ :low (float 0.0 lo-val)
+ :high hi))
+ ;; (float (+0.0) x) => (float (0.0) x)
+ ((and (consp lo) (plusp lo-float-zero-p))
+ (make-numeric-type :class (numeric-type-class type)
+ :format (numeric-type-format type)
+ :complexp :real
+ :low (list (float 0.0 lo-val))
+ :high hi))
+ (t
+ ;; (float +0.0 x) => (or (member 0.0) (float (0.0) x))
+ ;; (float (-0.0) x) => (or (member 0.0) (float (0.0) x))
+ (list (make-member-type :members (list (float 0.0 lo-val)))
+ (make-numeric-type :class (numeric-type-class type)
+ :format (numeric-type-format type)
+ :complexp :real
+ :low (list (float 0.0 lo-val))
+ :high hi)))))
+ (hi-float-zero-p
+ (cond
+ ;; (float x +0.0) => (float x 0.0)
+ ((and (not (consp hi)) (plusp hi-float-zero-p))
+ (make-numeric-type :class (numeric-type-class type)
+ :format (numeric-type-format type)
+ :complexp :real
+ :low lo
+ :high (float 0.0 hi-val)))
+ ;; (float x (-0.0)) => (float x (0.0))
+ ((and (consp hi) (minusp hi-float-zero-p))
+ (make-numeric-type :class (numeric-type-class type)
+ :format (numeric-type-format type)
+ :complexp :real
+ :low lo
+ :high (list (float 0.0 hi-val))))
+ (t
+ ;; (float x (+0.0)) => (or (member -0.0) (float x (0.0)))
+ ;; (float x -0.0) => (or (member -0.0) (float x (0.0)))
+ (list (make-member-type :members (list (float -0.0 hi-val)))
+ (make-numeric-type :class (numeric-type-class type)
+ :format (numeric-type-format type)
+ :complexp :real
+ :low lo
+ :high (list (float 0.0 hi-val)))))))
+ (t
+ type)))
+ ;; Not real float.
+ type))
+
+;;; Convert back a possible list of numeric types.
+#!-negative-zero-is-not-zero
+(defun convert-back-numeric-type-list (type-list)
+ (typecase type-list
+ (list
+ (let ((results '()))
+ (dolist (type type-list)
+ (if (numeric-type-p type)
+ (let ((result (convert-back-numeric-type type)))
+ (if (listp result)
+ (setf results (append results result))
+ (push result results)))
+ (push type results)))
+ results))
+ (numeric-type
+ (convert-back-numeric-type type-list))
+ (union-type
+ (convert-back-numeric-type-list (union-type-types type-list)))
+ (t
+ type-list)))
+
+;;; Make-Canonical-Union-Type
+;;;
+;;; Take a list of types and return a canonical type specifier,
+;;; combining any members types together. If both positive and
+;;; negative members types are present they are converted to a float
+;;; type. X This would be far simpler if the type-union methods could
+;;; handle member/number unions.
+(defun make-canonical-union-type (type-list)
+ (let ((members '())
+ (misc-types '()))
+ (dolist (type type-list)
+ (if (member-type-p type)
+ (setf members (union members (member-type-members type)))
+ (push type misc-types)))
+ #!+long-float
+ (when (null (set-difference '(-0l0 0l0) members))
+ #!-negative-zero-is-not-zero
+ (push (specifier-type '(long-float 0l0 0l0)) misc-types)
+ #!+negative-zero-is-not-zero
+ (push (specifier-type '(long-float -0l0 0l0)) misc-types)
+ (setf members (set-difference members '(-0l0 0l0))))
+ (when (null (set-difference '(-0d0 0d0) members))
+ #!-negative-zero-is-not-zero
+ (push (specifier-type '(double-float 0d0 0d0)) misc-types)
+ #!+negative-zero-is-not-zero
+ (push (specifier-type '(double-float -0d0 0d0)) misc-types)
+ (setf members (set-difference members '(-0d0 0d0))))
+ (when (null (set-difference '(-0f0 0f0) members))
+ #!-negative-zero-is-not-zero
+ (push (specifier-type '(single-float 0f0 0f0)) misc-types)
+ #!+negative-zero-is-not-zero
+ (push (specifier-type '(single-float -0f0 0f0)) misc-types)
+ (setf members (set-difference members '(-0f0 0f0))))
+ (cond ((null members)
+ (let ((res (first misc-types)))
+ (dolist (type (rest misc-types))
+ (setq res (type-union res type)))
+ res))
+ ((null misc-types)
+ (make-member-type :members members))
+ (t
+ (let ((res (first misc-types)))
+ (dolist (type (rest misc-types))
+ (setq res (type-union res type)))
+ (dolist (type members)
+ (setq res (type-union
+ res (make-member-type :members (list type)))))
+ res)))))
+
+;;; Convert-Member-Type
+;;;
+;;; Convert a member type with a single member to a numeric type.
+(defun convert-member-type (arg)
+ (let* ((members (member-type-members arg))
+ (member (first members))
+ (member-type (type-of member)))
+ (assert (not (rest members)))
+ (specifier-type `(,(if (subtypep member-type 'integer)
+ 'integer
+ member-type)
+ ,member ,member))))
+
+;;; ONE-ARG-DERIVE-TYPE
+;;;
+;;; This is used in defoptimizers for computing the resulting type of
+;;; a function.
+;;;
+;;; Given the continuation ARG, derive the resulting type using the
+;;; DERIVE-FCN. DERIVE-FCN takes exactly one argument which is some
+;;; "atomic" continuation type like numeric-type or member-type
+;;; (containing just one element). It should return the resulting
+;;; type, which can be a list of types.
+;;;
+;;; For the case of member types, if a member-fcn is given it is
+;;; called to compute the result otherwise the member type is first
+;;; converted to a numeric type and the derive-fcn is call.
+(defun one-arg-derive-type (arg derive-fcn member-fcn
+ &optional (convert-type t))
+ (declare (type function derive-fcn)
+ (type (or null function) member-fcn)
+ #!+negative-zero-is-not-zero (ignore convert-type))
+ (let ((arg-list (prepare-arg-for-derive-type (continuation-type arg))))
+ (when arg-list
+ (flet ((deriver (x)
+ (typecase x
+ (member-type
+ (if member-fcn
+ (with-float-traps-masked
+ (:underflow :overflow :divide-by-zero)
+ (make-member-type
+ :members (list
+ (funcall member-fcn
+ (first (member-type-members x))))))
+ ;; Otherwise convert to a numeric type.
+ (let ((result-type-list
+ (funcall derive-fcn (convert-member-type x))))
+ #!-negative-zero-is-not-zero
+ (if convert-type
+ (convert-back-numeric-type-list result-type-list)
+ result-type-list)
+ #!+negative-zero-is-not-zero
+ result-type-list)))
+ (numeric-type
+ #!-negative-zero-is-not-zero
+ (if convert-type
+ (convert-back-numeric-type-list
+ (funcall derive-fcn (convert-numeric-type x)))
+ (funcall derive-fcn x))
+ #!+negative-zero-is-not-zero
+ (funcall derive-fcn x))
+ (t
+ *universal-type*))))
+ ;; Run down the list of args and derive the type of each one,
+ ;; saving all of the results in a list.
+ (let ((results nil))
+ (dolist (arg arg-list)
+ (let ((result (deriver arg)))
+ (if (listp result)
+ (setf results (append results result))
+ (push result results))))
+ (if (rest results)
+ (make-canonical-union-type results)
+ (first results)))))))
+
+;;; TWO-ARG-DERIVE-TYPE
+;;;
+;;; Same as ONE-ARG-DERIVE-TYPE, except we assume the function takes
+;;; two arguments. DERIVE-FCN takes 3 args in this case: the two
+;;; original args and a third which is T to indicate if the two args
+;;; really represent the same continuation. This is useful for
+;;; deriving the type of things like (* x x), which should always be
+;;; positive. If we didn't do this, we wouldn't be able to tell.
+(defun two-arg-derive-type (arg1 arg2 derive-fcn fcn
+ &optional (convert-type t))
+ #!+negative-zero-is-not-zero
+ (declare (ignore convert-type))
+ (flet (#!-negative-zero-is-not-zero
+ (deriver (x y same-arg)
+ (cond ((and (member-type-p x) (member-type-p y))
+ (let* ((x (first (member-type-members x)))
+ (y (first (member-type-members y)))
+ (result (with-float-traps-masked
+ (:underflow :overflow :divide-by-zero
+ :invalid)
+ (funcall fcn x y))))
+ (cond ((null result))
+ ((and (floatp result) (float-nan-p result))
+ (make-numeric-type
+ :class 'float
+ :format (type-of result)
+ :complexp :real))
+ (t
+ (make-member-type :members (list result))))))
+ ((and (member-type-p x) (numeric-type-p y))
+ (let* ((x (convert-member-type x))
+ (y (if convert-type (convert-numeric-type y) y))
+ (result (funcall derive-fcn x y same-arg)))
+ (if convert-type
+ (convert-back-numeric-type-list result)
+ result)))
+ ((and (numeric-type-p x) (member-type-p y))
+ (let* ((x (if convert-type (convert-numeric-type x) x))
+ (y (convert-member-type y))
+ (result (funcall derive-fcn x y same-arg)))
+ (if convert-type
+ (convert-back-numeric-type-list result)
+ result)))
+ ((and (numeric-type-p x) (numeric-type-p y))
+ (let* ((x (if convert-type (convert-numeric-type x) x))
+ (y (if convert-type (convert-numeric-type y) y))
+ (result (funcall derive-fcn x y same-arg)))
+ (if convert-type
+ (convert-back-numeric-type-list result)
+ result)))
+ (t
+ *universal-type*)))
+ #!+negative-zero-is-not-zero
+ (deriver (x y same-arg)
+ (cond ((and (member-type-p x) (member-type-p y))
+ (let* ((x (first (member-type-members x)))
+ (y (first (member-type-members y)))
+ (result (with-float-traps-masked
+ (:underflow :overflow :divide-by-zero)
+ (funcall fcn x y))))
+ (if result
+ (make-member-type :members (list result)))))
+ ((and (member-type-p x) (numeric-type-p y))
+ (let ((x (convert-member-type x)))
+ (funcall derive-fcn x y same-arg)))
+ ((and (numeric-type-p x) (member-type-p y))
+ (let ((y (convert-member-type y)))
+ (funcall derive-fcn x y same-arg)))
+ ((and (numeric-type-p x) (numeric-type-p y))
+ (funcall derive-fcn x y same-arg))
+ (t
+ *universal-type*))))
+ (let ((same-arg (same-leaf-ref-p arg1 arg2))
+ (a1 (prepare-arg-for-derive-type (continuation-type arg1)))
+ (a2 (prepare-arg-for-derive-type (continuation-type arg2))))
+ (when (and a1 a2)
+ (let ((results nil))
+ (if same-arg
+ ;; Since the args are the same continuation, just run
+ ;; down the lists.
+ (dolist (x a1)
+ (let ((result (deriver x x same-arg)))
+ (if (listp result)
+ (setf results (append results result))
+ (push result results))))
+ ;; Try all pairwise combinations.
+ (dolist (x a1)
+ (dolist (y a2)
+ (let ((result (or (deriver x y same-arg)
+ (numeric-contagion x y))))
+ (if (listp result)
+ (setf results (append results result))
+ (push result results))))))
+ (if (rest results)
+ (make-canonical-union-type results)
+ (first results)))))))
+
+) ; PROGN
+\f
+#!-propagate-float-type
+(progn
+(defoptimizer (+ derive-type) ((x y))
+ (derive-integer-type
+ x y
+ #'(lambda (x y)
+ (flet ((frob (x y)
+ (if (and x y)
+ (+ x y)
+ nil)))
+ (values (frob (numeric-type-low x) (numeric-type-low y))
+ (frob (numeric-type-high x) (numeric-type-high y)))))))
+
+(defoptimizer (- derive-type) ((x y))
+ (derive-integer-type
+ x y
+ #'(lambda (x y)
+ (flet ((frob (x y)
+ (if (and x y)
+ (- x y)
+ nil)))
+ (values (frob (numeric-type-low x) (numeric-type-high y))
+ (frob (numeric-type-high x) (numeric-type-low y)))))))
+
+(defoptimizer (* derive-type) ((x y))
+ (derive-integer-type
+ x y
+ #'(lambda (x y)
+ (let ((x-low (numeric-type-low x))
+ (x-high (numeric-type-high x))
+ (y-low (numeric-type-low y))
+ (y-high (numeric-type-high y)))
+ (cond ((not (and x-low y-low))
+ (values nil nil))
+ ((or (minusp x-low) (minusp y-low))
+ (if (and x-high y-high)
+ (let ((max (* (max (abs x-low) (abs x-high))
+ (max (abs y-low) (abs y-high)))))
+ (values (- max) max))
+ (values nil nil)))
+ (t
+ (values (* x-low y-low)
+ (if (and x-high y-high)
+ (* x-high y-high)
+ nil))))))))
+
+(defoptimizer (/ derive-type) ((x y))
+ (numeric-contagion (continuation-type x) (continuation-type y)))
+
+) ; PROGN
+
+#!+propagate-float-type
+(progn
+(defun +-derive-type-aux (x y same-arg)
+ (if (and (numeric-type-real-p x)
+ (numeric-type-real-p y))
+ (let ((result
+ (if same-arg
+ (let ((x-int (numeric-type->interval x)))
+ (interval-add x-int x-int))
+ (interval-add (numeric-type->interval x)
+ (numeric-type->interval y))))
+ (result-type (numeric-contagion x y)))
+ ;; If the result type is a float, we need to be sure to coerce
+ ;; the bounds into the correct type.
+ (when (eq (numeric-type-class result-type) 'float)
+ (setf result (interval-func
+ #'(lambda (x)
+ (coerce x (or (numeric-type-format result-type)
+ 'float)))
+ result)))
+ (make-numeric-type
+ :class (if (and (eq (numeric-type-class x) 'integer)
+ (eq (numeric-type-class y) 'integer))
+ ;; The sum of integers is always an integer
+ 'integer
+ (numeric-type-class result-type))
+ :format (numeric-type-format result-type)
+ :low (interval-low result)
+ :high (interval-high result)))
+ ;; General contagion
+ (numeric-contagion x y)))
+
+(defoptimizer (+ derive-type) ((x y))
+ (two-arg-derive-type x y #'+-derive-type-aux #'+))
+
+(defun --derive-type-aux (x y same-arg)
+ (if (and (numeric-type-real-p x)
+ (numeric-type-real-p y))
+ (let ((result
+ ;; (- x x) is always 0.
+ (if same-arg
+ (make-interval :low 0 :high 0)
+ (interval-sub (numeric-type->interval x)
+ (numeric-type->interval y))))
+ (result-type (numeric-contagion x y)))
+ ;; If the result type is a float, we need to be sure to coerce
+ ;; the bounds into the correct type.
+ (when (eq (numeric-type-class result-type) 'float)
+ (setf result (interval-func
+ #'(lambda (x)
+ (coerce x (or (numeric-type-format result-type)
+ 'float)))
+ result)))
+ (make-numeric-type
+ :class (if (and (eq (numeric-type-class x) 'integer)
+ (eq (numeric-type-class y) 'integer))
+ ;; The difference of integers is always an integer
+ 'integer
+ (numeric-type-class result-type))
+ :format (numeric-type-format result-type)
+ :low (interval-low result)
+ :high (interval-high result)))
+ ;; General contagion
+ (numeric-contagion x y)))
+
+(defoptimizer (- derive-type) ((x y))
+ (two-arg-derive-type x y #'--derive-type-aux #'-))
+
+(defun *-derive-type-aux (x y same-arg)
+ (if (and (numeric-type-real-p x)
+ (numeric-type-real-p y))
+ (let ((result
+ ;; (* x x) is always positive, so take care to do it
+ ;; right.
+ (if same-arg
+ (interval-sqr (numeric-type->interval x))
+ (interval-mul (numeric-type->interval x)
+ (numeric-type->interval y))))
+ (result-type (numeric-contagion x y)))
+ ;; If the result type is a float, we need to be sure to coerce
+ ;; the bounds into the correct type.
+ (when (eq (numeric-type-class result-type) 'float)
+ (setf result (interval-func
+ #'(lambda (x)
+ (coerce x (or (numeric-type-format result-type)
+ 'float)))
+ result)))
+ (make-numeric-type
+ :class (if (and (eq (numeric-type-class x) 'integer)
+ (eq (numeric-type-class y) 'integer))
+ ;; The product of integers is always an integer
+ 'integer
+ (numeric-type-class result-type))
+ :format (numeric-type-format result-type)
+ :low (interval-low result)
+ :high (interval-high result)))
+ (numeric-contagion x y)))
+
+(defoptimizer (* derive-type) ((x y))
+ (two-arg-derive-type x y #'*-derive-type-aux #'*))
+
+(defun /-derive-type-aux (x y same-arg)
+ (if (and (numeric-type-real-p x)
+ (numeric-type-real-p y))
+ (let ((result
+ ;; (/ x x) is always 1, except if x can contain 0. In
+ ;; that case, we shouldn't optimize the division away
+ ;; because we want 0/0 to signal an error.
+ (if (and same-arg
+ (not (interval-contains-p
+ 0 (interval-closure (numeric-type->interval y)))))
+ (make-interval :low 1 :high 1)
+ (interval-div (numeric-type->interval x)
+ (numeric-type->interval y))))
+ (result-type (numeric-contagion x y)))
+ ;; If the result type is a float, we need to be sure to coerce
+ ;; the bounds into the correct type.
+ (when (eq (numeric-type-class result-type) 'float)
+ (setf result (interval-func
+ #'(lambda (x)
+ (coerce x (or (numeric-type-format result-type)
+ 'float)))
+ result)))
+ (make-numeric-type :class (numeric-type-class result-type)
+ :format (numeric-type-format result-type)
+ :low (interval-low result)
+ :high (interval-high result)))
+ (numeric-contagion x y)))
+
+(defoptimizer (/ derive-type) ((x y))
+ (two-arg-derive-type x y #'/-derive-type-aux #'/))
+
+) ; PROGN
+
+;;; KLUDGE: All this ASH optimization is suppressed under CMU CL
+;;; because as of version 2.4.6 for Debian, CMU CL blows up on (ASH
+;;; 1000000000 -100000000000) (i.e. ASH of two bignums yielding zero)
+;;; and it's hard to avoid that calculation in here.
+#-(and cmu sb-xc-host)
+(progn
+#!-propagate-fun-type
+(defoptimizer (ash derive-type) ((n shift))
+ (or (let ((n-type (continuation-type n)))
+ (when (numeric-type-p n-type)
+ (let ((n-low (numeric-type-low n-type))
+ (n-high (numeric-type-high n-type)))
+ (if (constant-continuation-p shift)
+ (let ((shift (continuation-value shift)))
+ (make-numeric-type :class 'integer
+ :complexp :real
+ :low (when n-low (ash n-low shift))
+ :high (when n-high (ash n-high shift))))
+ (let ((s-type (continuation-type shift)))
+ (when (numeric-type-p s-type)
+ (let ((s-low (numeric-type-low s-type))
+ (s-high (numeric-type-high s-type)))
+ (if (and s-low s-high (<= s-low 64) (<= s-high 64))
+ (make-numeric-type :class 'integer
+ :complexp :real
+ :low (when n-low
+ (min (ash n-low s-high)
+ (ash n-low s-low)))
+ :high (when n-high
+ (max (ash n-high s-high)
+ (ash n-high s-low))))
+ (make-numeric-type :class 'integer
+ :complexp :real)))))))))
+ *universal-type*))
+#!+propagate-fun-type
+(defun ash-derive-type-aux (n-type shift same-arg)
+ (declare (ignore same-arg))
+ (or (and (csubtypep n-type (specifier-type 'integer))
+ (csubtypep shift (specifier-type 'integer))
+ (let ((n-low (numeric-type-low n-type))
+ (n-high (numeric-type-high n-type))
+ (s-low (numeric-type-low shift))
+ (s-high (numeric-type-high shift)))
+ ;; KLUDGE: The bare 64's here should be related to
+ ;; symbolic machine word size values somehow.
+ (if (and s-low s-high (<= s-low 64) (<= s-high 64))
+ (make-numeric-type :class 'integer :complexp :real
+ :low (when n-low
+ (min (ash n-low s-high)
+ (ash n-low s-low)))
+ :high (when n-high
+ (max (ash n-high s-high)
+ (ash n-high s-low))))
+ (make-numeric-type :class 'integer
+ :complexp :real))))
+ *universal-type*))
+#!+propagate-fun-type
+(defoptimizer (ash derive-type) ((n shift))
+ (two-arg-derive-type n shift #'ash-derive-type-aux #'ash))
+) ; PROGN
+
+#!-propagate-float-type
+(macrolet ((frob (fun)
+ `#'(lambda (type type2)
+ (declare (ignore type2))
+ (let ((lo (numeric-type-low type))
+ (hi (numeric-type-high type)))
+ (values (if hi (,fun hi) nil) (if lo (,fun lo) nil))))))
+
+ (defoptimizer (%negate derive-type) ((num))
+ (derive-integer-type num num (frob -)))
+
+ (defoptimizer (lognot derive-type) ((int))
+ (derive-integer-type int int (frob lognot))))
+
+#!+propagate-float-type
+(defoptimizer (lognot derive-type) ((int))
+ (derive-integer-type int int
+ #'(lambda (type type2)
+ (declare (ignore type2))
+ (let ((lo (numeric-type-low type))
+ (hi (numeric-type-high type)))
+ (values (if hi (lognot hi) nil)
+ (if lo (lognot lo) nil)
+ (numeric-type-class type)
+ (numeric-type-format type))))))
+
+#!+propagate-float-type
+(defoptimizer (%negate derive-type) ((num))
+ (flet ((negate-bound (b)
+ (set-bound (- (bound-value b)) (consp b))))
+ (one-arg-derive-type num
+ #'(lambda (type)
+ (let ((lo (numeric-type-low type))
+ (hi (numeric-type-high type))
+ (result (copy-numeric-type type)))
+ (setf (numeric-type-low result)
+ (if hi (negate-bound hi) nil))
+ (setf (numeric-type-high result)
+ (if lo (negate-bound lo) nil))
+ result))
+ #'-)))
+
+#!-propagate-float-type
+(defoptimizer (abs derive-type) ((num))
+ (let ((type (continuation-type num)))
+ (if (and (numeric-type-p type)
+ (eq (numeric-type-class type) 'integer)
+ (eq (numeric-type-complexp type) :real))
+ (let ((lo (numeric-type-low type))
+ (hi (numeric-type-high type)))
+ (make-numeric-type :class 'integer :complexp :real
+ :low (cond ((and hi (minusp hi))
+ (abs hi))
+ (lo
+ (max 0 lo))
+ (t
+ 0))
+ :high (if (and hi lo)
+ (max (abs hi) (abs lo))
+ nil)))
+ (numeric-contagion type type))))
+
+#!+propagate-float-type
+(defun abs-derive-type-aux (type)
+ (cond ((eq (numeric-type-complexp type) :complex)
+ ;; The absolute value of a complex number is always a
+ ;; non-negative float.
+ (let* ((format (case (numeric-type-class type)
+ ((integer rational) 'single-float)
+ (t (numeric-type-format type))))
+ (bound-format (or format 'float)))
+ (make-numeric-type :class 'float
+ :format format
+ :complexp :real
+ :low (coerce 0 bound-format)
+ :high nil)))
+ (t
+ ;; The absolute value of a real number is a non-negative real
+ ;; of the same type.
+ (let* ((abs-bnd (interval-abs (numeric-type->interval type)))
+ (class (numeric-type-class type))
+ (format (numeric-type-format type))
+ (bound-type (or format class 'real)))
+ (make-numeric-type
+ :class class
+ :format format
+ :complexp :real
+ :low (coerce-numeric-bound (interval-low abs-bnd) bound-type)
+ :high (coerce-numeric-bound
+ (interval-high abs-bnd) bound-type))))))
+
+#!+propagate-float-type
+(defoptimizer (abs derive-type) ((num))
+ (one-arg-derive-type num #'abs-derive-type-aux #'abs))
+
+#!-propagate-float-type
+(defoptimizer (truncate derive-type) ((number divisor))
+ (let ((number-type (continuation-type number))
+ (divisor-type (continuation-type divisor))
+ (integer-type (specifier-type 'integer)))
+ (if (and (numeric-type-p number-type)
+ (csubtypep number-type integer-type)
+ (numeric-type-p divisor-type)
+ (csubtypep divisor-type integer-type))
+ (let ((number-low (numeric-type-low number-type))
+ (number-high (numeric-type-high number-type))
+ (divisor-low (numeric-type-low divisor-type))
+ (divisor-high (numeric-type-high divisor-type)))
+ (values-specifier-type
+ `(values ,(integer-truncate-derive-type number-low number-high
+ divisor-low divisor-high)
+ ,(integer-rem-derive-type number-low number-high
+ divisor-low divisor-high))))
+ *universal-type*)))
+
+#-sb-xc-host ;(CROSS-FLOAT-INFINITY-KLUDGE, see base-target-features.lisp-expr)
+(progn
+#!+propagate-float-type
+(progn
+
+(defun rem-result-type (number-type divisor-type)
+ ;; Figure out what the remainder type is. The remainder is an
+ ;; integer if both args are integers; a rational if both args are
+ ;; rational; and a float otherwise.
+ (cond ((and (csubtypep number-type (specifier-type 'integer))
+ (csubtypep divisor-type (specifier-type 'integer)))
+ 'integer)
+ ((and (csubtypep number-type (specifier-type 'rational))
+ (csubtypep divisor-type (specifier-type 'rational)))
+ 'rational)
+ ((and (csubtypep number-type (specifier-type 'float))
+ (csubtypep divisor-type (specifier-type 'float)))
+ ;; Both are floats so the result is also a float, of
+ ;; the largest type.
+ (or (float-format-max (numeric-type-format number-type)
+ (numeric-type-format divisor-type))
+ 'float))
+ ((and (csubtypep number-type (specifier-type 'float))
+ (csubtypep divisor-type (specifier-type 'rational)))
+ ;; One of the arguments is a float and the other is a
+ ;; rational. The remainder is a float of the same
+ ;; type.
+ (or (numeric-type-format number-type) 'float))
+ ((and (csubtypep divisor-type (specifier-type 'float))
+ (csubtypep number-type (specifier-type 'rational)))
+ ;; One of the arguments is a float and the other is a
+ ;; rational. The remainder is a float of the same
+ ;; type.
+ (or (numeric-type-format divisor-type) 'float))
+ (t
+ ;; Some unhandled combination. This usually means both args
+ ;; are REAL so the result is a REAL.
+ 'real)))
+
+(defun truncate-derive-type-quot (number-type divisor-type)
+ (let* ((rem-type (rem-result-type number-type divisor-type))
+ (number-interval (numeric-type->interval number-type))
+ (divisor-interval (numeric-type->interval divisor-type)))
+ ;;(declare (type (member '(integer rational float)) rem-type))
+ ;; We have real numbers now.
+ (cond ((eq rem-type 'integer)
+ ;; Since the remainder type is INTEGER, both args are
+ ;; INTEGERs.
+ (let* ((res (integer-truncate-derive-type
+ (interval-low number-interval)
+ (interval-high number-interval)
+ (interval-low divisor-interval)
+ (interval-high divisor-interval))))
+ (specifier-type (if (listp res) res 'integer))))
+ (t
+ (let ((quot (truncate-quotient-bound
+ (interval-div number-interval
+ divisor-interval))))
+ (specifier-type `(integer ,(or (interval-low quot) '*)
+ ,(or (interval-high quot) '*))))))))
+
+(defun truncate-derive-type-rem (number-type divisor-type)
+ (let* ((rem-type (rem-result-type number-type divisor-type))
+ (number-interval (numeric-type->interval number-type))
+ (divisor-interval (numeric-type->interval divisor-type))
+ (rem (truncate-rem-bound number-interval divisor-interval)))
+ ;;(declare (type (member '(integer rational float)) rem-type))
+ ;; We have real numbers now.
+ (cond ((eq rem-type 'integer)
+ ;; Since the remainder type is INTEGER, both args are
+ ;; INTEGERs.
+ (specifier-type `(,rem-type ,(or (interval-low rem) '*)
+ ,(or (interval-high rem) '*))))
+ (t
+ (multiple-value-bind (class format)
+ (ecase rem-type
+ (integer
+ (values 'integer nil))
+ (rational
+ (values 'rational nil))
+ ((or single-float double-float #!+long-float long-float)
+ (values 'float rem-type))
+ (float
+ (values 'float nil))
+ (real
+ (values nil nil)))
+ (when (member rem-type '(float single-float double-float
+ #!+long-float long-float))
+ (setf rem (interval-func #'(lambda (x)
+ (coerce x rem-type))
+ rem)))
+ (make-numeric-type :class class
+ :format format
+ :low (interval-low rem)
+ :high (interval-high rem)))))))
+
+(defun truncate-derive-type-quot-aux (num div same-arg)
+ (declare (ignore same-arg))
+ (if (and (numeric-type-real-p num)
+ (numeric-type-real-p div))
+ (truncate-derive-type-quot num div)
+ *empty-type*))
+
+(defun truncate-derive-type-rem-aux (num div same-arg)
+ (declare (ignore same-arg))
+ (if (and (numeric-type-real-p num)
+ (numeric-type-real-p div))
+ (truncate-derive-type-rem num div)
+ *empty-type*))
+
+(defoptimizer (truncate derive-type) ((number divisor))
+ (let ((quot (two-arg-derive-type number divisor
+ #'truncate-derive-type-quot-aux #'truncate))
+ (rem (two-arg-derive-type number divisor
+ #'truncate-derive-type-rem-aux #'rem)))
+ (when (and quot rem)
+ (make-values-type :required (list quot rem)))))
+
+(defun ftruncate-derive-type-quot (number-type divisor-type)
+ ;; The bounds are the same as for truncate. However, the first
+ ;; result is a float of some type. We need to determine what that
+ ;; type is. Basically it's the more contagious of the two types.
+ (let ((q-type (truncate-derive-type-quot number-type divisor-type))
+ (res-type (numeric-contagion number-type divisor-type)))
+ (make-numeric-type :class 'float
+ :format (numeric-type-format res-type)
+ :low (numeric-type-low q-type)
+ :high (numeric-type-high q-type))))
+
+(defun ftruncate-derive-type-quot-aux (n d same-arg)
+ (declare (ignore same-arg))
+ (if (and (numeric-type-real-p n)
+ (numeric-type-real-p d))
+ (ftruncate-derive-type-quot n d)
+ *empty-type*))
+
+(defoptimizer (ftruncate derive-type) ((number divisor))
+ (let ((quot
+ (two-arg-derive-type number divisor
+ #'ftruncate-derive-type-quot-aux #'ftruncate))
+ (rem (two-arg-derive-type number divisor
+ #'truncate-derive-type-rem-aux #'rem)))
+ (when (and quot rem)
+ (make-values-type :required (list quot rem)))))
+
+(defun %unary-truncate-derive-type-aux (number)
+ (truncate-derive-type-quot number (specifier-type '(integer 1 1))))
+
+(defoptimizer (%unary-truncate derive-type) ((number))
+ (one-arg-derive-type number
+ #'%unary-truncate-derive-type-aux
+ #'%unary-truncate))
+
+;;; Define optimizers for FLOOR and CEILING.
+(macrolet
+ ((frob-opt (name q-name r-name)
+ (let ((q-aux (symbolicate q-name "-AUX"))
+ (r-aux (symbolicate r-name "-AUX")))
+ `(progn
+ ;; Compute type of quotient (first) result
+ (defun ,q-aux (number-type divisor-type)
+ (let* ((number-interval
+ (numeric-type->interval number-type))
+ (divisor-interval
+ (numeric-type->interval divisor-type))
+ (quot (,q-name (interval-div number-interval
+ divisor-interval))))
+ (specifier-type `(integer ,(or (interval-low quot) '*)
+ ,(or (interval-high quot) '*)))))
+ ;; Compute type of remainder
+ (defun ,r-aux (number-type divisor-type)
+ (let* ((divisor-interval
+ (numeric-type->interval divisor-type))
+ (rem (,r-name divisor-interval))
+ (result-type (rem-result-type number-type divisor-type)))
+ (multiple-value-bind (class format)
+ (ecase result-type
+ (integer
+ (values 'integer nil))
+ (rational
+ (values 'rational nil))
+ ((or single-float double-float #!+long-float long-float)
+ (values 'float result-type))
+ (float
+ (values 'float nil))
+ (real
+ (values nil nil)))
+ (when (member result-type '(float single-float double-float
+ #!+long-float long-float))
+ ;; Make sure the limits on the interval have
+ ;; the right type.
+ (setf rem (interval-func #'(lambda (x)
+ (coerce x result-type))
+ rem)))
+ (make-numeric-type :class class
+ :format format
+ :low (interval-low rem)
+ :high (interval-high rem)))))
+ ;; The optimizer itself
+ (defoptimizer (,name derive-type) ((number divisor))
+ (flet ((derive-q (n d same-arg)
+ (declare (ignore same-arg))
+ (if (and (numeric-type-real-p n)
+ (numeric-type-real-p d))
+ (,q-aux n d)
+ *empty-type*))
+ (derive-r (n d same-arg)
+ (declare (ignore same-arg))
+ (if (and (numeric-type-real-p n)
+ (numeric-type-real-p d))
+ (,r-aux n d)
+ *empty-type*)))
+ (let ((quot (two-arg-derive-type
+ number divisor #'derive-q #',name))
+ (rem (two-arg-derive-type
+ number divisor #'derive-r #'mod)))
+ (when (and quot rem)
+ (make-values-type :required (list quot rem))))))
+ ))))
+
+ ;; FIXME: DEF-FROB-OPT, not just FROB-OPT
+ (frob-opt floor floor-quotient-bound floor-rem-bound)
+ (frob-opt ceiling ceiling-quotient-bound ceiling-rem-bound))
+
+;;; Define optimizers for FFLOOR and FCEILING
+(macrolet
+ ((frob-opt (name q-name r-name)
+ (let ((q-aux (symbolicate "F" q-name "-AUX"))
+ (r-aux (symbolicate r-name "-AUX")))
+ `(progn
+ ;; Compute type of quotient (first) result
+ (defun ,q-aux (number-type divisor-type)
+ (let* ((number-interval
+ (numeric-type->interval number-type))
+ (divisor-interval
+ (numeric-type->interval divisor-type))
+ (quot (,q-name (interval-div number-interval
+ divisor-interval)))
+ (res-type (numeric-contagion number-type divisor-type)))
+ (make-numeric-type
+ :class (numeric-type-class res-type)
+ :format (numeric-type-format res-type)
+ :low (interval-low quot)
+ :high (interval-high quot))))
+
+ (defoptimizer (,name derive-type) ((number divisor))
+ (flet ((derive-q (n d same-arg)
+ (declare (ignore same-arg))
+ (if (and (numeric-type-real-p n)
+ (numeric-type-real-p d))
+ (,q-aux n d)
+ *empty-type*))
+ (derive-r (n d same-arg)
+ (declare (ignore same-arg))
+ (if (and (numeric-type-real-p n)
+ (numeric-type-real-p d))
+ (,r-aux n d)
+ *empty-type*)))
+ (let ((quot (two-arg-derive-type
+ number divisor #'derive-q #',name))
+ (rem (two-arg-derive-type
+ number divisor #'derive-r #'mod)))
+ (when (and quot rem)
+ (make-values-type :required (list quot rem))))))))))
+
+ ;; FIXME: DEF-FROB-OPT, not just FROB-OPT
+ (frob-opt ffloor floor-quotient-bound floor-rem-bound)
+ (frob-opt fceiling ceiling-quotient-bound ceiling-rem-bound))
+
+;;; Functions to compute the bounds on the quotient and remainder for
+;;; the FLOOR function.
+(defun floor-quotient-bound (quot)
+ ;; Take the floor of the quotient and then massage it into what we
+ ;; need.
+ (let ((lo (interval-low quot))
+ (hi (interval-high quot)))
+ ;; Take the floor of the lower bound. The result is always a
+ ;; closed lower bound.
+ (setf lo (if lo
+ (floor (bound-value lo))
+ nil))
+ ;; For the upper bound, we need to be careful
+ (setf hi
+ (cond ((consp hi)
+ ;; An open bound. We need to be careful here because
+ ;; the floor of '(10.0) is 9, but the floor of
+ ;; 10.0 is 10.
+ (multiple-value-bind (q r) (floor (first hi))
+ (if (zerop r)
+ (1- q)
+ q)))
+ (hi
+ ;; A closed bound, so the answer is obvious.
+ (floor hi))
+ (t
+ hi)))
+ (make-interval :low lo :high hi)))
+(defun floor-rem-bound (div)
+ ;; The remainder depends only on the divisor. Try to get the
+ ;; correct sign for the remainder if we can.
+ (case (interval-range-info div)
+ (+
+ ;; Divisor is always positive.
+ (let ((rem (interval-abs div)))
+ (setf (interval-low rem) 0)
+ (when (and (numberp (interval-high rem))
+ (not (zerop (interval-high rem))))
+ ;; The remainder never contains the upper bound. However,
+ ;; watch out for the case where the high limit is zero!
+ (setf (interval-high rem) (list (interval-high rem))))
+ rem))
+ (-
+ ;; Divisor is always negative
+ (let ((rem (interval-neg (interval-abs div))))
+ (setf (interval-high rem) 0)
+ (when (numberp (interval-low rem))
+ ;; The remainder never contains the lower bound.
+ (setf (interval-low rem) (list (interval-low rem))))
+ rem))
+ (otherwise
+ ;; The divisor can be positive or negative. All bets off.
+ ;; The magnitude of remainder is the maximum value of the
+ ;; divisor.
+ (let ((limit (bound-value (interval-high (interval-abs div)))))
+ ;; The bound never reaches the limit, so make the interval open
+ (make-interval :low (if limit
+ (list (- limit))
+ limit)
+ :high (list limit))))))
+#| Test cases
+(floor-quotient-bound (make-interval :low 0.3 :high 10.3))
+=> #S(INTERVAL :LOW 0 :HIGH 10)
+(floor-quotient-bound (make-interval :low 0.3 :high '(10.3)))
+=> #S(INTERVAL :LOW 0 :HIGH 10)
+(floor-quotient-bound (make-interval :low 0.3 :high 10))
+=> #S(INTERVAL :LOW 0 :HIGH 10)
+(floor-quotient-bound (make-interval :low 0.3 :high '(10)))
+=> #S(INTERVAL :LOW 0 :HIGH 9)
+(floor-quotient-bound (make-interval :low '(0.3) :high 10.3))
+=> #S(INTERVAL :LOW 0 :HIGH 10)
+(floor-quotient-bound (make-interval :low '(0.0) :high 10.3))
+=> #S(INTERVAL :LOW 0 :HIGH 10)
+(floor-quotient-bound (make-interval :low '(-1.3) :high 10.3))
+=> #S(INTERVAL :LOW -2 :HIGH 10)
+(floor-quotient-bound (make-interval :low '(-1.0) :high 10.3))
+=> #S(INTERVAL :LOW -1 :HIGH 10)
+(floor-quotient-bound (make-interval :low -1.0 :high 10.3))
+=> #S(INTERVAL :LOW -1 :HIGH 10)
+
+(floor-rem-bound (make-interval :low 0.3 :high 10.3))
+=> #S(INTERVAL :LOW 0 :HIGH '(10.3))
+(floor-rem-bound (make-interval :low 0.3 :high '(10.3)))
+=> #S(INTERVAL :LOW 0 :HIGH '(10.3))
+(floor-rem-bound (make-interval :low -10 :high -2.3))
+#S(INTERVAL :LOW (-10) :HIGH 0)
+(floor-rem-bound (make-interval :low 0.3 :high 10))
+=> #S(INTERVAL :LOW 0 :HIGH '(10))
+(floor-rem-bound (make-interval :low '(-1.3) :high 10.3))
+=> #S(INTERVAL :LOW '(-10.3) :HIGH '(10.3))
+(floor-rem-bound (make-interval :low '(-20.3) :high 10.3))
+=> #S(INTERVAL :LOW (-20.3) :HIGH (20.3))
+|#
+\f
+;;; same functions for CEILING
+(defun ceiling-quotient-bound (quot)
+ ;; Take the ceiling of the quotient and then massage it into what we
+ ;; need.
+ (let ((lo (interval-low quot))
+ (hi (interval-high quot)))
+ ;; Take the ceiling of the upper bound. The result is always a
+ ;; closed upper bound.
+ (setf hi (if hi
+ (ceiling (bound-value hi))
+ nil))
+ ;; For the lower bound, we need to be careful
+ (setf lo
+ (cond ((consp lo)
+ ;; An open bound. We need to be careful here because
+ ;; the ceiling of '(10.0) is 11, but the ceiling of
+ ;; 10.0 is 10.
+ (multiple-value-bind (q r) (ceiling (first lo))
+ (if (zerop r)
+ (1+ q)
+ q)))
+ (lo
+ ;; A closed bound, so the answer is obvious.
+ (ceiling lo))
+ (t
+ lo)))
+ (make-interval :low lo :high hi)))
+(defun ceiling-rem-bound (div)
+ ;; The remainder depends only on the divisor. Try to get the
+ ;; correct sign for the remainder if we can.
+
+ (case (interval-range-info div)
+ (+
+ ;; Divisor is always positive. The remainder is negative.
+ (let ((rem (interval-neg (interval-abs div))))
+ (setf (interval-high rem) 0)
+ (when (and (numberp (interval-low rem))
+ (not (zerop (interval-low rem))))
+ ;; The remainder never contains the upper bound. However,
+ ;; watch out for the case when the upper bound is zero!
+ (setf (interval-low rem) (list (interval-low rem))))
+ rem))
+ (-
+ ;; Divisor is always negative. The remainder is positive
+ (let ((rem (interval-abs div)))
+ (setf (interval-low rem) 0)
+ (when (numberp (interval-high rem))
+ ;; The remainder never contains the lower bound.
+ (setf (interval-high rem) (list (interval-high rem))))
+ rem))
+ (otherwise
+ ;; The divisor can be positive or negative. All bets off.
+ ;; The magnitude of remainder is the maximum value of the
+ ;; divisor.
+ (let ((limit (bound-value (interval-high (interval-abs div)))))
+ ;; The bound never reaches the limit, so make the interval open
+ (make-interval :low (if limit
+ (list (- limit))
+ limit)
+ :high (list limit))))))
+
+#| Test cases
+(ceiling-quotient-bound (make-interval :low 0.3 :high 10.3))
+=> #S(INTERVAL :LOW 1 :HIGH 11)
+(ceiling-quotient-bound (make-interval :low 0.3 :high '(10.3)))
+=> #S(INTERVAL :LOW 1 :HIGH 11)
+(ceiling-quotient-bound (make-interval :low 0.3 :high 10))
+=> #S(INTERVAL :LOW 1 :HIGH 10)
+(ceiling-quotient-bound (make-interval :low 0.3 :high '(10)))
+=> #S(INTERVAL :LOW 1 :HIGH 10)
+(ceiling-quotient-bound (make-interval :low '(0.3) :high 10.3))
+=> #S(INTERVAL :LOW 1 :HIGH 11)
+(ceiling-quotient-bound (make-interval :low '(0.0) :high 10.3))
+=> #S(INTERVAL :LOW 1 :HIGH 11)
+(ceiling-quotient-bound (make-interval :low '(-1.3) :high 10.3))
+=> #S(INTERVAL :LOW -1 :HIGH 11)
+(ceiling-quotient-bound (make-interval :low '(-1.0) :high 10.3))
+=> #S(INTERVAL :LOW 0 :HIGH 11)
+(ceiling-quotient-bound (make-interval :low -1.0 :high 10.3))
+=> #S(INTERVAL :LOW -1 :HIGH 11)
+
+(ceiling-rem-bound (make-interval :low 0.3 :high 10.3))
+=> #S(INTERVAL :LOW (-10.3) :HIGH 0)
+(ceiling-rem-bound (make-interval :low 0.3 :high '(10.3)))
+=> #S(INTERVAL :LOW 0 :HIGH '(10.3))
+(ceiling-rem-bound (make-interval :low -10 :high -2.3))
+=> #S(INTERVAL :LOW 0 :HIGH (10))
+(ceiling-rem-bound (make-interval :low 0.3 :high 10))
+=> #S(INTERVAL :LOW (-10) :HIGH 0)
+(ceiling-rem-bound (make-interval :low '(-1.3) :high 10.3))
+=> #S(INTERVAL :LOW (-10.3) :HIGH (10.3))
+(ceiling-rem-bound (make-interval :low '(-20.3) :high 10.3))
+=> #S(INTERVAL :LOW (-20.3) :HIGH (20.3))
+|#
+\f
+(defun truncate-quotient-bound (quot)
+ ;; For positive quotients, truncate is exactly like floor. For
+ ;; negative quotients, truncate is exactly like ceiling. Otherwise,
+ ;; it's the union of the two pieces.
+ (case (interval-range-info quot)
+ (+
+ ;; Just like floor
+ (floor-quotient-bound quot))
+ (-
+ ;; Just like ceiling
+ (ceiling-quotient-bound quot))
+ (otherwise
+ ;; Split the interval into positive and negative pieces, compute
+ ;; the result for each piece and put them back together.
+ (destructuring-bind (neg pos) (interval-split 0 quot t t)
+ (interval-merge-pair (ceiling-quotient-bound neg)
+ (floor-quotient-bound pos))))))
+
+(defun truncate-rem-bound (num div)
+ ;; This is significantly more complicated than floor or ceiling. We
+ ;; need both the number and the divisor to determine the range. The
+ ;; basic idea is to split the ranges of num and den into positive
+ ;; and negative pieces and deal with each of the four possibilities
+ ;; in turn.
+ (case (interval-range-info num)
+ (+
+ (case (interval-range-info div)
+ (+
+ (floor-rem-bound div))
+ (-
+ (ceiling-rem-bound div))
+ (otherwise
+ (destructuring-bind (neg pos) (interval-split 0 div t t)
+ (interval-merge-pair (truncate-rem-bound num neg)
+ (truncate-rem-bound num pos))))))
+ (-
+ (case (interval-range-info div)
+ (+
+ (ceiling-rem-bound div))
+ (-
+ (floor-rem-bound div))
+ (otherwise
+ (destructuring-bind (neg pos) (interval-split 0 div t t)
+ (interval-merge-pair (truncate-rem-bound num neg)
+ (truncate-rem-bound num pos))))))
+ (otherwise
+ (destructuring-bind (neg pos) (interval-split 0 num t t)
+ (interval-merge-pair (truncate-rem-bound neg div)
+ (truncate-rem-bound pos div))))))
+)) ; end PROGN's
+
+;;; Derive useful information about the range. Returns three values:
+;;; - '+ if its positive, '- negative, or nil if it overlaps 0.
+;;; - The abs of the minimal value (i.e. closest to 0) in the range.
+;;; - The abs of the maximal value if there is one, or nil if it is
+;;; unbounded.
+(defun numeric-range-info (low high)
+ (cond ((and low (not (minusp low)))
+ (values '+ low high))
+ ((and high (not (plusp high)))
+ (values '- (- high) (if low (- low) nil)))
+ (t
+ (values nil 0 (and low high (max (- low) high))))))
+
+(defun integer-truncate-derive-type
+ (number-low number-high divisor-low divisor-high)
+ ;; The result cannot be larger in magnitude than the number, but the sign
+ ;; might change. If we can determine the sign of either the number or
+ ;; the divisor, we can eliminate some of the cases.
+ (multiple-value-bind (number-sign number-min number-max)
+ (numeric-range-info number-low number-high)
+ (multiple-value-bind (divisor-sign divisor-min divisor-max)
+ (numeric-range-info divisor-low divisor-high)
+ (when (and divisor-max (zerop divisor-max))
+ ;; We've got a problem: guaranteed division by zero.
+ (return-from integer-truncate-derive-type t))
+ (when (zerop divisor-min)
+ ;; We'll assume that they aren't going to divide by zero.
+ (incf divisor-min))
+ (cond ((and number-sign divisor-sign)
+ ;; We know the sign of both.
+ (if (eq number-sign divisor-sign)
+ ;; Same sign, so the result will be positive.
+ `(integer ,(if divisor-max
+ (truncate number-min divisor-max)
+ 0)
+ ,(if number-max
+ (truncate number-max divisor-min)
+ '*))
+ ;; Different signs, the result will be negative.
+ `(integer ,(if number-max
+ (- (truncate number-max divisor-min))
+ '*)
+ ,(if divisor-max
+ (- (truncate number-min divisor-max))
+ 0))))
+ ((eq divisor-sign '+)
+ ;; The divisor is positive. Therefore, the number will just
+ ;; become closer to zero.
+ `(integer ,(if number-low
+ (truncate number-low divisor-min)
+ '*)
+ ,(if number-high
+ (truncate number-high divisor-min)
+ '*)))
+ ((eq divisor-sign '-)
+ ;; The divisor is negative. Therefore, the absolute value of
+ ;; the number will become closer to zero, but the sign will also
+ ;; change.
+ `(integer ,(if number-high
+ (- (truncate number-high divisor-min))
+ '*)
+ ,(if number-low
+ (- (truncate number-low divisor-min))
+ '*)))
+ ;; The divisor could be either positive or negative.
+ (number-max
+ ;; The number we are dividing has a bound. Divide that by the
+ ;; smallest posible divisor.
+ (let ((bound (truncate number-max divisor-min)))
+ `(integer ,(- bound) ,bound)))
+ (t
+ ;; The number we are dividing is unbounded, so we can't tell
+ ;; anything about the result.
+ `integer)))))
+
+#!-propagate-float-type
+(defun integer-rem-derive-type
+ (number-low number-high divisor-low divisor-high)
+ (if (and divisor-low divisor-high)
+ ;; We know the range of the divisor, and the remainder must be smaller
+ ;; than the divisor. We can tell the sign of the remainer if we know
+ ;; the sign of the number.
+ (let ((divisor-max (1- (max (abs divisor-low) (abs divisor-high)))))
+ `(integer ,(if (or (null number-low)
+ (minusp number-low))
+ (- divisor-max)
+ 0)
+ ,(if (or (null number-high)
+ (plusp number-high))
+ divisor-max
+ 0)))
+ ;; The divisor is potentially either very positive or very negative.
+ ;; Therefore, the remainer is unbounded, but we might be able to tell
+ ;; something about the sign from the number.
+ `(integer ,(if (and number-low (not (minusp number-low)))
+ ;; The number we are dividing is positive. Therefore,
+ ;; the remainder must be positive.
+ 0
+ '*)
+ ,(if (and number-high (not (plusp number-high)))
+ ;; The number we are dividing is negative. Therefore,
+ ;; the remainder must be negative.
+ 0
+ '*))))
+
+#!-propagate-float-type
+(defoptimizer (random derive-type) ((bound &optional state))
+ (let ((type (continuation-type bound)))
+ (when (numeric-type-p type)
+ (let ((class (numeric-type-class type))
+ (high (numeric-type-high type))
+ (format (numeric-type-format type)))
+ (make-numeric-type
+ :class class
+ :format format
+ :low (coerce 0 (or format class 'real))
+ :high (cond ((not high) nil)
+ ((eq class 'integer) (max (1- high) 0))
+ ((or (consp high) (zerop high)) high)
+ (t `(,high))))))))
+
+#!+propagate-float-type
+(defun random-derive-type-aux (type)
+ (let ((class (numeric-type-class type))
+ (high (numeric-type-high type))
+ (format (numeric-type-format type)))
+ (make-numeric-type
+ :class class
+ :format format
+ :low (coerce 0 (or format class 'real))
+ :high (cond ((not high) nil)
+ ((eq class 'integer) (max (1- high) 0))
+ ((or (consp high) (zerop high)) high)
+ (t `(,high))))))
+
+#!+propagate-float-type
+(defoptimizer (random derive-type) ((bound &optional state))
+ (one-arg-derive-type bound #'random-derive-type-aux nil))
+\f
+;;;; logical derive-type methods
+
+;;; Return the maximum number of bits an integer of the supplied type can take
+;;; up, or NIL if it is unbounded. The second (third) value is T if the
+;;; integer can be positive (negative) and NIL if not. Zero counts as
+;;; positive.
+(defun integer-type-length (type)
+ (if (numeric-type-p type)
+ (let ((min (numeric-type-low type))
+ (max (numeric-type-high type)))
+ (values (and min max (max (integer-length min) (integer-length max)))
+ (or (null max) (not (minusp max)))
+ (or (null min) (minusp min))))
+ (values nil t t)))
+
+#!-propagate-fun-type
+(progn
+(defoptimizer (logand derive-type) ((x y))
+ (multiple-value-bind (x-len x-pos x-neg)
+ (integer-type-length (continuation-type x))
+ (declare (ignore x-pos))
+ (multiple-value-bind (y-len y-pos y-neg)
+ (integer-type-length (continuation-type y))
+ (declare (ignore y-pos))
+ (if (not x-neg)
+ ;; X must be positive.
+ (if (not y-neg)
+ ;; The must both be positive.
+ (cond ((or (null x-len) (null y-len))
+ (specifier-type 'unsigned-byte))
+ ((or (zerop x-len) (zerop y-len))
+ (specifier-type '(integer 0 0)))
+ (t
+ (specifier-type `(unsigned-byte ,(min x-len y-len)))))
+ ;; X is positive, but Y might be negative.
+ (cond ((null x-len)
+ (specifier-type 'unsigned-byte))
+ ((zerop x-len)
+ (specifier-type '(integer 0 0)))
+ (t
+ (specifier-type `(unsigned-byte ,x-len)))))
+ ;; X might be negative.
+ (if (not y-neg)
+ ;; Y must be positive.
+ (cond ((null y-len)
+ (specifier-type 'unsigned-byte))
+ ((zerop y-len)
+ (specifier-type '(integer 0 0)))
+ (t
+ (specifier-type
+ `(unsigned-byte ,y-len))))
+ ;; Either might be negative.
+ (if (and x-len y-len)
+ ;; The result is bounded.
+ (specifier-type `(signed-byte ,(1+ (max x-len y-len))))
+ ;; We can't tell squat about the result.
+ (specifier-type 'integer)))))))
+
+(defoptimizer (logior derive-type) ((x y))
+ (multiple-value-bind (x-len x-pos x-neg)
+ (integer-type-length (continuation-type x))
+ (multiple-value-bind (y-len y-pos y-neg)
+ (integer-type-length (continuation-type y))
+ (cond
+ ((and (not x-neg) (not y-neg))
+ ;; Both are positive.
+ (specifier-type `(unsigned-byte ,(if (and x-len y-len)
+ (max x-len y-len)
+ '*))))
+ ((not x-pos)
+ ;; X must be negative.
+ (if (not y-pos)
+ ;; Both are negative. The result is going to be negative and be
+ ;; the same length or shorter than the smaller.
+ (if (and x-len y-len)
+ ;; It's bounded.
+ (specifier-type `(integer ,(ash -1 (min x-len y-len)) -1))
+ ;; It's unbounded.
+ (specifier-type '(integer * -1)))
+ ;; X is negative, but we don't know about Y. The result will be
+ ;; negative, but no more negative than X.
+ (specifier-type
+ `(integer ,(or (numeric-type-low (continuation-type x)) '*)
+ -1))))
+ (t
+ ;; X might be either positive or negative.
+ (if (not y-pos)
+ ;; But Y is negative. The result will be negative.
+ (specifier-type
+ `(integer ,(or (numeric-type-low (continuation-type y)) '*)
+ -1))
+ ;; We don't know squat about either. It won't get any bigger.
+ (if (and x-len y-len)
+ ;; Bounded.
+ (specifier-type `(signed-byte ,(1+ (max x-len y-len))))
+ ;; Unbounded.
+ (specifier-type 'integer))))))))
+
+(defoptimizer (logxor derive-type) ((x y))
+ (multiple-value-bind (x-len x-pos x-neg)
+ (integer-type-length (continuation-type x))
+ (multiple-value-bind (y-len y-pos y-neg)
+ (integer-type-length (continuation-type y))
+ (cond
+ ((or (and (not x-neg) (not y-neg))
+ (and (not x-pos) (not y-pos)))
+ ;; Either both are negative or both are positive. The result will be
+ ;; positive, and as long as the longer.
+ (specifier-type `(unsigned-byte ,(if (and x-len y-len)
+ (max x-len y-len)
+ '*))))
+ ((or (and (not x-pos) (not y-neg))
+ (and (not y-neg) (not y-pos)))
+ ;; Either X is negative and Y is positive of vice-verca. The result
+ ;; will be negative.
+ (specifier-type `(integer ,(if (and x-len y-len)
+ (ash -1 (max x-len y-len))
+ '*)
+ -1)))
+ ;; We can't tell what the sign of the result is going to be. All we
+ ;; know is that we don't create new bits.
+ ((and x-len y-len)
+ (specifier-type `(signed-byte ,(1+ (max x-len y-len)))))
+ (t
+ (specifier-type 'integer))))))
+
+) ; PROGN
+
+#!+propagate-fun-type
+(progn
+(defun logand-derive-type-aux (x y &optional same-leaf)
+ (declare (ignore same-leaf))
+ (multiple-value-bind (x-len x-pos x-neg) (integer-type-length x)
+ (declare (ignore x-pos))
+ (multiple-value-bind (y-len y-pos y-neg) (integer-type-length y)
+ (declare (ignore y-pos))
+ (if (not x-neg)
+ ;; X must be positive.
+ (if (not y-neg)
+ ;; The must both be positive.
+ (cond ((or (null x-len) (null y-len))
+ (specifier-type 'unsigned-byte))
+ ((or (zerop x-len) (zerop y-len))
+ (specifier-type '(integer 0 0)))
+ (t
+ (specifier-type `(unsigned-byte ,(min x-len y-len)))))
+ ;; X is positive, but Y might be negative.
+ (cond ((null x-len)
+ (specifier-type 'unsigned-byte))
+ ((zerop x-len)
+ (specifier-type '(integer 0 0)))
+ (t
+ (specifier-type `(unsigned-byte ,x-len)))))
+ ;; X might be negative.
+ (if (not y-neg)
+ ;; Y must be positive.
+ (cond ((null y-len)
+ (specifier-type 'unsigned-byte))
+ ((zerop y-len)
+ (specifier-type '(integer 0 0)))
+ (t
+ (specifier-type
+ `(unsigned-byte ,y-len))))
+ ;; Either might be negative.
+ (if (and x-len y-len)
+ ;; The result is bounded.
+ (specifier-type `(signed-byte ,(1+ (max x-len y-len))))
+ ;; We can't tell squat about the result.
+ (specifier-type 'integer)))))))
+
+(defun logior-derive-type-aux (x y &optional same-leaf)
+ (declare (ignore same-leaf))
+ (multiple-value-bind (x-len x-pos x-neg) (integer-type-length x)
+ (multiple-value-bind (y-len y-pos y-neg) (integer-type-length y)
+ (cond
+ ((and (not x-neg) (not y-neg))
+ ;; Both are positive.
+ (if (and x-len y-len (zerop x-len) (zerop y-len))
+ (specifier-type '(integer 0 0))
+ (specifier-type `(unsigned-byte ,(if (and x-len y-len)
+ (max x-len y-len)
+ '*)))))
+ ((not x-pos)
+ ;; X must be negative.
+ (if (not y-pos)
+ ;; Both are negative. The result is going to be negative and be
+ ;; the same length or shorter than the smaller.
+ (if (and x-len y-len)
+ ;; It's bounded.
+ (specifier-type `(integer ,(ash -1 (min x-len y-len)) -1))
+ ;; It's unbounded.
+ (specifier-type '(integer * -1)))
+ ;; X is negative, but we don't know about Y. The result will be
+ ;; negative, but no more negative than X.
+ (specifier-type
+ `(integer ,(or (numeric-type-low x) '*)
+ -1))))
+ (t
+ ;; X might be either positive or negative.
+ (if (not y-pos)
+ ;; But Y is negative. The result will be negative.
+ (specifier-type
+ `(integer ,(or (numeric-type-low y) '*)
+ -1))
+ ;; We don't know squat about either. It won't get any bigger.
+ (if (and x-len y-len)
+ ;; Bounded.
+ (specifier-type `(signed-byte ,(1+ (max x-len y-len))))
+ ;; Unbounded.
+ (specifier-type 'integer))))))))
+
+(defun logxor-derive-type-aux (x y &optional same-leaf)
+ (declare (ignore same-leaf))
+ (multiple-value-bind (x-len x-pos x-neg) (integer-type-length x)
+ (multiple-value-bind (y-len y-pos y-neg) (integer-type-length y)
+ (cond
+ ((or (and (not x-neg) (not y-neg))
+ (and (not x-pos) (not y-pos)))
+ ;; Either both are negative or both are positive. The result will be
+ ;; positive, and as long as the longer.
+ (if (and x-len y-len (zerop x-len) (zerop y-len))
+ (specifier-type '(integer 0 0))
+ (specifier-type `(unsigned-byte ,(if (and x-len y-len)
+ (max x-len y-len)
+ '*)))))
+ ((or (and (not x-pos) (not y-neg))
+ (and (not y-neg) (not y-pos)))
+ ;; Either X is negative and Y is positive of vice-verca. The result
+ ;; will be negative.
+ (specifier-type `(integer ,(if (and x-len y-len)
+ (ash -1 (max x-len y-len))
+ '*)
+ -1)))
+ ;; We can't tell what the sign of the result is going to be. All we
+ ;; know is that we don't create new bits.
+ ((and x-len y-len)
+ (specifier-type `(signed-byte ,(1+ (max x-len y-len)))))
+ (t
+ (specifier-type 'integer))))))
+
+(macrolet ((frob (logfcn)
+ (let ((fcn-aux (symbolicate logfcn "-DERIVE-TYPE-AUX")))
+ `(defoptimizer (,logfcn derive-type) ((x y))
+ (two-arg-derive-type x y #',fcn-aux #',logfcn)))))
+ ;; FIXME: DEF-FROB, not just FROB
+ (frob logand)
+ (frob logior)
+ (frob logxor))
+
+) ; PROGN
+\f
+;;;; miscellaneous derive-type methods
+
+(defoptimizer (code-char derive-type) ((code))
+ (specifier-type 'base-char))
+
+(defoptimizer (values derive-type) ((&rest values))
+ (values-specifier-type
+ `(values ,@(mapcar #'(lambda (x)
+ (type-specifier (continuation-type x)))
+ values))))
+\f
+;;;; byte operations
+;;;;
+;;;; We try to turn byte operations into simple logical operations. First, we
+;;;; convert byte specifiers into separate size and position arguments passed
+;;;; to internal %FOO functions. We then attempt to transform the %FOO
+;;;; functions into boolean operations when the size and position are constant
+;;;; and the operands are fixnums.
+
+(macrolet (;; Evaluate body with Size-Var and Pos-Var bound to expressions that
+ ;; evaluate to the Size and Position of the byte-specifier form
+ ;; Spec. We may wrap a let around the result of the body to bind
+ ;; some variables.
+ ;;
+ ;; If the spec is a Byte form, then bind the vars to the subforms.
+ ;; otherwise, evaluate Spec and use the Byte-Size and Byte-Position.
+ ;; The goal of this transformation is to avoid consing up byte
+ ;; specifiers and then immediately throwing them away.
+ (with-byte-specifier ((size-var pos-var spec) &body body)
+ (once-only ((spec `(macroexpand ,spec))
+ (temp '(gensym)))
+ `(if (and (consp ,spec)
+ (eq (car ,spec) 'byte)
+ (= (length ,spec) 3))
+ (let ((,size-var (second ,spec))
+ (,pos-var (third ,spec)))
+ ,@body)
+ (let ((,size-var `(byte-size ,,temp))
+ (,pos-var `(byte-position ,,temp)))
+ `(let ((,,temp ,,spec))
+ ,,@body))))))
+
+ (def-source-transform ldb (spec int)
+ (with-byte-specifier (size pos spec)
+ `(%ldb ,size ,pos ,int)))
+
+ (def-source-transform dpb (newbyte spec int)
+ (with-byte-specifier (size pos spec)
+ `(%dpb ,newbyte ,size ,pos ,int)))
+
+ (def-source-transform mask-field (spec int)
+ (with-byte-specifier (size pos spec)
+ `(%mask-field ,size ,pos ,int)))
+
+ (def-source-transform deposit-field (newbyte spec int)
+ (with-byte-specifier (size pos spec)
+ `(%deposit-field ,newbyte ,size ,pos ,int))))
+
+(defoptimizer (%ldb derive-type) ((size posn num))
+ (let ((size (continuation-type size)))
+ (if (and (numeric-type-p size)
+ (csubtypep size (specifier-type 'integer)))
+ (let ((size-high (numeric-type-high size)))
+ (if (and size-high (<= size-high sb!vm:word-bits))
+ (specifier-type `(unsigned-byte ,size-high))
+ (specifier-type 'unsigned-byte)))
+ *universal-type*)))
+
+(defoptimizer (%mask-field derive-type) ((size posn num))
+ (let ((size (continuation-type size))
+ (posn (continuation-type posn)))
+ (if (and (numeric-type-p size)
+ (csubtypep size (specifier-type 'integer))
+ (numeric-type-p posn)
+ (csubtypep posn (specifier-type 'integer)))
+ (let ((size-high (numeric-type-high size))
+ (posn-high (numeric-type-high posn)))
+ (if (and size-high posn-high
+ (<= (+ size-high posn-high) sb!vm:word-bits))
+ (specifier-type `(unsigned-byte ,(+ size-high posn-high)))
+ (specifier-type 'unsigned-byte)))
+ *universal-type*)))
+
+(defoptimizer (%dpb derive-type) ((newbyte size posn int))
+ (let ((size (continuation-type size))
+ (posn (continuation-type posn))
+ (int (continuation-type int)))
+ (if (and (numeric-type-p size)
+ (csubtypep size (specifier-type 'integer))
+ (numeric-type-p posn)
+ (csubtypep posn (specifier-type 'integer))
+ (numeric-type-p int)
+ (csubtypep int (specifier-type 'integer)))
+ (let ((size-high (numeric-type-high size))
+ (posn-high (numeric-type-high posn))
+ (high (numeric-type-high int))
+ (low (numeric-type-low int)))
+ (if (and size-high posn-high high low
+ (<= (+ size-high posn-high) sb!vm:word-bits))
+ (specifier-type
+ (list (if (minusp low) 'signed-byte 'unsigned-byte)
+ (max (integer-length high)
+ (integer-length low)
+ (+ size-high posn-high))))
+ *universal-type*))
+ *universal-type*)))
+
+(defoptimizer (%deposit-field derive-type) ((newbyte size posn int))
+ (let ((size (continuation-type size))
+ (posn (continuation-type posn))
+ (int (continuation-type int)))
+ (if (and (numeric-type-p size)
+ (csubtypep size (specifier-type 'integer))
+ (numeric-type-p posn)
+ (csubtypep posn (specifier-type 'integer))
+ (numeric-type-p int)
+ (csubtypep int (specifier-type 'integer)))
+ (let ((size-high (numeric-type-high size))
+ (posn-high (numeric-type-high posn))
+ (high (numeric-type-high int))
+ (low (numeric-type-low int)))
+ (if (and size-high posn-high high low
+ (<= (+ size-high posn-high) sb!vm:word-bits))
+ (specifier-type
+ (list (if (minusp low) 'signed-byte 'unsigned-byte)
+ (max (integer-length high)
+ (integer-length low)
+ (+ size-high posn-high))))
+ *universal-type*))
+ *universal-type*)))
+
+(deftransform %ldb ((size posn int)
+ (fixnum fixnum integer)
+ (unsigned-byte #.sb!vm:word-bits))
+ "convert to inline logical ops"
+ `(logand (ash int (- posn))
+ (ash ,(1- (ash 1 sb!vm:word-bits))
+ (- size ,sb!vm:word-bits))))
+
+(deftransform %mask-field ((size posn int)
+ (fixnum fixnum integer)
+ (unsigned-byte #.sb!vm:word-bits))
+ "convert to inline logical ops"
+ `(logand int
+ (ash (ash ,(1- (ash 1 sb!vm:word-bits))
+ (- size ,sb!vm:word-bits))
+ posn)))
+
+;;; Note: for %DPB and %DEPOSIT-FIELD, we can't use
+;;; (OR (SIGNED-BYTE N) (UNSIGNED-BYTE N))
+;;; as the result type, as that would allow result types
+;;; that cover the range -2^(n-1) .. 1-2^n, instead of allowing result types
+;;; of (UNSIGNED-BYTE N) and result types of (SIGNED-BYTE N).
+
+(deftransform %dpb ((new size posn int)
+ *
+ (unsigned-byte #.sb!vm:word-bits))
+ "convert to inline logical ops"
+ `(let ((mask (ldb (byte size 0) -1)))
+ (logior (ash (logand new mask) posn)
+ (logand int (lognot (ash mask posn))))))
+
+(deftransform %dpb ((new size posn int)
+ *
+ (signed-byte #.sb!vm:word-bits))
+ "convert to inline logical ops"
+ `(let ((mask (ldb (byte size 0) -1)))
+ (logior (ash (logand new mask) posn)
+ (logand int (lognot (ash mask posn))))))
+
+(deftransform %deposit-field ((new size posn int)
+ *
+ (unsigned-byte #.sb!vm:word-bits))
+ "convert to inline logical ops"
+ `(let ((mask (ash (ldb (byte size 0) -1) posn)))
+ (logior (logand new mask)
+ (logand int (lognot mask)))))
+
+(deftransform %deposit-field ((new size posn int)
+ *
+ (signed-byte #.sb!vm:word-bits))
+ "convert to inline logical ops"
+ `(let ((mask (ash (ldb (byte size 0) -1) posn)))
+ (logior (logand new mask)
+ (logand int (lognot mask)))))
+\f
+;;; miscellanous numeric transforms
+
+;;; If a constant appears as the first arg, swap the args.
+(deftransform commutative-arg-swap ((x y) * * :defun-only t :node node)
+ (if (and (constant-continuation-p x)
+ (not (constant-continuation-p y)))
+ `(,(continuation-function-name (basic-combination-fun node))
+ y
+ ,(continuation-value x))
+ (give-up-ir1-transform)))
+
+(dolist (x '(= char= + * logior logand logxor))
+ (%deftransform x '(function * *) #'commutative-arg-swap
+ "place constant arg last."))
+
+;;; Handle the case of a constant BOOLE-CODE.
+(deftransform boole ((op x y) * * :when :both)
+ "convert to inline logical ops"
+ (unless (constant-continuation-p op)
+ (give-up-ir1-transform "BOOLE code is not a constant."))
+ (let ((control (continuation-value op)))
+ (case control
+ (#.boole-clr 0)
+ (#.boole-set -1)
+ (#.boole-1 'x)
+ (#.boole-2 'y)
+ (#.boole-c1 '(lognot x))
+ (#.boole-c2 '(lognot y))
+ (#.boole-and '(logand x y))
+ (#.boole-ior '(logior x y))
+ (#.boole-xor '(logxor x y))
+ (#.boole-eqv '(logeqv x y))
+ (#.boole-nand '(lognand x y))
+ (#.boole-nor '(lognor x y))
+ (#.boole-andc1 '(logandc1 x y))
+ (#.boole-andc2 '(logandc2 x y))
+ (#.boole-orc1 '(logorc1 x y))
+ (#.boole-orc2 '(logorc2 x y))
+ (t
+ (abort-ir1-transform "~S is an illegal control arg to BOOLE."
+ control)))))
+\f
+;;;; converting special case multiply/divide to shifts
+
+;;; If arg is a constant power of two, turn * into a shift.
+(deftransform * ((x y) (integer integer) * :when :both)
+ "convert x*2^k to shift"
+ (unless (constant-continuation-p y)
+ (give-up-ir1-transform))
+ (let* ((y (continuation-value y))
+ (y-abs (abs y))
+ (len (1- (integer-length y-abs))))
+ (unless (= y-abs (ash 1 len))
+ (give-up-ir1-transform))
+ (if (minusp y)
+ `(- (ash x ,len))
+ `(ash x ,len))))
+
+;;; If both arguments and the result are (unsigned-byte 32), try to come up
+;;; with a ``better'' multiplication using multiplier recoding. There are two
+;;; different ways the multiplier can be recoded. The more obvious is to shift
+;;; X by the correct amount for each bit set in Y and to sum the results. But
+;;; if there is a string of bits that are all set, you can add X shifted by
+;;; one more then the bit position of the first set bit and subtract X shifted
+;;; by the bit position of the last set bit. We can't use this second method
+;;; when the high order bit is bit 31 because shifting by 32 doesn't work
+;;; too well.
+(deftransform * ((x y)
+ ((unsigned-byte 32) (unsigned-byte 32))
+ (unsigned-byte 32))
+ "recode as shift and add"
+ (unless (constant-continuation-p y)
+ (give-up-ir1-transform))
+ (let ((y (continuation-value y))
+ (result nil)
+ (first-one nil))
+ (labels ((tub32 (x) `(truly-the (unsigned-byte 32) ,x))
+ (add (next-factor)
+ (setf result
+ (tub32
+ (if result
+ `(+ ,result ,(tub32 next-factor))
+ next-factor)))))
+ (declare (inline add))
+ (dotimes (bitpos 32)
+ (if first-one
+ (when (not (logbitp bitpos y))
+ (add (if (= (1+ first-one) bitpos)
+ ;; There is only a single bit in the string.
+ `(ash x ,first-one)
+ ;; There are at least two.
+ `(- ,(tub32 `(ash x ,bitpos))
+ ,(tub32 `(ash x ,first-one)))))
+ (setf first-one nil))
+ (when (logbitp bitpos y)
+ (setf first-one bitpos))))
+ (when first-one
+ (cond ((= first-one 31))
+ ((= first-one 30)
+ (add '(ash x 30)))
+ (t
+ (add `(- ,(tub32 '(ash x 31)) ,(tub32 `(ash x ,first-one))))))
+ (add '(ash x 31))))
+ (or result 0)))
+
+;;; If arg is a constant power of two, turn FLOOR into a shift and mask.
+;;; If CEILING, add in (1- (ABS Y)) and then do FLOOR.
+(flet ((frob (y ceil-p)
+ (unless (constant-continuation-p y)
+ (give-up-ir1-transform))
+ (let* ((y (continuation-value y))
+ (y-abs (abs y))
+ (len (1- (integer-length y-abs))))
+ (unless (= y-abs (ash 1 len))
+ (give-up-ir1-transform))
+ (let ((shift (- len))
+ (mask (1- y-abs)))
+ `(let ,(when ceil-p `((x (+ x ,(1- y-abs)))))
+ ,(if (minusp y)
+ `(values (ash (- x) ,shift)
+ (- (logand (- x) ,mask)))
+ `(values (ash x ,shift)
+ (logand x ,mask))))))))
+ (deftransform floor ((x y) (integer integer) *)
+ "convert division by 2^k to shift"
+ (frob y nil))
+ (deftransform ceiling ((x y) (integer integer) *)
+ "convert division by 2^k to shift"
+ (frob y t)))
+
+;;; Do the same for MOD.
+(deftransform mod ((x y) (integer integer) * :when :both)
+ "convert remainder mod 2^k to LOGAND"
+ (unless (constant-continuation-p y)
+ (give-up-ir1-transform))
+ (let* ((y (continuation-value y))
+ (y-abs (abs y))
+ (len (1- (integer-length y-abs))))
+ (unless (= y-abs (ash 1 len))
+ (give-up-ir1-transform))
+ (let ((mask (1- y-abs)))
+ (if (minusp y)
+ `(- (logand (- x) ,mask))
+ `(logand x ,mask)))))
+
+;;; If arg is a constant power of two, turn TRUNCATE into a shift and mask.
+(deftransform truncate ((x y) (integer integer))
+ "convert division by 2^k to shift"
+ (unless (constant-continuation-p y)
+ (give-up-ir1-transform))
+ (let* ((y (continuation-value y))
+ (y-abs (abs y))
+ (len (1- (integer-length y-abs))))
+ (unless (= y-abs (ash 1 len))
+ (give-up-ir1-transform))
+ (let* ((shift (- len))
+ (mask (1- y-abs)))
+ `(if (minusp x)
+ (values ,(if (minusp y)
+ `(ash (- x) ,shift)
+ `(- (ash (- x) ,shift)))
+ (- (logand (- x) ,mask)))
+ (values ,(if (minusp y)
+ `(- (ash (- x) ,shift))
+ `(ash x ,shift))
+ (logand x ,mask))))))
+
+;;; And the same for REM.
+(deftransform rem ((x y) (integer integer) * :when :both)
+ "convert remainder mod 2^k to LOGAND"
+ (unless (constant-continuation-p y)
+ (give-up-ir1-transform))
+ (let* ((y (continuation-value y))
+ (y-abs (abs y))
+ (len (1- (integer-length y-abs))))
+ (unless (= y-abs (ash 1 len))
+ (give-up-ir1-transform))
+ (let ((mask (1- y-abs)))
+ `(if (minusp x)
+ (- (logand (- x) ,mask))
+ (logand x ,mask)))))
+\f
+;;;; arithmetic and logical identity operation elimination
+;;;;
+;;;; Flush calls to various arith functions that convert to the identity
+;;;; function or a constant.
+
+(dolist (stuff '((ash 0 x)
+ (logand -1 x)
+ (logand 0 0)
+ (logior 0 x)
+ (logior -1 -1)
+ (logxor -1 (lognot x))
+ (logxor 0 x)))
+ (destructuring-bind (name identity result) stuff
+ (deftransform name ((x y) `(* (constant-argument (member ,identity))) '*
+ :eval-name t :when :both)
+ "fold identity operations"
+ result)))
+
+;;; These are restricted to rationals, because (- 0 0.0) is 0.0, not -0.0, and
+;;; (* 0 -4.0) is -0.0.
+(deftransform - ((x y) ((constant-argument (member 0)) rational) *
+ :when :both)
+ "convert (- 0 x) to negate"
+ '(%negate y))
+(deftransform * ((x y) (rational (constant-argument (member 0))) *
+ :when :both)
+ "convert (* x 0) to 0."
+ 0)
+
+;;; Return T if in an arithmetic op including continuations X and Y, the
+;;; result type is not affected by the type of X. That is, Y is at least as
+;;; contagious as X.
+#+nil
+(defun not-more-contagious (x y)
+ (declare (type continuation x y))
+ (let ((x (continuation-type x))
+ (y (continuation-type y)))
+ (values (type= (numeric-contagion x y)
+ (numeric-contagion y y)))))
+;;; Patched version by Raymond Toy. dtc: Should be safer although it
+;;; needs more work as valid transforms are missed; some cases are
+;;; specific to particular transform functions so the use of this
+;;; function may need a re-think.
+(defun not-more-contagious (x y)
+ (declare (type continuation x y))
+ (flet ((simple-numeric-type (num)
+ (and (numeric-type-p num)
+ ;; Return non-NIL if NUM is integer, rational, or a float
+ ;; of some type (but not FLOAT)
+ (case (numeric-type-class num)
+ ((integer rational)
+ t)
+ (float
+ (numeric-type-format num))
+ (t
+ nil)))))
+ (let ((x (continuation-type x))
+ (y (continuation-type y)))
+ (if (and (simple-numeric-type x)
+ (simple-numeric-type y))
+ (values (type= (numeric-contagion x y)
+ (numeric-contagion y y)))))))
+
+;;; Fold (+ x 0).
+;;;
+;;; If y is not constant, not zerop, or is contagious, or a
+;;; positive float +0.0 then give up.
+(deftransform + ((x y) (t (constant-argument t)) * :when :both)
+ "fold zero arg"
+ (let ((val (continuation-value y)))
+ (unless (and (zerop val)
+ (not (and (floatp val) (plusp (float-sign val))))
+ (not-more-contagious y x))
+ (give-up-ir1-transform)))
+ 'x)
+
+;;; Fold (- x 0).
+;;;
+;;; If y is not constant, not zerop, or is contagious, or a
+;;; negative float -0.0 then give up.
+(deftransform - ((x y) (t (constant-argument t)) * :when :both)
+ "fold zero arg"
+ (let ((val (continuation-value y)))
+ (unless (and (zerop val)
+ (not (and (floatp val) (minusp (float-sign val))))
+ (not-more-contagious y x))
+ (give-up-ir1-transform)))
+ 'x)
+
+;;; Fold (OP x +/-1)
+(dolist (stuff '((* x (%negate x))
+ (/ x (%negate x))
+ (expt x (/ 1 x))))
+ (destructuring-bind (name result minus-result) stuff
+ (deftransform name ((x y) '(t (constant-argument real)) '* :eval-name t
+ :when :both)
+ "fold identity operations"
+ (let ((val (continuation-value y)))
+ (unless (and (= (abs val) 1)
+ (not-more-contagious y x))
+ (give-up-ir1-transform))
+ (if (minusp val) minus-result result)))))
+
+;;; Fold (expt x n) into multiplications for small integral values of
+;;; N; convert (expt x 1/2) to sqrt.
+(deftransform expt ((x y) (t (constant-argument real)) *)
+ "recode as multiplication or sqrt"
+ (let ((val (continuation-value y)))
+ ;; If Y would cause the result to be promoted to the same type as
+ ;; Y, we give up. If not, then the result will be the same type
+ ;; as X, so we can replace the exponentiation with simple
+ ;; multiplication and division for small integral powers.
+ (unless (not-more-contagious y x)
+ (give-up-ir1-transform))
+ (cond ((zerop val) '(float 1 x))
+ ((= val 2) '(* x x))
+ ((= val -2) '(/ (* x x)))
+ ((= val 3) '(* x x x))
+ ((= val -3) '(/ (* x x x)))
+ ((= val 1/2) '(sqrt x))
+ ((= val -1/2) '(/ (sqrt x)))
+ (t (give-up-ir1-transform)))))
+
+;;; KLUDGE: Shouldn't (/ 0.0 0.0), etc. cause exceptions in these
+;;; transformations?
+;;; Perhaps we should have to prove that the denominator is nonzero before
+;;; doing them? (Also the DOLIST over macro calls is weird. Perhaps
+;;; just FROB?) -- WHN 19990917
+(dolist (name '(ash /))
+ (deftransform name ((x y) '((constant-argument (integer 0 0)) integer) '*
+ :eval-name t :when :both)
+ "fold zero arg"
+ 0))
+(dolist (name '(truncate round floor ceiling))
+ (deftransform name ((x y) '((constant-argument (integer 0 0)) integer) '*
+ :eval-name t :when :both)
+ "fold zero arg"
+ '(values 0 0)))
+\f
+;;;; character operations
+
+(deftransform char-equal ((a b) (base-char base-char))
+ "open code"
+ '(let* ((ac (char-code a))
+ (bc (char-code b))
+ (sum (logxor ac bc)))
+ (or (zerop sum)
+ (when (eql sum #x20)
+ (let ((sum (+ ac bc)))
+ (and (> sum 161) (< sum 213)))))))
+
+(deftransform char-upcase ((x) (base-char))
+ "open code"
+ '(let ((n-code (char-code x)))
+ (if (and (> n-code #o140) ; Octal 141 is #\a.
+ (< n-code #o173)) ; Octal 172 is #\z.
+ (code-char (logxor #x20 n-code))
+ x)))
+
+(deftransform char-downcase ((x) (base-char))
+ "open code"
+ '(let ((n-code (char-code x)))
+ (if (and (> n-code 64) ; 65 is #\A.
+ (< n-code 91)) ; 90 is #\Z.
+ (code-char (logxor #x20 n-code))
+ x)))
+\f
+;;;; equality predicate transforms
+
+;;; Return true if X and Y are continuations whose only use is a reference
+;;; to the same leaf, and the value of the leaf cannot change.
+(defun same-leaf-ref-p (x y)
+ (declare (type continuation x y))
+ (let ((x-use (continuation-use x))
+ (y-use (continuation-use y)))
+ (and (ref-p x-use)
+ (ref-p y-use)
+ (eq (ref-leaf x-use) (ref-leaf y-use))
+ (constant-reference-p x-use))))
+
+;;; If X and Y are the same leaf, then the result is true. Otherwise, if
+;;; there is no intersection between the types of the arguments, then the
+;;; result is definitely false.
+(deftransform simple-equality-transform ((x y) * * :defun-only t
+ :when :both)
+ (cond ((same-leaf-ref-p x y)
+ 't)
+ ((not (types-intersect (continuation-type x) (continuation-type y)))
+ 'nil)
+ (t
+ (give-up-ir1-transform))))
+
+(dolist (x '(eq char= equal))
+ (%deftransform x '(function * *) #'simple-equality-transform))
+
+;;; Similar to SIMPLE-EQUALITY-PREDICATE, except that we also try to convert
+;;; to a type-specific predicate or EQ:
+;;; -- If both args are characters, convert to CHAR=. This is better than just
+;;; converting to EQ, since CHAR= may have special compilation strategies
+;;; for non-standard representations, etc.
+;;; -- If either arg is definitely not a number, then we can compare with EQ.
+;;; -- Otherwise, we try to put the arg we know more about second. If X is
+;;; constant then we put it second. If X is a subtype of Y, we put it
+;;; second. These rules make it easier for the back end to match these
+;;; interesting cases.
+;;; -- If Y is a fixnum, then we quietly pass because the back end can handle
+;;; that case, otherwise give an efficency note.
+(deftransform eql ((x y) * * :when :both)
+ "convert to simpler equality predicate"
+ (let ((x-type (continuation-type x))
+ (y-type (continuation-type y))
+ (char-type (specifier-type 'character))
+ (number-type (specifier-type 'number)))
+ (cond ((same-leaf-ref-p x y)
+ 't)
+ ((not (types-intersect x-type y-type))
+ 'nil)
+ ((and (csubtypep x-type char-type)
+ (csubtypep y-type char-type))
+ '(char= x y))
+ ((or (not (types-intersect x-type number-type))
+ (not (types-intersect y-type number-type)))
+ '(eq x y))
+ ((and (not (constant-continuation-p y))
+ (or (constant-continuation-p x)
+ (and (csubtypep x-type y-type)
+ (not (csubtypep y-type x-type)))))
+ '(eql y x))
+ (t
+ (give-up-ir1-transform)))))
+
+;;; Convert to EQL if both args are rational and complexp is specified
+;;; and the same for both.
+(deftransform = ((x y) * * :when :both)
+ "open code"
+ (let ((x-type (continuation-type x))
+ (y-type (continuation-type y)))
+ (if (and (csubtypep x-type (specifier-type 'number))
+ (csubtypep y-type (specifier-type 'number)))
+ (cond ((or (and (csubtypep x-type (specifier-type 'float))
+ (csubtypep y-type (specifier-type 'float)))
+ (and (csubtypep x-type (specifier-type '(complex float)))
+ (csubtypep y-type (specifier-type '(complex float)))))
+ ;; They are both floats. Leave as = so that -0.0 is
+ ;; handled correctly.
+ (give-up-ir1-transform))
+ ((or (and (csubtypep x-type (specifier-type 'rational))
+ (csubtypep y-type (specifier-type 'rational)))
+ (and (csubtypep x-type (specifier-type '(complex rational)))
+ (csubtypep y-type (specifier-type '(complex rational)))))
+ ;; They are both rationals and complexp is the same. Convert
+ ;; to EQL.
+ '(eql x y))
+ (t
+ (give-up-ir1-transform
+ "The operands might not be the same type.")))
+ (give-up-ir1-transform
+ "The operands might not be the same type."))))
+
+;;; If Cont's type is a numeric type, then return the type, otherwise
+;;; GIVE-UP-IR1-TRANSFORM.
+(defun numeric-type-or-lose (cont)
+ (declare (type continuation cont))
+ (let ((res (continuation-type cont)))
+ (unless (numeric-type-p res) (give-up-ir1-transform))
+ res))
+
+;;; See whether we can statically determine (< X Y) using type information.
+;;; If X's high bound is < Y's low, then X < Y. Similarly, if X's low is >=
+;;; to Y's high, the X >= Y (so return NIL). If not, at least make sure any
+;;; constant arg is second.
+;;;
+;;; KLUDGE: Why should constant argument be second? It would be nice to find
+;;; out and explain. -- WHN 19990917
+#!-propagate-float-type
+(defun ir1-transform-< (x y first second inverse)
+ (if (same-leaf-ref-p x y)
+ 'nil
+ (let* ((x-type (numeric-type-or-lose x))
+ (x-lo (numeric-type-low x-type))
+ (x-hi (numeric-type-high x-type))
+ (y-type (numeric-type-or-lose y))
+ (y-lo (numeric-type-low y-type))
+ (y-hi (numeric-type-high y-type)))
+ (cond ((and x-hi y-lo (< x-hi y-lo))
+ 't)
+ ((and y-hi x-lo (>= x-lo y-hi))
+ 'nil)
+ ((and (constant-continuation-p first)
+ (not (constant-continuation-p second)))
+ `(,inverse y x))
+ (t
+ (give-up-ir1-transform))))))
+#!+propagate-float-type
+(defun ir1-transform-< (x y first second inverse)
+ (if (same-leaf-ref-p x y)
+ 'nil
+ (let ((xi (numeric-type->interval (numeric-type-or-lose x)))
+ (yi (numeric-type->interval (numeric-type-or-lose y))))
+ (cond ((interval-< xi yi)
+ 't)
+ ((interval->= xi yi)
+ 'nil)
+ ((and (constant-continuation-p first)
+ (not (constant-continuation-p second)))
+ `(,inverse y x))
+ (t
+ (give-up-ir1-transform))))))
+
+(deftransform < ((x y) (integer integer) * :when :both)
+ (ir1-transform-< x y x y '>))
+
+(deftransform > ((x y) (integer integer) * :when :both)
+ (ir1-transform-< y x x y '<))
+
+#!+propagate-float-type
+(deftransform < ((x y) (float float) * :when :both)
+ (ir1-transform-< x y x y '>))
+
+#!+propagate-float-type
+(deftransform > ((x y) (float float) * :when :both)
+ (ir1-transform-< y x x y '<))
+\f
+;;;; converting N-arg comparisons
+;;;;
+;;;; We convert calls to N-arg comparison functions such as < into
+;;;; two-arg calls. This transformation is enabled for all such
+;;;; comparisons in this file. If any of these predicates are not
+;;;; open-coded, then the transformation should be removed at some
+;;;; point to avoid pessimization.
+
+;;; This function is used for source transformation of N-arg
+;;; comparison functions other than inequality. We deal both with
+;;; converting to two-arg calls and inverting the sense of the test,
+;;; if necessary. If the call has two args, then we pass or return a
+;;; negated test as appropriate. If it is a degenerate one-arg call,
+;;; then we transform to code that returns true. Otherwise, we bind
+;;; all the arguments and expand into a bunch of IFs.
+(declaim (ftype (function (symbol list boolean) *) multi-compare))
+(defun multi-compare (predicate args not-p)
+ (let ((nargs (length args)))
+ (cond ((< nargs 1) (values nil t))
+ ((= nargs 1) `(progn ,@args t))
+ ((= nargs 2)
+ (if not-p
+ `(if (,predicate ,(first args) ,(second args)) nil t)
+ (values nil t)))
+ (t
+ (do* ((i (1- nargs) (1- i))
+ (last nil current)
+ (current (gensym) (gensym))
+ (vars (list current) (cons current vars))
+ (result 't (if not-p
+ `(if (,predicate ,current ,last)
+ nil ,result)
+ `(if (,predicate ,current ,last)
+ ,result nil))))
+ ((zerop i)
+ `((lambda ,vars ,result) . ,args)))))))
+
+(def-source-transform = (&rest args) (multi-compare '= args nil))
+(def-source-transform < (&rest args) (multi-compare '< args nil))
+(def-source-transform > (&rest args) (multi-compare '> args nil))
+(def-source-transform <= (&rest args) (multi-compare '> args t))
+(def-source-transform >= (&rest args) (multi-compare '< args t))
+
+(def-source-transform char= (&rest args) (multi-compare 'char= args nil))
+(def-source-transform char< (&rest args) (multi-compare 'char< args nil))
+(def-source-transform char> (&rest args) (multi-compare 'char> args nil))
+(def-source-transform char<= (&rest args) (multi-compare 'char> args t))
+(def-source-transform char>= (&rest args) (multi-compare 'char< args t))
+
+(def-source-transform char-equal (&rest args) (multi-compare 'char-equal args nil))
+(def-source-transform char-lessp (&rest args) (multi-compare 'char-lessp args nil))
+(def-source-transform char-greaterp (&rest args) (multi-compare 'char-greaterp args nil))
+(def-source-transform char-not-greaterp (&rest args) (multi-compare 'char-greaterp args t))
+(def-source-transform char-not-lessp (&rest args) (multi-compare 'char-lessp args t))
+
+;;; This function does source transformation of N-arg inequality
+;;; functions such as /=. This is similar to Multi-Compare in the <3
+;;; arg cases. If there are more than two args, then we expand into
+;;; the appropriate n^2 comparisons only when speed is important.
+(declaim (ftype (function (symbol list) *) multi-not-equal))
+(defun multi-not-equal (predicate args)
+ (let ((nargs (length args)))
+ (cond ((< nargs 1) (values nil t))
+ ((= nargs 1) `(progn ,@args t))
+ ((= nargs 2)
+ `(if (,predicate ,(first args) ,(second args)) nil t))
+ ((not (policy nil (>= speed space) (>= speed cspeed)))
+ (values nil t))
+ (t
+ (collect ((vars))
+ (dotimes (i nargs) (vars (gensym)))
+ (do ((var (vars) next)
+ (next (cdr (vars)) (cdr next))
+ (result 't))
+ ((null next)
+ `((lambda ,(vars) ,result) . ,args))
+ (let ((v1 (first var)))
+ (dolist (v2 next)
+ (setq result `(if (,predicate ,v1 ,v2) nil ,result))))))))))
+
+(def-source-transform /= (&rest args) (multi-not-equal '= args))
+(def-source-transform char/= (&rest args) (multi-not-equal 'char= args))
+(def-source-transform char-not-equal (&rest args) (multi-not-equal 'char-equal args))
+
+;;; Expand MAX and MIN into the obvious comparisons.
+(def-source-transform max (arg &rest more-args)
+ (if (null more-args)
+ `(values ,arg)
+ (once-only ((arg1 arg)
+ (arg2 `(max ,@more-args)))
+ `(if (> ,arg1 ,arg2)
+ ,arg1 ,arg2))))
+(def-source-transform min (arg &rest more-args)
+ (if (null more-args)
+ `(values ,arg)
+ (once-only ((arg1 arg)
+ (arg2 `(min ,@more-args)))
+ `(if (< ,arg1 ,arg2)
+ ,arg1 ,arg2))))
+\f
+;;;; converting N-arg arithmetic functions
+;;;;
+;;;; N-arg arithmetic and logic functions are associated into two-arg
+;;;; versions, and degenerate cases are flushed.
+
+;;; Left-associate First-Arg and More-Args using Function.
+(declaim (ftype (function (symbol t list) list) associate-arguments))
+(defun associate-arguments (function first-arg more-args)
+ (let ((next (rest more-args))
+ (arg (first more-args)))
+ (if (null next)
+ `(,function ,first-arg ,arg)
+ (associate-arguments function `(,function ,first-arg ,arg) next))))
+
+;;; Do source transformations for transitive functions such as +.
+;;; One-arg cases are replaced with the arg and zero arg cases with
+;;; the identity. If Leaf-Fun is true, then replace two-arg calls with
+;;; a call to that function.
+(defun source-transform-transitive (fun args identity &optional leaf-fun)
+ (declare (symbol fun leaf-fun) (list args))
+ (case (length args)
+ (0 identity)
+ (1 `(values ,(first args)))
+ (2 (if leaf-fun
+ `(,leaf-fun ,(first args) ,(second args))
+ (values nil t)))
+ (t
+ (associate-arguments fun (first args) (rest args)))))
+
+(def-source-transform + (&rest args) (source-transform-transitive '+ args 0))
+(def-source-transform * (&rest args) (source-transform-transitive '* args 1))
+(def-source-transform logior (&rest args) (source-transform-transitive 'logior args 0))
+(def-source-transform logxor (&rest args) (source-transform-transitive 'logxor args 0))
+(def-source-transform logand (&rest args) (source-transform-transitive 'logand args -1))
+
+(def-source-transform logeqv (&rest args)
+ (if (evenp (length args))
+ `(lognot (logxor ,@args))
+ `(logxor ,@args)))
+
+;;; Note: we can't use SOURCE-TRANSFORM-TRANSITIVE for GCD and LCM
+;;; because when they are given one argument, they return its absolute
+;;; value.
+
+(def-source-transform gcd (&rest args)
+ (case (length args)
+ (0 0)
+ (1 `(abs (the integer ,(first args))))
+ (2 (values nil t))
+ (t (associate-arguments 'gcd (first args) (rest args)))))
+
+(def-source-transform lcm (&rest args)
+ (case (length args)
+ (0 1)
+ (1 `(abs (the integer ,(first args))))
+ (2 (values nil t))
+ (t (associate-arguments 'lcm (first args) (rest args)))))
+
+;;; Do source transformations for intransitive n-arg functions such as
+;;; /. With one arg, we form the inverse. With two args we pass.
+;;; Otherwise we associate into two-arg calls.
+(declaim (ftype (function (symbol list t) list) source-transform-intransitive))
+(defun source-transform-intransitive (function args inverse)
+ (case (length args)
+ ((0 2) (values nil t))
+ (1 `(,@inverse ,(first args)))
+ (t (associate-arguments function (first args) (rest args)))))
+
+(def-source-transform - (&rest args)
+ (source-transform-intransitive '- args '(%negate)))
+(def-source-transform / (&rest args)
+ (source-transform-intransitive '/ args '(/ 1)))
+\f
+;;;; APPLY
+
+;;; We convert APPLY into MULTIPLE-VALUE-CALL so that the compiler
+;;; only needs to understand one kind of variable-argument call. It is
+;;; more efficient to convert APPLY to MV-CALL than MV-CALL to APPLY.
+(def-source-transform apply (fun arg &rest more-args)
+ (let ((args (cons arg more-args)))
+ `(multiple-value-call ,fun
+ ,@(mapcar #'(lambda (x)
+ `(values ,x))
+ (butlast args))
+ (values-list ,(car (last args))))))
+\f
+;;;; FORMAT
+;;;;
+;;;; If the control string is a compile-time constant, then replace it
+;;;; with a use of the FORMATTER macro so that the control string is
+;;;; ``compiled.'' Furthermore, if the destination is either a stream
+;;;; or T and the control string is a function (i.e. formatter), then
+;;;; convert the call to format to just a funcall of that function.
+
+(deftransform format ((dest control &rest args) (t simple-string &rest t) *
+ :policy (> speed space))
+ (unless (constant-continuation-p control)
+ (give-up-ir1-transform "The control string is not a constant."))
+ (let ((arg-names (mapcar #'(lambda (x) (declare (ignore x)) (gensym)) args)))
+ `(lambda (dest control ,@arg-names)
+ (declare (ignore control))
+ (format dest (formatter ,(continuation-value control)) ,@arg-names))))
+
+(deftransform format ((stream control &rest args) (stream function &rest t) *
+ :policy (> speed space))
+ (let ((arg-names (mapcar #'(lambda (x) (declare (ignore x)) (gensym)) args)))
+ `(lambda (stream control ,@arg-names)
+ (funcall control stream ,@arg-names)
+ nil)))
+
+(deftransform format ((tee control &rest args) ((member t) function &rest t) *
+ :policy (> speed space))
+ (let ((arg-names (mapcar #'(lambda (x) (declare (ignore x)) (gensym)) args)))
+ `(lambda (tee control ,@arg-names)
+ (declare (ignore tee))
+ (funcall control *standard-output* ,@arg-names)
+ nil)))
--- /dev/null
+;;;; This file implements a sparse set abstraction, represented as a
+;;;; sorted linked list. We don't use bit-vectors to represent sets in
+;;;; flow analysis, since the universe may be quite large but the
+;;;; average number of elements is small. We keep the list sorted so
+;;;; that we can do union and intersection in linear time.
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!C")
+
+(file-comment
+ "$Header$")
+
+;;; Each structure that may be placed in a SSet must include the
+;;; SSet-Element structure. We allow an initial value of NIL to mean
+;;; that no ordering has been assigned yet (although an ordering must
+;;; be assigned before doing set operations.)
+(defstruct (sset-element (:constructor nil))
+ (number nil :type (or index null)))
+
+(defstruct (sset (:constructor make-sset ())
+ (:copier nil))
+ (elements (list nil) :type list))
+(defprinter (sset)
+ (elements :prin1 (cdr elements)))
+
+;;; Iterate over the elements in SSET, binding VAR to each element in
+;;; turn.
+(defmacro do-sset-elements ((var sset &optional result) &body body)
+ `(dolist (,var (cdr (sset-elements ,sset)) ,result) ,@body))
+
+;;; Destructively add Element to Set. If Element was not in the set,
+;;; then we return true, otherwise we return false.
+(declaim (ftype (function (sset-element sset) boolean) sset-adjoin))
+(defun sset-adjoin (element set)
+ (let ((number (sset-element-number element))
+ (elements (sset-elements set)))
+ (do ((prev elements current)
+ (current (cdr elements) (cdr current)))
+ ((null current)
+ (setf (cdr prev) (list element))
+ t)
+ (let ((el (car current)))
+ (when (>= (sset-element-number el) number)
+ (when (eq el element)
+ (return nil))
+ (setf (cdr prev) (cons element current))
+ (return t))))))
+
+;;; Destructively remove Element from Set. If element was in the set,
+;;; then return true, otherwise return false.
+(declaim (ftype (function (sset-element sset) boolean) sset-delete))
+(defun sset-delete (element set)
+ (let ((elements (sset-elements set)))
+ (do ((prev elements current)
+ (current (cdr elements) (cdr current)))
+ ((null current) nil)
+ (when (eq (car current) element)
+ (setf (cdr prev) (cdr current))
+ (return t)))))
+
+;;; Return true if Element is in Set, false otherwise.
+(declaim (ftype (function (sset-element sset) boolean) sset-member))
+(defun sset-member (element set)
+ (declare (inline member))
+ (not (null (member element (cdr (sset-elements set)) :test #'eq))))
+
+;;; Return true if SET contains no elements, false otherwise.
+(declaim (ftype (function (sset) boolean) sset-empty))
+(defun sset-empty (set)
+ (null (cdr (sset-elements set))))
+
+;;; Return a new copy of SET.
+(declaim (ftype (function (sset) sset) copy-sset))
+(defun copy-sset (set)
+ (let ((res (make-sset)))
+ (setf (sset-elements res) (copy-list (sset-elements set)))
+ res))
+
+;;; Perform the appropriate set operation on Set1 and Set2 by destructively
+;;; modifying Set1. We return true if Set1 was modified, false otherwise.
+(declaim (ftype (function (sset sset) boolean) sset-union sset-intersection
+ sset-difference))
+(defun sset-union (set1 set2)
+ (let* ((prev-el1 (sset-elements set1))
+ (el1 (cdr prev-el1))
+ (changed nil))
+ (do ((el2 (cdr (sset-elements set2)) (cdr el2)))
+ ((null el2) changed)
+ (let* ((e (car el2))
+ (num2 (sset-element-number e)))
+ (loop
+ (when (null el1)
+ (setf (cdr prev-el1) (copy-list el2))
+ (return-from sset-union t))
+ (let ((num1 (sset-element-number (car el1))))
+ (when (>= num1 num2)
+ (if (> num1 num2)
+ (let ((new (cons e el1)))
+ (setf (cdr prev-el1) new)
+ (setq prev-el1 new changed t))
+ (shiftf prev-el1 el1 (cdr el1)))
+ (return))
+ (shiftf prev-el1 el1 (cdr el1))))))))
+(defun sset-intersection (set1 set2)
+ (let* ((prev-el1 (sset-elements set1))
+ (el1 (cdr prev-el1))
+ (changed nil))
+ (do ((el2 (cdr (sset-elements set2)) (cdr el2)))
+ ((null el2)
+ (cond (el1
+ (setf (cdr prev-el1) nil)
+ t)
+ (t changed)))
+ (let ((num2 (sset-element-number (car el2))))
+ (loop
+ (when (null el1)
+ (return-from sset-intersection changed))
+ (let ((num1 (sset-element-number (car el1))))
+ (when (>= num1 num2)
+ (when (= num1 num2)
+ (shiftf prev-el1 el1 (cdr el1)))
+ (return))
+ (pop el1)
+ (setf (cdr prev-el1) el1)
+ (setq changed t)))))))
+(defun sset-difference (set1 set2)
+ (let* ((prev-el1 (sset-elements set1))
+ (el1 (cdr prev-el1))
+ (changed nil))
+ (do ((el2 (cdr (sset-elements set2)) (cdr el2)))
+ ((null el2) changed)
+ (let ((num2 (sset-element-number (car el2))))
+ (loop
+ (when (null el1)
+ (return-from sset-difference changed))
+ (let ((num1 (sset-element-number (car el1))))
+ (when (>= num1 num2)
+ (when (= num1 num2)
+ (pop el1)
+ (setf (cdr prev-el1) el1)
+ (setq changed t))
+ (return))
+ (shiftf prev-el1 el1 (cdr el1))))))))
+
+;;; Destructively modify Set1 to include its union with the difference
+;;; of Set2 and Set3. We return true if Set1 was modified, false
+;;; otherwise.
+(declaim (ftype (function (sset sset sset) boolean) sset-union-of-difference))
+(defun sset-union-of-difference (set1 set2 set3)
+ (let* ((prev-el1 (sset-elements set1))
+ (el1 (cdr prev-el1))
+ (el3 (cdr (sset-elements set3)))
+ (changed nil))
+ (do ((el2 (cdr (sset-elements set2)) (cdr el2)))
+ ((null el2) changed)
+ (let* ((e (car el2))
+ (num2 (sset-element-number e)))
+ (loop
+ (when (null el3)
+ (loop
+ (when (null el1)
+ (setf (cdr prev-el1) (copy-list el2))
+ (return-from sset-union-of-difference t))
+ (let ((num1 (sset-element-number (car el1))))
+ (when (>= num1 num2)
+ (if (> num1 num2)
+ (let ((new (cons e el1)))
+ (setf (cdr prev-el1) new)
+ (setq prev-el1 new changed t))
+ (shiftf prev-el1 el1 (cdr el1)))
+ (return))
+ (shiftf prev-el1 el1 (cdr el1))))
+ (return))
+ (let ((num3 (sset-element-number (car el3))))
+ (when (<= num2 num3)
+ (unless (= num2 num3)
+ (loop
+ (when (null el1)
+ (do ((el2 el2 (cdr el2)))
+ ((null el2)
+ (return-from sset-union-of-difference changed))
+ (let* ((e (car el2))
+ (num2 (sset-element-number e)))
+ (loop
+ (when (null el3)
+ (setf (cdr prev-el1) (copy-list el2))
+ (return-from sset-union-of-difference t))
+ (setq num3 (sset-element-number (car el3)))
+ (when (<= num2 num3)
+ (unless (= num2 num3)
+ (let ((new (cons e el1)))
+ (setf (cdr prev-el1) new)
+ (setq prev-el1 new changed t)))
+ (return))
+ (pop el3)))))
+ (let ((num1 (sset-element-number (car el1))))
+ (when (>= num1 num2)
+ (if (> num1 num2)
+ (let ((new (cons e el1)))
+ (setf (cdr prev-el1) new)
+ (setq prev-el1 new changed t))
+ (shiftf prev-el1 el1 (cdr el1)))
+ (return))
+ (shiftf prev-el1 el1 (cdr el1)))))
+ (return)))
+ (pop el3))))))
--- /dev/null
+;;;; This file implements the stack analysis phase in the compiler. We
+;;;; do a graph walk to determine which unknown-values continuations
+;;;; are on the stack at each point in the program, and then we insert
+;;;; cleanup code to pop off unused values.
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!C")
+
+(file-comment
+ "$Header$")
+\f
+;;; Scan through Block looking for uses of :Unknown continuations that have
+;;; their Dest outside of the block. We do some checking to verify the
+;;; invariant that all pushes come after the last pop.
+(defun find-pushed-continuations (block)
+ (let* ((2block (block-info block))
+ (popped (ir2-block-popped 2block))
+ (last-pop (if popped
+ (continuation-dest (car (last popped)))
+ nil)))
+ (collect ((pushed))
+ (let ((saw-last nil))
+ (do-nodes (node cont block)
+ (when (eq node last-pop)
+ (setq saw-last t))
+
+ (let ((dest (continuation-dest cont))
+ (2cont (continuation-info cont)))
+ (when (and dest
+ (not (eq (node-block dest) block))
+ 2cont
+ (eq (ir2-continuation-kind 2cont) :unknown))
+ (assert (or saw-last (not last-pop)))
+ (pushed cont)))))
+
+ (setf (ir2-block-pushed 2block) (pushed))))
+ (values))
+\f
+;;;; annotation graph walk
+
+;;; Do a backward walk in the flow graph simulating the run-time stack of
+;;; unknown-values continuations and annotating the blocks with the result.
+;;;
+;;; Block is the block that is currently being walked and Stack is the stack
+;;; of unknown-values continuations in effect immediately after block. We
+;;; simulate the stack by popping off the unknown-values generated by this
+;;; block (if any) and pushing the continuations for values received by this
+;;; block. (The role of push and pop are interchanged because we are doing a
+;;; backward walk.)
+;;;
+;;; If we run into a values generator whose continuation isn't on stack top,
+;;; then the receiver hasn't yet been reached on any walk to this use. In this
+;;; case, we ignore the push for now, counting on Annotate-Dead-Values to clean
+;;; it up if we discover that it isn't reachable at all.
+;;;
+;;; If our final stack isn't empty, then we walk all the predecessor blocks
+;;; that don't have all the continuations that we have on our Start-Stack on
+;;; their End-Stack. This is our termination condition for the graph walk. We
+;;; put the test around the recursive call so that the initial call to this
+;;; function will do something even though there isn't initially anything on
+;;; the stack.
+;;;
+;;; We can use the tailp test, since the only time we want to bottom out
+;;; with a non-empty stack is when we intersect with another path from the same
+;;; top-level call to this function that has more values receivers on that
+;;; path. When we bottom out in this way, we are counting on
+;;; DISCARD-UNUSED-VALUES doing its thing.
+;;;
+;;; When we do recurse, we check that predecessor's END-STACK is a
+;;; subsequence of our START-STACK. There may be extra stuff on the top
+;;; of our stack because the last path to the predecessor may have discarded
+;;; some values that we use. There may be extra stuff on the bottom of our
+;;; stack because this walk may be from a values receiver whose lifetime
+;;; encloses that of the previous walk.
+;;;
+;;; If a predecessor block is the component head, then it must be the case
+;;; that this is a NLX entry stub. If so, we just stop our walk, since the
+;;; stack at the exit point doesn't have anything to do with our stack.
+(defun stack-simulation-walk (block stack)
+ (declare (type cblock block) (list stack))
+ (let ((2block (block-info block)))
+ (setf (ir2-block-end-stack 2block) stack)
+ (let ((new-stack stack))
+ (dolist (push (reverse (ir2-block-pushed 2block)))
+ (if (eq (car new-stack) push)
+ (pop new-stack)
+ (assert (not (member push new-stack)))))
+
+ (dolist (pop (reverse (ir2-block-popped 2block)))
+ (push pop new-stack))
+
+ (setf (ir2-block-start-stack 2block) new-stack)
+
+ (when new-stack
+ (dolist (pred (block-pred block))
+ (if (eq pred (component-head (block-component block)))
+ (assert (find block
+ (environment-nlx-info (block-environment block))
+ :key #'nlx-info-target))
+ (let ((pred-stack (ir2-block-end-stack (block-info pred))))
+ (unless (tailp new-stack pred-stack)
+ (assert (search pred-stack new-stack))
+ (stack-simulation-walk pred new-stack))))))))
+
+ (values))
+
+;;; Do stack annotation for any values generators in Block that were
+;;; unreached by all walks (i.e. the continuation isn't live at the point that
+;;; it is generated.) This will only happen when the values receiver cannot be
+;;; reached from this particular generator (due to an unconditional control
+;;; transfer.)
+;;;
+;;; What we do is push on the End-Stack all continuations in Pushed that
+;;; aren't already present in the End-Stack. When we find any pushed
+;;; continuation that isn't live, it must be the case that all continuations
+;;; pushed after (on top of) it aren't live.
+;;;
+;;; If we see a pushed continuation that is the CONT of a tail call, then we
+;;; ignore it, since the tail call didn't actually push anything. The tail
+;;; call must always the last in the block.
+(defun annotate-dead-values (block)
+ (declare (type cblock block))
+ (let* ((2block (block-info block))
+ (stack (ir2-block-end-stack 2block))
+ (last (block-last block))
+ (tailp-cont (if (node-tail-p last) (node-cont last))))
+ (do ((pushes (ir2-block-pushed 2block) (rest pushes))
+ (popping nil))
+ ((null pushes))
+ (let ((push (first pushes)))
+ (cond ((member push stack)
+ (assert (not popping)))
+ ((eq push tailp-cont)
+ (assert (null (rest pushes))))
+ (t
+ (push push (ir2-block-end-stack 2block))
+ (setq popping t))))))
+
+ (values))
+\f
+;;; Called when we discover that the stack-top unknown-values continuation
+;;; at the end of Block1 is different from that at the start of Block2 (its
+;;; successor.)
+;;;
+;;; We insert a call to a funny function in a new cleanup block introduced
+;;; between Block1 and Block2. Since control analysis and LTN have already
+;;; run, we must do make an IR2 block, then do ADD-TO-EMIT-ORDER and
+;;; LTN-ANALYZE-BLOCK on the new block. The new block is inserted after Block1
+;;; in the emit order.
+;;;
+;;; If the control transfer between Block1 and Block2 represents a
+;;; tail-recursive return (:Deleted IR2-continuation) or a non-local exit, then
+;;; the cleanup code will never actually be executed. It doesn't seem to be
+;;; worth the risk of trying to optimize this, since this rarely happens and
+;;; wastes only space.
+(defun discard-unused-values (block1 block2)
+ (declare (type cblock block1 block2))
+ (let* ((block1-stack (ir2-block-end-stack (block-info block1)))
+ (block2-stack (ir2-block-start-stack (block-info block2)))
+ (last-popped (elt block1-stack
+ (- (length block1-stack)
+ (length block2-stack)
+ 1))))
+ (assert (tailp block2-stack block1-stack))
+
+ (let* ((block (insert-cleanup-code block1 block2
+ (continuation-next (block-start block2))
+ `(%pop-values ',last-popped)))
+ (2block (make-ir2-block block)))
+ (setf (block-info block) 2block)
+ (add-to-emit-order 2block (block-info block1))
+ (ltn-analyze-block block)))
+
+ (values))
+\f
+;;;; stack analysis
+
+;;; Return a list of all the blocks containing genuine uses of one of the
+;;; Receivers. Exits are excluded, since they don't drop through to the
+;;; receiver.
+(defun find-values-generators (receivers)
+ (declare (list receivers))
+ (collect ((res nil adjoin))
+ (dolist (rec receivers)
+ (dolist (pop (ir2-block-popped (block-info rec)))
+ (do-uses (use pop)
+ (unless (exit-p use)
+ (res (node-block use))))))
+ (res)))
+
+;;; Analyze the use of unknown-values continuations in Component, inserting
+;;; cleanup code to discard values that are generated but never received. This
+;;; phase doesn't need to be run when Values-Receivers is null, i.e. there are
+;;; no unknown-values continuations used across block boundaries.
+;;;
+;;; Do the backward graph walk, starting at each values receiver. We ignore
+;;; receivers that already have a non-null Start-Stack. These are nested
+;;; values receivers that have already been reached on another walk. We don't
+;;; want to clobber that result with our null initial stack.
+(defun stack-analyze (component)
+ (declare (type component component))
+ (let* ((2comp (component-info component))
+ (receivers (ir2-component-values-receivers 2comp))
+ (generators (find-values-generators receivers)))
+
+ (dolist (block generators)
+ (find-pushed-continuations block))
+
+ (dolist (block receivers)
+ (unless (ir2-block-start-stack (block-info block))
+ (stack-simulation-walk block ())))
+
+ (dolist (block generators)
+ (annotate-dead-values block))
+
+ (do-blocks (block component)
+ (let ((top (car (ir2-block-end-stack (block-info block)))))
+ (dolist (succ (block-succ block))
+ (when (and (block-start succ)
+ (not (eq (car (ir2-block-start-stack (block-info succ)))
+ top)))
+ (discard-unused-values block succ))))))
+
+ (values))
--- /dev/null
+;;;; This file contains the noise to byte-compile stuff. It uses the
+;;;; same front end as the real compiler, but generates byte code
+;;;; instead of native code.
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!C")
+
+(file-comment
+ "$Header$")
+
+;;; Generate trace-file output for the byte compiler back-end.
+;;;
+;;; (Note: As of sbcl-0.6.7, this is target-only code not because it's
+;;; logically target-only, but just because it's still implemented in
+;;; terms of SAPs.)
+#!+sb-show
+(defun describe-byte-component (component xeps segment *standard-output*)
+ (format t "~|~%;;;; byte component ~S~2%" (component-name component))
+ (format t ";;; functions:~%")
+ (dolist (fun (component-lambdas component))
+ (when (leaf-name fun)
+ (let ((info (leaf-info fun)))
+ (when info
+ (format t "~6D: ~S~%"
+ (sb!assem:label-position (byte-lambda-info-label info))
+ (leaf-name fun))))))
+
+ (format t "~%;;;disassembly:~2%")
+ (collect ((eps)
+ (chunks))
+ (dolist (x xeps)
+ (let ((xep (cdr x)))
+ (etypecase xep
+ (simple-byte-function
+ (eps (simple-byte-function-entry-point xep)))
+ (hairy-byte-function
+ (dolist (ep (hairy-byte-function-entry-points xep))
+ (eps ep))
+ (when (hairy-byte-function-more-args-entry-point xep)
+ (eps (hairy-byte-function-more-args-entry-point xep)))))))
+ ;; In CMU CL, this was
+ ;; (SB!ASSEM:SEGMENT-MAP-OUTPUT
+ ;; SEGMENT
+ ;; #'(LAMBDA (SAP BYTES) (CHUNKS (CONS SAP BYTES))))
+ ;; -- WHN 19990811
+ (sb!assem:on-segment-contents-vectorly segment
+ (lambda (chunk) (chunks chunk)))
+ (let* ((total-bytes (reduce #'+ (mapcar #'cdr (chunks))))
+ ;; KLUDGE: It's not clear that BUF has to be a SAP instead
+ ;; of a nice high-level, safe, friendly vector. Perhaps
+ ;; this code could be rewritten to use ordinary indices and
+ ;; vectors instead of SAP references to chunks of raw
+ ;; system memory? -- WHN 19990811
+ (buf (allocate-system-memory total-bytes)))
+ (let ((offset 0))
+ (dolist (chunk (chunks))
+ (declare (type (simple-array (unsigned-byte 8)) chunk))
+ (copy-byte-vector-to-system-area chunk buf offset)
+ (incf offset chunk-n-bits)))
+
+ (disassem-byte-sap buf
+ total-bytes
+ (map 'vector
+ #'(lambda (x)
+ (if (constant-p x)
+ (constant-value x)
+ x))
+ (byte-component-info-constants
+ (component-info component)))
+ (sort (eps) #'<))
+ (terpri)
+ (deallocate-system-memory buf total-bytes)
+ (values))))
+
+;;; Given a byte-compiled function, disassemble it to standard output.
+(defun disassem-byte-fun (xep)
+ (declare (optimize (inhibit-warnings 3)))
+ (disassem-byte-component
+ (byte-function-component xep)
+ (etypecase xep
+ (simple-byte-function
+ (list (simple-byte-function-entry-point xep)))
+ (hairy-byte-function
+ (sort (copy-list
+ (if (hairy-byte-function-more-args-entry-point xep)
+ (cons (hairy-byte-function-more-args-entry-point xep)
+ (hairy-byte-function-entry-points xep))
+ (hairy-byte-function-entry-points xep)))
+ #'<)))))
+
+;;; Given a byte-compiled component, disassemble it to standard output.
+;;; EPS is a list of the entry points.
+(defun disassem-byte-component (component &optional (eps '(0)))
+ (let* ((bytes (* (code-header-ref component sb!vm:code-code-size-slot)
+ sb!vm:word-bytes))
+ (num-consts (- (get-header-data component)
+ sb!vm:code-constants-offset))
+ (consts (make-array num-consts)))
+ (dotimes (i num-consts)
+ (setf (aref consts i)
+ (code-header-ref component (+ i sb!vm:code-constants-offset))))
+ (without-gcing
+ (disassem-byte-sap (code-instructions component) bytes
+ consts eps))
+ (values)))
+
+;;; Disassemble byte code from a SAP and constants vector.
+(defun disassem-byte-sap (sap bytes constants eps)
+ (declare (optimize (inhibit-warnings 3)))
+ (let ((index 0))
+ (labels ((newline ()
+ (format t "~&~4D:" index))
+ (next-byte ()
+ (let ((byte (sap-ref-8 sap index)))
+ (format t " ~2,'0X" byte)
+ (incf index)
+ byte))
+ (extract-24-bits ()
+ (logior (ash (next-byte) 16)
+ (ash (next-byte) 8)
+ (next-byte)))
+ (extract-extended-op ()
+ (let ((byte (next-byte)))
+ (if (= byte 255)
+ (extract-24-bits)
+ byte)))
+ (extract-4-bit-op (byte)
+ (let ((4-bits (ldb (byte 4 0) byte)))
+ (if (= 4-bits 15)
+ (extract-extended-op)
+ 4-bits)))
+ (extract-3-bit-op (byte)
+ (let ((3-bits (ldb (byte 3 0) byte)))
+ (if (= 3-bits 7)
+ :var
+ 3-bits)))
+ (extract-branch-target (byte)
+ (if (logbitp 0 byte)
+ (let ((disp (next-byte)))
+ (if (logbitp 7 disp)
+ (+ index disp -256)
+ (+ index disp)))
+ (extract-24-bits)))
+ (note (string &rest noise)
+ (format t "~12T~?" string noise))
+ (get-constant (index)
+ (if (< -1 index (length constants))
+ (aref constants index)
+ "<bogus index>")))
+ (loop
+ (unless (< index bytes)
+ (return))
+
+ (when (eql index (first eps))
+ (newline)
+ (pop eps)
+ (let ((frame-size
+ (let ((byte (next-byte)))
+ (if (< byte 255)
+ (* byte 2)
+ (logior (ash (next-byte) 16)
+ (ash (next-byte) 8)
+ (next-byte))))))
+ (note "Entry point, frame-size=~D~%" frame-size)))
+
+ (newline)
+ (let ((byte (next-byte)))
+ (macrolet ((dispatch (&rest clauses)
+ `(cond ,@(mapcar #'(lambda (clause)
+ `((= (logand byte ,(caar clause))
+ ,(cadar clause))
+ ,@(cdr clause)))
+ clauses))))
+ (dispatch
+ ((#b11110000 #b00000000)
+ (let ((op (extract-4-bit-op byte)))
+ (note "push-local ~D" op)))
+ ((#b11110000 #b00010000)
+ (let ((op (extract-4-bit-op byte)))
+ (note "push-arg ~D" op)))
+ ((#b11110000 #b00100000)
+ (let ((*print-level* 3)
+ (*print-lines* 2))
+ (note "push-const ~S" (get-constant (extract-4-bit-op byte)))))
+ ((#b11110000 #b00110000)
+ (let ((op (extract-4-bit-op byte))
+ (*print-level* 3)
+ (*print-lines* 2))
+ (note "push-sys-const ~S"
+ (svref *system-constants* op))))
+ ((#b11110000 #b01000000)
+ (let ((op (extract-4-bit-op byte)))
+ (note "push-int ~D" op)))
+ ((#b11110000 #b01010000)
+ (let ((op (extract-4-bit-op byte)))
+ (note "push-neg-int ~D" (- (1+ op)))))
+ ((#b11110000 #b01100000)
+ (let ((op (extract-4-bit-op byte)))
+ (note "pop-local ~D" op)))
+ ((#b11110000 #b01110000)
+ (let ((op (extract-4-bit-op byte)))
+ (note "pop-n ~D" op)))
+ ((#b11110000 #b10000000)
+ (let ((op (extract-3-bit-op byte)))
+ (note "~:[~;named-~]call, ~D args"
+ (logbitp 3 byte) op)))
+ ((#b11110000 #b10010000)
+ (let ((op (extract-3-bit-op byte)))
+ (note "~:[~;named-~]tail-call, ~D args"
+ (logbitp 3 byte) op)))
+ ((#b11110000 #b10100000)
+ (let ((op (extract-3-bit-op byte)))
+ (note "~:[~;named-~]multiple-call, ~D args"
+ (logbitp 3 byte) op)))
+ ((#b11111000 #b10110000)
+ ;; local call
+ (let ((op (extract-3-bit-op byte))
+ (target (extract-24-bits)))
+ (note "local call ~D, ~D args" target op)))
+ ((#b11111000 #b10111000)
+ ;; local tail-call
+ (let ((op (extract-3-bit-op byte))
+ (target (extract-24-bits)))
+ (note "local tail-call ~D, ~D args" target op)))
+ ((#b11111000 #b11000000)
+ ;; local-multiple-call
+ (let ((op (extract-3-bit-op byte))
+ (target (extract-24-bits)))
+ (note "local multiple-call ~D, ~D args" target op)))
+ ((#b11111000 #b11001000)
+ ;; return
+ (let ((op (extract-3-bit-op byte)))
+ (note "return, ~D vals" op)))
+ ((#b11111110 #b11010000)
+ ;; branch
+ (note "branch ~D" (extract-branch-target byte)))
+ ((#b11111110 #b11010010)
+ ;; if-true
+ (note "if-true ~D" (extract-branch-target byte)))
+ ((#b11111110 #b11010100)
+ ;; if-false
+ (note "if-false ~D" (extract-branch-target byte)))
+ ((#b11111110 #b11010110)
+ ;; if-eq
+ (note "if-eq ~D" (extract-branch-target byte)))
+ ((#b11111000 #b11011000)
+ ;; XOP
+ (let* ((low-3-bits (extract-3-bit-op byte))
+ (xop (nth (if (eq low-3-bits :var) (next-byte) low-3-bits)
+ *xop-names*)))
+ (note "xop ~A~@[ ~D~]"
+ xop
+ (case xop
+ ((catch go unwind-protect)
+ (extract-24-bits))
+ ((type-check push-n-under)
+ (get-constant (extract-extended-op)))))))
+
+ ((#b11100000 #b11100000)
+ ;; inline
+ (note "inline ~A"
+ (inline-function-info-function
+ (svref *inline-functions* (ldb (byte 5 0) byte))))))))))))
--- /dev/null
+;;;; disassembler-related stuff not needed in cross-compilation host
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!DISASSEM")
+
+(file-comment
+ "$Header$")
+
+;;;; FIXME: A lot of stupid package prefixes would go away if DISASSEM
+;;;; would use the SB!DI package. And some more would go away if it would
+;;;; use SB!SYS (in order to get to the SAP-FOO operators).
+\f
+;;;; combining instructions where one specializes another
+
+(defun inst-specializes-p (special general)
+ #!+sb-doc
+ "Returns non-NIL if the instruction SPECIAL is a more specific version of
+ GENERAL (i.e., the same instruction, but with more constraints)."
+ (declare (type instruction special general))
+ (let ((smask (inst-mask special))
+ (gmask (inst-mask general)))
+ (and (dchunk= (inst-id general)
+ (dchunk-and (inst-id special) gmask))
+ (dchunk-strict-superset-p smask gmask))))
+
+;;; a bit arbitrary, but should work ok...
+(defun specializer-rank (inst)
+ #!+sb-doc
+ "Returns an integer corresponding to the specificity of the instruction INST."
+ (declare (type instruction inst))
+ (* (dchunk-count-bits (inst-mask inst)) 4))
+
+(defun order-specializers (insts)
+ #!+sb-doc
+ "Order the list of instructions INSTS with more specific (more constant
+ bits, or same-as argument constains) ones first. Returns the ordered list."
+ (declare (type list insts))
+ (sort insts
+ #'(lambda (i1 i2)
+ (> (specializer-rank i1) (specializer-rank i2)))))
+
+(defun specialization-error (insts)
+ (error "Instructions either aren't related or conflict in some way:~% ~S"
+ insts))
+
+(defun try-specializing (insts)
+ #!+sb-doc
+ "Given a list of instructions INSTS, Sees if one of these instructions is a
+ more general form of all the others, in which case they are put into its
+ specializers list, and it is returned. Otherwise an error is signaled."
+ (declare (type list insts))
+ (let ((masters (copy-list insts)))
+ (dolist (possible-master insts)
+ (dolist (possible-specializer insts)
+ (unless (or (eq possible-specializer possible-master)
+ (inst-specializes-p possible-specializer possible-master))
+ (setf masters (delete possible-master masters))
+ (return) ; exit the inner loop
+ )))
+ (cond ((null masters)
+ (specialization-error insts))
+ ((cdr masters)
+ (error "multiple specializing masters: ~S" masters))
+ (t
+ (let ((master (car masters)))
+ (setf (inst-specializers master)
+ (order-specializers (remove master insts)))
+ master)))))
+\f
+;;;; choosing an instruction
+
+#!-sb-fluid (declaim (inline inst-matches-p choose-inst-specialization))
+
+(defun inst-matches-p (inst chunk)
+ #!+sb-doc
+ "Returns non-NIL if all constant-bits in INST match CHUNK."
+ (declare (type instruction inst)
+ (type dchunk chunk))
+ (dchunk= (dchunk-and (inst-mask inst) chunk) (inst-id inst)))
+
+(defun choose-inst-specialization (inst chunk)
+ #!+sb-doc
+ "Given an instruction object, INST, and a bit-pattern, CHUNK, picks the
+ most specific instruction on INST's specializer list whose constraints are
+ met by CHUNK. If none do, then INST is returned."
+ (declare (type instruction inst)
+ (type dchunk chunk))
+ (or (dolist (spec (inst-specializers inst) nil)
+ (declare (type instruction spec))
+ (when (inst-matches-p spec chunk)
+ (return spec)))
+ inst))
+\f
+;;;; searching for an instruction in instruction space
+
+(defun find-inst (chunk inst-space)
+ #!+sb-doc
+ "Returns the instruction object within INST-SPACE corresponding to the
+ bit-pattern CHUNK, or NIL if there isn't one."
+ (declare (type dchunk chunk)
+ (type (or null inst-space instruction) inst-space))
+ (etypecase inst-space
+ (null nil)
+ (instruction
+ (if (inst-matches-p inst-space chunk)
+ (choose-inst-specialization inst-space chunk)
+ nil))
+ (inst-space
+ (let* ((mask (ispace-valid-mask inst-space))
+ (id (dchunk-and mask chunk)))
+ (declare (type dchunk id mask))
+ (dolist (choice (ispace-choices inst-space))
+ (declare (type inst-space-choice choice))
+ (when (dchunk= id (ischoice-common-id choice))
+ (return (find-inst chunk (ischoice-subspace choice)))))))))
+\f
+;;;; building the instruction space
+
+(defun build-inst-space (insts &optional (initial-mask dchunk-one))
+ #!+sb-doc
+ "Returns an instruction-space object corresponding to the list of
+ instructions INSTS. If the optional parameter INITIAL-MASK is supplied, only
+ bits it has set are used."
+ ;; This is done by finding any set of bits that's common to
+ ;; all instructions, building an instruction-space node that selects on those
+ ;; bits, and recursively handle sets of instructions with a common value for
+ ;; these bits (which, since there should be fewer instructions than in INSTS,
+ ;; should have some additional set of bits to select on, etc). If there
+ ;; are no common bits, or all instructions have the same value within those
+ ;; bits, TRY-SPECIALIZING is called, which handles the cases of many
+ ;; variations on a single instruction.
+ (declare (type list insts)
+ (type dchunk initial-mask))
+ (cond ((null insts)
+ nil)
+ ((null (cdr insts))
+ (car insts))
+ (t
+ (let ((vmask (dchunk-copy initial-mask)))
+ (dolist (inst insts)
+ (dchunk-andf vmask (inst-mask inst)))
+ (if (dchunk-zerop vmask)
+ (try-specializing insts)
+ (let ((buckets nil))
+ (dolist (inst insts)
+ (let* ((common-id (dchunk-and (inst-id inst) vmask))
+ (bucket (assoc common-id buckets :test #'dchunk=)))
+ (cond ((null bucket)
+ (push (list common-id inst) buckets))
+ (t
+ (push inst (cdr bucket))))))
+ (let ((submask (dchunk-clear initial-mask vmask)))
+ (if (= (length buckets) 1)
+ (try-specializing insts)
+ (make-inst-space
+ :valid-mask vmask
+ :choices (mapcar #'(lambda (bucket)
+ (make-inst-space-choice
+ :subspace (build-inst-space
+ (cdr bucket)
+ submask)
+ :common-id (car bucket)))
+ buckets))))))))))
+\f
+;;;; an inst-space printer for debugging purposes
+
+(defun print-masked-binary (num mask word-size &optional (show word-size))
+ (do ((bit (1- word-size) (1- bit)))
+ ((< bit 0))
+ (write-char (cond ((logbitp bit mask)
+ (if (logbitp bit num) #\1 #\0))
+ ((< bit show) #\x)
+ (t #\space)))))
+
+(defun print-inst-bits (inst)
+ (print-masked-binary (inst-id inst)
+ (inst-mask inst)
+ dchunk-bits
+ (bytes-to-bits (inst-length inst))))
+
+(defun print-inst-space (inst-space &optional (indent 0))
+ #!+sb-doc
+ "Prints a nicely formatted version of INST-SPACE."
+ (etypecase inst-space
+ (null)
+ (instruction
+ (format t "~Vt[~A(~A)~40T" indent
+ (inst-name inst-space)
+ (inst-format-name inst-space))
+ (print-inst-bits inst-space)
+ (dolist (inst (inst-specializers inst-space))
+ (format t "~%~Vt:~A~40T" indent (inst-name inst))
+ (print-inst-bits inst))
+ (write-char #\])
+ (terpri))
+ (inst-space
+ (format t "~Vt---- ~8,'0X ----~%"
+ indent
+ (ispace-valid-mask inst-space))
+ (map nil
+ #'(lambda (choice)
+ (format t "~Vt~8,'0X ==>~%"
+ (+ 2 indent)
+ (ischoice-common-id choice))
+ (print-inst-space (ischoice-subspace choice)
+ (+ 4 indent)))
+ (ispace-choices inst-space)))))
+\f
+;;;; (The actual disassembly part follows.)
+\f
+;;; Code object layout:
+;;; header-word
+;;; code-size (starting from first inst, in words)
+;;; entry-points (points to first function header)
+;;; debug-info
+;;; trace-table-offset (starting from first inst, in bytes)
+;;; constant1
+;;; constant2
+;;; ...
+;;; <padding to dual-word boundary>
+;;; start of instructions
+;;; ...
+;;; function-headers and lra's buried in here randomly
+;;; ...
+;;; start of trace-table
+;;; <padding to dual-word boundary>
+;;;
+;;; Function header layout (dual word aligned):
+;;; header-word
+;;; self pointer
+;;; next pointer (next function header)
+;;; name
+;;; arglist
+;;; type
+;;;
+;;; LRA layout (dual word aligned):
+;;; header-word
+
+#!-sb-fluid (declaim (inline words-to-bytes bytes-to-words))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defun words-to-bytes (num)
+ "Converts a word-offset NUM to a byte-offset."
+ (declare (type offset num))
+ (ash num sb!vm:word-shift))
+ ) ; EVAL-WHEN
+
+(defun bytes-to-words (num)
+ #!+sb-doc
+ "Converts a byte-offset NUM to a word-offset."
+ (declare (type offset num))
+ (ash num (- sb!vm:word-shift)))
+
+(defconstant lra-size (words-to-bytes 1))
+\f
+(defstruct offs-hook
+ (offset 0 :type offset)
+ (function (required-argument) :type function)
+ (before-address nil :type (member t nil)))
+
+(defstruct (segment (:conc-name seg-)
+ (:constructor %make-segment))
+ (sap-maker (required-argument)
+ :type (function () sb!sys:system-area-pointer))
+ (length 0 :type length)
+ (virtual-location 0 :type address)
+ (storage-info nil :type (or null storage-info))
+ (code nil :type (or null sb!kernel:code-component))
+ (hooks nil :type list))
+(def!method print-object ((seg segment) stream)
+ (print-unreadable-object (seg stream :type t)
+ (let ((addr (sb!sys:sap-int (funcall (seg-sap-maker seg)))))
+ (format stream "#X~X[~D]~:[ (#X~X)~;~*~]~@[ in ~S~]"
+ addr
+ (seg-length seg)
+ (= (seg-virtual-location seg) addr)
+ (seg-virtual-location seg)
+ (seg-code seg)))))
+\f
+;;; All state during disassembly. We store some seemingly redundant
+;;; information so that we can allow garbage collect during disassembly and
+;;; not get tripped up by a code block being moved...
+(defstruct (disassem-state (:conc-name dstate-)
+ (:constructor %make-dstate))
+ (cur-offs 0 :type offset) ; offset of current pos in segment
+ (next-offs 0 :type offset) ; offset of next position
+
+ (segment-sap (required-argument) :type sb!sys:system-area-pointer)
+ ; a sap pointing to our segment
+ (segment nil :type (or null segment)) ; the current segment
+
+ (alignment sb!vm:word-bytes :type alignment) ; what to align to in most cases
+ (byte-order :little-endian
+ :type (member :big-endian :little-endian))
+
+ (properties nil :type list) ; for user code to hang stuff off of
+ (filtered-values (make-array max-filtered-value-index)
+ :type filtered-value-vector)
+
+ (addr-print-len nil :type ; used for prettifying printing
+ (or null (integer 0 20)))
+ (argument-column 0 :type column)
+ (output-state :beginning ; to make output look nicer
+ :type (member :beginning
+ :block-boundary
+ nil))
+
+ (labels nil :type list) ; alist of (address . label-number)
+ (label-hash (make-hash-table) ; same thing in a different form
+ :type hash-table)
+
+ (fun-hooks nil :type list) ; list of function
+
+ ;; these next two are popped as they are used
+ (cur-labels nil :type list) ; alist of (address . label-number)
+ (cur-offs-hooks nil :type list) ; list of offs-hook
+
+ (notes nil :type list) ; for the current location
+
+ (current-valid-locations nil ; currently active source variables
+ :type (or null (vector bit))))
+(def!method print-object ((dstate disassem-state) stream)
+ (print-unreadable-object (dstate stream :type t)
+ (format stream
+ "+~D~@[ in ~S~]"
+ (dstate-cur-offs dstate)
+ (dstate-segment dstate))))
+
+(defun dstate-cur-addr (dstate)
+ #!+sb-doc
+ "Returns the absolute address of the current instruction in DSTATE."
+ (the address (+ (seg-virtual-location (dstate-segment dstate))
+ (dstate-cur-offs dstate))))
+
+(defun dstate-next-addr (dstate)
+ #!+sb-doc
+ "Returns the absolute address of the next instruction in DSTATE."
+ (the address (+ (seg-virtual-location (dstate-segment dstate))
+ (dstate-next-offs dstate))))
+\f
+;;;; function ops
+
+(defun fun-self (fun)
+ (declare (type compiled-function fun))
+ (sb!kernel:%function-self fun))
+
+(defun fun-code (fun)
+ (declare (type compiled-function fun))
+ (sb!kernel:function-code-header (fun-self fun)))
+
+(defun fun-next (fun)
+ (declare (type compiled-function fun))
+ (sb!kernel:%function-next fun))
+
+(defun fun-address (function)
+ (declare (type compiled-function function))
+ (- (sb!kernel:get-lisp-obj-address function) sb!vm:function-pointer-type))
+
+(defun fun-insts-offset (function)
+ #!+sb-doc
+ "Offset of FUNCTION from the start of its code-component's instruction area."
+ (declare (type compiled-function function))
+ (- (fun-address function)
+ (sb!sys:sap-int (sb!kernel:code-instructions (fun-code function)))))
+
+(defun fun-offset (function)
+ #!+sb-doc
+ "Offset of FUNCTION from the start of its code-component."
+ (declare (type compiled-function function))
+ (words-to-bytes (sb!kernel:get-closure-length function)))
+\f
+;;;; operations on code-components (which hold the instructions for
+;;;; one or more functions)
+
+(defun code-inst-area-length (code-component)
+ #!+sb-doc
+ "Returns the length of the instruction area in CODE-COMPONENT."
+ (declare (type sb!kernel:code-component code-component))
+ (sb!kernel:code-header-ref code-component
+ sb!vm:code-trace-table-offset-slot))
+
+(defun code-inst-area-address (code-component)
+ #!+sb-doc
+ "Returns the address of the instruction area in CODE-COMPONENT."
+ (declare (type sb!kernel:code-component code-component))
+ (sb!sys:sap-int (sb!kernel:code-instructions code-component)))
+
+(defun code-first-function (code-component)
+ #!+sb-doc
+ "Returns the first function in CODE-COMPONENT."
+ (declare (type sb!kernel:code-component code-component))
+ (sb!kernel:code-header-ref code-component
+ sb!vm:code-trace-table-offset-slot))
+
+(defun segment-offs-to-code-offs (offset segment)
+ (sb!sys:without-gcing
+ (let* ((seg-base-addr (sb!sys:sap-int (funcall (seg-sap-maker segment))))
+ (code-addr
+ (logandc1 sb!vm:lowtag-mask
+ (sb!kernel:get-lisp-obj-address (seg-code segment))))
+ (addr (+ offset seg-base-addr)))
+ (declare (type address seg-base-addr code-addr addr))
+ (- addr code-addr))))
+
+(defun code-offs-to-segment-offs (offset segment)
+ (sb!sys:without-gcing
+ (let* ((seg-base-addr (sb!sys:sap-int (funcall (seg-sap-maker segment))))
+ (code-addr
+ (logandc1 sb!vm:lowtag-mask
+ (sb!kernel:get-lisp-obj-address (seg-code segment))))
+ (addr (+ offset code-addr)))
+ (declare (type address seg-base-addr code-addr addr))
+ (- addr seg-base-addr))))
+
+(defun code-insts-offs-to-segment-offs (offset segment)
+ (sb!sys:without-gcing
+ (let* ((seg-base-addr (sb!sys:sap-int (funcall (seg-sap-maker segment))))
+ (code-insts-addr
+ (sb!sys:sap-int (sb!kernel:code-instructions (seg-code segment))))
+ (addr (+ offset code-insts-addr)))
+ (declare (type address seg-base-addr code-insts-addr addr))
+ (- addr seg-base-addr))))
+\f
+(defun lra-hook (chunk stream dstate)
+ (declare (type dchunk chunk)
+ (ignore chunk)
+ (type (or null stream) stream)
+ (type disassem-state dstate))
+ (when (and (aligned-p (+ (seg-virtual-location (dstate-segment dstate))
+ (dstate-cur-offs dstate))
+ (* 2 sb!vm:word-bytes))
+ ;; Check type.
+ (= (sb!sys:sap-ref-8 (dstate-segment-sap dstate)
+ (if (eq (dstate-byte-order dstate)
+ :little-endian)
+ (dstate-cur-offs dstate)
+ (+ (dstate-cur-offs dstate)
+ (1- lra-size))))
+ sb!vm:return-pc-header-type))
+ (unless (null stream)
+ (princ '.lra stream))
+ (incf (dstate-next-offs dstate) lra-size))
+ nil)
+
+(defun fun-header-hook (stream dstate)
+ #!+sb-doc
+ "Print the function-header (entry-point) pseudo-instruction at the current
+ location in DSTATE to STREAM."
+ (declare (type (or null stream) stream)
+ (type disassem-state dstate))
+ (unless (null stream)
+ (let* ((seg (dstate-segment dstate))
+ (code (seg-code seg))
+ (woffs
+ (bytes-to-words
+ (segment-offs-to-code-offs (dstate-cur-offs dstate) seg)))
+ (name
+ (sb!kernel:code-header-ref code
+ (+ woffs sb!vm:function-name-slot)))
+ (args
+ (sb!kernel:code-header-ref code
+ (+ woffs sb!vm:function-arglist-slot)))
+ (type
+ (sb!kernel:code-header-ref code
+ (+ woffs sb!vm:function-type-slot))))
+ (format stream ".~A ~S~:A" 'entry name args)
+ (note #'(lambda (stream)
+ (format stream "~:S" type)) ; use format to print NIL as ()
+ dstate)))
+ (incf (dstate-next-offs dstate)
+ (words-to-bytes sb!vm:function-code-offset)))
+\f
+(defun alignment-hook (chunk stream dstate)
+ (declare (type dchunk chunk)
+ (ignore chunk)
+ (type (or null stream) stream)
+ (type disassem-state dstate))
+ (let ((location
+ (+ (seg-virtual-location (dstate-segment dstate))
+ (dstate-cur-offs dstate)))
+ (alignment (dstate-alignment dstate)))
+ (unless (aligned-p location alignment)
+ (when stream
+ (format stream "~A~Vt~D~%" '.align
+ (dstate-argument-column dstate)
+ alignment))
+ (incf(dstate-next-offs dstate)
+ (- (align location alignment) location)))
+ nil))
+
+(defun rewind-current-segment (dstate segment)
+ (declare (type disassem-state dstate)
+ (type segment segment))
+ (setf (dstate-segment dstate) segment)
+ (setf (dstate-cur-offs-hooks dstate)
+ (stable-sort (nreverse (copy-list (seg-hooks segment)))
+ #'(lambda (oh1 oh2)
+ (or (< (offs-hook-offset oh1) (offs-hook-offset oh2))
+ (and (= (offs-hook-offset oh1)
+ (offs-hook-offset oh2))
+ (offs-hook-before-address oh1)
+ (not (offs-hook-before-address oh2)))))))
+ (setf (dstate-cur-offs dstate) 0)
+ (setf (dstate-cur-labels dstate) (dstate-labels dstate)))
+
+(defun do-offs-hooks (before-address stream dstate)
+ (declare (type (or null stream) stream)
+ (type disassem-state dstate))
+ (let ((cur-offs (dstate-cur-offs dstate)))
+ (setf (dstate-next-offs dstate) cur-offs)
+ (loop
+ (let ((next-hook (car (dstate-cur-offs-hooks dstate))))
+ (when (null next-hook)
+ (return))
+ (let ((hook-offs (offs-hook-offset next-hook)))
+ (when (or (> hook-offs cur-offs)
+ (and (= hook-offs cur-offs)
+ before-address
+ (not (offs-hook-before-address next-hook))))
+ (return))
+ (unless (< hook-offs cur-offs)
+ (funcall (offs-hook-function next-hook) stream dstate))
+ (pop (dstate-cur-offs-hooks dstate))
+ (unless (= (dstate-next-offs dstate) cur-offs)
+ (return)))))))
+
+(defun do-fun-hooks (chunk stream dstate)
+ (let ((hooks (dstate-fun-hooks dstate))
+ (cur-offs (dstate-cur-offs dstate)))
+ (setf (dstate-next-offs dstate) cur-offs)
+ (dolist (hook hooks nil)
+ (let ((prefix-p (funcall hook chunk stream dstate)))
+ (unless (= (dstate-next-offs dstate) cur-offs)
+ (return prefix-p))))))
+
+(defun handle-bogus-instruction (stream dstate)
+ (let ((alignment (dstate-alignment dstate)))
+ (unless (null stream)
+ (multiple-value-bind (words bytes)
+ (truncate alignment sb!vm:word-bytes)
+ (when (> words 0)
+ (print-words words stream dstate))
+ (when (> bytes 0)
+ (print-bytes bytes stream dstate))))
+ (incf (dstate-next-offs dstate) alignment)))
+
+(defun map-segment-instructions (function segment dstate &optional stream)
+ #!+sb-doc
+ "Iterate through the instructions in SEGMENT, calling FUNCTION
+ for each instruction, with arguments of CHUNK, STREAM, and DSTATE."
+ (declare (type function function)
+ (type segment segment)
+ (type disassem-state dstate)
+ (type (or null stream) stream))
+
+ (let ((ispace (get-inst-space))
+ (prefix-p nil)) ; just processed a prefix inst
+
+ (rewind-current-segment dstate segment)
+
+ (loop
+ (when (>= (dstate-cur-offs dstate)
+ (seg-length (dstate-segment dstate)))
+ ;; done!
+ (return))
+
+ (setf (dstate-next-offs dstate) (dstate-cur-offs dstate))
+
+ (do-offs-hooks t stream dstate)
+ (unless (or prefix-p (null stream))
+ (print-current-address stream dstate))
+ (do-offs-hooks nil stream dstate)
+
+ (unless (> (dstate-next-offs dstate) (dstate-cur-offs dstate))
+ (sb!sys:without-gcing
+ (setf (dstate-segment-sap dstate) (funcall (seg-sap-maker segment)))
+
+ (let ((chunk
+ (sap-ref-dchunk (dstate-segment-sap dstate)
+ (dstate-cur-offs dstate)
+ (dstate-byte-order dstate))))
+ (let ((fun-prefix-p (do-fun-hooks chunk stream dstate)))
+ (if (> (dstate-next-offs dstate) (dstate-cur-offs dstate))
+ (setf prefix-p fun-prefix-p)
+ (let ((inst (find-inst chunk ispace)))
+ (cond ((null inst)
+ (handle-bogus-instruction stream dstate))
+ (t
+ (setf (dstate-next-offs dstate)
+ (+ (dstate-cur-offs dstate)
+ (inst-length inst)))
+
+ (let ((prefilter (inst-prefilter inst))
+ (control (inst-control inst)))
+ (when prefilter
+ (funcall prefilter chunk dstate))
+
+ (funcall function chunk inst)
+
+ (setf prefix-p (null (inst-printer inst)))
+
+ (when control
+ (funcall control chunk inst stream dstate))))))
+ )))))
+
+ (setf (dstate-cur-offs dstate) (dstate-next-offs dstate))
+
+ (unless (null stream)
+ (unless prefix-p
+ (print-notes-and-newline stream dstate))
+ (setf (dstate-output-state dstate) nil)))))
+\f
+(defun add-segment-labels (segment dstate)
+ #!+sb-doc
+ "Make an initial non-printing disassembly pass through DSTATE, noting any
+ addresses that are referenced by instructions in this segment."
+ ;; add labels at the beginning with a label-number of nil; we'll notice
+ ;; later and fill them in (and sort them)
+ (declare (type disassem-state dstate))
+ (let ((labels (dstate-labels dstate)))
+ (map-segment-instructions
+ #'(lambda (chunk inst)
+ (declare (type dchunk chunk) (type instruction inst))
+ (let ((labeller (inst-labeller inst)))
+ (when labeller
+ (setf labels (funcall labeller chunk labels dstate)))))
+ segment
+ dstate)
+ (setf (dstate-labels dstate) labels)
+ ;; erase any notes that got there by accident
+ (setf (dstate-notes dstate) nil)))
+
+(defun number-labels (dstate)
+ #!+sb-doc
+ "If any labels in DSTATE have been added since the last call to this
+ function, give them label-numbers, enter them in the hash-table, and make
+ sure the label list is in sorted order."
+ (let ((labels (dstate-labels dstate)))
+ (when (and labels (null (cdar labels)))
+ ;; at least one label left un-numbered
+ (setf labels (sort labels #'< :key #'car))
+ (let ((max -1)
+ (label-hash (dstate-label-hash dstate)))
+ (dolist (label labels)
+ (when (not (null (cdr label)))
+ (setf max (max max (cdr label)))))
+ (dolist (label labels)
+ (when (null (cdr label))
+ (incf max)
+ (setf (cdr label) max)
+ (setf (gethash (car label) label-hash)
+ (format nil "L~D" max)))))
+ (setf (dstate-labels dstate) labels))))
+\f
+(defun get-inst-space ()
+ #!+sb-doc
+ "Get the instruction-space, creating it if necessary."
+ (let ((ispace *disassem-inst-space*))
+ (when (null ispace)
+ (let ((insts nil))
+ (maphash #'(lambda (name inst-flavs)
+ (declare (ignore name))
+ (dolist (flav inst-flavs)
+ (push flav insts)))
+ *disassem-insts*)
+ (setf ispace (build-inst-space insts)))
+ (setf *disassem-inst-space* ispace))
+ ispace))
+\f
+;;;; Add global hooks.
+
+(defun add-offs-hook (segment addr hook)
+ (let ((entry (cons addr hook)))
+ (if (null (seg-hooks segment))
+ (setf (seg-hooks segment) (list entry))
+ (push entry (cdr (last (seg-hooks segment)))))))
+
+(defun add-offs-note-hook (segment addr note)
+ (add-offs-hook segment
+ addr
+ #'(lambda (stream dstate)
+ (declare (type (or null stream) stream)
+ (type disassem-state dstate))
+ (when stream
+ (note note dstate)))))
+
+(defun add-offs-comment-hook (segment addr comment)
+ (add-offs-hook segment
+ addr
+ #'(lambda (stream dstate)
+ (declare (type (or null stream) stream)
+ (ignore dstate))
+ (when stream
+ (write-string ";;; " stream)
+ (etypecase comment
+ (string
+ (write-string comment stream))
+ (function
+ (funcall comment stream)))
+ (terpri stream)))))
+
+(defun add-fun-hook (dstate function)
+ (push function (dstate-fun-hooks dstate)))
+\f
+(defun set-location-printing-range (dstate from length)
+ (setf (dstate-addr-print-len dstate)
+ ;; 4 bits per hex digit
+ (ceiling (integer-length (logxor from (+ from length))) 4)))
+
+(defun print-current-address (stream dstate)
+ #!+sb-doc
+ "Print the current address in DSTATE to STREAM, plus any labels that
+ correspond to it, and leave the cursor in the instruction column."
+ (declare (type stream stream)
+ (type disassem-state dstate))
+ (let* ((location
+ (+ (seg-virtual-location (dstate-segment dstate))
+ (dstate-cur-offs dstate)))
+ (location-column-width *disassem-location-column-width*)
+ (plen (dstate-addr-print-len dstate)))
+
+ (when (null plen)
+ (setf plen location-column-width)
+ (set-location-printing-range dstate
+ (seg-virtual-location (dstate-segment dstate))
+ (seg-length (dstate-segment dstate))))
+ (when (eq (dstate-output-state dstate) :beginning)
+ (setf plen location-column-width))
+
+ (fresh-line stream)
+
+ ;; print the location
+ ;; [this is equivalent to (format stream "~V,'0x:" plen printed-value), but
+ ;; usually avoids any consing]
+ (tab0 (- location-column-width plen) stream)
+ (let* ((printed-bits (* 4 plen))
+ (printed-value (ldb (byte printed-bits 0) location))
+ (leading-zeros
+ (truncate (- printed-bits (integer-length printed-value)) 4)))
+ (dotimes (i leading-zeros)
+ (write-char #\0 stream))
+ (unless (zerop printed-value)
+ (write printed-value :stream stream :base 16 :radix nil))
+ (write-char #\: stream))
+
+ ;; print any labels
+ (loop
+ (let* ((next-label (car (dstate-cur-labels dstate)))
+ (label-location (car next-label)))
+ (when (or (null label-location) (> label-location location))
+ (return))
+ (unless (< label-location location)
+ (format stream " L~D:" (cdr next-label)))
+ (pop (dstate-cur-labels dstate))))
+
+ ;; move to the instruction column
+ (tab0 (+ location-column-width 1 label-column-width) stream)
+ ))
+\f
+(eval-when (:compile-toplevel :execute)
+ (sb!xc:defmacro with-print-restrictions (&rest body)
+ `(let ((*print-pretty* t)
+ (*print-lines* 2)
+ (*print-length* 4)
+ (*print-level* 3))
+ ,@body)))
+
+(defun print-notes-and-newline (stream dstate)
+ #!+sb-doc
+ "Print a newline to STREAM, inserting any pending notes in DSTATE as
+ end-of-line comments. If there is more than one note, a separate line
+ will be used for each one."
+ (declare (type stream stream)
+ (type disassem-state dstate))
+ (with-print-restrictions
+ (dolist (note (dstate-notes dstate))
+ (format stream "~Vt; " *disassem-note-column*)
+ (etypecase note
+ (string
+ (write-string note stream))
+ (function
+ (funcall note stream)))
+ (terpri stream))
+ (fresh-line stream)
+ (setf (dstate-notes dstate) nil)))
+
+(defun print-bytes (num stream dstate)
+ #!+sb-doc
+ "Disassemble NUM bytes to STREAM as simple `BYTE' instructions"
+ (declare (type offset num)
+ (type stream stream)
+ (type disassem-state dstate))
+ (format stream "~A~Vt" 'BYTE (dstate-argument-column dstate))
+ (let ((sap (dstate-segment-sap dstate))
+ (start-offs (dstate-cur-offs dstate)))
+ (dotimes (offs num)
+ (unless (zerop offs)
+ (write-string ", " stream))
+ (format stream "#X~2,'0x" (sb!sys:sap-ref-8 sap (+ offs start-offs))))))
+
+(defun print-words (num stream dstate)
+ #!+sb-doc
+ "Disassemble NUM machine-words to STREAM as simple `WORD' instructions"
+ (declare (type offset num)
+ (type stream stream)
+ (type disassem-state dstate))
+ (format stream "~A~Vt" 'WORD (dstate-argument-column dstate))
+ (let ((sap (dstate-segment-sap dstate))
+ (start-offs (dstate-cur-offs dstate))
+ (byte-order (dstate-byte-order dstate)))
+ (dotimes (word-offs num)
+ (unless (zerop word-offs)
+ (write-string ", " stream))
+ (let ((word 0) (bit-shift 0))
+ (dotimes (byte-offs sb!vm:word-bytes)
+ (let ((byte
+ (sb!sys:sap-ref-8
+ sap
+ (+ start-offs
+ (* word-offs sb!vm:word-bytes)
+ byte-offs))))
+ (setf word
+ (if (eq byte-order :big-endian)
+ (+ (ash word sb!vm:byte-bits) byte)
+ (+ word (ash byte bit-shift))))
+ (incf bit-shift sb!vm:byte-bits)))
+ (format stream "#X~V,'0X" (ash sb!vm:word-bits -2) word)))))
+\f
+(defvar *default-dstate-hooks* (list #'lra-hook))
+
+(defun make-dstate (&optional (fun-hooks *default-dstate-hooks*))
+ #!+sb-doc
+ "Make a disassembler-state object."
+ (let ((sap
+ (sb!sys:vector-sap (coerce #() '(vector (unsigned-byte 8)))))
+ (alignment *disassem-inst-alignment-bytes*)
+ (arg-column
+ (+ (or *disassem-opcode-column-width* 0)
+ *disassem-location-column-width*
+ 1
+ label-column-width)))
+
+ (when (> alignment 1)
+ (push #'alignment-hook fun-hooks))
+
+ (%make-dstate :segment-sap sap
+ :fun-hooks fun-hooks
+ :argument-column arg-column
+ :alignment alignment
+ :byte-order sb!c:*backend-byte-order*)))
+
+(defun add-fun-header-hooks (segment)
+ (declare (type segment segment))
+ (do ((fun (sb!kernel:code-header-ref (seg-code segment)
+ sb!vm:code-entry-points-slot)
+ (fun-next fun))
+ (length (seg-length segment)))
+ ((null fun))
+ (let ((offset (code-offs-to-segment-offs (fun-offset fun) segment)))
+ (when (<= 0 offset length)
+ (push (make-offs-hook :offset offset :function #'fun-header-hook)
+ (seg-hooks segment))))))
+\f
+;;; A SAP-MAKER is a no-argument function that returns a SAP.
+
+#!-sb-fluid (declaim (inline sap-maker))
+
+(defun sap-maker (function input offset)
+ (declare (optimize (speed 3))
+ (type (function (t) sb!sys:system-area-pointer) function)
+ (type offset offset))
+ (let ((old-sap (sb!sys:sap+ (funcall function input) offset)))
+ (declare (type sb!sys:system-area-pointer old-sap))
+ #'(lambda ()
+ (let ((new-addr
+ (+ (sb!sys:sap-int (funcall function input)) offset)))
+ ;; Saving the sap like this avoids consing except when the sap
+ ;; changes (because the sap-int, arith, etc., get inlined).
+ (declare (type address new-addr))
+ (if (= (sb!sys:sap-int old-sap) new-addr)
+ old-sap
+ (setf old-sap (sb!sys:int-sap new-addr)))))))
+
+(defun vector-sap-maker (vector offset)
+ (declare (optimize (speed 3))
+ (type offset offset))
+ (sap-maker #'sb!sys:vector-sap vector offset))
+
+(defun code-sap-maker (code offset)
+ (declare (optimize (speed 3))
+ (type sb!kernel:code-component code)
+ (type offset offset))
+ (sap-maker #'sb!kernel:code-instructions code offset))
+
+(defun memory-sap-maker (address)
+ (declare (optimize (speed 3))
+ (type address address))
+ (let ((sap (sb!sys:int-sap address)))
+ #'(lambda () sap)))
+\f
+(defun make-segment (sap-maker length
+ &key
+ code virtual-location
+ debug-function source-form-cache
+ hooks)
+ #!+sb-doc
+ "Return a memory segment located at the system-area-pointer returned by
+ SAP-MAKER and LENGTH bytes long in the disassem-state object DSTATE.
+ Optional keyword arguments include :VIRTUAL-LOCATION (by default the same as
+ the address), :DEBUG-FUNCTION, :SOURCE-FORM-CACHE (a source-form-cache
+ object), and :HOOKS (a list of offs-hook objects)."
+ (declare (type (function () sb!sys:system-area-pointer) sap-maker)
+ (type length length)
+ (type (or null address) virtual-location)
+ (type (or null sb!di:debug-function) debug-function)
+ (type (or null source-form-cache) source-form-cache))
+ (let* ((segment
+ (%make-segment
+ :sap-maker sap-maker
+ :length length
+ :virtual-location (or virtual-location
+ (sb!sys:sap-int (funcall sap-maker)))
+ :hooks hooks
+ :code code)))
+ (add-debugging-hooks segment debug-function source-form-cache)
+ (add-fun-header-hooks segment)
+ segment))
+
+(defun make-vector-segment (vector offset &rest args)
+ (declare (type vector vector)
+ (type offset offset)
+ (inline make-segment))
+ (apply #'make-segment (vector-sap-maker vector offset) args))
+
+(defun make-code-segment (code offset length &rest args)
+ (declare (type sb!kernel:code-component code)
+ (type offset offset)
+ (inline make-segment))
+ (apply #'make-segment (code-sap-maker code offset) length :code code args))
+
+(defun make-memory-segment (address &rest args)
+ (declare (type address address)
+ (inline make-segment))
+ (apply #'make-segment (memory-sap-maker address) args))
+\f
+;;; just for fun
+(defun print-fun-headers (function)
+ (declare (type compiled-function function))
+ (let* ((self (fun-self function))
+ (code (sb!kernel:function-code-header self)))
+ (format t "Code-header ~S: size: ~S, trace-table-offset: ~S~%"
+ code
+ (sb!kernel:code-header-ref code
+ sb!vm:code-code-size-slot)
+ (sb!kernel:code-header-ref code
+ sb!vm:code-trace-table-offset-slot))
+ (do ((fun (sb!kernel:code-header-ref code sb!vm:code-entry-points-slot)
+ (fun-next fun)))
+ ((null fun))
+ (let ((fun-offset (sb!kernel:get-closure-length fun)))
+ ;; There is function header fun-offset words from the
+ ;; code header.
+ (format t "Fun-header ~S at offset ~D (words): ~S~A => ~S~%"
+ fun
+ fun-offset
+ (sb!kernel:code-header-ref
+ code (+ fun-offset sb!vm:function-name-slot))
+ (sb!kernel:code-header-ref
+ code (+ fun-offset sb!vm:function-arglist-slot))
+ (sb!kernel:code-header-ref
+ code (+ fun-offset sb!vm:function-type-slot)))))))
+\f
+;;; getting at the source code...
+
+(defstruct (source-form-cache (:conc-name sfcache-))
+ (debug-source nil :type (or null sb!di:debug-source))
+ (top-level-form-index -1 :type fixnum)
+ (top-level-form nil :type list)
+ (form-number-mapping-table nil :type (or null (vector list)))
+ (last-location-retrieved nil :type (or null sb!di:code-location))
+ (last-form-retrieved -1 :type fixnum)
+ )
+
+(defun get-top-level-form (debug-source tlf-index)
+ (let ((name (sb!di:debug-source-name debug-source)))
+ (ecase (sb!di:debug-source-from debug-source)
+ (:file
+ (cond ((not (probe-file name))
+ (warn "The source file ~S no longer seems to exist." name)
+ nil)
+ (t
+ (let ((start-positions
+ (sb!di:debug-source-start-positions debug-source)))
+ (cond ((null start-positions)
+ (warn "There is no start positions map.")
+ nil)
+ (t
+ (let* ((local-tlf-index
+ (- tlf-index
+ (sb!di:debug-source-root-number
+ debug-source)))
+ (char-offset
+ (aref start-positions local-tlf-index)))
+ (with-open-file (f name)
+ (cond ((= (sb!di:debug-source-created debug-source)
+ (file-write-date name))
+ (file-position f char-offset))
+ (t
+ (warn "Source file ~S has been modified; ~@
+ using form offset instead of file index."
+ name)
+ (let ((*read-suppress* t))
+ (dotimes (i local-tlf-index) (read f)))))
+ (let ((*readtable* (copy-readtable)))
+ (set-dispatch-macro-character
+ #\# #\.
+ #'(lambda (stream sub-char &rest rest)
+ (declare (ignore rest sub-char))
+ (let ((token (read stream t nil t)))
+ (format nil "#.~S" token))))
+ (read f))
+ ))))))))
+ (:lisp
+ (aref name tlf-index)))))
+
+(defun cache-valid (loc cache)
+ (and cache
+ (and (eq (sb!di:code-location-debug-source loc)
+ (sfcache-debug-source cache))
+ (eq (sb!di:code-location-top-level-form-offset loc)
+ (sfcache-top-level-form-index cache)))))
+
+(defun get-source-form (loc context &optional cache)
+ (let* ((cache-valid (cache-valid loc cache))
+ (tlf-index (sb!di:code-location-top-level-form-offset loc))
+ (form-number (sb!di:code-location-form-number loc))
+ (top-level-form
+ (if cache-valid
+ (sfcache-top-level-form cache)
+ (get-top-level-form (sb!di:code-location-debug-source loc)
+ tlf-index)))
+ (mapping-table
+ (if cache-valid
+ (sfcache-form-number-mapping-table cache)
+ (sb!di:form-number-translations top-level-form tlf-index))))
+ (when (and (not cache-valid) cache)
+ (setf (sfcache-debug-source cache) (sb!di:code-location-debug-source loc)
+ (sfcache-top-level-form-index cache) tlf-index
+ (sfcache-top-level-form cache) top-level-form
+ (sfcache-form-number-mapping-table cache) mapping-table))
+ (cond ((null top-level-form)
+ nil)
+ ((> form-number (length mapping-table))
+ (warn "bogus form-number in form! The source file has probably ~@
+ been changed too much to cope with.")
+ (when cache
+ ;; Disable future warnings.
+ (setf (sfcache-top-level-form cache) nil))
+ nil)
+ (t
+ (when cache
+ (setf (sfcache-last-location-retrieved cache) loc)
+ (setf (sfcache-last-form-retrieved cache) form-number))
+ (sb!di:source-path-context top-level-form
+ (aref mapping-table form-number)
+ context)))))
+
+(defun get-different-source-form (loc context &optional cache)
+ (if (and (cache-valid loc cache)
+ (or (= (sb!di:code-location-form-number loc)
+ (sfcache-last-form-retrieved cache))
+ (and (sfcache-last-location-retrieved cache)
+ (sb!di:code-location=
+ loc
+ (sfcache-last-location-retrieved cache)))))
+ (values nil nil)
+ (values (get-source-form loc context cache) t)))
+\f
+;;;; stuff to use debugging-info to augment the disassembly
+
+(defun code-function-map (code)
+ (declare (type sb!kernel:code-component code))
+ (sb!di::get-debug-info-function-map (sb!kernel:%code-debug-info code)))
+
+(defstruct location-group
+ (locations #() :type (vector (or list fixnum)))
+ )
+
+(defstruct storage-info
+ (groups nil :type list) ; alist of (name . location-group)
+ (debug-vars #() :type vector))
+
+(defun dstate-debug-vars (dstate)
+ #!+sb-doc
+ "Return the vector of DEBUG-VARs currently associated with DSTATE."
+ (declare (type disassem-state dstate))
+ (storage-info-debug-vars (seg-storage-info (dstate-segment dstate))))
+
+(defun find-valid-storage-location (offset lg-name dstate)
+ #!+sb-doc
+ "Given the OFFSET of a location within the location-group called LG-NAME,
+ see whether there's a current mapping to a source variable in DSTATE, and
+ if so, return the offset of that variable in the current debug-var vector."
+ (declare (type offset offset)
+ (type symbol lg-name)
+ (type disassem-state dstate))
+ (let* ((storage-info
+ (seg-storage-info (dstate-segment dstate)))
+ (location-group
+ (and storage-info
+ (cdr (assoc lg-name (storage-info-groups storage-info)))))
+ (currently-valid
+ (dstate-current-valid-locations dstate)))
+ (and location-group
+ (not (null currently-valid))
+ (let ((locations (location-group-locations location-group)))
+ (and (< offset (length locations))
+ (let ((used-by (aref locations offset)))
+ (and used-by
+ (let ((debug-var-num
+ (typecase used-by
+ (fixnum
+ (and (not
+ (zerop (bit currently-valid used-by)))
+ used-by))
+ (list
+ (some #'(lambda (num)
+ (and (not
+ (zerop
+ (bit currently-valid num)))
+ num))
+ used-by)))))
+ (and debug-var-num
+ (progn
+ ;; Found a valid storage reference!
+ ;; can't use it again until it's revalidated...
+ (setf (bit (dstate-current-valid-locations
+ dstate)
+ debug-var-num)
+ 0)
+ debug-var-num))
+ ))))))))
+
+(defun grow-vector (vec new-len &optional initial-element)
+ #!+sb-doc
+ "Return a new vector which has the same contents as the old one VEC, plus
+ new cells (for a total size of NEW-LEN). The additional elements are
+ initialized to INITIAL-ELEMENT."
+ (declare (type vector vec)
+ (type fixnum new-len))
+ (let ((new
+ (make-sequence `(vector ,(array-element-type vec) ,new-len)
+ new-len
+ :initial-element initial-element)))
+ (dotimes (i (length vec))
+ (setf (aref new i) (aref vec i)))
+ new))
+
+(defun storage-info-for-debug-function (debug-function)
+ #!+sb-doc
+ "Returns a STORAGE-INFO struction describing the object-to-source
+ variable mappings from DEBUG-FUNCTION."
+ (declare (type sb!di:debug-function debug-function))
+ (let ((sc-vec sb!c::*backend-sc-numbers*)
+ (groups nil)
+ (debug-vars (sb!di::debug-function-debug-vars
+ debug-function)))
+ (and debug-vars
+ (dotimes (debug-var-offset
+ (length debug-vars)
+ (make-storage-info :groups groups
+ :debug-vars debug-vars))
+ (let ((debug-var (aref debug-vars debug-var-offset)))
+ #+nil
+ (format t ";;; At offset ~D: ~S~%" debug-var-offset debug-var)
+ (let* ((sc-offset
+ (sb!di::compiled-debug-var-sc-offset debug-var))
+ (sb-name
+ (sb!c:sb-name
+ (sb!c:sc-sb (aref sc-vec
+ (sb!c:sc-offset-scn sc-offset))))))
+ #+nil
+ (format t ";;; SET: ~S[~D]~%"
+ sb-name (sb!c:sc-offset-offset sc-offset))
+ (unless (null sb-name)
+ (let ((group (cdr (assoc sb-name groups))))
+ (when (null group)
+ (setf group (make-location-group))
+ (push `(,sb-name . ,group) groups))
+ (let* ((locations (location-group-locations group))
+ (length (length locations))
+ (offset (sb!c:sc-offset-offset sc-offset)))
+ (when (>= offset length)
+ (setf locations
+ (grow-vector locations
+ (max (* 2 length)
+ (1+ offset))
+ nil)
+ (location-group-locations group)
+ locations))
+ (let ((already-there (aref locations offset)))
+ (cond ((null already-there)
+ (setf (aref locations offset) debug-var-offset))
+ ((eql already-there debug-var-offset))
+ (t
+ (if (listp already-there)
+ (pushnew debug-var-offset
+ (aref locations offset))
+ (setf (aref locations offset)
+ (list debug-var-offset
+ already-there)))))
+ )))))))
+ )))
+
+(defun source-available-p (debug-function)
+ (handler-case
+ (sb!di:do-debug-function-blocks (block debug-function)
+ (declare (ignore block))
+ (return t))
+ (sb!di:no-debug-blocks () nil)))
+
+(defun print-block-boundary (stream dstate)
+ (let ((os (dstate-output-state dstate)))
+ (when (not (eq os :beginning))
+ (when (not (eq os :block-boundary))
+ (terpri stream))
+ (setf (dstate-output-state dstate)
+ :block-boundary))))
+
+(defun add-source-tracking-hooks (segment debug-function &optional sfcache)
+ #!+sb-doc
+ "Add hooks to track to track the source code in SEGMENT during
+ disassembly. SFCACHE can be either NIL or it can be a SOURCE-FORM-CACHE
+ structure, in which case it is used to cache forms from files."
+ (declare (type segment segment)
+ (type (or null sb!di:debug-function) debug-function)
+ (type (or null source-form-cache) sfcache))
+ (let ((last-block-pc -1))
+ (flet ((add-hook (pc fun &optional before-address)
+ (push (make-offs-hook
+ :offset pc ;; ##### FIX to account for non-zero offs in code
+ :function fun
+ :before-address before-address)
+ (seg-hooks segment))))
+ (handler-case
+ (sb!di:do-debug-function-blocks (block debug-function)
+ (let ((first-location-in-block-p t))
+ (sb!di:do-debug-block-locations (loc block)
+ (let ((pc (sb!di::compiled-code-location-pc loc)))
+
+ ;; Put blank lines in at block boundaries
+ (when (and first-location-in-block-p
+ (/= pc last-block-pc))
+ (setf first-location-in-block-p nil)
+ (add-hook pc
+ #'(lambda (stream dstate)
+ (print-block-boundary stream dstate))
+ t)
+ (setf last-block-pc pc))
+
+ ;; Print out corresponding source; this information is not
+ ;; all that accurate, but it's better than nothing
+ (unless (zerop (sb!di:code-location-form-number loc))
+ (multiple-value-bind (form new)
+ (get-different-source-form loc 0 sfcache)
+ (when new
+ (let ((at-block-begin (= pc last-block-pc)))
+ (add-hook
+ pc
+ #'(lambda (stream dstate)
+ (declare (ignore dstate))
+ (when stream
+ (unless at-block-begin
+ (terpri stream))
+ (format stream ";;; [~D] "
+ (sb!di:code-location-form-number
+ loc))
+ (prin1-short form stream)
+ (terpri stream)
+ (terpri stream)))
+ t)))))
+
+ ;; Keep track of variable live-ness as best we can.
+ (let ((live-set
+ (copy-seq (sb!di::compiled-code-location-live-set
+ loc))))
+ (add-hook
+ pc
+ #'(lambda (stream dstate)
+ (declare (ignore stream))
+ (setf (dstate-current-valid-locations dstate)
+ live-set)
+ #+nil
+ (note #'(lambda (stream)
+ (let ((*print-length* nil))
+ (format stream "live set: ~S"
+ live-set)))
+ dstate))))
+ ))))
+ (sb!di:no-debug-blocks () nil)))))
+
+(defun add-debugging-hooks (segment debug-function &optional sfcache)
+ (when debug-function
+ (setf (seg-storage-info segment)
+ (storage-info-for-debug-function debug-function))
+ (add-source-tracking-hooks segment debug-function sfcache)
+ (let ((kind (sb!di:debug-function-kind debug-function)))
+ (flet ((anh (n)
+ (push (make-offs-hook
+ :offset 0
+ :function #'(lambda (stream dstate)
+ (declare (ignore stream))
+ (note n dstate)))
+ (seg-hooks segment))))
+ (case kind
+ (:external)
+ ((nil)
+ (anh "No-arg-parsing entry point"))
+ (t
+ (anh #'(lambda (stream)
+ (format stream "~S entry point" kind)))))))))
+\f
+(defun get-function-segments (function)
+ #!+sb-doc
+ "Returns a list of the segments of memory containing machine code
+ instructions for FUNCTION."
+ (declare (type compiled-function function))
+ (let* ((code (fun-code function))
+ (function-map (code-function-map code))
+ (fname (sb!kernel:%function-name function))
+ (sfcache (make-source-form-cache)))
+ (let ((first-block-seen-p nil)
+ (nil-block-seen-p nil)
+ (last-offset 0)
+ (last-debug-function nil)
+ (segments nil))
+ (flet ((add-seg (offs len df)
+ (when (> len 0)
+ (push (make-code-segment code offs len
+ :debug-function df
+ :source-form-cache sfcache)
+ segments))))
+ (dotimes (fmap-index (length function-map))
+ (let ((fmap-entry (aref function-map fmap-index)))
+ (etypecase fmap-entry
+ (integer
+ (when first-block-seen-p
+ (add-seg last-offset
+ (- fmap-entry last-offset)
+ last-debug-function)
+ (setf last-debug-function nil))
+ (setf last-offset fmap-entry))
+ (sb!c::compiled-debug-function
+ (let ((name (sb!c::compiled-debug-function-name fmap-entry))
+ (kind (sb!c::compiled-debug-function-kind fmap-entry)))
+ #+nil
+ (format t ";;; SAW ~S ~S ~S,~S ~D,~D~%"
+ name kind first-block-seen-p nil-block-seen-p
+ last-offset
+ (sb!c::compiled-debug-function-start-pc fmap-entry))
+ (cond (#+nil (eq last-offset fun-offset)
+ (and (equal name fname) (not first-block-seen-p))
+ (setf first-block-seen-p t))
+ ((eq kind :external)
+ (when first-block-seen-p
+ (return)))
+ ((eq kind nil)
+ (when nil-block-seen-p
+ (return))
+ (when first-block-seen-p
+ (setf nil-block-seen-p t))))
+ (setf last-debug-function
+ (sb!di::make-compiled-debug-function fmap-entry code))
+ )))))
+ (let ((max-offset (code-inst-area-length code)))
+ (when (and first-block-seen-p last-debug-function)
+ (add-seg last-offset
+ (- max-offset last-offset)
+ last-debug-function))
+ (if (null segments)
+ (let ((offs (fun-insts-offset function)))
+ (make-code-segment code offs (- max-offset offs)))
+ (nreverse segments)))))))
+
+(defun get-code-segments (code
+ &optional
+ (start-offs 0)
+ (length (code-inst-area-length code)))
+ #!+sb-doc
+ "Returns a list of the segments of memory containing machine code
+ instructions for the code-component CODE. If START-OFFS and/or LENGTH is
+ supplied, only that part of the code-segment is used (but these are
+ constrained to lie within the code-segment)."
+ (declare (type sb!kernel:code-component code)
+ (type offset start-offs)
+ (type length length))
+ (let ((segments nil))
+ (when code
+ (let ((function-map (code-function-map code))
+ (sfcache (make-source-form-cache)))
+ (let ((last-offset 0)
+ (last-debug-function nil))
+ (flet ((add-seg (offs len df)
+ (let* ((restricted-offs
+ (min (max start-offs offs) (+ start-offs length)))
+ (restricted-len
+ (- (min (max start-offs (+ offs len))
+ (+ start-offs length))
+ restricted-offs)))
+ (when (> restricted-len 0)
+ (push (make-code-segment code
+ restricted-offs restricted-len
+ :debug-function df
+ :source-form-cache sfcache)
+ segments)))))
+ (dotimes (fmap-index (length function-map))
+ (let ((fmap-entry (aref function-map fmap-index)))
+ (etypecase fmap-entry
+ (integer
+ (add-seg last-offset (- fmap-entry last-offset)
+ last-debug-function)
+ (setf last-debug-function nil)
+ (setf last-offset fmap-entry))
+ (sb!c::compiled-debug-function
+ (setf last-debug-function
+ (sb!di::make-compiled-debug-function fmap-entry
+ code))))))
+ (when last-debug-function
+ (add-seg last-offset
+ (- (code-inst-area-length code) last-offset)
+ last-debug-function))))))
+ (if (null segments)
+ (make-code-segment code start-offs length)
+ (nreverse segments))))
+\f
+#+nil
+(defun find-function-segment (fun)
+ #!+sb-doc
+ "Return the address of the instructions for function and its length.
+ The length is computed using a heuristic, and so may not be accurate."
+ (declare (type compiled-function fun))
+ (let* ((code
+ (fun-code fun))
+ (fun-addr
+ (- (sb!kernel:get-lisp-obj-address fun) sb!vm:function-pointer-type))
+ (max-length
+ (code-inst-area-length code))
+ (upper-bound
+ (+ (code-inst-area-address code) max-length)))
+ (do ((some-fun (code-first-function code)
+ (fun-next some-fun)))
+ ((null some-fun)
+ (values fun-addr (- upper-bound fun-addr)))
+ (let ((some-addr (fun-address some-fun)))
+ (when (and (> some-addr fun-addr)
+ (< some-addr upper-bound))
+ (setf upper-bound some-addr))))))
+\f
+(defun segment-overflow (segment dstate)
+ #!+sb-doc
+ "Returns two values: the amount by which the last instruction in the
+ segment goes past the end of the segment, and the offset of the end of the
+ segment from the beginning of that instruction. If all instructions fit
+ perfectly, this will return 0 and 0."
+ (declare (type segment segment)
+ (type disassem-state dstate))
+ (let ((seglen (seg-length segment))
+ (last-start 0))
+ (map-segment-instructions #'(lambda (chunk inst)
+ (declare (ignore chunk inst))
+ (setf last-start (dstate-cur-offs dstate)))
+ segment
+ dstate)
+ (values (- (dstate-cur-offs dstate) seglen)
+ (- seglen last-start))))
+
+(defun label-segments (seglist dstate)
+ #!+sb-doc
+ "Computes labels for all the memory segments in SEGLIST and adds them to
+ DSTATE. It's important to call this function with all the segments you're
+ interested in, so it can find references from one to another."
+ (declare (type list seglist)
+ (type disassem-state dstate))
+ (dolist (seg seglist)
+ (add-segment-labels seg dstate))
+ ;; now remove any labels that don't point anywhere in the segments we have
+ (setf (dstate-labels dstate)
+ (remove-if #'(lambda (lab)
+ (not
+ (some #'(lambda (seg)
+ (let ((start (seg-virtual-location seg)))
+ (<= start
+ (car lab)
+ (+ start (seg-length seg)))))
+ seglist)))
+ (dstate-labels dstate))))
+
+(defun disassemble-segment (segment stream dstate)
+ #!+sb-doc
+ "Disassemble the machine code instructions in SEGMENT to STREAM."
+ (declare (type segment segment)
+ (type stream stream)
+ (type disassem-state dstate))
+ (let ((*print-pretty* nil)) ; otherwise the pp conses hugely
+ (number-labels dstate)
+ (map-segment-instructions
+ #'(lambda (chunk inst)
+ (declare (type dchunk chunk) (type instruction inst))
+ (let ((printer (inst-printer inst)))
+ (when printer
+ (funcall printer chunk inst stream dstate))))
+ segment
+ dstate
+ stream)))
+
+(defun disassemble-segments (segments stream dstate)
+ #!+sb-doc
+ "Disassemble the machine code instructions in each memory segment in
+ SEGMENTS in turn to STREAM."
+ (declare (type list segments)
+ (type stream stream)
+ (type disassem-state dstate))
+ (unless (null segments)
+ (let ((first (car segments))
+ (last (car (last segments))))
+ (set-location-printing-range dstate
+ (seg-virtual-location first)
+ (- (+ (seg-virtual-location last)
+ (seg-length last))
+ (seg-virtual-location first)))
+ (setf (dstate-output-state dstate) :beginning)
+ (dolist (seg segments)
+ (disassemble-segment seg stream dstate)))))
+\f
+;;;; top-level functions
+
+(defun disassemble-function (function &key
+ (stream *standard-output*)
+ (use-labels t))
+ #!+sb-doc
+ "Disassemble the machine code instructions for FUNCTION."
+ (declare (type compiled-function function)
+ (type stream stream)
+ (type (member t nil) use-labels))
+ (let* ((dstate (make-dstate))
+ (segments (get-function-segments function)))
+ (when use-labels
+ (label-segments segments dstate))
+ (disassemble-segments segments stream dstate)))
+
+(defun compile-function-lambda-expr (function)
+ (declare (type function function))
+ (multiple-value-bind (lambda closurep name)
+ (function-lambda-expression function)
+ (declare (ignore name))
+ (when closurep
+ (error "cannot compile a lexical closure"))
+ (compile nil lambda)))
+
+(defun compiled-function-or-lose (thing &optional (name thing))
+ (cond ((or (symbolp thing)
+ (and (listp thing)
+ (eq (car thing) 'setf)))
+ (compiled-function-or-lose (fdefinition thing) thing))
+ ((sb!eval:interpreted-function-p thing)
+ (compile-function-lambda-expr thing))
+ ((functionp thing)
+ thing)
+ ((and (listp thing)
+ (eq (car thing) 'sb!impl::lambda))
+ (compile nil thing))
+ (t
+ (error "can't make a compiled function from ~S" name))))
+
+(defun disassemble (object &key
+ (stream *standard-output*)
+ (use-labels t))
+ #!+sb-doc
+ "Disassemble the machine code associated with OBJECT, which can be a
+ function, a lambda expression, or a symbol with a function definition. If
+ it is not already compiled, the compiler is called to produce something to
+ disassemble."
+ (declare (type (or function symbol cons) object)
+ (type (or (member t) stream) stream)
+ (type (member t nil) use-labels))
+ (let ((fun (compiled-function-or-lose object)))
+ (if (typep fun 'sb!kernel:byte-function)
+ (sb!c:disassem-byte-fun fun)
+ ;; we can't detect closures, so be careful
+ (disassemble-function (fun-self fun)
+ :stream stream
+ :use-labels use-labels)))
+ (values))
+
+(defun disassemble-memory (address
+ length
+ &key
+ (stream *standard-output*)
+ code-component
+ (use-labels t))
+ #!+sb-doc
+ "Disassembles the given area of memory starting at ADDRESS and LENGTH long.
+ Note that if CODE-COMPONENT is NIL and this memory could move during a GC,
+ you'd better disable it around the call to this function."
+ (declare (type (or address sb!sys:system-area-pointer) address)
+ (type length length)
+ (type stream stream)
+ (type (or null sb!kernel:code-component) code-component)
+ (type (member t nil) use-labels))
+ (let* ((address
+ (if (sb!sys:system-area-pointer-p address)
+ (sb!sys:sap-int address)
+ address))
+ (dstate (make-dstate))
+ (segments
+ (if code-component
+ (let ((code-offs
+ (- address
+ (sb!sys:sap-int
+ (sb!kernel:code-instructions code-component)))))
+ (when (or (< code-offs 0)
+ (> code-offs (code-inst-area-length code-component)))
+ (error "address ~X not in the code component ~S"
+ address code-component))
+ (get-code-segments code-component code-offs length))
+ (list (make-memory-segment address length)))))
+ (when use-labels
+ (label-segments segments dstate))
+ (disassemble-segments segments stream dstate)))
+
+(defun disassemble-code-component (code-component &key
+ (stream *standard-output*)
+ (use-labels t))
+ #!+sb-doc
+ "Disassemble the machine code instructions associated with
+ CODE-COMPONENT (this may include multiple entry points)."
+ (declare (type (or null sb!kernel:code-component compiled-function)
+ code-component)
+ (type stream stream)
+ (type (member t nil) use-labels))
+ (let* ((code-component
+ (if (functionp code-component)
+ (fun-code code-component)
+ code-component))
+ (dstate (make-dstate))
+ (segments (get-code-segments code-component)))
+ (when use-labels
+ (label-segments segments dstate))
+ (disassemble-segments segments stream dstate)))
+\f
+;;; Code for making useful segments from arbitrary lists of code-blocks
+
+;;; The maximum size of an instruction -- this includes pseudo-instructions
+;;; like error traps with their associated operands, so it should be big enough
+;;; to include them (i.e. it's not just 4 on a risc machine!).
+(defconstant max-instruction-size 16)
+
+(defun sap-to-vector (sap start end)
+ (let* ((length (- end start))
+ (result (make-array length :element-type '(unsigned-byte 8)))
+ (sap (sb!sys:sap+ sap start)))
+ (dotimes (i length)
+ (setf (aref result i) (sb!sys:sap-ref-8 sap i)))
+ result))
+
+(defun add-block-segments (sap amount seglist location connecting-vec dstate)
+ (declare (type list seglist)
+ (type integer location)
+ (type (or null (vector (unsigned-byte 8))) connecting-vec)
+ (type disassem-state dstate))
+ (flet ((addit (seg overflow)
+ (let ((length (+ (seg-length seg) overflow)))
+ (when (> length 0)
+ (setf (seg-length seg) length)
+ (incf location length)
+ (push seg seglist)))))
+ (let ((connecting-overflow 0))
+ (when connecting-vec
+ ;; tack on some of the new block to the old overflow vector
+ (let* ((beginning-of-block-amount
+ (if sap (min max-instruction-size amount) 0))
+ (connecting-vec
+ (if sap
+ (concatenate
+ '(vector (unsigned-byte 8))
+ connecting-vec
+ (sap-to-vector sap 0 beginning-of-block-amount))
+ connecting-vec)))
+ (when (and (< (length connecting-vec) max-instruction-size)
+ (not (null sap)))
+ (return-from add-block-segments
+ ;; We want connecting vectors to be large enough to hold
+ ;; any instruction, and since the current sap wasn't large
+ ;; enough to do this (and is now entirely on the end of the
+ ;; overflow-vector), just save it for next time.
+ (values seglist location connecting-vec)))
+ (when (> (length connecting-vec) 0)
+ (let ((seg
+ (make-vector-segment connecting-vec
+ 0
+ (- (length connecting-vec)
+ beginning-of-block-amount)
+ :virtual-location location)))
+ (setf connecting-overflow (segment-overflow seg dstate))
+ (addit seg connecting-overflow)))))
+ (cond ((null sap)
+ ;; Nothing more to add.
+ (values seglist location nil))
+ ((< (- amount connecting-overflow) max-instruction-size)
+ ;; We can't create a segment with the minimum size
+ ;; required for an instruction, so just keep on accumulating
+ ;; in the overflow vector for the time-being.
+ (values seglist
+ location
+ (sap-to-vector sap connecting-overflow amount)))
+ (t
+ ;; Put as much as we can into a new segment, and the rest
+ ;; into the overflow-vector.
+ (let* ((initial-length
+ (- amount connecting-overflow max-instruction-size))
+ (seg
+ (make-segment #'(lambda ()
+ (sb!sys:sap+ sap connecting-overflow))
+ initial-length
+ :virtual-location location))
+ (overflow
+ (segment-overflow seg dstate)))
+ (addit seg overflow)
+ (values seglist
+ location
+ (sap-to-vector sap
+ (+ connecting-overflow (seg-length seg))
+ amount))))))))
+\f
+;;;; code to disassemble assembler segments
+
+(defun assem-segment-to-disassem-segments (assem-segment dstate)
+ (declare (type sb!assem:segment assem-segment)
+ (type disassem-state dstate))
+ (let ((location 0)
+ (disassem-segments nil)
+ (connecting-vec nil))
+ (error "stub: code not converted to new SEGMENT WHN 19990322" ; KLUDGE
+ assem-segment) ; (to avoid "ASSEM-SEGMENT defined but never used")
+ ;; old code, needs to be converted to use less-SAPpy ASSEM-SEGMENTs:
+ #|(sb!assem:segment-map-output
+ assem-segment
+ #'(lambda (sap amount)
+ (multiple-value-setq (disassem-segments location connecting-vec)
+ (add-block-segments sap amount
+ disassem-segments location
+ connecting-vec
+ dstate))))|#
+ (when connecting-vec
+ (setf disassem-segments
+ (add-block-segments nil nil
+ disassem-segments location
+ connecting-vec
+ dstate)))
+ (sort disassem-segments #'< :key #'seg-virtual-location)))
+
+;;; FIXME: I noticed that this is only called by #!+SB-SHOW code. It would
+;;; be good to see whether this is the only caller of any other functions.
+#!+sb-show
+(defun disassemble-assem-segment (assem-segment stream)
+ #!+sb-doc
+ "Disassemble the machine code instructions associated with
+ ASSEM-SEGMENT (of type assem:segment)."
+ (declare (type sb!assem:segment assem-segment)
+ (type stream stream))
+ (let* ((dstate (make-dstate))
+ (disassem-segments
+ (assem-segment-to-disassem-segments assem-segment dstate)))
+ (label-segments disassem-segments dstate)
+ (disassemble-segments disassem-segments stream dstate)))
+\f
+;;; routines to find things in the Lisp environment
+
+(defconstant groked-symbol-slots
+ (sort `((,sb!vm:symbol-value-slot . symbol-value)
+ (,sb!vm:symbol-plist-slot . symbol-plist)
+ (,sb!vm:symbol-name-slot . symbol-name)
+ (,sb!vm:symbol-package-slot . symbol-package))
+ #'<
+ :key #'car)
+ #!+sb-doc
+ "An alist of (SYMBOL-SLOT-OFFSET . ACCESS-FUNCTION-NAME) for slots in a
+symbol object that we know about.")
+
+(defun grok-symbol-slot-ref (address)
+ #!+sb-doc
+ "Given ADDRESS, try and figure out if which slot of which symbol is being
+ refered to. Of course we can just give up, so it's not a big deal...
+ Returns two values, the symbol and the name of the access function of the
+ slot."
+ (declare (type address address))
+ (if (not (aligned-p address sb!vm:word-bytes))
+ (values nil nil)
+ (do ((slots-tail groked-symbol-slots (cdr slots-tail)))
+ ((null slots-tail)
+ (values nil nil))
+ (let* ((field (car slots-tail))
+ (slot-offset (words-to-bytes (car field)))
+ (maybe-symbol-addr (- address slot-offset))
+ (maybe-symbol
+ (sb!kernel:make-lisp-obj
+ (+ maybe-symbol-addr sb!vm:other-pointer-type))))
+ (when (symbolp maybe-symbol)
+ (return (values maybe-symbol (cdr field))))))))
+
+(defvar *address-of-nil-object* (sb!kernel:get-lisp-obj-address nil))
+
+(defun grok-nil-indexed-symbol-slot-ref (byte-offset)
+ #!+sb-doc
+ "Given a BYTE-OFFSET from NIL, try and figure out if which slot of which
+ symbol is being refered to. Of course we can just give up, so it's not a big
+ deal... Returns two values, the symbol and the access function."
+ (declare (type offset byte-offset))
+ (grok-symbol-slot-ref (+ *address-of-nil-object* byte-offset)))
+
+(defun get-nil-indexed-object (byte-offset)
+ #!+sb-doc
+ "Returns the lisp object located BYTE-OFFSET from NIL."
+ (declare (type offset byte-offset))
+ (sb!kernel:make-lisp-obj (+ *address-of-nil-object* byte-offset)))
+
+(defun get-code-constant (byte-offset dstate)
+ #!+sb-doc
+ "Returns two values; the lisp-object located at BYTE-OFFSET in the constant
+ area of the code-object in the current segment and T, or NIL and NIL if
+ there is no code-object in the current segment."
+ (declare (type offset byte-offset)
+ (type disassem-state dstate))
+ (let ((code (seg-code (dstate-segment dstate))))
+ (if code
+ (values
+ (sb!kernel:code-header-ref code
+ (ash (+ byte-offset
+ sb!vm:other-pointer-type)
+ (- sb!vm:word-shift)))
+ t)
+ (values nil nil))))
+
+(defvar *assembler-routines-by-addr* nil)
+
+(defun find-assembler-routine (address)
+ #!+sb-doc
+ "Returns the name of the primitive lisp assembler routine located at
+ ADDRESS, or NIL if there isn't one."
+ (declare (type address address))
+ (when (null *assembler-routines-by-addr*)
+ (setf *assembler-routines-by-addr* (make-hash-table))
+ (maphash #'(lambda (name address)
+ (setf (gethash address *assembler-routines-by-addr*) name))
+ sb!kernel:*assembler-routines*))
+ (gethash address *assembler-routines-by-addr*))
+\f
+;;;; some handy function for machine-dependent code to use...
+
+#!-sb-fluid (declaim (maybe-inline sap-ref-int read-suffix))
+
+(defun sap-ref-int (sap offset length byte-order)
+ (declare (type sb!sys:system-area-pointer sap)
+ (type (unsigned-byte 16) offset)
+ (type (member 1 2 4) length)
+ (type (member :little-endian :big-endian) byte-order)
+ (optimize (speed 3) (safety 0)))
+ (ecase length
+ (1 (sb!sys:sap-ref-8 sap offset))
+ (2 (if (eq byte-order :big-endian)
+ (+ (ash (sb!sys:sap-ref-8 sap offset) 8)
+ (sb!sys:sap-ref-8 sap (+ offset 1)))
+ (+ (ash (sb!sys:sap-ref-8 sap (+ offset 1)) 8)
+ (sb!sys:sap-ref-8 sap offset))))
+ (4 (if (eq byte-order :big-endian)
+ (+ (ash (sb!sys:sap-ref-8 sap offset) 24)
+ (ash (sb!sys:sap-ref-8 sap (+ 1 offset)) 16)
+ (ash (sb!sys:sap-ref-8 sap (+ 2 offset)) 8)
+ (sb!sys:sap-ref-8 sap (+ 3 offset)))
+ (+ (sb!sys:sap-ref-8 sap offset)
+ (ash (sb!sys:sap-ref-8 sap (+ 1 offset)) 8)
+ (ash (sb!sys:sap-ref-8 sap (+ 2 offset)) 16)
+ (ash (sb!sys:sap-ref-8 sap (+ 3 offset)) 24))))))
+
+(defun read-suffix (length dstate)
+ (declare (type (member 8 16 32) length)
+ (type disassem-state dstate)
+ (optimize (speed 3) (safety 0)))
+ (let ((length (ecase length (8 1) (16 2) (32 4))))
+ (declare (type (unsigned-byte 3) length))
+ (prog1
+ (sap-ref-int (dstate-segment-sap dstate)
+ (dstate-next-offs dstate)
+ length
+ (dstate-byte-order dstate))
+ (incf (dstate-next-offs dstate) length))))
+\f
+;;;; optional routines to make notes about code
+
+(defun note (note dstate)
+ #!+sb-doc
+ "Store NOTE (which can be either a string or a function with a single
+ stream argument) to be printed as an end-of-line comment after the current
+ instruction is disassembled."
+ (declare (type (or string function) note)
+ (type disassem-state dstate))
+ (push note (dstate-notes dstate)))
+
+(defun prin1-short (thing stream)
+ (with-print-restrictions
+ (prin1 thing stream)))
+
+(defun prin1-quoted-short (thing stream)
+ (if (self-evaluating-p thing)
+ (prin1-short thing stream)
+ (prin1-short `',thing stream)))
+
+(defun note-code-constant (byte-offset dstate)
+ #!+sb-doc
+ "Store a note about the lisp constant located BYTE-OFFSET bytes from the
+ current code-component, to be printed as an end-of-line comment after the
+ current instruction is disassembled."
+ (declare (type offset byte-offset)
+ (type disassem-state dstate))
+ (multiple-value-bind (const valid)
+ (get-code-constant byte-offset dstate)
+ (when valid
+ (note #'(lambda (stream)
+ (prin1-quoted-short const stream))
+ dstate))
+ const))
+
+(defun maybe-note-nil-indexed-symbol-slot-ref (nil-byte-offset dstate)
+ #!+sb-doc
+ "If the memory address located NIL-BYTE-OFFSET bytes from the constant NIL
+ is a valid slot in a symbol, store a note describing which symbol and slot,
+ to be printed as an end-of-line comment after the current instruction is
+ disassembled. Returns non-NIL iff a note was recorded."
+ (declare (type offset nil-byte-offset)
+ (type disassem-state dstate))
+ (multiple-value-bind (symbol access-fun)
+ (grok-nil-indexed-symbol-slot-ref nil-byte-offset)
+ (when access-fun
+ (note #'(lambda (stream)
+ (prin1 (if (eq access-fun 'symbol-value)
+ symbol
+ `(,access-fun ',symbol))
+ stream))
+ dstate))
+ access-fun))
+
+(defun maybe-note-nil-indexed-object (nil-byte-offset dstate)
+ #!+sb-doc
+ "If the memory address located NIL-BYTE-OFFSET bytes from the constant NIL
+ is a valid lisp object, store a note describing which symbol and slot, to
+ be printed as an end-of-line comment after the current instruction is
+ disassembled. Returns non-NIL iff a note was recorded."
+ (declare (type offset nil-byte-offset)
+ (type disassem-state dstate))
+ (let ((obj (get-nil-indexed-object nil-byte-offset)))
+ (note #'(lambda (stream)
+ (prin1-quoted-short obj stream))
+ dstate)
+ t))
+
+(defun maybe-note-assembler-routine (address note-address-p dstate)
+ #!+sb-doc
+ "If ADDRESS is the address of a primitive assembler routine, store a note
+ describing which one, to be printed as an end-of-line comment after the
+ current instruction is disassembled. Returns non-NIL iff a note was
+ recorded. If NOTE-ADDRESS-P is non-NIL, a note of the address is also made."
+ (declare (type address address)
+ (type disassem-state dstate))
+ (let ((name (find-assembler-routine address)))
+ (unless (null name)
+ (note #'(lambda (stream)
+ (if NOTE-ADDRESS-P
+ (format stream "#X~8,'0x: ~S" address name)
+ (prin1 name stream)))
+ dstate))
+ name))
+
+(defun maybe-note-single-storage-ref (offset sc-name dstate)
+ #!+sb-doc
+ "If there's a valid mapping from OFFSET in the storage class SC-NAME to a
+ source variable, make a note of the source-variable name, to be printed as
+ an end-of-line comment after the current instruction is disassembled.
+ Returns non-NIL iff a note was recorded."
+ (declare (type offset offset)
+ (type symbol sc-name)
+ (type disassem-state dstate))
+ (let ((storage-location
+ (find-valid-storage-location offset sc-name dstate)))
+ (when storage-location
+ (note #'(lambda (stream)
+ (princ (sb!di:debug-var-symbol
+ (aref (storage-info-debug-vars
+ (seg-storage-info (dstate-segment dstate)))
+ storage-location))
+ stream))
+ dstate)
+ t)))
+
+(defun maybe-note-associated-storage-ref (offset sb-name assoc-with dstate)
+ #!+sb-doc
+ "If there's a valid mapping from OFFSET in the storage-base called SB-NAME
+ to a source variable, make a note equating ASSOC-WITH with the
+ source-variable name, to be printed as an end-of-line comment after the
+ current instruction is disassembled. Returns non-NIL iff a note was
+ recorded."
+ (declare (type offset offset)
+ (type symbol sb-name)
+ (type (or symbol string) assoc-with)
+ (type disassem-state dstate))
+ (let ((storage-location
+ (find-valid-storage-location offset sb-name dstate)))
+ (when storage-location
+ (note #'(lambda (stream)
+ (format stream "~A = ~S"
+ assoc-with
+ (sb!di:debug-var-symbol
+ (aref (dstate-debug-vars dstate)
+ storage-location))
+ stream))
+ dstate)
+ t)))
+\f
+(defun get-internal-error-name (errnum)
+ (car (svref sb!c:*backend-internal-errors* errnum)))
+
+(defun get-sc-name (sc-offs)
+ (sb!c::location-print-name
+ ;; FIXME: This seems like an awful lot of computation just to get a name.
+ ;; Couldn't we just use lookup in *BACKEND-SC-NAMES*, without having to cons
+ ;; up a new object?
+ (sb!c:make-random-tn :kind :normal
+ :sc (svref sb!c:*backend-sc-numbers*
+ (sb!c:sc-offset-scn sc-offs))
+ :offset (sb!c:sc-offset-offset sc-offs))))
+
+(defun handle-break-args (error-parse-fun stream dstate)
+ #!+sb-doc
+ "When called from an error break instruction's :DISASSEM-CONTROL (or
+ :DISASSEM-PRINTER) function, will correctly deal with printing the
+ arguments to the break.
+
+ ERROR-PARSE-FUN should be a function that accepts:
+ 1) a SYSTEM-AREA-POINTER
+ 2) a BYTE-OFFSET from the SAP to begin at
+ 3) optionally, LENGTH-ONLY, which if non-NIL, means to only return
+ the byte length of the arguments (to avoid unnecessary consing)
+ It should read information from the SAP starting at BYTE-OFFSET, and return
+ four values:
+ 1) the error number
+ 2) the total length, in bytes, of the information
+ 3) a list of SC-OFFSETs of the locations of the error parameters
+ 4) a list of the length (as read from the SAP), in bytes, of each of the
+ return-values."
+ (declare (type function error-parse-fun)
+ (type (or null stream) stream)
+ (type disassem-state dstate))
+ (multiple-value-bind (errnum adjust sc-offsets lengths)
+ (funcall error-parse-fun
+ (dstate-segment-sap dstate)
+ (dstate-next-offs dstate)
+ (null stream))
+ (when stream
+ (setf (dstate-cur-offs dstate)
+ (dstate-next-offs dstate))
+ (flet ((emit-err-arg (note)
+ (let ((num (pop lengths)))
+ (print-notes-and-newline stream dstate)
+ (print-current-address stream dstate)
+ (print-bytes num stream dstate)
+ (incf (dstate-cur-offs dstate) num)
+ (when note
+ (note note dstate)))))
+ (emit-err-arg nil)
+ (emit-err-arg (symbol-name (get-internal-error-name errnum)))
+ (dolist (sc-offs sc-offsets)
+ (emit-err-arg (get-sc-name sc-offs)))))
+ (incf (dstate-next-offs dstate)
+ adjust)))
--- /dev/null
+;;;; dumping functionality which isn't needed in cross-compilation
+;;;; (and, typically, which is awkward to implement in the
+;;;; cross-compilation host)
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!C")
+
+(file-comment
+ "$Header$")
+
+;;; Dump the first N bytes of VEC out to FILE. VEC is some sort of unboxed
+;;; vector-like thing that we can BLT from.
+(defun dump-raw-bytes (vec n fasl-file)
+ (declare (type index n) (type fasl-file fasl-file))
+ (sb!sys:output-raw-bytes (fasl-file-stream fasl-file) vec 0 n)
+ (values))
+
+;;; Dump a multi-dimensional array. Note: any displacements are folded out.
+;;;
+;;; This isn't needed at cross-compilation time because SBCL doesn't
+;;; use multi-dimensional arrays internally. It's hard to implement
+;;; at cross-compilation time because it uses WITH-ARRAY-DATA. If it ever
+;;; becomes necessary to implement it at cross-compilation time, it might
+;;; possible to use ROW-MAJOR-AREF stuff to do it portably.
+(defun dump-multi-dim-array (array file)
+ (let ((rank (array-rank array)))
+ (dotimes (i rank)
+ (dump-integer (array-dimension array i) file))
+ (sb!impl::with-array-data ((vector array) (start) (end))
+ (if (and (= start 0) (= end (length vector)))
+ (sub-dump-object vector file)
+ (sub-dump-object (subseq vector start end) file)))
+ (dump-fop 'sb!impl::fop-array file)
+ (dump-unsigned-32 rank file)
+ (eq-save-object array file)))
+\f
+(defun dump-single-float-vector (vec file)
+ (let ((length (length vec)))
+ (dump-fop 'sb!impl::fop-single-float-vector file)
+ (dump-unsigned-32 length file)
+ (dump-raw-bytes vec (* length sb!vm:word-bytes) file)))
+
+(defun dump-double-float-vector (vec file)
+ (let ((length (length vec)))
+ (dump-fop 'sb!impl::fop-double-float-vector file)
+ (dump-unsigned-32 length file)
+ (dump-raw-bytes vec (* length sb!vm:word-bytes 2) file)))
+
+#!+long-float
+(defun dump-long-float-vector (vec file)
+ (let ((length (length vec)))
+ (dump-fop 'sb!impl::fop-long-float-vector file)
+ (dump-unsigned-32 length file)
+ (dump-raw-bytes vec (* length sb!vm:word-bytes #!+x86 3 #!+sparc 4) file)))
+
+(defun dump-complex-single-float-vector (vec file)
+ (let ((length (length vec)))
+ (dump-fop 'sb!impl::fop-complex-single-float-vector file)
+ (dump-unsigned-32 length file)
+ (dump-raw-bytes vec (* length sb!vm:word-bytes 2) file)))
+
+(defun dump-complex-double-float-vector (vec file)
+ (let ((length (length vec)))
+ (dump-fop 'sb!impl::fop-complex-double-float-vector file)
+ (dump-unsigned-32 length file)
+ (dump-raw-bytes vec (* length sb!vm:word-bytes 2 2) file)))
+
+#!+long-float
+(defun dump-complex-long-float-vector (vec file)
+ (let ((length (length vec)))
+ (dump-fop 'sb!impl::fop-complex-long-float-vector file)
+ (dump-unsigned-32 length file)
+ (dump-raw-bytes vec (* length sb!vm:word-bytes #!+x86 3 #!+sparc 4 2) file)))
+
+#!+(and long-float x86)
+(defun dump-long-float (float file)
+ (declare (long-float float))
+ (let ((exp-bits (long-float-exp-bits float))
+ (high-bits (long-float-high-bits float))
+ (low-bits (long-float-low-bits float)))
+ (dump-unsigned-32 low-bits file)
+ (dump-unsigned-32 high-bits file)
+ (dump-integer-as-n-bytes exp-bits 2 file)))
+
+#!+(and long-float sparc)
+(defun dump-long-float (float file)
+ (declare (long-float float))
+ (let ((exp-bits (long-float-exp-bits float))
+ (high-bits (long-float-high-bits float))
+ (mid-bits (long-float-mid-bits float))
+ (low-bits (long-float-low-bits float)))
+ (dump-unsigned-32 low-bits file)
+ (dump-unsigned-32 mid-bits file)
+ (dump-unsigned-32 high-bits file)
+ (dump-integer-as-n-bytes exp-bits 4 file)))
+
+;;; Or a complex...
+
+(defun dump-complex (x file)
+ (typecase x
+ ((complex single-float)
+ (dump-fop 'sb!impl::fop-complex-single-float file)
+ (dump-integer-as-n-bytes (single-float-bits (realpart x)) 4 file)
+ (dump-integer-as-n-bytes (single-float-bits (imagpart x)) 4 file))
+ ((complex double-float)
+ (dump-fop 'sb!impl::fop-complex-double-float file)
+ (let ((re (realpart x)))
+ (declare (double-float re))
+ (dump-unsigned-32 (double-float-low-bits re) file)
+ (dump-integer-as-n-bytes (double-float-high-bits re) 4 file))
+ (let ((im (imagpart x)))
+ (declare (double-float im))
+ (dump-unsigned-32 (double-float-low-bits im) file)
+ (dump-integer-as-n-bytes (double-float-high-bits im) 4 file)))
+ #!+long-float
+ ((complex long-float)
+ (dump-fop 'sb!impl::fop-complex-long-float file)
+ (dump-long-float (realpart x) file)
+ (dump-long-float (imagpart x) file))
+ (t
+ (sub-dump-object (realpart x) file)
+ (sub-dump-object (imagpart x) file)
+ (dump-fop 'sb!impl::fop-complex file))))
+
--- /dev/null
+;;;; functions from classic CMU CL src/compiler/main.lisp which are
+;;;; needed only (and which may make sense only) on the
+;;;; cross-compilation target, not the cross-compilation host
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!C")
+
+(file-comment
+ "$Header$")
+\f
+;;;; COMPILE and UNCOMPILE
+
+(defun get-lambda-to-compile (definition)
+ (if (consp definition)
+ definition
+ (multiple-value-bind (def env-p)
+ (function-lambda-expression definition)
+ (when env-p
+ (error "~S was defined in a non-null environment." definition))
+ (unless def
+ (error "Can't find a definition for ~S." definition))
+ def)))
+
+;;; Find the function that is being compiled by COMPILE and bash its name to
+;;; NAME. We also substitute for any references to name so that recursive
+;;; calls will be compiled direct. Lambda is the top-level lambda for the
+;;; compilation. A REF for the real function is the only thing in the
+;;; top-level lambda other than the bind and return, so it isn't too hard to
+;;; find.
+(defun compile-fix-function-name (lambda name)
+ (declare (type clambda lambda) (type (or symbol cons) name))
+ (when name
+ (let ((fun (ref-leaf
+ (continuation-next
+ (node-cont (lambda-bind lambda))))))
+ (setf (leaf-name fun) name)
+ (let ((old (gethash name *free-functions*)))
+ (when old (substitute-leaf fun old)))
+ name)))
+
+(defun compile (name &optional (definition (fdefinition name)))
+ #!+sb-doc
+ "Compiles the function whose name is Name. If Definition is supplied,
+ it should be a lambda expression that is compiled and then placed in the
+ function cell of Name. If Name is Nil, the compiled code object is
+ returned."
+ (with-compilation-values
+ (sb!xc:with-compilation-unit ()
+ (let* ((*info-environment* (or *backend-info-environment*
+ *info-environment*))
+ (*lexenv* (make-null-lexenv))
+ (form `#',(get-lambda-to-compile definition))
+ (*source-info* (make-lisp-source-info form))
+ (*top-level-lambdas* ())
+ (*converting-for-interpreter* nil)
+ (*block-compile* nil)
+ (*compiler-error-bailout*
+ #'(lambda ()
+ (compiler-mumble
+ "~2&fatal error, aborting compilation~%")
+ (return-from compile (values nil t nil))))
+ (*current-path* nil)
+ (*last-source-context* nil)
+ (*last-original-source* nil)
+ (*last-source-form* nil)
+ (*last-format-string* nil)
+ (*last-format-args* nil)
+ (*last-message-count* 0)
+ (*compile-object* (make-core-object))
+ (*gensym-counter* 0)
+ ;; FIXME: ANSI doesn't say anything about CL:COMPILE
+ ;; interacting with these variables, so we shouldn't. As
+ ;; of SBCL 0.6.7, COMPILE-FILE controls its verbosity by
+ ;; binding these variables, so as a quick hack we do so
+ ;; too. But a proper implementation would have verbosity
+ ;; controlled by function arguments and lexical variables.
+ (*compile-verbose* nil)
+ (*compile-print* nil))
+ (clear-stuff)
+ (find-source-paths form 0)
+ (let ((lambda (ir1-top-level form '(original-source-start 0 0) t)))
+
+ (compile-fix-function-name lambda name)
+ (let* ((component
+ (block-component (node-block (lambda-bind lambda))))
+ (*all-components* (list component)))
+ (local-call-analyze component))
+
+ (multiple-value-bind (components top-components)
+ (find-initial-dfo (list lambda))
+ (let ((*all-components* (append components top-components)))
+ (dolist (component *all-components*)
+ (compile-component component))))
+
+ (let* ((res1 (core-call-top-level-lambda lambda *compile-object*))
+ (result (or name res1)))
+ (fix-core-source-info *source-info* *compile-object* res1)
+ (when name
+ (setf (fdefinition name) res1))
+ result))))))
--- /dev/null
+;;;; This file contains utilities used for creating and manipulating
+;;;; TNs, and some other more assorted IR2 utilities.
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!C")
+
+(file-comment
+ "$Header$")
+
+;;; The component that is currently being compiled. TNs are allocated
+;;; in this component.
+(defvar *component-being-compiled*)
+
+(defmacro do-packed-tns ((tn component &optional result) &body body)
+ #!+sb-doc
+ "Do-Packed-TNs (TN-Var Component [Result]) Declaration* Form*
+ Iterate over all packed TNs allocated in Component."
+ (let ((n-component (gensym)))
+ `(let ((,n-component (component-info ,component)))
+ (do ((,tn (ir2-component-normal-tns ,n-component) (tn-next ,tn)))
+ ((null ,tn))
+ ,@body)
+ (do ((,tn (ir2-component-restricted-tns ,n-component) (tn-next ,tn)))
+ ((null ,tn))
+ ,@body)
+ (do ((,tn (ir2-component-wired-tns ,n-component) (tn-next ,tn)))
+ ((null ,tn)
+ ,result)
+ ,@body))))
+\f
+;;; Remove all TNs with no references from the lists of unpacked TNs. We
+;;; null out the Offset so that nobody will mistake deleted wired TNs for
+;;; properly packed TNs. We mark non-deleted alias TNs so that aliased TNs
+;;; aren't considered to be unreferenced.
+(defun delete-unreferenced-tns (component)
+ (let* ((2comp (component-info component))
+ (aliases (make-array (1+ (ir2-component-global-tn-counter 2comp))
+ :element-type 'bit :initial-element 0)))
+ (labels ((delete-some (getter setter)
+ (let ((prev nil))
+ (do ((tn (funcall getter 2comp) (tn-next tn)))
+ ((null tn))
+ (cond
+ ((or (used-p tn)
+ (and (eq (tn-kind tn) :specified-save)
+ (used-p (tn-save-tn tn))))
+ (setq prev tn))
+ (t
+ (delete-1 tn prev setter))))))
+ (used-p (tn)
+ (or (tn-reads tn) (tn-writes tn)
+ (member (tn-kind tn) '(:component :environment))
+ (not (zerop (sbit aliases (tn-number tn))))))
+ (delete-1 (tn prev setter)
+ (if prev
+ (setf (tn-next prev) (tn-next tn))
+ (funcall setter (tn-next tn) 2comp))
+ (setf (tn-offset tn) nil)
+ (case (tn-kind tn)
+ (:environment
+ (clear-live tn
+ #'ir2-environment-live-tns
+ #'(setf ir2-environment-live-tns)))
+ (:debug-environment
+ (clear-live tn
+ #'ir2-environment-debug-live-tns
+ #'(setf ir2-environment-debug-live-tns)))))
+ (clear-live (tn getter setter)
+ (let ((env (environment-info (tn-environment tn))))
+ (funcall setter (delete tn (funcall getter env)) env))))
+ (declare (inline used-p delete-some delete-1 clear-live))
+ (delete-some #'ir2-component-alias-tns
+ #'(setf ir2-component-alias-tns))
+ (do ((tn (ir2-component-alias-tns 2comp) (tn-next tn)))
+ ((null tn))
+ (setf (sbit aliases (tn-number (tn-save-tn tn))) 1))
+ (delete-some #'ir2-component-normal-tns
+ #'(setf ir2-component-normal-tns))
+ (delete-some #'ir2-component-restricted-tns
+ #'(setf ir2-component-restricted-tns))
+ (delete-some #'ir2-component-wired-tns
+ #'(setf ir2-component-wired-tns))))
+ (values))
+\f
+;;;; TN creation
+
+;;; Create a packed TN of the specified primitive-type in the
+;;; *COMPONENT-BEING-COMPILED*. We use the SCs from the primitive type
+;;; to determine which SCs it can be packed in.
+(defun make-normal-tn (type)
+ (declare (type primitive-type type))
+ (let* ((component (component-info *component-being-compiled*))
+ (res (make-tn (incf (ir2-component-global-tn-counter component))
+ :normal type nil)))
+ (push-in tn-next res (ir2-component-normal-tns component))
+ res))
+
+;;; Create a normal packed TN with representation indicated by SCN.
+(defun make-representation-tn (ptype scn)
+ (declare (type primitive-type ptype) (type sc-number scn))
+ (let* ((component (component-info *component-being-compiled*))
+ (res (make-tn (incf (ir2-component-global-tn-counter component))
+ :normal ptype
+ (svref *backend-sc-numbers* scn))))
+ (push-in tn-next res (ir2-component-normal-tns component))
+ res))
+
+;;; Create a TN wired to a particular location in an SC. We set the Offset
+;;; and FSC to record where it goes, and then put it on the current component's
+;;; Wired-TNs list. Ptype is the TN's primitive-type, which may be NIL in VOP
+;;; temporaries.
+(defun make-wired-tn (ptype scn offset)
+ (declare (type (or primitive-type null) ptype)
+ (type sc-number scn) (type unsigned-byte offset))
+ (let* ((component (component-info *component-being-compiled*))
+ (res (make-tn (incf (ir2-component-global-tn-counter component))
+ :normal ptype
+ (svref *backend-sc-numbers* scn))))
+ (setf (tn-offset res) offset)
+ (push-in tn-next res (ir2-component-wired-tns component))
+ res))
+
+;;; Create a packed TN restricted to the SC with number SCN. Ptype is as
+;;; for MAKE-WIRED-TN.
+(defun make-restricted-tn (ptype scn)
+ (declare (type (or primitive-type null) ptype) (type sc-number scn))
+ (let* ((component (component-info *component-being-compiled*))
+ (res (make-tn (incf (ir2-component-global-tn-counter component))
+ :normal ptype
+ (svref *backend-sc-numbers* scn))))
+ (push-in tn-next res (ir2-component-restricted-tns component))
+ res))
+
+;;; Make TN be live throughout environment. Return TN. In the DEBUG case,
+;;; the TN is treated normally in blocks in the environment which reference the
+;;; TN, allowing targeting to/from the TN. This results in move efficient
+;;; code, but may result in the TN sometimes not being live when you want it.
+(defun environment-live-tn (tn env)
+ (declare (type tn tn) (type environment env))
+ (assert (eq (tn-kind tn) :normal))
+ (setf (tn-kind tn) :environment)
+ (setf (tn-environment tn) env)
+ (push tn (ir2-environment-live-tns (environment-info env)))
+ tn)
+(defun environment-debug-live-tn (tn env)
+ (declare (type tn tn) (type environment env))
+ (assert (eq (tn-kind tn) :normal))
+ (setf (tn-kind tn) :debug-environment)
+ (setf (tn-environment tn) env)
+ (push tn (ir2-environment-debug-live-tns (environment-info env)))
+ tn)
+
+;;; Make TN be live throughout the current component. Return TN.
+(defun component-live-tn (tn)
+ (declare (type tn tn))
+ (assert (eq (tn-kind tn) :normal))
+ (setf (tn-kind tn) :component)
+ (push tn (ir2-component-component-tns (component-info
+ *component-being-compiled*)))
+ tn)
+
+;;; Specify that Save be used as the save location for TN. TN is returned.
+(defun specify-save-tn (tn save)
+ (declare (type tn tn save))
+ (assert (eq (tn-kind save) :normal))
+ (assert (and (not (tn-save-tn tn)) (not (tn-save-tn save))))
+ (setf (tn-kind save) :specified-save)
+ (setf (tn-save-tn tn) save)
+ (setf (tn-save-tn save) tn)
+ (push save
+ (ir2-component-specified-save-tns
+ (component-info *component-being-compiled*)))
+ tn)
+
+;;; Create a constant TN. The implementation dependent
+;;; Immediate-Constant-SC function is used to determine whether the constant
+;;; has an immediate representation.
+(defun make-constant-tn (constant)
+ (declare (type constant constant))
+ (let* ((component (component-info *component-being-compiled*))
+ (immed (immediate-constant-sc (constant-value constant)))
+ (sc (svref *backend-sc-numbers*
+ (or immed (sc-number-or-lose 'constant))))
+ (res (make-tn 0 :constant (primitive-type (leaf-type constant)) sc)))
+ (unless immed
+ (let ((constants (ir2-component-constants component)))
+ (setf (tn-offset res) (fill-pointer constants))
+ (vector-push-extend constant constants)))
+ (push-in tn-next res (ir2-component-constant-tns component))
+ (setf (tn-leaf res) constant)
+ res))
+
+(defun make-load-time-value-tn (handle type)
+ (let* ((component (component-info *component-being-compiled*))
+ (sc (svref *backend-sc-numbers*
+ (sc-number-or-lose 'constant)))
+ (res (make-tn 0 :constant (primitive-type type) sc))
+ (constants (ir2-component-constants component)))
+ (setf (tn-offset res) (fill-pointer constants))
+ (vector-push-extend (cons :load-time-value handle) constants)
+ (push-in tn-next res (ir2-component-constant-tns component))
+ res))
+
+;;; Make a TN that aliases TN for use in local call argument passing.
+(defun make-alias-tn (tn)
+ (declare (type tn tn))
+ (let* ((component (component-info *component-being-compiled*))
+ (res (make-tn (incf (ir2-component-global-tn-counter component))
+ :alias (tn-primitive-type tn) nil)))
+ (setf (tn-save-tn res) tn)
+ (push-in tn-next res
+ (ir2-component-alias-tns component))
+ res))
+
+;;; Return a load-time constant TN with the specified Kind and Info. If the
+;;; desired Constants entry already exists, then reuse it, otherwise allocate a
+;;; new load-time constant slot.
+(defun make-load-time-constant-tn (kind info)
+ (declare (type keyword kind))
+ (let* ((component (component-info *component-being-compiled*))
+ (res (make-tn 0
+ :constant
+ *backend-t-primitive-type*
+ (svref *backend-sc-numbers*
+ (sc-number-or-lose 'constant))))
+ (constants (ir2-component-constants component)))
+
+ (do ((i 0 (1+ i)))
+ ((= i (length constants))
+ (setf (tn-offset res) i)
+ (vector-push-extend (cons kind info) constants))
+ (let ((entry (aref constants i)))
+ (when (and (consp entry)
+ (eq (car entry) kind)
+ (or (eq (cdr entry) info)
+ (and (consp info)
+ (equal (cdr entry) info))))
+ (setf (tn-offset res) i)
+ (return))))
+
+ (push-in tn-next res (ir2-component-constant-tns component))
+ res))
+\f
+;;;; TN referencing
+
+;;; Make a TN-Ref that references TN and return it. Write-P should be true
+;;; if this is a write reference, otherwise false. All we do other than
+;;; calling the constructor is add the reference to the TN's references.
+(defun reference-tn (tn write-p)
+ (declare (type tn tn) (type boolean write-p))
+ (let ((res (make-tn-ref tn write-p)))
+ (if write-p
+ (push-in tn-ref-next res (tn-writes tn))
+ (push-in tn-ref-next res (tn-reads tn)))
+ res))
+
+;;; Make TN-Refs to reference each TN in TNs, linked together by
+;;; TN-Ref-Across. Write-P is the Write-P value for the refs. More is
+;;; stuck in the TN-Ref-Across of the ref for the last TN, or returned as the
+;;; result if there are no TNs.
+(defun reference-tn-list (tns write-p &optional more)
+ (declare (list tns) (type boolean write-p) (type (or tn-ref null) more))
+ (if tns
+ (let* ((first (reference-tn (first tns) write-p))
+ (prev first))
+ (dolist (tn (rest tns))
+ (let ((res (reference-tn tn write-p)))
+ (setf (tn-ref-across prev) res)
+ (setq prev res)))
+ (setf (tn-ref-across prev) more)
+ first)
+ more))
+
+;;; Remove Ref from the references for its associated TN.
+(defun delete-tn-ref (ref)
+ (declare (type tn-ref ref))
+ (if (tn-ref-write-p ref)
+ (deletef-in tn-ref-next (tn-writes (tn-ref-tn ref)) ref)
+ (deletef-in tn-ref-next (tn-reads (tn-ref-tn ref)) ref))
+ (values))
+
+;;; Do stuff to change the TN referenced by Ref. We remove Ref from its
+;;; old TN's refs, add ref to TN's refs, and set the TN-Ref-TN.
+(defun change-tn-ref-tn (ref tn)
+ (declare (type tn-ref ref) (type tn tn))
+ (delete-tn-ref ref)
+ (setf (tn-ref-tn ref) tn)
+ (if (tn-ref-write-p ref)
+ (push-in tn-ref-next ref (tn-writes tn))
+ (push-in tn-ref-next ref (tn-reads tn)))
+ (values))
+\f
+;;;; miscellaneous utilities
+
+;;; Emit a move-like template determined at run-time, with X as the argument
+;;; and Y as the result. Useful for move, coerce and type-check templates. If
+;;; supplied, then insert before VOP, otherwise insert at then end of the
+;;; block. Returns the last VOP inserted.
+(defun emit-move-template (node block template x y &optional before)
+ (declare (type node node) (type ir2-block block)
+ (type template template) (type tn x y))
+ (let ((arg (reference-tn x nil))
+ (result (reference-tn y t)))
+ (multiple-value-bind (first last)
+ (funcall (template-emit-function template) node block template arg
+ result)
+ (insert-vop-sequence first last block before)
+ last)))
+
+;;; Like EMIT-MOVE-TEMPLATE, except that we pass in Info args too.
+(defun emit-load-template (node block template x y info &optional before)
+ (declare (type node node) (type ir2-block block)
+ (type template template) (type tn x y))
+ (let ((arg (reference-tn x nil))
+ (result (reference-tn y t)))
+ (multiple-value-bind (first last)
+ (funcall (template-emit-function template) node block template arg
+ result info)
+ (insert-vop-sequence first last block before)
+ last)))
+
+;;; Like EMIT-MOVE-TEMPLATE, except that the VOP takes two args.
+(defun emit-move-arg-template (node block template x f y &optional before)
+ (declare (type node node) (type ir2-block block)
+ (type template template) (type tn x f y))
+ (let ((x-ref (reference-tn x nil))
+ (f-ref (reference-tn f nil))
+ (y-ref (reference-tn y t)))
+ (setf (tn-ref-across x-ref) f-ref)
+ (multiple-value-bind (first last)
+ (funcall (template-emit-function template) node block template x-ref
+ y-ref)
+ (insert-vop-sequence first last block before)
+ last)))
+
+;;; Like EMIT-MOVE-TEMPLATE, except that the VOP takes no args.
+(defun emit-context-template (node block template y &optional before)
+ (declare (type node node) (type ir2-block block)
+ (type template template) (type tn y))
+ (let ((y-ref (reference-tn y t)))
+ (multiple-value-bind (first last)
+ (funcall (template-emit-function template) node block template nil
+ y-ref)
+ (insert-vop-sequence first last block before)
+ last)))
+
+;;; Return the label marking the start of Block, assigning one if necessary.
+(defun block-label (block)
+ (declare (type cblock block))
+ (let ((2block (block-info block)))
+ (or (ir2-block-%label 2block)
+ (setf (ir2-block-%label 2block) (gen-label)))))
+
+;;; Return true if Block is emitted immediately after the block ended by Node.
+(defun drop-thru-p (node block)
+ (declare (type node node) (type cblock block))
+ (let ((next-block (ir2-block-next (block-info (node-block node)))))
+ (assert (eq node (block-last (node-block node))))
+ (eq next-block (block-info block))))
+
+;;; Link a list of VOPs from First to Last into Block, Before the specified
+;;; VOP. If Before is NIL, insert at the end.
+(defun insert-vop-sequence (first last block before)
+ (declare (type vop first last) (type ir2-block block)
+ (type (or vop null) before))
+ (if before
+ (let ((prev (vop-prev before)))
+ (setf (vop-prev first) prev)
+ (if prev
+ (setf (vop-next prev) first)
+ (setf (ir2-block-start-vop block) first))
+ (setf (vop-next last) before)
+ (setf (vop-prev before) last))
+ (let ((current (ir2-block-last-vop block)))
+ (setf (vop-prev first) current)
+ (setf (ir2-block-last-vop block) last)
+ (if current
+ (setf (vop-next current) first)
+ (setf (ir2-block-start-vop block) first))))
+ (values))
+
+;;; Delete all of the TN-Refs associated with VOP and remove VOP from the IR2.
+(defun delete-vop (vop)
+ (declare (type vop vop))
+ (do ((ref (vop-refs vop) (tn-ref-next-ref ref)))
+ ((null ref))
+ (delete-tn-ref ref))
+
+ (let ((prev (vop-prev vop))
+ (next (vop-next vop))
+ (block (vop-block vop)))
+ (if prev
+ (setf (vop-next prev) next)
+ (setf (ir2-block-start-vop block) next))
+ (if next
+ (setf (vop-prev next) prev)
+ (setf (ir2-block-last-vop block) prev)))
+
+ (values))
+
+;;; Return a list of N normal TNs of the specified primitive type.
+(defun make-n-tns (n ptype)
+ (declare (type unsigned-byte n) (type primitive-type ptype))
+ (collect ((res))
+ (dotimes (i n)
+ (res (make-normal-tn ptype)))
+ (res)))
+
+;;; Return true if X and Y are packed in the same location, false otherwise.
+;;; This is false if either operand is constant.
+(defun location= (x y)
+ (declare (type tn x y))
+ (and (eq (sc-sb (tn-sc x)) (sc-sb (tn-sc y)))
+ (eql (tn-offset x) (tn-offset y))
+ (not (or (eq (tn-kind x) :constant)
+ (eq (tn-kind y) :constant)))))
+
+;;; Return the value of an immediate constant TN.
+(defun tn-value (tn)
+ (declare (type tn tn))
+ (assert (member (tn-kind tn) '(:constant :cached-constant)))
+ (constant-value (tn-leaf tn)))
+
+;;; Force TN to be allocated in a SC that doesn't need to be saved: an
+;;; unbounded non-save-p SC. We don't actually make it a real "restricted" TN,
+;;; but since we change the SC to an unbounded one, we should always succeed in
+;;; packing it in that SC.
+(defun force-tn-to-stack (tn)
+ (declare (type tn tn))
+ (let ((sc (tn-sc tn)))
+ (unless (and (not (sc-save-p sc))
+ (eq (sb-kind (sc-sb sc)) :unbounded))
+ (dolist (alt (sc-alternate-scs sc)
+ (error "SC ~S has no :unbounded :save-p NIL alternate SC."
+ (sc-name sc)))
+ (when (and (not (sc-save-p alt))
+ (eq (sb-kind (sc-sb alt)) :unbounded))
+ (setf (tn-sc tn) alt)
+ (return)))))
+ (values))
+
--- /dev/null
+;;;; trace tables (from codegen.lisp in CMU CL sources)
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!C")
+
+(file-comment
+ "$Header$")
+
+(defun trace-table-entry (state)
+ (let ((label (gen-label)))
+ (emit-label label)
+ (push (cons label state) *trace-table-info*))
+ (values))
+
+;;; Convert the list of (label . state) entries into an ivector.
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defconstant tt-bits-per-state 3)
+ (defconstant tt-bytes-per-entry 2)
+ (defconstant tt-bits-per-entry (* tt-bytes-per-entry sb!vm:byte-bits))
+ (defconstant tt-bits-per-offset (- tt-bits-per-entry tt-bits-per-state))
+ (defconstant tt-max-offset (1- (ash 1 tt-bits-per-offset))))
+(deftype tt-state ()
+ `(unsigned-byte ,tt-bits-per-state))
+(deftype tt-entry ()
+ `(unsigned-byte ,tt-bits-per-entry))
+(deftype tt-offset ()
+ `(unsigned-byte ,tt-bits-per-offset))
+(declaim (ftype (function (list) (simple-array tt-entry 1)) pack-trace-table))
+(defun pack-trace-table (entries)
+ (declare (list entries))
+ #!-gengc (declare (ignore entries))
+ #!+gengc (let ((result (make-array (logandc2 (1+ (length entries)) 1)
+ :element-type 'tt-entry))
+ (index 0)
+ (last-posn 0)
+ (last-state 0))
+ (declare (type index index last-posn)
+ (type tt-state last-state))
+ (flet ((push-entry (offset state)
+ (declare (type tt-offset offset)
+ (type tt-state state))
+ (when (>= index (length result))
+ (setf result
+ (replace (make-array
+ (truncate (* (length result) 5) 4)
+ :element-type
+ 'tt-entry)
+ result)))
+ (setf (aref result index)
+ (logior (ash offset tt-bits-per-state) state))
+ (incf index)))
+ (dolist (entry entries)
+ (let* ((posn (label-position (car entry)))
+ (state (cdr entry)))
+ (declare (type index posn) (type tt-state state))
+ (assert (<= last-posn posn))
+ (do ((offset (- posn last-posn) (- offset tt-max-offset)))
+ ((< offset tt-max-offset)
+ (push-entry offset state))
+ (push-entry tt-max-offset last-state))
+ (setf last-posn posn)
+ (setf last-state state)))
+ (when (oddp index)
+ (push-entry 0 last-state)))
+ (if (eql (length result) index)
+ result
+ (subseq result 0 index)))
+ #!-gengc (make-array 0 :element-type 'tt-entry))
--- /dev/null
+;;;; This file contains stuff that implements the portable IR1
+;;;; semantics of type tests and coercion. The main thing we do is
+;;;; convert complex type operations into simpler code that can be
+;;;; compiled inline.
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!C")
+
+(file-comment
+ "$Header$")
+\f
+;;;; type predicate translation
+;;;;
+;;;; We maintain a bidirectional association between type predicates
+;;;; and the tested type. The presence of a predicate in this
+;;;; association implies that it is desirable to implement tests of
+;;;; this type using the predicate. These are either predicates that
+;;;; the back end is likely to have special knowledge about, or
+;;;; predicates so complex that the only reasonable implentation is
+;;;; via function call.
+;;;;
+;;;; Some standard types (such as SEQUENCE) are best tested by letting
+;;;; the TYPEP source transform do its thing with the expansion. These
+;;;; types (and corresponding predicates) are not maintained in this
+;;;; association. In this case, there need not be any predicate
+;;;; function unless it is required by the Common Lisp specification.
+;;;;
+;;;; The mapping between predicates and type structures is considered
+;;;; part of the backend; different backends can support different
+;;;; sets of predicates.
+
+(defmacro define-type-predicate (name type)
+ #!+sb-doc
+ "Define-Type-Predicate Name Type
+ Establish an association between the type predicate Name and the
+ corresponding Type. This causes the type predicate to be recognized for
+ purposes of optimization."
+ `(%define-type-predicate ',name ',type))
+(defun %define-type-predicate (name specifier)
+ (let ((type (specifier-type specifier)))
+ (setf (gethash name *backend-predicate-types*) type)
+ (setf *backend-type-predicates*
+ (cons (cons type name)
+ (remove name *backend-type-predicates*
+ :key #'cdr)))
+ (%deftransform name '(function (t) *) #'fold-type-predicate)
+ name))
+\f
+;;;; IR1 transforms
+
+;;; If we discover the type argument is constant during IR1
+;;; optimization, then give the source transform another chance. The
+;;; source transform can't pass, since we give it an explicit
+;;; constant. At worst, it will convert to %TYPEP, which will prevent
+;;; spurious attempts at transformation (and possible repeated
+;;; warnings.)
+(deftransform typep ((object type))
+ (unless (constant-continuation-p type)
+ (give-up-ir1-transform "can't open-code test of non-constant type"))
+ `(typep object ',(continuation-value type)))
+
+;;; If the continuation OBJECT definitely is or isn't of the specified
+;;; type, then return T or NIL as appropriate. Otherwise quietly
+;;; GIVE-UP-IR1-TRANSFORM.
+(defun ir1-transform-type-predicate (object type)
+ (declare (type continuation object) (type ctype type))
+ (let ((otype (continuation-type object)))
+ (cond ((not (types-intersect otype type))
+ 'nil)
+ ((csubtypep otype type)
+ 't)
+ (t
+ (give-up-ir1-transform)))))
+
+;;; Flush %TYPEP tests whose result is known at compile time.
+(deftransform %typep ((object type))
+ (unless (constant-continuation-p type) (give-up-ir1-transform))
+ (ir1-transform-type-predicate
+ object
+ (specifier-type (continuation-value type))))
+
+;;; This is the IR1 transform for simple type predicates. It checks
+;;; whether the single argument is known to (not) be of the
+;;; appropriate type, expanding to T or NIL as appropriate.
+(deftransform fold-type-predicate ((object) * * :node node :defun-only t)
+ (let ((ctype (gethash (leaf-name
+ (ref-leaf
+ (continuation-use
+ (basic-combination-fun node))))
+ *backend-predicate-types*)))
+ (assert ctype)
+ (ir1-transform-type-predicate object ctype)))
+
+;;; If FIND-CLASS is called on a constant class, locate the CLASS-CELL
+;;; at load time.
+(deftransform find-class ((name) ((constant-argument symbol)) *
+ :when :both)
+ (let* ((name (continuation-value name))
+ (cell (find-class-cell name)))
+ `(or (class-cell-class ',cell)
+ (error "class not yet defined: ~S" name))))
+\f
+;;;; standard type predicates
+
+;;; FIXME: needed only at cold load time, can be uninterned afterwards;
+;;; or perhaps could just be done at toplevel
+(defun define-standard-type-predicates ()
+ (define-type-predicate arrayp array)
+ ; (The ATOM predicate is handled separately as (NOT CONS).)
+ (define-type-predicate bit-vector-p bit-vector)
+ (define-type-predicate characterp character)
+ (define-type-predicate compiled-function-p compiled-function)
+ (define-type-predicate complexp complex)
+ (define-type-predicate complex-rational-p (complex rational))
+ (define-type-predicate complex-float-p (complex float))
+ (define-type-predicate consp cons)
+ (define-type-predicate floatp float)
+ (define-type-predicate functionp function)
+ (define-type-predicate integerp integer)
+ (define-type-predicate keywordp keyword)
+ (define-type-predicate listp list)
+ (define-type-predicate null null)
+ (define-type-predicate numberp number)
+ (define-type-predicate rationalp rational)
+ (define-type-predicate realp real)
+ (define-type-predicate simple-bit-vector-p simple-bit-vector)
+ (define-type-predicate simple-string-p simple-string)
+ (define-type-predicate simple-vector-p simple-vector)
+ (define-type-predicate stringp string)
+ (define-type-predicate %instancep instance)
+ (define-type-predicate funcallable-instance-p funcallable-instance)
+ (define-type-predicate symbolp symbol)
+ (define-type-predicate vectorp vector))
+
+(define-standard-type-predicates)
+\f
+;;;; transforms for type predicates not implemented primitively
+;;;;
+;;;; See also VM dependent transforms.
+
+(def-source-transform atom (x)
+ `(not (consp ,x)))
+\f
+;;;; TYPEP source transform
+
+;;; Return a form that tests the variable N-Object for being in the binds
+;;; specified by Type. Base is the name of the base type, for declaration. We
+;;; make safety locally 0 to inhibit any checking of this assertion.
+#!-negative-zero-is-not-zero
+(defun transform-numeric-bound-test (n-object type base)
+ (declare (type numeric-type type))
+ (let ((low (numeric-type-low type))
+ (high (numeric-type-high type)))
+ `(locally
+ (declare (optimize (safety 0)))
+ (and ,@(when low
+ (if (consp low)
+ `((> (the ,base ,n-object) ,(car low)))
+ `((>= (the ,base ,n-object) ,low))))
+ ,@(when high
+ (if (consp high)
+ `((< (the ,base ,n-object) ,(car high)))
+ `((<= (the ,base ,n-object) ,high))))))))
+
+#!+negative-zero-is-not-zero
+(defun transform-numeric-bound-test (n-object type base)
+ (declare (type numeric-type type))
+ (let ((low (numeric-type-low type))
+ (high (numeric-type-high type))
+ (float-type-p (csubtypep type (specifier-type 'float)))
+ (x (gensym))
+ (y (gensym)))
+ `(locally
+ (declare (optimize (safety 0)))
+ (and ,@(when low
+ (if (consp low)
+ `((let ((,x (the ,base ,n-object))
+ (,y ,(car low)))
+ ,(if (not float-type-p)
+ `(> ,x ,y)
+ `(if (and (zerop ,x) (zerop ,y))
+ (> (float-sign ,x) (float-sign ,y))
+ (> ,x ,y)))))
+ `((let ((,x (the ,base ,n-object))
+ (,y ,low))
+ ,(if (not float-type-p)
+ `(>= ,x ,y)
+ `(if (and (zerop ,x) (zerop ,y))
+ (>= (float-sign ,x) (float-sign ,y))
+ (>= ,x ,y)))))))
+ ,@(when high
+ (if (consp high)
+ `((let ((,x (the ,base ,n-object))
+ (,y ,(car high)))
+ ,(if (not float-type-p)
+ `(< ,x ,y)
+ `(if (and (zerop ,x) (zerop ,y))
+ (< (float-sign ,x) (float-sign ,y))
+ (< ,x ,y)))))
+ `((let ((,x (the ,base ,n-object))
+ (,y ,high))
+ ,(if (not float-type-p)
+ `(<= ,x ,y)
+ `(if (and (zerop ,x) (zerop ,y))
+ (<= (float-sign ,x) (float-sign ,y))
+ (<= ,x ,y)))))))))))
+
+;;; Do source transformation of a test of a known numeric type. We can
+;;; assume that the type doesn't have a corresponding predicate, since
+;;; those types have already been picked off. In particular, CLASS
+;;; must be specified, since it is unspecified only in NUMBER and
+;;; COMPLEX. Similarly, we assume that COMPLEXP is always specified.
+;;;
+;;; For non-complex types, we just test that the number belongs to the
+;;; base type, and then test that it is in bounds. When CLASS is
+;;; INTEGER, we check to see whether the range is no bigger than
+;;; FIXNUM. If so, we check for FIXNUM instead of INTEGER. This allows
+;;; us to use fixnum comparison to test the bounds.
+;;;
+;;; For complex types, we must test for complex, then do the above on
+;;; both the real and imaginary parts. When CLASS is float, we need
+;;; only check the type of the realpart, since the format of the
+;;; realpart and the imagpart must be the same.
+(defun source-transform-numeric-typep (object type)
+ (let* ((class (numeric-type-class type))
+ (base (ecase class
+ (integer (containing-integer-type type))
+ (rational 'rational)
+ (float (or (numeric-type-format type) 'float))
+ ((nil) 'real))))
+ (once-only ((n-object object))
+ (ecase (numeric-type-complexp type)
+ (:real
+ `(and (typep ,n-object ',base)
+ ,(transform-numeric-bound-test n-object type base)))
+ (:complex
+ `(and (complexp ,n-object)
+ ,(once-only ((n-real `(realpart (the complex ,n-object)))
+ (n-imag `(imagpart (the complex ,n-object))))
+ `(progn
+ ,n-imag ; ignorable
+ (and (typep ,n-real ',base)
+ ,@(when (eq class 'integer)
+ `((typep ,n-imag ',base)))
+ ,(transform-numeric-bound-test n-real type base)
+ ,(transform-numeric-bound-test n-imag type
+ base))))))))))
+
+;;; Do the source transformation for a test of a hairy type. AND,
+;;; SATISFIES and NOT are converted into the obvious code. We convert
+;;; unknown types to %TYPEP, emitting an efficiency note if
+;;; appropriate.
+(defun source-transform-hairy-typep (object type)
+ (declare (type hairy-type type))
+ (let ((spec (hairy-type-specifier type)))
+ (cond ((unknown-type-p type)
+ (when (policy nil (> speed brevity))
+ (compiler-note "can't open-code test of unknown type ~S"
+ (type-specifier type)))
+ `(%typep ,object ',spec))
+ (t
+ (ecase (first spec)
+ (satisfies `(if (funcall #',(second spec) ,object) t nil))
+ ((not and)
+ (once-only ((n-obj object))
+ `(,(first spec) ,@(mapcar #'(lambda (x)
+ `(typep ,n-obj ',x))
+ (rest spec))))))))))
+
+;;; Do source transformation for Typep of a known union type. If a
+;;; union type contains LIST, then we pull that out and make it into a
+;;; single LISTP call. Note that if SYMBOL is in the union, then LIST
+;;; will be a subtype even without there being any (member NIL). We
+;;; just drop through to the general code in this case, rather than
+;;; trying to optimize it.
+(defun source-transform-union-typep (object type)
+ (let* ((types (union-type-types type))
+ (ltype (specifier-type 'list))
+ (mtype (find-if #'member-type-p types)))
+ (cond ((and mtype (csubtypep ltype type))
+ (let ((members (member-type-members mtype)))
+ (once-only ((n-obj object))
+ `(if (listp ,n-obj)
+ t
+ (typep ,n-obj
+ '(or ,@(mapcar #'type-specifier
+ (remove (specifier-type 'cons)
+ (remove mtype types)))
+ (member ,@(remove nil members))))))))
+ (t
+ (once-only ((n-obj object))
+ `(or ,@(mapcar #'(lambda (x)
+ `(typep ,n-obj ',(type-specifier x)))
+ types)))))))
+
+;;; Return the predicate and type from the most specific entry in
+;;; *TYPE-PREDICATES* that is a supertype of TYPE.
+(defun find-supertype-predicate (type)
+ (declare (type ctype type))
+ (let ((res nil)
+ (res-type nil))
+ (dolist (x *backend-type-predicates*)
+ (let ((stype (car x)))
+ (when (and (csubtypep type stype)
+ (or (not res-type)
+ (csubtypep stype res-type)))
+ (setq res-type stype)
+ (setq res (cdr x)))))
+ (values res res-type)))
+
+;;; Return forms to test that OBJ has the rank and dimensions
+;;; specified by TYPE, where STYPE is the type we have checked against
+;;; (which is the same but for dimensions.)
+(defun test-array-dimensions (obj type stype)
+ (declare (type array-type type stype))
+ (let ((obj `(truly-the ,(type-specifier stype) ,obj))
+ (dims (array-type-dimensions type)))
+ (unless (eq dims '*)
+ (collect ((res))
+ (when (eq (array-type-dimensions stype) '*)
+ (res `(= (array-rank ,obj) ,(length dims))))
+ (do ((i 0 (1+ i))
+ (dim dims (cdr dim)))
+ ((null dim))
+ (let ((dim (car dim)))
+ (unless (eq dim '*)
+ (res `(= (array-dimension ,obj ,i) ,dim)))))
+ (res)))))
+
+;;; If we can find a type predicate that tests for the type w/o
+;;; dimensions, then use that predicate and test for dimensions.
+;;; Otherwise, just do %TYPEP.
+(defun source-transform-array-typep (obj type)
+ (multiple-value-bind (pred stype) (find-supertype-predicate type)
+ (if (and (array-type-p stype)
+ ;; (If the element type hasn't been defined yet, it's
+ ;; not safe to assume here that it will eventually
+ ;; have (UPGRADED-ARRAY-ELEMENT-TYPE type)=T, so punt.)
+ (not (unknown-type-p (array-type-element-type type)))
+ (type= (array-type-specialized-element-type stype)
+ (array-type-specialized-element-type type))
+ (eq (array-type-complexp stype) (array-type-complexp type)))
+ (once-only ((n-obj obj))
+ `(and (,pred ,n-obj)
+ ,@(test-array-dimensions n-obj type stype)))
+ `(%typep ,obj ',(type-specifier type)))))
+
+;;; Transform a type test against some instance type. The type test is
+;;; flushed if the result is known at compile time. If not properly
+;;; named, error. If sealed and has no subclasses, just test for
+;;; layout-EQ. If a structure then test for layout-EQ and then a
+;;; general test based on layout-inherits. If safety is important,
+;;; then we also check whether the layout for the object is invalid
+;;; and signal an error if so. Otherwise, look up the indirect
+;;; class-cell and call CLASS-CELL-TYPEP at runtime.
+;;;
+;;; KLUDGE: The :WHEN :BOTH option here is probably a suboptimal
+;;; solution to the problem of %INSTANCE-TYPEP forms in byte compiled
+;;; code; it'd probably be better just to have %INSTANCE-TYPEP forms
+;;; never be generated in byte compiled code, or maybe to have a DEFUN
+;;; %INSTANCE-TYPEP somewhere to handle them if they are. But it's not
+;;; terribly important because mostly, %INSTANCE-TYPEP forms *aren't*
+;;; generated in byte compiled code. (As of sbcl-0.6.5, they could
+;;; sometimes be generated when byte compiling inline functions, but
+;;; it's quite uncommon.) -- WHN 20000523
+(deftransform %instance-typep ((object spec) * * :when :both)
+ (assert (constant-continuation-p spec))
+ (let* ((spec (continuation-value spec))
+ (class (specifier-type spec))
+ (name (sb!xc:class-name class))
+ (otype (continuation-type object))
+ (layout (let ((res (info :type :compiler-layout name)))
+ (if (and res (not (layout-invalid res)))
+ res
+ nil))))
+ (/noshow "entering DEFTRANSFORM %INSTANCE-TYPEP" otype spec class name layout)
+ (cond
+ ;; Flush tests whose result is known at compile time.
+ ((not (types-intersect otype class))
+ (/noshow "flushing constant NIL")
+ nil)
+ ((csubtypep otype class)
+ (/noshow "flushing constant T")
+ t)
+ ;; If not properly named, error.
+ ((not (and name (eq (sb!xc:find-class name) class)))
+ (compiler-error "can't compile TYPEP of anonymous or undefined ~
+ class:~% ~S"
+ class))
+ (t
+ ;; Otherwise transform the type test.
+ (multiple-value-bind (pred get-layout)
+ (cond
+ ((csubtypep class (specifier-type 'funcallable-instance))
+ (values 'funcallable-instance-p '%funcallable-instance-layout))
+ ((csubtypep class (specifier-type 'instance))
+ (values '%instancep '%instance-layout))
+ (t
+ (values '(lambda (x) (declare (ignore x)) t) 'layout-of)))
+ (/noshow pred get-layout)
+ (cond
+ ((and (eq (class-state class) :sealed) layout
+ (not (class-subclasses class)))
+ ;; Sealed and has no subclasses.
+ (/noshow "sealed and has no subclasses")
+ (let ((n-layout (gensym)))
+ `(and (,pred object)
+ (let ((,n-layout (,get-layout object)))
+ ,@(when (policy nil (>= safety speed))
+ `((when (layout-invalid ,n-layout)
+ (%layout-invalid-error object ',layout))))
+ (eq ,n-layout ',layout)))))
+ ((and (typep class 'basic-structure-class) layout)
+ (/noshow "structure type tests; hierarchical layout depths")
+ ;; structure type tests; hierarchical layout depths
+ (let ((depthoid (layout-depthoid layout))
+ (n-layout (gensym)))
+ `(and (,pred object)
+ (let ((,n-layout (,get-layout object)))
+ ,@(when (policy nil (>= safety speed))
+ `((when (layout-invalid ,n-layout)
+ (%layout-invalid-error object ',layout))))
+ (if (eq ,n-layout ',layout)
+ t
+ (and (> (layout-depthoid ,n-layout)
+ ,depthoid)
+ (locally (declare (optimize (safety 0)))
+ (eq (svref (layout-inherits ,n-layout)
+ ,depthoid)
+ ',layout))))))))
+ (t
+ (/noshow "default case -- ,PRED and CLASS-CELL-TYPEP")
+ `(and (,pred object)
+ (class-cell-typep (,get-layout object)
+ ',(find-class-cell name)
+ object)))))))))
+
+#|
+;;; Return (VALUES BEST-GUESS EXACT?), where BEST-GUESS is a CTYPE
+;;; which corresponds to the value returned by
+;;; CL:UPGRADED-ARRAY-ELEMENT-TYPE, and EXACT? tells whether that
+;;; result might change when we encounter a DEFTYPE.
+(declaim (maybe-inline upgraded-array-element-ctype-2))
+(defun upgraded-array-element-ctype-2 (spec)
+ (let ((ctype (specifier-type `(array ,spec))))
+ (values (array-type-specialized-element-type
+ (specifier-type `(array ,spec)))
+ (not (unknown-type-p (array-type-element-type ctype))))))
+|#
+
+;;; If the specifier argument is a quoted constant, then we consider
+;;; converting into a simple predicate or other stuff. If the type is
+;;; constant, but we can't transform the call, then we convert to
+;;; %TYPEP. We only pass when the type is non-constant. This allows us
+;;; to recognize between calls that might later be transformed
+;;; successfully when a constant type is discovered. We don't give an
+;;; efficiency note when we pass, since the IR1 transform will give
+;;; one if necessary and appropriate.
+;;;
+;;; If the type is TYPE= to a type that has a predicate, then expand
+;;; to that predicate. Otherwise, we dispatch off of the type's type.
+;;; These transformations can increase space, but it is hard to tell
+;;; when, so we ignore policy and always do them. When byte-compiling,
+;;; we only do transforms that have potential for control
+;;; simplification. Instance type tests are converted to
+;;; %INSTANCE-TYPEP to allow type propagation.
+(def-source-transform typep (object spec)
+ (if (and (consp spec) (eq (car spec) 'quote))
+ (let ((type (specifier-type (cadr spec))))
+ (or (let ((pred (cdr (assoc type *backend-type-predicates*
+ :test #'type=))))
+ (when pred `(,pred ,object)))
+ (typecase type
+ (hairy-type
+ (source-transform-hairy-typep object type))
+ (union-type
+ (source-transform-union-typep object type))
+ (member-type
+ `(member ,object ',(member-type-members type)))
+ (args-type
+ (compiler-warning "illegal type specifier for TYPEP: ~S"
+ (cadr spec))
+ `(%typep ,object ,spec))
+ (t nil))
+ (and (not (byte-compiling))
+ (typecase type
+ (numeric-type
+ (source-transform-numeric-typep object type))
+ (sb!xc:class
+ `(%instance-typep ,object ,spec))
+ (array-type
+ (source-transform-array-typep object type))
+ (t nil)))
+ `(%typep ,object ,spec)))
+ (values nil t)))
+\f
+;;;; coercion
+
+;;; old working version
+(deftransform coerce ((x type) (* *) * :when :both)
+ (unless (constant-continuation-p type)
+ (give-up-ir1-transform))
+ (let ((tspec (specifier-type (continuation-value type))))
+ (if (csubtypep (continuation-type x) tspec)
+ 'x
+ `(the ,(continuation-value type)
+ ,(cond ((csubtypep tspec (specifier-type 'double-float))
+ '(%double-float x))
+ ;; FIXME: If LONG-FLOAT is to be supported, we
+ ;; need to pick it off here before falling through
+ ;; to %SINGLE-FLOAT.
+ ((csubtypep tspec (specifier-type 'float))
+ '(%single-float x))
+ (t
+ (give-up-ir1-transform)))))))
+
+;;; KLUDGE: new broken version -- 20000504
+#+nil
+(deftransform coerce ((x type) (* *) * :when :both)
+ (unless (constant-continuation-p type)
+ (give-up-ir1-transform))
+ (let ((tspec (specifier-type (continuation-value type))))
+ (if (csubtypep (continuation-type x) tspec)
+ 'x
+ `(if #+nil (typep x type) #-nil nil
+ x
+ (the ,(continuation-value type)
+ ,(cond ((csubtypep tspec (specifier-type 'double-float))
+ '(%double-float x))
+ ;; FIXME: If LONG-FLOAT is to be supported,
+ ;; we need to pick it off here before falling
+ ;; through to %SINGLE-FLOAT.
+ ((csubtypep tspec (specifier-type 'float))
+ '(%single-float x))
+ #+nil
+ ((csubtypep tspec (specifier-type 'list))
+ '(coerce-to-list x))
+ #+nil
+ ((csubtypep tspec (specifier-type 'string))
+ '(coerce-to-simple-string x))
+ #+nil
+ ((csubtypep tspec (specifier-type 'bit-vector))
+ '(coerce-to-bit-vector x))
+ #+nil
+ ((csubtypep tspec (specifier-type 'vector))
+ '(coerce-to-vector x type))
+ (t
+ (give-up-ir1-transform))))))))
--- /dev/null
+;;;; implementation-independent facilities used for defining the
+;;;; compiler's interface to the VM in a given implementation
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!C")
+
+(file-comment
+ "$Header$")
+
+;;; Return the template having the specified name, or die trying.
+(defun template-or-lose (x)
+ (the template
+ (or (gethash x *backend-template-names*)
+ (error "~S is not a defined template." x))))
+
+;;; Return the SC structure, SB structure or SC number corresponding to a
+;;; name, or die trying.
+(defun sc-or-lose (x)
+ (the sc
+ (or (gethash x *backend-sc-names*)
+ (error "~S is not a defined storage class." x))))
+(defun sb-or-lose (x)
+ (the sb
+ (or (gethash x *backend-sb-names*)
+ (error "~S is not a defined storage base." x))))
+(defun sc-number-or-lose (x)
+ (the sc-number (sc-number (sc-or-lose x))))
+
+;;; Like the non-meta versions, but go for the meta-compile-time info.
+;;; These should not be used after load time, since compiling the compiler
+;;; changes the definitions.
+(defun meta-sc-or-lose (x)
+ (the sc
+ (or (gethash x *backend-meta-sc-names*)
+ (error "~S is not a defined storage class." x))))
+(defun meta-sb-or-lose (x)
+ (the sb
+ (or (gethash x *backend-meta-sb-names*)
+ (error "~S is not a defined storage base." x))))
+(defun meta-sc-number-or-lose (x)
+ (the sc-number (sc-number (meta-sc-or-lose x))))
+\f
+;;;; side-effect classes
+
+(def-boolean-attribute vop
+ any)
+\f
+;;;; move/coerce definition
+
+;;; Compute at compiler load time the costs for moving between all SCs that
+;;; can be loaded from FROM-SC and to TO-SC given a base move cost Cost.
+(defun compute-move-costs (from-sc to-sc cost)
+ (declare (type sc from-sc to-sc) (type index cost))
+ (let ((to-scn (sc-number to-sc))
+ (from-costs (sc-load-costs from-sc)))
+ (dolist (dest-sc (cons to-sc (sc-alternate-scs to-sc)))
+ (let ((vec (sc-move-costs dest-sc))
+ (dest-costs (sc-load-costs dest-sc)))
+ (setf (svref vec (sc-number from-sc)) cost)
+ (dolist (sc (append (sc-alternate-scs from-sc)
+ (sc-constant-scs from-sc)))
+ (let* ((scn (sc-number sc))
+ (total (+ (svref from-costs scn)
+ (svref dest-costs to-scn)
+ cost))
+ (old (svref vec scn)))
+ (unless (and old (< old total))
+ (setf (svref vec scn) total))))))))
+\f
+;;;; primitive type definition
+
+;;; Return the primitive type corresponding to the specified name, or die
+;;; trying.
+(defun primitive-type-or-lose (name)
+ (the primitive-type
+ (or (gethash name *backend-primitive-type-names*)
+ (error "~S is not a defined primitive type." name))))
+
+;;; Return true if SC is either one of Ptype's SC's, or one of those SC's
+;;; alternate or constant SCs.
+(defun sc-allowed-by-primitive-type (sc ptype)
+ (declare (type sc sc) (type primitive-type ptype))
+ (let ((scn (sc-number sc)))
+ (dolist (allowed (primitive-type-scs ptype) nil)
+ (when (eql allowed scn)
+ (return t))
+ (let ((allowed-sc (svref *backend-sc-numbers* allowed)))
+ (when (or (member sc (sc-alternate-scs allowed-sc))
+ (member sc (sc-constant-scs allowed-sc)))
+ (return t))))))
+\f
+;;;; generation of emit functions
+
+(defconstant max-vop-tn-refs 256)
+
+(defvar *vop-tn-refs* (make-array max-vop-tn-refs :initial-element nil))
+(defvar *using-vop-tn-refs* nil)
+
+(defun flush-vop-tn-refs ()
+ (unless *using-vop-tn-refs*
+ (fill *vop-tn-refs* nil)))
+
+(pushnew 'flush-vop-tn-refs *before-gc-hooks*)
+
+(defconstant sc-bits (integer-length (1- sc-number-limit)))
+
+(defun emit-generic-vop (node block template args results &optional info)
+ (%emit-generic-vop node block template args results info))
+
+(defun %emit-generic-vop (node block template args results info)
+ (let* ((vop (make-vop block node template args results))
+ (num-args (vop-info-num-args template))
+ (last-arg (1- num-args))
+ (num-results (vop-info-num-results template))
+ (num-operands (+ num-args num-results))
+ (last-result (1- num-operands))
+ (ref-ordering (vop-info-ref-ordering template)))
+ (declare (type vop vop)
+ (type (integer 0 #.max-vop-tn-refs)
+ num-args num-results num-operands)
+ (type (integer -1 #.(1- max-vop-tn-refs)) last-arg last-result))
+ (setf (vop-codegen-info vop) info)
+ (let ((refs *vop-tn-refs*)
+ (*using-vop-tn-refs* t))
+ (declare (type (simple-vector #.max-vop-tn-refs) refs))
+ (do ((index 0 (1+ index))
+ (ref args (and ref (tn-ref-across ref))))
+ ((= index num-args))
+ (setf (svref refs index) ref))
+ (do ((index num-args (1+ index))
+ (ref results (and ref (tn-ref-across ref))))
+ ((= index num-operands))
+ (setf (svref refs index) ref))
+ (let ((temps (vop-info-temps template)))
+ (when temps
+ (let ((index num-operands)
+ (prev nil))
+ (dotimes (i (length temps))
+ (let* ((temp (aref temps i))
+ (tn (if (logbitp 0 temp)
+ (make-wired-tn nil
+ (ldb (byte sc-bits 1) temp)
+ (ash temp (- (1+ sc-bits))))
+ (make-restricted-tn nil (ash temp -1))))
+ (write-ref (reference-tn tn t)))
+ (setf (aref refs index) (reference-tn tn nil))
+ (setf (aref refs (1+ index)) write-ref)
+ (if prev
+ (setf (tn-ref-across prev) write-ref)
+ (setf (vop-temps vop) write-ref))
+ (setf prev write-ref)
+ (incf index 2))))))
+ (let ((prev nil))
+ (flet ((add-ref (ref)
+ (setf (tn-ref-vop ref) vop)
+ (setf (tn-ref-next-ref ref) prev)
+ (setf prev ref)))
+ (declare (inline add-ref))
+ (dotimes (i (length ref-ordering))
+ (let* ((index (aref ref-ordering i))
+ (ref (aref refs index)))
+ (if (or (= index last-arg) (= index last-result))
+ (do ((ref ref (tn-ref-across ref)))
+ ((null ref))
+ (add-ref ref))
+ (add-ref ref)))))
+ (setf (vop-refs vop) prev))
+ (let ((targets (vop-info-targets template)))
+ (when targets
+ (dotimes (i (length targets))
+ (let ((target (aref targets i)))
+ (target-if-desirable (aref refs (ldb (byte 8 8) target))
+ (aref refs (ldb (byte 8 0) target))))))))
+ (values vop vop)))
+\f
+;;;; function translation stuff
+
+;;; Add Template into List, removing any old template with the same name.
+;;; We also maintain the increasing cost ordering.
+(defun adjoin-template (template list)
+ (declare (type template template) (list list))
+ (sort (cons template
+ (remove (template-name template) list
+ :key #'template-name))
+ #'<=
+ :key #'template-cost))
+\f
+;;; Return a function type specifier describing Template's type computed
+;;; from the operand type restrictions.
+(defun template-type-specifier (template)
+ (declare (type template template))
+ (flet ((convert (types more-types)
+ (flet ((frob (x)
+ (if (eq x '*)
+ 't
+ (ecase (first x)
+ (:or `(or ,@(mapcar #'(lambda (type)
+ (type-specifier
+ (primitive-type-type
+ type)))
+ (rest x))))
+ (:constant `(constant-argument ,(third x)))))))
+ `(,@(mapcar #'frob types)
+ ,@(when more-types
+ `(&rest ,(frob more-types)))))))
+ (let* ((args (convert (template-arg-types template)
+ (template-more-args-type template)))
+ (result-restr (template-result-types template))
+ (results (if (eq result-restr :conditional)
+ '(boolean)
+ (convert result-restr
+ (cond ((template-more-results-type template))
+ ((/= (length result-restr) 1) '*)
+ (t nil))))))
+ `(function ,args
+ ,(if (= (length results) 1)
+ (first results)
+ `(values ,@results))))))
--- /dev/null
+;;;; structures for the second (virtual machine) intermediate
+;;;; representation in the compiler, IR2
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!C")
+
+(file-comment
+ "$Header$")
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ ;; the largest number of TNs whose liveness changes that we can have in any
+ ;; block
+ (defconstant local-tn-limit 64))
+
+(deftype local-tn-number () `(integer 0 (,local-tn-limit)))
+(deftype local-tn-count () `(integer 0 ,local-tn-limit))
+(deftype local-tn-vector () `(simple-vector ,local-tn-limit))
+(deftype local-tn-bit-vector () `(simple-bit-vector ,local-tn-limit))
+
+;;; Type of an SC number.
+(deftype sc-number () `(integer 0 (,sc-number-limit)))
+
+;;; Types for vectors indexed by SC numbers.
+(deftype sc-vector () `(simple-vector ,sc-number-limit))
+(deftype sc-bit-vector () `(simple-bit-vector ,sc-number-limit))
+
+;;; The different policies we can use to determine the coding strategy.
+(deftype policies ()
+ '(member :safe :small :fast :fast-safe))
+\f
+;;;; PRIMITIVE-TYPEs
+
+;;; The primitive type is used to represent the aspects of type interesting
+;;; to the VM. Selection of IR2 translation templates is done on the basis of
+;;; the primitive types of the operands, and the primitive type of a value
+;;; is used to constrain the possible representations of that value.
+(defstruct primitive-type
+ ;; The name of this primitive-type.
+ (name nil :type symbol)
+ ;; A list the SC numbers for all the SCs that a TN of this type can be
+ ;; allocated in.
+ (scs nil :type list)
+ ;; The Lisp type equivalent to this type. If this type could never be
+ ;; returned by Primitive-Type, then this is the NIL (or empty) type.
+ (type (required-argument) :type ctype)
+ ;; The template used to check that an object is of this type. This is a
+ ;; template of one argument and one result, both of primitive-type T. If
+ ;; the argument is of the correct type, then it is delivered into the
+ ;; result. If the type is incorrect, then an error is signalled.
+ (check nil :type (or template null)))
+
+(defprinter (primitive-type)
+ name)
+\f
+;;;; IR1 annotations used for IR2 conversion
+
+;;; Block-Info
+;;; Holds the IR2-Block structure. If there are overflow blocks, then this
+;;; points to the first IR2-Block. The Block-Info of the dummy component
+;;; head and tail are dummy IR2 blocks that begin and end the emission order
+;;; thread.
+;;;
+;;; Component-Info
+;;; Holds the IR2-Component structure.
+;;;
+;;; Continuation-Info
+;;; Holds the IR2-Continuation structure. Continuations whose values aren't
+;;; used won't have any.
+;;;
+;;; Cleanup-Info
+;;; If non-null, then a TN in which the affected dynamic environment pointer
+;;; should be saved after the binding is instantiated.
+;;;
+;;; Environment-Info
+;;; Holds the IR2-Environment structure.
+;;;
+;;; Tail-Set-Info
+;;; Holds the Return-Info structure.
+;;;
+;;; NLX-Info-Info
+;;; Holds the IR2-NLX-Info structure.
+;;;
+;;; Leaf-Info
+;;; If a non-set lexical variable, the TN that holds the value in the home
+;;; environment. If a constant, then the corresponding constant TN.
+;;; If an XEP lambda, then the corresponding Entry-Info structure.
+;;;
+;;; Basic-Combination-Info
+;;; The template chosen by LTN, or
+;;; :FULL if this is definitely a full call.
+;;; :FUNNY if this is an oddball thing with IR2-convert.
+;;; :LOCAL if this is a local call.
+;;;
+;;; Node-Tail-P
+;;; After LTN analysis, this is true only in combination nodes that are
+;;; truly tail recursive.
+
+;;; The IR2-Block structure holds information about a block that is used during
+;;; and after IR2 conversion. It is stored in the Block-Info slot for the
+;;; associated block.
+(defstruct (ir2-block (:include block-annotation)
+ (:constructor make-ir2-block (block)))
+ ;; The IR2-Block's number, which differs from Block's Block-Number if any
+ ;; blocks are split. This is assigned by lifetime analysis.
+ (number nil :type (or index null))
+ ;; Information about unknown-values continuations that is used by stack
+ ;; analysis to do stack simulation. A unknown-values continuation is Pushed
+ ;; if its Dest is in another block. Similarly, a continuation is Popped if
+ ;; its Dest is in this block but has its uses elsewhere. The continuations
+ ;; are in the order that are pushed/popped in the block. Note that the args
+ ;; to a single MV-Combination appear reversed in Popped, since we must
+ ;; effectively pop the last argument first. All pops must come before all
+ ;; pushes (although internal MV uses may be interleaved.) Popped is computed
+ ;; by LTN, and Pushed is computed by stack analysis.
+ (pushed () :type list)
+ (popped () :type list)
+ ;; The result of stack analysis: lists of all the unknown-values
+ ;; continuations on the stack at the block start and end, topmost
+ ;; continuation first.
+ (start-stack () :type list)
+ (end-stack () :type list)
+ ;; The first and last VOP in this block. If there are none, both slots are
+ ;; null.
+ (start-vop nil :type (or vop null))
+ (last-vop nil :type (or vop null))
+ ;; Number of local TNs actually allocated.
+ (local-tn-count 0 :type local-tn-count)
+ ;; A vector that maps local TN numbers to TNs. Some entries may be NIL,
+ ;; indicating that that number is unused. (This allows us to delete local
+ ;; conflict information without compressing the LTN numbers.)
+ ;;
+ ;; If an entry is :More, then this block contains only a single VOP. This
+ ;; VOP has so many more arguments and/or results that they cannot all be
+ ;; assigned distinct LTN numbers. In this case, we assign all the more args
+ ;; one LTN number, and all the more results another LTN number. We can do
+ ;; this, since more operands are referenced simultaneously as far as conflict
+ ;; analysis is concerned. Note that all these :More TNs will be global TNs.
+ (local-tns (make-array local-tn-limit) :type local-tn-vector)
+ ;; Bit-vectors used during lifetime analysis to keep track of references to
+ ;; local TNs. When indexed by the LTN number, the index for a TN is non-zero
+ ;; in Written if it is ever written in the block, and in Live-Out if
+ ;; the first reference is a read.
+ (written (make-array local-tn-limit :element-type 'bit
+ :initial-element 0)
+ :type local-tn-bit-vector)
+ (live-out (make-array local-tn-limit :element-type 'bit)
+ :type local-tn-bit-vector)
+ ;; Similar to the above, but is updated by lifetime flow analysis to have a 1
+ ;; for LTN numbers of TNs live at the end of the block. This takes into
+ ;; account all TNs that aren't :Live.
+ (live-in (make-array local-tn-limit :element-type 'bit
+ :initial-element 0)
+ :type local-tn-bit-vector)
+ ;; A thread running through the global-conflicts structures for this block,
+ ;; sorted by TN number.
+ (global-tns nil :type (or global-conflicts null))
+ ;; The assembler label that points to the beginning of the code for this
+ ;; block. Null when we haven't assigned a label yet.
+ (%label nil)
+ ;; List of Location-Info structures describing all the interesting (to the
+ ;; debugger) locations in this block.
+ (locations nil :type list))
+
+(defprinter (ir2-block)
+ (pushed :test pushed)
+ (popped :test popped)
+ (start-vop :test start-vop)
+ (last-vop :test last-vop)
+ (local-tn-count :test (not (zerop local-tn-count)))
+ (%label :test %label))
+
+;;; The IR2-Continuation structure is used to annotate continuations that are
+;;; used as a function result continuation or that receive MVs.
+(defstruct (ir2-continuation
+ (:constructor make-ir2-continuation (primitive-type)))
+ ;; If this is :Delayed, then this is a single value continuation for which
+ ;; the evaluation of the use is to be postponed until the evaluation of
+ ;; destination. This can be done for ref nodes or predicates whose
+ ;; destination is an IF.
+ ;;
+ ;; If this is :Fixed, then this continuation has a fixed number of values,
+ ;; with the TNs in Locs.
+ ;;
+ ;; If this is :Unknown, then this is an unknown-values continuation, using
+ ;; the passing locations in Locs.
+ ;;
+ ;; If this is :Unused, then this continuation should never actually be used
+ ;; as the destination of a value: it is only used tail-recursively.
+ (kind :fixed :type (member :delayed :fixed :unknown :unused))
+ ;; The primitive-type of the first value of this continuation. This is
+ ;; primarily for internal use during LTN, but it also records the type
+ ;; restriction on delayed references. In multiple-value contexts, this is
+ ;; null to indicate that it is meaningless. This is always (primitive-type
+ ;; (continuation-type cont)), which may be more restrictive than the
+ ;; tn-primitive-type of the value TN. This is becase the value TN must hold
+ ;; any possible type that could be computed (before type checking.)
+ (primitive-type nil :type (or primitive-type null))
+ ;; Locations used to hold the values of the continuation. If the number
+ ;; of values if fixed, then there is one TN per value. If the number of
+ ;; values is unknown, then this is a two-list of TNs holding the start of the
+ ;; values glob and the number of values. Note that since type checking is
+ ;; the responsibility of the values receiver, these TNs primitive type is
+ ;; only based on the proven type information.
+ (locs nil :type list))
+
+(defprinter (ir2-continuation)
+ kind
+ primitive-type
+ locs)
+
+;;; The IR2-Component serves mostly to accumulate non-code information about
+;;; the component being compiled.
+(defstruct ir2-component
+ ;; The counter used to allocate global TN numbers.
+ (global-tn-counter 0 :type index)
+ ;; Normal-TNs is the head of the list of all the normal TNs that need to be
+ ;; packed, linked through the Next slot. We place TNs on this list when we
+ ;; allocate them so that Pack can find them.
+ ;;
+ ;; Restricted-TNs are TNs that must be packed within a finite SC. We pack
+ ;; these TNs first to ensure that the restrictions will be satisfied (if
+ ;; possible).
+ ;;
+ ;; Wired-TNs are TNs that must be packed at a specific location. The SC
+ ;; and Offset are already filled in.
+ ;;
+ ;; Constant-TNs are non-packed TNs that represent constants. :Constant TNs
+ ;; may eventually be converted to :Cached-Constant normal TNs.
+ (normal-tns nil :type (or tn null))
+ (restricted-tns nil :type (or tn null))
+ (wired-tns nil :type (or tn null))
+ (constant-tns nil :type (or tn null))
+ ;; A list of all the :COMPONENT TNs (live throughout the component.) These
+ ;; TNs will also appear in the {NORMAL,RESTRICTED,WIRED} TNs as appropriate
+ ;; to their location.
+ (component-tns () :type list)
+ ;; If this component has a NFP, then this is it.
+ (nfp nil :type (or tn null))
+ ;; A list of the explicitly specified save TNs (kind :SPECIFIED-SAVE). These
+ ;; TNs will also appear in the {NORMAL,RESTRICTED,WIRED} TNs as appropriate
+ ;; to their location.
+ (specified-save-tns () :type list)
+ ;; Values-Receivers is a list of all the blocks whose ir2-block has a
+ ;; non-null value for Popped. This slot is initialized by LTN-Analyze as an
+ ;; input to Stack-Analyze.
+ (values-receivers nil :type list)
+ ;; An adjustable vector that records all the constants in the constant pool.
+ ;; A non-immediate :Constant TN with offset 0 refers to the constant in
+ ;; element 0, etc. Normal constants are represented by the placing the
+ ;; Constant leaf in this vector. A load-time constant is distinguished by
+ ;; being a cons (Kind . What). Kind is a keyword indicating how the constant
+ ;; is computed, and What is some context.
+ ;;
+ ;; These load-time constants are recognized:
+ ;;
+ ;; (:entry . <function>)
+ ;; Is replaced by the code pointer for the specified function. This is
+ ;; how compiled code (including DEFUN) gets its hands on a function.
+ ;; <function> is the XEP lambda for the called function; its Leaf-Info
+ ;; should be an Entry-Info structure.
+ ;;
+ ;; (:label . <label>)
+ ;; Is replaced with the byte offset of that label from the start of the
+ ;; code vector (including the header length.)
+ ;;
+ ;; A null entry in this vector is a placeholder for implementation overhead
+ ;; that is eventually stuffed in somehow.
+ (constants (make-array 10 :fill-pointer 0 :adjustable t) :type vector)
+ ;; Some kind of info about the component's run-time representation. This is
+ ;; filled in by the VM supplied Select-Component-Format function.
+ format
+ ;; A list of the Entry-Info structures describing all of the entries into
+ ;; this component. Filled in by entry analysis.
+ (entries nil :type list)
+ ;; Head of the list of :ALIAS TNs in this component, threaded by TN-NEXT.
+ (alias-tns nil :type (or tn null))
+ ;; Spilled-VOPs is a hashtable translating from "interesting" VOPs to a list
+ ;; of the TNs spilled at that VOP. This is used when computing debug info so
+ ;; that we don't consider the TN's value to be valid when it is in fact
+ ;; somewhere else. Spilled-TNs has T for every "interesting" TN that is ever
+ ;; spilled, providing a representation that is more convenient some places.
+ (spilled-vops (make-hash-table :test 'eq) :type hash-table)
+ (spilled-tns (make-hash-table :test 'eq) :type hash-table)
+ ;; Dynamic vop count info. This is needed by both ir2-convert and
+ ;; setup-dynamic-count-info. (But only if we are generating code to
+ ;; collect dynamic statistics.)
+ #!+sb-dyncount
+ (dyncount-info nil :type (or null dyncount-info)))
+
+;;; The Entry-Info structure condenses all the information that the dumper
+;;; needs to create each XEP's function entry data structure. The Entry-Info
+;;; structures are somtimes created before they are initialized, since ir2
+;;; conversion may need to compile a forward reference. In this case
+;;; the slots aren't actually initialized until entry analysis runs.
+(defstruct entry-info
+ ;; True if this function has a non-null closure environment.
+ (closure-p nil :type boolean)
+ ;; A label pointing to the entry vector for this function. Null until
+ ;; ENTRY-ANALYZE runs.
+ (offset nil :type (or label null))
+ ;; If this function was defined using DEFUN, then this is the name of the
+ ;; function, a symbol or (SETF <symbol>). Otherwise, this is some string
+ ;; that is intended to be informative.
+ (name "<not computed>" :type (or simple-string list symbol))
+ ;; A string representing the argument list that the function was defined
+ ;; with.
+ (arguments nil :type (or simple-string null))
+ ;; A function type specifier representing the arguments and results of this
+ ;; function.
+ (type 'function :type (or list (member function))))
+
+;;; An IR2-ENVIRONMENT is used to annotate non-LET lambdas with their passing
+;;; locations. It is stored in the Environment-Info.
+(defstruct ir2-environment
+ ;; The TNs that hold the passed environment within the function. This is an
+ ;; alist translating from the NLX-Info or lambda-var to the TN that holds
+ ;; the corresponding value within this function. This list is in the same
+ ;; order as the ENVIRONMENT-CLOSURE.
+ (environment nil :type list)
+ ;; The TNs that hold the Old-Fp and Return-PC within the function. We
+ ;; always save these so that the debugger can do a backtrace, even if the
+ ;; function has no return (and thus never uses them). Null only temporarily.
+ (old-fp nil :type (or tn null))
+ (return-pc nil :type (or tn null))
+ ;; The passing location for the Return-PC. The return PC is treated
+ ;; differently from the other arguments, since in some implementations we may
+ ;; use a call instruction that requires the return PC to be passed in a
+ ;; particular place.
+ (return-pc-pass (required-argument) :type tn)
+ ;; True if this function has a frame on the number stack. This is set by
+ ;; representation selection whenever it is possible that some function in
+ ;; our tail set will make use of the number stack.
+ (number-stack-p nil :type boolean)
+ ;; A list of all the :Environment TNs live in this environment.
+ (live-tns nil :type list)
+ ;; A list of all the :Debug-Environment TNs live in this environment.
+ (debug-live-tns nil :type list)
+ ;; A label that marks the start of elsewhere code for this function. Null
+ ;; until this label is assigned by codegen. Used for maintaining the debug
+ ;; source map.
+ (elsewhere-start nil :type (or label null))
+ ;; A label that marks the first location in this function at which the
+ ;; environment is properly initialized, i.e. arguments moved from their
+ ;; passing locations, etc. This is the start of the function as far as the
+ ;; debugger is concerned.
+ (environment-start nil :type (or label null)))
+(defprinter (ir2-environment)
+ environment
+ old-fp
+ return-pc
+ return-pc-pass)
+
+;;; The Return-Info structure is used by GTN to represent the return strategy
+;;; and locations for all the functions in a given Tail-Set. It is stored in
+;;; the Tail-Set-Info.
+(defstruct return-info
+ ;; The return convention used:
+ ;; -- If :Unknown, we use the standard return convention.
+ ;; -- If :Fixed, we use the known-values convention.
+ (kind (required-argument) :type (member :fixed :unknown))
+ ;; The number of values returned, or :Unknown if we don't know. Count may be
+ ;; known when Kind is :Unknown, since we may choose the standard return
+ ;; convention for other reasons.
+ (count (required-argument) :type (or index (member :unknown)))
+ ;; If count isn't :Unknown, then this is a list of the primitive-types of
+ ;; each value.
+ (types () :type list)
+ ;; If kind is :Fixed, then this is the list of the TNs that we return the
+ ;; values in.
+ (locations () :type list))
+(defprinter (return-info)
+ kind
+ count
+ types
+ locations)
+
+(defstruct ir2-nlx-info
+ ;; If the kind is :Entry (a lexical exit), then in the home environment, this
+ ;; holds a Value-Cell object containing the unwind block pointer. In the
+ ;; other cases nobody directly references the unwind-block, so we leave this
+ ;; slot null.
+ (home nil :type (or tn null))
+ ;; The saved control stack pointer.
+ (save-sp (required-argument) :type tn)
+ ;; The list of dynamic state save TNs.
+ (dynamic-state (list* (make-stack-pointer-tn)
+ (make-dynamic-state-tns))
+ :type list)
+ ;; The target label for NLX entry.
+ (target (gen-label) :type label))
+(defprinter (ir2-nlx-info)
+ home
+ save-sp
+ dynamic-state)
+
+;;; FIXME: Delete? (was commented out in CMU CL)
+#|
+;;; The Loop structure holds information about a loop.
+(defstruct (cloop (:conc-name loop-)
+ (:predicate loop-p)
+ (:constructor make-loop)
+ (:copier copy-loop))
+ ;; The kind of loop that this is. These values are legal:
+ ;;
+ ;; :Outer
+ ;; This is the outermost loop structure, and represents all the
+ ;; code in a component.
+ ;;
+ ;; :Natural
+ ;; A normal loop with only one entry.
+ ;;
+ ;; :Strange
+ ;; A segment of a "strange loop" in a non-reducible flow graph.
+ (kind (required-argument) :type (member :outer :natural :strange))
+ ;; The first and last blocks in the loop. There may be more than one tail,
+ ;; since there may be multiple back branches to the same head.
+ (head nil :type (or cblock null))
+ (tail nil :type list)
+ ;; A list of all the blocks in this loop or its inferiors that have a
+ ;; successor outside of the loop.
+ (exits nil :type list)
+ ;; The loop that this loop is nested within. This is null in the outermost
+ ;; loop structure.
+ (superior nil :type (or cloop null))
+ ;; A list of the loops nested directly within this one.
+ (inferiors nil :type list)
+ ;; The head of the list of blocks directly within this loop. We must recurse
+ ;; on Inferiors to find all the blocks.
+ (blocks nil :type (or null cblock)))
+(defprinter (loop)
+ kind
+ head
+ tail
+ exits)
+|#
+\f
+;;;; VOPs and templates
+
+;;; A VOP is a Virtual Operation. It represents an operation and the
+;;; operands to the operation.
+(defstruct (vop (:constructor make-vop (block node info args results)))
+ ;; VOP-Info structure containing static info about the operation.
+ (info nil :type (or vop-info null))
+ ;; The IR2-Block this VOP is in.
+ (block (required-argument) :type ir2-block)
+ ;; VOPs evaluated after and before this one. Null at the
+ ;; beginning/end of the block, and temporarily during IR2
+ ;; translation.
+ (next nil :type (or vop null))
+ (prev nil :type (or vop null))
+ ;; Heads of the TN-Ref lists for operand TNs, linked using the
+ ;; Across slot.
+ (args nil :type (or tn-ref null))
+ (results nil :type (or tn-ref null))
+ ;; Head of the list of write refs for each explicitly allocated
+ ;; temporary, linked together using the Across slot.
+ (temps nil :type (or tn-ref null))
+ ;; Head of the list of all TN-refs for references in this VOP,
+ ;; linked by the Next-Ref slot. There will be one entry for each
+ ;; operand and two (a read and a write) for each temporary.
+ (refs nil :type (or tn-ref null))
+ ;; Stuff that is passed uninterpreted from IR2 conversion to
+ ;; codegen. The meaning of this slot is totally dependent on the VOP.
+ codegen-info
+ ;; Node that generated this VOP, for keeping track of debug info.
+ (node nil :type (or node null))
+ ;; Local-TN bit vector representing the set of TNs live after args
+ ;; are read and before results are written. This is only filled in
+ ;; when VOP-INFO-SAVE-P is non-null.
+ (save-set nil :type (or local-tn-bit-vector null)))
+(defprinter (vop)
+ (info :prin1 (vop-info-name info))
+ args
+ results
+ (codegen-info :test codegen-info))
+
+;;; A TN-REF object contains information about a particular reference
+;;; to a TN. The information in TN-REFs largely determines how TNs are
+;;; packed.
+(defstruct (tn-ref (:constructor make-tn-ref (tn write-p)))
+ ;; the TN referenced
+ (tn (required-argument) :type tn)
+ ;; Is this is a write reference? (as opposed to a read reference)
+ (write-p nil :type boolean)
+ ;; the link for a list running through all TN-Refs for this TN of
+ ;; the same kind (read or write)
+ (next nil :type (or tn-ref null))
+ ;; the VOP where the reference happens, or NIL temporarily
+ (vop nil :type (or vop null))
+ ;; the link for a list of all TN-Refs in VOP, in reverse order of
+ ;; reference
+ (next-ref nil :type (or tn-ref null))
+ ;; the link for a list of the TN-Refs in VOP of the same kind
+ ;; (argument, result, temp)
+ (across nil :type (or tn-ref null))
+ ;; If true, this is a TN-Ref also in VOP whose TN we would like
+ ;; packed in the same location as our TN. Read and write refs are
+ ;; always paired: Target in the read points to the write, and
+ ;; vice-versa.
+ (target nil :type (or null tn-ref))
+ ;; the load TN allocated for this operand, if any
+ (load-tn nil :type (or tn null)))
+(defprinter (tn-ref)
+ tn
+ write-p
+ (vop :test vop :prin1 (vop-info-name (vop-info vop))))
+
+;;; A TEMPLATE object represents a particular IR2 coding strategy for
+;;; a known function.
+(def!struct (template (:constructor nil)
+ #-sb-xc-host (:pure t))
+ ;; The symbol name of this VOP. This is used when printing the VOP
+ ;; and is also used to provide a handle for definition and
+ ;; translation.
+ (name nil :type symbol)
+ ;; A Function-Type describing the arg/result type restrictions. We
+ ;; compute this from the Primitive-Type restrictions to make life
+ ;; easier for IR1 phases that need to anticipate LTN's template
+ ;; selection.
+ (type (required-argument) :type function-type)
+ ;; Lists of restrictions on the argument and result types. A
+ ;; restriction may take several forms:
+ ;; -- The restriction * is no restriction at all.
+ ;; -- A restriction (:OR <primitive-type>*) means that the operand
+ ;; must have one of the specified primitive types.
+ ;; -- A restriction (:CONSTANT <predicate> <type-spec>) means that the
+ ;; argument (not a result) must be a compile-time constant that
+ ;; satisfies the specified predicate function. In this case, the
+ ;; constant value will be passed as an info argument rather than
+ ;; as a normal argument. <type-spec> is a Lisp type specifier for
+ ;; the type tested by the predicate, used when we want to represent
+ ;; the type constraint as a Lisp function type.
+ ;;
+ ;; If Result-Types is :Conditional, then this is an IF-xxx style
+ ;; conditional that yeilds its result as a control transfer. The
+ ;; emit function takes two info arguments: the target label and a
+ ;; boolean flag indicating whether to negate the sense of the test.
+ (arg-types nil :type list)
+ (result-types nil :type (or list (member :conditional)))
+ ;; The primitive type restriction applied to each extra argument or
+ ;; result following the fixed operands. If NIL, no extra
+ ;; args/results are allowed. Otherwise, either * or a (:OR ...) list
+ ;; as described for the {ARG,RESULT}-TYPES.
+ (more-args-type nil :type (or (member nil *) cons))
+ (more-results-type nil :type (or (member nil *) cons))
+ ;; If true, this is a function that is called with no arguments to
+ ;; see whether this template can be emitted. This is used to
+ ;; conditionally compile for different target hardware
+ ;; configuarations (e.g. FP hardware.)
+ (guard nil :type (or function null))
+ ;; The policy under which this template is the best translation.
+ ;; Note that LTN might use this template under other policies if it
+ ;; can't figure our anything better to do.
+ (policy (required-argument) :type policies)
+ ;; The base cost for this template, given optimistic assumptions
+ ;; such as no operand loading, etc.
+ (cost (required-argument) :type index)
+ ;; If true, then a short noun-like phrase describing what this VOP
+ ;; "does", i.e. the implementation strategy. This is for use in
+ ;; efficiency notes.
+ (note nil :type (or string null))
+ ;; The number of trailing arguments to VOP or %PRIMITIVE that we
+ ;; bundle into a list and pass into the emit function. This provides
+ ;; a way to pass uninterpreted stuff directly to the code generator.
+ (info-arg-count 0 :type index)
+ ;; A function that emits the VOPs for this template. Arguments:
+ ;; 1] Node for source context.
+ ;; 2] IR2-Block that we place the VOP in.
+ ;; 3] This structure.
+ ;; 4] Head of argument TN-Ref list.
+ ;; 5] Head of result TN-Ref list.
+ ;; 6] If Info-Arg-Count is non-zero, then a list of the magic
+ ;; arguments.
+ ;;
+ ;; Two values are returned: the first and last VOP emitted. This vop
+ ;; sequence must be linked into the VOP Next/Prev chain for the
+ ;; block. At least one VOP is always emitted.
+ (emit-function (required-argument) :type function))
+(defprinter (template)
+ name
+ arg-types
+ result-types
+ (more-args-type :test more-args-type :prin1 more-args-type)
+ (more-results-type :test more-results-type :prin1 more-results-type)
+ policy
+ cost
+ (note :test note)
+ (info-arg-count :test (not (zerop info-arg-count))))
+
+;;; A VOP-INFO object holds the constant information for a given
+;;; virtual operation. We include TEMPLATE so that functions with a
+;;; direct VOP equivalent can be translated easily.
+(def!struct (vop-info
+ (:include template)
+ (:make-load-form-fun ignore-it))
+ ;; Side-effects of this VOP and side-effects that affect the value
+ ;; of this VOP.
+ (effects (required-argument) :type attributes)
+ (affected (required-argument) :type attributes)
+ ;; If true, causes special casing of TNs live after this VOP that
+ ;; aren't results:
+ ;; -- If T, all such TNs that are allocated in a SC with a defined
+ ;; save-sc will be saved in a TN in the save SC before the VOP
+ ;; and restored after the VOP. This is used by call VOPs. A bit
+ ;; vector representing the live TNs is stored in the VOP-SAVE-SET.
+ ;; -- If :Force-To-Stack, all such TNs will made into :Environment TNs
+ ;; and forced to be allocated in SCs without any save-sc. This is
+ ;; used by NLX entry vops.
+ ;; -- If :Compute-Only, just compute the save set, don't do any saving.
+ ;; This is used to get the live variables for debug info.
+ (save-p nil :type (member t nil :force-to-stack :compute-only))
+ ;; Info for automatic emission of move-arg VOPs by representation
+ ;; selection. If NIL, then do nothing special. If non-null, then
+ ;; there must be a more arg. Each more arg is moved to its passing
+ ;; location using the appropriate representation-specific
+ ;; move-argument VOP. The first (fixed) argument must be the
+ ;; control-stack frame pointer for the frame to move into. The first
+ ;; info arg is the list of passing locations.
+ ;;
+ ;; Additional constraints depend on the value:
+ ;;
+ ;; :FULL-CALL
+ ;; None.
+ ;;
+ ;; :LOCAL-CALL
+ ;; The second (fixed) arg is the NFP for the called function (from
+ ;; ALLOCATE-FRAME.)
+ ;;
+ ;; :KNOWN-RETURN
+ ;; If needed, the old NFP is computed using COMPUTE-OLD-NFP.
+ (move-args nil :type (member nil :full-call :local-call :known-return))
+ ;; A list of sc-vectors representing the loading costs of each fixed
+ ;; argument and result.
+ (arg-costs nil :type list)
+ (result-costs nil :type list)
+ ;; If true, sc-vectors representing the loading costs for any more
+ ;; args and results.
+ (more-arg-costs nil :type (or sc-vector null))
+ (more-result-costs nil :type (or sc-vector null))
+ ;; Lists of sc-vectors mapping each SC to the SCs that we can load
+ ;; into. If a SC is directly acceptable to the VOP, then the entry
+ ;; is T. Otherwise, it is a list of the SC numbers of all the SCs
+ ;; that we can load into. This list will be empty if there is no
+ ;; load function which loads from that SC to an SC allowed by the
+ ;; operand SC restriction.
+ (arg-load-scs nil :type list)
+ (result-load-scs nil :type list)
+ ;; If true, a function that is called with the VOP to do operand
+ ;; targeting. This is done by modifiying the TN-Ref-Target slots in
+ ;; the TN-Refs so that they point to other TN-Refs in the same VOP.
+ (target-function nil :type (or null function))
+ ;; A function that emits assembly code for a use of this VOP when it
+ ;; is called with the VOP structure. Null if this VOP has no
+ ;; specified generator (i.e. it exists only to be inherited by other
+ ;; VOPs.)
+ (generator-function nil :type (or function null))
+ ;; A list of things that are used to parameterize an inherited
+ ;; generator. This allows the same generator function to be used for
+ ;; a group of VOPs with similar implementations.
+ (variant nil :type list)
+ ;; The number of arguments and results. Each regular arg/result
+ ;; counts as one, and all the more args/results together count as 1.
+ (num-args 0 :type index)
+ (num-results 0 :type index)
+ ;; Vector of the temporaries the vop needs. See emit-generic-vop in
+ ;; vmdef for information on how the temps are encoded.
+ ;;
+ ;; (The SB-XC-HOST conditionalization on the type is there because
+ ;; it's difficult to dump specialized arrays portably, so on the
+ ;; cross-compilation host we punt by using unspecialized arrays
+ ;; instead.)
+ (temps nil :type (or null (specializable-vector (unsigned-byte 16))))
+ ;; The order all the refs for this vop should be put in. Each
+ ;; operand is assigned a number in the following ordering: args,
+ ;; more-args, results, more-results, temps This vector represents
+ ;; the order the operands should be put into in the next-ref link.
+ ;;
+ ;; (The SB-XC-HOST conditionalization on the type is there because
+ ;; it's difficult to dump specialized arrays portably, so on the
+ ;; cross-compilation host we punt by using unspecialized arrays
+ ;; instead.)
+ (ref-ordering nil :type (or null (specializable-vector (unsigned-byte 8))))
+ ;; Array of the various targets that should be done. Each element
+ ;; encodes the source ref (shifted 8) and the dest ref index.
+ (targets nil :type (or null (specializable-vector (unsigned-byte 16)))))
+\f
+;;;; SBs and SCs
+
+;;; copied from docs/internals/retargeting.tex by WHN 19990707:
+;;;
+;;; A Storage Base represents a physical storage resource such as a
+;;; register set or stack frame. Storage bases for non-global
+;;; resources such as the stack are relativized by the environment
+;;; that the TN is allocated in. Packing conflict information is kept
+;;; in the storage base, but non-packed storage resources such as
+;;; closure environments also have storage bases.
+;;;
+;;; Some storage bases:
+;;; General purpose registers
+;;; Floating point registers
+;;; Boxed (control) stack environment
+;;; Unboxed (number) stack environment
+;;; Closure environment
+;;;
+;;; A storage class is a potentially arbitrary set of the elements in
+;;; a storage base. Although conceptually there may be a hierarchy of
+;;; storage classes such as "all registers", "boxed registers", "boxed
+;;; scratch registers", this doesn't exist at the implementation
+;;; level. Such things can be done by specifying storage classes whose
+;;; locations overlap. A TN shouldn't have lots of overlapping SC's as
+;;; legal SC's, since time would be wasted repeatedly attempting to
+;;; pack in the same locations.
+;;;
+;;; ...
+;;;
+;;; Some SCs:
+;;; Reg: any register (immediate objects)
+;;; Save-Reg: a boxed register near r15 (registers easily saved in a call)
+;;; Boxed-Reg: any boxed register (any boxed object)
+;;; Unboxed-Reg: any unboxed register (any unboxed object)
+;;; Float-Reg, Double-Float-Reg: float in FP register.
+;;; Stack: boxed object on the stack (on cstack)
+;;; Word: any 32bit unboxed object on nstack.
+;;; Double: any 64bit unboxed object on nstack.
+
+;;; The SB structure represents the global information associated with
+;;; a storage base.
+(def!struct (sb (:make-load-form-fun just-dump-it-normally))
+ ;; Name, for printing and reference.
+ (name nil :type symbol)
+ ;; The kind of storage base (which determines the packing
+ ;; algorithm).
+ (kind :non-packed :type (member :finite :unbounded :non-packed))
+ ;; The number of elements in the SB. If finite, this is the total
+ ;; size. If unbounded, this is the size that the SB is initially
+ ;; allocated at.
+ (size 0 :type index))
+(defprinter (sb)
+ name)
+
+;;; The Finite-SB structure holds information needed by the packing
+;;; algorithm for finite SBs.
+(def!struct (finite-sb (:include sb))
+ ;; The number of locations currently allocated in this SB.
+ (current-size 0 :type index)
+ ;; The last location packed in, used by pack to scatter TNs to
+ ;; prevent a few locations from getting all the TNs, and thus
+ ;; getting overcrowded, reducing the possiblilities for targeting.
+ (last-offset 0 :type index)
+ ;; A vector containing, for each location in this SB, a vector
+ ;; indexed by IR2 block numbers, holding local conflict bit vectors.
+ ;; A TN must not be packed in a given location within a particular
+ ;; block if the LTN number for that TN in that block corresponds to
+ ;; a set bit in the bit-vector.
+ (conflicts '#() :type simple-vector)
+ ;; A vector containing, for each location in this SB, a bit-vector
+ ;; indexed by IR2 block numbers. If the bit corresponding to a block
+ ;; is set, then the location is in use somewhere in the block, and
+ ;; thus has a conflict for always-live TNs.
+ (always-live '#() :type simple-vector)
+ ;; A vector containing the TN currently live in each location in the
+ ;; SB, or NIL if the location is unused. This is used during load-tn pack.
+ (live-tns '#() :type simple-vector)
+ ;; The number of blocks for which the ALWAYS-LIVE and CONFLICTS
+ ;; might not be virgin, and thus must be reinitialized when PACK
+ ;; starts. Less then the length of those vectors when not all of the
+ ;; length was used on the previously packed component.
+ (last-block-count 0 :type index))
+
+;;; the SC structure holds the storage base that storage is allocated
+;;; in and information used to select locations within the SB.
+(defstruct sc
+ ;; Name, for printing and reference.
+ (name nil :type symbol)
+ ;; The number used to index SC cost vectors.
+ (number 0 :type sc-number)
+ ;; The storage base that this SC allocates storage from.
+ (sb nil :type (or sb null))
+ ;; The size of elements in this SC, in units of locations in the SB.
+ (element-size 0 :type index)
+ ;; If our SB is finite, a list of the locations in this SC.
+ (locations nil :type list)
+ ;; A list of the alternate (save) SCs for this SC.
+ (alternate-scs nil :type list)
+ ;; A list of the constant SCs that can me moved into this SC.
+ (constant-scs nil :type list)
+ ;; True if this values in this SC needs to be saved across calls.
+ (save-p nil :type boolean)
+ ;; Vectors mapping from SC numbers to information about how to load
+ ;; from the index SC to this one. Move-Functions holds the names of
+ ;; the functions used to do loading, and Load-Costs holds the cost
+ ;; of the corresponding Move-Functions. If loading is impossible,
+ ;; then the entries are NIL. Load-Costs is initialized to have a 0
+ ;; for this SC.
+ (move-functions (make-array sc-number-limit :initial-element nil)
+ :type sc-vector)
+ (load-costs (make-array sc-number-limit :initial-element nil)
+ :type sc-vector)
+ ;; A vector mapping from SC numbers to possibly
+ ;; representation-specific move and coerce VOPs. Each entry is a
+ ;; list of VOP-INFOs for VOPs that move/coerce an object in the
+ ;; index SC's representation into this SC's representation. This
+ ;; vector is filled out with entries for all SCs that can somehow be
+ ;; coerced into this SC, not just those VOPs defined to directly
+ ;; move into this SC (i.e. it allows for operand loading on the move
+ ;; VOP's operands.)
+ ;;
+ ;; When there are multiple applicable VOPs, the template arg and
+ ;; result type restrictions are used to determine which one to use.
+ ;; The list is sorted by increasing cost, so the first applicable
+ ;; VOP should be used.
+ ;;
+ ;; Move (or move-arg) VOPs with descriptor results shouldn't have
+ ;; TNs wired in the standard argument registers, since there may
+ ;; already be live TNs wired in those locations holding the values
+ ;; that we are setting up for unknown-values return.
+ (move-vops (make-array sc-number-limit :initial-element nil)
+ :type sc-vector)
+ ;; The costs corresponding to the MOVE-VOPS. Separate because this
+ ;; info is needed at meta-compile time, while the MOVE-VOPs don't
+ ;; exist till load time. If no move is defined, then the entry is
+ ;; NIL.
+ (move-costs (make-array sc-number-limit :initial-element nil)
+ :type sc-vector)
+ ;; Similar to Move-VOPs, except that we only ever use the entries
+ ;; for this SC and its alternates, since we never combine complex
+ ;; representation conversion with argument passing.
+ (move-arg-vops (make-array sc-number-limit :initial-element nil)
+ :type sc-vector)
+ ;; True if this SC or one of its alternates in in the NUMBER-STACK SB.
+ (number-stack-p nil :type boolean)
+ ;; Alignment restriction. The offset must be an even multiple of this.
+ (alignment 1 :type (and index (integer 1)))
+ ;; A list of locations that we avoid packing in during normal
+ ;; register allocation to ensure that these locations will be free
+ ;; for operand loading. This prevents load-TN packing from thrashing
+ ;; by spilling a lot.
+ (reserve-locations nil :type list))
+(defprinter (sc)
+ name)
+\f
+;;;; TNs
+
+(defstruct (tn (:include sset-element)
+ (:constructor make-random-tn)
+ (:constructor make-tn (number kind primitive-type sc)))
+ ;; The kind of TN this is:
+ ;;
+ ;; :NORMAL
+ ;; A normal, non-constant TN, representing a variable or temporary.
+ ;; Lifetime information is computed so that packing can be done.
+ ;;
+ ;; :ENVIRONMENT
+ ;; A TN that has hidden references (debugger or NLX), and thus must be
+ ;; allocated for the duration of the environment it is referenced in.
+ ;;
+ ;; :DEBUG-ENVIRONMENT
+ ;; Like :ENVIRONMENT, but is used for TNs that we want to be able to
+ ;; target to/from and that don't absolutely have to be live
+ ;; everywhere. These TNs are live in all blocks in the environment
+ ;; that don't reference this TN.
+ ;;
+ ;; :COMPONENT
+ ;; A TN that implicitly conflicts with all other TNs. No conflict
+ ;; info is computed.
+ ;;
+ ;; :SAVE
+ ;; :SAVE-ONCE
+ ;; A TN used for saving a :Normal TN across function calls. The
+ ;; lifetime information slots are unitialized: get the original
+ ;; TN our of the SAVE-TN slot and use it for conflicts. Save-Once
+ ;; is like :Save, except that it is only save once at the single
+ ;; writer of the original TN.
+ ;;
+ ;; :SPECIFIED-SAVE
+ ;; A TN that was explicitly specified as the save TN for another TN.
+ ;; When we actually get around to doing the saving, this will be
+ ;; changed to :SAVE or :SAVE-ONCE.
+ ;;
+ ;; :LOAD
+ ;; A load-TN used to compute an argument or result that is
+ ;; restricted to some finite SB. Load TNs don't have any conflict
+ ;; information. Load TN pack uses a special local conflict
+ ;; determination method.
+ ;;
+ ;; :CONSTANT
+ ;; Represents a constant, with TN-Leaf a Constant leaf. Lifetime
+ ;; information isn't computed, since the value isn't allocated by
+ ;; pack, but is instead generated as a load at each use. Since
+ ;; lifetime analysis isn't done on :Constant TNs, they don't have
+ ;; Local-Numbers and similar stuff.
+ ;;
+ ;; :ALIAS
+ ;; A special kind of TN used to represent initialization of local
+ ;; call arguments in the caller. It provides another name for the
+ ;; argument TN so that lifetime analysis doesn't get confused by
+ ;; self-recursive calls. Lifetime analysis treats this the same
+ ;; as :NORMAL, but then at the end merges the conflict info into
+ ;; the original TN and replaces all uses of the alias with the
+ ;; original TN. SAVE-TN holds the aliased TN.
+ (kind (required-argument)
+ :type (member :normal :environment :debug-environment
+ :save :save-once :specified-save :load :constant
+ :component :alias))
+ ;; The primitive-type for this TN's value. Null in restricted or
+ ;; wired TNs.
+ (primitive-type nil :type (or primitive-type null))
+ ;; If this TN represents a variable or constant, then this is the
+ ;; corresponding Leaf.
+ (leaf nil :type (or leaf null))
+ ;; Thread that links TNs together so that we can find them.
+ (next nil :type (or tn null))
+ ;; Head of TN-Ref lists for reads and writes of this TN.
+ (reads nil :type (or tn-ref null))
+ (writes nil :type (or tn-ref null))
+ ;; A link we use when building various temporary TN lists.
+ (next* nil :type (or tn null))
+ ;; Some block that contains a reference to this TN, or Nil if we
+ ;; haven't seen any reference yet. If the TN is local, then this is
+ ;; the block it is local to.
+ (local nil :type (or ir2-block null))
+ ;; If a local TN, the block relative number for this TN. Global TNs
+ ;; whose liveness changes within a block are also assigned a local
+ ;; number during the conflicts analysis of that block. If the TN has
+ ;; no local number within the block, then this is Nil.
+ (local-number nil :type (or local-tn-number null))
+ ;; If a local TN, a bit-vector with 1 for the local-number of every
+ ;; TN that we conflict with.
+ (local-conflicts (make-array local-tn-limit :element-type 'bit
+ :initial-element 0)
+ :type local-tn-bit-vector)
+ ;; Head of the list of Global-Conflicts structures for a global TN.
+ ;; This list is sorted by block number (i.e. reverse DFO), allowing
+ ;; the intersection between the lifetimes for two global TNs to be
+ ;; easily found. If null, then this TN is a local TN.
+ (global-conflicts nil :type (or global-conflicts null))
+ ;; During lifetime analysis, this is used as a pointer into the
+ ;; conflicts chain, for scanning through blocks in reverse DFO.
+ (current-conflict nil)
+ ;; In a :SAVE TN, this is the TN saved. In a :NORMAL or :ENVIRONMENT
+ ;; TN, this is the associated save TN. In TNs with no save TN, this
+ ;; is null.
+ (save-tn nil :type (or tn null))
+ ;; After pack, the SC we packed into. Beforehand, the SC we want to
+ ;; pack into, or null if we don't know.
+ (sc nil :type (or sc null))
+ ;; The offset within the SB that this TN is packed into. This is what
+ ;; indicates that the TN is packed.
+ (offset nil :type (or index null))
+ ;; Some kind of info about how important this TN is.
+ (cost 0 :type fixnum)
+ ;; If a :ENVIRONMENT or :DEBUG-ENVIRONMENT TN, this is the environment that
+ ;; the TN is live throughout.
+ (environment nil :type (or environment null)))
+(def!method print-object ((tn tn) stream)
+ (print-unreadable-object (tn stream :type t)
+ ;; KLUDGE: The distinction between PRINT-TN and PRINT-OBJECT on TN is
+ ;; not very mnemonic. -- WHN 20000124
+ (print-tn tn stream)))
+
+;;; The GLOBAL-CONFLICTS structure represents the conflicts for global
+;;; TNs. Each global TN has a list of these structures, one for each
+;;; block that it is live in. In addition to repsenting the result of
+;;; lifetime analysis, the global conflicts structure is used during
+;;; lifetime analysis to represent the set of TNs live at the start of
+;;; the IR2 block.
+(defstruct (global-conflicts
+ (:constructor make-global-conflicts (kind tn block number)))
+ ;; The IR2-Block that this structure represents the conflicts for.
+ (block (required-argument) :type ir2-block)
+ ;; Thread running through all the Global-Conflict for Block. This
+ ;; thread is sorted by TN number.
+ (next nil :type (or global-conflicts null))
+ ;; The way that TN is used by Block:
+ ;;
+ ;; :READ
+ ;; The TN is read before it is written. It starts the block live,
+ ;; but is written within the block.
+ ;;
+ ;; :WRITE
+ ;; The TN is written before any read. It starts the block dead,
+ ;; and need not have a read within the block.
+ ;;
+ ;; :READ-ONLY
+ ;; The TN is read, but never written. It starts the block live,
+ ;; and is not killed by the block. Lifetime analysis will promote
+ ;; :Read-Only TNs to :Live if they are live at the block end.
+ ;;
+ ;; :LIVE
+ ;; The TN is not referenced. It is live everywhere in the block.
+ (kind :read-only :type (member :read :write :read-only :live))
+ ;; A local conflicts vector representing conflicts with TNs live in
+ ;; Block. The index for the local TN number of each TN we conflict
+ ;; with in this block is 1. To find the full conflict set, the :Live
+ ;; TNs for Block must also be included. This slot is not meaningful
+ ;; when Kind is :Live.
+ (conflicts (make-array local-tn-limit
+ :element-type 'bit
+ :initial-element 0)
+ :type local-tn-bit-vector)
+ ;; The TN we are recording conflicts for.
+ (tn (required-argument) :type tn)
+ ;; Thread through all the Global-Conflicts for TN.
+ (tn-next nil :type (or global-conflicts null))
+ ;; TN's local TN number in Block. :Live TNs don't have local numbers.
+ (number nil :type (or local-tn-number null)))
+(defprinter (global-conflicts)
+ tn
+ block
+ kind
+ (number :test number))
--- /dev/null
+;;;; allocation VOPs for the x86
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!VM")
+
+(file-comment
+ "$Header$")
+\f
+;;;; LIST and LIST*
+
+(define-vop (list-or-list*)
+ (:args (things :more t))
+ (:temporary (:sc unsigned-reg) ptr temp)
+ (:temporary (:sc unsigned-reg :to (:result 0) :target result) res)
+ (:info num)
+ (:results (result :scs (descriptor-reg)))
+ (:variant-vars star)
+ (:policy :safe)
+ (:node-var node)
+ (:generator 0
+ (cond ((zerop num)
+ ;; (move result *nil-value*)
+ (inst mov result *nil-value*))
+ ((and star (= num 1))
+ (move result (tn-ref-tn things)))
+ (t
+ (macrolet
+ ((store-car (tn list &optional (slot sb!vm:cons-car-slot))
+ `(let ((reg
+ (sc-case ,tn
+ ((any-reg descriptor-reg) ,tn)
+ ((control-stack)
+ (move temp ,tn)
+ temp))))
+ (storew reg ,list ,slot sb!vm:list-pointer-type))))
+ (let ((cons-cells (if star (1- num) num)))
+ (pseudo-atomic
+ (allocation res (* (pad-data-block cons-size) cons-cells) node)
+ (inst lea res
+ (make-ea :byte :base res :disp list-pointer-type))
+ (move ptr res)
+ (dotimes (i (1- cons-cells))
+ (store-car (tn-ref-tn things) ptr)
+ (setf things (tn-ref-across things))
+ (inst add ptr (pad-data-block cons-size))
+ (storew ptr ptr (- cons-cdr-slot cons-size)
+ list-pointer-type))
+ (store-car (tn-ref-tn things) ptr)
+ (cond (star
+ (setf things (tn-ref-across things))
+ (store-car (tn-ref-tn things) ptr cons-cdr-slot))
+ (t
+ (storew *nil-value* ptr cons-cdr-slot
+ list-pointer-type)))
+ (assert (null (tn-ref-across things)))))
+ (move result res))))))
+
+(define-vop (list list-or-list*)
+ (:variant nil))
+
+(define-vop (list* list-or-list*)
+ (:variant t))
+\f
+;;;; special-purpose inline allocators
+
+(define-vop (allocate-code-object)
+ (:args (boxed-arg :scs (any-reg) :target boxed)
+ (unboxed-arg :scs (any-reg) :target unboxed))
+ (:results (result :scs (descriptor-reg)))
+ (:temporary (:sc unsigned-reg :from :eval) temp)
+ (:temporary (:sc unsigned-reg :from (:argument 0)) boxed)
+ (:temporary (:sc unsigned-reg :from (:argument 1)) unboxed)
+ (:generator 100
+ (move boxed boxed-arg)
+ (inst add boxed (fixnumize (1+ code-trace-table-offset-slot)))
+ (inst and boxed (lognot lowtag-mask))
+ (move unboxed unboxed-arg)
+ (inst shr unboxed word-shift)
+ (inst add unboxed lowtag-mask)
+ (inst and unboxed (lognot lowtag-mask))
+ (pseudo-atomic
+ ;; comment from CMU CL code:
+ ;; now loading code into static space cause it can't move
+ ;;
+ ;; KLUDGE: What? What's all the cruft about saving fixups for then?
+ ;; I think what's happened is that ALLOCATE-CODE-OBJECT is the basic
+ ;; CMU CL primitive; this ALLOCATE-CODE-OBJECT was hacked for
+ ;; static space only in a simple-minded port to the X86; and then
+ ;; in an attempt to improve the port to the X86,
+ ;; ALLOCATE-DYNAMIC-CODE-OBJECT was defined. If that's right, I'd like
+ ;; to know why not just go back to the basic CMU CL behavior of
+ ;; ALLOCATE-CODE-OBJECT, where it makes a relocatable code object.
+ ;; -- WHN 19990916
+ ;;
+ ;; FIXME: should have a check for overflow of static space
+ (load-symbol-value temp sb!impl::*static-space-free-pointer*)
+ (inst lea result (make-ea :byte :base temp :disp other-pointer-type))
+ (inst add temp boxed)
+ (inst add temp unboxed)
+ (store-symbol-value temp sb!impl::*static-space-free-pointer*)
+ (inst shl boxed (- type-bits word-shift))
+ (inst or boxed code-header-type)
+ (storew boxed result 0 other-pointer-type)
+ (storew unboxed result code-code-size-slot other-pointer-type)
+ (inst mov temp *nil-value*)
+ (storew temp result code-entry-points-slot other-pointer-type))
+ (storew temp result code-debug-info-slot other-pointer-type)))
+
+(define-vop (allocate-dynamic-code-object)
+ (:args (boxed-arg :scs (any-reg) :target boxed)
+ (unboxed-arg :scs (any-reg) :target unboxed))
+ (:results (result :scs (descriptor-reg) :from :eval))
+ (:temporary (:sc unsigned-reg :from (:argument 0)) boxed)
+ (:temporary (:sc unsigned-reg :from (:argument 1)) unboxed)
+ (:node-var node)
+ (:generator 100
+ (move boxed boxed-arg)
+ (inst add boxed (fixnumize (1+ code-trace-table-offset-slot)))
+ (inst and boxed (lognot lowtag-mask))
+ (move unboxed unboxed-arg)
+ (inst shr unboxed word-shift)
+ (inst add unboxed lowtag-mask)
+ (inst and unboxed (lognot lowtag-mask))
+ (inst mov result boxed)
+ (inst add result unboxed)
+ (pseudo-atomic
+ (allocation result result node)
+ (inst lea result (make-ea :byte :base result :disp other-pointer-type))
+ (inst shl boxed (- type-bits word-shift))
+ (inst or boxed code-header-type)
+ (storew boxed result 0 other-pointer-type)
+ (storew unboxed result code-code-size-slot other-pointer-type)
+ (storew *nil-value* result code-entry-points-slot other-pointer-type))
+ (storew *nil-value* result code-debug-info-slot other-pointer-type)))
+\f
+(define-vop (make-fdefn)
+ (:policy :fast-safe)
+ (:translate make-fdefn)
+ (:args (name :scs (descriptor-reg) :to :eval))
+ (:results (result :scs (descriptor-reg) :from :argument))
+ (:node-var node)
+ (:generator 37
+ (with-fixed-allocation (result fdefn-type fdefn-size node)
+ (storew name result fdefn-name-slot other-pointer-type)
+ (storew *nil-value* result fdefn-function-slot other-pointer-type)
+ (storew (make-fixup (extern-alien-name "undefined_tramp") :foreign)
+ result fdefn-raw-addr-slot other-pointer-type))))
+
+(define-vop (make-closure)
+ (:args (function :to :save :scs (descriptor-reg)))
+ (:info length)
+ (:temporary (:sc any-reg) temp)
+ (:results (result :scs (descriptor-reg)))
+ (:node-var node)
+ (:generator 10
+ (pseudo-atomic
+ (let ((size (+ length closure-info-offset)))
+ (allocation result (pad-data-block size) node)
+ (inst lea result
+ (make-ea :byte :base result :disp function-pointer-type))
+ (storew (logior (ash (1- size) type-bits) closure-header-type)
+ result 0 function-pointer-type))
+ (loadw temp function closure-function-slot function-pointer-type)
+ (storew temp result closure-function-slot function-pointer-type))))
+
+;;; The compiler likes to be able to directly make value cells.
+(define-vop (make-value-cell)
+ (:args (value :scs (descriptor-reg any-reg) :to :result))
+ (:results (result :scs (descriptor-reg) :from :eval))
+ (:node-var node)
+ (:generator 10
+ (with-fixed-allocation
+ (result value-cell-header-type value-cell-size node))
+ (storew value result value-cell-value-slot other-pointer-type)))
+\f
+;;;; automatic allocators for primitive objects
+
+(define-vop (make-unbound-marker)
+ (:args)
+ (:results (result :scs (any-reg)))
+ (:generator 1
+ (inst mov result unbound-marker-type)))
+
+(define-vop (fixed-alloc)
+ (:args)
+ (:info name words type lowtag)
+ (:ignore name)
+ (:results (result :scs (descriptor-reg)))
+ (:node-var node)
+ (:generator 50
+ (pseudo-atomic
+ (allocation result (pad-data-block words) node)
+ (inst lea result (make-ea :byte :base result :disp lowtag))
+ (when type
+ (storew (logior (ash (1- words) type-bits) type) result 0 lowtag)))))
+
+(define-vop (var-alloc)
+ (:args (extra :scs (any-reg)))
+ (:arg-types positive-fixnum)
+ (:info name words type lowtag)
+ (:ignore name)
+ (:results (result :scs (descriptor-reg) :from (:eval 1)))
+ (:temporary (:sc any-reg :from :eval :to (:eval 1)) bytes)
+ (:temporary (:sc any-reg :from :eval :to :result) header)
+ (:node-var node)
+ (:generator 50
+ (inst lea bytes
+ (make-ea :dword :base extra :disp (* (1+ words) word-bytes)))
+ (inst mov header bytes)
+ (inst shl header (- type-bits 2)) ; w+1 to length field
+
+ (inst lea header ; (w-1 << 8) | type
+ (make-ea :dword :base header :disp (+ (ash -2 type-bits) type)))
+ (inst and bytes (lognot lowtag-mask))
+ (pseudo-atomic
+ (allocation result bytes node)
+ (inst lea result (make-ea :byte :base result :disp lowtag))
+ (storew header result 0 lowtag))))
+
+(define-vop (make-symbol)
+ (:policy :fast-safe)
+ (:translate make-symbol)
+ (:args (name :scs (descriptor-reg) :to :eval))
+ (:temporary (:sc unsigned-reg :from :eval) temp)
+ (:results (result :scs (descriptor-reg) :from :argument))
+ (:node-var node)
+ (:generator 37
+ (with-fixed-allocation (result symbol-header-type symbol-size node)
+ (storew name result symbol-name-slot other-pointer-type)
+ (storew unbound-marker-type result symbol-value-slot other-pointer-type)
+ ;; Set up a random hash value for the symbol. Perhaps the object
+ ;; address could be used for even faster and smaller code!
+ ;; FIXME: We don't mind the symbol hash not being repeatable, so
+ ;; we might as well add in the object address here, too. (Adding entropy
+ ;; is good, even if ANSI doesn't understand that.)
+ (inst imul temp
+ (make-fixup (extern-alien-name "fast_random_state") :foreign)
+ 1103515245)
+ (inst add temp 12345)
+ (inst mov (make-fixup (extern-alien-name "fast_random_state") :foreign)
+ temp)
+ ;; We want a positive fixnum for the hash value, so discard the LS bits.
+ (inst shr temp 1)
+ (inst and temp #xfffffffc)
+ (storew temp result symbol-hash-slot other-pointer-type)
+ (storew *nil-value* result symbol-plist-slot other-pointer-type)
+ (storew *nil-value* result symbol-package-slot other-pointer-type))))
--- /dev/null
+;;;; the VM definition arithmetic VOPs for the x86
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!VM")
+
+(file-comment
+ "$Header$")
+\f
+;;;; unary operations
+
+(define-vop (fast-safe-arith-op)
+ (:policy :fast-safe)
+ (:effects)
+ (:affected))
+
+(define-vop (fixnum-unop fast-safe-arith-op)
+ (:args (x :scs (any-reg) :target res))
+ (:results (res :scs (any-reg)))
+ (:note "inline fixnum arithmetic")
+ (:arg-types tagged-num)
+ (:result-types tagged-num))
+
+(define-vop (signed-unop fast-safe-arith-op)
+ (:args (x :scs (signed-reg) :target res))
+ (:results (res :scs (signed-reg)))
+ (:note "inline (signed-byte 32) arithmetic")
+ (:arg-types signed-num)
+ (:result-types signed-num))
+
+(define-vop (fast-negate/fixnum fixnum-unop)
+ (:translate %negate)
+ (:generator 1
+ (move res x)
+ (inst neg res)))
+
+(define-vop (fast-negate/signed signed-unop)
+ (:translate %negate)
+ (:generator 2
+ (move res x)
+ (inst neg res)))
+
+(define-vop (fast-lognot/fixnum fixnum-unop)
+ (:translate lognot)
+ (:generator 2
+ (move res x)
+ (inst xor res (fixnumize -1))))
+
+(define-vop (fast-lognot/signed signed-unop)
+ (:translate lognot)
+ (:generator 1
+ (move res x)
+ (inst not res)))
+\f
+;;;; binary fixnum operations
+
+;;; Assume that any constant operand is the second arg...
+
+(define-vop (fast-fixnum-binop fast-safe-arith-op)
+ (:args (x :target r :scs (any-reg)
+ :load-if (not (and (sc-is x control-stack)
+ (sc-is y any-reg)
+ (sc-is r control-stack)
+ (location= x r))))
+ (y :scs (any-reg control-stack)))
+ (:arg-types tagged-num tagged-num)
+ (:results (r :scs (any-reg) :from (:argument 0)
+ :load-if (not (and (sc-is x control-stack)
+ (sc-is y any-reg)
+ (sc-is r control-stack)
+ (location= x r)))))
+ (:result-types tagged-num)
+ (:note "inline fixnum arithmetic"))
+
+(define-vop (fast-unsigned-binop fast-safe-arith-op)
+ (:args (x :target r :scs (unsigned-reg)
+ :load-if (not (and (sc-is x unsigned-stack)
+ (sc-is y unsigned-reg)
+ (sc-is r unsigned-stack)
+ (location= x r))))
+ (y :scs (unsigned-reg unsigned-stack)))
+ (:arg-types unsigned-num unsigned-num)
+ (:results (r :scs (unsigned-reg) :from (:argument 0)
+ :load-if (not (and (sc-is x unsigned-stack)
+ (sc-is y unsigned-reg)
+ (sc-is r unsigned-stack)
+ (location= x r)))))
+ (:result-types unsigned-num)
+ (:note "inline (unsigned-byte 32) arithmetic"))
+
+(define-vop (fast-signed-binop fast-safe-arith-op)
+ (:args (x :target r :scs (signed-reg)
+ :load-if (not (and (sc-is x signed-stack)
+ (sc-is y signed-reg)
+ (sc-is r signed-stack)
+ (location= x r))))
+ (y :scs (signed-reg signed-stack)))
+ (:arg-types signed-num signed-num)
+ (:results (r :scs (signed-reg) :from (:argument 0)
+ :load-if (not (and (sc-is x signed-stack)
+ (sc-is y signed-reg)
+ (sc-is r signed-stack)
+ (location= x r)))))
+ (:result-types signed-num)
+ (:note "inline (signed-byte 32) arithmetic"))
+
+(define-vop (fast-fixnum-binop-c fast-safe-arith-op)
+ (:args (x :target r :scs (any-reg control-stack)))
+ (:info y)
+ (:arg-types tagged-num (:constant (signed-byte 30)))
+ (:results (r :scs (any-reg)
+ :load-if (not (location= x r))))
+ (:result-types tagged-num)
+ (:note "inline fixnum arithmetic"))
+
+(define-vop (fast-unsigned-binop-c fast-safe-arith-op)
+ (:args (x :target r :scs (unsigned-reg unsigned-stack)))
+ (:info y)
+ (:arg-types unsigned-num (:constant (unsigned-byte 32)))
+ (:results (r :scs (unsigned-reg)
+ :load-if (not (location= x r))))
+ (:result-types unsigned-num)
+ (:note "inline (unsigned-byte 32) arithmetic"))
+
+(define-vop (fast-signed-binop-c fast-safe-arith-op)
+ (:args (x :target r :scs (signed-reg signed-stack)))
+ (:info y)
+ (:arg-types signed-num (:constant (signed-byte 32)))
+ (:results (r :scs (signed-reg)
+ :load-if (not (location= x r))))
+ (:result-types signed-num)
+ (:note "inline (signed-byte 32) arithmetic"))
+
+(macrolet ((define-binop (translate untagged-penalty op)
+ `(progn
+ (define-vop (,(symbolicate "FAST-" translate "/FIXNUM=>FIXNUM")
+ fast-fixnum-binop)
+ (:translate ,translate)
+ (:generator 2
+ (move r x)
+ (inst ,op r y)))
+ (define-vop (,(symbolicate 'fast- translate '-c/fixnum=>fixnum)
+ fast-fixnum-binop-c)
+ (:translate ,translate)
+ (:generator 1
+ (move r x)
+ (inst ,op r (fixnumize y))))
+ (define-vop (,(symbolicate "FAST-" translate "/SIGNED=>SIGNED")
+ fast-signed-binop)
+ (:translate ,translate)
+ (:generator ,(1+ untagged-penalty)
+ (move r x)
+ (inst ,op r y)))
+ (define-vop (,(symbolicate 'fast- translate '-c/signed=>signed)
+ fast-signed-binop-c)
+ (:translate ,translate)
+ (:generator ,untagged-penalty
+ (move r x)
+ (inst ,op r y)))
+ (define-vop (,(symbolicate "FAST-"
+ translate
+ "/UNSIGNED=>UNSIGNED")
+ fast-unsigned-binop)
+ (:translate ,translate)
+ (:generator ,(1+ untagged-penalty)
+ (move r x)
+ (inst ,op r y)))
+ (define-vop (,(symbolicate 'fast-
+ translate
+ '-c/unsigned=>unsigned)
+ fast-unsigned-binop-c)
+ (:translate ,translate)
+ (:generator ,untagged-penalty
+ (move r x)
+ (inst ,op r y))))))
+
+ ;;(define-binop + 4 add)
+ (define-binop - 4 sub)
+ (define-binop logand 2 and)
+ (define-binop logior 2 or)
+ (define-binop logxor 2 xor))
+
+
+;;; Special handling of add on the x86; can use lea to avoid a
+;;; register load, otherwise it uses add.
+(define-vop (fast-+/fixnum=>fixnum fast-safe-arith-op)
+ (:translate +)
+ (:args (x :scs (any-reg) :target r
+ :load-if (not (and (sc-is x control-stack)
+ (sc-is y any-reg)
+ (sc-is r control-stack)
+ (location= x r))))
+ (y :scs (any-reg control-stack)))
+ (:arg-types tagged-num tagged-num)
+ (:results (r :scs (any-reg) :from (:argument 0)
+ :load-if (not (and (sc-is x control-stack)
+ (sc-is y any-reg)
+ (sc-is r control-stack)
+ (location= x r)))))
+ (:result-types tagged-num)
+ (:note "inline fixnum arithmetic")
+ (:generator 2
+ (cond ((and (sc-is x any-reg) (sc-is y any-reg) (sc-is r any-reg)
+ (not (location= x r)))
+ (inst lea r (make-ea :dword :base x :index y :scale 1)))
+ (t
+ (move r x)
+ (inst add r y)))))
+
+(define-vop (fast-+-c/fixnum=>fixnum fast-safe-arith-op)
+ (:translate +)
+ (:args (x :target r :scs (any-reg control-stack)))
+ (:info y)
+ (:arg-types tagged-num (:constant (signed-byte 30)))
+ (:results (r :scs (any-reg)
+ :load-if (not (location= x r))))
+ (:result-types tagged-num)
+ (:note "inline fixnum arithmetic")
+ (:generator 1
+ (cond ((and (sc-is x any-reg) (sc-is r any-reg) (not (location= x r)))
+ (inst lea r (make-ea :dword :base x :disp (fixnumize y))))
+ (t
+ (move r x)
+ (inst add r (fixnumize y))))))
+
+(define-vop (fast-+/signed=>signed fast-safe-arith-op)
+ (:translate +)
+ (:args (x :scs (signed-reg) :target r
+ :load-if (not (and (sc-is x signed-stack)
+ (sc-is y signed-reg)
+ (sc-is r signed-stack)
+ (location= x r))))
+ (y :scs (signed-reg signed-stack)))
+ (:arg-types signed-num signed-num)
+ (:results (r :scs (signed-reg) :from (:argument 0)
+ :load-if (not (and (sc-is x signed-stack)
+ (sc-is y signed-reg)
+ (location= x r)))))
+ (:result-types signed-num)
+ (:note "inline (signed-byte 32) arithmetic")
+ (:generator 5
+ (cond ((and (sc-is x signed-reg) (sc-is y signed-reg) (sc-is r signed-reg)
+ (not (location= x r)))
+ (inst lea r (make-ea :dword :base x :index y :scale 1)))
+ (t
+ (move r x)
+ (inst add r y)))))
+
+(define-vop (fast-+-c/signed=>signed fast-safe-arith-op)
+ (:translate +)
+ (:args (x :target r :scs (signed-reg signed-stack)))
+ (:info y)
+ (:arg-types signed-num (:constant (signed-byte 32)))
+ (:results (r :scs (signed-reg)
+ :load-if (not (location= x r))))
+ (:result-types signed-num)
+ (:note "inline (signed-byte 32) arithmetic")
+ (:generator 4
+ (cond ((and (sc-is x signed-reg) (sc-is r signed-reg)
+ (not (location= x r)))
+ (inst lea r (make-ea :dword :base x :disp y)))
+ (t
+ (move r x)
+ (if (= y 1)
+ (inst inc r)
+ (inst add r y))))))
+
+(define-vop (fast-+/unsigned=>unsigned fast-safe-arith-op)
+ (:translate +)
+ (:args (x :scs (unsigned-reg) :target r
+ :load-if (not (and (sc-is x unsigned-stack)
+ (sc-is y unsigned-reg)
+ (sc-is r unsigned-stack)
+ (location= x r))))
+ (y :scs (unsigned-reg unsigned-stack)))
+ (:arg-types unsigned-num unsigned-num)
+ (:results (r :scs (unsigned-reg) :from (:argument 0)
+ :load-if (not (and (sc-is x unsigned-stack)
+ (sc-is y unsigned-reg)
+ (sc-is r unsigned-stack)
+ (location= x r)))))
+ (:result-types unsigned-num)
+ (:note "inline (unsigned-byte 32) arithmetic")
+ (:generator 5
+ (cond ((and (sc-is x unsigned-reg) (sc-is y unsigned-reg)
+ (sc-is r unsigned-reg) (not (location= x r)))
+ (inst lea r (make-ea :dword :base x :index y :scale 1)))
+ (t
+ (move r x)
+ (inst add r y)))))
+
+(define-vop (fast-+-c/unsigned=>unsigned fast-safe-arith-op)
+ (:translate +)
+ (:args (x :target r :scs (unsigned-reg unsigned-stack)))
+ (:info y)
+ (:arg-types unsigned-num (:constant (unsigned-byte 32)))
+ (:results (r :scs (unsigned-reg)
+ :load-if (not (location= x r))))
+ (:result-types unsigned-num)
+ (:note "inline (unsigned-byte 32) arithmetic")
+ (:generator 4
+ (cond ((and (sc-is x unsigned-reg) (sc-is r unsigned-reg)
+ (not (location= x r)))
+ (inst lea r (make-ea :dword :base x :disp y)))
+ (t
+ (move r x)
+ (if (= y 1)
+ (inst inc r)
+ (inst add r y))))))
+\f
+;;;; multiplication and division
+
+(define-vop (fast-*/fixnum=>fixnum fast-safe-arith-op)
+ (:translate *)
+ ;; We need different loading characteristics.
+ (:args (x :scs (any-reg) :target r)
+ (y :scs (any-reg control-stack)))
+ (:arg-types tagged-num tagged-num)
+ (:results (r :scs (any-reg) :from (:argument 0)))
+ (:result-types tagged-num)
+ (:note "inline fixnum arithmetic")
+ (:generator 4
+ (move r x)
+ (inst sar r 2)
+ (inst imul r y)))
+
+(define-vop (fast-*-c/fixnum=>fixnum fast-safe-arith-op)
+ (:translate *)
+ ;; We need different loading characteristics.
+ (:args (x :scs (any-reg control-stack)))
+ (:info y)
+ (:arg-types tagged-num (:constant (signed-byte 30)))
+ (:results (r :scs (any-reg)))
+ (:result-types tagged-num)
+ (:note "inline fixnum arithmetic")
+ (:generator 3
+ (inst imul r x y)))
+
+(define-vop (fast-*/signed=>signed fast-safe-arith-op)
+ (:translate *)
+ ;; We need different loading characteristics.
+ (:args (x :scs (signed-reg) :target r)
+ (y :scs (signed-reg signed-stack)))
+ (:arg-types signed-num signed-num)
+ (:results (r :scs (signed-reg) :from (:argument 0)))
+ (:result-types signed-num)
+ (:note "inline (signed-byte 32) arithmetic")
+ (:generator 5
+ (move r x)
+ (inst imul r y)))
+
+(define-vop (fast-*-c/signed=>signed fast-safe-arith-op)
+ (:translate *)
+ ;; We need different loading characteristics.
+ (:args (x :scs (signed-reg signed-stack)))
+ (:info y)
+ (:arg-types signed-num (:constant (signed-byte 32)))
+ (:results (r :scs (signed-reg)))
+ (:result-types signed-num)
+ (:note "inline (signed-byte 32) arithmetic")
+ (:generator 4
+ (inst imul r x y)))
+
+(define-vop (fast-*/unsigned=>unsigned fast-safe-arith-op)
+ (:translate *)
+ (:args (x :scs (unsigned-reg) :target eax)
+ (y :scs (unsigned-reg unsigned-stack)))
+ (:arg-types unsigned-num unsigned-num)
+ (:temporary (:sc unsigned-reg :offset eax-offset :target result
+ :from (:argument 0) :to :result) eax)
+ (:temporary (:sc unsigned-reg :offset edx-offset
+ :from :eval :to :result) edx)
+ (:ignore edx)
+ (:results (result :scs (unsigned-reg)))
+ (:result-types unsigned-num)
+ (:note "inline (unsigned-byte 32) arithmetic")
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:generator 6
+ (move eax x)
+ (inst mul eax y)
+ (move result eax)))
+
+
+(define-vop (fast-truncate/fixnum=>fixnum fast-safe-arith-op)
+ (:translate truncate)
+ (:args (x :scs (any-reg) :target eax)
+ (y :scs (any-reg control-stack)))
+ (:arg-types tagged-num tagged-num)
+ (:temporary (:sc signed-reg :offset eax-offset :target quo
+ :from (:argument 0) :to (:result 0)) eax)
+ (:temporary (:sc unsigned-reg :offset edx-offset :target rem
+ :from (:argument 0) :to (:result 1)) edx)
+ (:results (quo :scs (any-reg))
+ (rem :scs (any-reg)))
+ (:result-types tagged-num tagged-num)
+ (:note "inline fixnum arithmetic")
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:generator 31
+ (let ((zero (generate-error-code vop division-by-zero-error x y)))
+ (if (sc-is y any-reg)
+ (inst test y y) ; smaller instruction
+ (inst cmp y 0))
+ (inst jmp :eq zero))
+ (move eax x)
+ (inst cdq)
+ (inst idiv eax y)
+ (if (location= quo eax)
+ (inst shl eax 2)
+ (inst lea quo (make-ea :dword :index eax :scale 4)))
+ (move rem edx)))
+
+(define-vop (fast-truncate-c/fixnum=>fixnum fast-safe-arith-op)
+ (:translate truncate)
+ (:args (x :scs (any-reg) :target eax))
+ (:info y)
+ (:arg-types tagged-num (:constant (signed-byte 30)))
+ (:temporary (:sc signed-reg :offset eax-offset :target quo
+ :from :argument :to (:result 0)) eax)
+ (:temporary (:sc any-reg :offset edx-offset :target rem
+ :from :eval :to (:result 1)) edx)
+ (:temporary (:sc any-reg :from :eval :to :result) y-arg)
+ (:results (quo :scs (any-reg))
+ (rem :scs (any-reg)))
+ (:result-types tagged-num tagged-num)
+ (:note "inline fixnum arithmetic")
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:generator 30
+ (move eax x)
+ (inst cdq)
+ (inst mov y-arg (fixnumize y))
+ (inst idiv eax y-arg)
+ (if (location= quo eax)
+ (inst shl eax 2)
+ (inst lea quo (make-ea :dword :index eax :scale 4)))
+ (move rem edx)))
+
+(define-vop (fast-truncate/unsigned=>unsigned fast-safe-arith-op)
+ (:translate truncate)
+ (:args (x :scs (unsigned-reg) :target eax)
+ (y :scs (unsigned-reg signed-stack)))
+ (:arg-types unsigned-num unsigned-num)
+ (:temporary (:sc unsigned-reg :offset eax-offset :target quo
+ :from (:argument 0) :to (:result 0)) eax)
+ (:temporary (:sc unsigned-reg :offset edx-offset :target rem
+ :from (:argument 0) :to (:result 1)) edx)
+ (:results (quo :scs (unsigned-reg))
+ (rem :scs (unsigned-reg)))
+ (:result-types unsigned-num unsigned-num)
+ (:note "inline (unsigned-byte 32) arithmetic")
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:generator 33
+ (let ((zero (generate-error-code vop division-by-zero-error x y)))
+ (if (sc-is y unsigned-reg)
+ (inst test y y) ; smaller instruction
+ (inst cmp y 0))
+ (inst jmp :eq zero))
+ (move eax x)
+ (inst xor edx edx)
+ (inst div eax y)
+ (move quo eax)
+ (move rem edx)))
+
+(define-vop (fast-truncate-c/unsigned=>unsigned fast-safe-arith-op)
+ (:translate truncate)
+ (:args (x :scs (unsigned-reg) :target eax))
+ (:info y)
+ (:arg-types unsigned-num (:constant (unsigned-byte 32)))
+ (:temporary (:sc unsigned-reg :offset eax-offset :target quo
+ :from :argument :to (:result 0)) eax)
+ (:temporary (:sc unsigned-reg :offset edx-offset :target rem
+ :from :eval :to (:result 1)) edx)
+ (:temporary (:sc unsigned-reg :from :eval :to :result) y-arg)
+ (:results (quo :scs (unsigned-reg))
+ (rem :scs (unsigned-reg)))
+ (:result-types unsigned-num unsigned-num)
+ (:note "inline (unsigned-byte 32) arithmetic")
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:generator 32
+ (move eax x)
+ (inst xor edx edx)
+ (inst mov y-arg y)
+ (inst div eax y-arg)
+ (move quo eax)
+ (move rem edx)))
+
+(define-vop (fast-truncate/signed=>signed fast-safe-arith-op)
+ (:translate truncate)
+ (:args (x :scs (signed-reg) :target eax)
+ (y :scs (signed-reg signed-stack)))
+ (:arg-types signed-num signed-num)
+ (:temporary (:sc signed-reg :offset eax-offset :target quo
+ :from (:argument 0) :to (:result 0)) eax)
+ (:temporary (:sc signed-reg :offset edx-offset :target rem
+ :from (:argument 0) :to (:result 1)) edx)
+ (:results (quo :scs (signed-reg))
+ (rem :scs (signed-reg)))
+ (:result-types signed-num signed-num)
+ (:note "inline (signed-byte 32) arithmetic")
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:generator 33
+ (let ((zero (generate-error-code vop division-by-zero-error x y)))
+ (if (sc-is y signed-reg)
+ (inst test y y) ; smaller instruction
+ (inst cmp y 0))
+ (inst jmp :eq zero))
+ (move eax x)
+ (inst cdq)
+ (inst idiv eax y)
+ (move quo eax)
+ (move rem edx)))
+
+(define-vop (fast-truncate-c/signed=>signed fast-safe-arith-op)
+ (:translate truncate)
+ (:args (x :scs (signed-reg) :target eax))
+ (:info y)
+ (:arg-types signed-num (:constant (signed-byte 32)))
+ (:temporary (:sc signed-reg :offset eax-offset :target quo
+ :from :argument :to (:result 0)) eax)
+ (:temporary (:sc signed-reg :offset edx-offset :target rem
+ :from :eval :to (:result 1)) edx)
+ (:temporary (:sc signed-reg :from :eval :to :result) y-arg)
+ (:results (quo :scs (signed-reg))
+ (rem :scs (signed-reg)))
+ (:result-types signed-num signed-num)
+ (:note "inline (signed-byte 32) arithmetic")
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:generator 32
+ (move eax x)
+ (inst cdq)
+ (inst mov y-arg y)
+ (inst idiv eax y-arg)
+ (move quo eax)
+ (move rem edx)))
+
+
+\f
+;;;; Shifting
+(define-vop (fast-ash-c/fixnum=>fixnum)
+ (:translate ash)
+ (:policy :fast-safe)
+ (:args (number :scs (any-reg) :target result
+ :load-if (not (and (sc-is number any-reg control-stack)
+ (sc-is result any-reg control-stack)
+ (location= number result)))))
+ (:info amount)
+ (:arg-types tagged-num (:constant integer))
+ (:results (result :scs (any-reg)
+ :load-if (not (and (sc-is number control-stack)
+ (sc-is result control-stack)
+ (location= number result)))))
+ (:result-types tagged-num)
+ (:note "inline ASH")
+ (:generator 2
+ (cond ((and (= amount 1) (not (location= number result)))
+ (inst lea result (make-ea :dword :index number :scale 2)))
+ ((and (= amount 2) (not (location= number result)))
+ (inst lea result (make-ea :dword :index number :scale 4)))
+ ((and (= amount 3) (not (location= number result)))
+ (inst lea result (make-ea :dword :index number :scale 8)))
+ (t
+ (move result number)
+ (cond ((plusp amount)
+ ;; We don't have to worry about overflow because of the
+ ;; result type restriction.
+ (inst shl result amount))
+ (t
+ ;; If the amount is greater than 31, only shift by 31. We
+ ;; have to do this because the shift instructions only look
+ ;; at the low five bits of the result.
+ (inst sar result (min 31 (- amount)))
+ ;; Fixnum correction.
+ (inst and result #xfffffffc)))))))
+
+(define-vop (fast-ash-left/fixnum=>fixnum)
+ (:translate ash)
+ (:args (number :scs (any-reg) :target result
+ :load-if (not (and (sc-is number control-stack)
+ (sc-is result control-stack)
+ (location= number result))))
+ (amount :scs (unsigned-reg) :target ecx))
+ (:arg-types tagged-num positive-fixnum)
+ (:temporary (:sc unsigned-reg :offset ecx-offset :from (:argument 1)) ecx)
+ (:results (result :scs (any-reg) :from (:argument 0)
+ :load-if (not (and (sc-is number control-stack)
+ (sc-is result control-stack)
+ (location= number result)))))
+ (:result-types tagged-num)
+ (:policy :fast-safe)
+ (:note "inline ASH")
+ (:generator 3
+ (move result number)
+ (move ecx amount)
+ ;; The result-type ensures us that this shift will not overflow.
+ (inst shl result :cl)))
+
+(define-vop (fast-ash-c)
+ (:translate ash)
+ (:policy :fast-safe)
+ (:args (number :scs (signed-reg unsigned-reg) :target result
+ :load-if (not (and (sc-is number signed-stack unsigned-stack)
+ (sc-is result signed-stack unsigned-stack)
+ (location= number result)))))
+ (:info amount)
+ (:arg-types (:or signed-num unsigned-num) (:constant integer))
+ (:results (result :scs (signed-reg unsigned-reg)
+ :load-if (not
+ (and (sc-is number signed-stack unsigned-stack)
+ (sc-is result signed-stack unsigned-stack)
+ (location= number result)))))
+ (:result-types (:or signed-num unsigned-num))
+ (:note "inline ASH")
+ (:generator 3
+ (cond ((and (= amount 1) (not (location= number result)))
+ (inst lea result (make-ea :dword :index number :scale 2)))
+ ((and (= amount 2) (not (location= number result)))
+ (inst lea result (make-ea :dword :index number :scale 4)))
+ ((and (= amount 3) (not (location= number result)))
+ (inst lea result (make-ea :dword :index number :scale 8)))
+ (t
+ (move result number)
+ (cond ((plusp amount)
+ ;; We don't have to worry about overflow because of the
+ ;; result type restriction.
+ (inst shl result amount))
+ ((sc-is number signed-reg signed-stack)
+ ;; If the amount is greater than 31, only shift by 31. We
+ ;; have to do this because the shift instructions only look
+ ;; at the low five bits of the result.
+ (inst sar result (min 31 (- amount))))
+ (t
+ (inst shr result (min 31 (- amount)))))))))
+
+(define-vop (fast-ash-left)
+ (:translate ash)
+ (:args (number :scs (signed-reg unsigned-reg) :target result
+ :load-if (not (and (sc-is number signed-stack unsigned-stack)
+ (sc-is result signed-stack unsigned-stack)
+ (location= number result))))
+ (amount :scs (unsigned-reg) :target ecx))
+ (:arg-types (:or signed-num unsigned-num) positive-fixnum)
+ (:temporary (:sc unsigned-reg :offset ecx-offset :from (:argument 1)) ecx)
+ (:results (result :scs (signed-reg unsigned-reg) :from (:argument 0)
+ :load-if (not
+ (and (sc-is number signed-stack unsigned-stack)
+ (sc-is result signed-stack unsigned-stack)
+ (location= number result)))))
+ (:result-types (:or signed-num unsigned-num))
+ (:policy :fast-safe)
+ (:note "inline ASH")
+ (:generator 4
+ (move result number)
+ (move ecx amount)
+ ;; The result-type ensures us that this shift will not overflow.
+ (inst shl result :cl)))
+
+(define-vop (fast-ash)
+ (:translate ash)
+ (:policy :fast-safe)
+ (:args (number :scs (signed-reg unsigned-reg) :target result)
+ (amount :scs (signed-reg) :target ecx))
+ (:arg-types (:or signed-num unsigned-num) signed-num)
+ (:results (result :scs (signed-reg unsigned-reg) :from (:argument 0)))
+ (:result-types (:or signed-num unsigned-num))
+ (:temporary (:sc signed-reg :offset ecx-offset :from (:argument 1)) ecx)
+ (:note "inline ASH")
+ (:generator 5
+ (move result number)
+ (move ecx amount)
+ (inst or ecx ecx)
+ (inst jmp :ns positive)
+ (inst neg ecx)
+ (inst cmp ecx 31)
+ (inst jmp :be okay)
+ (inst mov ecx 31)
+ OKAY
+ (sc-case number
+ (signed-reg (inst sar result :cl))
+ (unsigned-reg (inst shr result :cl)))
+ (inst jmp done)
+
+ POSITIVE
+ ;; The result-type ensures us that this shift will not overflow.
+ (inst shl result :cl)
+
+ DONE))
+\f
+;;; Note: documentation for this function is wrong - rtfm
+(define-vop (signed-byte-32-len)
+ (:translate integer-length)
+ (:note "inline (signed-byte 32) integer-length")
+ (:policy :fast-safe)
+ (:args (arg :scs (signed-reg) :target res))
+ (:arg-types signed-num)
+ (:results (res :scs (any-reg)))
+ (:result-types positive-fixnum)
+ (:generator 30
+ (move res arg)
+ (inst cmp res 0)
+ (inst jmp :ge POS)
+ (inst not res)
+ POS
+ (inst bsr res res)
+ (inst jmp :z zero)
+ (inst inc res)
+ (inst shl res 2)
+ (inst jmp done)
+ ZERO
+ (inst xor res res)
+ DONE))
+
+(define-vop (unsigned-byte-32-count)
+ (:translate logcount)
+ (:note "inline (unsigned-byte 32) logcount")
+ (:policy :fast-safe)
+ (:args (arg :scs (unsigned-reg)))
+ (:arg-types unsigned-num)
+ (:results (result :scs (unsigned-reg)))
+ (:result-types positive-fixnum)
+ (:temporary (:sc unsigned-reg :from (:argument 0)) temp)
+ (:generator 30
+ (move result arg)
+
+ (inst mov temp result)
+ (inst shr temp 1)
+ (inst and result #x55555555)
+ (inst and temp #x55555555)
+ (inst add result temp)
+
+ (inst mov temp result)
+ (inst shr temp 2)
+ (inst and result #x33333333)
+ (inst and temp #x33333333)
+ (inst add result temp)
+
+ (inst mov temp result)
+ (inst shr temp 4)
+ (inst and result #x0f0f0f0f)
+ (inst and temp #x0f0f0f0f)
+ (inst add result temp)
+
+ (inst mov temp result)
+ (inst shr temp 8)
+ (inst and result #x00ff00ff)
+ (inst and temp #x00ff00ff)
+ (inst add result temp)
+
+ (inst mov temp result)
+ (inst shr temp 16)
+ (inst and result #x0000ffff)
+ (inst and temp #x0000ffff)
+ (inst add result temp)))
+
+
+\f
+;;;; binary conditional VOPs
+
+(define-vop (fast-conditional)
+ (:conditional)
+ (:info target not-p)
+ (:effects)
+ (:affected)
+ (:policy :fast-safe))
+
+(define-vop (fast-conditional/fixnum fast-conditional)
+ (:args (x :scs (any-reg)
+ :load-if (not (and (sc-is x control-stack)
+ (sc-is y any-reg))))
+ (y :scs (any-reg control-stack)))
+ (:arg-types tagged-num tagged-num)
+ (:note "inline fixnum comparison"))
+
+(define-vop (fast-conditional-c/fixnum fast-conditional/fixnum)
+ (:args (x :scs (any-reg control-stack)))
+ (:arg-types tagged-num (:constant (signed-byte 30)))
+ (:info target not-p y))
+
+(define-vop (fast-conditional/signed fast-conditional)
+ (:args (x :scs (signed-reg)
+ :load-if (not (and (sc-is x signed-stack)
+ (sc-is y signed-reg))))
+ (y :scs (signed-reg signed-stack)))
+ (:arg-types signed-num signed-num)
+ (:note "inline (signed-byte 32) comparison"))
+
+(define-vop (fast-conditional-c/signed fast-conditional/signed)
+ (:args (x :scs (signed-reg signed-stack)))
+ (:arg-types signed-num (:constant (signed-byte 32)))
+ (:info target not-p y))
+
+(define-vop (fast-conditional/unsigned fast-conditional)
+ (:args (x :scs (unsigned-reg)
+ :load-if (not (and (sc-is x unsigned-stack)
+ (sc-is y unsigned-reg))))
+ (y :scs (unsigned-reg unsigned-stack)))
+ (:arg-types unsigned-num unsigned-num)
+ (:note "inline (unsigned-byte 32) comparison"))
+
+(define-vop (fast-conditional-c/unsigned fast-conditional/unsigned)
+ (:args (x :scs (unsigned-reg unsigned-stack)))
+ (:arg-types unsigned-num (:constant (unsigned-byte 32)))
+ (:info target not-p y))
+
+
+(macrolet ((define-conditional-vop (tran cond unsigned not-cond not-unsigned)
+ `(progn
+ ,@(mapcar
+ #'(lambda (suffix cost signed)
+ `(define-vop (;; FIXME: These could be done more
+ ;; cleanly with SYMBOLICATE.
+ ,(intern (format nil "~:@(FAST-IF-~A~A~)"
+ tran suffix))
+ ,(intern
+ (format nil "~:@(FAST-CONDITIONAL~A~)"
+ suffix)))
+ (:translate ,tran)
+ (:generator ,cost
+ (inst cmp x
+ ,(if (eq suffix '-c/fixnum)
+ '(fixnumize y)
+ 'y))
+ (inst jmp (if not-p
+ ,(if signed
+ not-cond
+ not-unsigned)
+ ,(if signed
+ cond
+ unsigned))
+ target))))
+ '(/fixnum -c/fixnum /signed -c/signed /unsigned -c/unsigned)
+ '(4 3 6 5 6 5)
+ '(t t t t nil nil)))))
+
+ (define-conditional-vop < :l :b :ge :ae)
+ (define-conditional-vop > :g :a :le :be))
+
+(define-vop (fast-if-eql/signed fast-conditional/signed)
+ (:translate eql)
+ (:generator 6
+ (inst cmp x y)
+ (inst jmp (if not-p :ne :e) target)))
+
+(define-vop (fast-if-eql-c/signed fast-conditional-c/signed)
+ (:translate eql)
+ (:generator 5
+ (cond ((and (sc-is x signed-reg) (zerop y))
+ (inst test x x)) ; smaller instruction
+ (t
+ (inst cmp x y)))
+ (inst jmp (if not-p :ne :e) target)))
+
+(define-vop (fast-if-eql/unsigned fast-conditional/unsigned)
+ (:translate eql)
+ (:generator 6
+ (inst cmp x y)
+ (inst jmp (if not-p :ne :e) target)))
+
+(define-vop (fast-if-eql-c/unsigned fast-conditional-c/unsigned)
+ (:translate eql)
+ (:generator 5
+ (cond ((and (sc-is x unsigned-reg) (zerop y))
+ (inst test x x)) ; smaller instruction
+ (t
+ (inst cmp x y)))
+ (inst jmp (if not-p :ne :e) target)))
+
+;;; EQL/FIXNUM is funny because the first arg can be of any type, not just a
+;;; known fixnum.
+
+;;; These versions specify a fixnum restriction on their first arg. We have
+;;; also generic-eql/fixnum VOPs which are the same, but have no restriction on
+;;; the first arg and a higher cost. The reason for doing this is to prevent
+;;; fixnum specific operations from being used on word integers, spuriously
+;;; consing the argument.
+
+(define-vop (fast-eql/fixnum fast-conditional)
+ (:args (x :scs (any-reg)
+ :load-if (not (and (sc-is x control-stack)
+ (sc-is y any-reg))))
+ (y :scs (any-reg control-stack)))
+ (:arg-types tagged-num tagged-num)
+ (:note "inline fixnum comparison")
+ (:translate eql)
+ (:generator 4
+ (inst cmp x y)
+ (inst jmp (if not-p :ne :e) target)))
+(define-vop (generic-eql/fixnum fast-eql/fixnum)
+ (:args (x :scs (any-reg descriptor-reg)
+ :load-if (not (and (sc-is x control-stack)
+ (sc-is y any-reg))))
+ (y :scs (any-reg control-stack)))
+ (:arg-types * tagged-num)
+ (:variant-cost 7))
+
+(define-vop (fast-eql-c/fixnum fast-conditional/fixnum)
+ (:args (x :scs (any-reg control-stack)))
+ (:arg-types tagged-num (:constant (signed-byte 30)))
+ (:info target not-p y)
+ (:translate eql)
+ (:generator 2
+ (cond ((and (sc-is x any-reg) (zerop y))
+ (inst test x x)) ; smaller instruction
+ (t
+ (inst cmp x (fixnumize y))))
+ (inst jmp (if not-p :ne :e) target)))
+(define-vop (generic-eql-c/fixnum fast-eql-c/fixnum)
+ (:args (x :scs (any-reg descriptor-reg control-stack)))
+ (:arg-types * (:constant (signed-byte 30)))
+ (:variant-cost 6))
+\f
+;;;; 32-bit logical operations
+
+(define-vop (merge-bits)
+ (:translate merge-bits)
+ (:args (shift :scs (signed-reg unsigned-reg) :target ecx)
+ (prev :scs (unsigned-reg) :target result)
+ (next :scs (unsigned-reg)))
+ (:arg-types tagged-num unsigned-num unsigned-num)
+ (:temporary (:sc signed-reg :offset ecx-offset :from (:argument 0)) ecx)
+ (:results (result :scs (unsigned-reg) :from (:argument 1)))
+ (:result-types unsigned-num)
+ (:policy :fast-safe)
+ (:generator 4
+ (move ecx shift)
+ (move result prev)
+ (inst shrd result next :cl)))
+
+(define-vop (32bit-logical)
+ (:args (x :scs (unsigned-reg) :target r
+ :load-if (not (and (sc-is x unsigned-stack)
+ (sc-is r unsigned-stack)
+ (location= x r))))
+ (y :scs (unsigned-reg)
+ :load-if (or (not (sc-is y unsigned-stack))
+ (and (sc-is x unsigned-stack)
+ (sc-is y unsigned-stack)
+ (location= x r)))))
+ (:arg-types unsigned-num unsigned-num)
+ (:results (r :scs (unsigned-reg)
+ :from (:argument 0)
+ :load-if (not (and (sc-is x unsigned-stack)
+ (sc-is r unsigned-stack)
+ (location= x r)))))
+ (:result-types unsigned-num)
+ (:policy :fast-safe))
+
+(define-vop (32bit-logical-not)
+ (:translate 32bit-logical-not)
+ (:args (x :scs (unsigned-reg) :target r
+ :load-if (not (and (sc-is x unsigned-stack)
+ (sc-is r unsigned-stack)
+ (location= x r)))))
+ (:arg-types unsigned-num)
+ (:results (r :scs (unsigned-reg)
+ :load-if (not (and (sc-is x unsigned-stack)
+ (sc-is r unsigned-stack)
+ (location= x r)))))
+ (:result-types unsigned-num)
+ (:policy :fast-safe)
+ (:generator 1
+ (move r x)
+ (inst not r)))
+
+(define-vop (32bit-logical-and 32bit-logical)
+ (:translate 32bit-logical-and)
+ (:generator 1
+ (move r x)
+ (inst and r y)))
+
+(def-source-transform 32bit-logical-nand (x y)
+ `(32bit-logical-not (32bit-logical-and ,x ,y)))
+
+(define-vop (32bit-logical-or 32bit-logical)
+ (:translate 32bit-logical-or)
+ (:generator 1
+ (move r x)
+ (inst or r y)))
+
+(def-source-transform 32bit-logical-nor (x y)
+ `(32bit-logical-not (32bit-logical-or ,x ,y)))
+
+(define-vop (32bit-logical-xor 32bit-logical)
+ (:translate 32bit-logical-xor)
+ (:generator 1
+ (move r x)
+ (inst xor r y)))
+
+(def-source-transform 32bit-logical-eqv (x y)
+ `(32bit-logical-not (32bit-logical-xor ,x ,y)))
+
+(def-source-transform 32bit-logical-orc1 (x y)
+ `(32bit-logical-or (32bit-logical-not ,x) ,y))
+
+(def-source-transform 32bit-logical-orc2 (x y)
+ `(32bit-logical-or ,x (32bit-logical-not ,y)))
+
+(def-source-transform 32bit-logical-andc1 (x y)
+ `(32bit-logical-and (32bit-logical-not ,x) ,y))
+
+(def-source-transform 32bit-logical-andc2 (x y)
+ `(32bit-logical-and ,x (32bit-logical-not ,y)))
+
+;;; Only the lower 5 bits of the shift amount are significant.
+(define-vop (shift-towards-someplace)
+ (:policy :fast-safe)
+ (:args (num :scs (unsigned-reg) :target r)
+ (amount :scs (signed-reg) :target ecx))
+ (:arg-types unsigned-num tagged-num)
+ (:temporary (:sc signed-reg :offset ecx-offset :from (:argument 1)) ecx)
+ (:results (r :scs (unsigned-reg) :from (:argument 0)))
+ (:result-types unsigned-num))
+
+(define-vop (shift-towards-start shift-towards-someplace)
+ (:translate shift-towards-start)
+ (:note "SHIFT-TOWARDS-START")
+ (:generator 1
+ (move r num)
+ (move ecx amount)
+ (inst shr r :cl)))
+
+(define-vop (shift-towards-end shift-towards-someplace)
+ (:translate shift-towards-end)
+ (:note "SHIFT-TOWARDS-END")
+ (:generator 1
+ (move r num)
+ (move ecx amount)
+ (inst shl r :cl)))
+\f
+;;;; bignum stuff
+
+(define-vop (bignum-length get-header-data)
+ (:translate sb!bignum::%bignum-length)
+ (:policy :fast-safe))
+
+(define-vop (bignum-set-length set-header-data)
+ (:translate sb!bignum::%bignum-set-length)
+ (:policy :fast-safe))
+
+(define-full-reffer bignum-ref * bignum-digits-offset other-pointer-type
+ (unsigned-reg) unsigned-num sb!bignum::%bignum-ref)
+
+(define-full-setter bignum-set * bignum-digits-offset other-pointer-type
+ (unsigned-reg) unsigned-num sb!bignum::%bignum-set)
+
+(define-vop (digit-0-or-plus)
+ (:translate sb!bignum::%digit-0-or-plusp)
+ (:policy :fast-safe)
+ (:args (digit :scs (unsigned-reg)))
+ (:arg-types unsigned-num)
+ (:conditional)
+ (:info target not-p)
+ (:generator 3
+ (inst or digit digit)
+ (inst jmp (if not-p :s :ns) target)))
+
+
+;;; For add and sub with carry the sc of carry argument is any-reg so
+;;; the it may be passed as a fixnum or word and thus may be 0, 1, or
+;;; 4. This is easy to deal with and may save a fixnum-word
+;;; conversion.
+(define-vop (add-w/carry)
+ (:translate sb!bignum::%add-with-carry)
+ (:policy :fast-safe)
+ (:args (a :scs (unsigned-reg) :target result)
+ (b :scs (unsigned-reg unsigned-stack) :to :eval)
+ (c :scs (any-reg) :target temp))
+ (:arg-types unsigned-num unsigned-num positive-fixnum)
+ (:temporary (:sc any-reg :from (:argument 2) :to :eval) temp)
+ (:results (result :scs (unsigned-reg) :from (:argument 0))
+ (carry :scs (unsigned-reg)))
+ (:result-types unsigned-num positive-fixnum)
+ (:generator 4
+ (move result a)
+ (move temp c)
+ (inst neg temp) ; Set the carry flag to 0 if c=0 else to 1
+ (inst adc result b)
+ (inst mov carry 0)
+ (inst adc carry carry)))
+
+;;; Note: the borrow is the oppostite of the x86 convention - 1 for no
+;;; borrow and 0 for a borrow.
+(define-vop (sub-w/borrow)
+ (:translate sb!bignum::%subtract-with-borrow)
+ (:policy :fast-safe)
+ (:args (a :scs (unsigned-reg) :to :eval :target result)
+ (b :scs (unsigned-reg unsigned-stack) :to :result)
+ (c :scs (any-reg control-stack)))
+ (:arg-types unsigned-num unsigned-num positive-fixnum)
+ (:results (result :scs (unsigned-reg) :from :eval)
+ (borrow :scs (unsigned-reg)))
+ (:result-types unsigned-num positive-fixnum)
+ (:generator 5
+ (inst cmp c 1) ; Set the carry flag to 1 if c=0 else to 0
+ (move result a)
+ (inst sbb result b)
+ (inst mov borrow 0)
+ (inst adc borrow borrow)
+ (inst xor borrow 1)))
+
+
+(define-vop (bignum-mult-and-add-3-arg)
+ (:translate sb!bignum::%multiply-and-add)
+ (:policy :fast-safe)
+ (:args (x :scs (unsigned-reg) :target eax)
+ (y :scs (unsigned-reg unsigned-stack))
+ (carry-in :scs (unsigned-reg unsigned-stack)))
+ (:arg-types unsigned-num unsigned-num unsigned-num)
+ (:temporary (:sc unsigned-reg :offset eax-offset :from (:argument 0)
+ :to (:result 1) :target lo) eax)
+ (:temporary (:sc unsigned-reg :offset edx-offset :from (:argument 1)
+ :to (:result 0) :target hi) edx)
+ (:results (hi :scs (unsigned-reg))
+ (lo :scs (unsigned-reg)))
+ (:result-types unsigned-num unsigned-num)
+ (:generator 20
+ (move eax x)
+ (inst mul eax y)
+ (inst add eax carry-in)
+ (inst adc edx 0)
+ (move hi edx)
+ (move lo eax)))
+
+(define-vop (bignum-mult-and-add-4-arg)
+ (:translate sb!bignum::%multiply-and-add)
+ (:policy :fast-safe)
+ (:args (x :scs (unsigned-reg) :target eax)
+ (y :scs (unsigned-reg unsigned-stack))
+ (prev :scs (unsigned-reg unsigned-stack))
+ (carry-in :scs (unsigned-reg unsigned-stack)))
+ (:arg-types unsigned-num unsigned-num unsigned-num unsigned-num)
+ (:temporary (:sc unsigned-reg :offset eax-offset :from (:argument 0)
+ :to (:result 1) :target lo) eax)
+ (:temporary (:sc unsigned-reg :offset edx-offset :from (:argument 1)
+ :to (:result 0) :target hi) edx)
+ (:results (hi :scs (unsigned-reg))
+ (lo :scs (unsigned-reg)))
+ (:result-types unsigned-num unsigned-num)
+ (:generator 20
+ (move eax x)
+ (inst mul eax y)
+ (inst add eax prev)
+ (inst adc edx 0)
+ (inst add eax carry-in)
+ (inst adc edx 0)
+ (move hi edx)
+ (move lo eax)))
+
+
+(define-vop (bignum-mult)
+ (:translate sb!bignum::%multiply)
+ (:policy :fast-safe)
+ (:args (x :scs (unsigned-reg) :target eax)
+ (y :scs (unsigned-reg unsigned-stack)))
+ (:arg-types unsigned-num unsigned-num)
+ (:temporary (:sc unsigned-reg :offset eax-offset :from (:argument 0)
+ :to (:result 1) :target lo) eax)
+ (:temporary (:sc unsigned-reg :offset edx-offset :from (:argument 1)
+ :to (:result 0) :target hi) edx)
+ (:results (hi :scs (unsigned-reg))
+ (lo :scs (unsigned-reg)))
+ (:result-types unsigned-num unsigned-num)
+ (:generator 20
+ (move eax x)
+ (inst mul eax y)
+ (move hi edx)
+ (move lo eax)))
+
+(define-vop (bignum-lognot)
+ (:translate sb!bignum::%lognot)
+ (:policy :fast-safe)
+ (:args (x :scs (unsigned-reg unsigned-stack) :target r))
+ (:arg-types unsigned-num)
+ (:results (r :scs (unsigned-reg)
+ :load-if (not (location= x r))))
+ (:result-types unsigned-num)
+ (:generator 1
+ (move r x)
+ (inst not r)))
+
+(define-vop (fixnum-to-digit)
+ (:translate sb!bignum::%fixnum-to-digit)
+ (:policy :fast-safe)
+ (:args (fixnum :scs (any-reg control-stack) :target digit))
+ (:arg-types tagged-num)
+ (:results (digit :scs (unsigned-reg)
+ :load-if (not (and (sc-is fixnum control-stack)
+ (sc-is digit unsigned-stack)
+ (location= fixnum digit)))))
+ (:result-types unsigned-num)
+ (:generator 1
+ (move digit fixnum)
+ (inst sar digit 2)))
+
+(define-vop (bignum-floor)
+ (:translate sb!bignum::%floor)
+ (:policy :fast-safe)
+ (:args (div-high :scs (unsigned-reg) :target edx)
+ (div-low :scs (unsigned-reg) :target eax)
+ (divisor :scs (unsigned-reg unsigned-stack)))
+ (:arg-types unsigned-num unsigned-num unsigned-num)
+ (:temporary (:sc unsigned-reg :offset eax-offset :from (:argument 1)
+ :to (:result 0) :target quo) eax)
+ (:temporary (:sc unsigned-reg :offset edx-offset :from (:argument 0)
+ :to (:result 1) :target rem) edx)
+ (:results (quo :scs (unsigned-reg))
+ (rem :scs (unsigned-reg)))
+ (:result-types unsigned-num unsigned-num)
+ (:generator 300
+ (move edx div-high)
+ (move eax div-low)
+ (inst div eax divisor)
+ (move quo eax)
+ (move rem edx)))
+
+(define-vop (signify-digit)
+ (:translate sb!bignum::%fixnum-digit-with-correct-sign)
+ (:policy :fast-safe)
+ (:args (digit :scs (unsigned-reg unsigned-stack) :target res))
+ (:arg-types unsigned-num)
+ (:results (res :scs (any-reg signed-reg)
+ :load-if (not (and (sc-is digit unsigned-stack)
+ (sc-is res control-stack signed-stack)
+ (location= digit res)))))
+ (:result-types signed-num)
+ (:generator 1
+ (move res digit)
+ (when (sc-is res any-reg control-stack)
+ (inst shl res 2))))
+
+(define-vop (digit-ashr)
+ (:translate sb!bignum::%ashr)
+ (:policy :fast-safe)
+ (:args (digit :scs (unsigned-reg unsigned-stack) :target result)
+ (count :scs (unsigned-reg) :target ecx))
+ (:arg-types unsigned-num positive-fixnum)
+ (:temporary (:sc unsigned-reg :offset ecx-offset :from (:argument 1)) ecx)
+ (:results (result :scs (unsigned-reg) :from (:argument 0)
+ :load-if (not (and (sc-is result unsigned-stack)
+ (location= digit result)))))
+ (:result-types unsigned-num)
+ (:generator 1
+ (move result digit)
+ (move ecx count)
+ (inst sar result :cl)))
+
+(define-vop (digit-lshr digit-ashr)
+ (:translate sb!bignum::%digit-logical-shift-right)
+ (:generator 1
+ (move result digit)
+ (move ecx count)
+ (inst shr result :cl)))
+
+(define-vop (digit-ashl digit-ashr)
+ (:translate sb!bignum::%ashl)
+ (:generator 1
+ (move result digit)
+ (move ecx count)
+ (inst shl result :cl)))
+\f
+;;;; static functions
+
+(define-static-function two-arg-/ (x y) :translate /)
+
+(define-static-function two-arg-gcd (x y) :translate gcd)
+(define-static-function two-arg-lcm (x y) :translate lcm)
+
+(define-static-function two-arg-and (x y) :translate logand)
+(define-static-function two-arg-ior (x y) :translate logior)
+(define-static-function two-arg-xor (x y) :translate logxor)
+
+\f
+;;; Support for the Mersenne Twister, MT19937, random number generator
+;;; due to Matsumoto and Nishimura.
+;;;
+;;; Makoto Matsumoto and T. Nishimura, "Mersenne twister: A
+;;; 623-dimensionally equidistributed uniform pseudorandom number
+;;; generator.", ACM Transactions on Modeling and Computer Simulation,
+;;; 1997, to appear.
+;;;
+;;; State:
+;;; 0-1: Constant matrix A. [0, #x9908b0df] (not used here)
+;;; 2: Index; init. to 1.
+;;; 3-626: State.
+(defknown random-mt19937 ((simple-array (unsigned-byte 32) (*)))
+ (unsigned-byte 32) ())
+(define-vop (random-mt19937)
+ (:policy :fast-safe)
+ (:translate random-mt19937)
+ (:args (state :scs (descriptor-reg) :to :result))
+ (:arg-types simple-array-unsigned-byte-32)
+ (:temporary (:sc unsigned-reg :from (:eval 0) :to :result) k)
+ (:temporary (:sc unsigned-reg :offset eax-offset
+ :from (:eval 0) :to :result) tmp)
+ (:results (y :scs (unsigned-reg) :from (:eval 0)))
+ (:result-types unsigned-num)
+ (:generator 50
+ (inst mov k (make-ea :dword :base state
+ :disp (- (* (+ 2 sb!vm:vector-data-offset)
+ sb!vm:word-bytes)
+ sb!vm:other-pointer-type)))
+ (inst cmp k 624)
+ (inst jmp :ne no-update)
+ (inst mov tmp state) ; The state is passed in EAX.
+ (inst call (make-fixup 'random-mt19937-update :assembly-routine))
+ ;; Restore k, and set to 0.
+ (inst xor k k)
+ NO-UPDATE
+ ;; y = ptgfsr[k++];
+ (inst mov y (make-ea :dword :base state :index k :scale 4
+ :disp (- (* (+ 3 sb!vm:vector-data-offset)
+ sb!vm:word-bytes)
+ sb!vm:other-pointer-type)))
+ ;; y ^= (y >> 11);
+ (inst shr y 11)
+ (inst xor y (make-ea :dword :base state :index k :scale 4
+ :disp (- (* (+ 3 sb!vm:vector-data-offset)
+ sb!vm:word-bytes)
+ sb!vm:other-pointer-type)))
+ ;; y ^= (y << 7) & #x9d2c5680
+ (inst mov tmp y)
+ (inst inc k)
+ (inst shl tmp 7)
+ (inst mov (make-ea :dword :base state
+ :disp (- (* (+ 2 sb!vm:vector-data-offset)
+ sb!vm:word-bytes)
+ sb!vm:other-pointer-type))
+ k)
+ (inst and tmp #x9d2c5680)
+ (inst xor y tmp)
+ ;; y ^= (y << 15) & #xefc60000
+ (inst mov tmp y)
+ (inst shl tmp 15)
+ (inst and tmp #xefc60000)
+ (inst xor y tmp)
+ ;; y ^= (y >> 18);
+ (inst mov tmp y)
+ (inst shr tmp 18)
+ (inst xor y tmp)))
--- /dev/null
+;;;; array operations for the x86 VM
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!VM")
+
+(file-comment
+ "$Header$")
+\f
+;;;; allocator for the array header
+
+(define-vop (make-array-header)
+ (:translate make-array-header)
+ (:policy :fast-safe)
+ (:args (type :scs (any-reg))
+ (rank :scs (any-reg)))
+ (:arg-types positive-fixnum positive-fixnum)
+ (:temporary (:sc any-reg :to :eval) bytes)
+ (:temporary (:sc any-reg :to :result) header)
+ (:results (result :scs (descriptor-reg) :from :eval))
+ (:node-var node)
+ (:generator 13
+ (inst lea bytes
+ (make-ea :dword :base rank
+ :disp (+ (* (1+ array-dimensions-offset) word-bytes)
+ lowtag-mask)))
+ (inst and bytes (lognot lowtag-mask))
+ (inst lea header (make-ea :dword :base rank
+ :disp (fixnumize (1- array-dimensions-offset))))
+ (inst shl header type-bits)
+ (inst or header type)
+ (inst shr header 2)
+ (pseudo-atomic
+ (allocation result bytes node)
+ (inst lea result (make-ea :dword :base result :disp other-pointer-type))
+ (storew header result 0 other-pointer-type))))
+\f
+;;;; additional accessors and setters for the array header
+
+(defknown sb!impl::%array-dimension (t index) index
+ (flushable))
+(defknown sb!impl::%set-array-dimension (t index index) index
+ ())
+
+(define-full-reffer %array-dimension *
+ array-dimensions-offset other-pointer-type
+ (any-reg) positive-fixnum sb!impl::%array-dimension)
+
+(define-full-setter %set-array-dimension *
+ array-dimensions-offset other-pointer-type
+ (any-reg) positive-fixnum sb!impl::%set-array-dimension)
+
+(defknown sb!impl::%array-rank (t) index (flushable))
+
+(define-vop (array-rank-vop)
+ (:translate sb!impl::%array-rank)
+ (:policy :fast-safe)
+ (:args (x :scs (descriptor-reg)))
+ (:results (res :scs (unsigned-reg)))
+ (:result-types positive-fixnum)
+ (:generator 6
+ (loadw res x 0 other-pointer-type)
+ (inst shr res type-bits)
+ (inst sub res (1- array-dimensions-offset))))
+\f
+;;;; bounds checking routine
+
+;;; Note that the immediate SC for the index argument is disabled
+;;; because it is not possible to generate a valid error code SC for
+;;; an immediate value.
+(define-vop (check-bound)
+ (:translate %check-bound)
+ (:policy :fast-safe)
+ (:args (array :scs (descriptor-reg))
+ (bound :scs (any-reg descriptor-reg))
+ (index :scs (any-reg descriptor-reg #+nil immediate) :target result))
+ (:arg-types * positive-fixnum tagged-num)
+ (:results (result :scs (any-reg descriptor-reg)))
+ (:result-types positive-fixnum)
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:generator 5
+ (let ((error (generate-error-code vop invalid-array-index-error
+ array bound index))
+ (index (if (sc-is index immediate)
+ (fixnumize (tn-value index))
+ index)))
+ (inst cmp bound index)
+ ;; We use below-or-equal even though it's an unsigned test,
+ ;; because negative indexes appear as large unsigned numbers.
+ ;; Therefore, we get the <0 and >=bound test all rolled into one.
+ (inst jmp :be error)
+ (unless (and (tn-p index) (location= result index))
+ (inst mov result index)))))
+\f
+;;;; accessors/setters
+
+;;; variants built on top of WORD-INDEX-REF, etc. I.e., those vectors
+;;; whose elements are represented in integer registers and are built
+;;; out of 8, 16, or 32 bit elements.
+(macrolet ((def-full-data-vector-frobs (type element-type &rest scs)
+ `(progn
+ (define-full-reffer ,(symbolicate "DATA-VECTOR-REF/" type)
+ ,type vector-data-offset other-pointer-type ,scs
+ ,element-type data-vector-ref)
+ (define-full-setter ,(symbolicate "DATA-VECTOR-SET/" type)
+ ,type vector-data-offset other-pointer-type ,scs
+ ,element-type data-vector-set))))
+ (def-full-data-vector-frobs simple-vector * descriptor-reg any-reg)
+ (def-full-data-vector-frobs simple-array-unsigned-byte-32 unsigned-num
+ unsigned-reg)
+ (def-full-data-vector-frobs simple-array-signed-byte-30 tagged-num any-reg)
+ (def-full-data-vector-frobs simple-array-signed-byte-32 signed-num
+ signed-reg))
+\f
+;;;; integer vectors whose elements are smaller than a byte, i.e.,
+;;;; bit, 2-bit, and 4-bit vectors
+
+(macrolet ((def-small-data-vector-frobs (type bits)
+ (let* ((elements-per-word (floor sb!vm:word-bits bits))
+ (bit-shift (1- (integer-length elements-per-word))))
+ `(progn
+ (define-vop (,(symbolicate 'data-vector-ref/ type))
+ (:note "inline array access")
+ (:translate data-vector-ref)
+ (:policy :fast-safe)
+ (:args (object :scs (descriptor-reg))
+ (index :scs (unsigned-reg)))
+ (:arg-types ,type positive-fixnum)
+ (:results (result :scs (unsigned-reg) :from (:argument 0)))
+ (:result-types positive-fixnum)
+ (:temporary (:sc unsigned-reg :offset ecx-offset) ecx)
+ (:generator 20
+ (move ecx index)
+ (inst shr ecx ,bit-shift)
+ (inst mov result
+ (make-ea :dword :base object :index ecx :scale 4
+ :disp (- (* vector-data-offset word-bytes)
+ other-pointer-type)))
+ (move ecx index)
+ (inst and ecx ,(1- elements-per-word))
+ ,@(unless (= bits 1)
+ `((inst shl ecx ,(1- (integer-length bits)))))
+ (inst shr result :cl)
+ (inst and result ,(1- (ash 1 bits)))))
+ (define-vop (,(symbolicate 'data-vector-ref-c/ type))
+ (:translate data-vector-ref)
+ (:policy :fast-safe)
+ (:args (object :scs (descriptor-reg)))
+ (:arg-types ,type (:constant index))
+ (:info index)
+ (:results (result :scs (unsigned-reg)))
+ (:result-types positive-fixnum)
+ (:generator 15
+ (multiple-value-bind (word extra) (floor index ,elements-per-word)
+ (loadw result object (+ word vector-data-offset)
+ other-pointer-type)
+ (unless (zerop extra)
+ (inst shr result (* extra ,bits)))
+ (unless (= extra ,(1- elements-per-word))
+ (inst and result ,(1- (ash 1 bits)))))))
+ (define-vop (,(symbolicate 'data-vector-set/ type))
+ (:note "inline array store")
+ (:translate data-vector-set)
+ (:policy :fast-safe)
+ (:args (object :scs (descriptor-reg) :target ptr)
+ (index :scs (unsigned-reg) :target ecx)
+ (value :scs (unsigned-reg immediate) :target result))
+ (:arg-types ,type positive-fixnum positive-fixnum)
+ (:results (result :scs (unsigned-reg)))
+ (:result-types positive-fixnum)
+ (:temporary (:sc unsigned-reg) word-index)
+ (:temporary (:sc unsigned-reg :from (:argument 0)) ptr old)
+ (:temporary (:sc unsigned-reg :offset ecx-offset :from (:argument 1))
+ ecx)
+ (:generator 25
+ (move word-index index)
+ (inst shr word-index ,bit-shift)
+ (inst lea ptr
+ (make-ea :dword :base object :index word-index :scale 4
+ :disp (- (* vector-data-offset word-bytes)
+ other-pointer-type)))
+ (loadw old ptr)
+ (move ecx index)
+ (inst and ecx ,(1- elements-per-word))
+ ,@(unless (= bits 1)
+ `((inst shl ecx ,(1- (integer-length bits)))))
+ (inst ror old :cl)
+ (unless (and (sc-is value immediate)
+ (= (tn-value value) ,(1- (ash 1 bits))))
+ (inst and old ,(lognot (1- (ash 1 bits)))))
+ (sc-case value
+ (immediate
+ (unless (zerop (tn-value value))
+ (inst or old (logand (tn-value value) ,(1- (ash 1 bits))))))
+ (unsigned-reg
+ (inst or old value)))
+ (inst rol old :cl)
+ (storew old ptr)
+ (sc-case value
+ (immediate
+ (inst mov result (tn-value value)))
+ (unsigned-reg
+ (move result value)))))
+ (define-vop (,(symbolicate 'data-vector-set-c/ type))
+ (:translate data-vector-set)
+ (:policy :fast-safe)
+ (:args (object :scs (descriptor-reg))
+ (value :scs (unsigned-reg immediate) :target result))
+ (:arg-types ,type (:constant index) positive-fixnum)
+ (:info index)
+ (:results (result :scs (unsigned-reg)))
+ (:result-types positive-fixnum)
+ (:temporary (:sc unsigned-reg :to (:result 0)) old)
+ (:generator 20
+ (multiple-value-bind (word extra) (floor index ,elements-per-word)
+ (inst mov old
+ (make-ea :dword :base object
+ :disp (- (* (+ word vector-data-offset) word-bytes)
+ other-pointer-type)))
+ (sc-case value
+ (immediate
+ (let* ((value (tn-value value))
+ (mask ,(1- (ash 1 bits)))
+ (shift (* extra ,bits)))
+ (unless (= value mask)
+ (inst and old (lognot (ash mask shift))))
+ (unless (zerop value)
+ (inst or old (ash value shift)))))
+ (unsigned-reg
+ (let ((shift (* extra ,bits)))
+ (unless (zerop shift)
+ (inst ror old shift)
+ (inst and old (lognot ,(1- (ash 1 bits))))
+ (inst or old value)
+ (inst rol old shift)))))
+ (inst mov (make-ea :dword :base object
+ :disp (- (* (+ word vector-data-offset)
+ word-bytes)
+ other-pointer-type))
+ old)
+ (sc-case value
+ (immediate
+ (inst mov result (tn-value value)))
+ (unsigned-reg
+ (move result value))))))))))
+ (def-small-data-vector-frobs simple-bit-vector 1)
+ (def-small-data-vector-frobs simple-array-unsigned-byte-2 2)
+ (def-small-data-vector-frobs simple-array-unsigned-byte-4 4))
+
+;;; And the float variants.
+
+(define-vop (data-vector-ref/simple-array-single-float)
+ (:note "inline array access")
+ (:translate data-vector-ref)
+ (:policy :fast-safe)
+ (:args (object :scs (descriptor-reg))
+ (index :scs (any-reg)))
+ (:arg-types simple-array-single-float positive-fixnum)
+ (:results (value :scs (single-reg)))
+ (:result-types single-float)
+ (:generator 5
+ (with-empty-tn@fp-top(value)
+ (inst fld (make-ea :dword :base object :index index :scale 1
+ :disp (- (* sb!vm:vector-data-offset sb!vm:word-bytes)
+ sb!vm:other-pointer-type))))))
+
+(define-vop (data-vector-ref-c/simple-array-single-float)
+ (:note "inline array access")
+ (:translate data-vector-ref)
+ (:policy :fast-safe)
+ (:args (object :scs (descriptor-reg)))
+ (:info index)
+ (:arg-types simple-array-single-float (:constant (signed-byte 30)))
+ (:results (value :scs (single-reg)))
+ (:result-types single-float)
+ (:generator 4
+ (with-empty-tn@fp-top(value)
+ (inst fld (make-ea :dword :base object
+ :disp (- (+ (* sb!vm:vector-data-offset
+ sb!vm:word-bytes)
+ (* 4 index))
+ sb!vm:other-pointer-type))))))
+
+(define-vop (data-vector-set/simple-array-single-float)
+ (:note "inline array store")
+ (:translate data-vector-set)
+ (:policy :fast-safe)
+ (:args (object :scs (descriptor-reg))
+ (index :scs (any-reg))
+ (value :scs (single-reg) :target result))
+ (:arg-types simple-array-single-float positive-fixnum single-float)
+ (:results (result :scs (single-reg)))
+ (:result-types single-float)
+ (:generator 5
+ (cond ((zerop (tn-offset value))
+ ;; Value is in ST0
+ (inst fst (make-ea :dword :base object :index index :scale 1
+ :disp (- (* sb!vm:vector-data-offset
+ sb!vm:word-bytes)
+ sb!vm:other-pointer-type)))
+ (unless (zerop (tn-offset result))
+ ;; Value is in ST0 but not result.
+ (inst fst result)))
+ (t
+ ;; Value is not in ST0.
+ (inst fxch value)
+ (inst fst (make-ea :dword :base object :index index :scale 1
+ :disp (- (* sb!vm:vector-data-offset
+ sb!vm:word-bytes)
+ sb!vm:other-pointer-type)))
+ (cond ((zerop (tn-offset result))
+ ;; The result is in ST0.
+ (inst fst value))
+ (t
+ ;; Neither value or result are in ST0
+ (unless (location= value result)
+ (inst fst result))
+ (inst fxch value)))))))
+
+(define-vop (data-vector-set-c/simple-array-single-float)
+ (:note "inline array store")
+ (:translate data-vector-set)
+ (:policy :fast-safe)
+ (:args (object :scs (descriptor-reg))
+ (value :scs (single-reg) :target result))
+ (:info index)
+ (:arg-types simple-array-single-float (:constant (signed-byte 30))
+ single-float)
+ (:results (result :scs (single-reg)))
+ (:result-types single-float)
+ (:generator 4
+ (cond ((zerop (tn-offset value))
+ ;; Value is in ST0
+ (inst fst (make-ea :dword :base object
+ :disp (- (+ (* sb!vm:vector-data-offset
+ sb!vm:word-bytes)
+ (* 4 index))
+ sb!vm:other-pointer-type)))
+ (unless (zerop (tn-offset result))
+ ;; Value is in ST0 but not result.
+ (inst fst result)))
+ (t
+ ;; Value is not in ST0.
+ (inst fxch value)
+ (inst fst (make-ea :dword :base object
+ :disp (- (+ (* sb!vm:vector-data-offset
+ sb!vm:word-bytes)
+ (* 4 index))
+ sb!vm:other-pointer-type)))
+ (cond ((zerop (tn-offset result))
+ ;; The result is in ST0.
+ (inst fst value))
+ (t
+ ;; Neither value or result are in ST0
+ (unless (location= value result)
+ (inst fst result))
+ (inst fxch value)))))))
+
+(define-vop (data-vector-ref/simple-array-double-float)
+ (:note "inline array access")
+ (:translate data-vector-ref)
+ (:policy :fast-safe)
+ (:args (object :scs (descriptor-reg))
+ (index :scs (any-reg)))
+ (:arg-types simple-array-double-float positive-fixnum)
+ (:results (value :scs (double-reg)))
+ (:result-types double-float)
+ (:generator 7
+ (with-empty-tn@fp-top(value)
+ (inst fldd (make-ea :dword :base object :index index :scale 2
+ :disp (- (* sb!vm:vector-data-offset sb!vm:word-bytes)
+ sb!vm:other-pointer-type))))))
+
+(define-vop (data-vector-ref-c/simple-array-double-float)
+ (:note "inline array access")
+ (:translate data-vector-ref)
+ (:policy :fast-safe)
+ (:args (object :scs (descriptor-reg)))
+ (:info index)
+ (:arg-types simple-array-double-float (:constant (signed-byte 30)))
+ (:results (value :scs (double-reg)))
+ (:result-types double-float)
+ (:generator 6
+ (with-empty-tn@fp-top(value)
+ (inst fldd (make-ea :dword :base object
+ :disp (- (+ (* sb!vm:vector-data-offset
+ sb!vm:word-bytes)
+ (* 8 index))
+ sb!vm:other-pointer-type))))))
+
+(define-vop (data-vector-set/simple-array-double-float)
+ (:note "inline array store")
+ (:translate data-vector-set)
+ (:policy :fast-safe)
+ (:args (object :scs (descriptor-reg))
+ (index :scs (any-reg))
+ (value :scs (double-reg) :target result))
+ (:arg-types simple-array-double-float positive-fixnum double-float)
+ (:results (result :scs (double-reg)))
+ (:result-types double-float)
+ (:generator 20
+ (cond ((zerop (tn-offset value))
+ ;; Value is in ST0
+ (inst fstd (make-ea :dword :base object :index index :scale 2
+ :disp (- (* sb!vm:vector-data-offset
+ sb!vm:word-bytes)
+ sb!vm:other-pointer-type)))
+ (unless (zerop (tn-offset result))
+ ;; Value is in ST0 but not result.
+ (inst fstd result)))
+ (t
+ ;; Value is not in ST0.
+ (inst fxch value)
+ (inst fstd (make-ea :dword :base object :index index :scale 2
+ :disp (- (* sb!vm:vector-data-offset
+ sb!vm:word-bytes)
+ sb!vm:other-pointer-type)))
+ (cond ((zerop (tn-offset result))
+ ;; The result is in ST0.
+ (inst fstd value))
+ (t
+ ;; Neither value or result are in ST0
+ (unless (location= value result)
+ (inst fstd result))
+ (inst fxch value)))))))
+
+(define-vop (data-vector-set-c/simple-array-double-float)
+ (:note "inline array store")
+ (:translate data-vector-set)
+ (:policy :fast-safe)
+ (:args (object :scs (descriptor-reg))
+ (value :scs (double-reg) :target result))
+ (:info index)
+ (:arg-types simple-array-double-float (:constant (signed-byte 30))
+ double-float)
+ (:results (result :scs (double-reg)))
+ (:result-types double-float)
+ (:generator 19
+ (cond ((zerop (tn-offset value))
+ ;; Value is in ST0
+ (inst fstd (make-ea :dword :base object
+ :disp (- (+ (* sb!vm:vector-data-offset
+ sb!vm:word-bytes)
+ (* 8 index))
+ sb!vm:other-pointer-type)))
+ (unless (zerop (tn-offset result))
+ ;; Value is in ST0 but not result.
+ (inst fstd result)))
+ (t
+ ;; Value is not in ST0.
+ (inst fxch value)
+ (inst fstd (make-ea :dword :base object
+ :disp (- (+ (* sb!vm:vector-data-offset
+ sb!vm:word-bytes)
+ (* 8 index))
+ sb!vm:other-pointer-type)))
+ (cond ((zerop (tn-offset result))
+ ;; The result is in ST0.
+ (inst fstd value))
+ (t
+ ;; Neither value or result are in ST0
+ (unless (location= value result)
+ (inst fstd result))
+ (inst fxch value)))))))
+
+#!+long-float
+(define-vop (data-vector-ref/simple-array-long-float)
+ (:note "inline array access")
+ (:translate data-vector-ref)
+ (:policy :fast-safe)
+ (:args (object :scs (descriptor-reg) :to :result)
+ (index :scs (any-reg)))
+ (:arg-types simple-array-long-float positive-fixnum)
+ (:temporary (:sc any-reg :from :eval :to :result) temp)
+ (:results (value :scs (long-reg)))
+ (:result-types long-float)
+ (:generator 7
+ ;; temp = 3 * index
+ (inst lea temp (make-ea :dword :base index :index index :scale 2))
+ (with-empty-tn@fp-top(value)
+ (inst fldl (make-ea :dword :base object :index temp :scale 1
+ :disp (- (* sb!vm:vector-data-offset
+ sb!vm:word-bytes)
+ sb!vm:other-pointer-type))))))
+
+#!+long-float
+(define-vop (data-vector-ref-c/simple-array-long-float)
+ (:note "inline array access")
+ (:translate data-vector-ref)
+ (:policy :fast-safe)
+ (:args (object :scs (descriptor-reg)))
+ (:info index)
+ (:arg-types simple-array-long-float (:constant (signed-byte 30)))
+ (:results (value :scs (long-reg)))
+ (:result-types long-float)
+ (:generator 6
+ (with-empty-tn@fp-top(value)
+ (inst fldl (make-ea :dword :base object
+ :disp (- (+ (* sb!vm:vector-data-offset
+ sb!vm:word-bytes)
+ (* 12 index))
+ sb!vm:other-pointer-type))))))
+
+#!+long-float
+(define-vop (data-vector-set/simple-array-long-float)
+ (:note "inline array store")
+ (:translate data-vector-set)
+ (:policy :fast-safe)
+ (:args (object :scs (descriptor-reg) :to :result)
+ (index :scs (any-reg))
+ (value :scs (long-reg) :target result))
+ (:arg-types simple-array-long-float positive-fixnum long-float)
+ (:temporary (:sc any-reg :from (:argument 1) :to :result) temp)
+ (:results (result :scs (long-reg)))
+ (:result-types long-float)
+ (:generator 20
+ ;; temp = 3 * index
+ (inst lea temp (make-ea :dword :base index :index index :scale 2))
+ (cond ((zerop (tn-offset value))
+ ;; Value is in ST0
+ (store-long-float
+ (make-ea :dword :base object :index temp :scale 1
+ :disp (- (* sb!vm:vector-data-offset sb!vm:word-bytes)
+ sb!vm:other-pointer-type)))
+ (unless (zerop (tn-offset result))
+ ;; Value is in ST0 but not result.
+ (inst fstd result)))
+ (t
+ ;; Value is not in ST0.
+ (inst fxch value)
+ (store-long-float
+ (make-ea :dword :base object :index temp :scale 1
+ :disp (- (* sb!vm:vector-data-offset sb!vm:word-bytes)
+ sb!vm:other-pointer-type)))
+ (cond ((zerop (tn-offset result))
+ ;; The result is in ST0.
+ (inst fstd value))
+ (t
+ ;; Neither value or result are in ST0
+ (unless (location= value result)
+ (inst fstd result))
+ (inst fxch value)))))))
+
+#!+long-float
+(define-vop (data-vector-set-c/simple-array-long-float)
+ (:note "inline array store")
+ (:translate data-vector-set)
+ (:policy :fast-safe)
+ (:args (object :scs (descriptor-reg))
+ (value :scs (long-reg) :target result))
+ (:info index)
+ (:arg-types simple-array-long-float (:constant (signed-byte 30)) long-float)
+ (:results (result :scs (long-reg)))
+ (:result-types long-float)
+ (:generator 19
+ (cond ((zerop (tn-offset value))
+ ;; Value is in ST0
+ (store-long-float (make-ea :dword :base object
+ :disp (- (+ (* sb!vm:vector-data-offset
+ sb!vm:word-bytes)
+ (* 12 index))
+ sb!vm:other-pointer-type)))
+ (unless (zerop (tn-offset result))
+ ;; Value is in ST0 but not result.
+ (inst fstd result)))
+ (t
+ ;; Value is not in ST0.
+ (inst fxch value)
+ (store-long-float (make-ea :dword :base object
+ :disp (- (+ (* sb!vm:vector-data-offset
+ sb!vm:word-bytes)
+ (* 12 index))
+ sb!vm:other-pointer-type)))
+ (cond ((zerop (tn-offset result))
+ ;; The result is in ST0.
+ (inst fstd value))
+ (t
+ ;; Neither value or result are in ST0
+ (unless (location= value result)
+ (inst fstd result))
+ (inst fxch value)))))))
+
+;;; complex float variants
+
+(define-vop (data-vector-ref/simple-array-complex-single-float)
+ (:note "inline array access")
+ (:translate data-vector-ref)
+ (:policy :fast-safe)
+ (:args (object :scs (descriptor-reg))
+ (index :scs (any-reg)))
+ (:arg-types simple-array-complex-single-float positive-fixnum)
+ (:results (value :scs (complex-single-reg)))
+ (:result-types complex-single-float)
+ (:generator 5
+ (let ((real-tn (complex-single-reg-real-tn value)))
+ (with-empty-tn@fp-top (real-tn)
+ (inst fld (make-ea :dword :base object :index index :scale 2
+ :disp (- (* sb!vm:vector-data-offset
+ sb!vm:word-bytes)
+ sb!vm:other-pointer-type)))))
+ (let ((imag-tn (complex-single-reg-imag-tn value)))
+ (with-empty-tn@fp-top (imag-tn)
+ (inst fld (make-ea :dword :base object :index index :scale 2
+ :disp (- (* (1+ sb!vm:vector-data-offset)
+ sb!vm:word-bytes)
+ sb!vm:other-pointer-type)))))))
+
+(define-vop (data-vector-ref-c/simple-array-complex-single-float)
+ (:note "inline array access")
+ (:translate data-vector-ref)
+ (:policy :fast-safe)
+ (:args (object :scs (descriptor-reg)))
+ (:info index)
+ (:arg-types simple-array-complex-single-float (:constant (signed-byte 30)))
+ (:results (value :scs (complex-single-reg)))
+ (:result-types complex-single-float)
+ (:generator 4
+ (let ((real-tn (complex-single-reg-real-tn value)))
+ (with-empty-tn@fp-top (real-tn)
+ (inst fld (make-ea :dword :base object
+ :disp (- (+ (* sb!vm:vector-data-offset
+ sb!vm:word-bytes)
+ (* 8 index))
+ sb!vm:other-pointer-type)))))
+ (let ((imag-tn (complex-single-reg-imag-tn value)))
+ (with-empty-tn@fp-top (imag-tn)
+ (inst fld (make-ea :dword :base object
+ :disp (- (+ (* sb!vm:vector-data-offset
+ sb!vm:word-bytes)
+ (* 8 index) 4)
+ sb!vm:other-pointer-type)))))))
+
+(define-vop (data-vector-set/simple-array-complex-single-float)
+ (:note "inline array store")
+ (:translate data-vector-set)
+ (:policy :fast-safe)
+ (:args (object :scs (descriptor-reg))
+ (index :scs (any-reg))
+ (value :scs (complex-single-reg) :target result))
+ (:arg-types simple-array-complex-single-float positive-fixnum
+ complex-single-float)
+ (:results (result :scs (complex-single-reg)))
+ (:result-types complex-single-float)
+ (:generator 5
+ (let ((value-real (complex-single-reg-real-tn value))
+ (result-real (complex-single-reg-real-tn result)))
+ (cond ((zerop (tn-offset value-real))
+ ;; Value is in ST0.
+ (inst fst (make-ea :dword :base object :index index :scale 2
+ :disp (- (* sb!vm:vector-data-offset
+ sb!vm:word-bytes)
+ sb!vm:other-pointer-type)))
+ (unless (zerop (tn-offset result-real))
+ ;; Value is in ST0 but not result.
+ (inst fst result-real)))
+ (t
+ ;; Value is not in ST0.
+ (inst fxch value-real)
+ (inst fst (make-ea :dword :base object :index index :scale 2
+ :disp (- (* sb!vm:vector-data-offset
+ sb!vm:word-bytes)
+ sb!vm:other-pointer-type)))
+ (cond ((zerop (tn-offset result-real))
+ ;; The result is in ST0.
+ (inst fst value-real))
+ (t
+ ;; Neither value or result are in ST0
+ (unless (location= value-real result-real)
+ (inst fst result-real))
+ (inst fxch value-real))))))
+ (let ((value-imag (complex-single-reg-imag-tn value))
+ (result-imag (complex-single-reg-imag-tn result)))
+ (inst fxch value-imag)
+ (inst fst (make-ea :dword :base object :index index :scale 2
+ :disp (- (+ (* sb!vm:vector-data-offset
+ sb!vm:word-bytes)
+ 4)
+ sb!vm:other-pointer-type)))
+ (unless (location= value-imag result-imag)
+ (inst fst result-imag))
+ (inst fxch value-imag))))
+
+(define-vop (data-vector-set-c/simple-array-complex-single-float)
+ (:note "inline array store")
+ (:translate data-vector-set)
+ (:policy :fast-safe)
+ (:args (object :scs (descriptor-reg))
+ (value :scs (complex-single-reg) :target result))
+ (:info index)
+ (:arg-types simple-array-complex-single-float (:constant (signed-byte 30))
+ complex-single-float)
+ (:results (result :scs (complex-single-reg)))
+ (:result-types complex-single-float)
+ (:generator 4
+ (let ((value-real (complex-single-reg-real-tn value))
+ (result-real (complex-single-reg-real-tn result)))
+ (cond ((zerop (tn-offset value-real))
+ ;; Value is in ST0
+ (inst fst (make-ea :dword :base object
+ :disp (- (+ (* sb!vm:vector-data-offset
+ sb!vm:word-bytes)
+ (* 8 index))
+ sb!vm:other-pointer-type)))
+ (unless (zerop (tn-offset result-real))
+ ;; Value is in ST0 but not result.
+ (inst fst result-real)))
+ (t
+ ;; Value is not in ST0.
+ (inst fxch value-real)
+ (inst fst (make-ea :dword :base object
+ :disp (- (+ (* sb!vm:vector-data-offset
+ sb!vm:word-bytes)
+ (* 8 index))
+ sb!vm:other-pointer-type)))
+ (cond ((zerop (tn-offset result-real))
+ ;; The result is in ST0.
+ (inst fst value-real))
+ (t
+ ;; Neither value or result are in ST0
+ (unless (location= value-real result-real)
+ (inst fst result-real))
+ (inst fxch value-real))))))
+ (let ((value-imag (complex-single-reg-imag-tn value))
+ (result-imag (complex-single-reg-imag-tn result)))
+ (inst fxch value-imag)
+ (inst fst (make-ea :dword :base object
+ :disp (- (+ (* sb!vm:vector-data-offset
+ sb!vm:word-bytes)
+ (* 8 index) 4)
+ sb!vm:other-pointer-type)))
+ (unless (location= value-imag result-imag)
+ (inst fst result-imag))
+ (inst fxch value-imag))))
+
+
+(define-vop (data-vector-ref/simple-array-complex-double-float)
+ (:note "inline array access")
+ (:translate data-vector-ref)
+ (:policy :fast-safe)
+ (:args (object :scs (descriptor-reg))
+ (index :scs (any-reg)))
+ (:arg-types simple-array-complex-double-float positive-fixnum)
+ (:results (value :scs (complex-double-reg)))
+ (:result-types complex-double-float)
+ (:generator 7
+ (let ((real-tn (complex-double-reg-real-tn value)))
+ (with-empty-tn@fp-top (real-tn)
+ (inst fldd (make-ea :dword :base object :index index :scale 4
+ :disp (- (* sb!vm:vector-data-offset
+ sb!vm:word-bytes)
+ sb!vm:other-pointer-type)))))
+ (let ((imag-tn (complex-double-reg-imag-tn value)))
+ (with-empty-tn@fp-top (imag-tn)
+ (inst fldd (make-ea :dword :base object :index index :scale 4
+ :disp (- (+ (* sb!vm:vector-data-offset
+ sb!vm:word-bytes)
+ 8)
+ sb!vm:other-pointer-type)))))))
+
+(define-vop (data-vector-ref-c/simple-array-complex-double-float)
+ (:note "inline array access")
+ (:translate data-vector-ref)
+ (:policy :fast-safe)
+ (:args (object :scs (descriptor-reg)))
+ (:info index)
+ (:arg-types simple-array-complex-double-float (:constant (signed-byte 30)))
+ (:results (value :scs (complex-double-reg)))
+ (:result-types complex-double-float)
+ (:generator 6
+ (let ((real-tn (complex-double-reg-real-tn value)))
+ (with-empty-tn@fp-top (real-tn)
+ (inst fldd (make-ea :dword :base object
+ :disp (- (+ (* sb!vm:vector-data-offset
+ sb!vm:word-bytes)
+ (* 16 index))
+ sb!vm:other-pointer-type)))))
+ (let ((imag-tn (complex-double-reg-imag-tn value)))
+ (with-empty-tn@fp-top (imag-tn)
+ (inst fldd (make-ea :dword :base object
+ :disp (- (+ (* sb!vm:vector-data-offset
+ sb!vm:word-bytes)
+ (* 16 index) 8)
+ sb!vm:other-pointer-type)))))))
+
+(define-vop (data-vector-set/simple-array-complex-double-float)
+ (:note "inline array store")
+ (:translate data-vector-set)
+ (:policy :fast-safe)
+ (:args (object :scs (descriptor-reg))
+ (index :scs (any-reg))
+ (value :scs (complex-double-reg) :target result))
+ (:arg-types simple-array-complex-double-float positive-fixnum
+ complex-double-float)
+ (:results (result :scs (complex-double-reg)))
+ (:result-types complex-double-float)
+ (:generator 20
+ (let ((value-real (complex-double-reg-real-tn value))
+ (result-real (complex-double-reg-real-tn result)))
+ (cond ((zerop (tn-offset value-real))
+ ;; Value is in ST0
+ (inst fstd (make-ea :dword :base object :index index :scale 4
+ :disp (- (* sb!vm:vector-data-offset
+ sb!vm:word-bytes)
+ sb!vm:other-pointer-type)))
+ (unless (zerop (tn-offset result-real))
+ ;; Value is in ST0 but not result.
+ (inst fstd result-real)))
+ (t
+ ;; Value is not in ST0.
+ (inst fxch value-real)
+ (inst fstd (make-ea :dword :base object :index index :scale 4
+ :disp (- (* sb!vm:vector-data-offset
+ sb!vm:word-bytes)
+ sb!vm:other-pointer-type)))
+ (cond ((zerop (tn-offset result-real))
+ ;; The result is in ST0.
+ (inst fstd value-real))
+ (t
+ ;; Neither value or result are in ST0
+ (unless (location= value-real result-real)
+ (inst fstd result-real))
+ (inst fxch value-real))))))
+ (let ((value-imag (complex-double-reg-imag-tn value))
+ (result-imag (complex-double-reg-imag-tn result)))
+ (inst fxch value-imag)
+ (inst fstd (make-ea :dword :base object :index index :scale 4
+ :disp (- (+ (* sb!vm:vector-data-offset
+ sb!vm:word-bytes)
+ 8)
+ sb!vm:other-pointer-type)))
+ (unless (location= value-imag result-imag)
+ (inst fstd result-imag))
+ (inst fxch value-imag))))
+
+(define-vop (data-vector-set-c/simple-array-complex-double-float)
+ (:note "inline array store")
+ (:translate data-vector-set)
+ (:policy :fast-safe)
+ (:args (object :scs (descriptor-reg))
+ (value :scs (complex-double-reg) :target result))
+ (:info index)
+ (:arg-types simple-array-complex-double-float (:constant (signed-byte 30))
+ complex-double-float)
+ (:results (result :scs (complex-double-reg)))
+ (:result-types complex-double-float)
+ (:generator 19
+ (let ((value-real (complex-double-reg-real-tn value))
+ (result-real (complex-double-reg-real-tn result)))
+ (cond ((zerop (tn-offset value-real))
+ ;; Value is in ST0
+ (inst fstd (make-ea :dword :base object
+ :disp (- (+ (* sb!vm:vector-data-offset
+ sb!vm:word-bytes)
+ (* 16 index))
+ sb!vm:other-pointer-type)))
+ (unless (zerop (tn-offset result-real))
+ ;; Value is in ST0 but not result.
+ (inst fstd result-real)))
+ (t
+ ;; Value is not in ST0.
+ (inst fxch value-real)
+ (inst fstd (make-ea :dword :base object
+ :disp (- (+ (* sb!vm:vector-data-offset
+ sb!vm:word-bytes)
+ (* 16 index))
+ sb!vm:other-pointer-type)))
+ (cond ((zerop (tn-offset result-real))
+ ;; The result is in ST0.
+ (inst fstd value-real))
+ (t
+ ;; Neither value or result are in ST0
+ (unless (location= value-real result-real)
+ (inst fstd result-real))
+ (inst fxch value-real))))))
+ (let ((value-imag (complex-double-reg-imag-tn value))
+ (result-imag (complex-double-reg-imag-tn result)))
+ (inst fxch value-imag)
+ (inst fstd (make-ea :dword :base object
+ :disp (- (+ (* sb!vm:vector-data-offset
+ sb!vm:word-bytes)
+ (* 16 index) 8)
+ sb!vm:other-pointer-type)))
+ (unless (location= value-imag result-imag)
+ (inst fstd result-imag))
+ (inst fxch value-imag))))
+
+
+#!+long-float
+(define-vop (data-vector-ref/simple-array-complex-long-float)
+ (:note "inline array access")
+ (:translate data-vector-ref)
+ (:policy :fast-safe)
+ (:args (object :scs (descriptor-reg) :to :result)
+ (index :scs (any-reg)))
+ (:arg-types simple-array-complex-long-float positive-fixnum)
+ (:temporary (:sc any-reg :from :eval :to :result) temp)
+ (:results (value :scs (complex-long-reg)))
+ (:result-types complex-long-float)
+ (:generator 7
+ ;; temp = 3 * index
+ (inst lea temp (make-ea :dword :base index :index index :scale 2))
+ (let ((real-tn (complex-long-reg-real-tn value)))
+ (with-empty-tn@fp-top (real-tn)
+ (inst fldl (make-ea :dword :base object :index temp :scale 2
+ :disp (- (* sb!vm:vector-data-offset
+ sb!vm:word-bytes)
+ sb!vm:other-pointer-type)))))
+ (let ((imag-tn (complex-long-reg-imag-tn value)))
+ (with-empty-tn@fp-top (imag-tn)
+ (inst fldl (make-ea :dword :base object :index temp :scale 2
+ :disp (- (+ (* sb!vm:vector-data-offset
+ sb!vm:word-bytes)
+ 12)
+ sb!vm:other-pointer-type)))))))
+
+#!+long-float
+(define-vop (data-vector-ref-c/simple-array-complex-long-float)
+ (:note "inline array access")
+ (:translate data-vector-ref)
+ (:policy :fast-safe)
+ (:args (object :scs (descriptor-reg)))
+ (:info index)
+ (:arg-types simple-array-complex-long-float (:constant (signed-byte 30)))
+ (:results (value :scs (complex-long-reg)))
+ (:result-types complex-long-float)
+ (:generator 6
+ (let ((real-tn (complex-long-reg-real-tn value)))
+ (with-empty-tn@fp-top (real-tn)
+ (inst fldl (make-ea :dword :base object
+ :disp (- (+ (* sb!vm:vector-data-offset
+ sb!vm:word-bytes)
+ (* 24 index))
+ sb!vm:other-pointer-type)))))
+ (let ((imag-tn (complex-long-reg-imag-tn value)))
+ (with-empty-tn@fp-top (imag-tn)
+ (inst fldl (make-ea :dword :base object
+ :disp (- (+ (* sb!vm:vector-data-offset
+ sb!vm:word-bytes)
+ (* 24 index) 12)
+ sb!vm:other-pointer-type)))))))
+
+#!+long-float
+(define-vop (data-vector-set/simple-array-complex-long-float)
+ (:note "inline array store")
+ (:translate data-vector-set)
+ (:policy :fast-safe)
+ (:args (object :scs (descriptor-reg) :to :result)
+ (index :scs (any-reg))
+ (value :scs (complex-long-reg) :target result))
+ (:arg-types simple-array-complex-long-float positive-fixnum
+ complex-long-float)
+ (:temporary (:sc any-reg :from (:argument 1) :to :result) temp)
+ (:results (result :scs (complex-long-reg)))
+ (:result-types complex-long-float)
+ (:generator 20
+ ;; temp = 3 * index
+ (inst lea temp (make-ea :dword :base index :index index :scale 2))
+ (let ((value-real (complex-long-reg-real-tn value))
+ (result-real (complex-long-reg-real-tn result)))
+ (cond ((zerop (tn-offset value-real))
+ ;; Value is in ST0
+ (store-long-float
+ (make-ea :dword :base object :index temp :scale 2
+ :disp (- (* sb!vm:vector-data-offset sb!vm:word-bytes)
+ sb!vm:other-pointer-type)))
+ (unless (zerop (tn-offset result-real))
+ ;; Value is in ST0 but not result.
+ (inst fstd result-real)))
+ (t
+ ;; Value is not in ST0.
+ (inst fxch value-real)
+ (store-long-float
+ (make-ea :dword :base object :index temp :scale 2
+ :disp (- (* sb!vm:vector-data-offset sb!vm:word-bytes)
+ sb!vm:other-pointer-type)))
+ (cond ((zerop (tn-offset result-real))
+ ;; The result is in ST0.
+ (inst fstd value-real))
+ (t
+ ;; Neither value or result are in ST0
+ (unless (location= value-real result-real)
+ (inst fstd result-real))
+ (inst fxch value-real))))))
+ (let ((value-imag (complex-long-reg-imag-tn value))
+ (result-imag (complex-long-reg-imag-tn result)))
+ (inst fxch value-imag)
+ (store-long-float
+ (make-ea :dword :base object :index temp :scale 2
+ :disp (- (+ (* sb!vm:vector-data-offset sb!vm:word-bytes) 12)
+ sb!vm:other-pointer-type)))
+ (unless (location= value-imag result-imag)
+ (inst fstd result-imag))
+ (inst fxch value-imag))))
+
+#!+long-float
+(define-vop (data-vector-set-c/simple-array-complex-long-float)
+ (:note "inline array store")
+ (:translate data-vector-set)
+ (:policy :fast-safe)
+ (:args (object :scs (descriptor-reg))
+ (value :scs (complex-long-reg) :target result))
+ (:info index)
+ (:arg-types simple-array-complex-long-float (:constant (signed-byte 30))
+ complex-long-float)
+ (:results (result :scs (complex-long-reg)))
+ (:result-types complex-long-float)
+ (:generator 19
+ (let ((value-real (complex-long-reg-real-tn value))
+ (result-real (complex-long-reg-real-tn result)))
+ (cond ((zerop (tn-offset value-real))
+ ;; Value is in ST0
+ (store-long-float
+ (make-ea :dword :base object
+ :disp (- (+ (* sb!vm:vector-data-offset
+ sb!vm:word-bytes)
+ (* 24 index))
+ sb!vm:other-pointer-type)))
+ (unless (zerop (tn-offset result-real))
+ ;; Value is in ST0 but not result.
+ (inst fstd result-real)))
+ (t
+ ;; Value is not in ST0.
+ (inst fxch value-real)
+ (store-long-float
+ (make-ea :dword :base object
+ :disp (- (+ (* sb!vm:vector-data-offset
+ sb!vm:word-bytes)
+ (* 24 index))
+ sb!vm:other-pointer-type)))
+ (cond ((zerop (tn-offset result-real))
+ ;; The result is in ST0.
+ (inst fstd value-real))
+ (t
+ ;; Neither value or result are in ST0
+ (unless (location= value-real result-real)
+ (inst fstd result-real))
+ (inst fxch value-real))))))
+ (let ((value-imag (complex-long-reg-imag-tn value))
+ (result-imag (complex-long-reg-imag-tn result)))
+ (inst fxch value-imag)
+ (store-long-float
+ (make-ea :dword :base object
+ :disp (- (+ (* sb!vm:vector-data-offset
+ sb!vm:word-bytes)
+ ;; FIXME: There are so many of these bare constants
+ ;; (24, 12..) in the LONG-FLOAT code that it's
+ ;; ridiculous. I should probably just delete it all
+ ;; instead of appearing to flirt with supporting
+ ;; this maintenance nightmare.
+ (* 24 index) 12)
+ sb!vm:other-pointer-type)))
+ (unless (location= value-imag result-imag)
+ (inst fstd result-imag))
+ (inst fxch value-imag))))
+
+\f
+;;;; dtc expanded and fixed the following:
+
+;;; unsigned-byte-8
+
+(define-vop (data-vector-ref/simple-array-unsigned-byte-8)
+ (:translate data-vector-ref)
+ (:policy :fast-safe)
+ (:args (object :scs (descriptor-reg))
+ (index :scs (unsigned-reg)))
+ (:arg-types simple-array-unsigned-byte-8 positive-fixnum)
+ (:results (value :scs (unsigned-reg signed-reg)))
+ (:result-types positive-fixnum)
+ (:generator 5
+ (inst movzx value
+ (make-ea :byte :base object :index index :scale 1
+ :disp (- (* vector-data-offset word-bytes)
+ other-pointer-type)))))
+
+(define-vop (data-vector-ref-c/simple-array-unsigned-byte-8)
+ (:translate data-vector-ref)
+ (:policy :fast-safe)
+ (:args (object :scs (descriptor-reg)))
+ (:info index)
+ (:arg-types simple-array-unsigned-byte-8 (:constant (signed-byte 30)))
+ (:results (value :scs (unsigned-reg signed-reg)))
+ (:result-types positive-fixnum)
+ (:generator 4
+ (inst movzx value
+ (make-ea :byte :base object
+ :disp (- (+ (* vector-data-offset word-bytes) index)
+ other-pointer-type)))))
+
+(define-vop (data-vector-set/simple-array-unsigned-byte-8)
+ (:translate data-vector-set)
+ (:policy :fast-safe)
+ (:args (object :scs (descriptor-reg) :to (:eval 0))
+ (index :scs (unsigned-reg) :to (:eval 0))
+ (value :scs (unsigned-reg signed-reg) :target eax))
+ (:arg-types simple-array-unsigned-byte-8 positive-fixnum positive-fixnum)
+ (:temporary (:sc unsigned-reg :offset eax-offset :target result
+ :from (:argument 2) :to (:result 0))
+ eax)
+ (:results (result :scs (unsigned-reg signed-reg)))
+ (:result-types positive-fixnum)
+ (:generator 5
+ (move eax value)
+ (inst mov (make-ea :byte :base object :index index :scale 1
+ :disp (- (* vector-data-offset word-bytes)
+ other-pointer-type))
+ al-tn)
+ (move result eax)))
+
+(define-vop (data-vector-set-c/simple-array-unsigned-byte-8)
+ (:translate data-vector-set)
+ (:policy :fast-safe)
+ (:args (object :scs (descriptor-reg) :to (:eval 0))
+ (value :scs (unsigned-reg signed-reg) :target eax))
+ (:info index)
+ (:arg-types simple-array-unsigned-byte-8 (:constant (signed-byte 30))
+ positive-fixnum)
+ (:temporary (:sc unsigned-reg :offset eax-offset :target result
+ :from (:argument 1) :to (:result 0))
+ eax)
+ (:results (result :scs (unsigned-reg signed-reg)))
+ (:result-types positive-fixnum)
+ (:generator 4
+ (move eax value)
+ (inst mov (make-ea :byte :base object
+ :disp (- (+ (* vector-data-offset word-bytes) index)
+ other-pointer-type))
+ al-tn)
+ (move result eax)))
+
+;;; unsigned-byte-16
+
+(define-vop (data-vector-ref/simple-array-unsigned-byte-16)
+ (:translate data-vector-ref)
+ (:policy :fast-safe)
+ (:args (object :scs (descriptor-reg))
+ (index :scs (unsigned-reg)))
+ (:arg-types simple-array-unsigned-byte-16 positive-fixnum)
+ (:results (value :scs (unsigned-reg signed-reg)))
+ (:result-types positive-fixnum)
+ (:generator 5
+ (inst movzx value
+ (make-ea :word :base object :index index :scale 2
+ :disp (- (* vector-data-offset word-bytes)
+ other-pointer-type)))))
+
+(define-vop (data-vector-ref-c/simple-array-unsigned-byte-16)
+ (:translate data-vector-ref)
+ (:policy :fast-safe)
+ (:args (object :scs (descriptor-reg)))
+ (:info index)
+ (:arg-types simple-array-unsigned-byte-16 (:constant (signed-byte 30)))
+ (:results (value :scs (unsigned-reg signed-reg)))
+ (:result-types positive-fixnum)
+ (:generator 4
+ (inst movzx value
+ (make-ea :word :base object
+ :disp (- (+ (* vector-data-offset word-bytes) (* 2 index))
+ other-pointer-type)))))
+
+(define-vop (data-vector-set/simple-array-unsigned-byte-16)
+ (:translate data-vector-set)
+ (:policy :fast-safe)
+ (:args (object :scs (descriptor-reg) :to (:eval 0))
+ (index :scs (unsigned-reg) :to (:eval 0))
+ (value :scs (unsigned-reg signed-reg) :target eax))
+ (:arg-types simple-array-unsigned-byte-16 positive-fixnum positive-fixnum)
+ (:temporary (:sc unsigned-reg :offset eax-offset :target result
+ :from (:argument 2) :to (:result 0))
+ eax)
+ (:results (result :scs (unsigned-reg signed-reg)))
+ (:result-types positive-fixnum)
+ (:generator 5
+ (move eax value)
+ (inst mov (make-ea :word :base object :index index :scale 2
+ :disp (- (* vector-data-offset word-bytes)
+ other-pointer-type))
+ ax-tn)
+ (move result eax)))
+
+(define-vop (data-vector-set-c/simple-array-unsigned-byte-16)
+ (:translate data-vector-set)
+ (:policy :fast-safe)
+ (:args (object :scs (descriptor-reg) :to (:eval 0))
+ (value :scs (unsigned-reg signed-reg) :target eax))
+ (:info index)
+ (:arg-types simple-array-unsigned-byte-16 (:constant (signed-byte 30))
+ positive-fixnum)
+ (:temporary (:sc unsigned-reg :offset eax-offset :target result
+ :from (:argument 1) :to (:result 0))
+ eax)
+ (:results (result :scs (unsigned-reg signed-reg)))
+ (:result-types positive-fixnum)
+ (:generator 4
+ (move eax value)
+ (inst mov (make-ea :word :base object
+ :disp (- (+ (* vector-data-offset word-bytes)
+ (* 2 index))
+ other-pointer-type))
+ ax-tn)
+ (move result eax)))
+
+;;; simple-string
+
+(define-vop (data-vector-ref/simple-string)
+ (:translate data-vector-ref)
+ (:policy :fast-safe)
+ (:args (object :scs (descriptor-reg))
+ (index :scs (unsigned-reg)))
+ (:arg-types simple-string positive-fixnum)
+ (:temporary (:sc unsigned-reg ; byte-reg
+ :offset eax-offset ; al-offset
+ :target value
+ :from (:eval 0) :to (:result 0))
+ eax)
+ (:ignore eax)
+ (:results (value :scs (base-char-reg)))
+ (:result-types base-char)
+ (:generator 5
+ (inst mov al-tn
+ (make-ea :byte :base object :index index :scale 1
+ :disp (- (* vector-data-offset word-bytes)
+ other-pointer-type)))
+ (move value al-tn)))
+
+(define-vop (data-vector-ref-c/simple-string)
+ (:translate data-vector-ref)
+ (:policy :fast-safe)
+ (:args (object :scs (descriptor-reg)))
+ (:info index)
+ (:arg-types simple-string (:constant (signed-byte 30)))
+ (:temporary (:sc unsigned-reg :offset eax-offset :target value
+ :from (:eval 0) :to (:result 0))
+ eax)
+ (:ignore eax)
+ (:results (value :scs (base-char-reg)))
+ (:result-types base-char)
+ (:generator 4
+ (inst mov al-tn
+ (make-ea :byte :base object
+ :disp (- (+ (* vector-data-offset word-bytes) index)
+ other-pointer-type)))
+ (move value al-tn)))
+
+(define-vop (data-vector-set/simple-string)
+ (:translate data-vector-set)
+ (:policy :fast-safe)
+ (:args (object :scs (descriptor-reg) :to (:eval 0))
+ (index :scs (unsigned-reg) :to (:eval 0))
+ (value :scs (base-char-reg)))
+ (:arg-types simple-string positive-fixnum base-char)
+ (:results (result :scs (base-char-reg)))
+ (:result-types base-char)
+ (:generator 5
+ (inst mov (make-ea :byte :base object :index index :scale 1
+ :disp (- (* vector-data-offset word-bytes)
+ other-pointer-type))
+ value)
+ (move result value)))
+
+(define-vop (data-vector-set/simple-string-c)
+ (:translate data-vector-set)
+ (:policy :fast-safe)
+ (:args (object :scs (descriptor-reg) :to (:eval 0))
+ (value :scs (base-char-reg)))
+ (:info index)
+ (:arg-types simple-string (:constant (signed-byte 30)) base-char)
+ (:results (result :scs (base-char-reg)))
+ (:result-types base-char)
+ (:generator 4
+ (inst mov (make-ea :byte :base object
+ :disp (- (+ (* vector-data-offset word-bytes) index)
+ other-pointer-type))
+ value)
+ (move result value)))
+
+;;; signed-byte-8
+
+(define-vop (data-vector-ref/simple-array-signed-byte-8)
+ (:translate data-vector-ref)
+ (:policy :fast-safe)
+ (:args (object :scs (descriptor-reg))
+ (index :scs (unsigned-reg)))
+ (:arg-types simple-array-signed-byte-8 positive-fixnum)
+ (:results (value :scs (signed-reg)))
+ (:result-types tagged-num)
+ (:generator 5
+ (inst movsx value
+ (make-ea :byte :base object :index index :scale 1
+ :disp (- (* vector-data-offset word-bytes)
+ other-pointer-type)))))
+
+(define-vop (data-vector-ref-c/simple-array-signed-byte-8)
+ (:translate data-vector-ref)
+ (:policy :fast-safe)
+ (:args (object :scs (descriptor-reg)))
+ (:info index)
+ (:arg-types simple-array-signed-byte-8 (:constant (signed-byte 30)))
+ (:results (value :scs (signed-reg)))
+ (:result-types tagged-num)
+ (:generator 4
+ (inst movsx value
+ (make-ea :byte :base object
+ :disp (- (+ (* vector-data-offset word-bytes) index)
+ other-pointer-type)))))
+
+(define-vop (data-vector-set/simple-array-signed-byte-8)
+ (:translate data-vector-set)
+ (:policy :fast-safe)
+ (:args (object :scs (descriptor-reg) :to (:eval 0))
+ (index :scs (unsigned-reg) :to (:eval 0))
+ (value :scs (signed-reg) :target eax))
+ (:arg-types simple-array-signed-byte-8 positive-fixnum tagged-num)
+ (:temporary (:sc unsigned-reg :offset eax-offset :target result
+ :from (:argument 2) :to (:result 0))
+ eax)
+ (:results (result :scs (signed-reg)))
+ (:result-types tagged-num)
+ (:generator 5
+ (move eax value)
+ (inst mov (make-ea :byte :base object :index index :scale 1
+ :disp (- (* vector-data-offset word-bytes)
+ other-pointer-type))
+ al-tn)
+ (move result eax)))
+
+(define-vop (data-vector-set-c/simple-array-signed-byte-8)
+ (:translate data-vector-set)
+ (:policy :fast-safe)
+ (:args (object :scs (descriptor-reg) :to (:eval 0))
+ (value :scs (signed-reg) :target eax))
+ (:info index)
+ (:arg-types simple-array-signed-byte-8 (:constant (signed-byte 30))
+ tagged-num)
+ (:temporary (:sc unsigned-reg :offset eax-offset :target result
+ :from (:argument 1) :to (:result 0))
+ eax)
+ (:results (result :scs (signed-reg)))
+ (:result-types tagged-num)
+ (:generator 4
+ (move eax value)
+ (inst mov (make-ea :byte :base object
+ :disp (- (+ (* vector-data-offset word-bytes) index)
+ other-pointer-type))
+ al-tn)
+ (move result eax)))
+
+;;; signed-byte-16
+
+(define-vop (data-vector-ref/simple-array-signed-byte-16)
+ (:translate data-vector-ref)
+ (:policy :fast-safe)
+ (:args (object :scs (descriptor-reg))
+ (index :scs (unsigned-reg)))
+ (:arg-types simple-array-signed-byte-16 positive-fixnum)
+ (:results (value :scs (signed-reg)))
+ (:result-types tagged-num)
+ (:generator 5
+ (inst movsx value
+ (make-ea :word :base object :index index :scale 2
+ :disp (- (* vector-data-offset word-bytes)
+ other-pointer-type)))))
+
+(define-vop (data-vector-ref-c/simple-array-signed-byte-16)
+ (:translate data-vector-ref)
+ (:policy :fast-safe)
+ (:args (object :scs (descriptor-reg)))
+ (:info index)
+ (:arg-types simple-array-signed-byte-16 (:constant (signed-byte 30)))
+ (:results (value :scs (signed-reg)))
+ (:result-types tagged-num)
+ (:generator 4
+ (inst movsx value
+ (make-ea :word :base object
+ :disp (- (+ (* vector-data-offset word-bytes)
+ (* 2 index))
+ other-pointer-type)))))
+
+(define-vop (data-vector-set/simple-array-signed-byte-16)
+ (:translate data-vector-set)
+ (:policy :fast-safe)
+ (:args (object :scs (descriptor-reg) :to (:eval 0))
+ (index :scs (unsigned-reg) :to (:eval 0))
+ (value :scs (signed-reg) :target eax))
+ (:arg-types simple-array-signed-byte-16 positive-fixnum tagged-num)
+ (:temporary (:sc signed-reg :offset eax-offset :target result
+ :from (:argument 2) :to (:result 0))
+ eax)
+ (:results (result :scs (signed-reg)))
+ (:result-types tagged-num)
+ (:generator 5
+ (move eax value)
+ (inst mov (make-ea :word :base object :index index :scale 2
+ :disp (- (* vector-data-offset word-bytes)
+ other-pointer-type))
+ ax-tn)
+ (move result eax)))
+
+(define-vop (data-vector-set-c/simple-array-signed-byte-16)
+ (:translate data-vector-set)
+ (:policy :fast-safe)
+ (:args (object :scs (descriptor-reg) :to (:eval 0))
+ (value :scs (signed-reg) :target eax))
+ (:info index)
+ (:arg-types simple-array-signed-byte-16 (:constant (signed-byte 30)) tagged-num)
+ (:temporary (:sc signed-reg :offset eax-offset :target result
+ :from (:argument 1) :to (:result 0))
+ eax)
+ (:results (result :scs (signed-reg)))
+ (:result-types tagged-num)
+ (:generator 4
+ (move eax value)
+ (inst mov
+ (make-ea :word :base object
+ :disp (- (+ (* vector-data-offset word-bytes)
+ (* 2 index))
+ other-pointer-type))
+ ax-tn)
+ (move result eax)))
+\f
+;;; These VOPs are used for implementing float slots in structures (whose raw
+;;; data is an unsigned-32 vector).
+(define-vop (raw-ref-single data-vector-ref/simple-array-single-float)
+ (:translate %raw-ref-single)
+ (:arg-types simple-array-unsigned-byte-32 positive-fixnum))
+(define-vop (raw-ref-single-c data-vector-ref-c/simple-array-single-float)
+ (:translate %raw-ref-single)
+ (:arg-types simple-array-unsigned-byte-32 (:constant (signed-byte 30))))
+(define-vop (raw-set-single data-vector-set/simple-array-single-float)
+ (:translate %raw-set-single)
+ (:arg-types simple-array-unsigned-byte-32 positive-fixnum single-float))
+(define-vop (raw-set-single-c data-vector-set-c/simple-array-single-float)
+ (:translate %raw-set-single)
+ (:arg-types simple-array-unsigned-byte-32 (:constant (signed-byte 30))
+ single-float))
+(define-vop (raw-ref-double data-vector-ref/simple-array-double-float)
+ (:translate %raw-ref-double)
+ (:arg-types simple-array-unsigned-byte-32 positive-fixnum))
+(define-vop (raw-ref-double-c data-vector-ref-c/simple-array-double-float)
+ (:translate %raw-ref-double)
+ (:arg-types simple-array-unsigned-byte-32 (:constant (signed-byte 30))))
+(define-vop (raw-set-double data-vector-set/simple-array-double-float)
+ (:translate %raw-set-double)
+ (:arg-types simple-array-unsigned-byte-32 positive-fixnum double-float))
+(define-vop (raw-set-double-c data-vector-set-c/simple-array-double-float)
+ (:translate %raw-set-double)
+ (:arg-types simple-array-unsigned-byte-32 (:constant (signed-byte 30))
+ double-float))
+#!+long-float
+(define-vop (raw-ref-long data-vector-ref/simple-array-long-float)
+ (:translate %raw-ref-long)
+ (:arg-types simple-array-unsigned-byte-32 positive-fixnum))
+#!+long-float
+(define-vop (raw-ref-long-c data-vector-ref-c/simple-array-long-float)
+ (:translate %raw-ref-long)
+ (:arg-types simple-array-unsigned-byte-32 (:constant (signed-byte 30))))
+#!+long-float
+(define-vop (raw-set-double data-vector-set/simple-array-long-float)
+ (:translate %raw-set-long)
+ (:arg-types simple-array-unsigned-byte-32 positive-fixnum long-float))
+#!+long-float
+(define-vop (raw-set-long-c data-vector-set-c/simple-array-long-float)
+ (:translate %raw-set-long)
+ (:arg-types simple-array-unsigned-byte-32 (:constant (signed-byte 30))
+ long-float))
+
+;;;; complex-float raw structure slot accessors
+
+(define-vop (raw-ref-complex-single
+ data-vector-ref/simple-array-complex-single-float)
+ (:translate %raw-ref-complex-single)
+ (:arg-types simple-array-unsigned-byte-32 positive-fixnum))
+(define-vop (raw-ref-complex-single-c
+ data-vector-ref-c/simple-array-complex-single-float)
+ (:translate %raw-ref-complex-single)
+ (:arg-types simple-array-unsigned-byte-32 (:constant (signed-byte 30))))
+(define-vop (raw-set-complex-single
+ data-vector-set/simple-array-complex-single-float)
+ (:translate %raw-set-complex-single)
+ (:arg-types simple-array-unsigned-byte-32 positive-fixnum complex-single-float))
+(define-vop (raw-set-complex-single-c
+ data-vector-set-c/simple-array-complex-single-float)
+ (:translate %raw-set-complex-single)
+ (:arg-types simple-array-unsigned-byte-32 (:constant (signed-byte 30))
+ complex-single-float))
+(define-vop (raw-ref-complex-double
+ data-vector-ref/simple-array-complex-double-float)
+ (:translate %raw-ref-complex-double)
+ (:arg-types simple-array-unsigned-byte-32 positive-fixnum))
+(define-vop (raw-ref-complex-double-c
+ data-vector-ref-c/simple-array-complex-double-float)
+ (:translate %raw-ref-complex-double)
+ (:arg-types simple-array-unsigned-byte-32 (:constant (signed-byte 30))))
+(define-vop (raw-set-complex-double
+ data-vector-set/simple-array-complex-double-float)
+ (:translate %raw-set-complex-double)
+ (:arg-types simple-array-unsigned-byte-32 positive-fixnum
+ complex-double-float))
+(define-vop (raw-set-complex-double-c
+ data-vector-set-c/simple-array-complex-double-float)
+ (:translate %raw-set-complex-double)
+ (:arg-types simple-array-unsigned-byte-32 (:constant (signed-byte 30))
+ complex-double-float))
+#!+long-float
+(define-vop (raw-ref-complex-long
+ data-vector-ref/simple-array-complex-long-float)
+ (:translate %raw-ref-complex-long)
+ (:arg-types simple-array-unsigned-byte-32 positive-fixnum))
+#!+long-float
+(define-vop (raw-ref-complex-long-c
+ data-vector-ref-c/simple-array-complex-long-float)
+ (:translate %raw-ref-complex-long)
+ (:arg-types simple-array-unsigned-byte-32 (:constant (signed-byte 30))))
+#!+long-float
+(define-vop (raw-set-complex-long
+ data-vector-set/simple-array-complex-long-float)
+ (:translate %raw-set-complex-long)
+ (:arg-types simple-array-unsigned-byte-32 positive-fixnum
+ complex-long-float))
+#!+long-float
+(define-vop (raw-set-complex-long-c
+ data-vector-set-c/simple-array-complex-long-float)
+ (:translate %raw-set-complex-long)
+ (:arg-types simple-array-unsigned-byte-32 (:constant (signed-byte 30))
+ complex-long-float))
+
+;;; These vops are useful for accessing the bits of a vector
+;;; irrespective of what type of vector it is.
+(define-full-reffer raw-bits * 0 other-pointer-type (unsigned-reg)
+ unsigned-num %raw-bits)
+(define-full-setter set-raw-bits * 0 other-pointer-type (unsigned-reg)
+ unsigned-num %set-raw-bits)
+\f
+;;;; miscellaneous array VOPs
+
+(define-vop (get-vector-subtype get-header-data))
+(define-vop (set-vector-subtype set-header-data))
--- /dev/null
+;;;; that part of the parms.lisp file from original CMU CL which is defined in
+;;;; terms of the BACKEND structure
+;;;;
+;;;; FIXME: When we break up the BACKEND structure, this might be mergeable
+;;;; back into the parms.lisp file.
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!VM")
+
+(file-comment
+ "$Header$")
+\f
+;;;; compiler constants
+
+(setf *backend-fasl-file-type* "x86f")
+(setf *backend-fasl-file-implementation* :x86)
+(setf *backend-fasl-file-version* 4)
+;;; 2 = sbcl-0.6.4 uses COMPILE-OR-LOAD-DEFGENERIC
+;;; 3 = sbcl-0.6.6 uses private symbol, not :EMPTY, for empty HASH-TABLE slot
+;;; 4 = sbcl-0.6.7 uses HAIRY-DATA-VECTOR-REF and HAIRY-DATA-VECTOR-SET
+;;; when array headers or data element type uncertainty exist, and
+;;; uses DATA-VECTOR-REF and DATA-VECTOR-SET only for VOPs. (Thus,
+;;; full calls to DATA-VECTOR-REF and DATA-VECTOR-SET from older
+;;; fasl files would fail, because there are no DEFUNs for these
+;;; operations any more.)
+
+(setf *backend-register-save-penalty* 3)
+
+(setf *backend-byte-order* :little-endian)
+
+(setf *backend-page-size* 4096)
+;;; comment from CMU CL:
+;;;
+;;; in case we ever wanted to do this for Windows NT..
+;;;
+;;; Windows NT uses a memory system granularity of 64K, which means
+;;; everything that gets mapped must be a multiple of that. The real
+;;; page size is 512, but that doesn't do us a whole lot of good.
+;;; Effectively, the page size is 64K.
+;;;
+;;; would be: (setf *backend-page-size* 65536)
--- /dev/null
+;;;; the VOPs and other necessary machine specific support
+;;;; routines for call-out to C
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!VM")
+
+(file-comment
+ "$Header$")
+
+;; The move-argument vop is going to store args on the stack for
+;; call-out. These tn's will be used for that. move-arg is normally
+;; used for things going down the stack but C wants to have args
+;; indexed in the positive direction.
+
+(defun my-make-wired-tn (prim-type-name sc-name offset)
+ (make-wired-tn (primitive-type-or-lose prim-type-name)
+ (sc-number-or-lose sc-name)
+ offset))
+
+(defstruct arg-state
+ (stack-frame-size 0))
+
+(def-alien-type-method (integer :arg-tn) (type state)
+ (let ((stack-frame-size (arg-state-stack-frame-size state)))
+ (setf (arg-state-stack-frame-size state) (1+ stack-frame-size))
+ (multiple-value-bind (ptype stack-sc)
+ (if (alien-integer-type-signed type)
+ (values 'signed-byte-32 'signed-stack)
+ (values 'unsigned-byte-32 'unsigned-stack))
+ (my-make-wired-tn ptype stack-sc stack-frame-size))))
+
+(def-alien-type-method (system-area-pointer :arg-tn) (type state)
+ (declare (ignore type))
+ (let ((stack-frame-size (arg-state-stack-frame-size state)))
+ (setf (arg-state-stack-frame-size state) (1+ stack-frame-size))
+ (my-make-wired-tn 'system-area-pointer
+ 'sap-stack
+ stack-frame-size)))
+
+#!+long-float
+(def-alien-type-method (long-float :arg-tn) (type state)
+ (declare (ignore type))
+ (let ((stack-frame-size (arg-state-stack-frame-size state)))
+ (setf (arg-state-stack-frame-size state) (+ stack-frame-size 3))
+ (my-make-wired-tn 'long-float 'long-stack stack-frame-size)))
+
+(def-alien-type-method (double-float :arg-tn) (type state)
+ (declare (ignore type))
+ (let ((stack-frame-size (arg-state-stack-frame-size state)))
+ (setf (arg-state-stack-frame-size state) (+ stack-frame-size 2))
+ (my-make-wired-tn 'double-float 'double-stack stack-frame-size)))
+
+(def-alien-type-method (single-float :arg-tn) (type state)
+ (declare (ignore type))
+ (let ((stack-frame-size (arg-state-stack-frame-size state)))
+ (setf (arg-state-stack-frame-size state) (1+ stack-frame-size))
+ (my-make-wired-tn 'single-float 'single-stack stack-frame-size)))
+
+(defstruct result-state
+ (num-results 0))
+
+(defun result-reg-offset (slot)
+ (ecase slot
+ (0 eax-offset)
+ (1 edx-offset)))
+
+(def-alien-type-method (integer :result-tn) (type state)
+ (let ((num-results (result-state-num-results state)))
+ (setf (result-state-num-results state) (1+ num-results))
+ (multiple-value-bind (ptype reg-sc)
+ (if (alien-integer-type-signed type)
+ (values 'signed-byte-32 'signed-reg)
+ (values 'unsigned-byte-32 'unsigned-reg))
+ (my-make-wired-tn ptype reg-sc (result-reg-offset num-results)))))
+
+(def-alien-type-method (system-area-pointer :result-tn) (type state)
+ (declare (ignore type))
+ (let ((num-results (result-state-num-results state)))
+ (setf (result-state-num-results state) (1+ num-results))
+ (my-make-wired-tn 'system-area-pointer 'sap-reg
+ (result-reg-offset num-results))))
+
+#!+long-float
+(def-alien-type-method (long-float :result-tn) (type state)
+ (declare (ignore type))
+ (let ((num-results (result-state-num-results state)))
+ (setf (result-state-num-results state) (1+ num-results))
+ (my-make-wired-tn 'long-float 'long-reg (* num-results 2))))
+
+(def-alien-type-method (double-float :result-tn) (type state)
+ (declare (ignore type))
+ (let ((num-results (result-state-num-results state)))
+ (setf (result-state-num-results state) (1+ num-results))
+ (my-make-wired-tn 'double-float 'double-reg (* num-results 2))))
+
+(def-alien-type-method (single-float :result-tn) (type state)
+ (declare (ignore type))
+ (let ((num-results (result-state-num-results state)))
+ (setf (result-state-num-results state) (1+ num-results))
+ (my-make-wired-tn 'single-float 'single-reg (* num-results 2))))
+
+#+nil ;;pfw obsolete now?
+(def-alien-type-method (values :result-tn) (type state)
+ (mapcar #'(lambda (type)
+ (invoke-alien-type-method :result-tn type state))
+ (alien-values-type-values type)))
+
+;;; pfw - from alpha
+(def-alien-type-method (values :result-tn) (type state)
+ (let ((values (alien-values-type-values type)))
+ (when (cdr values)
+ (error "Too many result values from c-call."))
+ (when values
+ (invoke-alien-type-method :result-tn (car values) state))))
+
+(def-vm-support-routine make-call-out-tns (type)
+ (let ((arg-state (make-arg-state)))
+ (collect ((arg-tns))
+ (dolist #+nil ;; this reversed list seems to cause the alien botches!!
+ (arg-type (reverse (alien-function-type-arg-types type)))
+ (arg-type (alien-function-type-arg-types type))
+ (arg-tns (invoke-alien-type-method :arg-tn arg-type arg-state)))
+ (values (my-make-wired-tn 'positive-fixnum 'any-reg esp-offset)
+ (* (arg-state-stack-frame-size arg-state) word-bytes)
+ (arg-tns)
+ (invoke-alien-type-method :result-tn
+ (alien-function-type-result-type type)
+ (make-result-state))))))
+
+(define-vop (foreign-symbol-address)
+ (:translate foreign-symbol-address)
+ (:policy :fast-safe)
+ (:args)
+ (:arg-types (:constant simple-string))
+ (:info foreign-symbol)
+ (:results (res :scs (sap-reg)))
+ (:result-types system-area-pointer)
+ (:generator 2
+ (inst lea res (make-fixup (extern-alien-name foreign-symbol) :foreign))))
+
+(define-vop (call-out)
+ (:args (function :scs (sap-reg))
+ (args :more t))
+ (:results (results :more t))
+ ;; eax is already wired
+ (:temporary (:sc unsigned-reg :offset ecx-offset) ecx)
+ (:temporary (:sc unsigned-reg :offset edx-offset) edx)
+ (:node-var node)
+ (:vop-var vop)
+ (:save-p t)
+ (:ignore args ecx edx)
+ (:generator 0
+ (cond ((policy node (> space speed))
+ (move eax-tn function)
+ (inst call (make-fixup (extern-alien-name "call_into_c") :foreign)))
+ (t
+ ;; Setup the NPX for C; all the FP registers need to be
+ ;; empty; pop them all.
+ (inst fstp fr0-tn)
+ (inst fstp fr0-tn)
+ (inst fstp fr0-tn)
+ (inst fstp fr0-tn)
+ (inst fstp fr0-tn)
+ (inst fstp fr0-tn)
+ (inst fstp fr0-tn)
+ (inst fstp fr0-tn)
+
+ (inst call function)
+ ;; To give the debugger a clue. XX not really internal-error?
+ (note-this-location vop :internal-error)
+
+ ;; Restore the NPX for lisp.
+ (inst fldz) ; insure no regs are empty
+ (inst fldz)
+ (inst fldz)
+ (inst fldz)
+ (inst fldz)
+ (inst fldz)
+ (inst fldz)
+
+ (if (and results
+ (location= (tn-ref-tn results) fr0-tn))
+ ;; The return result is in fr0.
+ (inst fxch fr7-tn) ; move the result back to fr0
+ (inst fldz)) ; insure no regs are empty
+ ))))
+
+(define-vop (alloc-number-stack-space)
+ (:info amount)
+ (:results (result :scs (sap-reg any-reg)))
+ (:generator 0
+ (assert (location= result esp-tn))
+ (unless (zerop amount)
+ (let ((delta (logandc2 (+ amount 3) 3)))
+ (inst sub esp-tn delta)))
+ (move result esp-tn)))
+
+(define-vop (dealloc-number-stack-space)
+ (:info amount)
+ (:generator 0
+ (unless (zerop amount)
+ (let ((delta (logandc2 (+ amount 3) 3)))
+ (inst add esp-tn delta)))))
+
+(define-vop (alloc-alien-stack-space)
+ (:info amount)
+ (:results (result :scs (sap-reg any-reg)))
+ (:generator 0
+ (assert (not (location= result esp-tn)))
+ (unless (zerop amount)
+ (let ((delta (logandc2 (+ amount 3) 3)))
+ (inst sub (make-ea :dword
+ :disp (+ *nil-value*
+ (static-symbol-offset '*alien-stack*)
+ (ash symbol-value-slot word-shift)
+ (- other-pointer-type)))
+ delta)))
+ (load-symbol-value result *alien-stack*)))
+
+(define-vop (dealloc-alien-stack-space)
+ (:info amount)
+ (:generator 0
+ (unless (zerop amount)
+ (let ((delta (logandc2 (+ amount 3) 3)))
+ (inst add (make-ea :dword
+ :disp (+ *nil-value*
+ (static-symbol-offset '*alien-stack*)
+ (ash symbol-value-slot word-shift)
+ (- other-pointer-type)))
+ delta)))))
--- /dev/null
+;;;; function call for the x86 VM
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!VM")
+
+(file-comment
+ "$Header$")
+\f
+;;;; interfaces to IR2 conversion
+
+;;; Return a wired TN describing the N'th full call argument passing
+;;; location.
+(def-vm-support-routine standard-argument-location (n)
+ (declare (type unsigned-byte n))
+ (if (< n register-arg-count)
+ (make-wired-tn *backend-t-primitive-type* descriptor-reg-sc-number
+ (nth n register-arg-offsets))
+ (make-wired-tn *backend-t-primitive-type* control-stack-sc-number n)))
+
+;;; Make a passing location TN for a local call return PC.
+;;;
+;;; Always wire the return PC location to the stack in its standard
+;;; location.
+;;;
+;;; No problems.
+;#+nil
+(def-vm-support-routine make-return-pc-passing-location (standard)
+ (declare (ignore standard))
+ (make-wired-tn (primitive-type-or-lose 'system-area-pointer)
+ sap-stack-sc-number return-pc-save-offset))
+;;; If standard is true, then use the standard (full call) location,
+;;; otherwise use any legal location.
+;;;
+;;; No problems.
+#+nil
+(def-vm-support-routine make-return-pc-passing-location (standard)
+ (let ((ptype (primitive-type-or-lose 'system-area-pointer)))
+ (if standard
+ (make-wired-tn ptype sap-stack-sc-number return-pc-save-offset)
+ (make-normal-tn ptype))))
+
+;;; Similar to Make-Return-PC-Passing-Location, but makes a location to pass
+;;; Old-FP in.
+;;;
+;;; This is wired in both the standard and the local-call
+;;; conventions, because we want to be able to assume it's always there.
+;;; Besides, the x86 doesn't have enough registers to really make it
+;;; profitable to pass it in a register.
+;;;
+;;; No problems
+;#+nil
+(def-vm-support-routine make-old-fp-passing-location (standard)
+ (declare (ignore standard))
+ (make-wired-tn *fixnum-primitive-type* control-stack-sc-number
+ ocfp-save-offset))
+;;; If standard is true, then use the standard (full call) location,
+;;; otherwise use any legal location.
+;;;
+;;; No problems.
+#+nil
+(def-vm-support-routine make-old-fp-passing-location (standard)
+ (if standard
+ (make-wired-tn *fixnum-primitive-type* control-stack-sc-number
+ ocfp-save-offset)
+ (make-normal-tn *fixnum-primitive-type*)))
+
+;;; Make the TNs used to hold Old-FP and Return-PC within the current
+;;; function. We treat these specially so that the debugger can find them at a
+;;; known location.
+;;;
+;;; Without using a save-tn - which does not make much sense if it is
+;;; wire to the stack? No problems.
+(def-vm-support-routine make-old-fp-save-location (env)
+ (environment-debug-live-tn (make-wired-tn *fixnum-primitive-type*
+ control-stack-sc-number
+ ocfp-save-offset)
+ env))
+;;; Using a save-tn. No problems.
+#+nil
+(def-vm-support-routine make-old-fp-save-location (env)
+ (specify-save-tn
+ (environment-debug-live-tn (make-normal-tn *fixnum-primitive-type*) env)
+ (make-wired-tn *fixnum-primitive-type* control-stack-sc-number
+ ocfp-save-offset)))
+
+;;; Without using a save-tn - which does not make much sense if it is
+;;; wire to the stack? No problems.
+(def-vm-support-routine make-return-pc-save-location (env)
+ (environment-debug-live-tn
+ (make-wired-tn (primitive-type-or-lose 'system-area-pointer)
+ sap-stack-sc-number return-pc-save-offset)
+ env))
+;;; Using a save-tn. No problems.
+#+nil
+(def-vm-support-routine make-return-pc-save-location (env)
+ (let ((ptype (primitive-type-or-lose 'system-area-pointer)))
+ (specify-save-tn
+ (environment-debug-live-tn (make-normal-tn ptype) env)
+ (make-wired-tn ptype sap-stack-sc-number return-pc-save-offset))))
+
+;;; Make a TN for the standard argument count passing location. We only
+;;; need to make the standard location, since a count is never passed when we
+;;; are using non-standard conventions.
+(def-vm-support-routine make-argument-count-location ()
+ (make-wired-tn *fixnum-primitive-type* any-reg-sc-number ecx-offset))
+
+
+;;; Make a TN to hold the number-stack frame pointer. This is allocated
+;;; once per component, and is component-live.
+(def-vm-support-routine make-nfp-tn ()
+ (make-restricted-tn *fixnum-primitive-type* ignore-me-sc-number))
+
+(def-vm-support-routine make-stack-pointer-tn ()
+ (make-normal-tn *fixnum-primitive-type*))
+
+(def-vm-support-routine make-number-stack-pointer-tn ()
+ (make-restricted-tn *fixnum-primitive-type* ignore-me-sc-number))
+
+;;; Return a list of TNs that can be used to represent an unknown-values
+;;; continuation within a function.
+(def-vm-support-routine make-unknown-values-locations ()
+ (list (make-stack-pointer-tn)
+ (make-normal-tn *fixnum-primitive-type*)))
+
+
+;;; This function is called by the Entry-Analyze phase, allowing
+;;; VM-dependent initialization of the IR2-Component structure. We push
+;;; placeholder entries in the Constants to leave room for additional
+;;; noise in the code object header.
+;;;
+;;; For the x86 the first constant is a pointer to a list of fixups,
+;;; or nil if the code object has none.
+(def-vm-support-routine select-component-format (component)
+ (declare (type component component))
+ (dotimes (i (1+ code-constants-offset))
+ (vector-push-extend nil
+ (ir2-component-constants (component-info component))))
+ (values))
+\f
+;;;; frame hackery
+
+;;; Used for setting up the Old-FP in local call.
+(define-vop (current-fp)
+ (:results (val :scs (any-reg control-stack)))
+ (:generator 1
+ (move val ebp-tn)))
+
+;;; We don't have a separate NFP, so we don't need to do anything here.
+(define-vop (compute-old-nfp)
+ (:results (val))
+ (:ignore val)
+ (:generator 1
+ nil))
+
+
+(define-vop (xep-allocate-frame)
+ (:info start-lab copy-more-arg-follows)
+ (:vop-var vop)
+ (:generator 1
+ ;; Make sure the function is aligned, and drop a label pointing to this
+ ;; function header.
+ (align lowtag-bits)
+ (trace-table-entry trace-table-function-prologue)
+ (emit-label start-lab)
+ ;; Skip space for the function header.
+ (inst function-header-word)
+ (dotimes (i (1- sb!vm:function-code-offset))
+ (inst dword 0))
+
+ ;; The start of the actual code.
+ ;; Save the return-pc.
+ (popw ebp-tn (- (1+ return-pc-save-offset)))
+
+ ;; If copy-more-arg follows it will allocate the correct stack
+ ;; size. The stack is not allocated first here as this may expose
+ ;; args on the stack if they take up more space than the frame!
+ (unless copy-more-arg-follows
+ ;; The args fit within the frame so just allocate the frame.
+ (inst lea esp-tn
+ (make-ea :dword :base ebp-tn
+ :disp (- (* sb!vm:word-bytes
+ (max 3 (sb-allocated-size 'stack)))))))
+
+ (trace-table-entry trace-table-normal)))
+
+;;; This is emitted directly before either a known-call-local, call-local,
+;;; or a multiple-call-local. All it does is allocate stack space for the
+;;; callee (who has the same size stack as us).
+(define-vop (allocate-frame)
+ (:results (res :scs (any-reg control-stack))
+ (nfp))
+ (:info callee)
+ (:ignore nfp callee)
+ (:generator 2
+ (move res esp-tn)
+ (inst sub esp-tn (* sb!vm:word-bytes (sb-allocated-size 'stack)))))
+
+;;; Allocate a partial frame for passing stack arguments in a full call. Nargs
+;;; is the number of arguments passed. We allocate at least 3 slots, because
+;;; the XEP noise is going to want to use them before it can extend the stack.
+(define-vop (allocate-full-call-frame)
+ (:info nargs)
+ (:results (res :scs (any-reg control-stack)))
+ (:generator 2
+ (move res esp-tn)
+ (inst sub esp-tn (* (max nargs 3) sb!vm:word-bytes))))
+
+
+\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. Nvals is the number of
+;;; values that are to be received (should equal the length of Values).
+;;;
+;;; Move-Temp is a Descriptor-Reg TN used as a temporary.
+;;;
+;;; This code exploits the fact that in the unknown-values convention, a
+;;; single value return returns at the return PC + 2, whereas a return of other
+;;; than one value returns directly at the return PC.
+;;;
+;;; If 0 or 1 values are expected, then we just emit an instruction to reset
+;;; the SP (which will only be executed when other than 1 value is returned.)
+;;;
+;;; In the general case we have to do three things:
+;;; -- Default unsupplied register values. This need only be done when a
+;;; single value is returned, since register values are defaulted by the
+;;; called in the non-single case.
+;;; -- Default unsupplied stack values. This needs to be done whenever there
+;;; are stack values.
+;;; -- Reset SP. This must be done whenever other than 1 value is returned,
+;;; regardless of the number of values desired.
+(defun default-unknown-values (vop values nvals)
+ (declare (type (or tn-ref null) values)
+ (type unsigned-byte nvals))
+ (cond
+ ((<= nvals 1)
+ (note-this-location vop :single-value-return)
+ (inst mov esp-tn ebx-tn))
+ ((<= nvals register-arg-count)
+ (let ((regs-defaulted (gen-label)))
+ (note-this-location vop :unknown-return)
+ (inst jmp-short regs-defaulted)
+ ;; Default the unsuppled registers.
+ (let* ((2nd-tn-ref (tn-ref-across values))
+ (2nd-tn (tn-ref-tn 2nd-tn-ref)))
+ (inst mov 2nd-tn *nil-value*)
+ (when (> nvals 2)
+ (loop
+ for tn-ref = (tn-ref-across 2nd-tn-ref)
+ then (tn-ref-across tn-ref)
+ for count from 2 below register-arg-count
+ do count (inst mov (tn-ref-tn tn-ref) 2nd-tn))))
+ (inst mov ebx-tn esp-tn)
+ (emit-label regs-defaulted)
+ (inst mov esp-tn ebx-tn)))
+ ((<= nvals 7)
+ ;; Number of bytes depends on the relative jump instructions. Best
+ ;; case is 31+(n-3)*14, worst case is 35+(n-3)*18. For nvals=6
+ ;; that is 73/89 bytes, and for nvals=7 that is 87/107 bytes which
+ ;; is likely better than using the blt below.
+ (let ((regs-defaulted (gen-label))
+ (defaulting-done (gen-label))
+ (default-stack-slots (gen-label)))
+ (note-this-location vop :unknown-return)
+ ;; Branch off to the MV case.
+ (inst jmp-short regs-defaulted)
+ ;; Do the single value case.
+ ;; Default the register args
+ (inst mov eax-tn *nil-value*)
+ (do ((i 1 (1+ i))
+ (val (tn-ref-across values) (tn-ref-across val)))
+ ((= i (min nvals register-arg-count)))
+ (inst mov (tn-ref-tn val) eax-tn))
+
+ ;; Fake other registers so it looks like we returned with all the
+ ;; registers filled in.
+ (move ebx-tn esp-tn)
+ (inst push edx-tn)
+ (inst jmp default-stack-slots)
+
+ (emit-label regs-defaulted)
+
+ (inst mov eax-tn *nil-value*)
+ (storew edx-tn ebx-tn -1)
+ (collect ((defaults))
+ (do ((i register-arg-count (1+ i))
+ (val (do ((i 0 (1+ i))
+ (val values (tn-ref-across val)))
+ ((= i register-arg-count) val))
+ (tn-ref-across val)))
+ ((null val))
+ (let ((default-lab (gen-label))
+ (tn (tn-ref-tn val)))
+ (defaults (cons default-lab tn))
+
+ (inst cmp ecx-tn (fixnumize i))
+ (inst jmp :be default-lab)
+ (loadw edx-tn ebx-tn (- (1+ i)))
+ (inst mov tn edx-tn)))
+
+ (emit-label defaulting-done)
+ (loadw edx-tn ebx-tn -1)
+ (move esp-tn ebx-tn)
+
+ (let ((defaults (defaults)))
+ (when defaults
+ (assemble (*elsewhere*)
+ (trace-table-entry trace-table-function-prologue)
+ (emit-label default-stack-slots)
+ (dolist (default defaults)
+ (emit-label (car default))
+ (inst mov (cdr default) eax-tn))
+ (inst jmp defaulting-done)
+ (trace-table-entry trace-table-normal)))))))
+ (t
+ ;; 91 bytes for this branch.
+ (let ((regs-defaulted (gen-label))
+ (restore-edi (gen-label))
+ (no-stack-args (gen-label))
+ (default-stack-vals (gen-label))
+ (count-okay (gen-label)))
+ (note-this-location vop :unknown-return)
+ ;; Branch off to the MV case.
+ (inst jmp-short regs-defaulted)
+
+ ;; Default the register args, and set up the stack as if we entered
+ ;; the MV return point.
+ (inst mov ebx-tn esp-tn)
+ (inst push edx-tn)
+ (inst mov edi-tn *nil-value*)
+ (inst push edi-tn)
+ (inst mov esi-tn edi-tn)
+ ;; Compute a pointer to where to put the [defaulted] stack values.
+ (emit-label no-stack-args)
+ (inst lea edi-tn
+ (make-ea :dword :base ebp-tn
+ :disp (* (- (1+ register-arg-count)) word-bytes)))
+ ;; Load EAX with NIL so we can quickly store it, and set up stuff
+ ;; for the loop.
+ (inst mov eax-tn *nil-value*)
+ (inst std)
+ (inst mov ecx-tn (- nvals register-arg-count))
+ ;; Jump into the default loop.
+ (inst jmp default-stack-vals)
+
+ ;; The regs are defaulted. We need to copy any stack arguments,
+ ;; and then default the remaining stack arguments.
+ (emit-label regs-defaulted)
+ ;; Save EDI.
+ (storew edi-tn ebx-tn (- (1+ 1)))
+ ;; Compute the number of stack arguments, and if it's zero or less,
+ ;; don't copy any stack arguments.
+ (inst sub ecx-tn (fixnumize register-arg-count))
+ (inst jmp :le no-stack-args)
+
+ ;; Throw away any unwanted args.
+ (inst cmp ecx-tn (fixnumize (- nvals register-arg-count)))
+ (inst jmp :be count-okay)
+ (inst mov ecx-tn (fixnumize (- nvals register-arg-count)))
+ (emit-label count-okay)
+ ;; Save the number of stack values.
+ (inst mov eax-tn ecx-tn)
+ ;; Compute a pointer to where the stack args go.
+ (inst lea edi-tn
+ (make-ea :dword :base ebp-tn
+ :disp (* (- (1+ register-arg-count)) word-bytes)))
+ ;; Save ESI, and compute a pointer to where the args come from.
+ (storew esi-tn ebx-tn (- (1+ 2)))
+ (inst lea esi-tn
+ (make-ea :dword :base ebx-tn
+ :disp (* (- (1+ register-arg-count)) word-bytes)))
+ ;; Do the copy.
+ (inst shr ecx-tn word-shift) ; make word count
+ (inst std)
+ (inst rep)
+ (inst movs :dword)
+ ;; Restore ESI.
+ (loadw esi-tn ebx-tn (- (1+ 2)))
+ ;; Now we have to default the remaining args. Find out how many.
+ (inst sub eax-tn (fixnumize (- nvals register-arg-count)))
+ (inst neg eax-tn)
+ ;; If none, then just blow out of here.
+ (inst jmp :le restore-edi)
+ (inst mov ecx-tn eax-tn)
+ (inst shr ecx-tn word-shift) ; word count
+ ;; Load EAX with NIL for fast storing.
+ (inst mov eax-tn *nil-value*)
+ ;; Do the store.
+ (emit-label default-stack-vals)
+ (inst rep)
+ (inst stos eax-tn)
+ ;; Restore EDI, and reset the stack.
+ (emit-label restore-edi)
+ (loadw edi-tn ebx-tn (- (1+ 1)))
+ (inst mov esp-tn ebx-tn))))
+ (values))
+\f
+;;;; unknown values receiving
+
+;;; Emit code needed at the return point for an unknown-values call for an
+;;; arbitrary number of values.
+;;;
+;;; We do the single and non-single cases with no shared code: there doesn't
+;;; seem to be any potential overlap, and receiving a single value is more
+;;; important efficiency-wise.
+;;;
+;;; When there is a single value, we just push it on the stack, returning
+;;; the old SP and 1.
+;;;
+;;; When there is a variable number of values, we move all of the argument
+;;; registers onto the stack, and return Args and Nargs.
+;;;
+;;; Args and Nargs are TNs wired to the named locations. We must
+;;; explicitly allocate these TNs, since their lifetimes overlap with the
+;;; results Start and Count (also, it's nice to be able to target them).
+(defun receive-unknown-values (args nargs start count)
+ (declare (type tn args nargs start count))
+ (let ((variable-values (gen-label))
+ (done (gen-label)))
+ (inst jmp-short variable-values)
+
+ (inst mov start esp-tn)
+ (inst push (first *register-arg-tns*))
+ (inst mov count (fixnumize 1))
+ (inst jmp done)
+
+ (emit-label variable-values)
+ ;; dtc: this writes the registers onto the stack even if they are
+ ;; not needed, only the number specified in ecx are used and have
+ ;; stack allocated to them. No harm is done.
+ (loop
+ for arg in *register-arg-tns*
+ for i downfrom -1
+ do (storew arg args i))
+ (move start args)
+ (move count nargs)
+
+ (emit-label done))
+ (values))
+
+;;; VOP that can be inherited by unknown values receivers. The main thing this
+;;; handles is allocation of the result temporaries.
+(define-vop (unknown-values-receiver)
+ (:temporary (:sc descriptor-reg :offset ebx-offset
+ :from :eval :to (:result 0))
+ values-start)
+ (:temporary (:sc any-reg :offset ecx-offset
+ :from :eval :to (:result 1))
+ nvals)
+ (:results (start :scs (any-reg control-stack))
+ (count :scs (any-reg control-stack))))
+\f
+;;;; local call with unknown values convention return
+
+;;; Non-TR local call for a fixed number of values passed according to the
+;;; unknown values convention.
+;;;
+;;; FP is the frame pointer in install before doing the call.
+;;;
+;;; NFP would be the number-stack frame pointer if we had a separate number
+;;; stack.
+;;;
+;;; Args are the argument passing locations, which are specified only to
+;;; terminate their lifetimes in the caller.
+;;;
+;;; Values are the return value locations (wired to the standard passing
+;;; locations).
+;;; Nvals is the number of values received.
+;;;
+;;; Save is the save info, which we can ignore since saving has been done.
+;;;
+;;; Target is a continuation pointing to the start of the called function.
+(define-vop (call-local)
+ (:args (fp)
+ (nfp)
+ (args :more t))
+ (:results (values :more t))
+ (:save-p t)
+ (:move-args :local-call)
+ (:info arg-locs callee target nvals)
+ (:vop-var vop)
+ (:ignore nfp arg-locs args #+nil callee)
+ (:generator 5
+ (trace-table-entry trace-table-call-site)
+ (move ebp-tn fp)
+
+ (let ((ret-tn (callee-return-pc-tn callee)))
+ #+nil
+ (format t "*call-local ~S; tn-kind ~S; tn-save-tn ~S; its tn-kind ~S~%"
+ ret-tn (sb!c::tn-kind ret-tn) (sb!c::tn-save-tn ret-tn)
+ (sb!c::tn-kind (sb!c::tn-save-tn ret-tn)))
+
+ ;; Is the return-pc on the stack or in a register?
+ (sc-case ret-tn
+ ((sap-stack)
+ #+nil (format t "*call-local: ret-tn on stack; offset=~S~%"
+ (tn-offset ret-tn))
+ (storew (make-fixup nil :code-object return)
+ ebp-tn (- (1+ (tn-offset ret-tn)))))
+ ((sap-reg)
+ (inst lea ret-tn (make-fixup nil :code-object return)))))
+
+ (note-this-location vop :call-site)
+ (inst jmp target)
+ RETURN
+ (default-unknown-values vop values nvals)
+ (trace-table-entry trace-table-normal)))
+
+;;; Non-TR local call for a variable number of return values passed according
+;;; to the unknown values convention. The results are the start of the values
+;;; glob and the number of values received.
+(define-vop (multiple-call-local unknown-values-receiver)
+ (:args (fp)
+ (nfp)
+ (args :more t))
+ (:save-p t)
+ (:move-args :local-call)
+ (:info save callee target)
+ (:ignore args save nfp #+nil callee)
+ (:vop-var vop)
+ (:generator 20
+ (trace-table-entry trace-table-call-site)
+ (move ebp-tn fp)
+
+ (let ((ret-tn (callee-return-pc-tn callee)))
+ #+nil
+ (format t "*multiple-call-local ~S; tn-kind ~S; tn-save-tn ~S; its tn-kind ~S~%"
+ ret-tn (sb!c::tn-kind ret-tn) (sb!c::tn-save-tn ret-tn)
+ (sb!c::tn-kind (sb!c::tn-save-tn ret-tn)))
+
+ ;; Is the return-pc on the stack or in a register?
+ (sc-case ret-tn
+ ((sap-stack)
+ #+nil (format t "*multiple-call-local: ret-tn on stack; offset=~S~%"
+ (tn-offset ret-tn))
+ ;; Stack
+ (storew (make-fixup nil :code-object return)
+ ebp-tn (- (1+ (tn-offset ret-tn)))))
+ ((sap-reg)
+ ;; Register
+ (inst lea ret-tn (make-fixup nil :code-object return)))))
+
+ (note-this-location vop :call-site)
+ (inst jmp target)
+ RETURN
+ (note-this-location vop :unknown-return)
+ (receive-unknown-values values-start nvals start count)
+ (trace-table-entry trace-table-normal)))
+\f
+;;;; local call with known values return
+
+;;; Non-TR local call with known return locations. Known-value return works
+;;; just like argument passing in local call.
+;;;
+;;; Note: we can't use normal load-tn allocation for the fixed args, since all
+;;; registers may be tied up by the more operand. Instead, we use
+;;; MAYBE-LOAD-STACK-TN.
+(define-vop (known-call-local)
+ (:args (fp)
+ (nfp)
+ (args :more t))
+ (:results (res :more t))
+ (:move-args :local-call)
+ (:save-p t)
+ (:info save callee target)
+ (:ignore args res save nfp #+nil callee)
+ (:vop-var vop)
+ (:generator 5
+ (trace-table-entry trace-table-call-site)
+ (move ebp-tn fp)
+
+ (let ((ret-tn (callee-return-pc-tn callee)))
+
+ #+nil
+ (format t "*known-call-local ~S; tn-kind ~S; tn-save-tn ~S; its tn-kind ~S~%"
+ ret-tn (sb!c::tn-kind ret-tn) (sb!c::tn-save-tn ret-tn)
+ (sb!c::tn-kind (sb!c::tn-save-tn ret-tn)))
+
+ ;; Is the return-pc on the stack or in a register?
+ (sc-case ret-tn
+ ((sap-stack)
+ #+nil (format t "*known-call-local: ret-tn on stack; offset=~S~%"
+ (tn-offset ret-tn))
+ ;; Stack
+ (storew (make-fixup nil :code-object return)
+ ebp-tn (- (1+ (tn-offset ret-tn)))))
+ ((sap-reg)
+ ;; Register
+ (inst lea ret-tn (make-fixup nil :code-object return)))))
+
+ (note-this-location vop :call-site)
+ (inst jmp target)
+ RETURN
+ (note-this-location vop :known-return)
+ (trace-table-entry trace-table-normal)))
+\f
+;;; Return from known values call. We receive the return locations as
+;;; arguments to terminate their lifetimes in the returning function. We
+;;; restore FP and CSP and jump to the Return-PC.
+;;;
+;;; We can assume we know exactly where old-fp and return-pc are because
+;;; make-old-fp-save-location and make-return-pc-save-location always
+;;; return the same place.
+#+nil
+(define-vop (known-return)
+ (:args (old-fp)
+ (return-pc :scs (any-reg immediate-stack) :target rpc)
+ (vals :more t))
+ (:move-args :known-return)
+ (:info val-locs)
+ (:temporary (:sc unsigned-reg :from (:argument 1)) rpc)
+ (:ignore val-locs vals)
+ (:vop-var vop)
+ (:generator 6
+ (trace-table-entry trace-table-function-epilogue)
+ ;; Save the return-pc in a register 'cause the frame-pointer is going away.
+ ;; Note this not in the usual stack location so we can't use RET
+ (move rpc return-pc)
+ ;; Restore the stack.
+ (move esp-tn ebp-tn)
+ ;; Restore the old fp. We know OLD-FP is going to be in its stack
+ ;; save slot, which is a different frame that than this one,
+ ;; so we don't have to worry about having just cleared
+ ;; most of the stack.
+ (move ebp-tn old-fp)
+ (inst jmp rpc)
+ (trace-table-entry trace-table-normal)))
+\f
+;;; From Douglas Crosher
+;;; Return from known values call. We receive the return locations as
+;;; arguments to terminate their lifetimes in the returning function. We
+;;; restore FP and CSP and jump to the Return-PC.
+;;;
+;;; The old-fp may be either in a register or on the stack in its
+;;; standard save locations - slot 0.
+;;;
+;;; The return-pc may be in a register or on the stack in any slot.
+(define-vop (known-return)
+ (:args (old-fp)
+ (return-pc)
+ (vals :more t))
+ (:move-args :known-return)
+ (:info val-locs)
+ (:ignore val-locs vals)
+ (:vop-var vop)
+ (:generator 6
+ (trace-table-entry trace-table-function-epilogue)
+
+ #+nil (format t "*known-return: old-fp ~S, tn-kind ~S; ~S ~S~%"
+ old-fp (sb!c::tn-kind old-fp) (sb!c::tn-save-tn old-fp)
+ (sb!c::tn-kind (sb!c::tn-save-tn old-fp)))
+
+ #+nil (format t "*known-return: return-pc ~S, tn-kind ~S; ~S ~S~%"
+ return-pc (sb!c::tn-kind return-pc) (sb!c::tn-save-tn return-pc)
+ (sb!c::tn-kind (sb!c::tn-save-tn return-pc)))
+
+ ;; return-pc may be either in a register or on the stack.
+ (sc-case return-pc
+ ((sap-reg)
+ (sc-case old-fp
+ ((control-stack)
+
+ #+nil (format t "*known-return: old-fp ~S on stack; offset=~S~%"
+ old-fp (tn-offset old-fp))
+
+ (cond ((zerop (tn-offset old-fp))
+ ;; Zot all of the stack except for the old-fp.
+ (inst lea esp-tn (make-ea :dword :base ebp-tn
+ :disp (- (* (1+ ocfp-save-offset)
+ word-bytes))))
+ ;; Restore the old fp from its save location on the stack,
+ ;; and zot the stack.
+ (inst pop ebp-tn))
+
+ (t
+ (cerror "Continue any-way"
+ "VOP return-local doesn't work if old-fp (in slot %s) is not in slot 0"
+ (tn-offset old-fp)))))
+
+ ((any-reg descriptor-reg)
+ ;; Zot all the stack.
+ (move esp-tn ebp-tn)
+ ;; Restore the old-fp.
+ (move ebp-tn old-fp)))
+
+ ;; Return; return-pc is in a register.
+ (inst jmp return-pc))
+
+ ((sap-stack)
+
+ #+nil (format t "*known-return: return-pc ~S on stack; offset=~S~%"
+ return-pc (tn-offset return-pc))
+
+ ;; Zot all of the stack except for the old-fp and return-pc.
+ (inst lea esp-tn
+ (make-ea :dword :base ebp-tn
+ :disp (- (* (1+ (tn-offset return-pc)) word-bytes))))
+ ;; Restore the old fp. old-fp may be either on the stack in its
+ ;; save location or in a register, in either case this restores it.
+ (move ebp-tn old-fp)
+ ;; The return pops the return address (4 bytes), then we need
+ ;; to pop all the slots before the return-pc which includes the
+ ;; 4 bytes for the old-fp.
+ (inst ret (* (tn-offset return-pc) word-bytes))))
+
+ (trace-table-entry trace-table-normal)))
+\f
+;;;; full call
+;;;
+;;; There is something of a cross-product effect with full calls. Different
+;;; versions are used depending on whether we know the number of arguments or
+;;; the name of the called function, and whether we want fixed values, unknown
+;;; values, or a tail call.
+;;;
+;;; In full call, the arguments are passed creating a partial frame on the
+;;; stack top and storing stack arguments into that frame. On entry to the
+;;; callee, this partial frame is pointed to by FP.
+
+;;; This macro helps in the definition of full call VOPs by avoiding code
+;;; replication in defining the cross-product VOPs.
+;;;
+;;; Name is the name of the VOP to define.
+;;;
+;;; Named is true if the first argument is an fdefinition object whose
+;;; definition is to be called.
+;;;
+;;; Return is either :Fixed, :Unknown or :Tail:
+;;; -- If :Fixed, then the call is for a fixed number of values, returned in
+;;; the standard passing locations (passed as result operands).
+;;; -- If :Unknown, then the result values are pushed on the stack, and the
+;;; result values are specified by the Start and Count as in the
+;;; unknown-values continuation representation.
+;;; -- If :Tail, then do a tail-recursive call. No values are returned.
+;;; The Old-Fp and Return-PC are passed as the second and third arguments.
+;;;
+;;; In non-tail calls, the pointer to the stack arguments is passed as the last
+;;; fixed argument. If Variable is false, then the passing locations are
+;;; passed as a more arg. Variable is true if there are a variable number of
+;;; arguments passed on the stack. Variable cannot be specified with :Tail
+;;; return. TR variable argument call is implemented separately.
+;;;
+;;; In tail call with fixed arguments, the passing locations are passed as a
+;;; more arg, but there is no new-FP, since the arguments have been set up in
+;;; the current frame.
+(macrolet ((define-full-call (name named return variable)
+ (assert (not (and variable (eq return :tail))))
+ `(define-vop (,name
+ ,@(when (eq return :unknown)
+ '(unknown-values-receiver)))
+ (:args
+ ,@(unless (eq return :tail)
+ '((new-fp :scs (any-reg) :to (:argument 1))))
+
+ (fun :scs (descriptor-reg control-stack)
+ :target eax :to (:argument 0))
+
+ ,@(when (eq return :tail)
+ '((old-fp)
+ (return-pc)))
+
+ ,@(unless variable '((args :more t :scs (descriptor-reg)))))
+
+ ,@(when (eq return :fixed)
+ '((:results (values :more t))))
+
+ (:save-p ,(if (eq return :tail) :compute-only t))
+
+ ,@(unless (or (eq return :tail) variable)
+ '((:move-args :full-call)))
+
+ (:vop-var vop)
+ (:info
+ ,@(unless (or variable (eq return :tail)) '(arg-locs))
+ ,@(unless variable '(nargs))
+ ,@(when (eq return :fixed) '(nvals)))
+
+ (:ignore
+ ,@(unless (or variable (eq return :tail)) '(arg-locs))
+ ,@(unless variable '(args)))
+
+ ;; We pass either the fdefn object (for named call) or the actual
+ ;; function object (for unnamed call) in EAX. With named call,
+ ;; closure-tramp will replace it with the real function and invoke
+ ;; the real function for closures. Non-closures do not need this
+ ;; value, so don't care what shows up in it.
+ (:temporary
+ (:sc descriptor-reg :offset eax-offset :from (:argument 0) :to :eval)
+ eax)
+
+ ;; We pass the number of arguments in ECX.
+ (:temporary (:sc unsigned-reg :offset ecx-offset :to :eval) ecx)
+
+ ;; With variable call, we have to load the register-args out
+ ;; of the (new) stack frame before doing the call. Therefore,
+ ;; we have to tell the lifetime stuff that we need to use them.
+ ,@(when variable
+ (mapcar #'(lambda (name offset)
+ `(:temporary (:sc descriptor-reg
+ :offset ,offset
+ :from (:argument 0)
+ :to :eval)
+ ,name))
+ register-arg-names register-arg-offsets))
+
+ ,@(when (eq return :tail)
+ '((:temporary (:sc unsigned-reg
+ :from (:argument 1) :to (:argument 2)) old-fp-tmp)))
+
+ (:generator ,(+ (if named 5 0)
+ (if variable 19 1)
+ (if (eq return :tail) 0 10)
+ 15
+ (if (eq return :unknown) 25 0))
+ (trace-table-entry trace-table-call-site)
+
+ ;; This has to be done before the frame pointer is changed!
+ ;; eax stores the 'lexical environment' needed for closures
+ (move eax fun)
+
+
+ ,@(if variable
+ ;; For variable call, compute the number of arguments and
+ ;; move some of the arguments to registers.
+ (collect ((noise))
+ ;; Compute the number of arguments.
+ (noise '(inst mov ecx new-fp))
+ (noise '(inst sub ecx esp-tn))
+ ;; Move the necessary args to registers, this
+ ;; moves them all even if they are not all needed.
+ (loop
+ for name in register-arg-names
+ for index downfrom -1
+ do (noise `(loadw ,name new-fp ,index)))
+ (noise))
+ '((if (zerop nargs)
+ (inst xor ecx ecx)
+ (inst mov ecx (fixnumize nargs)))))
+ ,@(cond ((eq return :tail)
+ '(;; Python has figured out what frame we should return
+ ;; to so might as well use that clue. This seems
+ ;; really important to the implementation of things
+ ;; like (without-interrupts ...)
+
+ ;; dtc; Could be doing a tail call from a
+ ;; known-local-call etc in which the old-fp or ret-pc
+ ;; are in regs or in non-standard places. If the
+ ;; passing location were wired to the stack in
+ ;; standard locations then these moves will be
+ ;; un-necessary; this is probably best for the x86.
+ (sc-case old-fp
+ ((control-stack)
+ (unless (= ocfp-save-offset
+ (tn-offset old-fp))
+ ;; FIXME: FORMAT T for stale diagnostic
+ ;; output (several of them around here),
+ ;; ick
+ (format t "** tail-call old-fp not S0~%")
+ (move old-fp-tmp old-fp)
+ (storew old-fp-tmp
+ ebp-tn
+ (- (1+ ocfp-save-offset)))))
+ ((any-reg descriptor-reg)
+ (format t "** tail-call old-fp in reg not S0~%")
+ (storew old-fp
+ ebp-tn
+ (- (1+ ocfp-save-offset)))))
+
+ ;; For tail call, we have to push the return-pc so
+ ;; that it looks like we CALLed despite the fact that
+ ;; we are going to JMP.
+ (inst push return-pc)
+ ))
+ (t
+ ;; For non-tail call, we have to save our frame pointer
+ ;; and install the new frame pointer. We can't load
+ ;; stack tns after this point.
+ `(;; Python doesn't seem to allocate a frame here which
+ ;; doesn't leave room for the ofp/ret stuff.
+
+ ;; The variable args are on the stack and become the
+ ;; frame, but there may be <3 args and 3 stack slots
+ ;; are assumed allocate on the call. So need to
+ ;; ensure there are at least 3 slots. This hack just
+ ;; adds 3 more.
+ ,(if variable
+ '(inst sub esp-tn (fixnumize 3)))
+
+ ;; Save the fp
+ (storew ebp-tn new-fp (- (1+ ocfp-save-offset)))
+
+ (move ebp-tn new-fp) ; NB - now on new stack frame.
+ )))
+
+ (note-this-location vop :call-site)
+
+ (inst ,(if (eq return :tail) 'jmp 'call)
+ (make-ea :dword :base eax
+ :disp ,(if named
+ '(- (* fdefn-raw-addr-slot word-bytes)
+ other-pointer-type)
+ '(- (* closure-function-slot word-bytes)
+ function-pointer-type))))
+ ,@(ecase return
+ (:fixed
+ '((default-unknown-values vop values nvals)))
+ (:unknown
+ '((note-this-location vop :unknown-return)
+ (receive-unknown-values values-start nvals start count)))
+ (:tail))
+ (trace-table-entry trace-table-normal)))))
+
+ (define-full-call call nil :fixed nil)
+ (define-full-call call-named t :fixed nil)
+ (define-full-call multiple-call nil :unknown nil)
+ (define-full-call multiple-call-named t :unknown nil)
+ (define-full-call tail-call nil :tail nil)
+ (define-full-call tail-call-named t :tail nil)
+
+ (define-full-call call-variable nil :fixed t)
+ (define-full-call multiple-call-variable nil :unknown t))
+
+;;; This is defined separately, since it needs special code that BLT's the
+;;; arguments down. All the real work is done in the assembly routine. We just
+;;; set things up so that it can find what it needs.
+(define-vop (tail-call-variable)
+ (:args (args :scs (any-reg control-stack) :target esi)
+ (function :scs (descriptor-reg control-stack) :target eax)
+ (old-fp)
+ (ret-addr))
+ (:temporary (:sc unsigned-reg :offset esi-offset :from (:argument 0)) esi)
+ (:temporary (:sc unsigned-reg :offset eax-offset :from (:argument 1)) eax)
+; (:ignore ret-addr old-fp)
+ (:generator 75
+ ;; Move these into the passing locations if they are not already there.
+ (move esi args)
+ (move eax function)
+
+ ;; The following assumes that the return-pc and old-fp are on the
+ ;; stack in their standard save locations - Check this.
+ (unless (and (sc-is old-fp control-stack)
+ (= (tn-offset old-fp) ocfp-save-offset))
+ (error "tail-call-variable: ocfp not on stack in standard save location?"))
+ (unless (and (sc-is ret-addr sap-stack)
+ (= (tn-offset ret-addr) return-pc-save-offset))
+ (error "tail-call-variable: ret-addr not on stack in standard save location?"))
+
+
+ ;; And jump to the assembly routine.
+ (inst jmp (make-fixup 'tail-call-variable :assembly-routine))))
+\f
+;;;; unknown values return
+
+;;; Return a single-value using the Unknown-Values convention. Specifically,
+;;; we jump to clear the stack and jump to return-pc+2.
+;;;
+;;; We require old-fp to be in a register, because we want to reset ESP before
+;;; restoring EBP. If old-fp were still on the stack, it could get clobbered
+;;; by a signal.
+;;;
+;;; pfw--get wired-tn conflicts sometimes if register sc specd for args
+;;; having problems targeting args to regs -- using temps instead.
+(define-vop (return-single)
+ (:args (old-fp)
+ (return-pc)
+ (value))
+ (:temporary (:sc unsigned-reg) ofp)
+ (:temporary (:sc unsigned-reg) ret)
+ (:ignore value)
+ (:generator 6
+ (trace-table-entry trace-table-function-epilogue)
+ (move ret return-pc)
+ ;; Clear the control stack
+ (move ofp old-fp)
+ ;; Adjust the return address for the single value return.
+ (inst add ret 2)
+ ;; Restore the frame pointer.
+ (move esp-tn ebp-tn)
+ (move ebp-tn ofp)
+ ;; Out of here.
+ (inst jmp ret)))
+
+;;; Do unknown-values return of a fixed (other than 1) number of values. The
+;;; Values are required to be set up in the standard passing locations. Nvals
+;;; is the number of values returned.
+;;;
+;;; Basically, we just load ECX with the number of values returned and EBX
+;;; with a pointer to the values, set ESP to point to the end of the values,
+;;; and jump directly to return-pc.
+(define-vop (return)
+ (:args (old-fp)
+ (return-pc :to (:eval 1))
+ (values :more t))
+ (:ignore values)
+ (:info nvals)
+
+ ;; In the case of other than one value, we need these registers to tell
+ ;; the caller where they are and how many there are.
+ (:temporary (:sc unsigned-reg :offset ebx-offset) ebx)
+ (:temporary (:sc unsigned-reg :offset ecx-offset) ecx)
+
+ ;; We need to stretch the lifetime of return-pc past the argument
+ ;; registers so that we can default the argument registers without
+ ;; trashing return-pc.
+ (:temporary (:sc unsigned-reg :offset (first register-arg-offsets)
+ :from :eval) a0)
+ (:temporary (:sc unsigned-reg :offset (second register-arg-offsets)
+ :from :eval) a1)
+ (:temporary (:sc unsigned-reg :offset (third register-arg-offsets)
+ :from :eval) a2)
+
+ (:generator 6
+ (trace-table-entry trace-table-function-epilogue)
+ ;; Establish the values pointer and values count.
+ (move ebx ebp-tn)
+ (if (zerop nvals)
+ (inst xor ecx ecx) ; smaller
+ (inst mov ecx (fixnumize nvals)))
+ ;; restore the frame pointer.
+ (move ebp-tn old-fp)
+ ;; clear as much of the stack as possible, but not past the return
+ ;; address.
+ (inst lea esp-tn (make-ea :dword :base ebx
+ :disp (- (* (max nvals 2) word-bytes))))
+ ;; pre-default any argument register that need it.
+ (when (< nvals register-arg-count)
+ (let* ((arg-tns (nthcdr nvals (list a0 a1 a2)))
+ (first (first arg-tns)))
+ (inst mov first *nil-value*)
+ (dolist (tn (cdr arg-tns))
+ (inst mov tn first))))
+ ;; And away we go. Except that return-pc is still on the
+ ;; stack and we've changed the stack pointer. So we have to
+ ;; tell it to index off of EBX instead of EBP.
+ (cond ((zerop nvals)
+ ;; Return popping the return address and the OCFP.
+ (inst ret word-bytes))
+ ((= nvals 1)
+ ;; Return popping the return, leaving 1 slot. Can this
+ ;; happen, or is a single value return handled elsewhere?
+ (inst ret))
+ (t
+ (inst jmp (make-ea :dword :base ebx
+ :disp (- (* (1+ (tn-offset return-pc))
+ word-bytes))))))
+
+ (trace-table-entry trace-table-normal)))
+
+;;; Do unknown-values return of an arbitrary number of values (passed on the
+;;; stack.) We check for the common case of a single return value, and do that
+;;; inline using the normal single value return convention. Otherwise, we
+;;; branch off to code that calls an assembly-routine.
+;;;
+;;; The assembly routine takes the following args:
+;;; EAX -- the return-pc to finally jump to.
+;;; EBX -- pointer to where to put the values.
+;;; ECX -- number of values to find there.
+;;; ESI -- pointer to where to find the values.
+(define-vop (return-multiple)
+ (:args (old-fp :to (:eval 1) :target old-fp-temp)
+ (return-pc :target eax)
+ (vals :scs (any-reg) :target esi)
+ (nvals :scs (any-reg) :target ecx))
+
+ (:temporary (:sc unsigned-reg :offset eax-offset :from (:argument 1)) eax)
+ (:temporary (:sc unsigned-reg :offset esi-offset :from (:argument 2)) esi)
+ (:temporary (:sc unsigned-reg :offset ecx-offset :from (:argument 3)) ecx)
+ (:temporary (:sc unsigned-reg :offset ebx-offset :from (:eval 0)) ebx)
+ (:temporary (:sc descriptor-reg :offset (first register-arg-offsets)
+ :from (:eval 0)) a0)
+ (:temporary (:sc unsigned-reg :from (:eval 1)) old-fp-temp)
+ (:node-var node)
+
+ (:generator 13
+ (trace-table-entry trace-table-function-epilogue)
+ ;; Load the return-pc.
+ (move eax return-pc)
+ (unless (policy node (> space speed))
+ ;; Check for the single case.
+ (let ((not-single (gen-label)))
+ (inst cmp nvals (fixnumize 1))
+ (inst jmp :ne not-single)
+
+ ;; Return with one value.
+ (loadw a0 vals -1)
+ ;; Clear the stack. We load old-fp into a register before clearing
+ ;; the stack.
+ (move old-fp-temp old-fp)
+ (move esp-tn ebp-tn)
+ (move ebp-tn old-fp-temp)
+ ;; Fix the return-pc to point at the single-value entry point.
+ (inst add eax 2)
+ ;; Out of here.
+ (inst jmp eax)
+
+ ;; Nope, not the single case. Jump to the assembly routine.
+ (emit-label not-single)))
+ (move esi vals)
+ (move ecx nvals)
+ (move ebx ebp-tn)
+ (move ebp-tn old-fp)
+ (inst jmp (make-fixup 'return-multiple :assembly-routine))
+ (trace-table-entry trace-table-normal)))
+\f
+;;;; XEP hackery
+
+;;; We don't need to do anything special for regular functions.
+(define-vop (setup-environment)
+ (:info label)
+ (:ignore label)
+ (:generator 0
+ ;; Don't bother doing anything.
+ nil))
+
+;;; Get the lexical environment from its passing location.
+(define-vop (setup-closure-environment)
+ (:results (closure :scs (descriptor-reg)))
+ (:info label)
+ (:ignore label)
+ (:generator 6
+ ;; Get result.
+ (move closure eax-tn)))
+
+;;; Copy a more arg from the argument area to the end of the current frame.
+;;; Fixed is the number of non-more arguments.
+;;;
+;;; The tricky part is doing this without trashing any of the calling
+;;; convention registers that are still needed. This vop is emitted directly
+;;; after the xep-allocate frame. That means the registers are in use as
+;;; follows:
+;;;
+;;; EAX -- The lexenv.
+;;; EBX -- Available.
+;;; ECX -- The total number of arguments.
+;;; EDX -- The first arg.
+;;; EDI -- The second arg.
+;;; ESI -- The third arg.
+;;;
+;;; So basically, we have one register available for our use: EBX.
+;;;
+;;; What we can do is push the other regs onto the stack, and then restore
+;;; their values by looking directly below where we put the more-args.
+(define-vop (copy-more-arg)
+ (:info fixed)
+ (:generator 20
+ ;; Avoid the copy if there are no more args.
+ (cond ((zerop fixed)
+ (inst jecxz just-alloc-frame))
+ (t
+ (inst cmp ecx-tn (fixnumize fixed))
+ (inst jmp :be just-alloc-frame)))
+
+ ;; Allocate the space on the stack.
+ ;; stack = ebp - (max 3 frame-size) - (nargs - fixed)
+ (inst lea ebx-tn
+ (make-ea :dword :base ebp-tn
+ :disp (- (fixnumize fixed)
+ (* sb!vm:word-bytes
+ (max 3 (sb-allocated-size 'stack))))))
+ (inst sub ebx-tn ecx-tn) ; Got the new stack in ebx
+ (inst mov esp-tn ebx-tn)
+
+ ;; Now: nargs>=1 && nargs>fixed
+
+ ;; Save the original count of args.
+ (inst mov ebx-tn ecx-tn)
+
+ (cond ((< fixed register-arg-count)
+ ;; We must stop when we run out of stack args, not when we
+ ;; run out of more args.
+ ;; Number to copy = nargs-3
+ (inst sub ecx-tn (fixnumize register-arg-count))
+ ;; Everything of interest in registers.
+ (inst jmp :be do-regs))
+ (t
+ ;; Number to copy = nargs-fixed
+ (inst sub ecx-tn (fixnumize fixed))))
+
+ ;; Save edi and esi register args.
+ (inst push edi-tn)
+ (inst push esi-tn)
+ ;; Okay, we have pushed the register args. We can trash them
+ ;; now.
+
+ ;; Initialize dst to be end of stack; skiping the values pushed
+ ;; above.
+ (inst lea edi-tn (make-ea :dword :base esp-tn :disp 8))
+
+ ;; Initialize src to be end of args.
+ (inst mov esi-tn ebp-tn)
+ (inst sub esi-tn ebx-tn)
+
+ (inst shr ecx-tn word-shift) ; make word count
+ ;; And copy the args.
+ (inst cld) ; auto-inc ESI and EDI.
+ (inst rep)
+ (inst movs :dword)
+
+ ;; So now we need to restore EDI and ESI.
+ (inst pop esi-tn)
+ (inst pop edi-tn)
+
+ DO-REGS
+
+ ;; Restore ECX
+ (inst mov ecx-tn ebx-tn)
+
+ ;; Here: nargs>=1 && nargs>fixed
+ (when (< fixed register-arg-count)
+ ;; Now we have to deposit any more args that showed up in
+ ;; registers.
+ (do ((i fixed))
+ ( nil )
+ ;; Store it relative to ebp
+ (inst mov (make-ea :dword :base ebp-tn
+ :disp (- (* 4
+ (+ 1 (- i fixed)
+ (max 3 (sb-allocated-size 'stack))))))
+ (nth i *register-arg-tns*))
+
+ (incf i)
+ (when (>= i register-arg-count)
+ (return))
+
+ ;; Don't deposit any more than there are.
+ (if (zerop i)
+ (inst test ecx-tn ecx-tn)
+ (inst cmp ecx-tn (fixnumize i)))
+ (inst jmp :eq done)))
+
+ (inst jmp done)
+
+ JUST-ALLOC-FRAME
+ (inst lea esp-tn
+ (make-ea :dword :base ebp-tn
+ :disp (- (* sb!vm:word-bytes
+ (max 3 (sb-allocated-size 'stack))))))
+
+ DONE))
+
+;;; More args are stored contiguously on the stack, starting immediately at the
+;;; context pointer. The context pointer is not typed, so the lowtag is 0.
+(define-vop (more-arg)
+ (:translate %more-arg)
+ (:policy :fast-safe)
+ (:args (object :scs (descriptor-reg) :to :result)
+ (index :scs (any-reg) :target temp))
+ (:arg-types * tagged-num)
+ (:temporary (:sc unsigned-reg :from (:argument 1) :to :result) temp)
+ (:results (value :scs (any-reg descriptor-reg)))
+ (:result-types *)
+ (:generator 5
+ (move temp index)
+ (inst neg temp)
+ (inst mov value (make-ea :dword :base object :index temp))))
+
+(define-vop (more-arg-c)
+ (:translate %more-arg)
+ (:policy :fast-safe)
+ (:args (object :scs (descriptor-reg)))
+ (:info index)
+ (:arg-types * (:constant (signed-byte 30)))
+ (:results (value :scs (any-reg descriptor-reg)))
+ (:result-types *)
+ (:generator 4
+ (inst mov value
+ (make-ea :dword :base object :disp (- (* index word-bytes))))))
+
+
+;;; Turn more arg (context, count) into a list.
+(define-vop (listify-rest-args)
+ (:translate %listify-rest-args)
+ (:policy :safe)
+ (:args (context :scs (descriptor-reg) :target src)
+ (count :scs (any-reg) :target ecx))
+ (:arg-types * tagged-num)
+ (:temporary (:sc unsigned-reg :offset esi-offset :from (:argument 0)) src)
+ (:temporary (:sc unsigned-reg :offset ecx-offset :from (:argument 1)) ecx)
+ (:temporary (:sc unsigned-reg :offset eax-offset) eax)
+ (:temporary (:sc unsigned-reg) dst)
+ (:results (result :scs (descriptor-reg)))
+ (:node-var node)
+ (:generator 20
+ (let ((enter (gen-label))
+ (loop (gen-label))
+ (done (gen-label)))
+ (move src context)
+ (move ecx count)
+ ;; Check to see whether there are no args, and just return NIL if so.
+ (inst mov result *nil-value*)
+ (inst jecxz done)
+ (inst lea dst (make-ea :dword :index ecx :scale 2))
+ (pseudo-atomic
+ (allocation dst dst node)
+ (inst lea dst (make-ea :byte :base dst :disp list-pointer-type))
+ ;; Convert the count into a raw value, so that we can use the LOOP inst.
+ (inst shr ecx 2)
+ ;; Set decrement mode (successive args at lower addresses)
+ (inst std)
+ ;; Set up the result.
+ (move result dst)
+ ;; Jump into the middle of the loop, 'cause that's were we want
+ ;; to start.
+ (inst jmp enter)
+ (emit-label loop)
+ ;; Compute a pointer to the next cons.
+ (inst add dst (* cons-size word-bytes))
+ ;; Store a pointer to this cons in the CDR of the previous cons.
+ (storew dst dst -1 list-pointer-type)
+ (emit-label enter)
+ ;; Grab one value and stash it in the car of this cons.
+ (inst lods eax)
+ (storew eax dst 0 list-pointer-type)
+ ;; Go back for more.
+ (inst loop loop)
+ ;; NIL out the last cons.
+ (storew *nil-value* dst 1 sb!vm:list-pointer-type))
+ (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 (originally passed in
+;;; ECX.) Fixed is the number of non-rest arguments.
+;;;
+;;; 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 below the current
+;;; stack top.
+(define-vop (more-arg-context)
+ (:policy :fast-safe)
+ (:translate sb!c::%more-arg-context)
+ (:args (supplied :scs (any-reg) :target count))
+ (:arg-types positive-fixnum (:constant fixnum))
+ (:info fixed)
+ (:results (context :scs (descriptor-reg))
+ (count :scs (any-reg)))
+ (:result-types t tagged-num)
+ (:note "more-arg-context")
+ (:generator 5
+ (move count supplied)
+ ;; SP at this point points at the last arg pushed.
+ ;; Point to the first more-arg, not above it.
+ (inst lea context (make-ea :dword :base esp-tn
+ :index count :scale 1
+ :disp (- (+ (fixnumize fixed) 4))))
+ (unless (zerop fixed)
+ (inst sub count (fixnumize fixed)))))
+
+;;; Signal wrong argument count error if Nargs isn't = to Count.
+(define-vop (verify-argument-count)
+ (:policy :fast-safe)
+ (:translate sb!c::%verify-argument-count)
+ (:args (nargs :scs (any-reg)))
+ (:arg-types positive-fixnum (:constant t))
+ (:info count)
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:generator 3
+ (let ((err-lab
+ (generate-error-code vop invalid-argument-count-error nargs)))
+ (if (zerop count)
+ (inst test nargs nargs) ; smaller instruction
+ (inst cmp nargs (fixnumize count)))
+ (inst jmp :ne err-lab))))
+
+;;; Various other error signallers.
+(macrolet ((frob (name error translate &rest args)
+ `(define-vop (,name)
+ ,@(when translate
+ `((:policy :fast-safe)
+ (:translate ,translate)))
+ (:args ,@(mapcar #'(lambda (arg)
+ `(,arg :scs (any-reg descriptor-reg)))
+ args))
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:generator 1000
+ (error-call vop ,error ,@args)))))
+ (frob argument-count-error invalid-argument-count-error
+ sb!c::%argument-count-error nargs)
+ (frob type-check-error object-not-type-error sb!c::%type-check-error
+ object type)
+ (frob layout-invalid-error layout-invalid-error sb!c::%layout-invalid-error
+ object layout)
+ (frob odd-keyword-arguments-error odd-keyword-arguments-error
+ sb!c::%odd-keyword-arguments-error)
+ (frob unknown-keyword-argument-error unknown-keyword-argument-error
+ sb!c::%unknown-keyword-argument-error key)
+ (frob nil-function-returned-error nil-function-returned-error nil fun))
--- /dev/null
+;;;; various primitive memory access VOPs for the x86 VM
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!VM")
+
+(file-comment
+ "$Header$")
+\f
+;;;; data object ref/set stuff
+
+(define-vop (slot)
+ (:args (object :scs (descriptor-reg)))
+ (:info name offset lowtag)
+ (:ignore name)
+ (:results (result :scs (descriptor-reg any-reg)))
+ (:generator 1
+ (loadw result object offset lowtag)))
+
+(define-vop (set-slot)
+ (:args (object :scs (descriptor-reg))
+ (value :scs (descriptor-reg any-reg immediate)))
+ (:info name offset lowtag)
+ (:ignore name)
+ (:results)
+ (:generator 1
+ (if (sc-is value immediate)
+ (let ((val (tn-value value)))
+ (etypecase val
+ (integer
+ (inst mov
+ (make-ea :dword :base object
+ :disp (- (* offset word-bytes) lowtag))
+ (fixnumize val)))
+ (symbol
+ (inst mov
+ (make-ea :dword :base object
+ :disp (- (* offset word-bytes) lowtag))
+ (+ *nil-value* (static-symbol-offset val))))
+ (character
+ (inst mov
+ (make-ea :dword :base object
+ :disp (- (* offset word-bytes) lowtag))
+ (logior (ash (char-code val) type-bits)
+ base-char-type)))))
+ ;; Else, value not immediate.
+ (storew value object offset lowtag))))
+\f
+;;;; symbol hacking VOPs
+
+;;; these next two cf the sparc version, by jrd.
+;;; FIXME: Deref this ^ reference.
+
+;;; The compiler likes to be able to directly SET symbols.
+(define-vop (set cell-set)
+ (:variant symbol-value-slot other-pointer-type))
+
+;;; Do a cell ref with an error check for being unbound.
+(define-vop (checked-cell-ref)
+ (:args (object :scs (descriptor-reg) :target obj-temp))
+ (:results (value :scs (descriptor-reg any-reg)))
+ (:policy :fast-safe)
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:temporary (:sc descriptor-reg :from (:argument 0)) obj-temp))
+
+;;; With Symbol-Value, we check that the value isn't the trap object. So
+;;; Symbol-Value of NIL is NIL.
+(define-vop (symbol-value)
+ (:translate symbol-value)
+ (:policy :fast-safe)
+ (:args (object :scs (descriptor-reg) :to (:result 1)))
+ (:results (value :scs (descriptor-reg any-reg)))
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:generator 9
+ (let ((err-lab (generate-error-code vop unbound-symbol-error object)))
+ (loadw value object symbol-value-slot other-pointer-type)
+ (inst cmp value unbound-marker-type)
+ (inst jmp :e err-lab))))
+
+(define-vop (fast-symbol-value cell-ref)
+ (:variant symbol-value-slot other-pointer-type)
+ (:policy :fast)
+ (:translate symbol-value))
+
+(defknown fast-symbol-value-xadd (symbol fixnum) fixnum ())
+(define-vop (fast-symbol-value-xadd cell-xadd)
+ (:variant symbol-value-slot other-pointer-type)
+ (:policy :fast)
+ (:translate fast-symbol-value-xadd)
+ (:arg-types * tagged-num))
+
+(define-vop (boundp)
+ (:translate boundp)
+ (:policy :fast-safe)
+ (:args (object :scs (descriptor-reg)))
+ (:conditional)
+ (:info target not-p)
+ (:temporary (:sc descriptor-reg :from (:argument 0)) value)
+ (:generator 9
+ (loadw value object symbol-value-slot other-pointer-type)
+ (inst cmp value unbound-marker-type)
+ (inst jmp (if not-p :e :ne) target)))
+
+(define-vop (symbol-hash)
+ (:policy :fast-safe)
+ (:translate symbol-hash)
+ (:args (symbol :scs (descriptor-reg)))
+ (:results (res :scs (any-reg)))
+ (:result-types positive-fixnum)
+ (:generator 2
+ ;; The symbol-hash slot of NIL holds NIL because it is also the cdr slot,
+ ;; so we have to strip off the two low bits to make sure it is a fixnum.
+ ;;
+ ;; FIXME: Is this still true? It seems to me from my reading of
+ ;; the DEFINE-PRIMITIVE-OBJECT in objdef.lisp that the symbol-hash
+ ;; is the second slot, and offset 0 = tags and stuff (and CAR slot in
+ ;; a CONS), offset 1 = value slot (and CDR slot in a CONS), and
+ ;; offset 2 = hash slot.
+ (loadw res symbol symbol-hash-slot other-pointer-type)
+ (inst and res (lognot #b11))))
+\f
+;;;; fdefinition (fdefn) objects
+
+(define-vop (fdefn-function cell-ref) ; /pfw - alpha
+ (:variant fdefn-function-slot other-pointer-type))
+
+(define-vop (safe-fdefn-function)
+ (:args (object :scs (descriptor-reg) :to (:result 1)))
+ (:results (value :scs (descriptor-reg any-reg)))
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:generator 10
+ (loadw value object fdefn-function-slot other-pointer-type)
+ (inst cmp value *nil-value*)
+ ;; FIXME: UNDEFINED-SYMBOL-ERROR seems to actually be for symbols with no
+ ;; function value, not, as the name might suggest, symbols with no ordinary
+ ;; value. Perhaps the name could be made more mnemonic?
+ (let ((err-lab (generate-error-code vop undefined-symbol-error object)))
+ (inst jmp :e err-lab))))
+
+(define-vop (set-fdefn-function)
+ (:policy :fast-safe)
+ (:translate (setf fdefn-function))
+ (:args (function :scs (descriptor-reg) :target result)
+ (fdefn :scs (descriptor-reg)))
+ (:temporary (:sc unsigned-reg) raw)
+ (:temporary (:sc byte-reg) type)
+ (:results (result :scs (descriptor-reg)))
+ (:generator 38
+ (load-type type function (- function-pointer-type))
+ (inst lea raw
+ (make-ea :byte :base function
+ :disp (- (* function-code-offset word-bytes)
+ function-pointer-type)))
+ (inst cmp type function-header-type)
+ (inst jmp :e normal-fn)
+ (inst lea raw (make-fixup (extern-alien-name "closure_tramp") :foreign))
+ NORMAL-FN
+ (storew function fdefn fdefn-function-slot other-pointer-type)
+ (storew raw fdefn fdefn-raw-addr-slot other-pointer-type)
+ (move result function)))
+
+(define-vop (fdefn-makunbound)
+ (:policy :fast-safe)
+ (:translate fdefn-makunbound)
+ (:args (fdefn :scs (descriptor-reg) :target result))
+ (:results (result :scs (descriptor-reg)))
+ (:generator 38
+ (storew *nil-value* fdefn fdefn-function-slot other-pointer-type)
+ (storew (make-fixup (extern-alien-name "undefined_tramp") :foreign)
+ fdefn fdefn-raw-addr-slot other-pointer-type)
+ (move result fdefn)))
+\f
+;;;; binding and unbinding
+
+;;; BIND -- Establish VAL as a binding for SYMBOL. Save the old value and
+;;; the symbol on the binding stack and stuff the new value into the
+;;; symbol.
+
+(define-vop (bind)
+ (:args (val :scs (any-reg descriptor-reg))
+ (symbol :scs (descriptor-reg)))
+ (:temporary (:sc unsigned-reg) temp bsp)
+ (:generator 5
+ (load-symbol-value bsp *binding-stack-pointer*)
+ (loadw temp symbol symbol-value-slot other-pointer-type)
+ (inst add bsp (* binding-size word-bytes))
+ (store-symbol-value bsp *binding-stack-pointer*)
+ (storew temp bsp (- binding-value-slot binding-size))
+ (storew symbol bsp (- binding-symbol-slot binding-size))
+ (storew val symbol symbol-value-slot other-pointer-type)))
+
+(define-vop (unbind)
+ (:temporary (:sc unsigned-reg) symbol value bsp)
+ (:generator 0
+ (load-symbol-value bsp *binding-stack-pointer*)
+ (loadw symbol bsp (- binding-symbol-slot binding-size))
+ (loadw value bsp (- binding-value-slot binding-size))
+ (storew value symbol symbol-value-slot other-pointer-type)
+ (storew 0 bsp (- binding-symbol-slot binding-size))
+ (inst sub bsp (* binding-size word-bytes))
+ (store-symbol-value bsp *binding-stack-pointer*)))
+
+(define-vop (unbind-to-here)
+ (:args (where :scs (descriptor-reg any-reg)))
+ (:temporary (:sc unsigned-reg) symbol value bsp)
+ (:generator 0
+ (load-symbol-value bsp *binding-stack-pointer*)
+ (inst cmp where bsp)
+ (inst jmp :e done)
+
+ LOOP
+ (loadw symbol bsp (- binding-symbol-slot binding-size))
+ (inst or symbol symbol)
+ (inst jmp :z skip)
+ (loadw value bsp (- binding-value-slot binding-size))
+ (storew value symbol symbol-value-slot other-pointer-type)
+ (storew 0 bsp (- binding-symbol-slot binding-size))
+
+ SKIP
+ (inst sub bsp (* binding-size word-bytes))
+ (inst cmp where bsp)
+ (inst jmp :ne loop)
+ (store-symbol-value bsp *binding-stack-pointer*)
+
+ DONE))
+\f
+;;;; closure indexing
+
+(define-full-reffer closure-index-ref *
+ closure-info-offset function-pointer-type
+ (any-reg descriptor-reg) * %closure-index-ref)
+
+(define-full-setter set-funcallable-instance-info *
+ funcallable-instance-info-offset function-pointer-type
+ (any-reg descriptor-reg) * %set-funcallable-instance-info)
+
+(define-full-reffer funcallable-instance-info *
+ funcallable-instance-info-offset function-pointer-type
+ (descriptor-reg any-reg) * %funcallable-instance-info)
+
+(define-vop (funcallable-instance-lexenv cell-ref)
+ (:variant funcallable-instance-lexenv-slot function-pointer-type))
+
+(define-vop (closure-ref slot-ref)
+ (:variant closure-info-offset function-pointer-type))
+
+(define-vop (closure-init slot-set)
+ (:variant closure-info-offset function-pointer-type))
+\f
+;;;; value cell hackery
+
+(define-vop (value-cell-ref cell-ref)
+ (:variant value-cell-value-slot other-pointer-type))
+
+(define-vop (value-cell-set cell-set)
+ (:variant value-cell-value-slot other-pointer-type))
+\f
+;;;; structure hackery
+
+(define-vop (instance-length)
+ (:policy :fast-safe)
+ (:translate %instance-length)
+ (:args (struct :scs (descriptor-reg)))
+ (:results (res :scs (unsigned-reg)))
+ (:result-types positive-fixnum)
+ (:generator 4
+ (loadw res struct 0 instance-pointer-type)
+ (inst shr res type-bits)))
+
+(define-vop (instance-ref slot-ref)
+ (:variant instance-slots-offset instance-pointer-type)
+ (:policy :fast-safe)
+ (:translate %instance-ref)
+ (:arg-types instance (:constant index)))
+
+(define-vop (instance-set slot-set)
+ (:policy :fast-safe)
+ (:translate %instance-set)
+ (:variant instance-slots-offset instance-pointer-type)
+ (:arg-types instance (:constant index) *))
+
+(define-full-reffer instance-index-ref * instance-slots-offset
+ instance-pointer-type (any-reg descriptor-reg) * %instance-ref)
+
+(define-full-setter instance-index-set * instance-slots-offset
+ instance-pointer-type (any-reg descriptor-reg) * %instance-set)
+
+(defknown sb!kernel::%instance-set-conditional (instance index t t) t
+ (unsafe))
+
+(define-vop (instance-set-conditional-c slot-set-conditional)
+ (:policy :fast-safe)
+ (:translate sb!kernel::%instance-set-conditional)
+ (:variant instance-slots-offset instance-pointer-type)
+ (:arg-types instance (:constant index) * *))
+
+(define-vop (instance-set-conditional)
+ (:translate sb!kernel::%instance-set-conditional)
+ (:args (object :scs (descriptor-reg) :to :eval)
+ (slot :scs (any-reg) :to :result)
+ (old-value :scs (descriptor-reg any-reg) :target eax)
+ (new-value :scs (descriptor-reg any-reg) :target temp))
+ (:arg-types instance positive-fixnum * *)
+ (:temporary (:sc descriptor-reg :offset eax-offset
+ :from (:argument 1) :to :result :target result) eax)
+ (:temporary (:sc descriptor-reg :from (:argument 2) :to :result) temp)
+ (:results (result :scs (descriptor-reg)))
+ (:policy :fast-safe)
+ (:generator 5
+ (move eax old-value)
+ (move temp new-value)
+ (inst cmpxchg (make-ea :dword :base object :index slot :scale 1
+ :disp (- (* instance-slots-offset word-bytes)
+ instance-pointer-type))
+ temp)
+ (move result eax)))
+
+(defknown %instance-xadd (instance index fixnum) fixnum ())
+(define-vop (instance-xadd-c slot-xadd)
+ (:policy :fast-safe)
+ (:translate %instance-xadd)
+ (:variant instance-slots-offset instance-pointer-type)
+ (:arg-types instance (:constant index) tagged-num))
+\f
+;;;; code object frobbing
+
+(define-full-reffer code-header-ref * 0 other-pointer-type
+ (any-reg descriptor-reg) * code-header-ref)
+
+(define-full-setter code-header-set * 0 other-pointer-type
+ (any-reg descriptor-reg) * code-header-set)
--- /dev/null
+;;;; x86 definition of character operations
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!VM")
+
+(file-comment
+ "$Header$")
+\f
+;;;; moves and coercions
+
+;;; Move a tagged char to an untagged representation.
+(define-vop (move-to-base-char)
+ (:args (x :scs (any-reg control-stack) :target al))
+ (:temporary (:sc byte-reg :offset al-offset
+ :from (:argument 0) :to (:eval 0)) al)
+ (:ignore al)
+ (:temporary (:sc byte-reg :offset ah-offset :target y
+ :from (:argument 0) :to (:result 0)) ah)
+ (:results (y :scs (base-char-reg base-char-stack)))
+ (:note "character untagging")
+ (:generator 1
+ (move eax-tn x)
+ (move y ah)))
+(define-move-vop move-to-base-char :move
+ (any-reg control-stack) (base-char-reg base-char-stack))
+
+;;; Move an untagged char to a tagged representation.
+(define-vop (move-from-base-char)
+ (:args (x :scs (base-char-reg base-char-stack) :target ah))
+ (:temporary (:sc byte-reg :offset al-offset :target y
+ :from (:argument 0) :to (:result 0)) al)
+ (:temporary (:sc byte-reg :offset ah-offset
+ :from (:argument 0) :to (:result 0)) ah)
+ (:results (y :scs (any-reg descriptor-reg control-stack)))
+ (:note "character tagging")
+ (:generator 1
+ (move ah x) ; Maybe move char byte.
+ (inst mov al base-char-type) ; x86 to type bits
+ (inst and eax-tn #xffff) ; Remove any junk bits.
+ (move y eax-tn)))
+(define-move-vop move-from-base-char :move
+ (base-char-reg base-char-stack) (any-reg descriptor-reg control-stack))
+
+;;; Move untagged base-char values.
+(define-vop (base-char-move)
+ (:args (x :target y
+ :scs (base-char-reg)
+ :load-if (not (location= x y))))
+ (:results (y :scs (base-char-reg base-char-stack)
+ :load-if (not (location= x y))))
+ (:note "character move")
+ (:effects)
+ (:affected)
+ (:generator 0
+ (move y x)))
+(define-move-vop base-char-move :move
+ (base-char-reg) (base-char-reg base-char-stack))
+
+;;; Move untagged base-char arguments/return-values.
+(define-vop (move-base-char-argument)
+ (:args (x :target y
+ :scs (base-char-reg))
+ (fp :scs (any-reg)
+ :load-if (not (sc-is y base-char-reg))))
+ (:results (y))
+ (:note "character arg move")
+ (:generator 0
+ (sc-case y
+ (base-char-reg
+ (move y x))
+ (base-char-stack
+ (inst mov
+ (make-ea :byte :base fp :disp (- (* (1+ (tn-offset y)) 4)))
+ x)))))
+(define-move-vop move-base-char-argument :move-argument
+ (any-reg base-char-reg) (base-char-reg))
+
+;;; Use standard MOVE-ARGUMENT + coercion to move an untagged base-char
+;;; to a descriptor passing location.
+(define-move-vop move-argument :move-argument
+ (base-char-reg) (any-reg descriptor-reg))
+\f
+;;;; other operations
+
+(define-vop (char-code)
+ (:translate char-code)
+ (:policy :fast-safe)
+ (:args (ch :scs (base-char-reg base-char-stack)))
+ (:arg-types base-char)
+ (:results (res :scs (unsigned-reg)))
+ (:result-types positive-fixnum)
+ (:generator 1
+ (inst movzx res ch)))
+
+(define-vop (code-char)
+ (:translate code-char)
+ (:policy :fast-safe)
+ (:args (code :scs (unsigned-reg unsigned-stack) :target eax))
+ (:arg-types positive-fixnum)
+ (:temporary (:sc unsigned-reg :offset eax-offset :target res
+ :from (:argument 0) :to (:result 0))
+ eax)
+ (:results (res :scs (base-char-reg)))
+ (:result-types base-char)
+ (:generator 1
+ (move eax code)
+ (move res al-tn)))
+\f
+;;; comparison of BASE-CHARs
+(define-vop (base-char-compare)
+ (:args (x :scs (base-char-reg base-char-stack))
+ (y :scs (base-char-reg)
+ :load-if (not (and (sc-is x base-char-reg)
+ (sc-is y base-char-stack)))))
+ (:arg-types base-char base-char)
+ (:conditional)
+ (:info target not-p)
+ (:policy :fast-safe)
+ (:note "inline comparison")
+ (:variant-vars condition not-condition)
+ (:generator 3
+ (inst cmp x y)
+ (inst jmp (if not-p not-condition condition) target)))
+
+(define-vop (fast-char=/base-char base-char-compare)
+ (:translate char=)
+ (:variant :e :ne))
+
+(define-vop (fast-char</base-char base-char-compare)
+ (:translate char<)
+ (:variant :b :nb))
+
+(define-vop (fast-char>/base-char base-char-compare)
+ (:translate char>)
+ (:variant :a :na))
--- /dev/null
+;;;; x86 support for the debugger
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!VM")
+
+(file-comment
+ "$Header$")
+
+(define-vop (debug-cur-sp)
+ (:translate current-sp)
+ (:policy :fast-safe)
+ (:results (res :scs (sap-reg sap-stack)))
+ (:result-types system-area-pointer)
+ (:generator 1
+ (move res esp-tn)))
+
+(define-vop (debug-cur-fp)
+ (:translate current-fp)
+ (:policy :fast-safe)
+ (:results (res :scs (sap-reg sap-stack)))
+ (:result-types system-area-pointer)
+ (:generator 1
+ (move res ebp-tn)))
+
+;;; Stack-ref and %set-stack-ref can be used to read and store
+;;; descriptor objects on the control stack. Use the sap-ref
+;;; functions to access other data types.
+(define-vop (read-control-stack)
+ (:translate stack-ref)
+ (:policy :fast-safe)
+ (:args (sap :scs (sap-reg) :to :eval)
+ (offset :scs (any-reg) :target temp))
+ (:arg-types system-area-pointer positive-fixnum)
+ (:temporary (:sc unsigned-reg :from (:argument 1)) temp)
+ (:results (result :scs (descriptor-reg)))
+ (:result-types *)
+ (:generator 9
+ (move temp offset)
+ (inst neg temp)
+ (inst mov result
+ (make-ea :dword :base sap :disp (- word-bytes) :index temp))))
+
+(define-vop (read-control-stack-c)
+ (:translate stack-ref)
+ (:policy :fast-safe)
+ (:args (sap :scs (sap-reg)))
+ (:info index)
+ (:arg-types system-area-pointer (:constant (signed-byte 30)))
+ (:results (result :scs (descriptor-reg)))
+ (:result-types *)
+ (:generator 5
+ (inst mov result (make-ea :dword :base sap
+ :disp (- (* (1+ index) word-bytes))))))
+
+(define-vop (write-control-stack)
+ (:translate %set-stack-ref)
+ (:policy :fast-safe)
+ (:args (sap :scs (sap-reg) :to :eval)
+ (offset :scs (any-reg) :target temp)
+ (value :scs (descriptor-reg) :to :result :target result))
+ (:arg-types system-area-pointer positive-fixnum *)
+ (:temporary (:sc unsigned-reg :from (:argument 1) :to :result) temp)
+ (:results (result :scs (descriptor-reg)))
+ (:result-types *)
+ (:generator 9
+ (move temp offset)
+ (inst neg temp)
+ (inst mov
+ (make-ea :dword :base sap :disp (- word-bytes) :index temp) value)
+ (move result value)))
+
+(define-vop (write-control-stack-c)
+ (:translate %set-stack-ref)
+ (:policy :fast-safe)
+ (:args (sap :scs (sap-reg))
+ (value :scs (descriptor-reg) :target result))
+ (:info index)
+ (:arg-types system-area-pointer (:constant (signed-byte 30)) *)
+ (:results (result :scs (descriptor-reg)))
+ (:result-types *)
+ (:generator 5
+ (inst mov (make-ea :dword :base sap
+ :disp (- (* (1+ index) word-bytes)))
+ value)
+ (move result value)))
+
+(define-vop (code-from-mumble)
+ (:policy :fast-safe)
+ (:args (thing :scs (descriptor-reg)))
+ (:results (code :scs (descriptor-reg)))
+ (:temporary (:sc unsigned-reg) temp)
+ (:variant-vars lowtag)
+ (:generator 5
+ (let ((bogus (gen-label))
+ (done (gen-label)))
+ (loadw temp thing 0 lowtag)
+ (inst shr temp type-bits)
+ (inst jmp :z bogus)
+ (inst shl temp (1- (integer-length word-bytes)))
+ (unless (= lowtag other-pointer-type)
+ (inst add temp (- lowtag other-pointer-type)))
+ (move code thing)
+ (inst sub code temp)
+ (emit-label done)
+ (assemble (*elsewhere*)
+ (emit-label bogus)
+ (inst mov code *nil-value*)
+ (inst jmp done)))))
+
+(define-vop (code-from-lra code-from-mumble)
+ (:translate sb!di::lra-code-header)
+ (:variant other-pointer-type))
+
+(define-vop (code-from-function code-from-mumble)
+ (:translate sb!di::function-code-header)
+ (:variant function-pointer-type))
+
+(define-vop (make-lisp-obj)
+ (:policy :fast-safe)
+ (:translate sb!di::make-lisp-obj)
+ (:args (value :scs (unsigned-reg unsigned-stack) :target result))
+ (:arg-types unsigned-num)
+ (:results (result :scs (descriptor-reg)
+ :load-if (not (sc-is value unsigned-reg))
+ ))
+ (:generator 1
+ (move result value)))
+
+(define-vop (get-lisp-obj-address)
+ (:policy :fast-safe)
+ (:translate sb!di::get-lisp-obj-address)
+ (:args (thing :scs (descriptor-reg control-stack) :target result))
+ (:results (result :scs (unsigned-reg)
+ :load-if (not (and (sc-is thing descriptor-reg)
+ (sc-is result unsigned-stack)))))
+ (:result-types unsigned-num)
+ (:generator 1
+ (move result thing)))
+
+
+(define-vop (function-word-offset)
+ (:policy :fast-safe)
+ (:translate sb!di::function-word-offset)
+ (:args (fun :scs (descriptor-reg)))
+ (:results (res :scs (unsigned-reg)))
+ (:result-types positive-fixnum)
+ (:generator 5
+ (loadw res fun 0 function-pointer-type)
+ (inst shr res type-bits)))
--- /dev/null
+;;;; floating point support for the x86
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!VM")
+
+(file-comment
+ "$Header$")
+\f
+(macrolet ((ea-for-xf-desc (tn slot)
+ `(make-ea
+ :dword :base ,tn
+ :disp (- (* ,slot sb!vm:word-bytes) sb!vm:other-pointer-type))))
+ (defun ea-for-sf-desc (tn)
+ (ea-for-xf-desc tn sb!vm:single-float-value-slot))
+ (defun ea-for-df-desc (tn)
+ (ea-for-xf-desc tn sb!vm:double-float-value-slot))
+ #!+long-float
+ (defun ea-for-lf-desc (tn)
+ (ea-for-xf-desc tn sb!vm:long-float-value-slot))
+ ;; complex floats
+ (defun ea-for-csf-real-desc (tn)
+ (ea-for-xf-desc tn sb!vm:complex-single-float-real-slot))
+ (defun ea-for-csf-imag-desc (tn)
+ (ea-for-xf-desc tn sb!vm:complex-single-float-imag-slot))
+ (defun ea-for-cdf-real-desc (tn)
+ (ea-for-xf-desc tn sb!vm:complex-double-float-real-slot))
+ (defun ea-for-cdf-imag-desc (tn)
+ (ea-for-xf-desc tn sb!vm:complex-double-float-imag-slot))
+ #!+long-float
+ (defun ea-for-clf-real-desc (tn)
+ (ea-for-xf-desc tn sb!vm:complex-long-float-real-slot))
+ #!+long-float
+ (defun ea-for-clf-imag-desc (tn)
+ (ea-for-xf-desc tn sb!vm:complex-long-float-imag-slot)))
+
+(macrolet ((ea-for-xf-stack (tn kind)
+ `(make-ea
+ :dword :base ebp-tn
+ :disp (- (* (+ (tn-offset ,tn)
+ (ecase ,kind (:single 1) (:double 2) (:long 3)))
+ sb!vm:word-bytes)))))
+ (defun ea-for-sf-stack (tn)
+ (ea-for-xf-stack tn :single))
+ (defun ea-for-df-stack (tn)
+ (ea-for-xf-stack tn :double))
+ #!+long-float
+ (defun ea-for-lf-stack (tn)
+ (ea-for-xf-stack tn :long)))
+
+;;; Complex float stack EAs
+(macrolet ((ea-for-cxf-stack (tn kind slot &optional base)
+ `(make-ea
+ :dword :base ,base
+ :disp (- (* (+ (tn-offset ,tn)
+ (* (ecase ,kind
+ (:single 1)
+ (:double 2)
+ (:long 3))
+ (ecase ,slot (:real 1) (:imag 2))))
+ sb!vm:word-bytes)))))
+ (defun ea-for-csf-real-stack (tn &optional (base ebp-tn))
+ (ea-for-cxf-stack tn :single :real base))
+ (defun ea-for-csf-imag-stack (tn &optional (base ebp-tn))
+ (ea-for-cxf-stack tn :single :imag base))
+ (defun ea-for-cdf-real-stack (tn &optional (base ebp-tn))
+ (ea-for-cxf-stack tn :double :real base))
+ (defun ea-for-cdf-imag-stack (tn &optional (base ebp-tn))
+ (ea-for-cxf-stack tn :double :imag base))
+ #!+long-float
+ (defun ea-for-clf-real-stack (tn &optional (base ebp-tn))
+ (ea-for-cxf-stack tn :long :real base))
+ #!+long-float
+ (defun ea-for-clf-imag-stack (tn &optional (base ebp-tn))
+ (ea-for-cxf-stack tn :long :imag base)))
+
+;;; Abstract out the copying of a FP register to the FP stack top, and
+;;; provide two alternatives for its implementation. Note: it's not
+;;; necessary to distinguish between a single or double register move
+;;; here.
+;;;
+;;; Using a Pop then load.
+(defun copy-fp-reg-to-fr0 (reg)
+ (assert (not (zerop (tn-offset reg))))
+ (inst fstp fr0-tn)
+ (inst fld (make-random-tn :kind :normal
+ :sc (sc-or-lose 'double-reg)
+ :offset (1- (tn-offset reg)))))
+;;; Using Fxch then Fst to restore the original reg contents.
+#+nil
+(defun copy-fp-reg-to-fr0 (reg)
+ (assert (not (zerop (tn-offset reg))))
+ (inst fxch reg)
+ (inst fst reg))
+
+;;; The x86 can't store a long-float to memory without popping the
+;;; stack and marking a register as empty, so it is necessary to
+;;; restore the register from memory.
+#!+long-float
+(defun store-long-float (ea)
+ (inst fstpl ea)
+ (inst fldl ea))
+\f
+;;;; move functions
+
+;;; x is source, y is destination
+(define-move-function (load-single 2) (vop x y)
+ ((single-stack) (single-reg))
+ (with-empty-tn@fp-top(y)
+ (inst fld (ea-for-sf-stack x))))
+
+(define-move-function (store-single 2) (vop x y)
+ ((single-reg) (single-stack))
+ (cond ((zerop (tn-offset x))
+ (inst fst (ea-for-sf-stack y)))
+ (t
+ (inst fxch x)
+ (inst fst (ea-for-sf-stack y))
+ ;; This may not be necessary as ST0 is likely invalid now.
+ (inst fxch x))))
+
+(define-move-function (load-double 2) (vop x y)
+ ((double-stack) (double-reg))
+ (with-empty-tn@fp-top(y)
+ (inst fldd (ea-for-df-stack x))))
+
+(define-move-function (store-double 2) (vop x y)
+ ((double-reg) (double-stack))
+ (cond ((zerop (tn-offset x))
+ (inst fstd (ea-for-df-stack y)))
+ (t
+ (inst fxch x)
+ (inst fstd (ea-for-df-stack y))
+ ;; This may not be necessary as ST0 is likely invalid now.
+ (inst fxch x))))
+
+#!+long-float
+(define-move-function (load-long 2) (vop x y)
+ ((long-stack) (long-reg))
+ (with-empty-tn@fp-top(y)
+ (inst fldl (ea-for-lf-stack x))))
+
+#!+long-float
+(define-move-function (store-long 2) (vop x y)
+ ((long-reg) (long-stack))
+ (cond ((zerop (tn-offset x))
+ (store-long-float (ea-for-lf-stack y)))
+ (t
+ (inst fxch x)
+ (store-long-float (ea-for-lf-stack y))
+ ;; This may not be necessary as ST0 is likely invalid now.
+ (inst fxch x))))
+
+;;; The i387 has instructions to load some useful constants.
+;;; This doesn't save much time but might cut down on memory
+;;; access and reduce the size of the constant vector (CV).
+;;; Intel claims they are stored in a more precise form on chip.
+;;; Anyhow, might as well use the feature. It can be turned
+;;; off by hacking the "immediate-constant-sc" in vm.lisp.
+(define-move-function (load-fp-constant 2) (vop x y)
+ ((fp-constant) (single-reg double-reg #!+long-float long-reg))
+ (let ((value (sb!c::constant-value (sb!c::tn-leaf x))))
+ (with-empty-tn@fp-top(y)
+ (cond ((zerop value)
+ (inst fldz))
+ ((= value 1l0)
+ (inst fld1))
+ ((= value pi)
+ (inst fldpi))
+ ((= value (log 10l0 2l0))
+ (inst fldl2t))
+ ((= value (log 2.718281828459045235360287471352662L0 2l0))
+ (inst fldl2e))
+ ((= value (log 2l0 10l0))
+ (inst fldlg2))
+ ((= value (log 2l0 2.718281828459045235360287471352662L0))
+ (inst fldln2))
+ (t (warn "Ignoring bogus i387 Constant ~A" value))))))
+
+\f
+;;;; complex float move functions
+
+(defun complex-single-reg-real-tn (x)
+ (make-random-tn :kind :normal :sc (sc-or-lose 'single-reg)
+ :offset (tn-offset x)))
+(defun complex-single-reg-imag-tn (x)
+ (make-random-tn :kind :normal :sc (sc-or-lose 'single-reg)
+ :offset (1+ (tn-offset x))))
+
+(defun complex-double-reg-real-tn (x)
+ (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg)
+ :offset (tn-offset x)))
+(defun complex-double-reg-imag-tn (x)
+ (make-random-tn :kind :normal :sc (sc-or-lose 'double-reg)
+ :offset (1+ (tn-offset x))))
+
+#!+long-float
+(defun complex-long-reg-real-tn (x)
+ (make-random-tn :kind :normal :sc (sc-or-lose 'long-reg)
+ :offset (tn-offset x)))
+#!+long-float
+(defun complex-long-reg-imag-tn (x)
+ (make-random-tn :kind :normal :sc (sc-or-lose 'long-reg)
+ :offset (1+ (tn-offset x))))
+
+;;; x is source, y is destination
+(define-move-function (load-complex-single 2) (vop x y)
+ ((complex-single-stack) (complex-single-reg))
+ (let ((real-tn (complex-single-reg-real-tn y)))
+ (with-empty-tn@fp-top (real-tn)
+ (inst fld (ea-for-csf-real-stack x))))
+ (let ((imag-tn (complex-single-reg-imag-tn y)))
+ (with-empty-tn@fp-top (imag-tn)
+ (inst fld (ea-for-csf-imag-stack x)))))
+
+(define-move-function (store-complex-single 2) (vop x y)
+ ((complex-single-reg) (complex-single-stack))
+ (let ((real-tn (complex-single-reg-real-tn x)))
+ (cond ((zerop (tn-offset real-tn))
+ (inst fst (ea-for-csf-real-stack y)))
+ (t
+ (inst fxch real-tn)
+ (inst fst (ea-for-csf-real-stack y))
+ (inst fxch real-tn))))
+ (let ((imag-tn (complex-single-reg-imag-tn x)))
+ (inst fxch imag-tn)
+ (inst fst (ea-for-csf-imag-stack y))
+ (inst fxch imag-tn)))
+
+(define-move-function (load-complex-double 2) (vop x y)
+ ((complex-double-stack) (complex-double-reg))
+ (let ((real-tn (complex-double-reg-real-tn y)))
+ (with-empty-tn@fp-top(real-tn)
+ (inst fldd (ea-for-cdf-real-stack x))))
+ (let ((imag-tn (complex-double-reg-imag-tn y)))
+ (with-empty-tn@fp-top(imag-tn)
+ (inst fldd (ea-for-cdf-imag-stack x)))))
+
+(define-move-function (store-complex-double 2) (vop x y)
+ ((complex-double-reg) (complex-double-stack))
+ (let ((real-tn (complex-double-reg-real-tn x)))
+ (cond ((zerop (tn-offset real-tn))
+ (inst fstd (ea-for-cdf-real-stack y)))
+ (t
+ (inst fxch real-tn)
+ (inst fstd (ea-for-cdf-real-stack y))
+ (inst fxch real-tn))))
+ (let ((imag-tn (complex-double-reg-imag-tn x)))
+ (inst fxch imag-tn)
+ (inst fstd (ea-for-cdf-imag-stack y))
+ (inst fxch imag-tn)))
+
+#!+long-float
+(define-move-function (load-complex-long 2) (vop x y)
+ ((complex-long-stack) (complex-long-reg))
+ (let ((real-tn (complex-long-reg-real-tn y)))
+ (with-empty-tn@fp-top(real-tn)
+ (inst fldl (ea-for-clf-real-stack x))))
+ (let ((imag-tn (complex-long-reg-imag-tn y)))
+ (with-empty-tn@fp-top(imag-tn)
+ (inst fldl (ea-for-clf-imag-stack x)))))
+
+#!+long-float
+(define-move-function (store-complex-long 2) (vop x y)
+ ((complex-long-reg) (complex-long-stack))
+ (let ((real-tn (complex-long-reg-real-tn x)))
+ (cond ((zerop (tn-offset real-tn))
+ (store-long-float (ea-for-clf-real-stack y)))
+ (t
+ (inst fxch real-tn)
+ (store-long-float (ea-for-clf-real-stack y))
+ (inst fxch real-tn))))
+ (let ((imag-tn (complex-long-reg-imag-tn x)))
+ (inst fxch imag-tn)
+ (store-long-float (ea-for-clf-imag-stack y))
+ (inst fxch imag-tn)))
+
+\f
+;;;; move VOPs
+
+;;; Float register to register moves.
+(define-vop (float-move)
+ (:args (x))
+ (:results (y))
+ (:note "float move")
+ (:generator 0
+ (unless (location= x y)
+ (cond ((zerop (tn-offset y))
+ (copy-fp-reg-to-fr0 x))
+ ((zerop (tn-offset x))
+ (inst fstd y))
+ (t
+ (inst fxch x)
+ (inst fstd y)
+ (inst fxch x))))))
+
+(define-vop (single-move float-move)
+ (:args (x :scs (single-reg) :target y :load-if (not (location= x y))))
+ (:results (y :scs (single-reg) :load-if (not (location= x y)))))
+(define-move-vop single-move :move (single-reg) (single-reg))
+
+(define-vop (double-move float-move)
+ (:args (x :scs (double-reg) :target y :load-if (not (location= x y))))
+ (:results (y :scs (double-reg) :load-if (not (location= x y)))))
+(define-move-vop double-move :move (double-reg) (double-reg))
+
+#!+long-float
+(define-vop (long-move float-move)
+ (:args (x :scs (long-reg) :target y :load-if (not (location= x y))))
+ (:results (y :scs (long-reg) :load-if (not (location= x y)))))
+#!+long-float
+(define-move-vop long-move :move (long-reg) (long-reg))
+
+;;; complex float register to register moves
+(define-vop (complex-float-move)
+ (:args (x :target y :load-if (not (location= x y))))
+ (:results (y :load-if (not (location= x y))))
+ (:note "complex float move")
+ (:generator 0
+ (unless (location= x y)
+ ;; Note the complex-float-regs are aligned to every second
+ ;; float register so there is not need to worry about overlap.
+ (let ((x-real (complex-double-reg-real-tn x))
+ (y-real (complex-double-reg-real-tn y)))
+ (cond ((zerop (tn-offset y-real))
+ (copy-fp-reg-to-fr0 x-real))
+ ((zerop (tn-offset x-real))
+ (inst fstd y-real))
+ (t
+ (inst fxch x-real)
+ (inst fstd y-real)
+ (inst fxch x-real))))
+ (let ((x-imag (complex-double-reg-imag-tn x))
+ (y-imag (complex-double-reg-imag-tn y)))
+ (inst fxch x-imag)
+ (inst fstd y-imag)
+ (inst fxch x-imag)))))
+
+(define-vop (complex-single-move complex-float-move)
+ (:args (x :scs (complex-single-reg) :target y
+ :load-if (not (location= x y))))
+ (:results (y :scs (complex-single-reg) :load-if (not (location= x y)))))
+(define-move-vop complex-single-move :move
+ (complex-single-reg) (complex-single-reg))
+
+(define-vop (complex-double-move complex-float-move)
+ (:args (x :scs (complex-double-reg)
+ :target y :load-if (not (location= x y))))
+ (:results (y :scs (complex-double-reg) :load-if (not (location= x y)))))
+(define-move-vop complex-double-move :move
+ (complex-double-reg) (complex-double-reg))
+
+#!+long-float
+(define-vop (complex-long-move complex-float-move)
+ (:args (x :scs (complex-long-reg)
+ :target y :load-if (not (location= x y))))
+ (:results (y :scs (complex-long-reg) :load-if (not (location= x y)))))
+#!+long-float
+(define-move-vop complex-long-move :move
+ (complex-long-reg) (complex-long-reg))
+\f
+;;; Move from float to a descriptor reg. allocating a new float
+;;; object in the process.
+(define-vop (move-from-single)
+ (:args (x :scs (single-reg) :to :save))
+ (:results (y :scs (descriptor-reg)))
+ (:node-var node)
+ (:note "float to pointer coercion")
+ (:generator 13
+ (with-fixed-allocation (y
+ sb!vm:single-float-type
+ sb!vm:single-float-size node)
+ (with-tn@fp-top(x)
+ (inst fst (ea-for-sf-desc y))))))
+(define-move-vop move-from-single :move
+ (single-reg) (descriptor-reg))
+
+(define-vop (move-from-double)
+ (:args (x :scs (double-reg) :to :save))
+ (:results (y :scs (descriptor-reg)))
+ (:node-var node)
+ (:note "float to pointer coercion")
+ (:generator 13
+ (with-fixed-allocation (y
+ sb!vm:double-float-type
+ sb!vm:double-float-size
+ node)
+ (with-tn@fp-top(x)
+ (inst fstd (ea-for-df-desc y))))))
+(define-move-vop move-from-double :move
+ (double-reg) (descriptor-reg))
+
+#!+long-float
+(define-vop (move-from-long)
+ (:args (x :scs (long-reg) :to :save))
+ (:results (y :scs (descriptor-reg)))
+ (:node-var node)
+ (:note "float to pointer coercion")
+ (:generator 13
+ (with-fixed-allocation (y
+ sb!vm:long-float-type
+ sb!vm:long-float-size
+ node)
+ (with-tn@fp-top(x)
+ (store-long-float (ea-for-lf-desc y))))))
+#!+long-float
+(define-move-vop move-from-long :move
+ (long-reg) (descriptor-reg))
+
+(define-vop (move-from-fp-constant)
+ (:args (x :scs (fp-constant)))
+ (:results (y :scs (descriptor-reg)))
+ (:generator 2
+ (ecase (sb!c::constant-value (sb!c::tn-leaf x))
+ (0f0 (load-symbol-value y *fp-constant-0s0*))
+ (1f0 (load-symbol-value y *fp-constant-1s0*))
+ (0d0 (load-symbol-value y *fp-constant-0d0*))
+ (1d0 (load-symbol-value y *fp-constant-1d0*))
+ #!+long-float
+ (0l0 (load-symbol-value y *fp-constant-0l0*))
+ #!+long-float
+ (1l0 (load-symbol-value y *fp-constant-1l0*))
+ #!+long-float
+ (#.pi (load-symbol-value y *fp-constant-pi*))
+ #!+long-float
+ (#.(log 10l0 2l0) (load-symbol-value y *fp-constant-l2t*))
+ #!+long-float
+ (#.(log 2.718281828459045235360287471352662L0 2l0)
+ (load-symbol-value y *fp-constant-l2e*))
+ #!+long-float
+ (#.(log 2l0 10l0) (load-symbol-value y *fp-constant-lg2*))
+ #!+long-float
+ (#.(log 2l0 2.718281828459045235360287471352662L0)
+ (load-symbol-value y *fp-constant-ln2*)))))
+(define-move-vop move-from-fp-constant :move
+ (fp-constant) (descriptor-reg))
+
+;;; Move from a descriptor to a float register
+(define-vop (move-to-single)
+ (:args (x :scs (descriptor-reg)))
+ (:results (y :scs (single-reg)))
+ (:note "pointer to float coercion")
+ (:generator 2
+ (with-empty-tn@fp-top(y)
+ (inst fld (ea-for-sf-desc x)))))
+(define-move-vop move-to-single :move (descriptor-reg) (single-reg))
+
+(define-vop (move-to-double)
+ (:args (x :scs (descriptor-reg)))
+ (:results (y :scs (double-reg)))
+ (:note "pointer to float coercion")
+ (:generator 2
+ (with-empty-tn@fp-top(y)
+ (inst fldd (ea-for-df-desc x)))))
+(define-move-vop move-to-double :move (descriptor-reg) (double-reg))
+
+#!+long-float
+(define-vop (move-to-long)
+ (:args (x :scs (descriptor-reg)))
+ (:results (y :scs (long-reg)))
+ (:note "pointer to float coercion")
+ (:generator 2
+ (with-empty-tn@fp-top(y)
+ (inst fldl (ea-for-lf-desc x)))))
+#!+long-float
+(define-move-vop move-to-long :move (descriptor-reg) (long-reg))
+
+\f
+;;; Move from complex float to a descriptor reg. allocating a new
+;;; complex float object in the process.
+(define-vop (move-from-complex-single)
+ (:args (x :scs (complex-single-reg) :to :save))
+ (:results (y :scs (descriptor-reg)))
+ (:node-var node)
+ (:note "complex float to pointer coercion")
+ (:generator 13
+ (with-fixed-allocation (y
+ sb!vm:complex-single-float-type
+ sb!vm:complex-single-float-size node)
+ (let ((real-tn (complex-single-reg-real-tn x)))
+ (with-tn@fp-top(real-tn)
+ (inst fst (ea-for-csf-real-desc y))))
+ (let ((imag-tn (complex-single-reg-imag-tn x)))
+ (with-tn@fp-top(imag-tn)
+ (inst fst (ea-for-csf-imag-desc y)))))))
+(define-move-vop move-from-complex-single :move
+ (complex-single-reg) (descriptor-reg))
+
+(define-vop (move-from-complex-double)
+ (:args (x :scs (complex-double-reg) :to :save))
+ (:results (y :scs (descriptor-reg)))
+ (:node-var node)
+ (:note "complex float to pointer coercion")
+ (:generator 13
+ (with-fixed-allocation (y
+ sb!vm:complex-double-float-type
+ sb!vm:complex-double-float-size
+ node)
+ (let ((real-tn (complex-double-reg-real-tn x)))
+ (with-tn@fp-top(real-tn)
+ (inst fstd (ea-for-cdf-real-desc y))))
+ (let ((imag-tn (complex-double-reg-imag-tn x)))
+ (with-tn@fp-top(imag-tn)
+ (inst fstd (ea-for-cdf-imag-desc y)))))))
+(define-move-vop move-from-complex-double :move
+ (complex-double-reg) (descriptor-reg))
+
+#!+long-float
+(define-vop (move-from-complex-long)
+ (:args (x :scs (complex-long-reg) :to :save))
+ (:results (y :scs (descriptor-reg)))
+ (:node-var node)
+ (:note "complex float to pointer coercion")
+ (:generator 13
+ (with-fixed-allocation (y
+ sb!vm:complex-long-float-type
+ sb!vm:complex-long-float-size
+ node)
+ (let ((real-tn (complex-long-reg-real-tn x)))
+ (with-tn@fp-top(real-tn)
+ (store-long-float (ea-for-clf-real-desc y))))
+ (let ((imag-tn (complex-long-reg-imag-tn x)))
+ (with-tn@fp-top(imag-tn)
+ (store-long-float (ea-for-clf-imag-desc y)))))))
+#!+long-float
+(define-move-vop move-from-complex-long :move
+ (complex-long-reg) (descriptor-reg))
+
+;;; Move from a descriptor to a complex float register
+(macrolet ((frob (name sc format)
+ `(progn
+ (define-vop (,name)
+ (:args (x :scs (descriptor-reg)))
+ (:results (y :scs (,sc)))
+ (:note "pointer to complex float coercion")
+ (:generator 2
+ (let ((real-tn (complex-double-reg-real-tn y)))
+ (with-empty-tn@fp-top(real-tn)
+ ,@(ecase format
+ (:single '((inst fld (ea-for-csf-real-desc x))))
+ (:double '((inst fldd (ea-for-cdf-real-desc x))))
+ #!+long-float
+ (:long '((inst fldl (ea-for-clf-real-desc x)))))))
+ (let ((imag-tn (complex-double-reg-imag-tn y)))
+ (with-empty-tn@fp-top(imag-tn)
+ ,@(ecase format
+ (:single '((inst fld (ea-for-csf-imag-desc x))))
+ (:double '((inst fldd (ea-for-cdf-imag-desc x))))
+ #!+long-float
+ (:long '((inst fldl (ea-for-clf-imag-desc x)))))))))
+ (define-move-vop ,name :move (descriptor-reg) (,sc)))))
+ (frob move-to-complex-single complex-single-reg :single)
+ (frob move-to-complex-double complex-double-reg :double)
+ #!+long-float
+ (frob move-to-complex-double complex-long-reg :long))
+
+\f
+;;;; The move argument vops.
+;;;;
+;;;; Note these are also used to stuff fp numbers onto the c-call stack
+;;;; so the order is different than the lisp-stack.
+
+;;; The general move-argument vop
+(macrolet ((frob (name sc stack-sc format)
+ `(progn
+ (define-vop (,name)
+ (:args (x :scs (,sc) :target y)
+ (fp :scs (any-reg)
+ :load-if (not (sc-is y ,sc))))
+ (:results (y))
+ (:note "float argument move")
+ (:generator ,(case format (:single 2) (:double 3) (:long 4))
+ (sc-case y
+ (,sc
+ (unless (location= x y)
+ (cond ((zerop (tn-offset y))
+ (copy-fp-reg-to-fr0 x))
+ ((zerop (tn-offset x))
+ (inst fstd y))
+ (t
+ (inst fxch x)
+ (inst fstd y)
+ (inst fxch x)))))
+ (,stack-sc
+ (if (= (tn-offset fp) esp-offset)
+ (let* ((offset (* (tn-offset y) word-bytes))
+ (ea (make-ea :dword :base fp :disp offset)))
+ (with-tn@fp-top(x)
+ ,@(ecase format
+ (:single '((inst fst ea)))
+ (:double '((inst fstd ea)))
+ #!+long-float
+ (:long '((store-long-float ea))))))
+ (let ((ea (make-ea
+ :dword :base fp
+ :disp (- (* (+ (tn-offset y)
+ ,(case format
+ (:single 1)
+ (:double 2)
+ (:long 3)))
+ sb!vm:word-bytes)))))
+ (with-tn@fp-top(x)
+ ,@(ecase format
+ (:single '((inst fst ea)))
+ (:double '((inst fstd ea)))
+ #!+long-float
+ (:long '((store-long-float ea)))))))))))
+ (define-move-vop ,name :move-argument
+ (,sc descriptor-reg) (,sc)))))
+ (frob move-single-float-argument single-reg single-stack :single)
+ (frob move-double-float-argument double-reg double-stack :double)
+ #!+long-float
+ (frob move-long-float-argument long-reg long-stack :long))
+
+;;;; Complex float move-argument vop
+(macrolet ((frob (name sc stack-sc format)
+ `(progn
+ (define-vop (,name)
+ (:args (x :scs (,sc) :target y)
+ (fp :scs (any-reg)
+ :load-if (not (sc-is y ,sc))))
+ (:results (y))
+ (:note "complex float argument move")
+ (:generator ,(ecase format (:single 2) (:double 3) (:long 4))
+ (sc-case y
+ (,sc
+ (unless (location= x y)
+ (let ((x-real (complex-double-reg-real-tn x))
+ (y-real (complex-double-reg-real-tn y)))
+ (cond ((zerop (tn-offset y-real))
+ (copy-fp-reg-to-fr0 x-real))
+ ((zerop (tn-offset x-real))
+ (inst fstd y-real))
+ (t
+ (inst fxch x-real)
+ (inst fstd y-real)
+ (inst fxch x-real))))
+ (let ((x-imag (complex-double-reg-imag-tn x))
+ (y-imag (complex-double-reg-imag-tn y)))
+ (inst fxch x-imag)
+ (inst fstd y-imag)
+ (inst fxch x-imag))))
+ (,stack-sc
+ (let ((real-tn (complex-double-reg-real-tn x)))
+ (cond ((zerop (tn-offset real-tn))
+ ,@(ecase format
+ (:single
+ '((inst fst
+ (ea-for-csf-real-stack y fp))))
+ (:double
+ '((inst fstd
+ (ea-for-cdf-real-stack y fp))))
+ #!+long-float
+ (:long
+ '((store-long-float
+ (ea-for-clf-real-stack y fp))))))
+ (t
+ (inst fxch real-tn)
+ ,@(ecase format
+ (:single
+ '((inst fst
+ (ea-for-csf-real-stack y fp))))
+ (:double
+ '((inst fstd
+ (ea-for-cdf-real-stack y fp))))
+ #!+long-float
+ (:long
+ '((store-long-float
+ (ea-for-clf-real-stack y fp)))))
+ (inst fxch real-tn))))
+ (let ((imag-tn (complex-double-reg-imag-tn x)))
+ (inst fxch imag-tn)
+ ,@(ecase format
+ (:single
+ '((inst fst (ea-for-csf-imag-stack y fp))))
+ (:double
+ '((inst fstd (ea-for-cdf-imag-stack y fp))))
+ #!+long-float
+ (:long
+ '((store-long-float
+ (ea-for-clf-imag-stack y fp)))))
+ (inst fxch imag-tn))))))
+ (define-move-vop ,name :move-argument
+ (,sc descriptor-reg) (,sc)))))
+ (frob move-complex-single-float-argument
+ complex-single-reg complex-single-stack :single)
+ (frob move-complex-double-float-argument
+ complex-double-reg complex-double-stack :double)
+ #!+long-float
+ (frob move-complex-long-float-argument
+ complex-long-reg complex-long-stack :long))
+
+(define-move-vop move-argument :move-argument
+ (single-reg double-reg #!+long-float long-reg
+ complex-single-reg complex-double-reg #!+long-float complex-long-reg)
+ (descriptor-reg))
+
+\f
+;;;; arithmetic VOPs
+
+;;; dtc: The floating point arithmetic vops.
+;;;
+;;; Note: Although these can accept x and y on the stack or pointed to
+;;; from a descriptor register, they will work with register loading
+;;; without these. Same deal with the result - it need only be a
+;;; register. When load-tns are needed they will probably be in ST0
+;;; and the code below should be able to correctly handle all cases.
+;;;
+;;; However it seems to produce better code if all arg. and result
+;;; options are used; on the P86 there is no extra cost in using a
+;;; memory operand to the FP instructions - not so on the PPro.
+;;;
+;;; It may also be useful to handle constant args?
+;;;
+;;; 22-Jul-97: descriptor args lose in some simple cases when
+;;; a function result computed in a loop. Then Python insists
+;;; on consing the intermediate values! For example
+#|
+(defun test(a n)
+ (declare (type (simple-array double-float (*)) a)
+ (fixnum n))
+ (let ((sum 0d0))
+ (declare (type double-float sum))
+ (dotimes (i n)
+ (incf sum (* (aref a i)(aref a i))))
+ sum))
+|#
+;;; So, disabling descriptor args until this can be fixed elsewhere.
+(macrolet
+ ((frob (op fop-sti fopr-sti
+ fop fopr sname scost
+ fopd foprd dname dcost
+ lname lcost)
+ #!-long-float (declare (ignore lcost lname))
+ `(progn
+ (define-vop (,sname)
+ (:translate ,op)
+ (:args (x :scs (single-reg single-stack #+nil descriptor-reg)
+ :to :eval)
+ (y :scs (single-reg single-stack #+nil descriptor-reg)
+ :to :eval))
+ (:temporary (:sc single-reg :offset fr0-offset
+ :from :eval :to :result) fr0)
+ (:results (r :scs (single-reg single-stack)))
+ (:arg-types single-float single-float)
+ (:result-types single-float)
+ (:policy :fast-safe)
+ (:note "inline float arithmetic")
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:node-var node)
+ (:generator ,scost
+ ;; Handle a few special cases
+ (cond
+ ;; x, y, and r are the same register.
+ ((and (sc-is x single-reg) (location= x r) (location= y r))
+ (cond ((zerop (tn-offset r))
+ (inst ,fop fr0))
+ (t
+ (inst fxch r)
+ (inst ,fop fr0)
+ ;; XX the source register will not be valid.
+ (note-next-instruction vop :internal-error)
+ (inst fxch r))))
+
+ ;; x and r are the same register.
+ ((and (sc-is x single-reg) (location= x r))
+ (cond ((zerop (tn-offset r))
+ (sc-case y
+ (single-reg
+ ;; ST(0) = ST(0) op ST(y)
+ (inst ,fop y))
+ (single-stack
+ ;; ST(0) = ST(0) op Mem
+ (inst ,fop (ea-for-sf-stack y)))
+ (descriptor-reg
+ (inst ,fop (ea-for-sf-desc y)))))
+ (t
+ ;; y to ST0
+ (sc-case y
+ (single-reg
+ (unless (zerop (tn-offset y))
+ (copy-fp-reg-to-fr0 y)))
+ ((single-stack descriptor-reg)
+ (inst fstp fr0)
+ (if (sc-is y single-stack)
+ (inst fld (ea-for-sf-stack y))
+ (inst fld (ea-for-sf-desc y)))))
+ ;; ST(i) = ST(i) op ST0
+ (inst ,fop-sti r)))
+ (when (policy node (or (= debug 3) (> safety speed)))
+ (note-next-instruction vop :internal-error)
+ (inst wait)))
+ ;; y and r are the same register.
+ ((and (sc-is y single-reg) (location= y r))
+ (cond ((zerop (tn-offset r))
+ (sc-case x
+ (single-reg
+ ;; ST(0) = ST(x) op ST(0)
+ (inst ,fopr x))
+ (single-stack
+ ;; ST(0) = Mem op ST(0)
+ (inst ,fopr (ea-for-sf-stack x)))
+ (descriptor-reg
+ (inst ,fopr (ea-for-sf-desc x)))))
+ (t
+ ;; x to ST0
+ (sc-case x
+ (single-reg
+ (unless (zerop (tn-offset x))
+ (copy-fp-reg-to-fr0 x)))
+ ((single-stack descriptor-reg)
+ (inst fstp fr0)
+ (if (sc-is x single-stack)
+ (inst fld (ea-for-sf-stack x))
+ (inst fld (ea-for-sf-desc x)))))
+ ;; ST(i) = ST(0) op ST(i)
+ (inst ,fopr-sti r)))
+ (when (policy node (or (= debug 3) (> safety speed)))
+ (note-next-instruction vop :internal-error)
+ (inst wait)))
+ ;; The default case
+ (t
+ ;; Get the result to ST0.
+
+ ;; Special handling is needed if x or y are in ST0, and
+ ;; simpler code is generated.
+ (cond
+ ;; x is in ST0
+ ((and (sc-is x single-reg) (zerop (tn-offset x)))
+ ;; ST0 = ST0 op y
+ (sc-case y
+ (single-reg
+ (inst ,fop y))
+ (single-stack
+ (inst ,fop (ea-for-sf-stack y)))
+ (descriptor-reg
+ (inst ,fop (ea-for-sf-desc y)))))
+ ;; y is in ST0
+ ((and (sc-is y single-reg) (zerop (tn-offset y)))
+ ;; ST0 = x op ST0
+ (sc-case x
+ (single-reg
+ (inst ,fopr x))
+ (single-stack
+ (inst ,fopr (ea-for-sf-stack x)))
+ (descriptor-reg
+ (inst ,fopr (ea-for-sf-desc x)))))
+ (t
+ ;; x to ST0
+ (sc-case x
+ (single-reg
+ (copy-fp-reg-to-fr0 x))
+ (single-stack
+ (inst fstp fr0)
+ (inst fld (ea-for-sf-stack x)))
+ (descriptor-reg
+ (inst fstp fr0)
+ (inst fld (ea-for-sf-desc x))))
+ ;; ST0 = ST0 op y
+ (sc-case y
+ (single-reg
+ (inst ,fop y))
+ (single-stack
+ (inst ,fop (ea-for-sf-stack y)))
+ (descriptor-reg
+ (inst ,fop (ea-for-sf-desc y))))))
+
+ (note-next-instruction vop :internal-error)
+
+ ;; Finally save the result
+ (sc-case r
+ (single-reg
+ (cond ((zerop (tn-offset r))
+ (when (policy node (or (= debug 3) (> safety speed)))
+ (inst wait)))
+ (t
+ (inst fst r))))
+ (single-stack
+ (inst fst (ea-for-sf-stack r))))))))
+
+ (define-vop (,dname)
+ (:translate ,op)
+ (:args (x :scs (double-reg double-stack #+nil descriptor-reg)
+ :to :eval)
+ (y :scs (double-reg double-stack #+nil descriptor-reg)
+ :to :eval))
+ (:temporary (:sc double-reg :offset fr0-offset
+ :from :eval :to :result) fr0)
+ (:results (r :scs (double-reg double-stack)))
+ (:arg-types double-float double-float)
+ (:result-types double-float)
+ (:policy :fast-safe)
+ (:note "inline float arithmetic")
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:node-var node)
+ (:generator ,dcost
+ ;; Handle a few special cases
+ (cond
+ ;; x, y, and r are the same register.
+ ((and (sc-is x double-reg) (location= x r) (location= y r))
+ (cond ((zerop (tn-offset r))
+ (inst ,fop fr0))
+ (t
+ (inst fxch x)
+ (inst ,fopd fr0)
+ ;; XX the source register will not be valid.
+ (note-next-instruction vop :internal-error)
+ (inst fxch r))))
+
+ ;; x and r are the same register.
+ ((and (sc-is x double-reg) (location= x r))
+ (cond ((zerop (tn-offset r))
+ (sc-case y
+ (double-reg
+ ;; ST(0) = ST(0) op ST(y)
+ (inst ,fopd y))
+ (double-stack
+ ;; ST(0) = ST(0) op Mem
+ (inst ,fopd (ea-for-df-stack y)))
+ (descriptor-reg
+ (inst ,fopd (ea-for-df-desc y)))))
+ (t
+ ;; y to ST0
+ (sc-case y
+ (double-reg
+ (unless (zerop (tn-offset y))
+ (copy-fp-reg-to-fr0 y)))
+ ((double-stack descriptor-reg)
+ (inst fstp fr0)
+ (if (sc-is y double-stack)
+ (inst fldd (ea-for-df-stack y))
+ (inst fldd (ea-for-df-desc y)))))
+ ;; ST(i) = ST(i) op ST0
+ (inst ,fop-sti r)))
+ (when (policy node (or (= debug 3) (> safety speed)))
+ (note-next-instruction vop :internal-error)
+ (inst wait)))
+ ;; y and r are the same register.
+ ((and (sc-is y double-reg) (location= y r))
+ (cond ((zerop (tn-offset r))
+ (sc-case x
+ (double-reg
+ ;; ST(0) = ST(x) op ST(0)
+ (inst ,foprd x))
+ (double-stack
+ ;; ST(0) = Mem op ST(0)
+ (inst ,foprd (ea-for-df-stack x)))
+ (descriptor-reg
+ (inst ,foprd (ea-for-df-desc x)))))
+ (t
+ ;; x to ST0
+ (sc-case x
+ (double-reg
+ (unless (zerop (tn-offset x))
+ (copy-fp-reg-to-fr0 x)))
+ ((double-stack descriptor-reg)
+ (inst fstp fr0)
+ (if (sc-is x double-stack)
+ (inst fldd (ea-for-df-stack x))
+ (inst fldd (ea-for-df-desc x)))))
+ ;; ST(i) = ST(0) op ST(i)
+ (inst ,fopr-sti r)))
+ (when (policy node (or (= debug 3) (> safety speed)))
+ (note-next-instruction vop :internal-error)
+ (inst wait)))
+ ;; The default case
+ (t
+ ;; Get the result to ST0.
+
+ ;; Special handling is needed if x or y are in ST0, and
+ ;; simpler code is generated.
+ (cond
+ ;; x is in ST0
+ ((and (sc-is x double-reg) (zerop (tn-offset x)))
+ ;; ST0 = ST0 op y
+ (sc-case y
+ (double-reg
+ (inst ,fopd y))
+ (double-stack
+ (inst ,fopd (ea-for-df-stack y)))
+ (descriptor-reg
+ (inst ,fopd (ea-for-df-desc y)))))
+ ;; y is in ST0
+ ((and (sc-is y double-reg) (zerop (tn-offset y)))
+ ;; ST0 = x op ST0
+ (sc-case x
+ (double-reg
+ (inst ,foprd x))
+ (double-stack
+ (inst ,foprd (ea-for-df-stack x)))
+ (descriptor-reg
+ (inst ,foprd (ea-for-df-desc x)))))
+ (t
+ ;; x to ST0
+ (sc-case x
+ (double-reg
+ (copy-fp-reg-to-fr0 x))
+ (double-stack
+ (inst fstp fr0)
+ (inst fldd (ea-for-df-stack x)))
+ (descriptor-reg
+ (inst fstp fr0)
+ (inst fldd (ea-for-df-desc x))))
+ ;; ST0 = ST0 op y
+ (sc-case y
+ (double-reg
+ (inst ,fopd y))
+ (double-stack
+ (inst ,fopd (ea-for-df-stack y)))
+ (descriptor-reg
+ (inst ,fopd (ea-for-df-desc y))))))
+
+ (note-next-instruction vop :internal-error)
+
+ ;; Finally save the result
+ (sc-case r
+ (double-reg
+ (cond ((zerop (tn-offset r))
+ (when (policy node (or (= debug 3) (> safety speed)))
+ (inst wait)))
+ (t
+ (inst fst r))))
+ (double-stack
+ (inst fstd (ea-for-df-stack r))))))))
+
+ #!+long-float
+ (define-vop (,lname)
+ (:translate ,op)
+ (:args (x :scs (long-reg) :to :eval)
+ (y :scs (long-reg) :to :eval))
+ (:temporary (:sc long-reg :offset fr0-offset
+ :from :eval :to :result) fr0)
+ (:results (r :scs (long-reg)))
+ (:arg-types long-float long-float)
+ (:result-types long-float)
+ (:policy :fast-safe)
+ (:note "inline float arithmetic")
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:node-var node)
+ (:generator ,lcost
+ ;; Handle a few special cases
+ (cond
+ ;; x, y, and r are the same register.
+ ((and (location= x r) (location= y r))
+ (cond ((zerop (tn-offset r))
+ (inst ,fop fr0))
+ (t
+ (inst fxch x)
+ (inst ,fopd fr0)
+ ;; XX the source register will not be valid.
+ (note-next-instruction vop :internal-error)
+ (inst fxch r))))
+
+ ;; x and r are the same register.
+ ((location= x r)
+ (cond ((zerop (tn-offset r))
+ ;; ST(0) = ST(0) op ST(y)
+ (inst ,fopd y))
+ (t
+ ;; y to ST0
+ (unless (zerop (tn-offset y))
+ (copy-fp-reg-to-fr0 y))
+ ;; ST(i) = ST(i) op ST0
+ (inst ,fop-sti r)))
+ (when (policy node (or (= debug 3) (> safety speed)))
+ (note-next-instruction vop :internal-error)
+ (inst wait)))
+ ;; y and r are the same register.
+ ((location= y r)
+ (cond ((zerop (tn-offset r))
+ ;; ST(0) = ST(x) op ST(0)
+ (inst ,foprd x))
+ (t
+ ;; x to ST0
+ (unless (zerop (tn-offset x))
+ (copy-fp-reg-to-fr0 x))
+ ;; ST(i) = ST(0) op ST(i)
+ (inst ,fopr-sti r)))
+ (when (policy node (or (= debug 3) (> safety speed)))
+ (note-next-instruction vop :internal-error)
+ (inst wait)))
+ ;; the default case
+ (t
+ ;; Get the result to ST0.
+
+ ;; Special handling is needed if x or y are in ST0, and
+ ;; simpler code is generated.
+ (cond
+ ;; x is in ST0.
+ ((zerop (tn-offset x))
+ ;; ST0 = ST0 op y
+ (inst ,fopd y))
+ ;; y is in ST0
+ ((zerop (tn-offset y))
+ ;; ST0 = x op ST0
+ (inst ,foprd x))
+ (t
+ ;; x to ST0
+ (copy-fp-reg-to-fr0 x)
+ ;; ST0 = ST0 op y
+ (inst ,fopd y)))
+
+ (note-next-instruction vop :internal-error)
+
+ ;; Finally save the result.
+ (cond ((zerop (tn-offset r))
+ (when (policy node (or (= debug 3) (> safety speed)))
+ (inst wait)))
+ (t
+ (inst fst r))))))))))
+
+ (frob + fadd-sti fadd-sti
+ fadd fadd +/single-float 2
+ faddd faddd +/double-float 2
+ +/long-float 2)
+ (frob - fsub-sti fsubr-sti
+ fsub fsubr -/single-float 2
+ fsubd fsubrd -/double-float 2
+ -/long-float 2)
+ (frob * fmul-sti fmul-sti
+ fmul fmul */single-float 3
+ fmuld fmuld */double-float 3
+ */long-float 3)
+ (frob / fdiv-sti fdivr-sti
+ fdiv fdivr //single-float 12
+ fdivd fdivrd //double-float 12
+ //long-float 12))
+\f
+(macrolet ((frob (name inst translate sc type)
+ `(define-vop (,name)
+ (:args (x :scs (,sc) :target fr0))
+ (:results (y :scs (,sc)))
+ (:translate ,translate)
+ (:policy :fast-safe)
+ (:arg-types ,type)
+ (:result-types ,type)
+ (:temporary (:sc double-reg :offset fr0-offset
+ :from :argument :to :result) fr0)
+ (:ignore fr0)
+ (:note "inline float arithmetic")
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:generator 1
+ (note-this-location vop :internal-error)
+ (unless (zerop (tn-offset x))
+ (inst fxch x) ; x to top of stack
+ (unless (location= x y)
+ (inst fst x))) ; maybe save it
+ (inst ,inst) ; clobber st0
+ (unless (zerop (tn-offset y))
+ (inst fst y))))))
+
+ (frob abs/single-float fabs abs single-reg single-float)
+ (frob abs/double-float fabs abs double-reg double-float)
+ #!+long-float
+ (frob abs/long-float fabs abs long-reg long-float)
+ (frob %negate/single-float fchs %negate single-reg single-float)
+ (frob %negate/double-float fchs %negate double-reg double-float)
+ #!+long-float
+ (frob %negate/long-float fchs %negate long-reg long-float))
+\f
+;;;; comparison
+
+(define-vop (=/float)
+ (:args (x) (y))
+ (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
+ (:conditional)
+ (:info target not-p)
+ (:policy :fast-safe)
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:note "inline float comparison")
+ (:ignore temp)
+ (:generator 3
+ (note-this-location vop :internal-error)
+ (cond
+ ;; x is in ST0; y is in any reg.
+ ((zerop (tn-offset x))
+ (inst fucom y))
+ ;; y is in ST0; x is in another reg.
+ ((zerop (tn-offset y))
+ (inst fucom x))
+ ;; x and y are the same register, not ST0
+ ((location= x y)
+ (inst fxch x)
+ (inst fucom fr0-tn)
+ (inst fxch x))
+ ;; x and y are different registers, neither ST0.
+ (t
+ (inst fxch x)
+ (inst fucom y)
+ (inst fxch x)))
+ (inst fnstsw) ; status word to ax
+ (inst and ah-tn #x45) ; C3 C2 C0
+ (inst cmp ah-tn #x40)
+ (inst jmp (if not-p :ne :e) target)))
+
+(define-vop (=/single-float =/float)
+ (:translate =)
+ (:args (x :scs (single-reg))
+ (y :scs (single-reg)))
+ (:arg-types single-float single-float))
+
+(define-vop (=/double-float =/float)
+ (:translate =)
+ (:args (x :scs (double-reg))
+ (y :scs (double-reg)))
+ (:arg-types double-float double-float))
+
+#!+long-float
+(define-vop (=/long-float =/float)
+ (:translate =)
+ (:args (x :scs (long-reg))
+ (y :scs (long-reg)))
+ (:arg-types long-float long-float))
+
+
+(define-vop (<single-float)
+ (:translate <)
+ (:args (x :scs (single-reg single-stack descriptor-reg))
+ (y :scs (single-reg single-stack descriptor-reg)))
+ (:arg-types single-float single-float)
+ (:temporary (:sc single-reg :offset fr0-offset :from :eval) fr0)
+ (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
+ (:conditional)
+ (:info target not-p)
+ (:policy :fast-safe)
+ (:note "inline float comparison")
+ (:ignore temp)
+ (:generator 3
+ ;; Handle a few special cases
+ (cond
+ ;; y is ST0.
+ ((and (sc-is y single-reg) (zerop (tn-offset y)))
+ (sc-case x
+ (single-reg
+ (inst fcom x))
+ ((single-stack descriptor-reg)
+ (if (sc-is x single-stack)
+ (inst fcom (ea-for-sf-stack x))
+ (inst fcom (ea-for-sf-desc x)))))
+ (inst fnstsw) ; status word to ax
+ (inst and ah-tn #x45))
+
+ ;; General case when y is not in ST0.
+ (t
+ ;; x to ST0
+ (sc-case x
+ (single-reg
+ (unless (zerop (tn-offset x))
+ (copy-fp-reg-to-fr0 x)))
+ ((single-stack descriptor-reg)
+ (inst fstp fr0)
+ (if (sc-is x single-stack)
+ (inst fld (ea-for-sf-stack x))
+ (inst fld (ea-for-sf-desc x)))))
+ (sc-case y
+ (single-reg
+ (inst fcom y))
+ ((single-stack descriptor-reg)
+ (if (sc-is y single-stack)
+ (inst fcom (ea-for-sf-stack y))
+ (inst fcom (ea-for-sf-desc y)))))
+ (inst fnstsw) ; status word to ax
+ (inst and ah-tn #x45) ; C3 C2 C0
+ (inst cmp ah-tn #x01)))
+ (inst jmp (if not-p :ne :e) target)))
+
+(define-vop (<double-float)
+ (:translate <)
+ (:args (x :scs (double-reg double-stack descriptor-reg))
+ (y :scs (double-reg double-stack descriptor-reg)))
+ (:arg-types double-float double-float)
+ (:temporary (:sc double-reg :offset fr0-offset :from :eval) fr0)
+ (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
+ (:conditional)
+ (:info target not-p)
+ (:policy :fast-safe)
+ (:note "inline float comparison")
+ (:ignore temp)
+ (:generator 3
+ ;; Handle a few special cases
+ (cond
+ ;; y is ST0.
+ ((and (sc-is y double-reg) (zerop (tn-offset y)))
+ (sc-case x
+ (double-reg
+ (inst fcomd x))
+ ((double-stack descriptor-reg)
+ (if (sc-is x double-stack)
+ (inst fcomd (ea-for-df-stack x))
+ (inst fcomd (ea-for-df-desc x)))))
+ (inst fnstsw) ; status word to ax
+ (inst and ah-tn #x45))
+
+ ;; General case when y is not in ST0.
+ (t
+ ;; x to ST0
+ (sc-case x
+ (double-reg
+ (unless (zerop (tn-offset x))
+ (copy-fp-reg-to-fr0 x)))
+ ((double-stack descriptor-reg)
+ (inst fstp fr0)
+ (if (sc-is x double-stack)
+ (inst fldd (ea-for-df-stack x))
+ (inst fldd (ea-for-df-desc x)))))
+ (sc-case y
+ (double-reg
+ (inst fcomd y))
+ ((double-stack descriptor-reg)
+ (if (sc-is y double-stack)
+ (inst fcomd (ea-for-df-stack y))
+ (inst fcomd (ea-for-df-desc y)))))
+ (inst fnstsw) ; status word to ax
+ (inst and ah-tn #x45) ; C3 C2 C0
+ (inst cmp ah-tn #x01)))
+ (inst jmp (if not-p :ne :e) target)))
+
+#!+long-float
+(define-vop (<long-float)
+ (:translate <)
+ (:args (x :scs (long-reg))
+ (y :scs (long-reg)))
+ (:arg-types long-float long-float)
+ (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
+ (:conditional)
+ (:info target not-p)
+ (:policy :fast-safe)
+ (:note "inline float comparison")
+ (:ignore temp)
+ (:generator 3
+ (cond
+ ;; x is in ST0; y is in any reg.
+ ((zerop (tn-offset x))
+ (inst fcomd y)
+ (inst fnstsw) ; status word to ax
+ (inst and ah-tn #x45) ; C3 C2 C0
+ (inst cmp ah-tn #x01))
+ ;; y is in ST0; x is in another reg.
+ ((zerop (tn-offset y))
+ (inst fcomd x)
+ (inst fnstsw) ; status word to ax
+ (inst and ah-tn #x45))
+ ;; x and y are the same register, not ST0
+ ;; x and y are different registers, neither ST0.
+ (t
+ (inst fxch y)
+ (inst fcomd x)
+ (inst fxch y)
+ (inst fnstsw) ; status word to ax
+ (inst and ah-tn #x45))) ; C3 C2 C0
+ (inst jmp (if not-p :ne :e) target)))
+
+(define-vop (>single-float)
+ (:translate >)
+ (:args (x :scs (single-reg single-stack descriptor-reg))
+ (y :scs (single-reg single-stack descriptor-reg)))
+ (:arg-types single-float single-float)
+ (:temporary (:sc single-reg :offset fr0-offset :from :eval) fr0)
+ (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
+ (:conditional)
+ (:info target not-p)
+ (:policy :fast-safe)
+ (:note "inline float comparison")
+ (:ignore temp)
+ (:generator 3
+ ;; Handle a few special cases
+ (cond
+ ;; y is ST0.
+ ((and (sc-is y single-reg) (zerop (tn-offset y)))
+ (sc-case x
+ (single-reg
+ (inst fcom x))
+ ((single-stack descriptor-reg)
+ (if (sc-is x single-stack)
+ (inst fcom (ea-for-sf-stack x))
+ (inst fcom (ea-for-sf-desc x)))))
+ (inst fnstsw) ; status word to ax
+ (inst and ah-tn #x45)
+ (inst cmp ah-tn #x01))
+
+ ;; General case when y is not in ST0.
+ (t
+ ;; x to ST0
+ (sc-case x
+ (single-reg
+ (unless (zerop (tn-offset x))
+ (copy-fp-reg-to-fr0 x)))
+ ((single-stack descriptor-reg)
+ (inst fstp fr0)
+ (if (sc-is x single-stack)
+ (inst fld (ea-for-sf-stack x))
+ (inst fld (ea-for-sf-desc x)))))
+ (sc-case y
+ (single-reg
+ (inst fcom y))
+ ((single-stack descriptor-reg)
+ (if (sc-is y single-stack)
+ (inst fcom (ea-for-sf-stack y))
+ (inst fcom (ea-for-sf-desc y)))))
+ (inst fnstsw) ; status word to ax
+ (inst and ah-tn #x45)))
+ (inst jmp (if not-p :ne :e) target)))
+
+(define-vop (>double-float)
+ (:translate >)
+ (:args (x :scs (double-reg double-stack descriptor-reg))
+ (y :scs (double-reg double-stack descriptor-reg)))
+ (:arg-types double-float double-float)
+ (:temporary (:sc double-reg :offset fr0-offset :from :eval) fr0)
+ (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
+ (:conditional)
+ (:info target not-p)
+ (:policy :fast-safe)
+ (:note "inline float comparison")
+ (:ignore temp)
+ (:generator 3
+ ;; Handle a few special cases
+ (cond
+ ;; y is ST0.
+ ((and (sc-is y double-reg) (zerop (tn-offset y)))
+ (sc-case x
+ (double-reg
+ (inst fcomd x))
+ ((double-stack descriptor-reg)
+ (if (sc-is x double-stack)
+ (inst fcomd (ea-for-df-stack x))
+ (inst fcomd (ea-for-df-desc x)))))
+ (inst fnstsw) ; status word to ax
+ (inst and ah-tn #x45)
+ (inst cmp ah-tn #x01))
+
+ ;; General case when y is not in ST0.
+ (t
+ ;; x to ST0
+ (sc-case x
+ (double-reg
+ (unless (zerop (tn-offset x))
+ (copy-fp-reg-to-fr0 x)))
+ ((double-stack descriptor-reg)
+ (inst fstp fr0)
+ (if (sc-is x double-stack)
+ (inst fldd (ea-for-df-stack x))
+ (inst fldd (ea-for-df-desc x)))))
+ (sc-case y
+ (double-reg
+ (inst fcomd y))
+ ((double-stack descriptor-reg)
+ (if (sc-is y double-stack)
+ (inst fcomd (ea-for-df-stack y))
+ (inst fcomd (ea-for-df-desc y)))))
+ (inst fnstsw) ; status word to ax
+ (inst and ah-tn #x45)))
+ (inst jmp (if not-p :ne :e) target)))
+
+#!+long-float
+(define-vop (>long-float)
+ (:translate >)
+ (:args (x :scs (long-reg))
+ (y :scs (long-reg)))
+ (:arg-types long-float long-float)
+ (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
+ (:conditional)
+ (:info target not-p)
+ (:policy :fast-safe)
+ (:note "inline float comparison")
+ (:ignore temp)
+ (:generator 3
+ (cond
+ ;; y is in ST0; x is in any reg.
+ ((zerop (tn-offset y))
+ (inst fcomd x)
+ (inst fnstsw) ; status word to ax
+ (inst and ah-tn #x45)
+ (inst cmp ah-tn #x01))
+ ;; x is in ST0; y is in another reg.
+ ((zerop (tn-offset x))
+ (inst fcomd y)
+ (inst fnstsw) ; status word to ax
+ (inst and ah-tn #x45))
+ ;; y and x are the same register, not ST0
+ ;; y and x are different registers, neither ST0.
+ (t
+ (inst fxch x)
+ (inst fcomd y)
+ (inst fxch x)
+ (inst fnstsw) ; status word to ax
+ (inst and ah-tn #x45)))
+ (inst jmp (if not-p :ne :e) target)))
+
+;;; Comparisons with 0 can use the FTST instruction.
+
+(define-vop (float-test)
+ (:args (x))
+ (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
+ (:conditional)
+ (:info target not-p y)
+ (:variant-vars code)
+ (:policy :fast-safe)
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:note "inline float comparison")
+ (:ignore temp y)
+ (:generator 2
+ (note-this-location vop :internal-error)
+ (cond
+ ;; x is in ST0
+ ((zerop (tn-offset x))
+ (inst ftst))
+ ;; x not ST0
+ (t
+ (inst fxch x)
+ (inst ftst)
+ (inst fxch x)))
+ (inst fnstsw) ; status word to ax
+ (inst and ah-tn #x45) ; C3 C2 C0
+ (unless (zerop code)
+ (inst cmp ah-tn code))
+ (inst jmp (if not-p :ne :e) target)))
+
+(define-vop (=0/single-float float-test)
+ (:translate =)
+ (:args (x :scs (single-reg)))
+ #!-negative-zero-is-not-zero
+ (:arg-types single-float (:constant (single-float 0f0 0f0)))
+ #!+negative-zero-is-not-zero
+ (:arg-types single-float (:constant (single-float -0f0 0f0)))
+ (:variant #x40))
+(define-vop (=0/double-float float-test)
+ (:translate =)
+ (:args (x :scs (double-reg)))
+ #!-negative-zero-is-not-zero
+ (:arg-types double-float (:constant (double-float 0d0 0d0)))
+ #!+negative-zero-is-not-zero
+ (:arg-types double-float (:constant (double-float -0d0 0d0)))
+ (:variant #x40))
+#!+long-float
+(define-vop (=0/long-float float-test)
+ (:translate =)
+ (:args (x :scs (long-reg)))
+ #!-negative-zero-is-not-zero
+ (:arg-types long-float (:constant (long-float 0l0 0l0)))
+ #!+negative-zero-is-not-zero
+ (:arg-types long-float (:constant (long-float -0l0 0l0)))
+ (:variant #x40))
+
+(define-vop (<0/single-float float-test)
+ (:translate <)
+ (:args (x :scs (single-reg)))
+ #!-negative-zero-is-not-zero
+ (:arg-types single-float (:constant (single-float 0f0 0f0)))
+ #!+negative-zero-is-not-zero
+ (:arg-types single-float (:constant (single-float -0f0 0f0)))
+ (:variant #x01))
+(define-vop (<0/double-float float-test)
+ (:translate <)
+ (:args (x :scs (double-reg)))
+ #!-negative-zero-is-not-zero
+ (:arg-types double-float (:constant (double-float 0d0 0d0)))
+ #!+negative-zero-is-not-zero
+ (:arg-types double-float (:constant (double-float -0d0 0d0)))
+ (:variant #x01))
+#!+long-float
+(define-vop (<0/long-float float-test)
+ (:translate <)
+ (:args (x :scs (long-reg)))
+ #!-negative-zero-is-not-zero
+ (:arg-types long-float (:constant (long-float 0l0 0l0)))
+ #!+negative-zero-is-not-zero
+ (:arg-types long-float (:constant (long-float -0l0 0l0)))
+ (:variant #x01))
+
+(define-vop (>0/single-float float-test)
+ (:translate >)
+ (:args (x :scs (single-reg)))
+ #!-negative-zero-is-not-zero
+ (:arg-types single-float (:constant (single-float 0f0 0f0)))
+ #!+negative-zero-is-not-zero
+ (:arg-types single-float (:constant (single-float -0f0 0f0)))
+ (:variant #x00))
+(define-vop (>0/double-float float-test)
+ (:translate >)
+ (:args (x :scs (double-reg)))
+ #!-negative-zero-is-not-zero
+ (:arg-types double-float (:constant (double-float 0d0 0d0)))
+ #!+negative-zero-is-not-zero
+ (:arg-types double-float (:constant (double-float -0d0 0d0)))
+ (:variant #x00))
+#!+long-float
+(define-vop (>0/long-float float-test)
+ (:translate >)
+ (:args (x :scs (long-reg)))
+ #!-negative-zero-is-not-zero
+ (:arg-types long-float (:constant (long-float 0l0 0l0)))
+ #!+negative-zero-is-not-zero
+ (:arg-types long-float (:constant (long-float -0l0 0l0)))
+ (:variant #x00))
+
+#!+long-float
+(deftransform eql ((x y) (long-float long-float))
+ `(and (= (long-float-low-bits x) (long-float-low-bits y))
+ (= (long-float-high-bits x) (long-float-high-bits y))
+ (= (long-float-exp-bits x) (long-float-exp-bits y))))
+\f
+;;;; conversion
+
+(macrolet ((frob (name translate to-sc to-type)
+ `(define-vop (,name)
+ (:args (x :scs (signed-stack signed-reg) :target temp))
+ (:temporary (:sc signed-stack) temp)
+ (:results (y :scs (,to-sc)))
+ (:arg-types signed-num)
+ (:result-types ,to-type)
+ (:policy :fast-safe)
+ (:note "inline float coercion")
+ (:translate ,translate)
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:generator 5
+ (sc-case x
+ (signed-reg
+ (inst mov temp x)
+ (with-empty-tn@fp-top(y)
+ (note-this-location vop :internal-error)
+ (inst fild temp)))
+ (signed-stack
+ (with-empty-tn@fp-top(y)
+ (note-this-location vop :internal-error)
+ (inst fild x))))))))
+ (frob %single-float/signed %single-float single-reg single-float)
+ (frob %double-float/signed %double-float double-reg double-float)
+ #!+long-float
+ (frob %long-float/signed %long-float long-reg long-float))
+
+(macrolet ((frob (name translate to-sc to-type)
+ `(define-vop (,name)
+ (:args (x :scs (unsigned-reg)))
+ (:results (y :scs (,to-sc)))
+ (:arg-types unsigned-num)
+ (:result-types ,to-type)
+ (:policy :fast-safe)
+ (:note "inline float coercion")
+ (:translate ,translate)
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:generator 6
+ (inst push 0)
+ (inst push x)
+ (with-empty-tn@fp-top(y)
+ (note-this-location vop :internal-error)
+ (inst fildl (make-ea :dword :base esp-tn)))
+ (inst add esp-tn 8)))))
+ (frob %single-float/unsigned %single-float single-reg single-float)
+ (frob %double-float/unsigned %double-float double-reg double-float)
+ #!+long-float
+ (frob %long-float/unsigned %long-float long-reg long-float))
+
+;;; These should be no-ops but the compiler might want to move
+;;; some things around
+(macrolet ((frob (name translate from-sc from-type to-sc to-type)
+ `(define-vop (,name)
+ (:args (x :scs (,from-sc) :target y))
+ (:results (y :scs (,to-sc)))
+ (:arg-types ,from-type)
+ (:result-types ,to-type)
+ (:policy :fast-safe)
+ (:note "inline float coercion")
+ (:translate ,translate)
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:generator 2
+ (note-this-location vop :internal-error)
+ (unless (location= x y)
+ (cond
+ ((zerop (tn-offset x))
+ ;; x is in ST0, y is in another reg. not ST0
+ (inst fst y))
+ ((zerop (tn-offset y))
+ ;; y is in ST0, x is in another reg. not ST0
+ (copy-fp-reg-to-fr0 x))
+ (t
+ ;; Neither x or y are in ST0, and they are not in
+ ;; the same reg.
+ (inst fxch x)
+ (inst fst y)
+ (inst fxch x))))))))
+
+ (frob %single-float/double-float %single-float double-reg
+ double-float single-reg single-float)
+ #!+long-float
+ (frob %single-float/long-float %single-float long-reg
+ long-float single-reg single-float)
+ (frob %double-float/single-float %double-float single-reg single-float
+ double-reg double-float)
+ #!+long-float
+ (frob %double-float/long-float %double-float long-reg long-float
+ double-reg double-float)
+ #!+long-float
+ (frob %long-float/single-float %long-float single-reg single-float
+ long-reg long-float)
+ #!+long-float
+ (frob %long-float/double-float %long-float double-reg double-float
+ long-reg long-float))
+
+(macrolet ((frob (trans from-sc from-type round-p)
+ `(define-vop (,(symbolicate trans "/" from-type))
+ (:args (x :scs (,from-sc)))
+ (:temporary (:sc signed-stack) stack-temp)
+ ,@(unless round-p
+ '((:temporary (:sc unsigned-stack) scw)
+ (:temporary (:sc any-reg) rcw)))
+ (:results (y :scs (signed-reg)))
+ (:arg-types ,from-type)
+ (:result-types signed-num)
+ (:translate ,trans)
+ (:policy :fast-safe)
+ (:note "inline float truncate")
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:generator 5
+ ,@(unless round-p
+ '((note-this-location vop :internal-error)
+ ;; Catch any pending FPE exceptions.
+ (inst wait)))
+ (,(if round-p 'progn 'pseudo-atomic)
+ ;; normal mode (for now) is "round to best"
+ (with-tn@fp-top (x)
+ ,@(unless round-p
+ '((inst fnstcw scw) ; save current control word
+ (move rcw scw) ; into 16-bit register
+ (inst or rcw (ash #b11 10)) ; CHOP
+ (move stack-temp rcw)
+ (inst fldcw stack-temp)))
+ (sc-case y
+ (signed-stack
+ (inst fist y))
+ (signed-reg
+ (inst fist stack-temp)
+ (inst mov y stack-temp)))
+ ,@(unless round-p
+ '((inst fldcw scw)))))))))
+ (frob %unary-truncate single-reg single-float nil)
+ (frob %unary-truncate double-reg double-float nil)
+ #!+long-float
+ (frob %unary-truncate long-reg long-float nil)
+ (frob %unary-round single-reg single-float t)
+ (frob %unary-round double-reg double-float t)
+ #!+long-float
+ (frob %unary-round long-reg long-float t))
+
+(macrolet ((frob (trans from-sc from-type round-p)
+ `(define-vop (,(symbolicate trans "/" from-type "=>UNSIGNED"))
+ (:args (x :scs (,from-sc) :target fr0))
+ (:temporary (:sc double-reg :offset fr0-offset
+ :from :argument :to :result) fr0)
+ ,@(unless round-p
+ '((:temporary (:sc unsigned-stack) stack-temp)
+ (:temporary (:sc unsigned-stack) scw)
+ (:temporary (:sc any-reg) rcw)))
+ (:results (y :scs (unsigned-reg)))
+ (:arg-types ,from-type)
+ (:result-types unsigned-num)
+ (:translate ,trans)
+ (:policy :fast-safe)
+ (:note "inline float truncate")
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:generator 5
+ ,@(unless round-p
+ '((note-this-location vop :internal-error)
+ ;; Catch any pending FPE exceptions.
+ (inst wait)))
+ ;; normal mode (for now) is "round to best"
+ (unless (zerop (tn-offset x))
+ (copy-fp-reg-to-fr0 x))
+ ,@(unless round-p
+ '((inst fnstcw scw) ; save current control word
+ (move rcw scw) ; into 16-bit register
+ (inst or rcw (ash #b11 10)) ; CHOP
+ (move stack-temp rcw)
+ (inst fldcw stack-temp)))
+ (inst sub esp-tn 8)
+ (inst fistpl (make-ea :dword :base esp-tn))
+ (inst pop y)
+ (inst fld fr0) ; copy fr0 to at least restore stack.
+ (inst add esp-tn 4)
+ ,@(unless round-p
+ '((inst fldcw scw)))))))
+ (frob %unary-truncate single-reg single-float nil)
+ (frob %unary-truncate double-reg double-float nil)
+ #!+long-float
+ (frob %unary-truncate long-reg long-float nil)
+ (frob %unary-round single-reg single-float t)
+ (frob %unary-round double-reg double-float t)
+ #!+long-float
+ (frob %unary-round long-reg long-float t))
+
+(define-vop (make-single-float)
+ (:args (bits :scs (signed-reg) :target res
+ :load-if (not (or (and (sc-is bits signed-stack)
+ (sc-is res single-reg))
+ (and (sc-is bits signed-stack)
+ (sc-is res single-stack)
+ (location= bits res))))))
+ (:results (res :scs (single-reg single-stack)))
+ (:temporary (:sc signed-stack) stack-temp)
+ (:arg-types signed-num)
+ (:result-types single-float)
+ (:translate make-single-float)
+ (:policy :fast-safe)
+ (:vop-var vop)
+ (:generator 4
+ (sc-case res
+ (single-stack
+ (sc-case bits
+ (signed-reg
+ (inst mov res bits))
+ (signed-stack
+ (assert (location= bits res)))))
+ (single-reg
+ (sc-case bits
+ (signed-reg
+ ;; source must be in memory
+ (inst mov stack-temp bits)
+ (with-empty-tn@fp-top(res)
+ (inst fld stack-temp)))
+ (signed-stack
+ (with-empty-tn@fp-top(res)
+ (inst fld bits))))))))
+
+(define-vop (make-double-float)
+ (:args (hi-bits :scs (signed-reg))
+ (lo-bits :scs (unsigned-reg)))
+ (:results (res :scs (double-reg)))
+ (:temporary (:sc double-stack) temp)
+ (:arg-types signed-num unsigned-num)
+ (:result-types double-float)
+ (:translate make-double-float)
+ (:policy :fast-safe)
+ (:vop-var vop)
+ (:generator 2
+ (let ((offset (1+ (tn-offset temp))))
+ (storew hi-bits ebp-tn (- offset))
+ (storew lo-bits ebp-tn (- (1+ offset)))
+ (with-empty-tn@fp-top(res)
+ (inst fldd (make-ea :dword :base ebp-tn
+ :disp (- (* (1+ offset) word-bytes))))))))
+
+#!+long-float
+(define-vop (make-long-float)
+ (:args (exp-bits :scs (signed-reg))
+ (hi-bits :scs (unsigned-reg))
+ (lo-bits :scs (unsigned-reg)))
+ (:results (res :scs (long-reg)))
+ (:temporary (:sc long-stack) temp)
+ (:arg-types signed-num unsigned-num unsigned-num)
+ (:result-types long-float)
+ (:translate make-long-float)
+ (:policy :fast-safe)
+ (:vop-var vop)
+ (:generator 3
+ (let ((offset (1+ (tn-offset temp))))
+ (storew exp-bits ebp-tn (- offset))
+ (storew hi-bits ebp-tn (- (1+ offset)))
+ (storew lo-bits ebp-tn (- (+ offset 2)))
+ (with-empty-tn@fp-top(res)
+ (inst fldl (make-ea :dword :base ebp-tn
+ :disp (- (* (+ offset 2) word-bytes))))))))
+
+(define-vop (single-float-bits)
+ (:args (float :scs (single-reg descriptor-reg)
+ :load-if (not (sc-is float single-stack))))
+ (:results (bits :scs (signed-reg)))
+ (:temporary (:sc signed-stack :from :argument :to :result) stack-temp)
+ (:arg-types single-float)
+ (:result-types signed-num)
+ (:translate single-float-bits)
+ (:policy :fast-safe)
+ (:vop-var vop)
+ (:generator 4
+ (sc-case bits
+ (signed-reg
+ (sc-case float
+ (single-reg
+ (with-tn@fp-top(float)
+ (inst fst stack-temp)
+ (inst mov bits stack-temp)))
+ (single-stack
+ (inst mov bits float))
+ (descriptor-reg
+ (loadw
+ bits float sb!vm:single-float-value-slot
+ sb!vm:other-pointer-type))))
+ (signed-stack
+ (sc-case float
+ (single-reg
+ (with-tn@fp-top(float)
+ (inst fst bits))))))))
+
+(define-vop (double-float-high-bits)
+ (:args (float :scs (double-reg descriptor-reg)
+ :load-if (not (sc-is float double-stack))))
+ (:results (hi-bits :scs (signed-reg)))
+ (:temporary (:sc double-stack) temp)
+ (:arg-types double-float)
+ (:result-types signed-num)
+ (:translate double-float-high-bits)
+ (:policy :fast-safe)
+ (:vop-var vop)
+ (:generator 5
+ (sc-case float
+ (double-reg
+ (with-tn@fp-top(float)
+ (let ((where (make-ea :dword :base ebp-tn
+ :disp (- (* (+ 2 (tn-offset temp))
+ word-bytes)))))
+ (inst fstd where)))
+ (loadw hi-bits ebp-tn (- (1+ (tn-offset temp)))))
+ (double-stack
+ (loadw hi-bits ebp-tn (- (1+ (tn-offset float)))))
+ (descriptor-reg
+ (loadw hi-bits float (1+ sb!vm:double-float-value-slot)
+ sb!vm:other-pointer-type)))))
+
+(define-vop (double-float-low-bits)
+ (:args (float :scs (double-reg descriptor-reg)
+ :load-if (not (sc-is float double-stack))))
+ (:results (lo-bits :scs (unsigned-reg)))
+ (:temporary (:sc double-stack) temp)
+ (:arg-types double-float)
+ (:result-types unsigned-num)
+ (:translate double-float-low-bits)
+ (:policy :fast-safe)
+ (:vop-var vop)
+ (:generator 5
+ (sc-case float
+ (double-reg
+ (with-tn@fp-top(float)
+ (let ((where (make-ea :dword :base ebp-tn
+ :disp (- (* (+ 2 (tn-offset temp))
+ word-bytes)))))
+ (inst fstd where)))
+ (loadw lo-bits ebp-tn (- (+ 2 (tn-offset temp)))))
+ (double-stack
+ (loadw lo-bits ebp-tn (- (+ 2 (tn-offset float)))))
+ (descriptor-reg
+ (loadw lo-bits float sb!vm:double-float-value-slot
+ sb!vm:other-pointer-type)))))
+
+#!+long-float
+(define-vop (long-float-exp-bits)
+ (:args (float :scs (long-reg descriptor-reg)
+ :load-if (not (sc-is float long-stack))))
+ (:results (exp-bits :scs (signed-reg)))
+ (:temporary (:sc long-stack) temp)
+ (:arg-types long-float)
+ (:result-types signed-num)
+ (:translate long-float-exp-bits)
+ (:policy :fast-safe)
+ (:vop-var vop)
+ (:generator 5
+ (sc-case float
+ (long-reg
+ (with-tn@fp-top(float)
+ (let ((where (make-ea :dword :base ebp-tn
+ :disp (- (* (+ 3 (tn-offset temp))
+ word-bytes)))))
+ (store-long-float where)))
+ (inst movsx exp-bits
+ (make-ea :word :base ebp-tn
+ :disp (* (- (1+ (tn-offset temp))) word-bytes))))
+ (long-stack
+ (inst movsx exp-bits
+ (make-ea :word :base ebp-tn
+ :disp (* (- (1+ (tn-offset float))) word-bytes))))
+ (descriptor-reg
+ (inst movsx exp-bits
+ (make-ea :word :base float
+ :disp (- (* (+ 2 sb!vm:long-float-value-slot)
+ word-bytes)
+ sb!vm:other-pointer-type)))))))
+
+#!+long-float
+(define-vop (long-float-high-bits)
+ (:args (float :scs (long-reg descriptor-reg)
+ :load-if (not (sc-is float long-stack))))
+ (:results (hi-bits :scs (unsigned-reg)))
+ (:temporary (:sc long-stack) temp)
+ (:arg-types long-float)
+ (:result-types unsigned-num)
+ (:translate long-float-high-bits)
+ (:policy :fast-safe)
+ (:vop-var vop)
+ (:generator 5
+ (sc-case float
+ (long-reg
+ (with-tn@fp-top(float)
+ (let ((where (make-ea :dword :base ebp-tn
+ :disp (- (* (+ 3 (tn-offset temp))
+ word-bytes)))))
+ (store-long-float where)))
+ (loadw hi-bits ebp-tn (- (+ (tn-offset temp) 2))))
+ (long-stack
+ (loadw hi-bits ebp-tn (- (+ (tn-offset float) 2))))
+ (descriptor-reg
+ (loadw hi-bits float (1+ sb!vm:long-float-value-slot)
+ sb!vm:other-pointer-type)))))
+
+#!+long-float
+(define-vop (long-float-low-bits)
+ (:args (float :scs (long-reg descriptor-reg)
+ :load-if (not (sc-is float long-stack))))
+ (:results (lo-bits :scs (unsigned-reg)))
+ (:temporary (:sc long-stack) temp)
+ (:arg-types long-float)
+ (:result-types unsigned-num)
+ (:translate long-float-low-bits)
+ (:policy :fast-safe)
+ (:vop-var vop)
+ (:generator 5
+ (sc-case float
+ (long-reg
+ (with-tn@fp-top(float)
+ (let ((where (make-ea :dword :base ebp-tn
+ :disp (- (* (+ 3 (tn-offset temp))
+ word-bytes)))))
+ (store-long-float where)))
+ (loadw lo-bits ebp-tn (- (+ (tn-offset temp) 3))))
+ (long-stack
+ (loadw lo-bits ebp-tn (- (+ (tn-offset float) 3))))
+ (descriptor-reg
+ (loadw lo-bits float sb!vm:long-float-value-slot
+ sb!vm:other-pointer-type)))))
+\f
+;;;; float mode hackery
+
+(sb!xc:deftype float-modes () '(unsigned-byte 32)) ; really only 16
+(defknown floating-point-modes () float-modes (flushable))
+(defknown ((setf floating-point-modes)) (float-modes)
+ float-modes)
+
+(defconstant npx-env-size (* 7 sb!vm:word-bytes))
+(defconstant npx-cw-offset 0)
+(defconstant npx-sw-offset 4)
+
+(define-vop (floating-point-modes)
+ (:results (res :scs (unsigned-reg)))
+ (:result-types unsigned-num)
+ (:translate floating-point-modes)
+ (:policy :fast-safe)
+ (:temporary (:sc unsigned-reg :offset eax-offset :target res
+ :to :result) eax)
+ (:generator 8
+ (inst sub esp-tn npx-env-size) ; make space on stack
+ (inst wait) ; Catch any pending FPE exceptions
+ (inst fstenv (make-ea :dword :base esp-tn)) ; masks all exceptions
+ (inst fldenv (make-ea :dword :base esp-tn)) ; restore previous state
+ ;; Current status to high word
+ (inst mov eax (make-ea :dword :base esp-tn :disp (- npx-sw-offset 2)))
+ ;; Exception mask to low word
+ (inst mov ax-tn (make-ea :word :base esp-tn :disp npx-cw-offset))
+ (inst add esp-tn npx-env-size) ; Pop stack
+ (inst xor eax #x3f) ; Flip exception mask to trap enable bits
+ (move res eax)))
+
+(define-vop (set-floating-point-modes)
+ (:args (new :scs (unsigned-reg) :to :result :target res))
+ (:results (res :scs (unsigned-reg)))
+ (:arg-types unsigned-num)
+ (:result-types unsigned-num)
+ (:translate (setf floating-point-modes))
+ (:policy :fast-safe)
+ (:temporary (:sc unsigned-reg :offset eax-offset
+ :from :eval :to :result) eax)
+ (:generator 3
+ (inst sub esp-tn npx-env-size) ; make space on stack
+ (inst wait) ; Catch any pending FPE exceptions
+ (inst fstenv (make-ea :dword :base esp-tn))
+ (inst mov eax new)
+ (inst xor eax #x3f) ; turn trap enable bits into exception mask
+ (inst mov (make-ea :word :base esp-tn :disp npx-cw-offset) ax-tn)
+ (inst shr eax 16) ; position status word
+ (inst mov (make-ea :word :base esp-tn :disp npx-sw-offset) ax-tn)
+ (inst fldenv (make-ea :dword :base esp-tn))
+ (inst add esp-tn npx-env-size) ; Pop stack
+ (move res new)))
+\f
+#!-long-float
+(progn
+
+;;; Let's use some of the 80387 special functions.
+;;;
+;;; These defs will not take effect unless code/irrat.lisp is modified
+;;; to remove the inlined alien routine def.
+
+(macrolet ((frob (func trans op)
+ `(define-vop (,func)
+ (:args (x :scs (double-reg) :target fr0))
+ (:temporary (:sc double-reg :offset fr0-offset
+ :from :argument :to :result) fr0)
+ (:ignore fr0)
+ (:results (y :scs (double-reg)))
+ (:arg-types double-float)
+ (:result-types double-float)
+ (:translate ,trans)
+ (:policy :fast-safe)
+ (:note "inline NPX function")
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:node-var node)
+ (:generator 5
+ (note-this-location vop :internal-error)
+ (unless (zerop (tn-offset x))
+ (inst fxch x) ; x to top of stack
+ (unless (location= x y)
+ (inst fst x))) ; maybe save it
+ (inst ,op) ; clobber st0
+ (cond ((zerop (tn-offset y))
+ (when (policy node (or (= debug 3) (> safety speed)))
+ (inst wait)))
+ (t
+ (inst fst y)))))))
+
+ ;; Quick versions of fsin and fcos that require the argument to be
+ ;; within range 2^63.
+ (frob fsin-quick %sin-quick fsin)
+ (frob fcos-quick %cos-quick fcos)
+ (frob fsqrt %sqrt fsqrt))
+
+;;; Quick version of ftan that requires the argument to be within
+;;; range 2^63.
+(define-vop (ftan-quick)
+ (:translate %tan-quick)
+ (:args (x :scs (double-reg) :target fr0))
+ (:temporary (:sc double-reg :offset fr0-offset
+ :from :argument :to :result) fr0)
+ (:temporary (:sc double-reg :offset fr1-offset
+ :from :argument :to :result) fr1)
+ (:results (y :scs (double-reg)))
+ (:arg-types double-float)
+ (:result-types double-float)
+ (:policy :fast-safe)
+ (:note "inline tan function")
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:generator 5
+ (note-this-location vop :internal-error)
+ (case (tn-offset x)
+ (0
+ (inst fstp fr1))
+ (1
+ (inst fstp fr0))
+ (t
+ (inst fstp fr0)
+ (inst fstp fr0)
+ (inst fldd (make-random-tn :kind :normal
+ :sc (sc-or-lose 'double-reg)
+ :offset (- (tn-offset x) 2)))))
+ (inst fptan)
+ ;; Result is in fr1
+ (case (tn-offset y)
+ (0
+ (inst fxch fr1))
+ (1)
+ (t
+ (inst fxch fr1)
+ (inst fstd y)))))
+
+;;; These versions of fsin, fcos, and ftan try to use argument
+;;; reduction but to do this accurately requires greater precision and
+;;; it is hopelessly inaccurate.
+#+nil
+(macrolet ((frob (func trans op)
+ `(define-vop (,func)
+ (:translate ,trans)
+ (:args (x :scs (double-reg) :target fr0))
+ (:temporary (:sc unsigned-reg :offset eax-offset
+ :from :eval :to :result) eax)
+ (:temporary (:sc unsigned-reg :offset fr0-offset
+ :from :argument :to :result) fr0)
+ (:temporary (:sc unsigned-reg :offset fr1-offset
+ :from :argument :to :result) fr1)
+ (:results (y :scs (double-reg)))
+ (:arg-types double-float)
+ (:result-types double-float)
+ (:policy :fast-safe)
+ (:note "inline sin/cos function")
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:ignore eax)
+ (:generator 5
+ (note-this-location vop :internal-error)
+ (unless (zerop (tn-offset x))
+ (inst fxch x) ; x to top of stack
+ (unless (location= x y)
+ (inst fst x))) ; maybe save it
+ (inst ,op)
+ (inst fnstsw) ; status word to ax
+ (inst and ah-tn #x04) ; C2
+ (inst jmp :z DONE)
+ ;; Else x was out of range so reduce it; ST0 is unchanged.
+ (inst fstp fr1) ; Load 2*PI
+ (inst fldpi)
+ (inst fadd fr0)
+ (inst fxch fr1)
+ LOOP
+ (inst fprem1)
+ (inst fnstsw) ; status word to ax
+ (inst and ah-tn #x04) ; C2
+ (inst jmp :nz LOOP)
+ (inst ,op)
+ DONE
+ (unless (zerop (tn-offset y))
+ (inst fstd y))))))
+ (frob fsin %sin fsin)
+ (frob fcos %cos fcos))
+
+#+nil
+(define-vop (ftan)
+ (:translate %tan)
+ (:args (x :scs (double-reg) :target fr0))
+ (:temporary (:sc unsigned-reg :offset eax-offset
+ :from :argument :to :result) eax)
+ (:temporary (:sc double-reg :offset fr0-offset
+ :from :argument :to :result) fr0)
+ (:temporary (:sc double-reg :offset fr1-offset
+ :from :argument :to :result) fr1)
+ (:results (y :scs (double-reg)))
+ (:arg-types double-float)
+ (:result-types double-float)
+ (:policy :fast-safe)
+ (:note "inline tan function")
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:ignore eax)
+ (:generator 5
+ (note-this-location vop :internal-error)
+ (case (tn-offset x)
+ (0
+ (inst fstp fr1))
+ (1
+ (inst fstp fr0))
+ (t
+ (inst fstp fr0)
+ (inst fstp fr0)
+ (inst fldd (make-random-tn :kind :normal
+ :sc (sc-or-lose 'double-reg)
+ :offset (- (tn-offset x) 2)))))
+ (inst fptan)
+ (inst fnstsw) ; status word to ax
+ (inst and ah-tn #x04) ; C2
+ (inst jmp :z DONE)
+ ;; Else x was out of range so reduce it; ST0 is unchanged.
+ (inst fldpi) ; Load 2*PI
+ (inst fadd fr0)
+ (inst fxch fr1)
+ LOOP
+ (inst fprem1)
+ (inst fnstsw) ; status word to ax
+ (inst and ah-tn #x04) ; C2
+ (inst jmp :nz LOOP)
+ (inst fstp fr1)
+ (inst fptan)
+ DONE
+ ;; Result is in fr1
+ (case (tn-offset y)
+ (0
+ (inst fxch fr1))
+ (1)
+ (t
+ (inst fxch fr1)
+ (inst fstd y)))))
+
+;;; These versions of fsin, fcos, and ftan simply load a 0.0 result if
+;;; the argument is out of range 2^63 and would thus be hopelessly
+;;; inaccurate.
+(macrolet ((frob (func trans op)
+ `(define-vop (,func)
+ (:translate ,trans)
+ (:args (x :scs (double-reg) :target fr0))
+ (:temporary (:sc double-reg :offset fr0-offset
+ :from :argument :to :result) fr0)
+ (:temporary (:sc unsigned-reg :offset eax-offset
+ :from :argument :to :result) eax)
+ (:results (y :scs (double-reg)))
+ (:arg-types double-float)
+ (:result-types double-float)
+ (:policy :fast-safe)
+ (:note "inline sin/cos function")
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:ignore eax)
+ (:generator 5
+ (note-this-location vop :internal-error)
+ (unless (zerop (tn-offset x))
+ (inst fxch x) ; x to top of stack
+ (unless (location= x y)
+ (inst fst x))) ; maybe save it
+ (inst ,op)
+ (inst fnstsw) ; status word to ax
+ (inst and ah-tn #x04) ; C2
+ (inst jmp :z DONE)
+ ;; Else x was out of range so reduce it; ST0 is unchanged.
+ (inst fstp fr0) ; Load 0.0
+ (inst fldz)
+ DONE
+ (unless (zerop (tn-offset y))
+ (inst fstd y))))))
+ (frob fsin %sin fsin)
+ (frob fcos %cos fcos))
+
+(define-vop (ftan)
+ (:translate %tan)
+ (:args (x :scs (double-reg) :target fr0))
+ (:temporary (:sc double-reg :offset fr0-offset
+ :from :argument :to :result) fr0)
+ (:temporary (:sc double-reg :offset fr1-offset
+ :from :argument :to :result) fr1)
+ (:temporary (:sc unsigned-reg :offset eax-offset
+ :from :argument :to :result) eax)
+ (:results (y :scs (double-reg)))
+ (:arg-types double-float)
+ (:result-types double-float)
+ (:ignore eax)
+ (:policy :fast-safe)
+ (:note "inline tan function")
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:ignore eax)
+ (:generator 5
+ (note-this-location vop :internal-error)
+ (case (tn-offset x)
+ (0
+ (inst fstp fr1))
+ (1
+ (inst fstp fr0))
+ (t
+ (inst fstp fr0)
+ (inst fstp fr0)
+ (inst fldd (make-random-tn :kind :normal
+ :sc (sc-or-lose 'double-reg)
+ :offset (- (tn-offset x) 2)))))
+ (inst fptan)
+ (inst fnstsw) ; status word to ax
+ (inst and ah-tn #x04) ; C2
+ (inst jmp :z DONE)
+ ;; Else x was out of range so reduce it; ST0 is unchanged.
+ (inst fldz) ; Load 0.0
+ (inst fxch fr1)
+ DONE
+ ;; Result is in fr1
+ (case (tn-offset y)
+ (0
+ (inst fxch fr1))
+ (1)
+ (t
+ (inst fxch fr1)
+ (inst fstd y)))))
+
+#+nil
+(define-vop (fexp)
+ (:translate %exp)
+ (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0))
+ (:temporary (:sc double-reg :offset fr0-offset
+ :from :argument :to :result) fr0)
+ (:temporary (:sc double-reg :offset fr1-offset
+ :from :argument :to :result) fr1)
+ (:temporary (:sc double-reg :offset fr2-offset
+ :from :argument :to :result) fr2)
+ (:results (y :scs (double-reg)))
+ (:arg-types double-float)
+ (:result-types double-float)
+ (:policy :fast-safe)
+ (:note "inline exp function")
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:generator 5
+ (note-this-location vop :internal-error)
+ (sc-case x
+ (double-reg
+ (cond ((zerop (tn-offset x))
+ ;; x is in fr0
+ (inst fstp fr1)
+ (inst fldl2e)
+ (inst fmul fr1))
+ (t
+ ;; x is in a FP reg, not fr0
+ (inst fstp fr0)
+ (inst fldl2e)
+ (inst fmul x))))
+ ((double-stack descriptor-reg)
+ (inst fstp fr0)
+ (inst fldl2e)
+ (if (sc-is x double-stack)
+ (inst fmuld (ea-for-df-stack x))
+ (inst fmuld (ea-for-df-desc x)))))
+ ;; Now fr0=x log2(e)
+ (inst fst fr1)
+ (inst frndint)
+ (inst fst fr2)
+ (inst fsubp-sti fr1)
+ (inst f2xm1)
+ (inst fld1)
+ (inst faddp-sti fr1)
+ (inst fscale)
+ (inst fld fr0)
+ (case (tn-offset y)
+ ((0 1))
+ (t (inst fstd y)))))
+
+;;; Modified exp that handles the following special cases:
+;;; exp(+Inf) is +Inf; exp(-Inf) is 0; exp(NaN) is NaN.
+(define-vop (fexp)
+ (:translate %exp)
+ (:args (x :scs (double-reg) :target fr0))
+ (:temporary (:sc word-reg :offset eax-offset :from :eval :to :result) temp)
+ (:temporary (:sc double-reg :offset fr0-offset
+ :from :argument :to :result) fr0)
+ (:temporary (:sc double-reg :offset fr1-offset
+ :from :argument :to :result) fr1)
+ (:temporary (:sc double-reg :offset fr2-offset
+ :from :argument :to :result) fr2)
+ (:results (y :scs (double-reg)))
+ (:arg-types double-float)
+ (:result-types double-float)
+ (:policy :fast-safe)
+ (:note "inline exp function")
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:ignore temp)
+ (:generator 5
+ (note-this-location vop :internal-error)
+ (unless (zerop (tn-offset x))
+ (inst fxch x) ; x to top of stack
+ (unless (location= x y)
+ (inst fst x))) ; maybe save it
+ ;; Check for Inf or NaN
+ (inst fxam)
+ (inst fnstsw)
+ (inst sahf)
+ (inst jmp :nc NOINFNAN) ; Neither Inf or NaN.
+ (inst jmp :np NOINFNAN) ; NaN gives NaN? Continue.
+ (inst and ah-tn #x02) ; Test sign of Inf.
+ (inst jmp :z DONE) ; +Inf gives +Inf.
+ (inst fstp fr0) ; -Inf gives 0
+ (inst fldz)
+ (inst jmp-short DONE)
+ NOINFNAN
+ (inst fstp fr1)
+ (inst fldl2e)
+ (inst fmul fr1)
+ ;; Now fr0=x log2(e)
+ (inst fst fr1)
+ (inst frndint)
+ (inst fst fr2)
+ (inst fsubp-sti fr1)
+ (inst f2xm1)
+ (inst fld1)
+ (inst faddp-sti fr1)
+ (inst fscale)
+ (inst fld fr0)
+ DONE
+ (unless (zerop (tn-offset y))
+ (inst fstd y))))
+
+;;; Expm1 = exp(x) - 1.
+;;; Handles the following special cases:
+;;; expm1(+Inf) is +Inf; expm1(-Inf) is -1.0; expm1(NaN) is NaN.
+(define-vop (fexpm1)
+ (:translate %expm1)
+ (:args (x :scs (double-reg) :target fr0))
+ (:temporary (:sc word-reg :offset eax-offset :from :eval :to :result) temp)
+ (:temporary (:sc double-reg :offset fr0-offset
+ :from :argument :to :result) fr0)
+ (:temporary (:sc double-reg :offset fr1-offset
+ :from :argument :to :result) fr1)
+ (:temporary (:sc double-reg :offset fr2-offset
+ :from :argument :to :result) fr2)
+ (:results (y :scs (double-reg)))
+ (:arg-types double-float)
+ (:result-types double-float)
+ (:policy :fast-safe)
+ (:note "inline expm1 function")
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:ignore temp)
+ (:generator 5
+ (note-this-location vop :internal-error)
+ (unless (zerop (tn-offset x))
+ (inst fxch x) ; x to top of stack
+ (unless (location= x y)
+ (inst fst x))) ; maybe save it
+ ;; Check for Inf or NaN
+ (inst fxam)
+ (inst fnstsw)
+ (inst sahf)
+ (inst jmp :nc NOINFNAN) ; Neither Inf or NaN.
+ (inst jmp :np NOINFNAN) ; NaN gives NaN? Continue.
+ (inst and ah-tn #x02) ; Test sign of Inf.
+ (inst jmp :z DONE) ; +Inf gives +Inf.
+ (inst fstp fr0) ; -Inf gives -1.0
+ (inst fld1)
+ (inst fchs)
+ (inst jmp-short DONE)
+ NOINFNAN
+ ;; Free two stack slots leaving the argument on top.
+ (inst fstp fr2)
+ (inst fstp fr0)
+ (inst fldl2e)
+ (inst fmul fr1) ; Now fr0 = x log2(e)
+ (inst fst fr1)
+ (inst frndint)
+ (inst fsub-sti fr1)
+ (inst fxch fr1)
+ (inst f2xm1)
+ (inst fscale)
+ (inst fxch fr1)
+ (inst fld1)
+ (inst fscale)
+ (inst fstp fr1)
+ (inst fld1)
+ (inst fsub fr1)
+ (inst fsubr fr2)
+ DONE
+ (unless (zerop (tn-offset y))
+ (inst fstd y))))
+
+(define-vop (flog)
+ (:translate %log)
+ (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0))
+ (:temporary (:sc double-reg :offset fr0-offset
+ :from :argument :to :result) fr0)
+ (:temporary (:sc double-reg :offset fr1-offset
+ :from :argument :to :result) fr1)
+ (:results (y :scs (double-reg)))
+ (:arg-types double-float)
+ (:result-types double-float)
+ (:policy :fast-safe)
+ (:note "inline log function")
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:generator 5
+ (note-this-location vop :internal-error)
+ (sc-case x
+ (double-reg
+ (case (tn-offset x)
+ (0
+ ;; x is in fr0
+ (inst fstp fr1)
+ (inst fldln2)
+ (inst fxch fr1))
+ (1
+ ;; x is in fr1
+ (inst fstp fr0)
+ (inst fldln2)
+ (inst fxch fr1))
+ (t
+ ;; x is in a FP reg, not fr0 or fr1
+ (inst fstp fr0)
+ (inst fstp fr0)
+ (inst fldln2)
+ (inst fldd (make-random-tn :kind :normal
+ :sc (sc-or-lose 'double-reg)
+ :offset (1- (tn-offset x))))))
+ (inst fyl2x))
+ ((double-stack descriptor-reg)
+ (inst fstp fr0)
+ (inst fstp fr0)
+ (inst fldln2)
+ (if (sc-is x double-stack)
+ (inst fldd (ea-for-df-stack x))
+ (inst fldd (ea-for-df-desc x)))
+ (inst fyl2x)))
+ (inst fld fr0)
+ (case (tn-offset y)
+ ((0 1))
+ (t (inst fstd y)))))
+
+(define-vop (flog10)
+ (:translate %log10)
+ (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0))
+ (:temporary (:sc double-reg :offset fr0-offset
+ :from :argument :to :result) fr0)
+ (:temporary (:sc double-reg :offset fr1-offset
+ :from :argument :to :result) fr1)
+ (:results (y :scs (double-reg)))
+ (:arg-types double-float)
+ (:result-types double-float)
+ (:policy :fast-safe)
+ (:note "inline log10 function")
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:generator 5
+ (note-this-location vop :internal-error)
+ (sc-case x
+ (double-reg
+ (case (tn-offset x)
+ (0
+ ;; x is in fr0
+ (inst fstp fr1)
+ (inst fldlg2)
+ (inst fxch fr1))
+ (1
+ ;; x is in fr1
+ (inst fstp fr0)
+ (inst fldlg2)
+ (inst fxch fr1))
+ (t
+ ;; x is in a FP reg, not fr0 or fr1
+ (inst fstp fr0)
+ (inst fstp fr0)
+ (inst fldlg2)
+ (inst fldd (make-random-tn :kind :normal
+ :sc (sc-or-lose 'double-reg)
+ :offset (1- (tn-offset x))))))
+ (inst fyl2x))
+ ((double-stack descriptor-reg)
+ (inst fstp fr0)
+ (inst fstp fr0)
+ (inst fldlg2)
+ (if (sc-is x double-stack)
+ (inst fldd (ea-for-df-stack x))
+ (inst fldd (ea-for-df-desc x)))
+ (inst fyl2x)))
+ (inst fld fr0)
+ (case (tn-offset y)
+ ((0 1))
+ (t (inst fstd y)))))
+
+(define-vop (fpow)
+ (:translate %pow)
+ (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0)
+ (y :scs (double-reg double-stack descriptor-reg) :target fr1))
+ (:temporary (:sc double-reg :offset fr0-offset
+ :from (:argument 0) :to :result) fr0)
+ (:temporary (:sc double-reg :offset fr1-offset
+ :from (:argument 1) :to :result) fr1)
+ (:temporary (:sc double-reg :offset fr2-offset
+ :from :load :to :result) fr2)
+ (:results (r :scs (double-reg)))
+ (:arg-types double-float double-float)
+ (:result-types double-float)
+ (:policy :fast-safe)
+ (:note "inline pow function")
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:generator 5
+ (note-this-location vop :internal-error)
+ ;; Setup x in fr0 and y in fr1
+ (cond
+ ;; x in fr0; y in fr1
+ ((and (sc-is x double-reg) (zerop (tn-offset x))
+ (sc-is y double-reg) (= 1 (tn-offset y))))
+ ;; y in fr1; x not in fr0
+ ((and (sc-is y double-reg) (= 1 (tn-offset y)))
+ ;; Load x to fr0
+ (sc-case x
+ (double-reg
+ (copy-fp-reg-to-fr0 x))
+ (double-stack
+ (inst fstp fr0)
+ (inst fldd (ea-for-df-stack x)))
+ (descriptor-reg
+ (inst fstp fr0)
+ (inst fldd (ea-for-df-desc x)))))
+ ;; x in fr0; y not in fr1
+ ((and (sc-is x double-reg) (zerop (tn-offset x)))
+ (inst fxch fr1)
+ ;; Now load y to fr0
+ (sc-case y
+ (double-reg
+ (copy-fp-reg-to-fr0 y))
+ (double-stack
+ (inst fstp fr0)
+ (inst fldd (ea-for-df-stack y)))
+ (descriptor-reg
+ (inst fstp fr0)
+ (inst fldd (ea-for-df-desc y))))
+ (inst fxch fr1))
+ ;; x in fr1; y not in fr1
+ ((and (sc-is x double-reg) (= 1 (tn-offset x)))
+ ;; Load y to fr0
+ (sc-case y
+ (double-reg
+ (copy-fp-reg-to-fr0 y))
+ (double-stack
+ (inst fstp fr0)
+ (inst fldd (ea-for-df-stack y)))
+ (descriptor-reg
+ (inst fstp fr0)
+ (inst fldd (ea-for-df-desc y))))
+ (inst fxch fr1))
+ ;; y in fr0;
+ ((and (sc-is y double-reg) (zerop (tn-offset y)))
+ (inst fxch fr1)
+ ;; Now load x to fr0
+ (sc-case x
+ (double-reg
+ (copy-fp-reg-to-fr0 x))
+ (double-stack
+ (inst fstp fr0)
+ (inst fldd (ea-for-df-stack x)))
+ (descriptor-reg
+ (inst fstp fr0)
+ (inst fldd (ea-for-df-desc x)))))
+ ;; Neither x or y are in either fr0 or fr1
+ (t
+ ;; Load y then x
+ (inst fstp fr0)
+ (inst fstp fr0)
+ (sc-case y
+ (double-reg
+ (inst fldd (make-random-tn :kind :normal
+ :sc (sc-or-lose 'double-reg)
+ :offset (- (tn-offset y) 2))))
+ (double-stack
+ (inst fldd (ea-for-df-stack y)))
+ (descriptor-reg
+ (inst fldd (ea-for-df-desc y))))
+ ;; Load x to fr0
+ (sc-case x
+ (double-reg
+ (inst fldd (make-random-tn :kind :normal
+ :sc (sc-or-lose 'double-reg)
+ :offset (1- (tn-offset x)))))
+ (double-stack
+ (inst fldd (ea-for-df-stack x)))
+ (descriptor-reg
+ (inst fldd (ea-for-df-desc x))))))
+
+ ;; Now have x at fr0; and y at fr1
+ (inst fyl2x)
+ ;; Now fr0=y log2(x)
+ (inst fld fr0)
+ (inst frndint)
+ (inst fst fr2)
+ (inst fsubp-sti fr1)
+ (inst f2xm1)
+ (inst fld1)
+ (inst faddp-sti fr1)
+ (inst fscale)
+ (inst fld fr0)
+ (case (tn-offset r)
+ ((0 1))
+ (t (inst fstd r)))))
+
+(define-vop (fscalen)
+ (:translate %scalbn)
+ (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0)
+ (y :scs (signed-stack signed-reg) :target temp))
+ (:temporary (:sc double-reg :offset fr0-offset
+ :from (:argument 0) :to :result) fr0)
+ (:temporary (:sc double-reg :offset fr1-offset :from :eval :to :result) fr1)
+ (:temporary (:sc signed-stack :from (:argument 1) :to :result) temp)
+ (:results (r :scs (double-reg)))
+ (:arg-types double-float signed-num)
+ (:result-types double-float)
+ (:policy :fast-safe)
+ (:note "inline scalbn function")
+ (:generator 5
+ ;; Setup x in fr0 and y in fr1
+ (sc-case x
+ (double-reg
+ (case (tn-offset x)
+ (0
+ (inst fstp fr1)
+ (sc-case y
+ (signed-reg
+ (inst mov temp y)
+ (inst fild temp))
+ (signed-stack
+ (inst fild y)))
+ (inst fxch fr1))
+ (1
+ (inst fstp fr0)
+ (sc-case y
+ (signed-reg
+ (inst mov temp y)
+ (inst fild temp))
+ (signed-stack
+ (inst fild y)))
+ (inst fxch fr1))
+ (t
+ (inst fstp fr0)
+ (inst fstp fr0)
+ (sc-case y
+ (signed-reg
+ (inst mov temp y)
+ (inst fild temp))
+ (signed-stack
+ (inst fild y)))
+ (inst fld (make-random-tn :kind :normal
+ :sc (sc-or-lose 'double-reg)
+ :offset (1- (tn-offset x)))))))
+ ((double-stack descriptor-reg)
+ (inst fstp fr0)
+ (inst fstp fr0)
+ (sc-case y
+ (signed-reg
+ (inst mov temp y)
+ (inst fild temp))
+ (signed-stack
+ (inst fild y)))
+ (if (sc-is x double-stack)
+ (inst fldd (ea-for-df-stack x))
+ (inst fldd (ea-for-df-desc x)))))
+ (inst fscale)
+ (unless (zerop (tn-offset r))
+ (inst fstd r))))
+
+(define-vop (fscale)
+ (:translate %scalb)
+ (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0)
+ (y :scs (double-reg double-stack descriptor-reg) :target fr1))
+ (:temporary (:sc double-reg :offset fr0-offset
+ :from (:argument 0) :to :result) fr0)
+ (:temporary (:sc double-reg :offset fr1-offset
+ :from (:argument 1) :to :result) fr1)
+ (:results (r :scs (double-reg)))
+ (:arg-types double-float double-float)
+ (:result-types double-float)
+ (:policy :fast-safe)
+ (:note "inline scalb function")
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:generator 5
+ (note-this-location vop :internal-error)
+ ;; Setup x in fr0 and y in fr1
+ (cond
+ ;; x in fr0; y in fr1
+ ((and (sc-is x double-reg) (zerop (tn-offset x))
+ (sc-is y double-reg) (= 1 (tn-offset y))))
+ ;; y in fr1; x not in fr0
+ ((and (sc-is y double-reg) (= 1 (tn-offset y)))
+ ;; Load x to fr0
+ (sc-case x
+ (double-reg
+ (copy-fp-reg-to-fr0 x))
+ (double-stack
+ (inst fstp fr0)
+ (inst fldd (ea-for-df-stack x)))
+ (descriptor-reg
+ (inst fstp fr0)
+ (inst fldd (ea-for-df-desc x)))))
+ ;; x in fr0; y not in fr1
+ ((and (sc-is x double-reg) (zerop (tn-offset x)))
+ (inst fxch fr1)
+ ;; Now load y to fr0
+ (sc-case y
+ (double-reg
+ (copy-fp-reg-to-fr0 y))
+ (double-stack
+ (inst fstp fr0)
+ (inst fldd (ea-for-df-stack y)))
+ (descriptor-reg
+ (inst fstp fr0)
+ (inst fldd (ea-for-df-desc y))))
+ (inst fxch fr1))
+ ;; x in fr1; y not in fr1
+ ((and (sc-is x double-reg) (= 1 (tn-offset x)))
+ ;; Load y to fr0
+ (sc-case y
+ (double-reg
+ (copy-fp-reg-to-fr0 y))
+ (double-stack
+ (inst fstp fr0)
+ (inst fldd (ea-for-df-stack y)))
+ (descriptor-reg
+ (inst fstp fr0)
+ (inst fldd (ea-for-df-desc y))))
+ (inst fxch fr1))
+ ;; y in fr0;
+ ((and (sc-is y double-reg) (zerop (tn-offset y)))
+ (inst fxch fr1)
+ ;; Now load x to fr0
+ (sc-case x
+ (double-reg
+ (copy-fp-reg-to-fr0 x))
+ (double-stack
+ (inst fstp fr0)
+ (inst fldd (ea-for-df-stack x)))
+ (descriptor-reg
+ (inst fstp fr0)
+ (inst fldd (ea-for-df-desc x)))))
+ ;; Neither x or y are in either fr0 or fr1
+ (t
+ ;; Load y then x
+ (inst fstp fr0)
+ (inst fstp fr0)
+ (sc-case y
+ (double-reg
+ (inst fldd (make-random-tn :kind :normal
+ :sc (sc-or-lose 'double-reg)
+ :offset (- (tn-offset y) 2))))
+ (double-stack
+ (inst fldd (ea-for-df-stack y)))
+ (descriptor-reg
+ (inst fldd (ea-for-df-desc y))))
+ ;; Load x to fr0
+ (sc-case x
+ (double-reg
+ (inst fldd (make-random-tn :kind :normal
+ :sc (sc-or-lose 'double-reg)
+ :offset (1- (tn-offset x)))))
+ (double-stack
+ (inst fldd (ea-for-df-stack x)))
+ (descriptor-reg
+ (inst fldd (ea-for-df-desc x))))))
+
+ ;; Now have x at fr0; and y at fr1
+ (inst fscale)
+ (unless (zerop (tn-offset r))
+ (inst fstd r))))
+
+(define-vop (flog1p)
+ (:translate %log1p)
+ (:args (x :scs (double-reg) :to :result))
+ (:temporary (:sc double-reg :offset fr0-offset
+ :from :argument :to :result) fr0)
+ (:temporary (:sc double-reg :offset fr1-offset
+ :from :argument :to :result) fr1)
+ (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
+ (:results (y :scs (double-reg)))
+ (:arg-types double-float)
+ (:result-types double-float)
+ (:policy :fast-safe)
+ ;; FIXME: PENTIUM isn't used on the *FEATURES* list of the CMU CL I based
+ ;; SBCL on, even when it is running on a Pentium. Find out what's going
+ ;; on here and see what the proper value should be. (Perhaps just use the
+ ;; apparently-conservative value of T always?) For more confusion, see also
+ ;; apparently-reversed-sense test for the FLOG1P-PENTIUM vop below.
+ (:guard #!+pentium nil #!-pentium t)
+ (:note "inline log1p function")
+ (:ignore temp)
+ (:generator 5
+ ;; x is in a FP reg, not fr0, fr1.
+ (inst fstp fr0)
+ (inst fstp fr0)
+ (inst fldd (make-random-tn :kind :normal
+ :sc (sc-or-lose 'double-reg)
+ :offset (- (tn-offset x) 2)))
+ ;; Check the range
+ (inst push #x3e947ae1) ; Constant 0.29
+ (inst fabs)
+ (inst fld (make-ea :dword :base esp-tn))
+ (inst fcompp)
+ (inst add esp-tn 4)
+ (inst fnstsw) ; status word to ax
+ (inst and ah-tn #x45)
+ (inst jmp :z WITHIN-RANGE)
+ ;; Out of range for fyl2xp1.
+ (inst fld1)
+ (inst faddd (make-random-tn :kind :normal
+ :sc (sc-or-lose 'double-reg)
+ :offset (- (tn-offset x) 1)))
+ (inst fldln2)
+ (inst fxch fr1)
+ (inst fyl2x)
+ (inst jmp DONE)
+
+ WITHIN-RANGE
+ (inst fldln2)
+ (inst fldd (make-random-tn :kind :normal
+ :sc (sc-or-lose 'double-reg)
+ :offset (- (tn-offset x) 1)))
+ (inst fyl2xp1)
+ DONE
+ (inst fld fr0)
+ (case (tn-offset y)
+ ((0 1))
+ (t (inst fstd y)))))
+
+;;; The Pentium has a less restricted implementation of the fyl2xp1
+;;; instruction and a range check can be avoided.
+(define-vop (flog1p-pentium)
+ (:translate %log1p)
+ (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0))
+ (:temporary (:sc double-reg :offset fr0-offset
+ :from :argument :to :result) fr0)
+ (:temporary (:sc double-reg :offset fr1-offset
+ :from :argument :to :result) fr1)
+ (:results (y :scs (double-reg)))
+ (:arg-types double-float)
+ (:result-types double-float)
+ (:policy :fast-safe)
+ ;; FIXME: See comments on DEFINE-VOP FLOG1P :GUARD above.
+ (:guard #!+pentium t #!-pentium nil)
+ (:note "inline log1p with limited x range function")
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:generator 5
+ (note-this-location vop :internal-error)
+ (sc-case x
+ (double-reg
+ (case (tn-offset x)
+ (0
+ ;; x is in fr0
+ (inst fstp fr1)
+ (inst fldln2)
+ (inst fxch fr1))
+ (1
+ ;; x is in fr1
+ (inst fstp fr0)
+ (inst fldln2)
+ (inst fxch fr1))
+ (t
+ ;; x is in a FP reg, not fr0 or fr1
+ (inst fstp fr0)
+ (inst fstp fr0)
+ (inst fldln2)
+ (inst fldd (make-random-tn :kind :normal
+ :sc (sc-or-lose 'double-reg)
+ :offset (1- (tn-offset x)))))))
+ ((double-stack descriptor-reg)
+ (inst fstp fr0)
+ (inst fstp fr0)
+ (inst fldln2)
+ (if (sc-is x double-stack)
+ (inst fldd (ea-for-df-stack x))
+ (inst fldd (ea-for-df-desc x)))))
+ (inst fyl2xp1)
+ (inst fld fr0)
+ (case (tn-offset y)
+ ((0 1))
+ (t (inst fstd y)))))
+
+(define-vop (flogb)
+ (:translate %logb)
+ (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0))
+ (:temporary (:sc double-reg :offset fr0-offset
+ :from :argument :to :result) fr0)
+ (:temporary (:sc double-reg :offset fr1-offset
+ :from :argument :to :result) fr1)
+ (:results (y :scs (double-reg)))
+ (:arg-types double-float)
+ (:result-types double-float)
+ (:policy :fast-safe)
+ (:note "inline logb function")
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:generator 5
+ (note-this-location vop :internal-error)
+ (sc-case x
+ (double-reg
+ (case (tn-offset x)
+ (0
+ ;; x is in fr0
+ (inst fstp fr1))
+ (1
+ ;; x is in fr1
+ (inst fstp fr0))
+ (t
+ ;; x is in a FP reg, not fr0 or fr1
+ (inst fstp fr0)
+ (inst fstp fr0)
+ (inst fldd (make-random-tn :kind :normal
+ :sc (sc-or-lose 'double-reg)
+ :offset (- (tn-offset x) 2))))))
+ ((double-stack descriptor-reg)
+ (inst fstp fr0)
+ (inst fstp fr0)
+ (if (sc-is x double-stack)
+ (inst fldd (ea-for-df-stack x))
+ (inst fldd (ea-for-df-desc x)))))
+ (inst fxtract)
+ (case (tn-offset y)
+ (0
+ (inst fxch fr1))
+ (1)
+ (t (inst fxch fr1)
+ (inst fstd y)))))
+
+(define-vop (fatan)
+ (:translate %atan)
+ (:args (x :scs (double-reg double-stack descriptor-reg) :target fr0))
+ (:temporary (:sc double-reg :offset fr0-offset
+ :from (:argument 0) :to :result) fr0)
+ (:temporary (:sc double-reg :offset fr1-offset
+ :from (:argument 0) :to :result) fr1)
+ (:results (r :scs (double-reg)))
+ (:arg-types double-float)
+ (:result-types double-float)
+ (:policy :fast-safe)
+ (:note "inline atan function")
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:generator 5
+ (note-this-location vop :internal-error)
+ ;; Setup x in fr1 and 1.0 in fr0
+ (cond
+ ;; x in fr0
+ ((and (sc-is x double-reg) (zerop (tn-offset x)))
+ (inst fstp fr1))
+ ;; x in fr1
+ ((and (sc-is x double-reg) (= 1 (tn-offset x)))
+ (inst fstp fr0))
+ ;; x not in fr0 or fr1
+ (t
+ ;; Load x then 1.0
+ (inst fstp fr0)
+ (inst fstp fr0)
+ (sc-case x
+ (double-reg
+ (inst fldd (make-random-tn :kind :normal
+ :sc (sc-or-lose 'double-reg)
+ :offset (- (tn-offset x) 2))))
+ (double-stack
+ (inst fldd (ea-for-df-stack x)))
+ (descriptor-reg
+ (inst fldd (ea-for-df-desc x))))))
+ (inst fld1)
+ ;; Now have x at fr1; and 1.0 at fr0
+ (inst fpatan)
+ (inst fld fr0)
+ (case (tn-offset r)
+ ((0 1))
+ (t (inst fstd r)))))
+
+(define-vop (fatan2)
+ (:translate %atan2)
+ (:args (x :scs (double-reg double-stack descriptor-reg) :target fr1)
+ (y :scs (double-reg double-stack descriptor-reg) :target fr0))
+ (:temporary (:sc double-reg :offset fr0-offset
+ :from (:argument 1) :to :result) fr0)
+ (:temporary (:sc double-reg :offset fr1-offset
+ :from (:argument 0) :to :result) fr1)
+ (:results (r :scs (double-reg)))
+ (:arg-types double-float double-float)
+ (:result-types double-float)
+ (:policy :fast-safe)
+ (:note "inline atan2 function")
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:generator 5
+ (note-this-location vop :internal-error)
+ ;; Setup x in fr1 and y in fr0
+ (cond
+ ;; y in fr0; x in fr1
+ ((and (sc-is y double-reg) (zerop (tn-offset y))
+ (sc-is x double-reg) (= 1 (tn-offset x))))
+ ;; x in fr1; y not in fr0
+ ((and (sc-is x double-reg) (= 1 (tn-offset x)))
+ ;; Load y to fr0
+ (sc-case y
+ (double-reg
+ (copy-fp-reg-to-fr0 y))
+ (double-stack
+ (inst fstp fr0)
+ (inst fldd (ea-for-df-stack y)))
+ (descriptor-reg
+ (inst fstp fr0)
+ (inst fldd (ea-for-df-desc y)))))
+ ;; y in fr0; x not in fr1
+ ((and (sc-is y double-reg) (zerop (tn-offset y)))
+ (inst fxch fr1)
+ ;; Now load x to fr0
+ (sc-case x
+ (double-reg
+ (copy-fp-reg-to-fr0 x))
+ (double-stack
+ (inst fstp fr0)
+ (inst fldd (ea-for-df-stack x)))
+ (descriptor-reg
+ (inst fstp fr0)
+ (inst fldd (ea-for-df-desc x))))
+ (inst fxch fr1))
+ ;; y in fr1; x not in fr1
+ ((and (sc-is y double-reg) (= 1 (tn-offset y)))
+ ;; Load x to fr0
+ (sc-case x
+ (double-reg
+ (copy-fp-reg-to-fr0 x))
+ (double-stack
+ (inst fstp fr0)
+ (inst fldd (ea-for-df-stack x)))
+ (descriptor-reg
+ (inst fstp fr0)
+ (inst fldd (ea-for-df-desc x))))
+ (inst fxch fr1))
+ ;; x in fr0;
+ ((and (sc-is x double-reg) (zerop (tn-offset x)))
+ (inst fxch fr1)
+ ;; Now load y to fr0
+ (sc-case y
+ (double-reg
+ (copy-fp-reg-to-fr0 y))
+ (double-stack
+ (inst fstp fr0)
+ (inst fldd (ea-for-df-stack y)))
+ (descriptor-reg
+ (inst fstp fr0)
+ (inst fldd (ea-for-df-desc y)))))
+ ;; Neither y or x are in either fr0 or fr1
+ (t
+ ;; Load x then y
+ (inst fstp fr0)
+ (inst fstp fr0)
+ (sc-case x
+ (double-reg
+ (inst fldd (make-random-tn :kind :normal
+ :sc (sc-or-lose 'double-reg)
+ :offset (- (tn-offset x) 2))))
+ (double-stack
+ (inst fldd (ea-for-df-stack x)))
+ (descriptor-reg
+ (inst fldd (ea-for-df-desc x))))
+ ;; Load y to fr0
+ (sc-case y
+ (double-reg
+ (inst fldd (make-random-tn :kind :normal
+ :sc (sc-or-lose 'double-reg)
+ :offset (1- (tn-offset y)))))
+ (double-stack
+ (inst fldd (ea-for-df-stack y)))
+ (descriptor-reg
+ (inst fldd (ea-for-df-desc y))))))
+
+ ;; Now have y at fr0; and x at fr1
+ (inst fpatan)
+ (inst fld fr0)
+ (case (tn-offset r)
+ ((0 1))
+ (t (inst fstd r)))))
+
+) ; progn #!-long-float
+
+\f
+
+#!+long-float
+(progn
+
+;;; Lets use some of the 80387 special functions.
+;;;
+;;; These defs will not take effect unless code/irrat.lisp is modified
+;;; to remove the inlined alien routine def.
+
+(macrolet ((frob (func trans op)
+ `(define-vop (,func)
+ (:args (x :scs (long-reg) :target fr0))
+ (:temporary (:sc long-reg :offset fr0-offset
+ :from :argument :to :result) fr0)
+ (:ignore fr0)
+ (:results (y :scs (long-reg)))
+ (:arg-types long-float)
+ (:result-types long-float)
+ (:translate ,trans)
+ (:policy :fast-safe)
+ (:note "inline NPX function")
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:node-var node)
+ (:generator 5
+ (note-this-location vop :internal-error)
+ (unless (zerop (tn-offset x))
+ (inst fxch x) ; x to top of stack
+ (unless (location= x y)
+ (inst fst x))) ; maybe save it
+ (inst ,op) ; clobber st0
+ (cond ((zerop (tn-offset y))
+ (when (policy node (or (= debug 3) (> safety speed)))
+ (inst wait)))
+ (t
+ (inst fst y)))))))
+
+ ;; Quick versions of fsin and fcos that require the argument to be
+ ;; within range 2^63.
+ (frob fsin-quick %sin-quick fsin)
+ (frob fcos-quick %cos-quick fcos)
+ (frob fsqrt %sqrt fsqrt))
+
+;;; Quick version of ftan that requires the argument to be within
+;;; range 2^63.
+(define-vop (ftan-quick)
+ (:translate %tan-quick)
+ (:args (x :scs (long-reg) :target fr0))
+ (:temporary (:sc long-reg :offset fr0-offset
+ :from :argument :to :result) fr0)
+ (:temporary (:sc long-reg :offset fr1-offset
+ :from :argument :to :result) fr1)
+ (:results (y :scs (long-reg)))
+ (:arg-types long-float)
+ (:result-types long-float)
+ (:policy :fast-safe)
+ (:note "inline tan function")
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:generator 5
+ (note-this-location vop :internal-error)
+ (case (tn-offset x)
+ (0
+ (inst fstp fr1))
+ (1
+ (inst fstp fr0))
+ (t
+ (inst fstp fr0)
+ (inst fstp fr0)
+ (inst fldd (make-random-tn :kind :normal
+ :sc (sc-or-lose 'double-reg)
+ :offset (- (tn-offset x) 2)))))
+ (inst fptan)
+ ;; Result is in fr1
+ (case (tn-offset y)
+ (0
+ (inst fxch fr1))
+ (1)
+ (t
+ (inst fxch fr1)
+ (inst fstd y)))))
+
+;;; These versions of fsin, fcos, and ftan try to use argument
+;;; reduction but to do this accurately requires greater precision and
+;;; it is hopelessly inaccurate.
+#+nil
+(macrolet ((frob (func trans op)
+ `(define-vop (,func)
+ (:translate ,trans)
+ (:args (x :scs (long-reg) :target fr0))
+ (:temporary (:sc unsigned-reg :offset eax-offset
+ :from :eval :to :result) eax)
+ (:temporary (:sc long-reg :offset fr0-offset
+ :from :argument :to :result) fr0)
+ (:temporary (:sc long-reg :offset fr1-offset
+ :from :argument :to :result) fr1)
+ (:results (y :scs (long-reg)))
+ (:arg-types long-float)
+ (:result-types long-float)
+ (:policy :fast-safe)
+ (:note "inline sin/cos function")
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:ignore eax)
+ (:generator 5
+ (note-this-location vop :internal-error)
+ (unless (zerop (tn-offset x))
+ (inst fxch x) ; x to top of stack
+ (unless (location= x y)
+ (inst fst x))) ; maybe save it
+ (inst ,op)
+ (inst fnstsw) ; status word to ax
+ (inst and ah-tn #x04) ; C2
+ (inst jmp :z DONE)
+ ;; Else x was out of range so reduce it; ST0 is unchanged.
+ (inst fstp fr1) ; Load 2*PI
+ (inst fldpi)
+ (inst fadd fr0)
+ (inst fxch fr1)
+ LOOP
+ (inst fprem1)
+ (inst fnstsw) ; status word to ax
+ (inst and ah-tn #x04) ; C2
+ (inst jmp :nz LOOP)
+ (inst ,op)
+ DONE
+ (unless (zerop (tn-offset y))
+ (inst fstd y))))))
+ (frob fsin %sin fsin)
+ (frob fcos %cos fcos))
+
+#+nil
+(define-vop (ftan)
+ (:translate %tan)
+ (:args (x :scs (long-reg) :target fr0))
+ (:temporary (:sc unsigned-reg :offset eax-offset
+ :from :argument :to :result) eax)
+ (:temporary (:sc long-reg :offset fr0-offset
+ :from :argument :to :result) fr0)
+ (:temporary (:sc long-reg :offset fr1-offset
+ :from :argument :to :result) fr1)
+ (:results (y :scs (long-reg)))
+ (:arg-types long-float)
+ (:result-types long-float)
+ (:policy :fast-safe)
+ (:note "inline tan function")
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:ignore eax)
+ (:generator 5
+ (note-this-location vop :internal-error)
+ (case (tn-offset x)
+ (0
+ (inst fstp fr1))
+ (1
+ (inst fstp fr0))
+ (t
+ (inst fstp fr0)
+ (inst fstp fr0)
+ (inst fldd (make-random-tn :kind :normal
+ :sc (sc-or-lose 'double-reg)
+ :offset (- (tn-offset x) 2)))))
+ (inst fptan)
+ (inst fnstsw) ; status word to ax
+ (inst and ah-tn #x04) ; C2
+ (inst jmp :z DONE)
+ ;; Else x was out of range so reduce it; ST0 is unchanged.
+ (inst fldpi) ; Load 2*PI
+ (inst fadd fr0)
+ (inst fxch fr1)
+ LOOP
+ (inst fprem1)
+ (inst fnstsw) ; status word to ax
+ (inst and ah-tn #x04) ; C2
+ (inst jmp :nz LOOP)
+ (inst fstp fr1)
+ (inst fptan)
+ DONE
+ ;; Result is in fr1
+ (case (tn-offset y)
+ (0
+ (inst fxch fr1))
+ (1)
+ (t
+ (inst fxch fr1)
+ (inst fstd y)))))
+
+;;; These versions of fsin, fcos, and ftan simply load a 0.0 result if
+;;; the argument is out of range 2^63 and would thus be hopelessly
+;;; inaccurate.
+(macrolet ((frob (func trans op)
+ `(define-vop (,func)
+ (:translate ,trans)
+ (:args (x :scs (long-reg) :target fr0))
+ (:temporary (:sc long-reg :offset fr0-offset
+ :from :argument :to :result) fr0)
+ (:temporary (:sc unsigned-reg :offset eax-offset
+ :from :argument :to :result) eax)
+ (:results (y :scs (long-reg)))
+ (:arg-types long-float)
+ (:result-types long-float)
+ (:policy :fast-safe)
+ (:note "inline sin/cos function")
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:ignore eax)
+ (:generator 5
+ (note-this-location vop :internal-error)
+ (unless (zerop (tn-offset x))
+ (inst fxch x) ; x to top of stack
+ (unless (location= x y)
+ (inst fst x))) ; maybe save it
+ (inst ,op)
+ (inst fnstsw) ; status word to ax
+ (inst and ah-tn #x04) ; C2
+ (inst jmp :z DONE)
+ ;; Else x was out of range so reduce it; ST0 is unchanged.
+ (inst fstp fr0) ; Load 0.0
+ (inst fldz)
+ DONE
+ (unless (zerop (tn-offset y))
+ (inst fstd y))))))
+ (frob fsin %sin fsin)
+ (frob fcos %cos fcos))
+
+(define-vop (ftan)
+ (:translate %tan)
+ (:args (x :scs (long-reg) :target fr0))
+ (:temporary (:sc long-reg :offset fr0-offset
+ :from :argument :to :result) fr0)
+ (:temporary (:sc long-reg :offset fr1-offset
+ :from :argument :to :result) fr1)
+ (:temporary (:sc unsigned-reg :offset eax-offset
+ :from :argument :to :result) eax)
+ (:results (y :scs (long-reg)))
+ (:arg-types long-float)
+ (:result-types long-float)
+ (:ignore eax)
+ (:policy :fast-safe)
+ (:note "inline tan function")
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:ignore eax)
+ (:generator 5
+ (note-this-location vop :internal-error)
+ (case (tn-offset x)
+ (0
+ (inst fstp fr1))
+ (1
+ (inst fstp fr0))
+ (t
+ (inst fstp fr0)
+ (inst fstp fr0)
+ (inst fldd (make-random-tn :kind :normal
+ :sc (sc-or-lose 'double-reg)
+ :offset (- (tn-offset x) 2)))))
+ (inst fptan)
+ (inst fnstsw) ; status word to ax
+ (inst and ah-tn #x04) ; C2
+ (inst jmp :z DONE)
+ ;; Else x was out of range so reduce it; ST0 is unchanged.
+ (inst fldz) ; Load 0.0
+ (inst fxch fr1)
+ DONE
+ ;; Result is in fr1
+ (case (tn-offset y)
+ (0
+ (inst fxch fr1))
+ (1)
+ (t
+ (inst fxch fr1)
+ (inst fstd y)))))
+
+;;; Modified exp that handles the following special cases:
+;;; exp(+Inf) is +Inf; exp(-Inf) is 0; exp(NaN) is NaN.
+(define-vop (fexp)
+ (:translate %exp)
+ (:args (x :scs (long-reg) :target fr0))
+ (:temporary (:sc word-reg :offset eax-offset :from :eval :to :result) temp)
+ (:temporary (:sc long-reg :offset fr0-offset
+ :from :argument :to :result) fr0)
+ (:temporary (:sc long-reg :offset fr1-offset
+ :from :argument :to :result) fr1)
+ (:temporary (:sc long-reg :offset fr2-offset
+ :from :argument :to :result) fr2)
+ (:results (y :scs (long-reg)))
+ (:arg-types long-float)
+ (:result-types long-float)
+ (:policy :fast-safe)
+ (:note "inline exp function")
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:ignore temp)
+ (:generator 5
+ (note-this-location vop :internal-error)
+ (unless (zerop (tn-offset x))
+ (inst fxch x) ; x to top of stack
+ (unless (location= x y)
+ (inst fst x))) ; maybe save it
+ ;; Check for Inf or NaN
+ (inst fxam)
+ (inst fnstsw)
+ (inst sahf)
+ (inst jmp :nc NOINFNAN) ; Neither Inf or NaN.
+ (inst jmp :np NOINFNAN) ; NaN gives NaN? Continue.
+ (inst and ah-tn #x02) ; Test sign of Inf.
+ (inst jmp :z DONE) ; +Inf gives +Inf.
+ (inst fstp fr0) ; -Inf gives 0
+ (inst fldz)
+ (inst jmp-short DONE)
+ NOINFNAN
+ (inst fstp fr1)
+ (inst fldl2e)
+ (inst fmul fr1)
+ ;; Now fr0=x log2(e)
+ (inst fst fr1)
+ (inst frndint)
+ (inst fst fr2)
+ (inst fsubp-sti fr1)
+ (inst f2xm1)
+ (inst fld1)
+ (inst faddp-sti fr1)
+ (inst fscale)
+ (inst fld fr0)
+ DONE
+ (unless (zerop (tn-offset y))
+ (inst fstd y))))
+
+;;; Expm1 = exp(x) - 1.
+;;; Handles the following special cases:
+;;; expm1(+Inf) is +Inf; expm1(-Inf) is -1.0; expm1(NaN) is NaN.
+(define-vop (fexpm1)
+ (:translate %expm1)
+ (:args (x :scs (long-reg) :target fr0))
+ (:temporary (:sc word-reg :offset eax-offset :from :eval :to :result) temp)
+ (:temporary (:sc long-reg :offset fr0-offset
+ :from :argument :to :result) fr0)
+ (:temporary (:sc long-reg :offset fr1-offset
+ :from :argument :to :result) fr1)
+ (:temporary (:sc long-reg :offset fr2-offset
+ :from :argument :to :result) fr2)
+ (:results (y :scs (long-reg)))
+ (:arg-types long-float)
+ (:result-types long-float)
+ (:policy :fast-safe)
+ (:note "inline expm1 function")
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:ignore temp)
+ (:generator 5
+ (note-this-location vop :internal-error)
+ (unless (zerop (tn-offset x))
+ (inst fxch x) ; x to top of stack
+ (unless (location= x y)
+ (inst fst x))) ; maybe save it
+ ;; Check for Inf or NaN
+ (inst fxam)
+ (inst fnstsw)
+ (inst sahf)
+ (inst jmp :nc NOINFNAN) ; Neither Inf or NaN.
+ (inst jmp :np NOINFNAN) ; NaN gives NaN? Continue.
+ (inst and ah-tn #x02) ; Test sign of Inf.
+ (inst jmp :z DONE) ; +Inf gives +Inf.
+ (inst fstp fr0) ; -Inf gives -1.0
+ (inst fld1)
+ (inst fchs)
+ (inst jmp-short DONE)
+ NOINFNAN
+ ;; Free two stack slots leaving the argument on top.
+ (inst fstp fr2)
+ (inst fstp fr0)
+ (inst fldl2e)
+ (inst fmul fr1) ; Now fr0 = x log2(e)
+ (inst fst fr1)
+ (inst frndint)
+ (inst fsub-sti fr1)
+ (inst fxch fr1)
+ (inst f2xm1)
+ (inst fscale)
+ (inst fxch fr1)
+ (inst fld1)
+ (inst fscale)
+ (inst fstp fr1)
+ (inst fld1)
+ (inst fsub fr1)
+ (inst fsubr fr2)
+ DONE
+ (unless (zerop (tn-offset y))
+ (inst fstd y))))
+
+(define-vop (flog)
+ (:translate %log)
+ (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0))
+ (:temporary (:sc long-reg :offset fr0-offset
+ :from :argument :to :result) fr0)
+ (:temporary (:sc long-reg :offset fr1-offset
+ :from :argument :to :result) fr1)
+ (:results (y :scs (long-reg)))
+ (:arg-types long-float)
+ (:result-types long-float)
+ (:policy :fast-safe)
+ (:note "inline log function")
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:generator 5
+ (note-this-location vop :internal-error)
+ (sc-case x
+ (long-reg
+ (case (tn-offset x)
+ (0
+ ;; x is in fr0
+ (inst fstp fr1)
+ (inst fldln2)
+ (inst fxch fr1))
+ (1
+ ;; x is in fr1
+ (inst fstp fr0)
+ (inst fldln2)
+ (inst fxch fr1))
+ (t
+ ;; x is in a FP reg, not fr0 or fr1
+ (inst fstp fr0)
+ (inst fstp fr0)
+ (inst fldln2)
+ (inst fldd (make-random-tn :kind :normal
+ :sc (sc-or-lose 'double-reg)
+ :offset (1- (tn-offset x))))))
+ (inst fyl2x))
+ ((long-stack descriptor-reg)
+ (inst fstp fr0)
+ (inst fstp fr0)
+ (inst fldln2)
+ (if (sc-is x long-stack)
+ (inst fldl (ea-for-lf-stack x))
+ (inst fldl (ea-for-lf-desc x)))
+ (inst fyl2x)))
+ (inst fld fr0)
+ (case (tn-offset y)
+ ((0 1))
+ (t (inst fstd y)))))
+
+(define-vop (flog10)
+ (:translate %log10)
+ (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0))
+ (:temporary (:sc long-reg :offset fr0-offset
+ :from :argument :to :result) fr0)
+ (:temporary (:sc long-reg :offset fr1-offset
+ :from :argument :to :result) fr1)
+ (:results (y :scs (long-reg)))
+ (:arg-types long-float)
+ (:result-types long-float)
+ (:policy :fast-safe)
+ (:note "inline log10 function")
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:generator 5
+ (note-this-location vop :internal-error)
+ (sc-case x
+ (long-reg
+ (case (tn-offset x)
+ (0
+ ;; x is in fr0
+ (inst fstp fr1)
+ (inst fldlg2)
+ (inst fxch fr1))
+ (1
+ ;; x is in fr1
+ (inst fstp fr0)
+ (inst fldlg2)
+ (inst fxch fr1))
+ (t
+ ;; x is in a FP reg, not fr0 or fr1
+ (inst fstp fr0)
+ (inst fstp fr0)
+ (inst fldlg2)
+ (inst fldd (make-random-tn :kind :normal
+ :sc (sc-or-lose 'double-reg)
+ :offset (1- (tn-offset x))))))
+ (inst fyl2x))
+ ((long-stack descriptor-reg)
+ (inst fstp fr0)
+ (inst fstp fr0)
+ (inst fldlg2)
+ (if (sc-is x long-stack)
+ (inst fldl (ea-for-lf-stack x))
+ (inst fldl (ea-for-lf-desc x)))
+ (inst fyl2x)))
+ (inst fld fr0)
+ (case (tn-offset y)
+ ((0 1))
+ (t (inst fstd y)))))
+
+(define-vop (fpow)
+ (:translate %pow)
+ (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0)
+ (y :scs (long-reg long-stack descriptor-reg) :target fr1))
+ (:temporary (:sc long-reg :offset fr0-offset
+ :from (:argument 0) :to :result) fr0)
+ (:temporary (:sc long-reg :offset fr1-offset
+ :from (:argument 1) :to :result) fr1)
+ (:temporary (:sc long-reg :offset fr2-offset
+ :from :load :to :result) fr2)
+ (:results (r :scs (long-reg)))
+ (:arg-types long-float long-float)
+ (:result-types long-float)
+ (:policy :fast-safe)
+ (:note "inline pow function")
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:generator 5
+ (note-this-location vop :internal-error)
+ ;; Setup x in fr0 and y in fr1
+ (cond
+ ;; x in fr0; y in fr1
+ ((and (sc-is x long-reg) (zerop (tn-offset x))
+ (sc-is y long-reg) (= 1 (tn-offset y))))
+ ;; y in fr1; x not in fr0
+ ((and (sc-is y long-reg) (= 1 (tn-offset y)))
+ ;; Load x to fr0
+ (sc-case x
+ (long-reg
+ (copy-fp-reg-to-fr0 x))
+ (long-stack
+ (inst fstp fr0)
+ (inst fldl (ea-for-lf-stack x)))
+ (descriptor-reg
+ (inst fstp fr0)
+ (inst fldl (ea-for-lf-desc x)))))
+ ;; x in fr0; y not in fr1
+ ((and (sc-is x long-reg) (zerop (tn-offset x)))
+ (inst fxch fr1)
+ ;; Now load y to fr0
+ (sc-case y
+ (long-reg
+ (copy-fp-reg-to-fr0 y))
+ (long-stack
+ (inst fstp fr0)
+ (inst fldl (ea-for-lf-stack y)))
+ (descriptor-reg
+ (inst fstp fr0)
+ (inst fldl (ea-for-lf-desc y))))
+ (inst fxch fr1))
+ ;; x in fr1; y not in fr1
+ ((and (sc-is x long-reg) (= 1 (tn-offset x)))
+ ;; Load y to fr0
+ (sc-case y
+ (long-reg
+ (copy-fp-reg-to-fr0 y))
+ (long-stack
+ (inst fstp fr0)
+ (inst fldl (ea-for-lf-stack y)))
+ (descriptor-reg
+ (inst fstp fr0)
+ (inst fldl (ea-for-lf-desc y))))
+ (inst fxch fr1))
+ ;; y in fr0;
+ ((and (sc-is y long-reg) (zerop (tn-offset y)))
+ (inst fxch fr1)
+ ;; Now load x to fr0
+ (sc-case x
+ (long-reg
+ (copy-fp-reg-to-fr0 x))
+ (long-stack
+ (inst fstp fr0)
+ (inst fldl (ea-for-lf-stack x)))
+ (descriptor-reg
+ (inst fstp fr0)
+ (inst fldl (ea-for-lf-desc x)))))
+ ;; Neither x or y are in either fr0 or fr1
+ (t
+ ;; Load y then x
+ (inst fstp fr0)
+ (inst fstp fr0)
+ (sc-case y
+ (long-reg
+ (inst fldd (make-random-tn :kind :normal
+ :sc (sc-or-lose 'double-reg)
+ :offset (- (tn-offset y) 2))))
+ (long-stack
+ (inst fldl (ea-for-lf-stack y)))
+ (descriptor-reg
+ (inst fldl (ea-for-lf-desc y))))
+ ;; Load x to fr0
+ (sc-case x
+ (long-reg
+ (inst fldd (make-random-tn :kind :normal
+ :sc (sc-or-lose 'double-reg)
+ :offset (1- (tn-offset x)))))
+ (long-stack
+ (inst fldl (ea-for-lf-stack x)))
+ (descriptor-reg
+ (inst fldl (ea-for-lf-desc x))))))
+
+ ;; Now have x at fr0; and y at fr1
+ (inst fyl2x)
+ ;; Now fr0=y log2(x)
+ (inst fld fr0)
+ (inst frndint)
+ (inst fst fr2)
+ (inst fsubp-sti fr1)
+ (inst f2xm1)
+ (inst fld1)
+ (inst faddp-sti fr1)
+ (inst fscale)
+ (inst fld fr0)
+ (case (tn-offset r)
+ ((0 1))
+ (t (inst fstd r)))))
+
+(define-vop (fscalen)
+ (:translate %scalbn)
+ (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0)
+ (y :scs (signed-stack signed-reg) :target temp))
+ (:temporary (:sc long-reg :offset fr0-offset
+ :from (:argument 0) :to :result) fr0)
+ (:temporary (:sc long-reg :offset fr1-offset :from :eval :to :result) fr1)
+ (:temporary (:sc signed-stack :from (:argument 1) :to :result) temp)
+ (:results (r :scs (long-reg)))
+ (:arg-types long-float signed-num)
+ (:result-types long-float)
+ (:policy :fast-safe)
+ (:note "inline scalbn function")
+ (:generator 5
+ ;; Setup x in fr0 and y in fr1
+ (sc-case x
+ (long-reg
+ (case (tn-offset x)
+ (0
+ (inst fstp fr1)
+ (sc-case y
+ (signed-reg
+ (inst mov temp y)
+ (inst fild temp))
+ (signed-stack
+ (inst fild y)))
+ (inst fxch fr1))
+ (1
+ (inst fstp fr0)
+ (sc-case y
+ (signed-reg
+ (inst mov temp y)
+ (inst fild temp))
+ (signed-stack
+ (inst fild y)))
+ (inst fxch fr1))
+ (t
+ (inst fstp fr0)
+ (inst fstp fr0)
+ (sc-case y
+ (signed-reg
+ (inst mov temp y)
+ (inst fild temp))
+ (signed-stack
+ (inst fild y)))
+ (inst fld (make-random-tn :kind :normal
+ :sc (sc-or-lose 'double-reg)
+ :offset (1- (tn-offset x)))))))
+ ((long-stack descriptor-reg)
+ (inst fstp fr0)
+ (inst fstp fr0)
+ (sc-case y
+ (signed-reg
+ (inst mov temp y)
+ (inst fild temp))
+ (signed-stack
+ (inst fild y)))
+ (if (sc-is x long-stack)
+ (inst fldl (ea-for-lf-stack x))
+ (inst fldl (ea-for-lf-desc x)))))
+ (inst fscale)
+ (unless (zerop (tn-offset r))
+ (inst fstd r))))
+
+(define-vop (fscale)
+ (:translate %scalb)
+ (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0)
+ (y :scs (long-reg long-stack descriptor-reg) :target fr1))
+ (:temporary (:sc long-reg :offset fr0-offset
+ :from (:argument 0) :to :result) fr0)
+ (:temporary (:sc long-reg :offset fr1-offset
+ :from (:argument 1) :to :result) fr1)
+ (:results (r :scs (long-reg)))
+ (:arg-types long-float long-float)
+ (:result-types long-float)
+ (:policy :fast-safe)
+ (:note "inline scalb function")
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:generator 5
+ (note-this-location vop :internal-error)
+ ;; Setup x in fr0 and y in fr1
+ (cond
+ ;; x in fr0; y in fr1
+ ((and (sc-is x long-reg) (zerop (tn-offset x))
+ (sc-is y long-reg) (= 1 (tn-offset y))))
+ ;; y in fr1; x not in fr0
+ ((and (sc-is y long-reg) (= 1 (tn-offset y)))
+ ;; Load x to fr0
+ (sc-case x
+ (long-reg
+ (copy-fp-reg-to-fr0 x))
+ (long-stack
+ (inst fstp fr0)
+ (inst fldl (ea-for-lf-stack x)))
+ (descriptor-reg
+ (inst fstp fr0)
+ (inst fldl (ea-for-lf-desc x)))))
+ ;; x in fr0; y not in fr1
+ ((and (sc-is x long-reg) (zerop (tn-offset x)))
+ (inst fxch fr1)
+ ;; Now load y to fr0
+ (sc-case y
+ (long-reg
+ (copy-fp-reg-to-fr0 y))
+ (long-stack
+ (inst fstp fr0)
+ (inst fldl (ea-for-lf-stack y)))
+ (descriptor-reg
+ (inst fstp fr0)
+ (inst fldl (ea-for-lf-desc y))))
+ (inst fxch fr1))
+ ;; x in fr1; y not in fr1
+ ((and (sc-is x long-reg) (= 1 (tn-offset x)))
+ ;; Load y to fr0
+ (sc-case y
+ (long-reg
+ (copy-fp-reg-to-fr0 y))
+ (long-stack
+ (inst fstp fr0)
+ (inst fldl (ea-for-lf-stack y)))
+ (descriptor-reg
+ (inst fstp fr0)
+ (inst fldl (ea-for-lf-desc y))))
+ (inst fxch fr1))
+ ;; y in fr0;
+ ((and (sc-is y long-reg) (zerop (tn-offset y)))
+ (inst fxch fr1)
+ ;; Now load x to fr0
+ (sc-case x
+ (long-reg
+ (copy-fp-reg-to-fr0 x))
+ (long-stack
+ (inst fstp fr0)
+ (inst fldl (ea-for-lf-stack x)))
+ (descriptor-reg
+ (inst fstp fr0)
+ (inst fldl (ea-for-lf-desc x)))))
+ ;; Neither x or y are in either fr0 or fr1
+ (t
+ ;; Load y then x
+ (inst fstp fr0)
+ (inst fstp fr0)
+ (sc-case y
+ (long-reg
+ (inst fldd (make-random-tn :kind :normal
+ :sc (sc-or-lose 'double-reg)
+ :offset (- (tn-offset y) 2))))
+ (long-stack
+ (inst fldl (ea-for-lf-stack y)))
+ (descriptor-reg
+ (inst fldl (ea-for-lf-desc y))))
+ ;; Load x to fr0
+ (sc-case x
+ (long-reg
+ (inst fldd (make-random-tn :kind :normal
+ :sc (sc-or-lose 'double-reg)
+ :offset (1- (tn-offset x)))))
+ (long-stack
+ (inst fldl (ea-for-lf-stack x)))
+ (descriptor-reg
+ (inst fldl (ea-for-lf-desc x))))))
+
+ ;; Now have x at fr0; and y at fr1
+ (inst fscale)
+ (unless (zerop (tn-offset r))
+ (inst fstd r))))
+
+(define-vop (flog1p)
+ (:translate %log1p)
+ (:args (x :scs (long-reg) :to :result))
+ (:temporary (:sc long-reg :offset fr0-offset
+ :from :argument :to :result) fr0)
+ (:temporary (:sc long-reg :offset fr1-offset
+ :from :argument :to :result) fr1)
+ (:temporary (:sc word-reg :offset eax-offset :from :eval) temp)
+ (:results (y :scs (long-reg)))
+ (:arg-types long-float)
+ (:result-types long-float)
+ (:policy :fast-safe)
+ ;; FIXME 1: This appears to be the second DEFINE-VOP of FLOG1P.
+ ;; Perhaps this is OK because of the #!+LONG-FLOAT wrapped around
+ ;; an enormous PROGN above. Still, it would be probably be good to
+ ;; add some code to warn about redefining VOPs.
+ ;; FIXME 2: See comments on DEFINE-VOP FLOG1P :GUARD above.
+ (:guard #!+pentium nil #!-pentium t)
+ (:note "inline log1p function")
+ (:ignore temp)
+ (:generator 5
+ ;; x is in a FP reg, not fr0, fr1.
+ (inst fstp fr0)
+ (inst fstp fr0)
+ (inst fldd (make-random-tn :kind :normal
+ :sc (sc-or-lose 'double-reg)
+ :offset (- (tn-offset x) 2)))
+ ;; Check the range
+ (inst push #x3e947ae1) ; Constant 0.29
+ (inst fabs)
+ (inst fld (make-ea :dword :base esp-tn))
+ (inst fcompp)
+ (inst add esp-tn 4)
+ (inst fnstsw) ; status word to ax
+ (inst and ah-tn #x45)
+ (inst jmp :z WITHIN-RANGE)
+ ;; Out of range for fyl2xp1.
+ (inst fld1)
+ (inst faddd (make-random-tn :kind :normal
+ :sc (sc-or-lose 'double-reg)
+ :offset (- (tn-offset x) 1)))
+ (inst fldln2)
+ (inst fxch fr1)
+ (inst fyl2x)
+ (inst jmp DONE)
+
+ WITHIN-RANGE
+ (inst fldln2)
+ (inst fldd (make-random-tn :kind :normal
+ :sc (sc-or-lose 'double-reg)
+ :offset (- (tn-offset x) 1)))
+ (inst fyl2xp1)
+ DONE
+ (inst fld fr0)
+ (case (tn-offset y)
+ ((0 1))
+ (t (inst fstd y)))))
+
+;;; The Pentium has a less restricted implementation of the fyl2xp1
+;;; instruction and a range check can be avoided.
+(define-vop (flog1p-pentium)
+ (:translate %log1p)
+ (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0))
+ (:temporary (:sc long-reg :offset fr0-offset
+ :from :argument :to :result) fr0)
+ (:temporary (:sc long-reg :offset fr1-offset
+ :from :argument :to :result) fr1)
+ (:results (y :scs (long-reg)))
+ (:arg-types long-float)
+ (:result-types long-float)
+ (:policy :fast-safe)
+ ;; FIXME: See comments on DEFINE-VOP FLOG1P :GUARD above.
+ (:guard #!+pentium t #!-pentium)
+ (:note "inline log1p function")
+ (:generator 5
+ (sc-case x
+ (long-reg
+ (case (tn-offset x)
+ (0
+ ;; x is in fr0
+ (inst fstp fr1)
+ (inst fldln2)
+ (inst fxch fr1))
+ (1
+ ;; x is in fr1
+ (inst fstp fr0)
+ (inst fldln2)
+ (inst fxch fr1))
+ (t
+ ;; x is in a FP reg, not fr0 or fr1
+ (inst fstp fr0)
+ (inst fstp fr0)
+ (inst fldln2)
+ (inst fldd (make-random-tn :kind :normal
+ :sc (sc-or-lose 'double-reg)
+ :offset (1- (tn-offset x)))))))
+ ((long-stack descriptor-reg)
+ (inst fstp fr0)
+ (inst fstp fr0)
+ (inst fldln2)
+ (if (sc-is x long-stack)
+ (inst fldl (ea-for-lf-stack x))
+ (inst fldl (ea-for-lf-desc x)))))
+ (inst fyl2xp1)
+ (inst fld fr0)
+ (case (tn-offset y)
+ ((0 1))
+ (t (inst fstd y)))))
+
+(define-vop (flogb)
+ (:translate %logb)
+ (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0))
+ (:temporary (:sc long-reg :offset fr0-offset
+ :from :argument :to :result) fr0)
+ (:temporary (:sc long-reg :offset fr1-offset
+ :from :argument :to :result) fr1)
+ (:results (y :scs (long-reg)))
+ (:arg-types long-float)
+ (:result-types long-float)
+ (:policy :fast-safe)
+ (:note "inline logb function")
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:generator 5
+ (note-this-location vop :internal-error)
+ (sc-case x
+ (long-reg
+ (case (tn-offset x)
+ (0
+ ;; x is in fr0
+ (inst fstp fr1))
+ (1
+ ;; x is in fr1
+ (inst fstp fr0))
+ (t
+ ;; x is in a FP reg, not fr0 or fr1
+ (inst fstp fr0)
+ (inst fstp fr0)
+ (inst fldd (make-random-tn :kind :normal
+ :sc (sc-or-lose 'double-reg)
+ :offset (- (tn-offset x) 2))))))
+ ((long-stack descriptor-reg)
+ (inst fstp fr0)
+ (inst fstp fr0)
+ (if (sc-is x long-stack)
+ (inst fldl (ea-for-lf-stack x))
+ (inst fldl (ea-for-lf-desc x)))))
+ (inst fxtract)
+ (case (tn-offset y)
+ (0
+ (inst fxch fr1))
+ (1)
+ (t (inst fxch fr1)
+ (inst fstd y)))))
+
+(define-vop (fatan)
+ (:translate %atan)
+ (:args (x :scs (long-reg long-stack descriptor-reg) :target fr0))
+ (:temporary (:sc long-reg :offset fr0-offset
+ :from (:argument 0) :to :result) fr0)
+ (:temporary (:sc long-reg :offset fr1-offset
+ :from (:argument 0) :to :result) fr1)
+ (:results (r :scs (long-reg)))
+ (:arg-types long-float)
+ (:result-types long-float)
+ (:policy :fast-safe)
+ (:note "inline atan function")
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:generator 5
+ (note-this-location vop :internal-error)
+ ;; Setup x in fr1 and 1.0 in fr0
+ (cond
+ ;; x in fr0
+ ((and (sc-is x long-reg) (zerop (tn-offset x)))
+ (inst fstp fr1))
+ ;; x in fr1
+ ((and (sc-is x long-reg) (= 1 (tn-offset x)))
+ (inst fstp fr0))
+ ;; x not in fr0 or fr1
+ (t
+ ;; Load x then 1.0
+ (inst fstp fr0)
+ (inst fstp fr0)
+ (sc-case x
+ (long-reg
+ (inst fldd (make-random-tn :kind :normal
+ :sc (sc-or-lose 'double-reg)
+ :offset (- (tn-offset x) 2))))
+ (long-stack
+ (inst fldl (ea-for-lf-stack x)))
+ (descriptor-reg
+ (inst fldl (ea-for-lf-desc x))))))
+ (inst fld1)
+ ;; Now have x at fr1; and 1.0 at fr0
+ (inst fpatan)
+ (inst fld fr0)
+ (case (tn-offset r)
+ ((0 1))
+ (t (inst fstd r)))))
+
+(define-vop (fatan2)
+ (:translate %atan2)
+ (:args (x :scs (long-reg long-stack descriptor-reg) :target fr1)
+ (y :scs (long-reg long-stack descriptor-reg) :target fr0))
+ (:temporary (:sc long-reg :offset fr0-offset
+ :from (:argument 1) :to :result) fr0)
+ (:temporary (:sc long-reg :offset fr1-offset
+ :from (:argument 0) :to :result) fr1)
+ (:results (r :scs (long-reg)))
+ (:arg-types long-float long-float)
+ (:result-types long-float)
+ (:policy :fast-safe)
+ (:note "inline atan2 function")
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:generator 5
+ (note-this-location vop :internal-error)
+ ;; Setup x in fr1 and y in fr0
+ (cond
+ ;; y in fr0; x in fr1
+ ((and (sc-is y long-reg) (zerop (tn-offset y))
+ (sc-is x long-reg) (= 1 (tn-offset x))))
+ ;; x in fr1; y not in fr0
+ ((and (sc-is x long-reg) (= 1 (tn-offset x)))
+ ;; Load y to fr0
+ (sc-case y
+ (long-reg
+ (copy-fp-reg-to-fr0 y))
+ (long-stack
+ (inst fstp fr0)
+ (inst fldl (ea-for-lf-stack y)))
+ (descriptor-reg
+ (inst fstp fr0)
+ (inst fldl (ea-for-lf-desc y)))))
+ ;; y in fr0; x not in fr1
+ ((and (sc-is y long-reg) (zerop (tn-offset y)))
+ (inst fxch fr1)
+ ;; Now load x to fr0
+ (sc-case x
+ (long-reg
+ (copy-fp-reg-to-fr0 x))
+ (long-stack
+ (inst fstp fr0)
+ (inst fldl (ea-for-lf-stack x)))
+ (descriptor-reg
+ (inst fstp fr0)
+ (inst fldl (ea-for-lf-desc x))))
+ (inst fxch fr1))
+ ;; y in fr1; x not in fr1
+ ((and (sc-is y long-reg) (= 1 (tn-offset y)))
+ ;; Load x to fr0
+ (sc-case x
+ (long-reg
+ (copy-fp-reg-to-fr0 x))
+ (long-stack
+ (inst fstp fr0)
+ (inst fldl (ea-for-lf-stack x)))
+ (descriptor-reg
+ (inst fstp fr0)
+ (inst fldl (ea-for-lf-desc x))))
+ (inst fxch fr1))
+ ;; x in fr0;
+ ((and (sc-is x long-reg) (zerop (tn-offset x)))
+ (inst fxch fr1)
+ ;; Now load y to fr0
+ (sc-case y
+ (long-reg
+ (copy-fp-reg-to-fr0 y))
+ (long-stack
+ (inst fstp fr0)
+ (inst fldl (ea-for-lf-stack y)))
+ (descriptor-reg
+ (inst fstp fr0)
+ (inst fldl (ea-for-lf-desc y)))))
+ ;; Neither y or x are in either fr0 or fr1
+ (t
+ ;; Load x then y
+ (inst fstp fr0)
+ (inst fstp fr0)
+ (sc-case x
+ (long-reg
+ (inst fldd (make-random-tn :kind :normal
+ :sc (sc-or-lose 'double-reg)
+ :offset (- (tn-offset x) 2))))
+ (long-stack
+ (inst fldl (ea-for-lf-stack x)))
+ (descriptor-reg
+ (inst fldl (ea-for-lf-desc x))))
+ ;; Load y to fr0
+ (sc-case y
+ (long-reg
+ (inst fldd (make-random-tn :kind :normal
+ :sc (sc-or-lose 'double-reg)
+ :offset (1- (tn-offset y)))))
+ (long-stack
+ (inst fldl (ea-for-lf-stack y)))
+ (descriptor-reg
+ (inst fldl (ea-for-lf-desc y))))))
+
+ ;; Now have y at fr0; and x at fr1
+ (inst fpatan)
+ (inst fld fr0)
+ (case (tn-offset r)
+ ((0 1))
+ (t (inst fstd r)))))
+
+) ; progn #!+long-float
+
+\f
+;;;; Complex float VOPs
+
+(define-vop (make-complex-single-float)
+ (:translate complex)
+ (:args (real :scs (single-reg) :to :result :target r
+ :load-if (not (location= real r)))
+ (imag :scs (single-reg) :to :save))
+ (:arg-types single-float single-float)
+ (:results (r :scs (complex-single-reg) :from (:argument 0)
+ :load-if (not (sc-is r complex-single-stack))))
+ (:result-types complex-single-float)
+ (:note "inline complex single-float creation")
+ (:policy :fast-safe)
+ (:generator 5
+ (sc-case r
+ (complex-single-reg
+ (let ((r-real (complex-double-reg-real-tn r)))
+ (unless (location= real r-real)
+ (cond ((zerop (tn-offset r-real))
+ (copy-fp-reg-to-fr0 real))
+ ((zerop (tn-offset real))
+ (inst fstd r-real))
+ (t
+ (inst fxch real)
+ (inst fstd r-real)
+ (inst fxch real)))))
+ (let ((r-imag (complex-double-reg-imag-tn r)))
+ (unless (location= imag r-imag)
+ (cond ((zerop (tn-offset imag))
+ (inst fstd r-imag))
+ (t
+ (inst fxch imag)
+ (inst fstd r-imag)
+ (inst fxch imag))))))
+ (complex-single-stack
+ (unless (location= real r)
+ (cond ((zerop (tn-offset real))
+ (inst fst (ea-for-csf-real-stack r)))
+ (t
+ (inst fxch real)
+ (inst fst (ea-for-csf-real-stack r))
+ (inst fxch real))))
+ (inst fxch imag)
+ (inst fst (ea-for-csf-imag-stack r))
+ (inst fxch imag)))))
+
+(define-vop (make-complex-double-float)
+ (:translate complex)
+ (:args (real :scs (double-reg) :target r
+ :load-if (not (location= real r)))
+ (imag :scs (double-reg) :to :save))
+ (:arg-types double-float double-float)
+ (:results (r :scs (complex-double-reg) :from (:argument 0)
+ :load-if (not (sc-is r complex-double-stack))))
+ (:result-types complex-double-float)
+ (:note "inline complex double-float creation")
+ (:policy :fast-safe)
+ (:generator 5
+ (sc-case r
+ (complex-double-reg
+ (let ((r-real (complex-double-reg-real-tn r)))
+ (unless (location= real r-real)
+ (cond ((zerop (tn-offset r-real))
+ (copy-fp-reg-to-fr0 real))
+ ((zerop (tn-offset real))
+ (inst fstd r-real))
+ (t
+ (inst fxch real)
+ (inst fstd r-real)
+ (inst fxch real)))))
+ (let ((r-imag (complex-double-reg-imag-tn r)))
+ (unless (location= imag r-imag)
+ (cond ((zerop (tn-offset imag))
+ (inst fstd r-imag))
+ (t
+ (inst fxch imag)
+ (inst fstd r-imag)
+ (inst fxch imag))))))
+ (complex-double-stack
+ (unless (location= real r)
+ (cond ((zerop (tn-offset real))
+ (inst fstd (ea-for-cdf-real-stack r)))
+ (t
+ (inst fxch real)
+ (inst fstd (ea-for-cdf-real-stack r))
+ (inst fxch real))))
+ (inst fxch imag)
+ (inst fstd (ea-for-cdf-imag-stack r))
+ (inst fxch imag)))))
+
+#!+long-float
+(define-vop (make-complex-long-float)
+ (:translate complex)
+ (:args (real :scs (long-reg) :target r
+ :load-if (not (location= real r)))
+ (imag :scs (long-reg) :to :save))
+ (:arg-types long-float long-float)
+ (:results (r :scs (complex-long-reg) :from (:argument 0)
+ :load-if (not (sc-is r complex-long-stack))))
+ (:result-types complex-long-float)
+ (:note "inline complex long-float creation")
+ (:policy :fast-safe)
+ (:generator 5
+ (sc-case r
+ (complex-long-reg
+ (let ((r-real (complex-double-reg-real-tn r)))
+ (unless (location= real r-real)
+ (cond ((zerop (tn-offset r-real))
+ (copy-fp-reg-to-fr0 real))
+ ((zerop (tn-offset real))
+ (inst fstd r-real))
+ (t
+ (inst fxch real)
+ (inst fstd r-real)
+ (inst fxch real)))))
+ (let ((r-imag (complex-double-reg-imag-tn r)))
+ (unless (location= imag r-imag)
+ (cond ((zerop (tn-offset imag))
+ (inst fstd r-imag))
+ (t
+ (inst fxch imag)
+ (inst fstd r-imag)
+ (inst fxch imag))))))
+ (complex-long-stack
+ (unless (location= real r)
+ (cond ((zerop (tn-offset real))
+ (store-long-float (ea-for-clf-real-stack r)))
+ (t
+ (inst fxch real)
+ (store-long-float (ea-for-clf-real-stack r))
+ (inst fxch real))))
+ (inst fxch imag)
+ (store-long-float (ea-for-clf-imag-stack r))
+ (inst fxch imag)))))
+
+
+(define-vop (complex-float-value)
+ (:args (x :target r))
+ (:results (r))
+ (:variant-vars offset)
+ (:policy :fast-safe)
+ (:generator 3
+ (cond ((sc-is x complex-single-reg complex-double-reg
+ #!+long-float complex-long-reg)
+ (let ((value-tn
+ (make-random-tn :kind :normal
+ :sc (sc-or-lose 'double-reg)
+ :offset (+ offset (tn-offset x)))))
+ (unless (location= value-tn r)
+ (cond ((zerop (tn-offset r))
+ (copy-fp-reg-to-fr0 value-tn))
+ ((zerop (tn-offset value-tn))
+ (inst fstd r))
+ (t
+ (inst fxch value-tn)
+ (inst fstd r)
+ (inst fxch value-tn))))))
+ ((sc-is r single-reg)
+ (let ((ea (sc-case x
+ (complex-single-stack
+ (ecase offset
+ (0 (ea-for-csf-real-stack x))
+ (1 (ea-for-csf-imag-stack x))))
+ (descriptor-reg
+ (ecase offset
+ (0 (ea-for-csf-real-desc x))
+ (1 (ea-for-csf-imag-desc x)))))))
+ (with-empty-tn@fp-top(r)
+ (inst fld ea))))
+ ((sc-is r double-reg)
+ (let ((ea (sc-case x
+ (complex-double-stack
+ (ecase offset
+ (0 (ea-for-cdf-real-stack x))
+ (1 (ea-for-cdf-imag-stack x))))
+ (descriptor-reg
+ (ecase offset
+ (0 (ea-for-cdf-real-desc x))
+ (1 (ea-for-cdf-imag-desc x)))))))
+ (with-empty-tn@fp-top(r)
+ (inst fldd ea))))
+ #!+long-float
+ ((sc-is r long-reg)
+ (let ((ea (sc-case x
+ (complex-long-stack
+ (ecase offset
+ (0 (ea-for-clf-real-stack x))
+ (1 (ea-for-clf-imag-stack x))))
+ (descriptor-reg
+ (ecase offset
+ (0 (ea-for-clf-real-desc x))
+ (1 (ea-for-clf-imag-desc x)))))))
+ (with-empty-tn@fp-top(r)
+ (inst fldl ea))))
+ (t (error "Complex-float-value VOP failure")))))
+
+(define-vop (realpart/complex-single-float complex-float-value)
+ (:translate realpart)
+ (:args (x :scs (complex-single-reg complex-single-stack descriptor-reg)
+ :target r))
+ (:arg-types complex-single-float)
+ (:results (r :scs (single-reg)))
+ (:result-types single-float)
+ (:note "complex float realpart")
+ (:variant 0))
+
+(define-vop (realpart/complex-double-float complex-float-value)
+ (:translate realpart)
+ (:args (x :scs (complex-double-reg complex-double-stack descriptor-reg)
+ :target r))
+ (:arg-types complex-double-float)
+ (:results (r :scs (double-reg)))
+ (:result-types double-float)
+ (:note "complex float realpart")
+ (:variant 0))
+
+#!+long-float
+(define-vop (realpart/complex-long-float complex-float-value)
+ (:translate realpart)
+ (:args (x :scs (complex-long-reg complex-long-stack descriptor-reg)
+ :target r))
+ (:arg-types complex-long-float)
+ (:results (r :scs (long-reg)))
+ (:result-types long-float)
+ (:note "complex float realpart")
+ (:variant 0))
+
+(define-vop (imagpart/complex-single-float complex-float-value)
+ (:translate imagpart)
+ (:args (x :scs (complex-single-reg complex-single-stack descriptor-reg)
+ :target r))
+ (:arg-types complex-single-float)
+ (:results (r :scs (single-reg)))
+ (:result-types single-float)
+ (:note "complex float imagpart")
+ (:variant 1))
+
+(define-vop (imagpart/complex-double-float complex-float-value)
+ (:translate imagpart)
+ (:args (x :scs (complex-double-reg complex-double-stack descriptor-reg)
+ :target r))
+ (:arg-types complex-double-float)
+ (:results (r :scs (double-reg)))
+ (:result-types double-float)
+ (:note "complex float imagpart")
+ (:variant 1))
+
+#!+long-float
+(define-vop (imagpart/complex-long-float complex-float-value)
+ (:translate imagpart)
+ (:args (x :scs (complex-long-reg complex-long-stack descriptor-reg)
+ :target r))
+ (:arg-types complex-long-float)
+ (:results (r :scs (long-reg)))
+ (:result-types long-float)
+ (:note "complex float imagpart")
+ (:variant 1))
+
+\f
+;;; A hack dummy VOP to bias the representation selection of its
+;;; argument towards a FP register which can help avoid consing at
+;;; inappropriate locations.
+
+(defknown double-float-reg-bias (double-float) (values))
+(define-vop (double-float-reg-bias)
+ (:translate double-float-reg-bias)
+ (:args (x :scs (double-reg double-stack) :load-if nil))
+ (:arg-types double-float)
+ (:policy :fast-safe)
+ (:note "inline dummy FP register bias")
+ (:ignore x)
+ (:generator 0))
+
+(defknown single-float-reg-bias (single-float) (values))
+(define-vop (single-float-reg-bias)
+ (:translate single-float-reg-bias)
+ (:args (x :scs (single-reg single-stack) :load-if nil))
+ (:arg-types single-float)
+ (:policy :fast-safe)
+ (:note "inline dummy FP register bias")
+ (:ignore x)
+ (:generator 0))
--- /dev/null
+;;;; that part of the description of the x86 instruction set (for
+;;;; 80386 and above) which can live on the cross-compilation host
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!VM")
+;;; FIXME: SB!DISASSEM: prefixes are used so widely in this file that
+;;; I wonder whether the separation of the disassembler from the
+;;; virtual machine is valid or adds value.
+
+(file-comment
+ "$Header$")
+
+;;; FIXME: In CMU CL, the code in this file seems to be fully
+;;; compiled, not byte compiled. I'm not sure that's reasonable:
+;;; there's a lot of code in this file, and considering the overall
+;;; speed of the compiler, having some byte-interpretation overhead
+;;; for every few bytes emitted doesn't seem likely to be noticeable.
+;;; I'd like to see what happens if I come back and byte-compile this
+;;; file.
+
+;;; Note: In CMU CL, this used to be a call to SET-DISASSEM-PARAMS.
+(setf sb!disassem:*disassem-inst-alignment-bytes* 1)
+
+(deftype reg () '(unsigned-byte 3))
+\f
+(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
+
+(defun offset-next (value dstate)
+ (declare (type integer value)
+ (type sb!disassem:disassem-state dstate))
+ (+ (sb!disassem:dstate-next-addr dstate) value))
+
+(defparameter *default-address-size*
+ ;; Actually, :DWORD is the only one really supported.
+ :dword)
+
+(defparameter *byte-reg-names*
+ #(al cl dl bl ah ch dh bh))
+(defparameter *word-reg-names*
+ #(ax cx dx bx sp bp si di))
+(defparameter *dword-reg-names*
+ #(eax ecx edx ebx esp ebp esi edi))
+
+(defun print-reg-with-width (value width stream dstate)
+ (declare (ignore dstate))
+ (princ (aref (ecase width
+ (:byte *byte-reg-names*)
+ (:word *word-reg-names*)
+ (:dword *dword-reg-names*))
+ value)
+ stream)
+ ;; XXX plus should do some source-var notes
+ )
+
+(defun print-reg (value stream dstate)
+ (declare (type reg value)
+ (type stream stream)
+ (type sb!disassem:disassem-state dstate))
+ (print-reg-with-width value
+ (sb!disassem:dstate-get-prop dstate 'width)
+ stream
+ dstate))
+
+(defun print-word-reg (value stream dstate)
+ (declare (type reg value)
+ (type stream stream)
+ (type sb!disassem:disassem-state dstate))
+ (print-reg-with-width value
+ (or (sb!disassem:dstate-get-prop dstate 'word-width)
+ +default-operand-size+)
+ stream
+ dstate))
+
+(defun print-byte-reg (value stream dstate)
+ (declare (type reg value)
+ (type stream stream)
+ (type sb!disassem:disassem-state dstate))
+ (print-reg-with-width value :byte stream dstate))
+
+(defun print-addr-reg (value stream dstate)
+ (declare (type reg value)
+ (type stream stream)
+ (type sb!disassem:disassem-state dstate))
+ (print-reg-with-width value *default-address-size* stream dstate))
+
+(defun print-reg/mem (value stream dstate)
+ (declare (type (or list reg) value)
+ (type stream stream)
+ (type sb!disassem:disassem-state dstate))
+ (if (typep value 'reg)
+ (print-reg value stream dstate)
+ (print-mem-access value stream nil dstate)))
+
+;; Same as print-reg/mem, but prints an explicit size indicator for
+;; memory references.
+(defun print-sized-reg/mem (value stream dstate)
+ (declare (type (or list reg) value)
+ (type stream stream)
+ (type sb!disassem:disassem-state dstate))
+ (if (typep value 'reg)
+ (print-reg value stream dstate)
+ (print-mem-access value stream t dstate)))
+
+(defun print-byte-reg/mem (value stream dstate)
+ (declare (type (or list reg) value)
+ (type stream stream)
+ (type sb!disassem:disassem-state dstate))
+ (if (typep value 'reg)
+ (print-byte-reg value stream dstate)
+ (print-mem-access value stream t dstate)))
+
+(defun print-label (value stream dstate)
+ (declare (ignore dstate))
+ (sb!disassem:princ16 value stream))
+
+;;; Returns either an integer, meaning a register, or a list of
+;;; (BASE-REG OFFSET INDEX-REG INDEX-SCALE), where any component
+;;; may be missing or nil to indicate that it's not used or has the
+;;; obvious default value (e.g., 1 for the index-scale).
+(defun prefilter-reg/mem (value dstate)
+ (declare (type list value)
+ (type sb!disassem:disassem-state dstate))
+ (let ((mod (car value))
+ (r/m (cadr value)))
+ (declare (type (unsigned-byte 2) mod)
+ (type (unsigned-byte 3) r/m))
+ (cond ((= mod #b11)
+ ;; registers
+ r/m)
+ ((= r/m #b100)
+ ;; sib byte
+ (let ((sib (sb!disassem:read-suffix 8 dstate)))
+ (declare (type (unsigned-byte 8) sib))
+ (let ((base-reg (ldb (byte 3 0) sib))
+ (index-reg (ldb (byte 3 3) sib))
+ (index-scale (ldb (byte 2 6) sib)))
+ (declare (type (unsigned-byte 3) base-reg index-reg)
+ (type (unsigned-byte 2) index-scale))
+ (let* ((offset
+ (case mod
+ (#b00
+ (if (= base-reg #b101)
+ (sb!disassem:read-signed-suffix 32 dstate)
+ nil))
+ (#b01
+ (sb!disassem:read-signed-suffix 8 dstate))
+ (#b10
+ (sb!disassem:read-signed-suffix 32 dstate)))))
+ (list (if (and (= mod #b00) (= base-reg #b101)) nil base-reg)
+ offset
+ (if (= index-reg #b100) nil index-reg)
+ (ash 1 index-scale))))))
+ ((and (= mod #b00) (= r/m #b101))
+ (list nil (sb!disassem:read-signed-suffix 32 dstate)) )
+ ((= mod #b00)
+ (list r/m))
+ ((= mod #b01)
+ (list r/m (sb!disassem:read-signed-suffix 8 dstate)))
+ (t ; (= mod #b10)
+ (list r/m (sb!disassem:read-signed-suffix 32 dstate))))))
+
+
+;;; This is a sort of bogus prefilter that just stores the info globally for
+;;; other people to use; it probably never gets printed.
+(defun prefilter-width (value dstate)
+ (setf (sb!disassem:dstate-get-prop dstate 'width)
+ (if (zerop value)
+ :byte
+ (let ((word-width
+ ;; set by a prefix instruction
+ (or (sb!disassem:dstate-get-prop dstate 'word-width)
+ +default-operand-size+)))
+ (when (not (eql word-width +default-operand-size+))
+ ;; Reset it.
+ (setf (sb!disassem:dstate-get-prop dstate 'word-width)
+ +default-operand-size+))
+ word-width))))
+
+(defun read-address (value dstate)
+ (declare (ignore value)) ; always nil anyway
+ (sb!disassem:read-suffix (width-bits *default-address-size*) dstate))
+
+(defun width-bits (width)
+ (ecase width
+ (:byte 8)
+ (:word 16)
+ (:dword 32)
+ (:float 32)
+ (:double 64)))
+
+) ; EVAL-WHEN
+\f
+;;;; disassembler argument types
+
+(sb!disassem:define-argument-type displacement
+ :sign-extend t
+ :use-label #'offset-next)
+
+(sb!disassem:define-argument-type accum
+ :printer #'(lambda (value stream dstate)
+ (declare (ignore value)
+ (type stream stream)
+ (type sb!disassem:disassem-state dstate))
+ (print-reg 0 stream dstate))
+ )
+
+(sb!disassem:define-argument-type word-accum
+ :printer #'(lambda (value stream dstate)
+ (declare (ignore value)
+ (type stream stream)
+ (type sb!disassem:disassem-state dstate))
+ (print-word-reg 0 stream dstate)))
+
+(sb!disassem:define-argument-type reg
+ :printer #'print-reg)
+
+(sb!disassem:define-argument-type addr-reg
+ :printer #'print-addr-reg)
+
+(sb!disassem:define-argument-type word-reg
+ :printer #'print-word-reg)
+
+(sb!disassem:define-argument-type imm-addr
+ :prefilter #'read-address
+ :printer #'print-label)
+
+(sb!disassem:define-argument-type imm-data
+ :prefilter #'(lambda (value dstate)
+ (declare (ignore value)) ; always nil anyway
+ (sb!disassem:read-suffix
+ (width-bits (sb!disassem:dstate-get-prop dstate 'width))
+ dstate))
+ )
+
+(sb!disassem:define-argument-type signed-imm-data
+ :prefilter #'(lambda (value dstate)
+ (declare (ignore value)) ; always nil anyway
+ (let ((width (sb!disassem:dstate-get-prop dstate 'width)))
+ (sb!disassem:read-signed-suffix (width-bits width) dstate)))
+ )
+
+(sb!disassem:define-argument-type signed-imm-byte
+ :prefilter #'(lambda (value dstate)
+ (declare (ignore value)) ; always nil anyway
+ (sb!disassem:read-signed-suffix 8 dstate)))
+
+(sb!disassem:define-argument-type signed-imm-dword
+ :prefilter #'(lambda (value dstate)
+ (declare (ignore value)) ; always nil anyway
+ (sb!disassem:read-signed-suffix 32 dstate)))
+
+(sb!disassem:define-argument-type imm-word
+ :prefilter #'(lambda (value dstate)
+ (declare (ignore value)) ; always nil anyway
+ (let ((width
+ (or (sb!disassem:dstate-get-prop dstate 'word-width)
+ +default-operand-size+)))
+ (sb!disassem:read-suffix (width-bits width) dstate))))
+
+;;; needed for the ret imm16 instruction
+(sb!disassem:define-argument-type imm-word-16
+ :prefilter #'(lambda (value dstate)
+ (declare (ignore value)) ; always nil anyway
+ (sb!disassem:read-suffix 16 dstate)))
+
+(sb!disassem:define-argument-type reg/mem
+ :prefilter #'prefilter-reg/mem
+ :printer #'print-reg/mem)
+(sb!disassem:define-argument-type sized-reg/mem
+ ;; Same as reg/mem, but prints an explicit size indicator for
+ ;; memory references.
+ :prefilter #'prefilter-reg/mem
+ :printer #'print-sized-reg/mem)
+(sb!disassem:define-argument-type byte-reg/mem
+ :prefilter #'prefilter-reg/mem
+ :printer #'print-byte-reg/mem)
+
+;;; added by jrd
+(eval-when (:compile-toplevel :load-toplevel :execute)
+(defun print-fp-reg (value stream dstate)
+ (declare (ignore dstate))
+ (format stream "FR~D" value))
+
+(defun prefilter-fp-reg (value dstate)
+ ;; just return it
+ (declare (ignore dstate))
+ value)
+)
+(sb!disassem:define-argument-type fp-reg
+ :prefilter #'prefilter-fp-reg
+ :printer #'print-fp-reg)
+
+(sb!disassem:define-argument-type width
+ :prefilter #'prefilter-width
+ :printer #'(lambda (value stream dstate)
+ (if ;; (zerop value)
+ (or (null value)
+ (and (numberp value) (zerop value))) ; zzz jrd
+ (princ 'b stream)
+ (let ((word-width
+ ;; set by a prefix instruction
+ (or (sb!disassem:dstate-get-prop dstate 'word-width)
+ +default-operand-size+)))
+ (princ (schar (symbol-name word-width) 0) stream)))))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+(defconstant conditions
+ '((:o . 0)
+ (:no . 1)
+ (:b . 2) (:nae . 2) (:c . 2)
+ (:nb . 3) (:ae . 3) (:nc . 3)
+ (:eq . 4) (:e . 4) (:z . 4)
+ (:ne . 5) (:nz . 5)
+ (:be . 6) (:na . 6)
+ (:nbe . 7) (:a . 7)
+ (:s . 8)
+ (:ns . 9)
+ (:p . 10) (:pe . 10)
+ (:np . 11) (:po . 11)
+ (:l . 12) (:nge . 12)
+ (:nl . 13) (:ge . 13)
+ (:le . 14) (:ng . 14)
+ (:nle . 15) (:g . 15)))
+
+(defparameter *condition-name-vec*
+ (let ((vec (make-array 16 :initial-element nil)))
+ (dolist (cond conditions)
+ (when (null (aref vec (cdr cond)))
+ (setf (aref vec (cdr cond)) (car cond))))
+ vec))
+);EVAL-WHEN
+
+;;; Set assembler parameters. (In CMU CL, this was done with
+;;; a call to a macro DEF-ASSEMBLER-PARAMS.)
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (setf sb!assem:*assem-scheduler-p* nil))
+
+(sb!disassem:define-argument-type condition-code
+ :printer *condition-name-vec*)
+
+(defun conditional-opcode (condition)
+ (cdr (assoc condition conditions :test #'eq)))
+\f
+;;;; disassembler instruction formats
+
+(eval-when (:compile-toplevel :execute)
+ (defun swap-if (direction field1 separator field2)
+ `(:if (,direction :constant 0)
+ (,field1 ,separator ,field2)
+ (,field2 ,separator ,field1))))
+
+(sb!disassem:define-instruction-format (byte 8 :default-printer '(:name))
+ (op :field (byte 8 0))
+ ;; optional fields
+ (accum :type 'accum)
+ (imm))
+
+(sb!disassem:define-instruction-format (simple 8)
+ (op :field (byte 7 1))
+ (width :field (byte 1 0) :type 'width)
+ ;; optional fields
+ (accum :type 'accum)
+ (imm))
+
+;;; Same as simple, but with direction bit
+(sb!disassem:define-instruction-format (simple-dir 8 :include 'simple)
+ (op :field (byte 6 2))
+ (dir :field (byte 1 1)))
+
+;;; Same as simple, but with the immediate value occurring by default,
+;;; and with an appropiate printer.
+(sb!disassem:define-instruction-format (accum-imm 8
+ :include 'simple
+ :default-printer '(:name
+ :tab accum ", " imm))
+ (imm :type 'imm-data))
+
+(sb!disassem:define-instruction-format (reg-no-width 8
+ :default-printer '(:name :tab reg))
+ (op :field (byte 5 3))
+ (reg :field (byte 3 0) :type 'word-reg)
+ ;; optional fields
+ (accum :type 'word-accum)
+ (imm))
+
+;;; adds a width field to reg-no-width
+(sb!disassem:define-instruction-format (reg 8
+ :default-printer '(:name :tab reg))
+ (op :field (byte 4 4))
+ (width :field (byte 1 3) :type 'width)
+ (reg :field (byte 3 0) :type 'reg)
+ ;; optional fields
+ (accum :type 'accum)
+ (imm)
+ )
+
+;;; Same as reg, but with direction bit
+(sb!disassem:define-instruction-format (reg-dir 8 :include 'reg)
+ (op :field (byte 3 5))
+ (dir :field (byte 1 4)))
+
+(sb!disassem:define-instruction-format (two-bytes 16
+ :default-printer '(:name))
+ (op :fields (list (byte 8 0) (byte 8 8))))
+
+(sb!disassem:define-instruction-format (reg-reg/mem 16
+ :default-printer
+ `(:name :tab reg ", " reg/mem))
+ (op :field (byte 7 1))
+ (width :field (byte 1 0) :type 'width)
+ (reg/mem :fields (list (byte 2 14) (byte 3 8))
+ :type 'reg/mem)
+ (reg :field (byte 3 11) :type 'reg)
+ ;; optional fields
+ (imm))
+
+;;; same as reg-reg/mem, but with direction bit
+(sb!disassem:define-instruction-format (reg-reg/mem-dir 16
+ :include 'reg-reg/mem
+ :default-printer
+ `(:name
+ :tab
+ ,(swap-if 'dir 'reg/mem ", " 'reg)))
+ (op :field (byte 6 2))
+ (dir :field (byte 1 1)))
+
+;;; Same as reg-rem/mem, but uses the reg field as a second op code.
+(sb!disassem:define-instruction-format (reg/mem 16
+ :default-printer '(:name :tab reg/mem))
+ (op :fields (list (byte 7 1) (byte 3 11)))
+ (width :field (byte 1 0) :type 'width)
+ (reg/mem :fields (list (byte 2 14) (byte 3 8))
+ :type 'sized-reg/mem)
+ ;; optional fields
+ (imm))
+
+;;; Same as reg/mem, but with the immediate value occurring by default,
+;;; and with an appropiate printer.
+(sb!disassem:define-instruction-format (reg/mem-imm 16
+ :include 'reg/mem
+ :default-printer
+ '(:name :tab reg/mem ", " imm))
+ (reg/mem :type 'sized-reg/mem)
+ (imm :type 'imm-data))
+
+;;; Same as reg/mem, but with using the accumulator in the default printer
+(sb!disassem:define-instruction-format
+ (accum-reg/mem 16
+ :include 'reg/mem :default-printer '(:name :tab accum ", " reg/mem))
+ (reg/mem :type 'reg/mem) ; don't need a size
+ (accum :type 'accum))
+
+;;; Same as reg-reg/mem, but with a prefix of #b00001111
+(sb!disassem:define-instruction-format (ext-reg-reg/mem 24
+ :default-printer
+ `(:name :tab reg ", " reg/mem))
+ (prefix :field (byte 8 0) :value #b00001111)
+ (op :field (byte 7 9))
+ (width :field (byte 1 8) :type 'width)
+ (reg/mem :fields (list (byte 2 22) (byte 3 16))
+ :type 'reg/mem)
+ (reg :field (byte 3 19) :type 'reg)
+ ;; optional fields
+ (imm))
+
+;;; Same as reg/mem, but with a prefix of #b00001111
+(sb!disassem:define-instruction-format (ext-reg/mem 24
+ :default-printer '(:name :tab reg/mem))
+ (prefix :field (byte 8 0) :value #b00001111)
+ (op :fields (list (byte 7 9) (byte 3 19)))
+ (width :field (byte 1 8) :type 'width)
+ (reg/mem :fields (list (byte 2 22) (byte 3 16))
+ :type 'sized-reg/mem)
+ ;; optional fields
+ (imm))
+\f
+;;;; This section was added by jrd, for fp instructions.
+
+;;; regular fp inst to/from registers/memory
+(sb!disassem:define-instruction-format (floating-point 16
+ :default-printer
+ `(:name :tab reg/mem))
+ (prefix :field (byte 5 3) :value #b11011)
+ (op :fields (list (byte 3 0) (byte 3 11)))
+ (reg/mem :fields (list (byte 2 14) (byte 3 8)) :type 'reg/mem))
+
+;;; fp insn to/from fp reg
+(sb!disassem:define-instruction-format (floating-point-fp 16
+ :default-printer `(:name :tab fp-reg))
+ (prefix :field (byte 5 3) :value #b11011)
+ (suffix :field (byte 2 14) :value #b11)
+ (op :fields (list (byte 3 0) (byte 3 11)))
+ (fp-reg :field (byte 3 8) :type 'fp-reg))
+
+;;; fp insn to/from fp reg, with the reversed source/destination flag.
+(sb!disassem:define-instruction-format
+ (floating-point-fp-d 16
+ :default-printer `(:name :tab ,(swap-if 'd "ST0" ", " 'fp-reg)))
+ (prefix :field (byte 5 3) :value #b11011)
+ (suffix :field (byte 2 14) :value #b11)
+ (op :fields (list (byte 2 0) (byte 3 11)))
+ (d :field (byte 1 2))
+ (fp-reg :field (byte 3 8) :type 'fp-reg))
+
+
+;;; (added by (?) pfw)
+;;; fp no operand isns
+(sb!disassem:define-instruction-format (floating-point-no 16
+ :default-printer '(:name))
+ (prefix :field (byte 8 0) :value #b11011001)
+ (suffix :field (byte 3 13) :value #b111)
+ (op :field (byte 5 8)))
+
+(sb!disassem:define-instruction-format (floating-point-3 16
+ :default-printer '(:name))
+ (prefix :field (byte 5 3) :value #b11011)
+ (suffix :field (byte 2 14) :value #b11)
+ (op :fields (list (byte 3 0) (byte 6 8))))
+
+(sb!disassem:define-instruction-format (floating-point-5 16
+ :default-printer '(:name))
+ (prefix :field (byte 8 0) :value #b11011011)
+ (suffix :field (byte 3 13) :value #b111)
+ (op :field (byte 5 8)))
+
+(sb!disassem:define-instruction-format (floating-point-st 16
+ :default-printer '(:name))
+ (prefix :field (byte 8 0) :value #b11011111)
+ (suffix :field (byte 3 13) :value #b111)
+ (op :field (byte 5 8)))
+
+(sb!disassem:define-instruction-format (string-op 8
+ :include 'simple
+ :default-printer '(:name width)))
+
+(sb!disassem:define-instruction-format (short-cond-jump 16)
+ (op :field (byte 4 4))
+ (cc :field (byte 4 0) :type 'condition-code)
+ (label :field (byte 8 8) :type 'displacement))
+
+(sb!disassem:define-instruction-format (short-jump 16
+ :default-printer '(:name :tab label))
+ (const :field (byte 4 4) :value #b1110)
+ (op :field (byte 4 0))
+ (label :field (byte 8 8) :type 'displacement))
+
+(sb!disassem:define-instruction-format (near-cond-jump 16)
+ (op :fields (list (byte 8 0) (byte 4 12)) :value '(#b00001111 #b1000))
+ (cc :field (byte 4 8) :type 'condition-code)
+ ;; The disassembler currently doesn't let you have an instruction > 32 bits
+ ;; long, so we fake it by using a prefilter to read the offset.
+ (label :type 'displacement
+ :prefilter #'(lambda (value dstate)
+ (declare (ignore value)) ; always nil anyway
+ (sb!disassem:read-signed-suffix 32 dstate))))
+
+(sb!disassem:define-instruction-format (near-jump 8
+ :default-printer '(:name :tab label))
+ (op :field (byte 8 0))
+ ;; The disassembler currently doesn't let you have an instruction > 32 bits
+ ;; long, so we fake it by using a prefilter to read the address.
+ (label :type 'displacement
+ :prefilter #'(lambda (value dstate)
+ (declare (ignore value)) ; always nil anyway
+ (sb!disassem:read-signed-suffix 32 dstate))))
+
+
+(sb!disassem:define-instruction-format (cond-set 24
+ :default-printer '('set cc :tab reg/mem))
+ (prefix :field (byte 8 0) :value #b00001111)
+ (op :field (byte 4 12) :value #b1001)
+ (cc :field (byte 4 8) :type 'condition-code)
+ (reg/mem :fields (list (byte 2 22) (byte 3 16))
+ :type 'byte-reg/mem)
+ (reg :field (byte 3 19) :value #b000))
+
+(sb!disassem:define-instruction-format (enter-format 32
+ :default-printer '(:name
+ :tab disp
+ (:unless (:constant 0)
+ ", " level)))
+ (op :field (byte 8 0))
+ (disp :field (byte 16 8))
+ (level :field (byte 8 24)))
+
+;;; Single byte instruction with an immediate byte argument.
+(sb!disassem:define-instruction-format (byte-imm 16
+ :default-printer '(:name :tab code))
+ (op :field (byte 8 0))
+ (code :field (byte 8 8)))
+\f
+;;;; primitive emitters
+
+(define-bitfield-emitter emit-word 16
+ (byte 16 0))
+
+(define-bitfield-emitter emit-dword 32
+ (byte 32 0))
+
+(define-bitfield-emitter emit-byte-with-reg 8
+ (byte 5 3) (byte 3 0))
+
+(define-bitfield-emitter emit-mod-reg-r/m-byte 8
+ (byte 2 6) (byte 3 3) (byte 3 0))
+
+(define-bitfield-emitter emit-sib-byte 8
+ (byte 2 6) (byte 3 3) (byte 3 0))
+\f
+;;;; fixup emitters
+
+(defun emit-absolute-fixup (segment fixup)
+ (note-fixup segment :absolute fixup)
+ (let ((offset (fixup-offset fixup)))
+ (if (label-p offset)
+ (emit-back-patch segment
+ 4 ; FIXME: sb!vm:word-bytes
+ #'(lambda (segment posn)
+ (declare (ignore posn))
+ (emit-dword segment
+ (- (+ (component-header-length)
+ (or (label-position offset)
+ 0))
+ other-pointer-type))))
+ (emit-dword segment (or offset 0)))))
+
+(defun emit-relative-fixup (segment fixup)
+ (note-fixup segment :relative fixup)
+ (emit-dword segment (or (fixup-offset fixup) 0)))
+\f
+;;;; the effective-address (ea) structure
+
+(defun reg-tn-encoding (tn)
+ (declare (type tn tn))
+ (assert (eq (sb-name (sc-sb (tn-sc tn))) 'registers))
+ (let ((offset (tn-offset tn)))
+ (logior (ash (logand offset 1) 2)
+ (ash offset -1))))
+
+(defstruct (ea (:constructor make-ea (size &key base index scale disp)))
+ (size nil :type (member :byte :word :dword))
+ (base nil :type (or tn null))
+ (index nil :type (or tn null))
+ (scale 1 :type (member 1 2 4 8))
+ (disp 0 :type (or (signed-byte 32) fixup)))
+(def!method print-object ((ea ea) stream)
+ (cond ((or *print-escape* *print-readably*)
+ (print-unreadable-object (ea stream :type t)
+ (format stream
+ "~S~@[ base=~S~]~@[ index=~S~]~@[ scale=~S~]~@[ disp=~S~]"
+ (ea-size ea)
+ (ea-base ea)
+ (ea-index ea)
+ (let ((scale (ea-scale ea)))
+ (if (= scale 1) nil scale))
+ (ea-disp ea))))
+ (t
+ (format stream "~A PTR [" (symbol-name (ea-size ea)))
+ (when (ea-base ea)
+ (write-string (x86-location-print-name (ea-base ea)) stream)
+ (when (ea-index ea)
+ (write-string "+" stream)))
+ (when (ea-index ea)
+ (write-string (x86-location-print-name (ea-index ea)) stream))
+ (unless (= (ea-scale ea) 1)
+ (format stream "*~A" (ea-scale ea)))
+ (typecase (ea-disp ea)
+ (null)
+ (integer
+ (format stream "~@D" (ea-disp ea)))
+ (t
+ (format stream "+~A" (ea-disp ea))))
+ (write-char #\] stream))))
+
+(defun emit-ea (segment thing reg &optional allow-constants)
+ (etypecase thing
+ (tn
+ (ecase (sb-name (sc-sb (tn-sc thing)))
+ (registers
+ (emit-mod-reg-r/m-byte segment #b11 reg (reg-tn-encoding thing)))
+ (stack
+ ;; Convert stack tns into an index off of EBP.
+ (let ((disp (- (* (1+ (tn-offset thing)) word-bytes))))
+ (cond ((< -128 disp 127)
+ (emit-mod-reg-r/m-byte segment #b01 reg #b101)
+ (emit-byte segment disp))
+ (t
+ (emit-mod-reg-r/m-byte segment #b10 reg #b101)
+ (emit-dword segment disp)))))
+ (constant
+ (unless allow-constants
+ (error
+ "Constant TNs can only be directly used in MOV, PUSH, and CMP."))
+ (emit-mod-reg-r/m-byte segment #b00 reg #b101)
+ (emit-absolute-fixup segment
+ (make-fixup nil
+ :code-object
+ (- (* (tn-offset thing) word-bytes)
+ other-pointer-type))))))
+ (ea
+ (let* ((base (ea-base thing))
+ (index (ea-index thing))
+ (scale (ea-scale thing))
+ (disp (ea-disp thing))
+ (mod (cond ((or (null base)
+ (and (eql disp 0)
+ (not (= (reg-tn-encoding base) #b101))))
+ #b00)
+ ((and (target-fixnump disp) (<= -128 disp 127))
+ #b01)
+ (t
+ #b10)))
+ (r/m (cond (index #b100)
+ ((null base) #b101)
+ (t (reg-tn-encoding base)))))
+ (emit-mod-reg-r/m-byte segment mod reg r/m)
+ (when (= r/m #b100)
+ (let ((ss (1- (integer-length scale)))
+ (index (if (null index)
+ #b100
+ (let ((index (reg-tn-encoding index)))
+ (if (= index #b100)
+ (error "can't index off of ESP")
+ index))))
+ (base (if (null base)
+ #b101
+ (reg-tn-encoding base))))
+ (emit-sib-byte segment ss index base)))
+ (cond ((= mod #b01)
+ (emit-byte segment disp))
+ ((or (= mod #b10) (null base))
+ (if (fixup-p disp)
+ (emit-absolute-fixup segment disp)
+ (emit-dword segment disp))))))
+ (fixup
+ (emit-mod-reg-r/m-byte segment #b00 reg #b101)
+ (emit-absolute-fixup segment thing))))
+
+(defun fp-reg-tn-p (thing)
+ (and (tn-p thing)
+ (eq (sb-name (sc-sb (tn-sc thing))) 'float-registers)))
+
+;;; like the above, but for fp-instructions--jrd
+(defun emit-fp-op (segment thing op)
+ (if (fp-reg-tn-p thing)
+ (emit-byte segment (dpb op (byte 3 3) (dpb (tn-offset thing)
+ (byte 3 0)
+ #b11000000)))
+ (emit-ea segment thing op)))
+
+(defun byte-reg-p (thing)
+ (and (tn-p thing)
+ (eq (sb-name (sc-sb (tn-sc thing))) 'registers)
+ (member (sc-name (tn-sc thing)) byte-sc-names)
+ t))
+
+(defun byte-ea-p (thing)
+ (typecase thing
+ (ea (eq (ea-size thing) :byte))
+ (tn
+ (and (member (sc-name (tn-sc thing)) byte-sc-names) t))
+ (t nil)))
+
+(defun word-reg-p (thing)
+ (and (tn-p thing)
+ (eq (sb-name (sc-sb (tn-sc thing))) 'registers)
+ (member (sc-name (tn-sc thing)) word-sc-names)
+ t))
+
+(defun word-ea-p (thing)
+ (typecase thing
+ (ea (eq (ea-size thing) :word))
+ (tn (and (member (sc-name (tn-sc thing)) word-sc-names) t))
+ (t nil)))
+
+(defun dword-reg-p (thing)
+ (and (tn-p thing)
+ (eq (sb-name (sc-sb (tn-sc thing))) 'registers)
+ (member (sc-name (tn-sc thing)) dword-sc-names)
+ t))
+
+(defun dword-ea-p (thing)
+ (typecase thing
+ (ea (eq (ea-size thing) :dword))
+ (tn
+ (and (member (sc-name (tn-sc thing)) dword-sc-names) t))
+ (t nil)))
+
+(defun register-p (thing)
+ (and (tn-p thing)
+ (eq (sb-name (sc-sb (tn-sc thing))) 'registers)))
+
+(defun accumulator-p (thing)
+ (and (register-p thing)
+ (= (tn-offset thing) 0)))
+\f
+;;;; utilities
+
+(defconstant +operand-size-prefix-byte+ #b01100110)
+
+(defconstant +default-operand-size+ :dword)
+
+(defun maybe-emit-operand-size-prefix (segment size)
+ (unless (or (eq size :byte) (eq size +default-operand-size+))
+ (emit-byte segment +operand-size-prefix-byte+)))
+
+(defun operand-size (thing)
+ (typecase thing
+ (tn
+ (case (sc-name (tn-sc thing))
+ (#.dword-sc-names
+ :dword)
+ (#.word-sc-names
+ :word)
+ (#.byte-sc-names
+ :byte)
+ ;; added by jrd. float-registers is a separate size (?)
+ (#.float-sc-names
+ :float)
+ (#.double-sc-names
+ :double)
+ (t
+ (error "can't tell the size of ~S ~S" thing (sc-name (tn-sc thing))))))
+ (ea
+ (ea-size thing))
+ (t
+ nil)))
+
+(defun matching-operand-size (dst src)
+ (let ((dst-size (operand-size dst))
+ (src-size (operand-size src)))
+ (if dst-size
+ (if src-size
+ (if (eq dst-size src-size)
+ dst-size
+ (error "size mismatch: ~S is a ~S and ~S is a ~S."
+ dst dst-size src src-size))
+ dst-size)
+ (if src-size
+ src-size
+ (error "can't tell the size of either ~S or ~S" dst src)))))
+
+(defun emit-sized-immediate (segment size value)
+ (ecase size
+ (:byte
+ (emit-byte segment value))
+ (:word
+ (emit-word segment value))
+ (:dword
+ (emit-dword segment value))))
+\f
+;;;; general data transfer
+
+(define-instruction mov (segment dst src)
+ ;; immediate to register
+ (:printer reg ((op #b1011) (imm nil :type 'imm-data))
+ '(:name :tab reg ", " imm))
+ ;; absolute mem to/from accumulator
+ (:printer simple-dir ((op #b101000) (imm nil :type 'imm-addr))
+ `(:name :tab ,(swap-if 'dir 'accum ", " '("[" imm "]"))))
+ ;; register to/from register/memory
+ (:printer reg-reg/mem-dir ((op #b100010)))
+ ;; immediate to register/memory
+ (:printer reg/mem-imm ((op '(#b1100011 #b000))))
+
+ (:emitter
+ (let ((size (matching-operand-size dst src)))
+ (maybe-emit-operand-size-prefix segment size)
+ (cond ((register-p dst)
+ (cond ((integerp src)
+ (emit-byte-with-reg segment
+ (if (eq size :byte)
+ #b10110
+ #b10111)
+ (reg-tn-encoding dst))
+ (emit-sized-immediate segment size src))
+ ((and (fixup-p src) (accumulator-p dst))
+ (emit-byte segment
+ (if (eq size :byte)
+ #b10100000
+ #b10100001))
+ (emit-absolute-fixup segment src))
+ (t
+ (emit-byte segment
+ (if (eq size :byte)
+ #b10001010
+ #b10001011))
+ (emit-ea segment src (reg-tn-encoding dst) t))))
+ ((and (fixup-p dst) (accumulator-p src))
+ (emit-byte segment (if (eq size :byte) #b10100010 #b10100011))
+ (emit-absolute-fixup segment dst))
+ ((integerp src)
+ (emit-byte segment (if (eq size :byte) #b11000110 #b11000111))
+ (emit-ea segment dst #b000)
+ (emit-sized-immediate segment size src))
+ ((register-p src)
+ (emit-byte segment (if (eq size :byte) #b10001000 #b10001001))
+ (emit-ea segment dst (reg-tn-encoding src)))
+ ((fixup-p src)
+ (assert (eq size :dword))
+ (emit-byte segment #b11000111)
+ (emit-ea segment dst #b000)
+ (emit-absolute-fixup segment src))
+ (t
+ (error "bogus arguments to MOV: ~S ~S" dst src))))))
+
+(defun emit-move-with-extension (segment dst src opcode)
+ (assert (register-p dst))
+ (let ((dst-size (operand-size dst))
+ (src-size (operand-size src)))
+ (ecase dst-size
+ (:word
+ (assert (eq src-size :byte))
+ (maybe-emit-operand-size-prefix segment :word)
+ (emit-byte segment #b00001111)
+ (emit-byte segment opcode)
+ (emit-ea segment src (reg-tn-encoding dst)))
+ (:dword
+ (ecase src-size
+ (:byte
+ (maybe-emit-operand-size-prefix segment :dword)
+ (emit-byte segment #b00001111)
+ (emit-byte segment opcode)
+ (emit-ea segment src (reg-tn-encoding dst)))
+ (:word
+ (emit-byte segment #b00001111)
+ (emit-byte segment (logior opcode 1))
+ (emit-ea segment src (reg-tn-encoding dst))))))))
+
+(define-instruction movsx (segment dst src)
+ (:printer ext-reg-reg/mem ((op #b1011111) (reg nil :type 'word-reg)))
+ (:emitter (emit-move-with-extension segment dst src #b10111110)))
+
+(define-instruction movzx (segment dst src)
+ (:printer ext-reg-reg/mem ((op #b1011011) (reg nil :type 'word-reg)))
+ (:emitter (emit-move-with-extension segment dst src #b10110110)))
+
+(define-instruction push (segment src)
+ ;; register
+ (:printer reg-no-width ((op #b01010)))
+ ;; register/memory
+ (:printer reg/mem ((op '(#b1111111 #b110)) (width 1)))
+ ;; immediate
+ (:printer byte ((op #b01101010) (imm nil :type 'signed-imm-byte))
+ '(:name :tab imm))
+ (:printer byte ((op #b01101000) (imm nil :type 'imm-word))
+ '(:name :tab imm))
+ ;; ### segment registers?
+
+ (:emitter
+ (cond ((integerp src)
+ (cond ((<= -128 src 127)
+ (emit-byte segment #b01101010)
+ (emit-byte segment src))
+ (t
+ (emit-byte segment #b01101000)
+ (emit-dword segment src))))
+ ((fixup-p src)
+ ;; Interpret the fixup as an immediate dword to push.
+ (emit-byte segment #b01101000)
+ (emit-absolute-fixup segment src))
+ (t
+ (let ((size (operand-size src)))
+ (assert (not (eq size :byte)))
+ (maybe-emit-operand-size-prefix segment size)
+ (cond ((register-p src)
+ (emit-byte-with-reg segment #b01010 (reg-tn-encoding src)))
+ (t
+ (emit-byte segment #b11111111)
+ (emit-ea segment src #b110 t))))))))
+
+(define-instruction pusha (segment)
+ (:printer byte ((op #b01100000)))
+ (:emitter
+ (emit-byte segment #b01100000)))
+
+(define-instruction pop (segment dst)
+ (:printer reg-no-width ((op #b01011)))
+ (:printer reg/mem ((op '(#b1000111 #b000)) (width 1)))
+ (:emitter
+ (let ((size (operand-size dst)))
+ (assert (not (eq size :byte)))
+ (maybe-emit-operand-size-prefix segment size)
+ (cond ((register-p dst)
+ (emit-byte-with-reg segment #b01011 (reg-tn-encoding dst)))
+ (t
+ (emit-byte segment #b10001111)
+ (emit-ea segment dst #b000))))))
+
+(define-instruction popa (segment)
+ (:printer byte ((op #b01100001)))
+ (:emitter
+ (emit-byte segment #b01100001)))
+
+(define-instruction xchg (segment operand1 operand2)
+ ;; Register with accumulator.
+ (:printer reg-no-width ((op #b10010)) '(:name :tab accum ", " reg))
+ ;; Register/Memory with Register.
+ (:printer reg-reg/mem ((op #b1000011)))
+ (:emitter
+ (let ((size (matching-operand-size operand1 operand2)))
+ (maybe-emit-operand-size-prefix segment size)
+ (labels ((xchg-acc-with-something (acc something)
+ (if (and (not (eq size :byte)) (register-p something))
+ (emit-byte-with-reg segment
+ #b10010
+ (reg-tn-encoding something))
+ (xchg-reg-with-something acc something)))
+ (xchg-reg-with-something (reg something)
+ (emit-byte segment (if (eq size :byte) #b10000110 #b10000111))
+ (emit-ea segment something (reg-tn-encoding reg))))
+ (cond ((accumulator-p operand1)
+ (xchg-acc-with-something operand1 operand2))
+ ((accumulator-p operand2)
+ (xchg-acc-with-something operand2 operand1))
+ ((register-p operand1)
+ (xchg-reg-with-something operand1 operand2))
+ ((register-p operand2)
+ (xchg-reg-with-something operand2 operand1))
+ (t
+ (error "bogus args to XCHG: ~S ~S" operand1 operand2)))))))
+
+(define-instruction lea (segment dst src)
+ (:printer reg-reg/mem ((op #b1000110) (width 1)))
+ (:emitter
+ (assert (dword-reg-p dst))
+ (emit-byte segment #b10001101)
+ (emit-ea segment src (reg-tn-encoding dst))))
+
+(define-instruction cmpxchg (segment dst src)
+ ;; Register/Memory with Register.
+ (:printer ext-reg-reg/mem ((op #b1011000)) '(:name :tab reg/mem ", " reg))
+ (:emitter
+ (assert (register-p src))
+ (let ((size (matching-operand-size src dst)))
+ (maybe-emit-operand-size-prefix segment size)
+ (emit-byte segment #b00001111)
+ (emit-byte segment (if (eq size :byte) #b10110000 #b10110001))
+ (emit-ea segment dst (reg-tn-encoding src)))))
+
+\f
+;;;; flag control instructions
+
+;;; CLC -- Clear Carry Flag.
+(define-instruction clc (segment)
+ (:printer byte ((op #b11111000)))
+ (:emitter
+ (emit-byte segment #b11111000)))
+
+;;; CLD -- Clear Direction Flag.
+(define-instruction cld (segment)
+ (:printer byte ((op #b11111100)))
+ (:emitter
+ (emit-byte segment #b11111100)))
+
+;;; CLI -- Clear Iterrupt Enable Flag.
+(define-instruction cli (segment)
+ (:printer byte ((op #b11111010)))
+ (:emitter
+ (emit-byte segment #b11111010)))
+
+;;; CMC -- Complement Carry Flag.
+(define-instruction cmc (segment)
+ (:printer byte ((op #b11110101)))
+ (:emitter
+ (emit-byte segment #b11110101)))
+
+;;; LAHF -- Load AH into flags.
+(define-instruction lahf (segment)
+ (:printer byte ((op #b10011111)))
+ (:emitter
+ (emit-byte segment #b10011111)))
+
+;;; POPF -- Pop flags.
+(define-instruction popf (segment)
+ (:printer byte ((op #b10011101)))
+ (:emitter
+ (emit-byte segment #b10011101)))
+
+;;; PUSHF -- push flags.
+(define-instruction pushf (segment)
+ (:printer byte ((op #b10011100)))
+ (:emitter
+ (emit-byte segment #b10011100)))
+
+;;; SAHF -- Store AH into flags.
+(define-instruction sahf (segment)
+ (:printer byte ((op #b10011110)))
+ (:emitter
+ (emit-byte segment #b10011110)))
+
+;;; STC -- Set Carry Flag.
+(define-instruction stc (segment)
+ (:printer byte ((op #b11111001)))
+ (:emitter
+ (emit-byte segment #b11111001)))
+
+;;; STD -- Set Direction Flag.
+(define-instruction std (segment)
+ (:printer byte ((op #b11111101)))
+ (:emitter
+ (emit-byte segment #b11111101)))
+
+;;; STI -- Set Interrupt Enable Flag.
+(define-instruction sti (segment)
+ (:printer byte ((op #b11111011)))
+ (:emitter
+ (emit-byte segment #b11111011)))
+\f
+;;;; arithmetic
+
+(defun emit-random-arith-inst (name segment dst src opcode
+ &optional allow-constants)
+ (let ((size (matching-operand-size dst src)))
+ (maybe-emit-operand-size-prefix segment size)
+ (cond
+ ((integerp src)
+ (cond ((and (not (eq size :byte)) (<= -128 src 127))
+ (emit-byte segment #b10000011)
+ (emit-ea segment dst opcode)
+ (emit-byte segment src))
+ ((accumulator-p dst)
+ (emit-byte segment
+ (dpb opcode
+ (byte 3 3)
+ (if (eq size :byte)
+ #b00000100
+ #b00000101)))
+ (emit-sized-immediate segment size src))
+ (t
+ (emit-byte segment (if (eq size :byte) #b10000000 #b10000001))
+ (emit-ea segment dst opcode)
+ (emit-sized-immediate segment size src))))
+ ((register-p src)
+ (emit-byte segment
+ (dpb opcode
+ (byte 3 3)
+ (if (eq size :byte) #b00000000 #b00000001)))
+ (emit-ea segment dst (reg-tn-encoding src) allow-constants))
+ ((register-p dst)
+ (emit-byte segment
+ (dpb opcode
+ (byte 3 3)
+ (if (eq size :byte) #b00000010 #b00000011)))
+ (emit-ea segment src (reg-tn-encoding dst) allow-constants))
+ (t
+ (error "bogus operands to ~A" name)))))
+
+(eval-when (:compile-toplevel :execute)
+ (defun arith-inst-printer-list (subop)
+ `((accum-imm ((op ,(dpb subop (byte 3 2) #b0000010))))
+ (reg/mem-imm ((op (#b1000000 ,subop))))
+ (reg/mem-imm ((op (#b1000001 ,subop))
+ (imm nil :type signed-imm-byte)))
+ (reg-reg/mem-dir ((op ,(dpb subop (byte 3 1) #b000000))))))
+ )
+
+(define-instruction add (segment dst src)
+ (:printer-list (arith-inst-printer-list #b000))
+ (:emitter (emit-random-arith-inst "ADD" segment dst src #b000)))
+
+(define-instruction adc (segment dst src)
+ (:printer-list (arith-inst-printer-list #b010))
+ (:emitter (emit-random-arith-inst "ADC" segment dst src #b010)))
+
+(define-instruction sub (segment dst src)
+ (:printer-list (arith-inst-printer-list #b101))
+ (:emitter (emit-random-arith-inst "SUB" segment dst src #b101)))
+
+(define-instruction sbb (segment dst src)
+ (:printer-list (arith-inst-printer-list #b011))
+ (:emitter (emit-random-arith-inst "SBB" segment dst src #b011)))
+
+(define-instruction cmp (segment dst src)
+ (:printer-list (arith-inst-printer-list #b111))
+ (:emitter (emit-random-arith-inst "CMP" segment dst src #b111 t)))
+
+(define-instruction inc (segment dst)
+ ;; Register.
+ (:printer reg-no-width ((op #b01000)))
+ ;; Register/Memory
+ (:printer reg/mem ((op '(#b1111111 #b000))))
+ (:emitter
+ (let ((size (operand-size dst)))
+ (maybe-emit-operand-size-prefix segment size)
+ (cond ((and (not (eq size :byte)) (register-p dst))
+ (emit-byte-with-reg segment #b01000 (reg-tn-encoding dst)))
+ (t
+ (emit-byte segment (if (eq size :byte) #b11111110 #b11111111))
+ (emit-ea segment dst #b000))))))
+
+(define-instruction dec (segment dst)
+ ;; Register.
+ (:printer reg-no-width ((op #b01001)))
+ ;; Register/Memory
+ (:printer reg/mem ((op '(#b1111111 #b001))))
+ (:emitter
+ (let ((size (operand-size dst)))
+ (maybe-emit-operand-size-prefix segment size)
+ (cond ((and (not (eq size :byte)) (register-p dst))
+ (emit-byte-with-reg segment #b01001 (reg-tn-encoding dst)))
+ (t
+ (emit-byte segment (if (eq size :byte) #b11111110 #b11111111))
+ (emit-ea segment dst #b001))))))
+
+(define-instruction neg (segment dst)
+ (:printer reg/mem ((op '(#b1111011 #b011))))
+ (:emitter
+ (let ((size (operand-size dst)))
+ (maybe-emit-operand-size-prefix segment size)
+ (emit-byte segment (if (eq size :byte) #b11110110 #b11110111))
+ (emit-ea segment dst #b011))))
+
+(define-instruction aaa (segment)
+ (:printer byte ((op #b00110111)))
+ (:emitter
+ (emit-byte segment #b00110111)))
+
+(define-instruction aas (segment)
+ (:printer byte ((op #b00111111)))
+ (:emitter
+ (emit-byte segment #b00111111)))
+
+(define-instruction daa (segment)
+ (:printer byte ((op #b00100111)))
+ (:emitter
+ (emit-byte segment #b00100111)))
+
+(define-instruction das (segment)
+ (:printer byte ((op #b00101111)))
+ (:emitter
+ (emit-byte segment #b00101111)))
+
+(define-instruction mul (segment dst src)
+ (:printer accum-reg/mem ((op '(#b1111011 #b100))))
+ (:emitter
+ (let ((size (matching-operand-size dst src)))
+ (assert (accumulator-p dst))
+ (maybe-emit-operand-size-prefix segment size)
+ (emit-byte segment (if (eq size :byte) #b11110110 #b11110111))
+ (emit-ea segment src #b100))))
+
+(define-instruction imul (segment dst &optional src1 src2)
+ (:printer accum-reg/mem ((op '(#b1111011 #b101))))
+ (:printer ext-reg-reg/mem ((op #b1010111)))
+ (:printer reg-reg/mem ((op #b0110100) (width 1) (imm nil :type 'imm-word))
+ '(:name :tab reg ", " reg/mem ", " imm))
+ (:printer reg-reg/mem ((op #b0110101) (width 1)
+ (imm nil :type 'signed-imm-byte))
+ '(:name :tab reg ", " reg/mem ", " imm))
+ (:emitter
+ (flet ((r/m-with-immed-to-reg (reg r/m immed)
+ (let* ((size (matching-operand-size reg r/m))
+ (sx (and (not (eq size :byte)) (<= -128 immed 127))))
+ (maybe-emit-operand-size-prefix segment size)
+ (emit-byte segment (if sx #b01101011 #b01101001))
+ (emit-ea segment r/m (reg-tn-encoding reg))
+ (if sx
+ (emit-byte segment immed)
+ (emit-sized-immediate segment size immed)))))
+ (cond (src2
+ (r/m-with-immed-to-reg dst src1 src2))
+ (src1
+ (if (integerp src1)
+ (r/m-with-immed-to-reg dst dst src1)
+ (let ((size (matching-operand-size dst src1)))
+ (maybe-emit-operand-size-prefix segment size)
+ (emit-byte segment #b00001111)
+ (emit-byte segment #b10101111)
+ (emit-ea segment src1 (reg-tn-encoding dst)))))
+ (t
+ (let ((size (operand-size dst)))
+ (maybe-emit-operand-size-prefix segment size)
+ (emit-byte segment (if (eq size :byte) #b11110110 #b11110111))
+ (emit-ea segment dst #b101)))))))
+
+(define-instruction div (segment dst src)
+ (:printer accum-reg/mem ((op '(#b1111011 #b110))))
+ (:emitter
+ (let ((size (matching-operand-size dst src)))
+ (assert (accumulator-p dst))
+ (maybe-emit-operand-size-prefix segment size)
+ (emit-byte segment (if (eq size :byte) #b11110110 #b11110111))
+ (emit-ea segment src #b110))))
+
+(define-instruction idiv (segment dst src)
+ (:printer accum-reg/mem ((op '(#b1111011 #b111))))
+ (:emitter
+ (let ((size (matching-operand-size dst src)))
+ (assert (accumulator-p dst))
+ (maybe-emit-operand-size-prefix segment size)
+ (emit-byte segment (if (eq size :byte) #b11110110 #b11110111))
+ (emit-ea segment src #b111))))
+
+(define-instruction aad (segment)
+ (:printer two-bytes ((op '(#b11010101 #b00001010))))
+ (:emitter
+ (emit-byte segment #b11010101)
+ (emit-byte segment #b00001010)))
+
+(define-instruction aam (segment)
+ (:printer two-bytes ((op '(#b11010100 #b00001010))))
+ (:emitter
+ (emit-byte segment #b11010100)
+ (emit-byte segment #b00001010)))
+
+;;; CBW -- Convert Byte to Word. AX <- sign_xtnd(AL)
+(define-instruction cbw (segment)
+ (:emitter
+ (maybe-emit-operand-size-prefix segment :word)
+ (emit-byte segment #b10011000)))
+
+;;; CWDE -- Convert Word To Double Word Extened. EAX <- sign_xtnd(AX)
+(define-instruction cwde (segment)
+ (:emitter
+ (maybe-emit-operand-size-prefix segment :dword)
+ (emit-byte segment #b10011000)))
+
+;;; CWD -- Convert Word to Double Word. DX:AX <- sign_xtnd(AX)
+(define-instruction cwd (segment)
+ (:emitter
+ (maybe-emit-operand-size-prefix segment :word)
+ (emit-byte segment #b10011001)))
+
+;;; CDQ -- Convert Double Word to Quad Word. EDX:EAX <- sign_xtnd(EAX)
+(define-instruction cdq (segment)
+ (:printer byte ((op #b10011001)))
+ (:emitter
+ (maybe-emit-operand-size-prefix segment :dword)
+ (emit-byte segment #b10011001)))
+
+(define-instruction xadd (segment dst src)
+ ;; Register/Memory with Register.
+ (:printer ext-reg-reg/mem ((op #b1100000)) '(:name :tab reg/mem ", " reg))
+ (:emitter
+ (assert (register-p src))
+ (let ((size (matching-operand-size src dst)))
+ (maybe-emit-operand-size-prefix segment size)
+ (emit-byte segment #b00001111)
+ (emit-byte segment (if (eq size :byte) #b11000000 #b11000001))
+ (emit-ea segment dst (reg-tn-encoding src)))))
+
+\f
+;;;; logic
+
+(defun emit-shift-inst (segment dst amount opcode)
+ (let ((size (operand-size dst)))
+ (maybe-emit-operand-size-prefix segment size)
+ (multiple-value-bind (major-opcode immed)
+ (case amount
+ (:cl (values #b11010010 nil))
+ (1 (values #b11010000 nil))
+ (t (values #b11000000 t)))
+ (emit-byte segment
+ (if (eq size :byte) major-opcode (logior major-opcode 1)))
+ (emit-ea segment dst opcode)
+ (when immed
+ (emit-byte segment amount)))))
+
+(eval-when (:compile-toplevel :execute)
+ (defun shift-inst-printer-list (subop)
+ `((reg/mem ((op (#b1101000 ,subop)))
+ (:name :tab reg/mem ", 1"))
+ (reg/mem ((op (#b1101001 ,subop)))
+ (:name :tab reg/mem ", " 'cl))
+ (reg/mem-imm ((op (#b1100000 ,subop))
+ (imm nil :type signed-imm-byte))))))
+
+(define-instruction rol (segment dst amount)
+ (:printer-list
+ (shift-inst-printer-list #b000))
+ (:emitter
+ (emit-shift-inst segment dst amount #b000)))
+
+(define-instruction ror (segment dst amount)
+ (:printer-list
+ (shift-inst-printer-list #b001))
+ (:emitter
+ (emit-shift-inst segment dst amount #b001)))
+
+(define-instruction rcl (segment dst amount)
+ (:printer-list
+ (shift-inst-printer-list #b010))
+ (:emitter
+ (emit-shift-inst segment dst amount #b010)))
+
+(define-instruction rcr (segment dst amount)
+ (:printer-list
+ (shift-inst-printer-list #b011))
+ (:emitter
+ (emit-shift-inst segment dst amount #b011)))
+
+(define-instruction shl (segment dst amount)
+ (:printer-list
+ (shift-inst-printer-list #b100))
+ (:emitter
+ (emit-shift-inst segment dst amount #b100)))
+
+(define-instruction shr (segment dst amount)
+ (:printer-list
+ (shift-inst-printer-list #b101))
+ (:emitter
+ (emit-shift-inst segment dst amount #b101)))
+
+(define-instruction sar (segment dst amount)
+ (:printer-list
+ (shift-inst-printer-list #b111))
+ (:emitter
+ (emit-shift-inst segment dst amount #b111)))
+
+(defun emit-double-shift (segment opcode dst src amt)
+ (let ((size (matching-operand-size dst src)))
+ (when (eq size :byte)
+ (error "Double shifts can only be used with words."))
+ (maybe-emit-operand-size-prefix segment size)
+ (emit-byte segment #b00001111)
+ (emit-byte segment (dpb opcode (byte 1 3)
+ (if (eq amt :cl) #b10100101 #b10100100)))
+ #+nil
+ (emit-ea segment dst src)
+ (emit-ea segment dst (reg-tn-encoding src)) ; pw tries this
+ (unless (eq amt :cl)
+ (emit-byte segment amt))))
+
+(eval-when (:compile-toplevel :execute)
+ (defun double-shift-inst-printer-list (op)
+ `(#+nil
+ (ext-reg-reg/mem-imm ((op ,(logior op #b100))
+ (imm nil :type signed-imm-byte)))
+ (ext-reg-reg/mem ((op ,(logior op #b101)))
+ (:name :tab reg/mem ", " 'cl)))))
+
+(define-instruction shld (segment dst src amt)
+ (:declare (type (or (member :cl) (mod 32)) amt))
+ (:printer-list (double-shift-inst-printer-list #b10100000))
+ (:emitter
+ (emit-double-shift segment #b0 dst src amt)))
+
+(define-instruction shrd (segment dst src amt)
+ (:declare (type (or (member :cl) (mod 32)) amt))
+ (:printer-list (double-shift-inst-printer-list #b10101000))
+ (:emitter
+ (emit-double-shift segment #b1 dst src amt)))
+
+(define-instruction and (segment dst src)
+ (:printer-list
+ (arith-inst-printer-list #b100))
+ (:emitter
+ (emit-random-arith-inst "AND" segment dst src #b100)))
+
+(define-instruction test (segment this that)
+ (:printer accum-imm ((op #b1010100)))
+ (:printer reg/mem-imm ((op '(#b1111011 #b000))))
+ (:printer reg-reg/mem ((op #b1000010)))
+ (:emitter
+ (let ((size (matching-operand-size this that)))
+ (maybe-emit-operand-size-prefix segment size)
+ (flet ((test-immed-and-something (immed something)
+ (cond ((accumulator-p something)
+ (emit-byte segment
+ (if (eq size :byte) #b10101000 #b10101001))
+ (emit-sized-immediate segment size immed))
+ (t
+ (emit-byte segment
+ (if (eq size :byte) #b11110110 #b11110111))
+ (emit-ea segment something #b000)
+ (emit-sized-immediate segment size immed))))
+ (test-reg-and-something (reg something)
+ (emit-byte segment (if (eq size :byte) #b10000100 #b10000101))
+ (emit-ea segment something (reg-tn-encoding reg))))
+ (cond ((integerp that)
+ (test-immed-and-something that this))
+ ((integerp this)
+ (test-immed-and-something this that))
+ ((register-p this)
+ (test-reg-and-something this that))
+ ((register-p that)
+ (test-reg-and-something that this))
+ (t
+ (error "bogus operands for TEST: ~S and ~S" this that)))))))
+
+(define-instruction or (segment dst src)
+ (:printer-list
+ (arith-inst-printer-list #b001))
+ (:emitter
+ (emit-random-arith-inst "OR" segment dst src #b001)))
+
+(define-instruction xor (segment dst src)
+ (:printer-list
+ (arith-inst-printer-list #b110))
+ (:emitter
+ (emit-random-arith-inst "XOR" segment dst src #b110)))
+
+(define-instruction not (segment dst)
+ (:printer reg/mem ((op '(#b1111011 #b010))))
+ (:emitter
+ (let ((size (operand-size dst)))
+ (maybe-emit-operand-size-prefix segment size)
+ (emit-byte segment (if (eq size :byte) #b11110110 #b11110111))
+ (emit-ea segment dst #b010))))
+\f
+;;;; string manipulation
+
+(define-instruction cmps (segment size)
+ (:printer string-op ((op #b1010011)))
+ (:emitter
+ (maybe-emit-operand-size-prefix segment size)
+ (emit-byte segment (if (eq size :byte) #b10100110 #b10100111))))
+
+(define-instruction ins (segment acc)
+ (:printer string-op ((op #b0110110)))
+ (:emitter
+ (let ((size (operand-size acc)))
+ (assert (accumulator-p acc))
+ (maybe-emit-operand-size-prefix segment size)
+ (emit-byte segment (if (eq size :byte) #b01101100 #b01101101)))))
+
+(define-instruction lods (segment acc)
+ (:printer string-op ((op #b1010110)))
+ (:emitter
+ (let ((size (operand-size acc)))
+ (assert (accumulator-p acc))
+ (maybe-emit-operand-size-prefix segment size)
+ (emit-byte segment (if (eq size :byte) #b10101100 #b10101101)))))
+
+(define-instruction movs (segment size)
+ (:printer string-op ((op #b1010010)))
+ (:emitter
+ (maybe-emit-operand-size-prefix segment size)
+ (emit-byte segment (if (eq size :byte) #b10100100 #b10100101))))
+
+(define-instruction outs (segment acc)
+ (:printer string-op ((op #b0110111)))
+ (:emitter
+ (let ((size (operand-size acc)))
+ (assert (accumulator-p acc))
+ (maybe-emit-operand-size-prefix segment size)
+ (emit-byte segment (if (eq size :byte) #b01101110 #b01101111)))))
+
+(define-instruction scas (segment acc)
+ (:printer string-op ((op #b1010111)))
+ (:emitter
+ (let ((size (operand-size acc)))
+ (assert (accumulator-p acc))
+ (maybe-emit-operand-size-prefix segment size)
+ (emit-byte segment (if (eq size :byte) #b10101110 #b10101111)))))
+
+(define-instruction stos (segment acc)
+ (:printer string-op ((op #b1010101)))
+ (:emitter
+ (let ((size (operand-size acc)))
+ (assert (accumulator-p acc))
+ (maybe-emit-operand-size-prefix segment size)
+ (emit-byte segment (if (eq size :byte) #b10101010 #b10101011)))))
+
+(define-instruction xlat (segment)
+ (:printer byte ((op #b11010111)))
+ (:emitter
+ (emit-byte segment #b11010111)))
+
+(define-instruction rep (segment)
+ (:emitter
+ (emit-byte segment #b11110010)))
+
+(define-instruction repe (segment)
+ (:printer byte ((op #b11110011)))
+ (:emitter
+ (emit-byte segment #b11110011)))
+
+(define-instruction repne (segment)
+ (:printer byte ((op #b11110010)))
+ (:emitter
+ (emit-byte segment #b11110010)))
+
+\f
+;;;; bit manipulation
+
+(define-instruction bsf (segment dst src)
+ (:emitter
+ (let ((size (matching-operand-size dst src)))
+ (when (eq size :byte)
+ (error "can't scan bytes: ~S" src))
+ (maybe-emit-operand-size-prefix segment size)
+ (emit-byte segment #b00001111)
+ (emit-byte segment #b10111100)
+ (emit-ea segment src (reg-tn-encoding dst)))))
+
+(define-instruction bsr (segment dst src)
+ (:emitter
+ (let ((size (matching-operand-size dst src)))
+ (when (eq size :byte)
+ (error "can't scan bytes: ~S" src))
+ (maybe-emit-operand-size-prefix segment size)
+ (emit-byte segment #b00001111)
+ (emit-byte segment #b10111101)
+ (emit-ea segment src (reg-tn-encoding dst)))))
+
+(defun emit-bit-test-and-mumble (segment src index opcode)
+ (let ((size (operand-size src)))
+ (when (eq size :byte)
+ (error "can't scan bytes: ~S" src))
+ (maybe-emit-operand-size-prefix segment size)
+ (emit-byte segment #b00001111)
+ (cond ((integerp index)
+ (emit-byte segment #b10111010)
+ (emit-ea segment src opcode)
+ (emit-byte segment index))
+ (t
+ (emit-byte segment (dpb opcode (byte 3 3) #b10000011))
+ (emit-ea segment src (reg-tn-encoding index))))))
+
+(define-instruction bt (segment src index)
+ (:emitter
+ (emit-bit-test-and-mumble segment src index #b100)))
+
+(define-instruction btc (segment src index)
+ (:emitter
+ (emit-bit-test-and-mumble segment src index #b111)))
+
+(define-instruction btr (segment src index)
+ (:emitter
+ (emit-bit-test-and-mumble segment src index #b110)))
+
+(define-instruction bts (segment src index)
+ (:emitter
+ (emit-bit-test-and-mumble segment src index #b101)))
+
+\f
+;;;; control transfer
+
+(define-instruction call (segment where)
+ (:printer near-jump ((op #b11101000)))
+ (:printer reg/mem ((op '(#b1111111 #b010)) (width 1)))
+ (:emitter
+ (typecase where
+ (label
+ (emit-byte segment #b11101000)
+ (emit-back-patch segment
+ 4
+ #'(lambda (segment posn)
+ (emit-dword segment
+ (- (label-position where)
+ (+ posn 4))))))
+ (fixup
+ (emit-byte segment #b11101000)
+ (emit-relative-fixup segment where))
+ (t
+ (emit-byte segment #b11111111)
+ (emit-ea segment where #b010)))))
+
+(defun emit-byte-displacement-backpatch (segment target)
+ (emit-back-patch segment
+ 1
+ #'(lambda (segment posn)
+ (let ((disp (- (label-position target) (1+ posn))))
+ (assert (<= -128 disp 127))
+ (emit-byte segment disp)))))
+
+(define-instruction jmp (segment cond &optional where)
+ ;; conditional jumps
+ (:printer short-cond-jump ((op #b0111)) '('j cc :tab label))
+ (:printer near-cond-jump () '('j cc :tab label))
+ ;; unconditional jumps
+ (:printer short-jump ((op #b1011)))
+ (:printer near-jump ((op #b11101001)) )
+ (:printer reg/mem ((op '(#b1111111 #b100)) (width 1)))
+ (:emitter
+ (cond (where
+ (emit-chooser
+ segment 6 2
+ #'(lambda (segment posn delta-if-after)
+ (let ((disp (- (label-position where posn delta-if-after)
+ (+ posn 2))))
+ (when (<= -128 disp 127)
+ (emit-byte segment
+ (dpb (conditional-opcode cond)
+ (byte 4 0)
+ #b01110000))
+ (emit-byte-displacement-backpatch segment where)
+ t)))
+ #'(lambda (segment posn)
+ (let ((disp (- (label-position where) (+ posn 6))))
+ (emit-byte segment #b00001111)
+ (emit-byte segment
+ (dpb (conditional-opcode cond)
+ (byte 4 0)
+ #b10000000))
+ (emit-dword segment disp)))))
+ ((label-p (setq where cond))
+ (emit-chooser
+ segment 5 0
+ #'(lambda (segment posn delta-if-after)
+ (let ((disp (- (label-position where posn delta-if-after)
+ (+ posn 2))))
+ (when (<= -128 disp 127)
+ (emit-byte segment #b11101011)
+ (emit-byte-displacement-backpatch segment where)
+ t)))
+ #'(lambda (segment posn)
+ (let ((disp (- (label-position where) (+ posn 5))))
+ (emit-byte segment #b11101001)
+ (emit-dword segment disp))
+ )))
+ ((fixup-p where)
+ (emit-byte segment #b11101001)
+ (emit-relative-fixup segment where))
+ (t
+ (unless (or (ea-p where) (tn-p where))
+ (error "don't know what to do with ~A" where))
+ (emit-byte segment #b11111111)
+ (emit-ea segment where #b100)))))
+
+(define-instruction jmp-short (segment label)
+ (:emitter
+ (emit-byte segment #b11101011)
+ (emit-byte-displacement-backpatch segment label)))
+
+(define-instruction ret (segment &optional stack-delta)
+ (:printer byte ((op #b11000011)))
+ (:printer byte ((op #b11000010) (imm nil :type 'imm-word-16))
+ '(:name :tab imm))
+ (:emitter
+ (cond (stack-delta
+ (emit-byte segment #b11000010)
+ (emit-word segment stack-delta))
+ (t
+ (emit-byte segment #b11000011)))))
+
+(define-instruction jecxz (segment target)
+ (:printer short-jump ((op #b0011)))
+ (:emitter
+ (emit-byte segment #b11100011)
+ (emit-byte-displacement-backpatch segment target)))
+
+(define-instruction loop (segment target)
+ (:printer short-jump ((op #b0010)))
+ (:emitter
+ (emit-byte segment #b11100010) ; pfw this was 11100011, or jecxz!!!!
+ (emit-byte-displacement-backpatch segment target)))
+
+(define-instruction loopz (segment target)
+ (:printer short-jump ((op #b0001)))
+ (:emitter
+ (emit-byte segment #b11100001)
+ (emit-byte-displacement-backpatch segment target)))
+
+(define-instruction loopnz (segment target)
+ (:printer short-jump ((op #b0000)))
+ (:emitter
+ (emit-byte segment #b11100000)
+ (emit-byte-displacement-backpatch segment target)))
+\f
+;;;; conditional byte set
+
+(define-instruction set (segment dst cond)
+ (:printer cond-set ())
+ (:emitter
+ (emit-byte segment #b00001111)
+ (emit-byte segment (dpb (conditional-opcode cond) (byte 4 0) #b10010000))
+ (emit-ea segment dst #b000)))
+\f
+;;;; enter/leave
+
+(define-instruction enter (segment disp &optional (level 0))
+ (:declare (type (unsigned-byte 16) disp)
+ (type (unsigned-byte 8) level))
+ (:printer enter-format ((op #b11001000)))
+ (:emitter
+ (emit-byte segment #b11001000)
+ (emit-word segment disp)
+ (emit-byte segment level)))
+
+(define-instruction leave (segment)
+ (:printer byte ((op #b11001001)))
+ (:emitter
+ (emit-byte segment #b11001001)))
+\f
+;;;; interrupt instructions
+
+(defun snarf-error-junk (sap offset &optional length-only)
+ (let* ((length (sb!sys:sap-ref-8 sap offset))
+ (vector (make-array length :element-type '(unsigned-byte 8))))
+ (declare (type sb!sys:system-area-pointer sap)
+ (type (unsigned-byte 8) length)
+ (type (simple-array (unsigned-byte 8) (*)) vector))
+ (cond (length-only
+ (values 0 (1+ length) nil nil))
+ (t
+ (sb!kernel:copy-from-system-area sap (* byte-bits (1+ offset))
+ vector (* word-bits
+ vector-data-offset)
+ (* length byte-bits))
+ (collect ((sc-offsets)
+ (lengths))
+ (lengths 1) ; the length byte
+ (let* ((index 0)
+ (error-number (sb!c::read-var-integer vector index)))
+ (lengths index)
+ (loop
+ (when (>= index length)
+ (return))
+ (let ((old-index index))
+ (sc-offsets (sb!c::read-var-integer vector index))
+ (lengths (- index old-index))))
+ (values error-number
+ (1+ length)
+ (sc-offsets)
+ (lengths))))))))
+
+#|
+(defmacro break-cases (breaknum &body cases)
+ (let ((bn-temp (gensym)))
+ (collect ((clauses))
+ (dolist (case cases)
+ (clauses `((= ,bn-temp ,(car case)) ,@(cdr case))))
+ `(let ((,bn-temp ,breaknum))
+ (cond ,@(clauses))))))
+|#
+
+(defun break-control (chunk inst stream dstate)
+ (declare (ignore inst))
+ (flet ((nt (x) (if stream (sb!disassem:note x dstate))))
+ ;; FIXME: Make sure that BYTE-IMM-CODE is defined. The genesis
+ ;; map has it undefined; and it should be easier to look in the target
+ ;; Lisp (with (DESCRIBE 'BYTE-IMM-CODE)) than to definitively deduce
+ ;; from first principles whether it's defined in some way that genesis
+ ;; can't grok.
+ (case (byte-imm-code chunk dstate)
+ (#.sb!vm:error-trap
+ (nt "error trap")
+ (sb!disassem:handle-break-args #'snarf-error-junk stream dstate))
+ (#.sb!vm:cerror-trap
+ (nt "cerror trap")
+ (sb!disassem:handle-break-args #'snarf-error-junk stream dstate))
+ (#.sb!vm:breakpoint-trap
+ (nt "breakpoint trap"))
+ (#.sb!vm:pending-interrupt-trap
+ (nt "pending interrupt trap"))
+ (#.sb!vm:halt-trap
+ (nt "halt trap"))
+ (#.sb!vm:function-end-breakpoint-trap
+ (nt "function end breakpoint trap")))))
+
+(define-instruction break (segment code)
+ (:declare (type (unsigned-byte 8) code))
+ (:printer byte-imm ((op #b11001100)) '(:name :tab code)
+ :control #'break-control)
+ (:emitter
+ (emit-byte segment #b11001100)
+ (emit-byte segment code)))
+
+(define-instruction int (segment number)
+ (:declare (type (unsigned-byte 8) number))
+ (:printer byte-imm ((op #b11001101)))
+ (:emitter
+ (etypecase number
+ ((member 3)
+ (emit-byte segment #b11001100))
+ ((unsigned-byte 8)
+ (emit-byte segment #b11001101)
+ (emit-byte segment number)))))
+
+(define-instruction into (segment)
+ (:printer byte ((op #b11001110)))
+ (:emitter
+ (emit-byte segment #b11001110)))
+
+(define-instruction bound (segment reg bounds)
+ (:emitter
+ (let ((size (matching-operand-size reg bounds)))
+ (when (eq size :byte)
+ (error "can't bounds-test bytes: ~S" reg))
+ (maybe-emit-operand-size-prefix segment size)
+ (emit-byte segment #b01100010)
+ (emit-ea segment bounds (reg-tn-encoding reg)))))
+
+(define-instruction iret (segment)
+ (:printer byte ((op #b11001111)))
+ (:emitter
+ (emit-byte segment #b11001111)))
+\f
+;;;; processor control
+
+(define-instruction hlt (segment)
+ (:printer byte ((op #b11110100)))
+ (:emitter
+ (emit-byte segment #b11110100)))
+
+(define-instruction nop (segment)
+ (:printer byte ((op #b10010000)))
+ (:emitter
+ (emit-byte segment #b10010000)))
+
+(define-instruction wait (segment)
+ (:printer byte ((op #b10011011)))
+ (:emitter
+ (emit-byte segment #b10011011)))
+
+(define-instruction lock (segment)
+ (:printer byte ((op #b11110000)))
+ (:emitter
+ (emit-byte segment #b11110000)))
+\f
+;;;; miscellaneous hackery
+
+(define-instruction byte (segment byte)
+ (:emitter
+ (emit-byte segment byte)))
+
+(define-instruction word (segment word)
+ (:emitter
+ (emit-word segment word)))
+
+(define-instruction dword (segment dword)
+ (:emitter
+ (emit-dword segment dword)))
+
+(defun emit-header-data (segment type)
+ (emit-back-patch segment
+ 4
+ (lambda (segment posn)
+ (emit-dword segment
+ (logior type
+ (ash (+ posn
+ (component-header-length))
+ (- type-bits
+ word-shift)))))))
+
+(define-instruction function-header-word (segment)
+ (:emitter
+ (emit-header-data segment function-header-type)))
+
+(define-instruction lra-header-word (segment)
+ (:emitter
+ (emit-header-data segment return-pc-header-type)))
+\f
+;;;; fp instructions
+;;;;
+;;;; FIXME: This section said "added by jrd", which should end up in CREDITS.
+;;;;
+;;;; Note: We treat the single-precision and double-precision variants
+;;;; as separate instructions.
+
+;;; Load single to st(0).
+(define-instruction fld (segment source)
+ (:printer floating-point ((op '(#b001 #b000))))
+ (:emitter
+ (emit-byte segment #b11011001)
+ (emit-fp-op segment source #b000)))
+
+;;; Load double to st(0).
+(define-instruction fldd (segment source)
+ (:printer floating-point ((op '(#b101 #b000))))
+ (:printer floating-point-fp ((op '(#b001 #b000))))
+ (:emitter
+ (if (fp-reg-tn-p source)
+ (emit-byte segment #b11011001)
+ (emit-byte segment #b11011101))
+ (emit-fp-op segment source #b000)))
+
+;;; Load long to st(0).
+(define-instruction fldl (segment source)
+ (:printer floating-point ((op '(#b011 #b101))))
+ (:emitter
+ (emit-byte segment #b11011011)
+ (emit-fp-op segment source #b101)))
+
+;;; Store single from st(0).
+(define-instruction fst (segment dest)
+ (:printer floating-point ((op '(#b001 #b010))))
+ (:emitter
+ (cond ((fp-reg-tn-p dest)
+ (emit-byte segment #b11011101)
+ (emit-fp-op segment dest #b010))
+ (t
+ (emit-byte segment #b11011001)
+ (emit-fp-op segment dest #b010)))))
+
+;;; Store double from st(0).
+(define-instruction fstd (segment dest)
+ (:printer floating-point ((op '(#b101 #b010))))
+ (:printer floating-point-fp ((op '(#b101 #b010))))
+ (:emitter
+ (cond ((fp-reg-tn-p dest)
+ (emit-byte segment #b11011101)
+ (emit-fp-op segment dest #b010))
+ (t
+ (emit-byte segment #b11011101)
+ (emit-fp-op segment dest #b010)))))
+
+;;; Arithmetic ops are all done with at least one operand at top of
+;;; stack. The other operand is is another register or a 32/64 bit
+;;; memory loc.
+
+;;; dtc: I've tried to follow the Intel ASM386 conventions, but note
+;;; that these conflict with the Gdb conventions for binops. To reduce
+;;; the confusion I've added comments showing the mathamatical
+;;; operation and the two syntaxes. By the ASM386 convention the
+;;; instruction syntax is:
+;;;
+;;; Fop Source
+;;; or Fop Destination, Source
+;;;
+;;; If only one operand is given then it is the source and the
+;;; destination is ST(0). There are reversed forms of the fsub and
+;;; fdiv instructions inducated by an 'R' suffix.
+;;;
+;;; The mathematical operation for the non-reverse form is always:
+;;; destination = destination op source
+;;;
+;;; For the reversed form it is:
+;;; destination = source op destination
+;;;
+;;; The instructions below only accept one operand at present which is
+;;; usually the source. I've hack in extra instructions to implement
+;;; the fops with a ST(i) destination, these have a -sti suffix and
+;;; the operand is the destination with the source being ST(0).
+
+;;; Add single:
+;;; st(0) = st(0) + memory or st(i).
+(define-instruction fadd (segment source)
+ (:printer floating-point ((op '(#b000 #b000))))
+ (:emitter
+ (emit-byte segment #b11011000)
+ (emit-fp-op segment source #b000)))
+
+;;; Add double:
+;;; st(0) = st(0) + memory or st(i).
+(define-instruction faddd (segment source)
+ (:printer floating-point ((op '(#b100 #b000))))
+ (:printer floating-point-fp ((op '(#b000 #b000))))
+ (:emitter
+ (if (fp-reg-tn-p source)
+ (emit-byte segment #b11011000)
+ (emit-byte segment #b11011100))
+ (emit-fp-op segment source #b000)))
+
+;;; Add double destination st(i):
+;;; st(i) = st(0) + st(i).
+(define-instruction fadd-sti (segment destination)
+ (:printer floating-point-fp ((op '(#b100 #b000))))
+ (:emitter
+ (assert (fp-reg-tn-p destination))
+ (emit-byte segment #b11011100)
+ (emit-fp-op segment destination #b000)))
+;;; with pop
+(define-instruction faddp-sti (segment destination)
+ (:printer floating-point-fp ((op '(#b110 #b000))))
+ (:emitter
+ (assert (fp-reg-tn-p destination))
+ (emit-byte segment #b11011110)
+ (emit-fp-op segment destination #b000)))
+
+;;; Subtract single:
+;;; st(0) = st(0) - memory or st(i).
+(define-instruction fsub (segment source)
+ (:printer floating-point ((op '(#b000 #b100))))
+ (:emitter
+ (emit-byte segment #b11011000)
+ (emit-fp-op segment source #b100)))
+
+;;; Subtract single, reverse:
+;;; st(0) = memory or st(i) - st(0).
+(define-instruction fsubr (segment source)
+ (:printer floating-point ((op '(#b000 #b101))))
+ (:emitter
+ (emit-byte segment #b11011000)
+ (emit-fp-op segment source #b101)))
+
+;;; Subtract double:
+;;; st(0) = st(0) - memory or st(i).
+(define-instruction fsubd (segment source)
+ (:printer floating-point ((op '(#b100 #b100))))
+ (:printer floating-point-fp ((op '(#b000 #b100))))
+ (:emitter
+ (if (fp-reg-tn-p source)
+ (emit-byte segment #b11011000)
+ (emit-byte segment #b11011100))
+ (emit-fp-op segment source #b100)))
+
+;;; Subtract double, reverse:
+;;; st(0) = memory or st(i) - st(0).
+(define-instruction fsubrd (segment source)
+ (:printer floating-point ((op '(#b100 #b101))))
+ (:printer floating-point-fp ((op '(#b000 #b101))))
+ (:emitter
+ (if (fp-reg-tn-p source)
+ (emit-byte segment #b11011000)
+ (emit-byte segment #b11011100))
+ (emit-fp-op segment source #b101)))
+
+;;; Subtract double, destination st(i):
+;;; st(i) = st(i) - st(0).
+;;;
+;;; ASM386 syntax: FSUB ST(i), ST
+;;; Gdb syntax: fsubr %st,%st(i)
+(define-instruction fsub-sti (segment destination)
+ (:printer floating-point-fp ((op '(#b100 #b101))))
+ (:emitter
+ (assert (fp-reg-tn-p destination))
+ (emit-byte segment #b11011100)
+ (emit-fp-op segment destination #b101)))
+;;; with a pop
+(define-instruction fsubp-sti (segment destination)
+ (:printer floating-point-fp ((op '(#b110 #b101))))
+ (:emitter
+ (assert (fp-reg-tn-p destination))
+ (emit-byte segment #b11011110)
+ (emit-fp-op segment destination #b101)))
+
+;;; Subtract double, reverse, destination st(i):
+;;; st(i) = st(0) - st(i).
+;;;
+;;; ASM386 syntax: FSUBR ST(i), ST
+;;; Gdb syntax: fsub %st,%st(i)
+(define-instruction fsubr-sti (segment destination)
+ (:printer floating-point-fp ((op '(#b100 #b100))))
+ (:emitter
+ (assert (fp-reg-tn-p destination))
+ (emit-byte segment #b11011100)
+ (emit-fp-op segment destination #b100)))
+;;; with a pop
+(define-instruction fsubrp-sti (segment destination)
+ (:printer floating-point-fp ((op '(#b110 #b100))))
+ (:emitter
+ (assert (fp-reg-tn-p destination))
+ (emit-byte segment #b11011110)
+ (emit-fp-op segment destination #b100)))
+
+;;; Multiply single:
+;;; st(0) = st(0) * memory or st(i).
+(define-instruction fmul (segment source)
+ (:printer floating-point ((op '(#b000 #b001))))
+ (:emitter
+ (emit-byte segment #b11011000)
+ (emit-fp-op segment source #b001)))
+
+;;; Multiply double:
+;;; st(0) = st(0) * memory or st(i).
+(define-instruction fmuld (segment source)
+ (:printer floating-point ((op '(#b100 #b001))))
+ (:printer floating-point-fp ((op '(#b000 #b001))))
+ (:emitter
+ (if (fp-reg-tn-p source)
+ (emit-byte segment #b11011000)
+ (emit-byte segment #b11011100))
+ (emit-fp-op segment source #b001)))
+
+;;; Multiply double, destination st(i):
+;;; st(i) = st(i) * st(0).
+(define-instruction fmul-sti (segment destination)
+ (:printer floating-point-fp ((op '(#b100 #b001))))
+ (:emitter
+ (assert (fp-reg-tn-p destination))
+ (emit-byte segment #b11011100)
+ (emit-fp-op segment destination #b001)))
+
+;;; Divide single:
+;;; st(0) = st(0) / memory or st(i).
+(define-instruction fdiv (segment source)
+ (:printer floating-point ((op '(#b000 #b110))))
+ (:emitter
+ (emit-byte segment #b11011000)
+ (emit-fp-op segment source #b110)))
+
+;;; Divide single, reverse:
+;;; st(0) = memory or st(i) / st(0).
+(define-instruction fdivr (segment source)
+ (:printer floating-point ((op '(#b000 #b111))))
+ (:emitter
+ (emit-byte segment #b11011000)
+ (emit-fp-op segment source #b111)))
+
+;;; Divide double:
+;;; st(0) = st(0) / memory or st(i).
+(define-instruction fdivd (segment source)
+ (:printer floating-point ((op '(#b100 #b110))))
+ (:printer floating-point-fp ((op '(#b000 #b110))))
+ (:emitter
+ (if (fp-reg-tn-p source)
+ (emit-byte segment #b11011000)
+ (emit-byte segment #b11011100))
+ (emit-fp-op segment source #b110)))
+
+;;; Divide double, reverse:
+;;; st(0) = memory or st(i) / st(0).
+(define-instruction fdivrd (segment source)
+ (:printer floating-point ((op '(#b100 #b111))))
+ (:printer floating-point-fp ((op '(#b000 #b111))))
+ (:emitter
+ (if (fp-reg-tn-p source)
+ (emit-byte segment #b11011000)
+ (emit-byte segment #b11011100))
+ (emit-fp-op segment source #b111)))
+
+;;; Divide double, destination st(i):
+;;; st(i) = st(i) / st(0).
+;;;
+;;; ASM386 syntax: FDIV ST(i), ST
+;;; Gdb syntax: fdivr %st,%st(i)
+(define-instruction fdiv-sti (segment destination)
+ (:printer floating-point-fp ((op '(#b100 #b111))))
+ (:emitter
+ (assert (fp-reg-tn-p destination))
+ (emit-byte segment #b11011100)
+ (emit-fp-op segment destination #b111)))
+
+;;; Divide double, reverse, destination st(i):
+;;; st(i) = st(0) / st(i).
+;;;
+;;; ASM386 syntax: FDIVR ST(i), ST
+;;; Gdb syntax: fdiv %st,%st(i)
+(define-instruction fdivr-sti (segment destination)
+ (:printer floating-point-fp ((op '(#b100 #b110))))
+ (:emitter
+ (assert (fp-reg-tn-p destination))
+ (emit-byte segment #b11011100)
+ (emit-fp-op segment destination #b110)))
+
+;;; Exchange fr0 with fr(n). (There is no double precision variant.)
+(define-instruction fxch (segment source)
+ (:printer floating-point-fp ((op '(#b001 #b001))))
+ (:emitter
+ (unless (and (tn-p source)
+ (eq (sb-name (sc-sb (tn-sc source))) 'float-registers))
+ (cl:break))
+ (emit-byte segment #b11011001)
+ (emit-fp-op segment source #b001)))
+
+;;; Push 32-bit integer to st0.
+(define-instruction fild (segment source)
+ (:printer floating-point ((op '(#b011 #b000))))
+ (:emitter
+ (emit-byte segment #b11011011)
+ (emit-fp-op segment source #b000)))
+
+;;; Push 64-bit integer to st0.
+(define-instruction fildl (segment source)
+ (:printer floating-point ((op '(#b111 #b101))))
+ (:emitter
+ (emit-byte segment #b11011111)
+ (emit-fp-op segment source #b101)))
+
+;;; Store 32-bit integer.
+(define-instruction fist (segment dest)
+ (:printer floating-point ((op '(#b011 #b010))))
+ (:emitter
+ (emit-byte segment #b11011011)
+ (emit-fp-op segment dest #b010)))
+
+;;; Store and pop 32-bit integer.
+(define-instruction fistp (segment dest)
+ (:printer floating-point ((op '(#b011 #b011))))
+ (:emitter
+ (emit-byte segment #b11011011)
+ (emit-fp-op segment dest #b011)))
+
+;;; Store and pop 64-bit integer.
+(define-instruction fistpl (segment dest)
+ (:printer floating-point ((op '(#b111 #b111))))
+ (:emitter
+ (emit-byte segment #b11011111)
+ (emit-fp-op segment dest #b111)))
+
+;;; Store single from st(0) and pop.
+(define-instruction fstp (segment dest)
+ (:printer floating-point ((op '(#b001 #b011))))
+ (:emitter
+ (cond ((fp-reg-tn-p dest)
+ (emit-byte segment #b11011101)
+ (emit-fp-op segment dest #b011))
+ (t
+ (emit-byte segment #b11011001)
+ (emit-fp-op segment dest #b011)))))
+
+;;; Store double from st(0) and pop.
+(define-instruction fstpd (segment dest)
+ (:printer floating-point ((op '(#b101 #b011))))
+ (:printer floating-point-fp ((op '(#b101 #b011))))
+ (:emitter
+ (cond ((fp-reg-tn-p dest)
+ (emit-byte segment #b11011101)
+ (emit-fp-op segment dest #b011))
+ (t
+ (emit-byte segment #b11011101)
+ (emit-fp-op segment dest #b011)))))
+
+;;; Store long from st(0) and pop.
+(define-instruction fstpl (segment dest)
+ (:printer floating-point ((op '(#b011 #b111))))
+ (:emitter
+ (emit-byte segment #b11011011)
+ (emit-fp-op segment dest #b111)))
+
+;;; Decrement stack-top pointer.
+(define-instruction fdecstp (segment)
+ (:printer floating-point-no ((op #b10110)))
+ (:emitter
+ (emit-byte segment #b11011001)
+ (emit-byte segment #b11110110)))
+
+;;; Increment stack-top pointer.
+(define-instruction fincstp (segment)
+ (:printer floating-point-no ((op #b10111)))
+ (:emitter
+ (emit-byte segment #b11011001)
+ (emit-byte segment #b11110111)))
+
+;;; Free fp register.
+(define-instruction ffree (segment dest)
+ (:printer floating-point-fp ((op '(#b101 #b000))))
+ (:emitter
+ (emit-byte segment #b11011101)
+ (emit-fp-op segment dest #b000)))
+
+(define-instruction fabs (segment)
+ (:printer floating-point-no ((op #b00001)))
+ (:emitter
+ (emit-byte segment #b11011001)
+ (emit-byte segment #b11100001)))
+
+(define-instruction fchs (segment)
+ (:printer floating-point-no ((op #b00000)))
+ (:emitter
+ (emit-byte segment #b11011001)
+ (emit-byte segment #b11100000)))
+
+(define-instruction frndint(segment)
+ (:printer floating-point-no ((op #b11100)))
+ (:emitter
+ (emit-byte segment #b11011001)
+ (emit-byte segment #b11111100)))
+
+;;; Initialize NPX.
+(define-instruction fninit(segment)
+ (:printer floating-point-5 ((op #b00011)))
+ (:emitter
+ (emit-byte segment #b11011011)
+ (emit-byte segment #b11100011)))
+
+;;; Store Status Word to AX.
+(define-instruction fnstsw(segment)
+ (:printer floating-point-st ((op #b00000)))
+ (:emitter
+ (emit-byte segment #b11011111)
+ (emit-byte segment #b11100000)))
+
+;;; Load Control Word.
+;;;
+;;; src must be a memory location
+(define-instruction fldcw(segment src)
+ (:printer floating-point ((op '(#b001 #b101))))
+ (:emitter
+ (emit-byte segment #b11011001)
+ (emit-fp-op segment src #b101)))
+
+;;; Store Control Word.
+(define-instruction fnstcw(segment dst)
+ (:printer floating-point ((op '(#b001 #b111))))
+ (:emitter
+ (emit-byte segment #b11011001)
+ (emit-fp-op segment dst #b111)))
+
+;;; Store FP Environment.
+(define-instruction fstenv(segment dst)
+ (:printer floating-point ((op '(#b001 #b110))))
+ (:emitter
+ (emit-byte segment #b11011001)
+ (emit-fp-op segment dst #b110)))
+
+;;; Restore FP Environment.
+(define-instruction fldenv(segment src)
+ (:printer floating-point ((op '(#b001 #b100))))
+ (:emitter
+ (emit-byte segment #b11011001)
+ (emit-fp-op segment src #b100)))
+
+;;; Save FP State.
+(define-instruction fsave(segment dst)
+ (:printer floating-point ((op '(#b101 #b110))))
+ (:emitter
+ (emit-byte segment #b11011101)
+ (emit-fp-op segment dst #b110)))
+
+;;; Restore FP State.
+(define-instruction frstor(segment src)
+ (:printer floating-point ((op '(#b101 #b100))))
+ (:emitter
+ (emit-byte segment #b11011101)
+ (emit-fp-op segment src #b100)))
+
+;;; Clear exceptions.
+(define-instruction fnclex(segment)
+ (:printer floating-point-5 ((op #b00010)))
+ (:emitter
+ (emit-byte segment #b11011011)
+ (emit-byte segment #b11100010)))
+
+;;; comparison
+(define-instruction fcom (segment src)
+ (:printer floating-point ((op '(#b000 #b010))))
+ (:emitter
+ (emit-byte segment #b11011000)
+ (emit-fp-op segment src #b010)))
+
+(define-instruction fcomd (segment src)
+ (:printer floating-point ((op '(#b100 #b010))))
+ (:printer floating-point-fp ((op '(#b000 #b010))))
+ (:emitter
+ (if (fp-reg-tn-p src)
+ (emit-byte segment #b11011000)
+ (emit-byte segment #b11011100))
+ (emit-fp-op segment src #b010)))
+
+;;; Compare ST1 to ST0, popping the stack twice.
+(define-instruction fcompp (segment)
+ (:printer floating-point-3 ((op '(#b110 #b011001))))
+ (:emitter
+ (emit-byte segment #b11011110)
+ (emit-byte segment #b11011001)))
+
+;;; unordered comparison
+(define-instruction fucom (segment src)
+ ;; XX Printer conflicts with frstor
+ ;; (:printer floating-point ((op '(#b101 #b100))))
+ (:emitter
+ (assert (fp-reg-tn-p src))
+ (emit-byte segment #b11011101)
+ (emit-fp-op segment src #b100)))
+
+(define-instruction ftst (segment)
+ (:printer floating-point-no ((op #b00100)))
+ (:emitter
+ (emit-byte segment #b11011001)
+ (emit-byte segment #b11100100)))
+
+;;;; 80387 specials
+
+(define-instruction fsqrt(segment)
+ (:printer floating-point-no ((op #b11010)))
+ (:emitter
+ (emit-byte segment #b11011001)
+ (emit-byte segment #b11111010)))
+
+(define-instruction fscale(segment)
+ (:printer floating-point-no ((op #b11101)))
+ (:emitter
+ (emit-byte segment #b11011001)
+ (emit-byte segment #b11111101)))
+
+(define-instruction fxtract(segment)
+ (:printer floating-point-no ((op #b10100)))
+ (:emitter
+ (emit-byte segment #b11011001)
+ (emit-byte segment #b11110100)))
+
+(define-instruction fsin(segment)
+ (:printer floating-point-no ((op #b11110)))
+ (:emitter
+ (emit-byte segment #b11011001)
+ (emit-byte segment #b11111110)))
+
+(define-instruction fcos(segment)
+ (:printer floating-point-no ((op #b11111)))
+ (:emitter
+ (emit-byte segment #b11011001)
+ (emit-byte segment #b11111111)))
+
+(define-instruction fprem1(segment)
+ (:printer floating-point-no ((op #b10101)))
+ (:emitter
+ (emit-byte segment #b11011001)
+ (emit-byte segment #b11110101)))
+
+(define-instruction fprem(segment)
+ (:printer floating-point-no ((op #b11000)))
+ (:emitter
+ (emit-byte segment #b11011001)
+ (emit-byte segment #b11111000)))
+
+(define-instruction fxam (segment)
+ (:printer floating-point-no ((op #b00101)))
+ (:emitter
+ (emit-byte segment #b11011001)
+ (emit-byte segment #b11100101)))
+
+;;; These do push/pop to stack and need special handling
+;;; in any VOPs that use them. See the book.
+
+;;; st0 <- st1*log2(st0)
+(define-instruction fyl2x(segment) ; pops stack
+ (:printer floating-point-no ((op #b10001)))
+ (:emitter
+ (emit-byte segment #b11011001)
+ (emit-byte segment #b11110001)))
+
+(define-instruction fyl2xp1(segment)
+ (:printer floating-point-no ((op #b11001)))
+ (:emitter
+ (emit-byte segment #b11011001)
+ (emit-byte segment #b11111001)))
+
+(define-instruction f2xm1(segment)
+ (:printer floating-point-no ((op #b10000)))
+ (:emitter
+ (emit-byte segment #b11011001)
+ (emit-byte segment #b11110000)))
+
+(define-instruction fptan(segment) ; st(0) <- 1; st(1) <- tan
+ (:printer floating-point-no ((op #b10010)))
+ (:emitter
+ (emit-byte segment #b11011001)
+ (emit-byte segment #b11110010)))
+
+(define-instruction fpatan(segment) ; POPS STACK
+ (:printer floating-point-no ((op #b10011)))
+ (:emitter
+ (emit-byte segment #b11011001)
+ (emit-byte segment #b11110011)))
+
+;;;; loading constants
+
+(define-instruction fldz(segment)
+ (:printer floating-point-no ((op #b01110)))
+ (:emitter
+ (emit-byte segment #b11011001)
+ (emit-byte segment #b11101110)))
+
+(define-instruction fld1(segment)
+ (:printer floating-point-no ((op #b01000)))
+ (:emitter
+ (emit-byte segment #b11011001)
+ (emit-byte segment #b11101000)))
+
+(define-instruction fldpi(segment)
+ (:printer floating-point-no ((op #b01011)))
+ (:emitter
+ (emit-byte segment #b11011001)
+ (emit-byte segment #b11101011)))
+
+(define-instruction fldl2t(segment)
+ (:printer floating-point-no ((op #b01001)))
+ (:emitter
+ (emit-byte segment #b11011001)
+ (emit-byte segment #b11101001)))
+
+(define-instruction fldl2e(segment)
+ (:printer floating-point-no ((op #b01010)))
+ (:emitter
+ (emit-byte segment #b11011001)
+ (emit-byte segment #b11101010)))
+
+(define-instruction fldlg2(segment)
+ (:printer floating-point-no ((op #b01100)))
+ (:emitter
+ (emit-byte segment #b11011001)
+ (emit-byte segment #b11101100)))
+
+(define-instruction fldln2(segment)
+ (:printer floating-point-no ((op #b01101)))
+ (:emitter
+ (emit-byte segment #b11011001)
+ (emit-byte segment #b11101101)))
--- /dev/null
+;;;; a bunch of handy macros for the x86
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!VM")
+
+(file-comment
+ "$Header$")
+
+;;; We can load/store into fp registers through the top of
+;;; stack %st(0) (fr0 here). Loads imply a push to an empty register
+;;; which then changes all the reg numbers. These macros help manage that.
+
+;;; Use this when we don't have to load anything. It preserves old tos value,
+;;; but probably destroys tn with operation.
+(defmacro with-tn@fp-top((tn) &body body)
+ `(progn
+ (unless (zerop (tn-offset ,tn))
+ (inst fxch ,tn))
+ ,@body
+ (unless (zerop (tn-offset ,tn))
+ (inst fxch ,tn))))
+
+;;; Use this to prepare for load of new value from memory. This
+;;; changes the register numbering so the next instruction had better
+;;; be a FP load from memory; a register load from another register
+;;; will probably be loading the wrong register!
+(defmacro with-empty-tn@fp-top((tn) &body body)
+ `(progn
+ (inst fstp ,tn)
+ ,@body
+ (unless (zerop (tn-offset ,tn))
+ (inst fxch ,tn)))) ; save into new dest and restore st(0)
+\f
+;;;; instruction-like macros
+
+(defmacro move (dst src)
+ #!+sb-doc
+ "Move SRC into DST unless they are location=."
+ (once-only ((n-dst dst)
+ (n-src src))
+ `(unless (location= ,n-dst ,n-src)
+ (inst mov ,n-dst ,n-src))))
+
+(defmacro make-ea-for-object-slot (ptr slot lowtag)
+ `(make-ea :dword :base ,ptr :disp (- (* ,slot word-bytes) ,lowtag)))
+
+(defmacro loadw (value ptr &optional (slot 0) (lowtag 0))
+ `(inst mov ,value (make-ea-for-object-slot ,ptr ,slot ,lowtag)))
+
+(defmacro storew (value ptr &optional (slot 0) (lowtag 0))
+ (once-only ((value value))
+ `(inst mov (make-ea-for-object-slot ,ptr ,slot ,lowtag) ,value)))
+
+(defmacro pushw (ptr &optional (slot 0) (lowtag 0))
+ `(inst push (make-ea-for-object-slot ,ptr ,slot ,lowtag)))
+
+(defmacro popw (ptr &optional (slot 0) (lowtag 0))
+ `(inst pop (make-ea-for-object-slot ,ptr ,slot ,lowtag)))
+\f
+;;;; macros to generate useful values
+
+(defmacro load-symbol (reg symbol)
+ `(inst mov ,reg (+ *nil-value* (static-symbol-offset ,symbol))))
+
+(defmacro load-symbol-value (reg symbol)
+ `(inst mov ,reg
+ (make-ea :dword
+ :disp (+ *nil-value*
+ (static-symbol-offset ',symbol)
+ (ash symbol-value-slot word-shift)
+ (- other-pointer-type)))))
+
+(defmacro store-symbol-value (reg symbol)
+ `(inst mov
+ (make-ea :dword
+ :disp (+ *nil-value*
+ (static-symbol-offset ',symbol)
+ (ash symbol-value-slot word-shift)
+ (- other-pointer-type)))
+ ,reg))
+
+
+(defmacro load-type (target source &optional (offset 0))
+ #!+sb-doc
+ "Loads the type bits of a pointer into target independent of
+ byte-ordering issues."
+ (once-only ((n-target target)
+ (n-source source)
+ (n-offset offset))
+ (ecase *backend-byte-order*
+ (:little-endian
+ `(inst mov ,n-target
+ (make-ea :byte :base ,n-source :disp ,n-offset)))
+ (:big-endian
+ `(inst mov ,n-target
+ (make-ea :byte :base ,n-source :disp (+ ,n-offset 3)))))))
+\f
+;;;; allocation helpers
+
+;;; Two allocation approaches are implemented. A call into C can be
+;;; used, and in that case special care can be taken to disable
+;;; interrupts. Alternatively with gencgc inline allocation is possible
+;;; although it isn't interrupt safe.
+
+;;; For GENCGC it is possible to inline object allocation, to permit
+;;; this set the following variable to True.
+;;;
+;;; FIXME: The comment above says that this isn't interrupt safe. Is that
+;;; right? If so, do we want to do this? And surely we don't want to do this by
+;;; default? How much time does it save to do this? Is it any different in the
+;;; current CMU CL version instead of the one that I grabbed in 1998?
+;;; (Later observation: In order to be interrupt safe, it'd probably
+;;; have to use PSEUDO-ATOMIC, so it's probably not -- yuck. Try benchmarks
+;;; with and without inline allocation, and unless the inline allocation
+;;; wins by a whole lot, it's not likely to be worth messing with. If
+;;; we want to hack up memory allocation for performance, effort spent
+;;; on DYNAMIC-EXTENT would probably give a better payoff.)
+(defvar *maybe-use-inline-allocation* t)
+
+;;; Call into C.
+;;;
+;;; FIXME: Except when inline allocation is enabled..?
+;;;
+;;; FIXME: Also, calls to
+;;; ALLOCATION are always wrapped with PSEUDO-ATOMIC -- why? Is it to
+;;; make sure that no GC happens between the time of allocation and the
+;;; time that the allocated memory has its tag bits set correctly?
+;;; If so, then ALLOCATION itself might as well set the PSEUDO-ATOMIC
+;;; bits, so that the caller need only clear them. Check whether it's
+;;; true that every ALLOCATION is surrounded by PSEUDO-ATOMIC, and
+;;; that every PSEUDO-ATOMIC contains a single ALLOCATION, which is
+;;; its first instruction. If so, the connection should probably be
+;;; formalized, in documentation and in macro definition,
+;;; with the macro becoming e.g. PSEUDO-ATOMIC-ALLOCATION.
+(defun allocation (alloc-tn size &optional inline)
+ #!+sb-doc
+ "Emit code to allocate an object with a size in bytes given by Size.
+ The size may be an integer of a TN.
+ If Inline is a VOP node-var then it is used to make an appropriate
+ speed vs size decision."
+ (flet ((load-size (dst-tn size)
+ (unless (and (tn-p size) (location= alloc-tn size))
+ (inst mov dst-tn size))))
+ (let ((alloc-tn-offset (tn-offset alloc-tn)))
+ ;; FIXME: All these (MAKE-FIXUP (EXTERN-ALIEN-NAME "foo") :FOREIGN)
+ ;; expressions should be moved into MACROLET ((ALIEN-FIXUP ..)),
+ ;; and INST CALL (MAKE-FIXUP ..) should become CALL-ALIEN-FIXUP.
+ (if (and #!+gencgc t #!-gencgc nil
+ *maybe-use-inline-allocation*
+ (or (null inline) (policy inline (>= speed space))))
+ ;; Inline allocation with GENCGC.
+ (let ((ok (gen-label)))
+ ;; Load the size first so that the size can be in the same
+ ;; register as alloc-tn.
+ (load-size alloc-tn size)
+ (inst add alloc-tn
+ (make-fixup (extern-alien-name "current_region_free_pointer")
+ :foreign))
+ (inst cmp alloc-tn
+ (make-fixup (extern-alien-name "current_region_end_addr")
+ :foreign))
+ (inst jmp :be OK)
+ ;; Dispatch to the appropriate overflow routine. There is a
+ ;; routine for each destination.
+ ;; FIXME: Could we use an alist here instead of an ECASE with lots
+ ;; of duplicate code? (and similar question for next ECASE, too)
+ (ecase alloc-tn-offset
+ (#.eax-offset ;; FIXME: Why the #\# #\.?
+ (inst call (make-fixup (extern-alien-name "alloc_overflow_eax")
+ :foreign)))
+ (#.ecx-offset
+ (inst call (make-fixup (extern-alien-name "alloc_overflow_ecx")
+ :foreign)))
+ (#.edx-offset
+ (inst call (make-fixup (extern-alien-name "alloc_overflow_edx")
+ :foreign)))
+ (#.ebx-offset
+ (inst call (make-fixup (extern-alien-name "alloc_overflow_ebx")
+ :foreign)))
+ (#.esi-offset
+ (inst call (make-fixup (extern-alien-name "alloc_overflow_esi")
+ :foreign)))
+ (#.edi-offset
+ (inst call (make-fixup (extern-alien-name "alloc_overflow_edi")
+ :foreign))))
+ (emit-label ok)
+ (inst xchg (make-fixup
+ (extern-alien-name "current_region_free_pointer")
+ :foreign)
+ alloc-tn))
+ ;; C call to allocate via dispatch routines. Each
+ ;; destination has a special entry point. The size may be a
+ ;; register or a constant.
+ (ecase alloc-tn-offset
+ (#.eax-offset
+ (case size
+ (8 (inst call (make-fixup (extern-alien-name "alloc_8_to_eax")
+ :foreign)))
+ (16 (inst call (make-fixup (extern-alien-name "alloc_16_to_eax")
+ :foreign)))
+ (t
+ (load-size eax-tn size)
+ (inst call (make-fixup (extern-alien-name "alloc_to_eax")
+ :foreign)))))
+ (#.ecx-offset
+ (case size
+ (8 (inst call (make-fixup (extern-alien-name "alloc_8_to_ecx")
+ :foreign)))
+ (16 (inst call (make-fixup (extern-alien-name "alloc_16_to_ecx")
+ :foreign)))
+ (t
+ (load-size ecx-tn size)
+ (inst call (make-fixup (extern-alien-name "alloc_to_ecx")
+ :foreign)))))
+ (#.edx-offset
+ (case size
+ (8 (inst call (make-fixup (extern-alien-name "alloc_8_to_edx")
+ :foreign)))
+ (16 (inst call (make-fixup (extern-alien-name "alloc_16_to_edx")
+ :foreign)))
+ (t
+ (load-size edx-tn size)
+ (inst call (make-fixup (extern-alien-name "alloc_to_edx")
+ :foreign)))))
+ (#.ebx-offset
+ (case size
+ (8 (inst call (make-fixup (extern-alien-name "alloc_8_to_ebx")
+ :foreign)))
+ (16 (inst call (make-fixup (extern-alien-name "alloc_16_to_ebx")
+ :foreign)))
+ (t
+ (load-size ebx-tn size)
+ (inst call (make-fixup (extern-alien-name "alloc_to_ebx")
+ :foreign)))))
+ (#.esi-offset
+ (case size
+ (8 (inst call (make-fixup (extern-alien-name "alloc_8_to_esi")
+ :foreign)))
+ (16 (inst call (make-fixup (extern-alien-name "alloc_16_to_esi")
+ :foreign)))
+ (t
+ (load-size esi-tn size)
+ (inst call (make-fixup (extern-alien-name "alloc_to_esi")
+ :foreign)))))
+ (#.edi-offset
+ (case size
+ (8 (inst call (make-fixup (extern-alien-name "alloc_8_to_edi")
+ :foreign)))
+ (16 (inst call (make-fixup (extern-alien-name "alloc_16_to_edi")
+ :foreign)))
+ (t
+ (load-size edi-tn size)
+ (inst call (make-fixup (extern-alien-name "alloc_to_edi")
+ :foreign)))))))))
+ (values))
+
+(defmacro with-fixed-allocation ((result-tn type-code size &optional inline)
+ &rest forms)
+ #!+sb-doc
+ "Allocate an other-pointer object of fixed Size with a single
+ word header having the specified Type-Code. The result is placed in
+ Result-TN."
+ `(pseudo-atomic
+ (allocation ,result-tn (pad-data-block ,size) ,inline)
+ (storew (logior (ash (1- ,size) sb!vm:type-bits) ,type-code) ,result-tn)
+ (inst lea ,result-tn
+ (make-ea :byte :base ,result-tn :disp other-pointer-type))
+ ,@forms))
+
+\f
+;;;; error code
+
+(defvar *adjustable-vectors* nil)
+
+(defmacro with-adjustable-vector ((var) &rest body)
+ `(let ((,var (or (pop *adjustable-vectors*)
+ (make-array 16
+ :element-type '(unsigned-byte 8)
+ :fill-pointer 0
+ :adjustable t))))
+ (setf (fill-pointer ,var) 0)
+ (unwind-protect
+ (progn
+ ,@body)
+ (push ,var *adjustable-vectors*))))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defun emit-error-break (vop kind code values)
+ (let ((vector (gensym)))
+ `((inst int 3) ; i386 breakpoint instruction
+ ;; The return PC points here; note the location for the debugger.
+ (let ((vop ,vop))
+ (when vop
+ (note-this-location vop :internal-error)))
+ (inst byte ,kind) ; eg trap_Xyyy
+ (with-adjustable-vector (,vector) ; interr arguments
+ (write-var-integer (error-number-or-lose ',code) ,vector)
+ ,@(mapcar (lambda (tn)
+ `(let ((tn ,tn))
+ ;; classic CMU CL comment:
+ ;; zzzzz jrd here. tn-offset is zero for constant
+ ;; tns.
+ (write-var-integer (make-sc-offset (sc-number
+ (tn-sc tn))
+ (or (tn-offset tn)
+ 0))
+ ,vector)))
+ values)
+ (inst byte (length ,vector))
+ (dotimes (i (length ,vector))
+ (inst byte (aref ,vector i))))))))
+
+(defmacro error-call (vop error-code &rest values)
+ #!+sb-doc
+ "Cause an error. ERROR-CODE is the error to cause."
+ (cons 'progn
+ (emit-error-break vop error-trap error-code values)))
+
+;;; not used in SBCL
+#|
+(defmacro cerror-call (vop label error-code &rest values)
+ #!+sb-doc
+ "Cause a continuable error. If the error is continued, execution resumes
+ at LABEL."
+ `(progn
+ ,@(emit-error-break vop cerror-trap error-code values)
+ (inst jmp ,label)))
+|#
+
+(defmacro generate-error-code (vop error-code &rest values)
+ #!+sb-doc
+ "Generate-Error-Code Error-code Value*
+ Emit code for an error with the specified Error-Code and context Values."
+ `(assemble (*elsewhere*)
+ (let ((start-lab (gen-label)))
+ (emit-label start-lab)
+ (error-call ,vop ,error-code ,@values)
+ start-lab)))
+
+;;; not used in SBCL
+#|
+(defmacro generate-cerror-code (vop error-code &rest values)
+ #!+sb-doc
+ "Generate-CError-Code Error-code Value*
+ Emit code for a continuable error with the specified Error-Code and
+ context Values. If the error is continued, execution resumes after
+ the GENERATE-CERROR-CODE form."
+ (let ((continue (gensym "CONTINUE-LABEL-"))
+ (error (gensym "ERROR-LABEL-")))
+ `(let ((,continue (gen-label))
+ (,error (gen-label)))
+ (emit-label ,continue)
+ (assemble (*elsewhere*)
+ (emit-label ,error)
+ (cerror-call ,vop ,continue ,error-code ,@values))
+ ,error)))
+|#
+\f
+;;;; PSEUDO-ATOMIC
+
+;;; FIXME: This should be a compile-time option, not a runtime option. Doing it
+;;; at runtime is bizarre. As I understand it, the default should definitely be
+;;; to have pseudo-atomic behavior, but for a performance-critical program
+;;; which is guaranteed not to have asynchronous exceptions, it could be worth
+;;; something to compile with :SB-NO-PSEUDO-ATOMIC.
+(defvar *enable-pseudo-atomic* t)
+
+;;; FIXME: *PSEUDO-ATOMIC-ATOMIC* and *PSEUDO-ATOMIC-INTERRUPTED*
+;;; should be in package SB!VM or SB!KERNEL, not SB!IMPL.
+
+;;; FIXME: *PSEUDO-ATOMIC-FOO* could be made into *PSEUDO-ATOMIC-BITS*,
+;;; set with a single operation and cleared with SHR *PSEUDO-ATOMIC-BITS*,-2;
+;;; the ATOMIC bit is bit 0, the INTERRUPTED bit is bit 1, and you check
+;;; the C flag after the shift to see whether you were interrupted.
+
+;;; FIXME: It appears that PSEUDO-ATOMIC is used to wrap operations which leave
+;;; untagged memory lying around, but some documentation would be nice.
+(defmacro pseudo-atomic (&rest forms)
+ (let ((label (gensym "LABEL-")))
+ `(let ((,label (gen-label)))
+ (when *enable-pseudo-atomic*
+ ;; FIXME: The MAKE-EA noise should become a MACROLET macro or
+ ;; something. (perhaps SVLB, for static variable low byte)
+ (inst mov (make-ea :byte :disp (+ *nil-value*
+ (static-symbol-offset
+ 'sb!impl::*pseudo-atomic-interrupted*)
+ (ash symbol-value-slot word-shift)
+ ;; FIXME: Use mask, not minus, to
+ ;; take out type bits.
+ (- other-pointer-type)))
+ 0)
+ (inst mov (make-ea :byte :disp (+ *nil-value*
+ (static-symbol-offset
+ 'sb!impl::*pseudo-atomic-atomic*)
+ (ash symbol-value-slot word-shift)
+ (- other-pointer-type)))
+ (fixnumize 1)))
+ ,@forms
+ (when *enable-pseudo-atomic*
+ (inst mov (make-ea :byte :disp (+ *nil-value*
+ (static-symbol-offset
+ 'sb!impl::*pseudo-atomic-atomic*)
+ (ash symbol-value-slot word-shift)
+ (- other-pointer-type)))
+ 0)
+ ;; KLUDGE: Is there any requirement for interrupts to be
+ ;; handled in order? It seems as though an interrupt coming
+ ;; in at this point will be executed before any pending interrupts.
+ ;; Or do incoming interrupts check to see whether any interrupts
+ ;; are pending? I wish I could find the documentation for
+ ;; pseudo-atomics.. -- WHN 19991130
+ (inst cmp (make-ea :byte
+ :disp (+ *nil-value*
+ (static-symbol-offset
+ 'sb!impl::*pseudo-atomic-interrupted*)
+ (ash symbol-value-slot word-shift)
+ (- other-pointer-type)))
+ 0)
+ (inst jmp :eq ,label)
+ (inst break pending-interrupt-trap)
+ (emit-label ,label)))))
+\f
+;;;; indexed references
+
+(defmacro define-full-reffer (name type offset lowtag scs el-type &optional translate)
+ `(progn
+ (define-vop (,name)
+ ,@(when translate
+ `((:translate ,translate)))
+ (:policy :fast-safe)
+ (:args (object :scs (descriptor-reg))
+ (index :scs (any-reg)))
+ (:arg-types ,type tagged-num)
+ (:results (value :scs ,scs))
+ (:result-types ,el-type)
+ (:generator 3 ; pw was 5
+ (inst mov value (make-ea :dword :base object :index index
+ :disp (- (* ,offset word-bytes) ,lowtag)))))
+ (define-vop (,(symbolicate name "-C"))
+ ,@(when translate
+ `((:translate ,translate)))
+ (:policy :fast-safe)
+ (:args (object :scs (descriptor-reg)))
+ (:info index)
+ (:arg-types ,type (:constant (signed-byte 30)))
+ (:results (value :scs ,scs))
+ (:result-types ,el-type)
+ (:generator 2 ; pw was 5
+ (inst mov value (make-ea :dword :base object
+ :disp (- (* (+ ,offset index) word-bytes)
+ ,lowtag)))))))
+
+(defmacro define-full-setter (name type offset lowtag scs el-type &optional translate)
+ `(progn
+ (define-vop (,name)
+ ,@(when translate
+ `((:translate ,translate)))
+ (:policy :fast-safe)
+ (:args (object :scs (descriptor-reg))
+ (index :scs (any-reg))
+ (value :scs ,scs :target result))
+ (:arg-types ,type tagged-num ,el-type)
+ (:results (result :scs ,scs))
+ (:result-types ,el-type)
+ (:generator 4 ; was 5
+ (inst mov (make-ea :dword :base object :index index
+ :disp (- (* ,offset word-bytes) ,lowtag))
+ value)
+ (move result value)))
+ (define-vop (,(symbolicate name "-C"))
+ ,@(when translate
+ `((:translate ,translate)))
+ (:policy :fast-safe)
+ (:args (object :scs (descriptor-reg))
+ (value :scs ,scs :target result))
+ (:info index)
+ (:arg-types ,type (:constant (signed-byte 30)) ,el-type)
+ (:results (result :scs ,scs))
+ (:result-types ,el-type)
+ (:generator 3 ; was 5
+ (inst mov (make-ea :dword :base object
+ :disp (- (* (+ ,offset index) word-bytes) ,lowtag))
+ value)
+ (move result value)))))
+
--- /dev/null
+;;;; the x86 definitions of some general purpose memory reference VOPs
+;;;; inherited by basic memory reference operations
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!VM")
+
+(file-comment
+ "$Header$")
+
+;;; Cell-Ref and Cell-Set are used to define VOPs like CAR, where the
+;;; offset to be read or written is a property of the VOP used.
+;;; Cell-Setf is similar to Cell-Set, but delivers the new value as
+;;; the result. Cell-Setf-Function takes its arguments as if it were a
+;;; setf function (new value first, as apposed to a setf macro, which
+;;; takes the new value last).
+(define-vop (cell-ref)
+ (:args (object :scs (descriptor-reg)))
+ (:results (value :scs (descriptor-reg any-reg)))
+ (:variant-vars offset lowtag)
+ (:policy :fast-safe)
+ (:generator 4
+ (loadw value object offset lowtag)))
+(define-vop (cell-set)
+ (:args (object :scs (descriptor-reg))
+ (value :scs (descriptor-reg any-reg)))
+ (:variant-vars offset lowtag)
+ (:policy :fast-safe)
+ (:generator 4
+ (storew value object offset lowtag)))
+(define-vop (cell-setf)
+ (:args (object :scs (descriptor-reg))
+ (value :scs (descriptor-reg any-reg) :target result))
+ (:results (result :scs (descriptor-reg any-reg)))
+ (:variant-vars offset lowtag)
+ (:policy :fast-safe)
+ (:generator 4
+ (storew value object offset lowtag)
+ (move result value)))
+(define-vop (cell-setf-function)
+ (:args (value :scs (descriptor-reg any-reg) :target result)
+ (object :scs (descriptor-reg)))
+ (:results (result :scs (descriptor-reg any-reg)))
+ (:variant-vars offset lowtag)
+ (:policy :fast-safe)
+ (:generator 4
+ (storew value object offset lowtag)
+ (move result value)))
+
+;;; Define accessor VOPs for some cells in an object. If the operation name
+;;; is NIL, then that operation isn't defined. If the translate function is
+;;; null, then we don't define a translation.
+(defmacro define-cell-accessors (offset lowtag
+ ref-op ref-trans set-op set-trans)
+ `(progn
+ ,@(when ref-op
+ `((define-vop (,ref-op cell-ref)
+ (:variant ,offset ,lowtag)
+ ,@(when ref-trans
+ `((:translate ,ref-trans))))))
+ ,@(when set-op
+ `((define-vop (,set-op cell-setf)
+ (:variant ,offset ,lowtag)
+ ,@(when set-trans
+ `((:translate ,set-trans))))))))
+
+;;; X86 special
+(define-vop (cell-xadd)
+ (:args (object :scs (descriptor-reg) :to :result)
+ (value :scs (any-reg) :target result))
+ (:results (result :scs (any-reg) :from (:argument 1)))
+ (:result-types tagged-num)
+ (:variant-vars offset lowtag)
+ (:policy :fast-safe)
+ (:generator 4
+ (move result value)
+ (inst xadd (make-ea :dword :base object
+ :disp (- (* offset word-bytes) lowtag))
+ value)))
+
+;;; Slot-Ref and Slot-Set are used to define VOPs like Closure-Ref, where the
+;;; offset is constant at compile time, but varies for different uses.
+(define-vop (slot-ref)
+ (:args (object :scs (descriptor-reg)))
+ (:results (value :scs (descriptor-reg any-reg)))
+ (:variant-vars base lowtag)
+ (:info offset)
+ (:generator 4
+ (loadw value object (+ base offset) lowtag)))
+(define-vop (slot-set)
+ (:args (object :scs (descriptor-reg))
+ (value :scs (descriptor-reg any-reg immediate)))
+ (:variant-vars base lowtag)
+ (:info offset)
+ (:generator 4
+ (if (sc-is value immediate)
+ (let ((val (tn-value value)))
+ (etypecase val
+ (integer
+ (inst mov
+ (make-ea :dword :base object
+ :disp (- (* (+ base offset) word-bytes) lowtag))
+ (fixnumize val)))
+ (symbol
+ (inst mov
+ (make-ea :dword :base object
+ :disp (- (* (+ base offset) word-bytes) lowtag))
+ (+ *nil-value* (static-symbol-offset val))))
+ (character
+ (inst mov
+ (make-ea :dword :base object
+ :disp (- (* (+ base offset) word-bytes) lowtag))
+ (logior (ash (char-code val) type-bits)
+ base-char-type)))))
+ ;; Else, value not immediate.
+ (storew value object (+ base offset) lowtag))))
+
+(define-vop (slot-set-conditional)
+ (:args (object :scs (descriptor-reg) :to :eval)
+ (old-value :scs (descriptor-reg any-reg) :target eax)
+ (new-value :scs (descriptor-reg any-reg) :target temp))
+ (:temporary (:sc descriptor-reg :offset eax-offset
+ :from (:argument 1) :to :result :target result) eax)
+ (:temporary (:sc descriptor-reg :from (:argument 2) :to :result) temp)
+ (:variant-vars base lowtag)
+ (:results (result :scs (descriptor-reg)))
+ (:info offset)
+ (:generator 4
+ (move eax old-value)
+ (move temp new-value)
+ (inst cmpxchg (make-ea :dword :base object
+ :disp (- (* (+ base offset) word-bytes) lowtag))
+ temp)
+ (move result eax)))
+
+;;; X86 special
+(define-vop (slot-xadd)
+ (:args (object :scs (descriptor-reg) :to :result)
+ (value :scs (any-reg) :target result))
+ (:results (result :scs (any-reg) :from (:argument 1)))
+ (:result-types tagged-num)
+ (:variant-vars base lowtag)
+ (:info offset)
+ (:generator 4
+ (move result value)
+ (inst xadd (make-ea :dword :base object
+ :disp (- (* (+ base offset) word-bytes) lowtag))
+ value)))
--- /dev/null
+;;;; the x86 VM definition of operand loading/saving and the MOVE vop
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!VM")
+
+(file-comment
+ "$Header$")
+
+(define-move-function (load-immediate 1) (vop x y)
+ ((immediate)
+ (any-reg descriptor-reg))
+ (let ((val (tn-value x)))
+ (etypecase val
+ (integer
+ (if (zerop val)
+ (inst xor y y)
+ (inst mov y (fixnumize val))))
+ (symbol
+ (load-symbol y val))
+ (character
+ (inst mov y (logior (ash (char-code val) type-bits)
+ base-char-type))))))
+
+(define-move-function (load-number 1) (vop x y)
+ ((immediate) (signed-reg unsigned-reg))
+ (inst mov y (tn-value x)))
+
+(define-move-function (load-base-char 1) (vop x y)
+ ((immediate) (base-char-reg))
+ (inst mov y (char-code (tn-value x))))
+
+(define-move-function (load-system-area-pointer 1) (vop x y)
+ ((immediate) (sap-reg))
+ (inst mov y (sap-int (tn-value x))))
+
+(define-move-function (load-constant 5) (vop x y)
+ ((constant) (descriptor-reg any-reg))
+ (inst mov y x))
+
+(define-move-function (load-stack 5) (vop x y)
+ ((control-stack) (any-reg descriptor-reg)
+ (base-char-stack) (base-char-reg)
+ (sap-stack) (sap-reg)
+ (signed-stack) (signed-reg)
+ (unsigned-stack) (unsigned-reg))
+ (inst mov y x))
+
+(define-move-function (store-stack 5) (vop x y)
+ ((any-reg descriptor-reg) (control-stack)
+ (base-char-reg) (base-char-stack)
+ (sap-reg) (sap-stack)
+ (signed-reg) (signed-stack)
+ (unsigned-reg) (unsigned-stack))
+ (inst mov y x))
+\f
+;;;; the MOVE VOP
+(define-vop (move)
+ (:args (x :scs (any-reg descriptor-reg immediate) :target y
+ :load-if (not (location= x y))))
+ (:results (y :scs (any-reg descriptor-reg)
+ :load-if
+ (not (or (location= x y)
+ (and (sc-is x any-reg descriptor-reg immediate)
+ (sc-is y control-stack))))))
+ (:effects)
+ (:affected)
+ (:generator 0
+ (if (and (sc-is x immediate)
+ (sc-is y any-reg descriptor-reg control-stack))
+ (let ((val (tn-value x)))
+ (etypecase val
+ (integer
+ (if (and (zerop val) (sc-is y any-reg descriptor-reg))
+ (inst xor y y)
+ (inst mov y (fixnumize val))))
+ (symbol
+ (inst mov y (+ *nil-value* (static-symbol-offset val))))
+ (character
+ (inst mov y (logior (ash (char-code val) type-bits)
+ base-char-type)))))
+ (move y x))))
+
+(define-move-vop move :move
+ (any-reg descriptor-reg immediate)
+ (any-reg descriptor-reg))
+
+;;; Make Move the check VOP for T so that type check generation
+;;; doesn't think it is a hairy type. This also allows checking of a
+;;; few of the values in a continuation to fall out.
+(primitive-type-vop move (:check) t)
+
+;;; The Move-Argument VOP is used for moving descriptor values into
+;;; another frame for argument or known value passing.
+;;;
+;;; Note: It is not going to be possible to move a constant directly
+;;; to another frame, except if the destination is a register and in
+;;; this case the loading works out.
+(define-vop (move-argument)
+ (:args (x :scs (any-reg descriptor-reg immediate) :target y
+ :load-if (not (and (sc-is y any-reg descriptor-reg)
+ (sc-is x control-stack))))
+ (fp :scs (any-reg)
+ :load-if (not (sc-is y any-reg descriptor-reg))))
+ (:results (y))
+ (:generator 0
+ (sc-case y
+ ((any-reg descriptor-reg)
+ (if (sc-is x immediate)
+ (let ((val (tn-value x)))
+ (etypecase val
+ (integer
+ (if (zerop val)
+ (inst xor y y)
+ (inst mov y (fixnumize val))))
+ (symbol
+ (load-symbol y val))
+ (character
+ (inst mov y (logior (ash (char-code val) type-bits)
+ base-char-type)))))
+ (move y x)))
+ ((control-stack)
+ (if (sc-is x immediate)
+ (let ((val (tn-value x)))
+ (if (= (tn-offset fp) esp-offset)
+ ;; C-call
+ (etypecase val
+ (integer
+ (storew (fixnumize val) fp (tn-offset y)))
+ (symbol
+ (storew (+ *nil-value* (static-symbol-offset val))
+ fp (tn-offset y)))
+ (character
+ (storew (logior (ash (char-code val) type-bits)
+ base-char-type)
+ fp (tn-offset y))))
+ ;; Lisp stack
+ (etypecase val
+ (integer
+ (storew (fixnumize val) fp (- (1+ (tn-offset y)))))
+ (symbol
+ (storew (+ *nil-value* (static-symbol-offset val))
+ fp (- (1+ (tn-offset y)))))
+ (character
+ (storew (logior (ash (char-code val) type-bits)
+ base-char-type)
+ fp (- (1+ (tn-offset y))))))))
+ (if (= (tn-offset fp) esp-offset)
+ ;; C-call
+ (storew x fp (tn-offset y))
+ ;; Lisp stack
+ (storew x fp (- (1+ (tn-offset y))))))))))
+
+(define-move-vop move-argument :move-argument
+ (any-reg descriptor-reg)
+ (any-reg descriptor-reg))
+\f
+;;;; ILLEGAL-MOVE
+
+;;; This VOP exists just to begin the lifetime of a TN that couldn't
+;;; be written legally due to a type error. An error is signalled
+;;; before this VOP is so we don't need to do anything (not that there
+;;; would be anything sensible to do anyway.)
+(define-vop (illegal-move)
+ (:args (x) (type))
+ (:results (y))
+ (:ignore y)
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:generator 666
+ (error-call vop object-not-type-error x type)))
+\f
+;;;; moves and coercions
+
+;;; These MOVE-TO-WORD VOPs move a tagged integer to a raw full-word
+;;; representation. Similarly, the MOVE-FROM-WORD VOPs converts a raw
+;;; integer to a tagged bignum or fixnum.
+
+;;; Arg is a fixnum, so just shift it. We need a type restriction
+;;; because some possible arg SCs (control-stack) overlap with
+;;; possible bignum arg SCs.
+(define-vop (move-to-word/fixnum)
+ (:args (x :scs (any-reg descriptor-reg) :target y
+ :load-if (not (location= x y))))
+ (:results (y :scs (signed-reg unsigned-reg)
+ :load-if (not (location= x y))))
+ (:arg-types tagged-num)
+ (:note "fixnum untagging")
+ (:generator 1
+ (move y x)
+ (inst sar y 2)))
+(define-move-vop move-to-word/fixnum :move
+ (any-reg descriptor-reg) (signed-reg unsigned-reg))
+
+;;; Arg is a non-immediate constant, load it.
+(define-vop (move-to-word-c)
+ (:args (x :scs (constant)))
+ (:results (y :scs (signed-reg unsigned-reg)))
+ (:note "constant load")
+ (:generator 1
+ (inst mov y (tn-value x))))
+(define-move-vop move-to-word-c :move
+ (constant) (signed-reg unsigned-reg))
+
+
+;;; Arg is a fixnum or bignum, figure out which and load if necessary.
+(define-vop (move-to-word/integer)
+ (:args (x :scs (descriptor-reg) :target eax))
+ (:results (y :scs (signed-reg unsigned-reg)))
+ (:note "integer to untagged word coercion")
+ (:temporary (:sc unsigned-reg :offset eax-offset
+ :from (:argument 0) :to (:result 0) :target y) eax)
+ (:generator 4
+ (move eax x)
+ (inst test al-tn 3)
+ (inst jmp :z fixnum)
+ (loadw y eax bignum-digits-offset other-pointer-type)
+ (inst jmp done)
+ FIXNUM
+ (inst sar eax 2)
+ (move y eax)
+ DONE))
+(define-move-vop move-to-word/integer :move
+ (descriptor-reg) (signed-reg unsigned-reg))
+
+
+;;; Result is a fixnum, so we can just shift. We need the result type
+;;; restriction because of the control-stack ambiguity noted above.
+(define-vop (move-from-word/fixnum)
+ (:args (x :scs (signed-reg unsigned-reg) :target y
+ :load-if (not (location= x y))))
+ (:results (y :scs (any-reg descriptor-reg)
+ :load-if (not (location= x y))))
+ (:result-types tagged-num)
+ (:note "fixnum tagging")
+ (:generator 1
+ (cond ((and (sc-is x signed-reg unsigned-reg)
+ (not (location= x y)))
+ ;; Uses 7 bytes, but faster on the Pentium
+ (inst lea y (make-ea :dword :index x :scale 4)))
+ (t
+ ;; Uses: If x is a reg 2 + 3; if x = y uses only 3 bytes
+ (move y x)
+ (inst shl y 2)))))
+(define-move-vop move-from-word/fixnum :move
+ (signed-reg unsigned-reg) (any-reg descriptor-reg))
+
+;;; Result may be a bignum, so we have to check. Use a worst-case cost
+;;; to make sure people know they may be number consing.
+;;;
+;;; KLUDGE: I assume this is suppressed in favor of the "faster inline
+;;; version" below. (See also mysterious comment "we don't want a VOP
+;;; on this one" on DEFINE-ASSEMBLY-ROUTINE (MOVE-FROM-SIGNED) in
+;;; "src/assembly/x86/alloc.lisp".) -- WHN 19990916
+#+nil
+(define-vop (move-from-signed)
+ (:args (x :scs (signed-reg unsigned-reg) :target eax))
+ (:temporary (:sc unsigned-reg :offset eax-offset :from (:argument 0)) eax)
+ (:temporary (:sc unsigned-reg :offset ebx-offset :to (:result 0) :target y)
+ ebx)
+ (:temporary (:sc unsigned-reg :offset ecx-offset
+ :from (:argument 0) :to (:result 0)) ecx)
+ (:ignore ecx)
+ (:results (y :scs (any-reg descriptor-reg)))
+ (:note "signed word to integer coercion")
+ (:generator 20
+ (move eax x)
+ (inst call (make-fixup 'move-from-signed :assembly-routine))
+ (move y ebx)))
+;;; Faster inline version,
+;;; KLUDGE: Do we really want the faster inline version? It's sorta big.
+;;; It is nice that it doesn't use any temporaries, though. -- WHN 19990916
+(define-vop (move-from-signed)
+ (:args (x :scs (signed-reg unsigned-reg) :to :result))
+ (:results (y :scs (any-reg descriptor-reg) :from :argument))
+ (:note "signed word to integer coercion")
+ (:node-var node)
+ (:generator 20
+ (assert (not (location= x y)))
+ (let ((bignum (gen-label))
+ (done (gen-label)))
+ (inst mov y x)
+ (inst shl y 1)
+ (inst jmp :o bignum)
+ (inst shl y 1)
+ (inst jmp :o bignum)
+ (emit-label done)
+ ;; KLUDGE: The sequence above leaves a DESCRIPTOR-REG Y in a
+ ;; non-descriptor state for a while. Does that matter? Does it matter in
+ ;; GENGC but not in GENCGC? Is this written down anywhere?
+ ;; -- WHN 19990916
+ ;;
+ ;; Also, the sequence above seems rather twisty. Why not something
+ ;; more obvious along the lines of
+ ;; inst move y x
+ ;; inst tst x #xc0000000
+ ;; inst jmp :nz bignum
+ ;; inst shl y 2
+ ;; emit-label done
+
+ (assemble (*elsewhere*)
+ (emit-label bignum)
+ (with-fixed-allocation
+ (y bignum-type (+ bignum-digits-offset 1) node)
+ (storew x y bignum-digits-offset other-pointer-type))
+ (inst jmp done)))))
+(define-move-vop move-from-signed :move
+ (signed-reg) (descriptor-reg))
+
+;;; Check for fixnum, and possibly allocate one or two word bignum
+;;; result. Use a worst-case cost to make sure people know they may be
+;;; number consing.
+#+nil
+(define-vop (move-from-unsigned)
+ (:args (x :scs (signed-reg unsigned-reg) :target eax))
+ (:temporary (:sc unsigned-reg :offset eax-offset :from (:argument 0)) eax)
+ (:temporary (:sc unsigned-reg :offset ebx-offset :to (:result 0) :target y)
+ ebx)
+ (:temporary (:sc unsigned-reg :offset ecx-offset
+ :from (:argument 0) :to (:result 0)) ecx)
+ (:ignore ecx)
+ (:results (y :scs (any-reg descriptor-reg)))
+ (:note "unsigned word to integer coercion")
+ (:generator 20
+ (move eax x)
+ (inst call (make-fixup 'move-from-unsigned :assembly-routine))
+ (move y ebx)))
+;;; Faster inline version.
+;;; KLUDGE: Do we really want the faster inline version? It seems awfully big..
+;;; If we really want speed, most likely it's only important in the non-consing
+;;; case, so how about about making the *ELSEWHERE* stuff into a subroutine? --
+;;; WHN 19990916
+(define-vop (move-from-unsigned)
+ (:args (x :scs (signed-reg unsigned-reg) :to :save))
+ (:temporary (:sc unsigned-reg) alloc)
+ (:results (y :scs (any-reg descriptor-reg)))
+ (:node-var node)
+ (:note "unsigned word to integer coercion")
+ (:generator 20
+ (assert (not (location= x y)))
+ (assert (not (location= x alloc)))
+ (assert (not (location= y alloc)))
+ (let ((bignum (gen-label))
+ (done (gen-label))
+ (one-word-bignum (gen-label))
+ (L1 (gen-label)))
+ (inst test x #xe0000000)
+ (inst jmp :nz bignum)
+ ;; Fixnum.
+ (inst lea y (make-ea :dword :index x :scale 4)) ; Faster but bigger.
+ ;(inst mov y x)
+ ;(inst shl y 2)
+ (emit-label done)
+
+ (assemble (*elsewhere*)
+ (emit-label bignum)
+ ;; Note: As on the mips port, space for a two word bignum is
+ ;; always allocated and the header size is set to either one
+ ;; or two words as appropriate.
+ (inst jmp :ns one-word-bignum)
+ ;; Two word bignum.
+ (inst mov y (logior (ash (1- (+ bignum-digits-offset 2))
+ sb!vm:type-bits)
+ bignum-type))
+ (inst jmp L1)
+ (emit-label one-word-bignum)
+ (inst mov y (logior (ash (1- (+ bignum-digits-offset 1))
+ sb!vm:type-bits)
+ bignum-type))
+ (emit-label L1)
+ (pseudo-atomic
+ (allocation alloc (pad-data-block (+ bignum-digits-offset 2)) node)
+ (storew y alloc)
+ (inst lea y (make-ea :byte :base alloc :disp other-pointer-type))
+ (storew x y bignum-digits-offset other-pointer-type))
+ (inst jmp done)))))
+(define-move-vop move-from-unsigned :move
+ (unsigned-reg) (descriptor-reg))
+
+;;; Move untagged numbers.
+(define-vop (word-move)
+ (:args (x :scs (signed-reg unsigned-reg) :target y
+ :load-if (not (location= x y))))
+ (:results (y :scs (signed-reg unsigned-reg)
+ :load-if
+ (not (or (location= x y)
+ (and (sc-is x signed-reg unsigned-reg)
+ (sc-is y signed-stack unsigned-stack))))))
+ (:effects)
+ (:affected)
+ (:note "word integer move")
+ (:generator 0
+ (move y x)))
+(define-move-vop word-move :move
+ (signed-reg unsigned-reg) (signed-reg unsigned-reg))
+
+;;; Move untagged number arguments/return-values.
+(define-vop (move-word-argument)
+ (:args (x :scs (signed-reg unsigned-reg) :target y)
+ (fp :scs (any-reg) :load-if (not (sc-is y sap-reg))))
+ (:results (y))
+ (:note "word integer argument move")
+ (:generator 0
+ (sc-case y
+ ((signed-reg unsigned-reg)
+ (move y x))
+ ((signed-stack unsigned-stack)
+ (if (= (tn-offset fp) esp-offset)
+ (storew x fp (tn-offset y)) ; c-call
+ (storew x fp (- (1+ (tn-offset y)))))))))
+(define-move-vop move-word-argument :move-argument
+ (descriptor-reg any-reg signed-reg unsigned-reg) (signed-reg unsigned-reg))
+
+;;; Use standard MOVE-ARGUMENT and coercion to move an untagged number
+;;; to a descriptor passing location.
+(define-move-vop move-argument :move-argument
+ (signed-reg unsigned-reg) (any-reg descriptor-reg))
--- /dev/null
+;;;; the definition of non-local exit for the x86 VM
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!VM")
+
+(file-comment
+ "$Header$")
+
+;;; Make an environment-live stack TN for saving the SP for NLX entry.
+(def-vm-support-routine make-nlx-sp-tn (env)
+ (environment-live-tn
+ (make-representation-tn *fixnum-primitive-type* any-reg-sc-number)
+ env))
+
+;;; Make a TN for the argument count passing location for a non-local entry.
+(def-vm-support-routine make-nlx-entry-argument-start-location ()
+ (make-wired-tn *fixnum-primitive-type* any-reg-sc-number ebx-offset))
+
+(defun catch-block-ea (tn)
+ (assert (sc-is tn catch-block))
+ (make-ea :dword :base ebp-tn
+ :disp (- (* (+ (tn-offset tn) catch-block-size) word-bytes))))
+
+\f
+;;;; Save and restore dynamic environment.
+;;;;
+;;;; These VOPs are used in the reentered function to restore the
+;;;; appropriate dynamic environment. Currently we only save the
+;;;; Current-Catch, the eval stack pointer, and the alien stack
+;;;; pointer.
+;;;;
+;;;; We don't need to save/restore the current unwind-protect, since
+;;;; unwind-protects are implicitly processed during unwinding.
+;;;;
+;;;; We don't need to save the BSP, because that is handled automatically.
+
+;;; Return a list of TNs that can be used to snapshot the dynamic state for
+;;; use with the Save/Restore-Dynamic-Environment VOPs.
+(def-vm-support-routine make-dynamic-state-tns ()
+ (make-n-tns 3 *backend-t-primitive-type*))
+
+(define-vop (save-dynamic-state)
+ (:results (catch :scs (descriptor-reg))
+ (eval :scs (descriptor-reg))
+ (alien-stack :scs (descriptor-reg)))
+ (:generator 13
+ (load-symbol-value catch sb!impl::*current-catch-block*)
+ (load-symbol-value eval sb!impl::*eval-stack-top*)
+ (load-symbol-value alien-stack *alien-stack*)))
+
+(define-vop (restore-dynamic-state)
+ (:args (catch :scs (descriptor-reg))
+ (eval :scs (descriptor-reg))
+ (alien-stack :scs (descriptor-reg)))
+ (:generator 10
+ (store-symbol-value catch sb!impl::*current-catch-block*)
+ (store-symbol-value eval sb!impl::*eval-stack-top*)
+ (store-symbol-value alien-stack *alien-stack*)))
+
+(define-vop (current-stack-pointer)
+ (:results (res :scs (any-reg control-stack)))
+ (:generator 1
+ (move res esp-tn)))
+
+(define-vop (current-binding-pointer)
+ (:results (res :scs (any-reg descriptor-reg)))
+ (:generator 1
+ (load-symbol-value res *binding-stack-pointer*)))
+\f
+;;;; unwind block hackery
+
+;;; Compute the address of the catch block from its TN, then store into the
+;;; block the current Fp, Env, Unwind-Protect, and the entry PC.
+(define-vop (make-unwind-block)
+ (:args (tn))
+ (:info entry-label)
+ (:temporary (:sc unsigned-reg) temp)
+ (:results (block :scs (any-reg)))
+ (:generator 22
+ (inst lea block (catch-block-ea tn))
+ (load-symbol-value temp sb!impl::*current-unwind-protect-block*)
+ (storew temp block unwind-block-current-uwp-slot)
+ (storew ebp-tn block unwind-block-current-cont-slot)
+ (storew (make-fixup nil :code-object entry-label)
+ block catch-block-entry-pc-slot)))
+
+;;; Like Make-Unwind-Block, except that we also store in the specified tag, and
+;;; link the block into the Current-Catch list.
+(define-vop (make-catch-block)
+ (:args (tn)
+ (tag :scs (descriptor-reg) :to (:result 1)))
+ (:info entry-label)
+ (:results (block :scs (any-reg)))
+ (:temporary (:sc descriptor-reg) temp)
+ (:generator 44
+ (inst lea block (catch-block-ea tn))
+ (load-symbol-value temp sb!impl::*current-unwind-protect-block*)
+ (storew temp block unwind-block-current-uwp-slot)
+ (storew ebp-tn block unwind-block-current-cont-slot)
+ (storew (make-fixup nil :code-object entry-label)
+ block catch-block-entry-pc-slot)
+ (storew tag block catch-block-tag-slot)
+ (load-symbol-value temp sb!impl::*current-catch-block*)
+ (storew temp block catch-block-previous-catch-slot)
+ (store-symbol-value block sb!impl::*current-catch-block*)))
+
+;;; Just set the current unwind-protect to TN's address. This instantiates an
+;;; unwind block as an unwind-protect.
+(define-vop (set-unwind-protect)
+ (:args (tn))
+ (:temporary (:sc unsigned-reg) new-uwp)
+ (:generator 7
+ (inst lea new-uwp (catch-block-ea tn))
+ (store-symbol-value new-uwp sb!impl::*current-unwind-protect-block*)))
+
+(define-vop (unlink-catch-block)
+ (:temporary (:sc unsigned-reg) block)
+ (:policy :fast-safe)
+ (:translate %catch-breakup)
+ (:generator 17
+ (load-symbol-value block sb!impl::*current-catch-block*)
+ (loadw block block catch-block-previous-catch-slot)
+ (store-symbol-value block sb!impl::*current-catch-block*)))
+
+(define-vop (unlink-unwind-protect)
+ (:temporary (:sc unsigned-reg) block)
+ (:policy :fast-safe)
+ (:translate %unwind-protect-breakup)
+ (:generator 17
+ (load-symbol-value block sb!impl::*current-unwind-protect-block*)
+ (loadw block block unwind-block-current-uwp-slot)
+ (store-symbol-value block sb!impl::*current-unwind-protect-block*)))
+\f
+;;;; NLX entry VOPs
+(define-vop (nlx-entry)
+ ;; Note: we can't list an sc-restriction, 'cause any load vops would
+ ;; be inserted before the return-pc label.
+ (:args (sp)
+ (start)
+ (count))
+ (:results (values :more t))
+ (:temporary (:sc descriptor-reg) move-temp)
+ (:info label nvals)
+ (:save-p :force-to-stack)
+ (:vop-var vop)
+ (:generator 30
+ (emit-label label)
+ (note-this-location vop :non-local-entry)
+ (cond ((zerop nvals))
+ ((= nvals 1)
+ (let ((no-values (gen-label)))
+ (inst mov (tn-ref-tn values) *nil-value*)
+ (inst jecxz no-values)
+ (loadw (tn-ref-tn values) start -1)
+ (emit-label no-values)))
+ (t
+ (collect ((defaults))
+ (do ((i 0 (1+ i))
+ (tn-ref values (tn-ref-across tn-ref)))
+ ((null tn-ref))
+ (let ((default-lab (gen-label))
+ (tn (tn-ref-tn tn-ref)))
+ (defaults (cons default-lab tn))
+
+ (inst cmp count (fixnumize i))
+ (inst jmp :le default-lab)
+ (sc-case tn
+ ((descriptor-reg any-reg)
+ (loadw tn start (- (1+ i))))
+ ((control-stack)
+ (loadw move-temp start (- (1+ i)))
+ (inst mov tn move-temp)))))
+ (let ((defaulting-done (gen-label)))
+ (emit-label defaulting-done)
+ (assemble (*elsewhere*)
+ (dolist (def (defaults))
+ (emit-label (car def))
+ (inst mov (cdr def) *nil-value*))
+ (inst jmp defaulting-done))))))
+ (inst mov esp-tn sp)))
+
+(define-vop (nlx-entry-multiple)
+ (:args (top)
+ (source)
+ (count :target ecx))
+ ;; Again, no SC restrictions for the args, 'cause the loading would
+ ;; happen before the entry label.
+ (:info label)
+ (:temporary (:sc unsigned-reg :offset ecx-offset :from (:argument 2)) ecx)
+ (:temporary (:sc unsigned-reg :offset esi-offset) esi)
+ (:temporary (:sc unsigned-reg :offset edi-offset) edi)
+ (:results (result :scs (any-reg) :from (:argument 0))
+ (num :scs (any-reg control-stack)))
+ (:save-p :force-to-stack)
+ (:vop-var vop)
+ (:generator 30
+ (emit-label label)
+ (note-this-location vop :non-local-entry)
+
+ (inst lea esi (make-ea :dword :base source :disp (- word-bytes)))
+ ;; The 'top' arg contains the %esp value saved at the time the
+ ;; catch block was created and points to where the thrown values
+ ;; should sit.
+ (move edi top)
+ (move result edi)
+
+ (inst sub edi word-bytes)
+ (move ecx count) ; fixnum words == bytes
+ (move num ecx)
+ (inst shr ecx word-shift) ; word count for <rep movs>
+ ;; If we got zero, we be done.
+ (inst jecxz done)
+ ;; Copy them down.
+ (inst std)
+ (inst rep)
+ (inst movs :dword)
+
+ DONE
+ ;; Reset the CSP at last moved arg.
+ (inst lea esp-tn (make-ea :dword :base edi :disp word-bytes))))
+
+
+;;; This VOP is just to force the TNs used in the cleanup onto the stack.
+(define-vop (uwp-entry)
+ (:info label)
+ (:save-p :force-to-stack)
+ (:results (block) (start) (count))
+ (:ignore block start count)
+ (:vop-var vop)
+ (:generator 0
+ (emit-label label)
+ (note-this-location vop :non-local-entry)))
--- /dev/null
+;;;; This file contains some parameterizations of various VM
+;;;; attributes for the x86. This file is separate from other stuff so
+;;;; that it can be compiled and loaded earlier.
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!VM")
+
+(file-comment
+ "$Header$")
+
+;;; ### Note: we simultaneously use ``word'' to mean a 32 bit quantity
+;;; and a 16 bit quantity depending on context. This is because Intel
+;;; insists on calling 16 bit things words and 32 bit things
+;;; double-words (or dwords). Therefore, in the instruction definition
+;;; and register specs, we use the Intel convention. But whenever we
+;;; are talking about stuff the rest of the lisp system might be
+;;; interested in, we use ``word'' to mean the size of a descriptor
+;;; object, which is 32 bits.
+\f
+;;;; machine architecture parameters
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+
+(defconstant word-bits 32
+ #!+sb-doc
+ "Number of bits per word where a word holds one lisp descriptor.")
+
+(defconstant byte-bits 8
+ #!+sb-doc
+ "Number of bits per byte where a byte is the smallest addressable object.")
+
+(defconstant word-shift (1- (integer-length (/ word-bits byte-bits)))
+ #!+sb-doc
+ "Number of bits to shift between word addresses and byte addresses.")
+
+(defconstant word-bytes (/ word-bits byte-bits)
+ #!+sb-doc
+ "Number of bytes in a word.")
+
+) ; EVAL-WHEN
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+(defconstant float-sign-shift 31)
+
+;; These values were taken from the alpha code. The values for
+;; bias and exponent min/max are not the same as shown in the 486 book.
+;; They may be correct for how Python uses them.
+(defconstant single-float-bias 126) ; Intel says 127
+(defconstant single-float-exponent-byte (byte 8 23))
+(defconstant single-float-significand-byte (byte 23 0))
+;; The 486 book shows the exponent range -126 to +127. The Lisp
+;; code that uses these values seems to want already biased numbers.
+(defconstant single-float-normal-exponent-min 1)
+(defconstant single-float-normal-exponent-max 254)
+(defconstant single-float-hidden-bit (ash 1 23))
+(defconstant single-float-trapping-nan-bit (ash 1 22))
+
+(defconstant double-float-bias 1022)
+(defconstant double-float-exponent-byte (byte 11 20))
+(defconstant double-float-significand-byte (byte 20 0))
+(defconstant double-float-normal-exponent-min 1)
+(defconstant double-float-normal-exponent-max #x7FE)
+(defconstant double-float-hidden-bit (ash 1 20))
+(defconstant double-float-trapping-nan-bit (ash 1 19))
+
+(defconstant long-float-bias 16382)
+(defconstant long-float-exponent-byte (byte 15 0))
+(defconstant long-float-significand-byte (byte 31 0))
+(defconstant long-float-normal-exponent-min 1)
+(defconstant long-float-normal-exponent-max #x7FFE)
+(defconstant long-float-hidden-bit (ash 1 31)) ; Actually not hidden
+(defconstant long-float-trapping-nan-bit (ash 1 30))
+
+(defconstant single-float-digits
+ (+ (byte-size single-float-significand-byte) 1))
+
+(defconstant double-float-digits
+ (+ (byte-size double-float-significand-byte) word-bits 1))
+
+(defconstant long-float-digits
+ (+ (byte-size long-float-significand-byte) word-bits 1))
+
+;;; pfw -- from i486 microprocessor programmers reference manual
+(defconstant float-invalid-trap-bit (ash 1 0))
+(defconstant float-denormal-trap-bit (ash 1 1))
+(defconstant float-divide-by-zero-trap-bit (ash 1 2))
+(defconstant float-overflow-trap-bit (ash 1 3))
+(defconstant float-underflow-trap-bit (ash 1 4))
+(defconstant float-inexact-trap-bit (ash 1 5))
+
+(defconstant float-round-to-nearest 0)
+(defconstant float-round-to-negative 1)
+(defconstant float-round-to-positive 2)
+(defconstant float-round-to-zero 3)
+
+(defconstant float-rounding-mode (byte 2 10))
+(defconstant float-sticky-bits (byte 6 16))
+(defconstant float-traps-byte (byte 6 0))
+(defconstant float-exceptions-byte (byte 6 16))
+(defconstant float-precision-control (byte 2 8))
+(defconstant float-fast-bit 0) ; No fast mode on x86
+
+); EVAL-WHEN
+\f
+;;;; description of the target address space
+
+;;; where to put the different spaces
+;;;
+;;; FIXME: Couldn't/shouldn't these be DEFCONSTANT instead of DEFPARAMETER?
+#!-linux (defparameter *target-read-only-space-start* #x10000000)
+#!-linux (defparameter *target-static-space-start* #x28000000)
+#!-linux (defparameter *target-dynamic-space-start* #x48000000)
+#!+linux (defparameter *target-read-only-space-start* #x01000000)
+#!+linux (defparameter *target-static-space-start* #x05000000)
+#!+linux (defparameter *target-dynamic-space-start* #x09000000)
+
+;;; Given that NIL is the first things allocated in static space, we
+;;; know its value at compile time:
+;;;
+;;; FIXME: Couldn't/shouldn't this be a DEFCONSTANT, and shouldn't it be
+;;; calculated from TARGET-STATIC-SPACE-START instead of assigned
+;;; separately?
+#!-linux (defparameter *nil-value* #x2800000B)
+#!+linux (defparameter *nil-value* #x0500000B)
+\f
+;;;; other miscellaneous constants
+
+(defenum (:suffix -trap :start 8)
+ halt
+ pending-interrupt
+ error
+ cerror
+ breakpoint
+ function-end-breakpoint
+ single-step-breakpoint)
+;;; FIXME: It'd be nice to replace all the DEFENUMs with something
+;;; a la
+;;; (WITH-DEF-ENUM (:START 8)
+;;; (DEF-ENUM HALT-TRAP)
+;;; (DEF-ENUM PENDING-INTERRUPT-TRAP)
+;;; ..)
+;;; for the benefit of anyone doing a lexical search for definitions
+;;; of these symbols.
+
+(defenum (:prefix object-not- :suffix -trap :start 16)
+ list
+ instance)
+
+(defenum (:prefix trace-table-)
+ normal
+ call-site
+ function-prologue
+ function-epilogue)
+\f
+;;;; static symbols
+
+;;; These symbols are loaded into static space directly after NIL so
+;;; that the system can compute their address by adding a constant
+;;; amount to NIL.
+;;;
+;;; The fdefn objects for the static functions are loaded into static
+;;; space directly after the static symbols. That way, the raw-addr
+;;; can be loaded directly out of them by indirecting relative to NIL.
+;;;
+;;; pfw X86 doesn't have enough registers to keep these things there.
+;;; Note these spaces grow from low to high addresses.
+(defvar *allocation-pointer*)
+(defvar *binding-stack-pointer*)
+(defvar *x86-cgc-active-p*) ; FIXME: Document this.
+(defvar *static-blue-bag* nil)
+
+;;; FIXME: *!INITIAL-FDEFN-OBJECTS* and !COLD-INIT probably don't need
+;;; to be in the static symbols table any more. Also, if
+;;; *INTERNAL-GC-TRIGGER* really is not used, we can punt it.
+(defparameter *static-symbols*
+ '(t
+
+ ;; The C startup code must fill these in.
+ *posix-argv*
+ sb!impl::*!initial-fdefn-objects*
+
+ ;; functions that the C code needs to call
+ sb!impl::!cold-init
+ sb!impl::maybe-gc
+ sb!kernel::internal-error
+ sb!di::handle-breakpoint
+ sb!impl::fdefinition-object
+
+ ;; free pointers
+ sb!impl::*read-only-space-free-pointer*
+ sb!impl::*static-space-free-pointer*
+ sb!impl::*initial-dynamic-space-free-pointer*
+
+ ;; things needed for non-local exit
+ sb!impl::*current-catch-block*
+ sb!impl::*current-unwind-protect-block*
+ sb!c::*eval-stack-top*
+ sb!vm::*alien-stack*
+
+ ;; interrupt handling
+ sb!impl::*pseudo-atomic-atomic*
+ sb!impl::*pseudo-atomic-interrupted*
+ sb!unix::*interrupts-enabled*
+ sb!unix::*interrupt-pending*
+ sb!impl::*free-interrupt-context-index*
+
+ sb!vm::*allocation-pointer*
+ sb!vm::*binding-stack-pointer*
+ sb!vm::*internal-gc-trigger* ; Not used.
+
+ ;; the floating point constants
+ sb!vm::*fp-constant-0d0*
+ sb!vm::*fp-constant-1d0*
+ sb!vm::*fp-constant-0s0*
+ sb!vm::*fp-constant-1s0*
+ ;; The following are all long-floats.
+ sb!vm::*fp-constant-0l0*
+ sb!vm::*fp-constant-1l0*
+ sb!vm::*fp-constant-pi*
+ sb!vm::*fp-constant-l2t*
+ sb!vm::*fp-constant-l2e*
+ sb!vm::*fp-constant-lg2*
+ sb!vm::*fp-constant-ln2*
+
+ ;; used by gencgc
+ sb!vm::*scavenge-read-only-space*
+
+ ;; multi-process support
+ sb!vm::*control-stacks*
+
+ ;; The ..SLOT-UNBOUND.. symbol is static in order to optimise the
+ ;; common slot unbound check.
+ sb!pcl::..slot-unbound..
+
+ ;; spare symbols
+ sb!vm::spare-10
+ sb!vm::spare-9
+ sb!vm::spare-8
+ sb!vm::spare-7
+ sb!vm::spare-6
+ sb!vm::spare-5
+ sb!vm::spare-4
+ sb!vm::spare-3
+ sb!vm::spare-2
+ sb!vm::spare-1
+
+ ;; used by cgc
+ sb!vm::*x86-cgc-active-p*
+ sb!vm::*static-blue-bag* ; must be last or change C code
+ ))
+
+(defparameter *static-functions*
+ '(length
+ sb!kernel:two-arg-+
+ sb!kernel:two-arg--
+ sb!kernel:two-arg-*
+ sb!kernel:two-arg-/
+ sb!kernel:two-arg-<
+ sb!kernel:two-arg->
+ sb!kernel:two-arg-=
+ eql
+ sb!kernel:%negate
+ sb!kernel:two-arg-and
+ sb!kernel:two-arg-ior
+ sb!kernel:two-arg-xor
+ sb!kernel:two-arg-gcd
+ sb!kernel:two-arg-lcm))
+\f
+;;;; stuff added by jrd
+
+;;; FIXME: Is this used? Delete it or document it.
+;;; cf the sparc PARMS.LISP
+(defparameter *assembly-unit-length* 8)
--- /dev/null
+;;;; predicate VOPs for the x86 VM
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!VM")
+
+(file-comment
+ "$Header$")
+\f
+;;;; the branch VOP
+
+;;; The unconditional branch, emitted when we can't drop through to the desired
+;;; destination. Dest is the continuation we transfer control to.
+(define-vop (branch)
+ (:info dest)
+ (:generator 5
+ (inst jmp dest)))
+
+\f
+;;;; conditional VOPs
+
+;;; Note: a constant-tn is allowed in CMP; it uses an EA displacement,
+;;; not immediate data.
+(define-vop (if-eq)
+ (:args (x :scs (any-reg descriptor-reg control-stack constant)
+ :load-if (not (and (sc-is x immediate)
+ (sc-is y any-reg descriptor-reg
+ control-stack constant))))
+ (y :scs (any-reg descriptor-reg immediate)
+ :load-if (not (and (sc-is x any-reg descriptor-reg immediate)
+ (sc-is y control-stack constant)))))
+ (:conditional)
+ (:info target not-p)
+ (:policy :fast-safe)
+ (:translate eq)
+ (:generator 3
+ (cond
+ ((sc-is y immediate)
+ (let ((val (tn-value y)))
+ (etypecase val
+ (integer
+ (if (and (zerop val) (sc-is x any-reg descriptor-reg))
+ (inst test x x) ; smaller
+ (inst cmp x (fixnumize val))))
+ (symbol
+ (inst cmp x (+ *nil-value* (static-symbol-offset val))))
+ (character
+ (inst cmp x (logior (ash (char-code val) type-bits)
+ base-char-type))))))
+ ((sc-is x immediate) ; and y not immediate
+ ;; Swap the order to fit the compare instruction.
+ (let ((val (tn-value x)))
+ (etypecase val
+ (integer
+ (if (and (zerop val) (sc-is y any-reg descriptor-reg))
+ (inst test y y) ; smaller
+ (inst cmp y (fixnumize val))))
+ (symbol
+ (inst cmp y (+ *nil-value* (static-symbol-offset val))))
+ (character
+ (inst cmp y (logior (ash (char-code val) type-bits)
+ base-char-type))))))
+ (t
+ (inst cmp x y)))
+
+ (inst jmp (if not-p :ne :e) target)))
--- /dev/null
+;;;; SAP operations for the x86 VM
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!VM")
+
+(file-comment
+ "$Header$")
+\f
+;;;; moves and coercions
+
+;;; Move a tagged SAP to an untagged representation.
+(define-vop (move-to-sap)
+ (:args (x :scs (descriptor-reg)))
+ (:results (y :scs (sap-reg)))
+ (:note "pointer to SAP coercion")
+ (:generator 1
+ (loadw y x sap-pointer-slot other-pointer-type)))
+(define-move-vop move-to-sap :move
+ (descriptor-reg) (sap-reg))
+
+;;; Move an untagged SAP to a tagged representation.
+(define-vop (move-from-sap)
+ (:args (sap :scs (sap-reg) :to :result))
+ (:results (res :scs (descriptor-reg) :from :argument))
+ (:note "SAP to pointer coercion")
+ (:node-var node)
+ (:generator 20
+ (with-fixed-allocation (res sap-type sap-size node)
+ (storew sap res sap-pointer-slot other-pointer-type))))
+(define-move-vop move-from-sap :move
+ (sap-reg) (descriptor-reg))
+
+;;; Move untagged sap values.
+(define-vop (sap-move)
+ (:args (x :target y
+ :scs (sap-reg)
+ :load-if (not (location= x y))))
+ (:results (y :scs (sap-reg)
+ :load-if (not (location= x y))))
+ (:note "SAP move")
+ (:effects)
+ (:affected)
+ (:generator 0
+ (move y x)))
+(define-move-vop sap-move :move
+ (sap-reg) (sap-reg))
+
+;;; Move untagged sap arguments/return-values.
+(define-vop (move-sap-argument)
+ (:args (x :target y
+ :scs (sap-reg))
+ (fp :scs (any-reg)
+ :load-if (not (sc-is y sap-reg))))
+ (:results (y))
+ (:note "SAP argument move")
+ (:generator 0
+ (sc-case y
+ (sap-reg
+ (move y x))
+ (sap-stack
+ (if (= (tn-offset fp) esp-offset)
+ (storew x fp (tn-offset y)) ; c-call
+ (storew x fp (- (1+ (tn-offset y)))))))))
+(define-move-vop move-sap-argument :move-argument
+ (descriptor-reg sap-reg) (sap-reg))
+
+;;; Use standard MOVE-ARGUMENT + coercion to move an untagged sap to a
+;;; descriptor passing location.
+(define-move-vop move-argument :move-argument
+ (sap-reg) (descriptor-reg))
+\f
+;;;; SAP-INT and INT-SAP
+
+(define-vop (sap-int)
+ (:args (sap :scs (sap-reg) :target int))
+ (:arg-types system-area-pointer)
+ (:results (int :scs (unsigned-reg)))
+ (:result-types unsigned-num)
+ (:translate sap-int)
+ (:policy :fast-safe)
+ (:generator 1
+ (move int sap)))
+
+(define-vop (int-sap)
+ (:args (int :scs (unsigned-reg) :target sap))
+ (:arg-types unsigned-num)
+ (:results (sap :scs (sap-reg)))
+ (:result-types system-area-pointer)
+ (:translate int-sap)
+ (:policy :fast-safe)
+ (:generator 1
+ (move sap int)))
+\f
+;;;; POINTER+ and POINTER-
+
+(define-vop (pointer+)
+ (:translate sap+)
+ (:args (ptr :scs (sap-reg) :target res
+ :load-if (not (location= ptr res)))
+ (offset :scs (signed-reg immediate)))
+ (:arg-types system-area-pointer signed-num)
+ (:results (res :scs (sap-reg) :from (:argument 0)
+ :load-if (not (location= ptr res))))
+ (:result-types system-area-pointer)
+ (:policy :fast-safe)
+ (:generator 1
+ (cond ((and (sc-is ptr sap-reg) (sc-is res sap-reg)
+ (not (location= ptr res)))
+ (sc-case offset
+ (signed-reg
+ (inst lea res (make-ea :dword :base ptr :index offset :scale 1)))
+ (immediate
+ (inst lea res (make-ea :dword :base ptr
+ :disp (tn-value offset))))))
+ (t
+ (move res ptr)
+ (sc-case offset
+ (signed-reg
+ (inst add res offset))
+ (immediate
+ (inst add res (tn-value offset))))))))
+
+(define-vop (pointer-)
+ (:translate sap-)
+ (:args (ptr1 :scs (sap-reg) :target res)
+ (ptr2 :scs (sap-reg)))
+ (:arg-types system-area-pointer system-area-pointer)
+ (:policy :fast-safe)
+ (:results (res :scs (signed-reg) :from (:argument 0)))
+ (:result-types signed-num)
+ (:generator 1
+ (move res ptr1)
+ (inst sub res ptr2)))
+\f
+;;;; mumble-SYSTEM-REF and mumble-SYSTEM-SET
+
+(macrolet ((def-system-ref-and-set (ref-name
+ set-name
+ sc
+ type
+ size
+ &optional signed)
+ (let ((ref-name-c (symbolicate ref-name "-C"))
+ (set-name-c (symbolicate set-name "-C"))
+ (temp-sc (symbolicate size "-REG")))
+ `(progn
+ (define-vop (,ref-name)
+ (:translate ,ref-name)
+ (:policy :fast-safe)
+ (:args (sap :scs (sap-reg))
+ (offset :scs (signed-reg)))
+ (:arg-types system-area-pointer signed-num)
+ ,@(unless (eq size :dword)
+ `((:temporary (:sc ,temp-sc
+ :from (:eval 0)
+ :to (:eval 1))
+ temp)))
+ (:results (result :scs (,sc)))
+ (:result-types ,type)
+ (:generator 5
+ (inst mov ,(if (eq size :dword) 'result 'temp)
+ (make-ea ,size :base sap :index offset))
+ ,@(unless (eq size :dword)
+ `((inst ,(if signed 'movsx 'movzx)
+ result temp)))))
+ (define-vop (,ref-name-c)
+ (:translate ,ref-name)
+ (:policy :fast-safe)
+ (:args (sap :scs (sap-reg)))
+ (:arg-types system-area-pointer
+ (:constant (signed-byte 32)))
+ (:info offset)
+ ,@(unless (eq size :dword)
+ `((:temporary (:sc ,temp-sc
+ :from (:eval 0)
+ :to (:eval 1))
+ temp)))
+ (:results (result :scs (,sc)))
+ (:result-types ,type)
+ (:generator 4
+ (inst mov ,(if (eq size :dword) 'result 'temp)
+ (make-ea ,size :base sap :disp offset))
+ ,@(unless (eq size :dword)
+ `((inst ,(if signed 'movsx 'movzx)
+ result temp)))))
+ (define-vop (,set-name)
+ (:translate ,set-name)
+ (:policy :fast-safe)
+ (:args (sap :scs (sap-reg) :to (:eval 0))
+ (offset :scs (signed-reg) :to (:eval 0))
+ (value :scs (,sc)
+ :target ,(if (eq size :dword)
+ 'result
+ 'temp)))
+ (:arg-types system-area-pointer signed-num ,type)
+ ,@(unless (eq size :dword)
+ `((:temporary (:sc ,temp-sc :offset eax-offset
+ :from (:argument 2) :to (:result 0)
+ :target result)
+ temp)))
+ (:results (result :scs (,sc)))
+ (:result-types ,type)
+ (:generator 5
+ ,@(unless (eq size :dword)
+ `((move eax-tn value)))
+ (inst mov (make-ea ,size
+ :base sap
+ :index offset)
+ ,(if (eq size :dword) 'value 'temp))
+ (move result
+ ,(if (eq size :dword) 'value 'eax-tn))))
+ (define-vop (,set-name-c)
+ (:translate ,set-name)
+ (:policy :fast-safe)
+ (:args (sap :scs (sap-reg) :to (:eval 0))
+ (value :scs (,sc)
+ :target ,(if (eq size :dword)
+ 'result
+ 'temp)))
+ (:arg-types system-area-pointer
+ (:constant (signed-byte 32)) ,type)
+ (:info offset)
+ ,@(unless (eq size :dword)
+ `((:temporary (:sc ,temp-sc :offset eax-offset
+ :from (:argument 2) :to (:result 0)
+ :target result)
+ temp)))
+ (:results (result :scs (,sc)))
+ (:result-types ,type)
+ (:generator 4
+ ,@(unless (eq size :dword)
+ `((move eax-tn value)))
+ (inst mov
+ (make-ea ,size :base sap :disp offset)
+ ,(if (eq size :dword) 'value 'temp))
+ (move result ,(if (eq size :dword)
+ 'value
+ 'eax-tn))))))))
+
+ (def-system-ref-and-set sap-ref-8 %set-sap-ref-8
+ unsigned-reg positive-fixnum :byte nil)
+ (def-system-ref-and-set signed-sap-ref-8 %set-signed-sap-ref-8
+ signed-reg tagged-num :byte t)
+ (def-system-ref-and-set sap-ref-16 %set-sap-ref-16
+ unsigned-reg positive-fixnum :word nil)
+ (def-system-ref-and-set signed-sap-ref-16 %set-signed-sap-ref-16
+ signed-reg tagged-num :word t)
+ (def-system-ref-and-set sap-ref-32 %set-sap-ref-32
+ unsigned-reg unsigned-num :dword nil)
+ (def-system-ref-and-set signed-sap-ref-32 %set-signed-sap-ref-32
+ signed-reg signed-num :dword t)
+ (def-system-ref-and-set sap-ref-sap %set-sap-ref-sap
+ sap-reg system-area-pointer :dword))
+\f
+;;;; SAP-REF-DOUBLE
+
+(define-vop (sap-ref-double)
+ (:translate sap-ref-double)
+ (:policy :fast-safe)
+ (:args (sap :scs (sap-reg))
+ (offset :scs (signed-reg)))
+ (:arg-types system-area-pointer signed-num)
+ (:results (result :scs (double-reg)))
+ (:result-types double-float)
+ (:generator 5
+ (with-empty-tn@fp-top(result)
+ (inst fldd (make-ea :dword :base sap :index offset)))))
+
+(define-vop (sap-ref-double-c)
+ (:translate sap-ref-double)
+ (:policy :fast-safe)
+ (:args (sap :scs (sap-reg)))
+ (:arg-types system-area-pointer (:constant (signed-byte 32)))
+ (:info offset)
+ (:results (result :scs (double-reg)))
+ (:result-types double-float)
+ (:generator 4
+ (with-empty-tn@fp-top(result)
+ (inst fldd (make-ea :dword :base sap :disp offset)))))
+
+(define-vop (%set-sap-ref-double)
+ (:translate %set-sap-ref-double)
+ (:policy :fast-safe)
+ (:args (sap :scs (sap-reg) :to (:eval 0))
+ (offset :scs (signed-reg) :to (:eval 0))
+ (value :scs (double-reg)))
+ (:arg-types system-area-pointer signed-num double-float)
+ (:results (result :scs (double-reg)))
+ (:result-types double-float)
+ (:generator 5
+ (cond ((zerop (tn-offset value))
+ ;; Value is in ST0.
+ (inst fstd (make-ea :dword :base sap :index offset))
+ (unless (zerop (tn-offset result))
+ ;; Value is in ST0 but not result.
+ (inst fstd result)))
+ (t
+ ;; Value is not in ST0.
+ (inst fxch value)
+ (inst fstd (make-ea :dword :base sap :index offset))
+ (cond ((zerop (tn-offset result))
+ ;; The result is in ST0.
+ (inst fstd value))
+ (t
+ ;; Neither value or result are in ST0.
+ (unless (location= value result)
+ (inst fstd result))
+ (inst fxch value)))))))
+
+(define-vop (%set-sap-ref-double-c)
+ (:translate %set-sap-ref-double)
+ (:policy :fast-safe)
+ (:args (sap :scs (sap-reg) :to (:eval 0))
+ (value :scs (double-reg)))
+ (:arg-types system-area-pointer (:constant (signed-byte 32)) double-float)
+ (:info offset)
+ (:results (result :scs (double-reg)))
+ (:result-types double-float)
+ (:generator 4
+ (cond ((zerop (tn-offset value))
+ ;; Value is in ST0.
+ (inst fstd (make-ea :dword :base sap :disp offset))
+ (unless (zerop (tn-offset result))
+ ;; Value is in ST0 but not result.
+ (inst fstd result)))
+ (t
+ ;; Value is not in ST0.
+ (inst fxch value)
+ (inst fstd (make-ea :dword :base sap :disp offset))
+ (cond ((zerop (tn-offset result))
+ ;; The result is in ST0.
+ (inst fstd value))
+ (t
+ ;; Neither value or result are in ST0.
+ (unless (location= value result)
+ (inst fstd result))
+ (inst fxch value)))))))
+\f
+;;;; SAP-REF-SINGLE
+
+(define-vop (sap-ref-single)
+ (:translate sap-ref-single)
+ (:policy :fast-safe)
+ (:args (sap :scs (sap-reg))
+ (offset :scs (signed-reg)))
+ (:arg-types system-area-pointer signed-num)
+ (:results (result :scs (single-reg)))
+ (:result-types single-float)
+ (:generator 5
+ (with-empty-tn@fp-top(result)
+ (inst fld (make-ea :dword :base sap :index offset)))))
+
+(define-vop (sap-ref-single-c)
+ (:translate sap-ref-single)
+ (:policy :fast-safe)
+ (:args (sap :scs (sap-reg)))
+ (:arg-types system-area-pointer (:constant (signed-byte 32)))
+ (:info offset)
+ (:results (result :scs (single-reg)))
+ (:result-types single-float)
+ (:generator 4
+ (with-empty-tn@fp-top(result)
+ (inst fld (make-ea :dword :base sap :disp offset)))))
+
+(define-vop (%set-sap-ref-single)
+ (:translate %set-sap-ref-single)
+ (:policy :fast-safe)
+ (:args (sap :scs (sap-reg) :to (:eval 0))
+ (offset :scs (signed-reg) :to (:eval 0))
+ (value :scs (single-reg)))
+ (:arg-types system-area-pointer signed-num single-float)
+ (:results (result :scs (single-reg)))
+ (:result-types single-float)
+ (:generator 5
+ (cond ((zerop (tn-offset value))
+ ;; Value is in ST0
+ (inst fst (make-ea :dword :base sap :index offset))
+ (unless (zerop (tn-offset result))
+ ;; Value is in ST0 but not result.
+ (inst fst result)))
+ (t
+ ;; Value is not in ST0.
+ (inst fxch value)
+ (inst fst (make-ea :dword :base sap :index offset))
+ (cond ((zerop (tn-offset result))
+ ;; The result is in ST0.
+ (inst fst value))
+ (t
+ ;; Neither value or result are in ST0
+ (unless (location= value result)
+ (inst fst result))
+ (inst fxch value)))))))
+
+(define-vop (%set-sap-ref-single-c)
+ (:translate %set-sap-ref-single)
+ (:policy :fast-safe)
+ (:args (sap :scs (sap-reg) :to (:eval 0))
+ (value :scs (single-reg)))
+ (:arg-types system-area-pointer (:constant (signed-byte 32)) single-float)
+ (:info offset)
+ (:results (result :scs (single-reg)))
+ (:result-types single-float)
+ (:generator 4
+ (cond ((zerop (tn-offset value))
+ ;; Value is in ST0
+ (inst fst (make-ea :dword :base sap :disp offset))
+ (unless (zerop (tn-offset result))
+ ;; Value is in ST0 but not result.
+ (inst fst result)))
+ (t
+ ;; Value is not in ST0.
+ (inst fxch value)
+ (inst fst (make-ea :dword :base sap :disp offset))
+ (cond ((zerop (tn-offset result))
+ ;; The result is in ST0.
+ (inst fst value))
+ (t
+ ;; Neither value or result are in ST0
+ (unless (location= value result)
+ (inst fst result))
+ (inst fxch value)))))))
+\f
+;;;; SAP-REF-LONG
+
+(define-vop (sap-ref-long)
+ (:translate sap-ref-long)
+ (:policy :fast-safe)
+ (:args (sap :scs (sap-reg))
+ (offset :scs (signed-reg)))
+ (:arg-types system-area-pointer signed-num)
+ (:results (result :scs (#!+long-float long-reg #!-long-float double-reg)))
+ (:result-types #!+long-float long-float #!-long-float double-float)
+ (:generator 5
+ (with-empty-tn@fp-top(result)
+ (inst fldl (make-ea :dword :base sap :index offset)))))
+
+(define-vop (sap-ref-long-c)
+ (:translate sap-ref-long)
+ (:policy :fast-safe)
+ (:args (sap :scs (sap-reg)))
+ (:arg-types system-area-pointer (:constant (signed-byte 32)))
+ (:info offset)
+ (:results (result :scs (#!+long-float long-reg #!-long-float double-reg)))
+ (:result-types #!+long-float long-float #!-long-float double-float)
+ (:generator 4
+ (with-empty-tn@fp-top(result)
+ (inst fldl (make-ea :dword :base sap :disp offset)))))
+
+#!+long-float
+(define-vop (%set-sap-ref-long)
+ (:translate %set-sap-ref-long)
+ (:policy :fast-safe)
+ (:args (sap :scs (sap-reg) :to (:eval 0))
+ (offset :scs (signed-reg) :to (:eval 0))
+ (value :scs (long-reg)))
+ (:arg-types system-area-pointer signed-num long-float)
+ (:results (result :scs (long-reg)))
+ (:result-types long-float)
+ (:generator 5
+ (cond ((zerop (tn-offset value))
+ ;; Value is in ST0
+ (store-long-float (make-ea :dword :base sap :index offset))
+ (unless (zerop (tn-offset result))
+ ;; Value is in ST0 but not result.
+ (inst fstd result)))
+ (t
+ ;; Value is not in ST0.
+ (inst fxch value)
+ (store-long-float (make-ea :dword :base sap :index offset))
+ (cond ((zerop (tn-offset result))
+ ;; The result is in ST0.
+ (inst fstd value))
+ (t
+ ;; Neither value or result are in ST0
+ (unless (location= value result)
+ (inst fstd result))
+ (inst fxch value)))))))
+\f
+;;; noise to convert normal lisp data objects into SAPs
+
+(define-vop (vector-sap)
+ (:translate vector-sap)
+ (:policy :fast-safe)
+ (:args (vector :scs (descriptor-reg) :target sap))
+ (:results (sap :scs (sap-reg)))
+ (:result-types system-area-pointer)
+ (:generator 2
+ (move sap vector)
+ (inst add sap (- (* vector-data-offset word-bytes) other-pointer-type))))
--- /dev/null
+;;;; VOPs which are useful for following the progress of the system
+;;;; early in boot
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!VM")
+
+(file-comment
+ "$Header$")
+
+;;; FIXME: should probably become conditional on #!+SB-SHOW
+;;; FIXME: should be called DEBUG-PRINT or COLD-PRINT
+(define-vop (print)
+ (:args (object :scs (descriptor-reg any-reg)))
+ (:temporary (:sc unsigned-reg
+ :offset eax-offset
+ :target result
+ :from :eval
+ :to (:result 0))
+ eax)
+ (:results (result :scs (descriptor-reg)))
+ (:save-p t)
+ (:generator 100
+ (inst push object)
+ (inst lea eax (make-fixup (extern-alien-name "debug_print") :foreign))
+ (inst call (make-fixup (extern-alien-name "call_into_c") :foreign))
+ (inst add esp-tn word-bytes)
+ (move result eax)))
--- /dev/null
+;;;; the VOPs and macro magic required to call static functions
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!VM")
+
+(file-comment
+ "$Header$")
+
+(define-vop (static-function-template)
+ (:save-p t)
+ (:policy :safe)
+ (:variant-vars function)
+ (:vop-var vop)
+ (:node-var node)
+ (:temporary (:sc unsigned-reg :offset ebx-offset
+ :from (:eval 0) :to (:eval 2)) ebx)
+ (:temporary (:sc unsigned-reg :offset ecx-offset
+ :from (:eval 0) :to (:eval 2)) ecx))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+
+(defun static-function-template-name (num-args num-results)
+ (intern (format nil "~:@(~R-arg-~R-result-static-function~)"
+ num-args num-results)))
+
+(defun moves (dst src)
+ (collect ((moves))
+ (do ((dst dst (cdr dst))
+ (src src (cdr src)))
+ ((or (null dst) (null src)))
+ (moves `(move ,(car dst) ,(car src))))
+ (moves)))
+
+(defun static-function-template-vop (num-args num-results)
+ (assert (and (<= num-args register-arg-count)
+ (<= num-results register-arg-count))
+ (num-args num-results)
+ "Either too many args (~D) or too many results (~D). Max = ~D"
+ num-args num-results register-arg-count)
+ (let ((num-temps (max num-args num-results)))
+ (collect ((temp-names) (temps) (arg-names) (args) (result-names) (results))
+ (dotimes (i num-results)
+ (let ((result-name (intern (format nil "RESULT-~D" i))))
+ (result-names result-name)
+ (results `(,result-name :scs (any-reg descriptor-reg)))))
+ (dotimes (i num-temps)
+ (let ((temp-name (intern (format nil "TEMP-~D" i))))
+ (temp-names temp-name)
+ (temps `(:temporary (:sc descriptor-reg
+ :offset ,(nth i register-arg-offsets)
+ :from ,(if (< i num-args)
+ `(:argument ,i)
+ '(:eval 1))
+ :to ,(if (< i num-results)
+ `(:result ,i)
+ '(:eval 1))
+ ,@(when (< i num-results)
+ `(:target ,(nth i (result-names)))))
+ ,temp-name))))
+ (dotimes (i num-args)
+ (let ((arg-name (intern (format nil "ARG-~D" i))))
+ (arg-names arg-name)
+ (args `(,arg-name
+ :scs (any-reg descriptor-reg)
+ :target ,(nth i (temp-names))))))
+ `(define-vop (,(static-function-template-name num-args num-results)
+ static-function-template)
+ (:args ,@(args))
+ ,@(temps)
+ (:results ,@(results))
+ (:generator ,(+ 50 num-args num-results)
+ ,@(moves (temp-names) (arg-names))
+
+ ;; If speed not more important than size, duplicate the
+ ;; effect of the ENTER with discrete instructions. Takes
+ ;; 2+1+3+2=8 bytes as opposed to 4+3=7 bytes.
+ (cond ((policy node (>= speed space))
+ (inst mov ebx esp-tn)
+ ;; Save the old-fp
+ (inst push ebp-tn)
+ ;; Ensure that at least three slots are available; one
+ ;; above, two more needed.
+ (inst sub esp-tn (fixnumize 2))
+ (inst mov ebp-tn ebx))
+ (t
+ (inst enter (fixnumize 2))
+ ;; The enter instruction pushes EBP and then copies
+ ;; ESP into EBP. We want the new EBP to be the
+ ;; original ESP, so we fix it up afterwards.
+ (inst add ebp-tn (fixnumize 1))))
+
+ ,(if (zerop num-args)
+ '(inst xor ecx ecx)
+ `(inst mov ecx (fixnumize ,num-args)))
+
+ (note-this-location vop :call-site)
+ ;; Static-function-offset gives the offset from the start of
+ ;; the nil object to the static function fdefn and has the
+ ;; low tag of 1 added. When the nil symbol value with its
+ ;; low tag of 3 is added the resulting value points to the
+ ;; raw address slot of the fdefn (at +4).
+ (inst call (make-ea :dword
+ :disp (+ *nil-value*
+ (static-function-offset function))))
+ ,(collect ((bindings) (links))
+ (do ((temp (temp-names) (cdr temp))
+ (name 'values (gensym))
+ (prev nil name)
+ (i 0 (1+ i)))
+ ((= i num-results))
+ (bindings `(,name
+ (make-tn-ref ,(car temp) nil)))
+ (when prev
+ (links `(setf (tn-ref-across ,prev) ,name))))
+ `(let ,(bindings)
+ ,@(links)
+ (default-unknown-values
+ vop
+ ,(if (zerop num-results) nil 'values)
+ ,num-results)))
+ ,@(moves (result-names) (temp-names)))))))
+
+) ; eval-when (compile load eval)
+
+(macrolet ((frob (num-args num-res)
+ (static-function-template-vop (eval num-args) (eval num-res))))
+ (frob 0 1)
+ (frob 1 1)
+ (frob 2 1)
+ (frob 3 1))
+
+(defmacro define-static-function (name args &key (results '(x)) translate
+ policy cost arg-types result-types)
+ `(define-vop (,name
+ ,(static-function-template-name (length args)
+ (length results)))
+ (:variant ',name)
+ (:note ,(format nil "static-function ~@(~S~)" name))
+ ,@(when translate
+ `((:translate ,translate)))
+ ,@(when policy
+ `((:policy ,policy)))
+ ,@(when cost
+ `((:generator-cost ,cost)))
+ ,@(when arg-types
+ `((:arg-types ,@arg-types)))
+ ,@(when result-types
+ `((:result-types ,@result-types)))))
--- /dev/null
+;;;; linkage information for standard static functions, and
+;;;; miscellaneous VOPs
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!VM")
+
+(file-comment
+ "$Header$")
+\f
+;;;; LENGTH
+
+(define-vop (length/list)
+ (:translate length)
+ (:args (object :scs (descriptor-reg control-stack) :target ptr))
+ (:arg-types list)
+ (:temporary (:sc unsigned-reg :offset eax-offset) eax)
+ (:temporary (:sc descriptor-reg :from (:argument 0)) ptr)
+ (:results (count :scs (any-reg)))
+ (:result-types positive-fixnum)
+ (:policy :fast-safe)
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:generator 40
+ ;; Move OBJECT into a temp we can bash on, and initialize the count.
+ (move ptr object)
+ (inst xor count count)
+ ;; If we are starting with NIL, then it's real easy.
+ (inst cmp ptr *nil-value*)
+ (inst jmp :e done)
+ ;; Note: we don't have to test to see whether the original argument is a
+ ;; list, because this is a :fast-safe vop.
+ LOOP
+ ;; Get the CDR and boost the count.
+ (loadw ptr ptr cons-cdr-slot list-pointer-type)
+ (inst add count (fixnumize 1))
+ ;; If we hit NIL, then we are done.
+ (inst cmp ptr *nil-value*)
+ (inst jmp :e done)
+ ;; Otherwise, check to see whether we hit the end of a dotted list. If
+ ;; not, loop back for more.
+ (move eax ptr)
+ (inst and al-tn lowtag-mask)
+ (inst cmp al-tn list-pointer-type)
+ (inst jmp :e loop)
+ ;; It's dotted all right. Flame out.
+ (error-call vop object-not-list-error ptr)
+ ;; We be done.
+ DONE))
+
+(define-vop (fast-length/list)
+ (:translate length)
+ (:args (object :scs (descriptor-reg control-stack) :target ptr))
+ (:arg-types list)
+ (:temporary (:sc descriptor-reg :from (:argument 0)) ptr)
+ (:results (count :scs (any-reg)))
+ (:result-types positive-fixnum)
+ (:policy :fast)
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:generator 30
+ ;; Get a copy of OBJECT in a register we can bash on, and
+ ;; initialize COUNT.
+ (move ptr object)
+ (inst xor count count)
+ ;; If we are starting with NIL, we be done.
+ (inst cmp ptr *nil-value*)
+ (inst jmp :e done)
+ ;; Indirect the next cons cell, and boost the count.
+ LOOP
+ (loadw ptr ptr cons-cdr-slot list-pointer-type)
+ (inst add count (fixnumize 1))
+ ;; If we aren't done, go back for more.
+ (inst cmp ptr *nil-value*)
+ (inst jmp :ne loop)
+ DONE))
+
+(define-static-function length (object) :translate length)
--- /dev/null
+;;;; x86 VM definitions of various system hacking operations
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!VM")
+
+(file-comment
+ "$Header$")
+\f
+;;;; type frobbing VOPs
+
+(define-vop (get-lowtag)
+ (:translate get-lowtag)
+ (:policy :fast-safe)
+ (:args (object :scs (any-reg descriptor-reg control-stack)
+ :target result))
+ (:results (result :scs (unsigned-reg)))
+ (:result-types positive-fixnum)
+ (:generator 1
+ (move result object)
+ (inst and result lowtag-mask)))
+
+(define-vop (get-type)
+ (:translate get-type)
+ (:policy :fast-safe)
+ (:args (object :scs (descriptor-reg)))
+ (:temporary (:sc unsigned-reg :offset eax-offset :to (:result 0)) eax)
+ (:results (result :scs (unsigned-reg)))
+ (:result-types positive-fixnum)
+ (:generator 6
+ (inst mov eax object)
+ (inst and al-tn lowtag-mask)
+ (inst cmp al-tn other-pointer-type)
+ (inst jmp :e other-ptr)
+ (inst cmp al-tn function-pointer-type)
+ (inst jmp :e function-ptr)
+
+ ;; pick off structures and list pointers
+ (inst test al-tn 1)
+ (inst jmp :ne done)
+
+ ;; pick off fixnums
+ (inst and al-tn 3)
+ (inst jmp :e done)
+
+ ;; must be an other immediate
+ (inst mov eax object)
+ (inst jmp done)
+
+ FUNCTION-PTR
+ (load-type al-tn object (- sb!vm:function-pointer-type))
+ (inst jmp done)
+
+ OTHER-PTR
+ (load-type al-tn object (- sb!vm:other-pointer-type))
+
+ DONE
+ (inst movzx result al-tn)))
+\f
+(define-vop (function-subtype)
+ (:translate function-subtype)
+ (:policy :fast-safe)
+ (:args (function :scs (descriptor-reg)))
+ (:temporary (:sc byte-reg :from (:eval 0) :to (:eval 1)) temp)
+ (:results (result :scs (unsigned-reg)))
+ (:result-types positive-fixnum)
+ (:generator 6
+ (load-type temp function (- sb!vm:function-pointer-type))
+ (inst movzx result temp)))
+
+(define-vop (set-function-subtype)
+ (:translate (setf function-subtype))
+ (:policy :fast-safe)
+ (:args (type :scs (unsigned-reg) :target eax)
+ (function :scs (descriptor-reg)))
+ (:arg-types positive-fixnum *)
+ (:temporary (:sc unsigned-reg :offset eax-offset :from (:argument 0)
+ :to (:result 0) :target result)
+ eax)
+ (:results (result :scs (unsigned-reg)))
+ (:result-types positive-fixnum)
+ (:generator 6
+ (move eax type)
+ (inst mov
+ (make-ea :byte :base function :disp (- function-pointer-type))
+ al-tn)
+ (move result eax)))
+
+(define-vop (get-header-data)
+ (:translate get-header-data)
+ (:policy :fast-safe)
+ (:args (x :scs (descriptor-reg)))
+ (:results (res :scs (unsigned-reg)))
+ (:result-types positive-fixnum)
+ (:generator 6
+ (loadw res x 0 other-pointer-type)
+ (inst shr res type-bits)))
+
+(define-vop (get-closure-length)
+ (:translate get-closure-length)
+ (:policy :fast-safe)
+ (:args (x :scs (descriptor-reg)))
+ (:results (res :scs (unsigned-reg)))
+ (:result-types positive-fixnum)
+ (:generator 6
+ (loadw res x 0 function-pointer-type)
+ (inst shr res type-bits)))
+
+(define-vop (set-header-data)
+ (:translate set-header-data)
+ (:policy :fast-safe)
+ (:args (x :scs (descriptor-reg) :target res :to (:result 0))
+ (data :scs (any-reg) :target eax))
+ (:arg-types * positive-fixnum)
+ (:results (res :scs (descriptor-reg)))
+ (:temporary (:sc unsigned-reg :offset eax-offset
+ :from (:argument 1) :to (:result 0)) eax)
+ (:generator 6
+ (move eax data)
+ (inst shl eax (- type-bits 2))
+ (inst mov al-tn (make-ea :byte :base x :disp (- other-pointer-type)))
+ (storew eax x 0 other-pointer-type)
+ (move res x)))
+\f
+(define-vop (make-fixnum)
+ (:args (ptr :scs (any-reg descriptor-reg) :target res))
+ (:results (res :scs (any-reg descriptor-reg)))
+ (:generator 1
+ ;; Some code (the hash table code) depends on this returning a
+ ;; positive number so make sure it does.
+ (move res ptr)
+ (inst shl res 3)
+ (inst shr res 1)))
+
+(define-vop (make-other-immediate-type)
+ (:args (val :scs (any-reg descriptor-reg) :target res)
+ (type :scs (unsigned-reg immediate)))
+ (:results (res :scs (any-reg descriptor-reg) :from (:argument 0)))
+ (:generator 2
+ (move res val)
+ (inst shl res (- type-bits 2))
+ (inst or res (sc-case type
+ (unsigned-reg type)
+ (immediate (tn-value type))))))
+\f
+;;;; allocation
+
+(define-vop (dynamic-space-free-pointer)
+ (:results (int :scs (sap-reg)))
+ (:result-types system-area-pointer)
+ (:translate dynamic-space-free-pointer)
+ (:policy :fast-safe)
+ (:generator 1
+ (load-symbol-value int *allocation-pointer*)))
+
+(define-vop (binding-stack-pointer-sap)
+ (:results (int :scs (sap-reg)))
+ (:result-types system-area-pointer)
+ (:translate binding-stack-pointer-sap)
+ (:policy :fast-safe)
+ (:generator 1
+ (load-symbol-value int *binding-stack-pointer*)))
+
+(defknown (setf binding-stack-pointer-sap)
+ (system-area-pointer) system-area-pointer ())
+
+(define-vop (set-binding-stack-pointer-sap)
+ (:args (new-value :scs (sap-reg) :target int))
+ (:arg-types system-area-pointer)
+ (:results (int :scs (sap-reg)))
+ (:result-types system-area-pointer)
+ (:translate (setf binding-stack-pointer-sap))
+ (:policy :fast-safe)
+ (:generator 1
+ (store-symbol-value new-value *binding-stack-pointer*)
+ (move int new-value)))
+
+(define-vop (control-stack-pointer-sap)
+ (:results (int :scs (sap-reg)))
+ (:result-types system-area-pointer)
+ (:translate control-stack-pointer-sap)
+ (:policy :fast-safe)
+ (:generator 1
+ (move int esp-tn)))
+\f
+;;;; code object frobbing
+
+(define-vop (code-instructions)
+ (:translate code-instructions)
+ (:policy :fast-safe)
+ (:args (code :scs (descriptor-reg) :to (:result 0)))
+ (:results (sap :scs (sap-reg) :from (:argument 0)))
+ (:result-types system-area-pointer)
+ (:generator 10
+ (loadw sap code 0 other-pointer-type)
+ (inst shr sap type-bits)
+ (inst lea sap (make-ea :byte :base code :index sap :scale 4
+ :disp (- other-pointer-type)))))
+
+(define-vop (compute-function)
+ (:args (code :scs (descriptor-reg) :to (:result 0))
+ (offset :scs (signed-reg unsigned-reg) :to (:result 0)))
+ (:arg-types * positive-fixnum)
+ (:results (func :scs (descriptor-reg) :from (:argument 0)))
+ (:generator 10
+ (loadw func code 0 other-pointer-type)
+ (inst shr func type-bits)
+ (inst lea func
+ (make-ea :byte :base offset :index func :scale 4
+ :disp (- function-pointer-type other-pointer-type)))
+ (inst add func code)))
+
+(defknown %function-self (function) function (flushable))
+
+(define-vop (%function-self)
+ (:policy :fast-safe)
+ (:translate %function-self)
+ (:args (function :scs (descriptor-reg)))
+ (:results (result :scs (descriptor-reg)))
+ (:generator 3
+ (loadw result function function-self-slot function-pointer-type)
+ (inst lea result
+ (make-ea :byte :base result
+ :disp (- function-pointer-type
+ (* function-code-offset word-bytes))))))
+
+;;; The closure function slot is a pointer to raw code on X86 instead of
+;;; a pointer to the code function object itself. This VOP is used
+;;; to reference the function object given the closure object.
+(def-source-transform %closure-function (closure)
+ `(%function-self ,closure))
+
+(def-source-transform %funcallable-instance-function (fin)
+ `(%function-self ,fin))
+
+(defknown (setf %function-self) (function function) function (unsafe))
+
+(define-vop (%set-function-self)
+ (:policy :fast-safe)
+ (:translate (setf %function-self))
+ (:args (new-self :scs (descriptor-reg) :target result :to :result)
+ (function :scs (descriptor-reg) :to :result))
+ (:temporary (:sc any-reg :from (:argument 0) :to :result) temp)
+ (:results (result :scs (descriptor-reg)))
+ (:generator 3
+ (inst lea temp
+ (make-ea :byte :base new-self
+ :disp (- (ash function-code-offset word-shift)
+ function-pointer-type)))
+ (storew temp function function-self-slot function-pointer-type)
+ (move result new-self)))
+
+;; We would have really liked to use a source-transform for this, but
+;; they don't work with SETF functions.
+(defknown ((setf %funcallable-instance-function)) (function function) function
+ (unsafe))
+(deftransform (setf %funcallable-instance-function) ((value fin))
+ '(setf (%function-self fin) value))
+\f
+;;;; other miscellaneous VOPs
+
+(defknown sb!unix::do-pending-interrupt () (values))
+(define-vop (sb!unix::do-pending-interrupt)
+ (:policy :fast-safe)
+ (:translate sb!unix::do-pending-interrupt)
+ (:generator 1
+ (inst break pending-interrupt-trap)))
+
+(define-vop (halt)
+ (:generator 1
+ (inst break halt-trap)))
+
+(defknown float-wait () (values))
+(define-vop (float-wait)
+ (:policy :fast-safe)
+ (:translate float-wait)
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:generator 1
+ (note-next-instruction vop :internal-error)
+ (inst wait)))
+\f
+;;;; dynamic vop count collection support
+
+#!+sb-dyncount
+(define-vop (count-me)
+ (:args (count-vector :scs (descriptor-reg)))
+ (:info index)
+ (:generator 0
+ (inst inc (make-ea :dword :base count-vector
+ :disp (- (* (+ vector-data-offset index) word-bytes)
+ other-pointer-type)))))
+\f
+;;;; primitive multi-thread support
+
+(defknown control-stack-fork ((simple-array (unsigned-byte 32) (*)) t)
+ (member t nil))
+
+(define-vop (control-stack-fork)
+ (:policy :fast-safe)
+ (:translate control-stack-fork)
+ (:args (save-stack :scs (descriptor-reg) :to :result)
+ (inherit :scs (descriptor-reg)))
+ (:arg-types simple-array-unsigned-byte-32 *)
+ (:results (child :scs (descriptor-reg)))
+ (:result-types t)
+ (:temporary (:sc unsigned-reg :from (:eval 0) :to (:eval 1)) index)
+ (:temporary (:sc unsigned-reg :from (:eval 0) :to (:eval 1)) stack)
+ (:temporary (:sc unsigned-reg :from (:eval 0) :to (:eval 1)) temp)
+ (:save-p t)
+ (:generator 25
+ (inst cmp inherit *nil-value*)
+ (inst jmp :e FRESH-STACK)
+
+ ;; Child inherits the stack of the parent.
+
+ ;; Setup the return context.
+ (inst push (make-fixup nil :code-object return))
+ (inst push ebp-tn)
+ ;; Save the stack.
+ (inst xor index index)
+ ;; First the stack-pointer.
+ (inst mov (make-ea :dword :base save-stack :index index :scale 4
+ :disp (- (* sb!vm:vector-data-offset sb!vm:word-bytes)
+ sb!vm:other-pointer-type))
+ esp-tn)
+ (inst inc index)
+ (inst mov stack (make-fixup (extern-alien-name "control_stack_end")
+ :foreign))
+ (inst jmp-short LOOP)
+
+ FRESH-STACK
+ ;; Child has a fresh control stack.
+
+ ;; Set up the return context.
+ (inst push (make-fixup nil :code-object return))
+ (inst mov stack (make-fixup (extern-alien-name "control_stack_end")
+ :foreign))
+ ;; The new FP is the top of the stack.
+ (inst push stack)
+ ;; Save the stack.
+ (inst xor index index)
+ ;; First save the adjusted stack-pointer.
+ (inst sub stack ebp-tn)
+ (inst add stack esp-tn)
+ (inst mov (make-ea :dword :base save-stack :index index :scale 4
+ :disp (- (* sb!vm:vector-data-offset sb!vm:word-bytes)
+ sb!vm:other-pointer-type))
+ stack)
+ ;; Save the current frame, replacing the OCFP and RA by 0.
+ (inst mov (make-ea :dword :base save-stack :index index :scale 4
+ :disp (- (* (+ sb!vm:vector-data-offset 1)
+ sb!vm:word-bytes)
+ sb!vm:other-pointer-type))
+ 0)
+ ;; Save 0 for the OCFP.
+ (inst mov (make-ea :dword :base save-stack :index index :scale 4
+ :disp (- (* (+ sb!vm:vector-data-offset 2)
+ sb!vm:word-bytes)
+ sb!vm:other-pointer-type))
+ 0)
+ (inst add index 3)
+ ;; Copy the remainder of the frame, skiping the OCFP and RA which
+ ;; are saved above.
+ (inst lea stack (make-ea :byte :base ebp-tn :disp -8))
+
+ LOOP
+ (inst cmp stack esp-tn)
+ (inst jmp :le stack-save-done)
+ (inst sub stack 4)
+ (inst mov temp (make-ea :dword :base stack))
+ (inst mov (make-ea :dword :base save-stack :index index :scale 4
+ :disp (- (* sb!vm:vector-data-offset sb!vm:word-bytes)
+ sb!vm:other-pointer-type))
+ temp)
+ (inst inc index)
+ (inst jmp-short LOOP)
+
+ RETURN
+ ;; Stack already clean if it reaches here. Parent returns NIL.
+ (inst mov child *nil-value*)
+ (inst jmp-short DONE)
+
+ STACK-SAVE-DONE
+ ;; Cleanup the stack
+ (inst add esp-tn 8)
+ ;; Child returns T.
+ (load-symbol child t)
+ DONE))
+
+(defknown control-stack-resume ((simple-array (unsigned-byte 32) (*))
+ (simple-array (unsigned-byte 32) (*)))
+ (values))
+
+(define-vop (control-stack-resume)
+ (:policy :fast-safe)
+ (:translate control-stack-resume)
+ (:args (save-stack :scs (descriptor-reg) :to :result)
+ (new-stack :scs (descriptor-reg) :to :result))
+ (:arg-types simple-array-unsigned-byte-32 simple-array-unsigned-byte-32)
+ (:temporary (:sc unsigned-reg :from (:eval 0) :to (:eval 1)) index)
+ (:temporary (:sc unsigned-reg :from (:eval 0) :to (:eval 1)) stack)
+ (:temporary (:sc unsigned-reg :from (:eval 0) :to (:eval 1)) temp)
+ (:save-p t)
+ (:generator 25
+ ;; Set up the return context.
+ (inst push (make-fixup nil :code-object RETURN))
+ (inst push ebp-tn)
+ ;; Save the stack.
+ (inst xor index index)
+ ;; First, the stack-pointer.
+ (inst mov (make-ea :dword :base save-stack :index index :scale 4
+ :disp (- (* sb!vm:vector-data-offset sb!vm:word-bytes)
+ sb!vm:other-pointer-type))
+ esp-tn)
+ (inst inc index)
+ (inst mov stack (make-fixup (extern-alien-name "control_stack_end")
+ :foreign))
+ LOOP
+ (inst cmp stack esp-tn)
+ (inst jmp :le STACK-SAVE-DONE)
+ (inst sub stack 4)
+ (inst mov temp (make-ea :dword :base stack))
+ (inst mov (make-ea :dword :base save-stack :index index :scale 4
+ :disp (- (* sb!vm:vector-data-offset sb!vm:word-bytes)
+ sb!vm:other-pointer-type))
+ temp)
+ (inst inc index)
+ (inst jmp-short LOOP)
+
+ STACK-SAVE-DONE
+ ;; Clean up the stack
+ (inst add esp-tn 8)
+
+ ;; Restore the new-stack.
+ (inst xor index index)
+ ;; First, the stack-pointer.
+ (inst mov esp-tn
+ (make-ea :dword :base new-stack :index index :scale 4
+ :disp (- (* sb!vm:vector-data-offset sb!vm:word-bytes)
+ sb!vm:other-pointer-type)))
+ (inst inc index)
+ (inst mov stack (make-fixup (extern-alien-name "control_stack_end")
+ :foreign))
+ LOOP2
+ (inst cmp stack esp-tn)
+ (inst jmp :le STACK-RESTORE-DONE)
+ (inst sub stack 4)
+ (inst mov temp (make-ea :dword :base new-stack :index index :scale 4
+ :disp (- (* sb!vm:vector-data-offset
+ sb!vm:word-bytes)
+ sb!vm:other-pointer-type)))
+ (inst mov (make-ea :dword :base stack) temp)
+ (inst inc index)
+ (inst jmp-short LOOP2)
+ STACK-RESTORE-DONE
+ ;; Pop the frame pointer, and resume at the return address.
+ (inst pop ebp-tn)
+ (inst ret)
+
+ ;; Original thread resumes, stack has been cleaned up.
+ RETURN))
+
+(defknown control-stack-return ((simple-array (unsigned-byte 32) (*)))
+ (values))
+
+(define-vop (control-stack-return)
+ (:policy :fast-safe)
+ (:translate control-stack-return)
+ (:args (new-stack :scs (descriptor-reg) :to :result))
+ (:arg-types simple-array-unsigned-byte-32)
+ (:temporary (:sc unsigned-reg :from (:eval 0) :to (:eval 1)) index)
+ (:temporary (:sc unsigned-reg :from (:eval 0) :to (:eval 1)) stack)
+ (:temporary (:sc unsigned-reg :from (:eval 0) :to (:eval 1)) temp)
+ (:save-p t)
+ (:generator 25
+ ;; Restore the new-stack.
+ (inst xor index index)
+ ;; First the stack-pointer.
+ (inst mov esp-tn
+ (make-ea :dword :base new-stack :index index :scale 4
+ :disp (- (* sb!vm:vector-data-offset sb!vm:word-bytes)
+ sb!vm:other-pointer-type)))
+ (inst inc index)
+ (inst mov stack (make-fixup (extern-alien-name "control_stack_end")
+ :foreign))
+ LOOP
+ (inst cmp stack esp-tn)
+ (inst jmp :le STACK-RESTORE-DONE)
+ (inst sub stack 4)
+ (inst mov temp (make-ea :dword :base new-stack :index index :scale 4
+ :disp (- (* sb!vm:vector-data-offset
+ sb!vm:word-bytes)
+ sb!vm:other-pointer-type)))
+ (inst mov (make-ea :dword :base stack) temp)
+ (inst inc index)
+ (inst jmp-short LOOP)
+ STACK-RESTORE-DONE
+ ;; Pop the frame pointer, and resume at the return address.
+ (inst pop ebp-tn)
+ (inst ret)))
--- /dev/null
+;;;; target-only stuff from CMU CL's src/compiler/x86/insts.lisp
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!VM")
+
+(file-comment
+ "$Header$")
+
+(defun print-mem-access (value stream print-size-p dstate)
+ (declare (type list value)
+ (type stream stream)
+ (type (member t nil) print-size-p)
+ (type sb!disassem:disassem-state dstate))
+ (when print-size-p
+ (princ (sb!disassem:dstate-get-prop dstate 'width) stream)
+ (princ '| PTR | stream))
+ (write-char #\[ stream)
+ (let ((firstp t))
+ (macrolet ((pel ((var val) &body body)
+ ;; Print an element of the address, maybe with
+ ;; a leading separator.
+ `(let ((,var ,val))
+ (when ,var
+ (unless firstp
+ (write-char #\+ stream))
+ ,@body
+ (setq firstp nil)))))
+ (pel (base-reg (first value))
+ (print-addr-reg base-reg stream dstate))
+ (pel (index-reg (third value))
+ (print-addr-reg index-reg stream dstate)
+ (let ((index-scale (fourth value)))
+ (when (and index-scale (not (= index-scale 1)))
+ (write-char #\* stream)
+ (princ index-scale stream))))
+ (let ((offset (second value)))
+ (when (and offset (or firstp (not (zerop offset))))
+ (unless (or firstp (minusp offset))
+ (write-char #\+ stream))
+ (if firstp
+ (sb!disassem:princ16 offset stream)
+ (princ offset stream))))))
+ (write-char #\] stream))
--- /dev/null
+;;;; type testing and checking VOPs for the x86 VM
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!VM")
+
+(file-comment
+ "$Header$")
+\f
+;;;; test generation utilities
+
+(eval-when (:compile-toplevel :execute)
+
+(defparameter immediate-types
+ (list unbound-marker-type base-char-type))
+
+(defparameter function-header-types
+ (list funcallable-instance-header-type
+ byte-code-function-type byte-code-closure-type
+ function-header-type closure-function-header-type
+ closure-header-type))
+
+(defun canonicalize-headers (headers)
+ (collect ((results))
+ (let ((start nil)
+ (prev nil)
+ (delta (- other-immediate-1-type other-immediate-0-type)))
+ (flet ((emit-test ()
+ (results (if (= start prev)
+ start
+ (cons start prev)))))
+ (dolist (header (sort headers #'<))
+ (cond ((null start)
+ (setf start header)
+ (setf prev header))
+ ((= header (+ prev delta))
+ (setf prev header))
+ (t
+ (emit-test)
+ (setf start header)
+ (setf prev header))))
+ (emit-test)))
+ (results)))
+
+) ; EVAL-WHEN
+
+(macrolet ((test-type (value target not-p &rest type-codes)
+ ;; Determine what interesting combinations we need to test for.
+ (let* ((type-codes (mapcar #'eval type-codes))
+ (fixnump (and (member even-fixnum-type type-codes)
+ (member odd-fixnum-type type-codes)
+ t))
+ (lowtags (remove lowtag-limit type-codes :test #'<))
+ (extended (remove lowtag-limit type-codes :test #'>))
+ (immediates (intersection extended immediate-types :test #'eql))
+ (headers (set-difference extended immediate-types :test #'eql))
+ (function-p (if (intersection headers function-header-types)
+ (if (subsetp headers function-header-types)
+ t
+ (error "can't test for mix of function subtypes ~
+ and normal header types"))
+ nil)))
+ (unless type-codes
+ (error "At least one type must be supplied for TEST-TYPE."))
+ (cond
+ (fixnump
+ (when (remove-if #'(lambda (x)
+ (or (= x even-fixnum-type)
+ (= x odd-fixnum-type)))
+ lowtags)
+ (error "can't mix fixnum testing with other lowtags"))
+ (when function-p
+ (error "can't mix fixnum testing with function subtype testing"))
+ (when immediates
+ (error "can't mix fixnum testing with other immediates"))
+ (if headers
+ `(%test-fixnum-and-headers ,value ,target ,not-p
+ ',(canonicalize-headers headers))
+ `(%test-fixnum ,value ,target ,not-p)))
+ (immediates
+ (when headers
+ (error "can't mix testing of immediates with testing of headers"))
+ (when lowtags
+ (error "can't mix testing of immediates with testing of lowtags"))
+ (when (cdr immediates)
+ (error "can't test multiple immediates at the same time"))
+ `(%test-immediate ,value ,target ,not-p ,(car immediates)))
+ (lowtags
+ (when (cdr lowtags)
+ (error "can't test multiple lowtags at the same time"))
+ (if headers
+ `(%test-lowtag-and-headers
+ ,value ,target ,not-p ,(car lowtags)
+ ,function-p ',(canonicalize-headers headers))
+ `(%test-lowtag ,value ,target ,not-p ,(car lowtags))))
+ (headers
+ `(%test-headers ,value ,target ,not-p ,function-p
+ ',(canonicalize-headers headers)))
+ (t
+ (error "nothing to test?"))))))
+
+;;; Emit the most compact form of the test immediate instruction,
+;;; using an 8 bit test when the immediate is only 8 bits and the
+;;; value is one of the four low registers (eax, ebx, ecx, edx) or the
+;;; control-stack.
+(defun generate-fixnum-test (value)
+ (let ((offset (tn-offset value)))
+ (cond ((and (sc-is value any-reg descriptor-reg)
+ (or (= offset eax-offset) (= offset ebx-offset)
+ (= offset ecx-offset) (= offset edx-offset)))
+ (inst test (make-random-tn :kind :normal
+ :sc (sc-or-lose 'byte-reg)
+ :offset offset)
+ 3))
+ ((sc-is value control-stack)
+ (inst test (make-ea :byte :base ebp-tn
+ :disp (- (* (1+ offset) sb!vm:word-bytes)))
+ 3))
+ (t
+ (inst test value 3)))))
+
+(defun %test-fixnum (value target not-p)
+ (generate-fixnum-test value)
+ (inst jmp (if not-p :nz :z) target))
+
+(defun %test-fixnum-and-headers (value target not-p headers)
+ (let ((drop-through (gen-label)))
+ (generate-fixnum-test value)
+ (inst jmp :z (if not-p drop-through target))
+ (%test-headers value target not-p nil headers drop-through)))
+
+(defun %test-immediate (value target not-p immediate)
+ ;; Code a single instruction byte test if possible.
+ (let ((offset (tn-offset value)))
+ (cond ((and (sc-is value any-reg descriptor-reg)
+ (or (= offset eax-offset) (= offset ebx-offset)
+ (= offset ecx-offset) (= offset edx-offset)))
+ (inst cmp (make-random-tn :kind :normal
+ :sc (sc-or-lose 'byte-reg)
+ :offset offset)
+ immediate))
+ (t
+ (move eax-tn value)
+ (inst cmp al-tn immediate))))
+ (inst jmp (if not-p :ne :e) target))
+
+(defun %test-lowtag (value target not-p lowtag &optional al-loaded)
+ (unless al-loaded
+ (move eax-tn value)
+ (inst and al-tn lowtag-mask))
+ (inst cmp al-tn lowtag)
+ (inst jmp (if not-p :ne :e) target))
+
+(defun %test-lowtag-and-headers (value target not-p lowtag function-p headers)
+ (let ((drop-through (gen-label)))
+ (%test-lowtag value (if not-p drop-through target) nil lowtag)
+ (%test-headers value target not-p function-p headers drop-through t)))
+
+
+(defun %test-headers (value target not-p function-p headers
+ &optional (drop-through (gen-label)) al-loaded)
+ (let ((lowtag (if function-p function-pointer-type other-pointer-type)))
+ (multiple-value-bind (equal less-or-equal when-true when-false)
+ ;; EQUAL and LESS-OR-EQUAL are the conditions for branching to TARGET.
+ ;; WHEN-TRUE and WHEN-FALSE are the labels to branch to when we know
+ ;; it's true and when we know it's false respectively.
+ (if not-p
+ (values :ne :a drop-through target)
+ (values :e :na target drop-through))
+ (%test-lowtag value when-false t lowtag al-loaded)
+ (inst mov al-tn (make-ea :byte :base value :disp (- lowtag)))
+ (do ((remaining headers (cdr remaining)))
+ ((null remaining))
+ (let ((header (car remaining))
+ (last (null (cdr remaining))))
+ (cond
+ ((atom header)
+ (inst cmp al-tn header)
+ (if last
+ (inst jmp equal target)
+ (inst jmp :e when-true)))
+ (t
+ (let ((start (car header))
+ (end (cdr header)))
+ (unless (= start bignum-type)
+ (inst cmp al-tn start)
+ (inst jmp :b when-false)) ; was :l
+ (inst cmp al-tn end)
+ (if last
+ (inst jmp less-or-equal target)
+ (inst jmp :be when-true))))))) ; was :le
+ (emit-label drop-through))))
+
+;; pw -- based on RISC version. Not sure extra hair is needed yet.
+;; difference is that this one uses SUB which overwrites operand
+;; both cmp and sub take 2 cycles so maybe its a wash
+#+nil
+(defun %test-headers (value target not-p function-p headers
+ &optional (drop-through (gen-label)) al-loaded)
+ (let ((lowtag (if function-p function-pointer-type other-pointer-type)))
+ (multiple-value-bind (equal less-or-equal when-true when-false)
+ ;; EQUAL and LESS-OR-EQUAL are the conditions for branching to TARGET.
+ ;; WHEN-TRUE and WHEN-FALSE are the labels to branch to when we know
+ ;; it's true and when we know it's false respectively.
+ (if not-p
+ (values :ne :a drop-through target)
+ (values :e :na target drop-through))
+ (%test-lowtag value when-false t lowtag al-loaded)
+ (inst mov al-tn (make-ea :byte :base value :disp (- lowtag)))
+ (let ((delta 0))
+ (do ((remaining headers (cdr remaining)))
+ ((null remaining))
+ (let ((header (car remaining))
+ (last (null (cdr remaining))))
+ (cond
+ ((atom header)
+ (inst sub al-tn (- header delta))
+ (setf delta header)
+ (if last
+ (inst jmp equal target)
+ (inst jmp :e when-true)))
+ (t
+ (let ((start (car header))
+ (end (cdr header)))
+ (unless (= start bignum-type)
+ (inst sub al-tn (- start delta))
+ (setf delta start)
+ (inst jmp :l when-false))
+ (inst sub al-tn (- end delta))
+ (setf delta end)
+ (if last
+ (inst jmp less-or-equal target)
+ (inst jmp :le when-true))))))))
+ (emit-label drop-through))))
+\f
+;;;; type checking and testing
+
+(define-vop (check-type)
+ (:args (value :target result :scs (any-reg descriptor-reg)))
+ (:results (result :scs (any-reg descriptor-reg)))
+ (:temporary (:sc unsigned-reg :offset eax-offset :to (:result 0)) eax)
+ (:ignore eax)
+ (:vop-var vop)
+ (:save-p :compute-only))
+
+(define-vop (type-predicate)
+ (:args (value :scs (any-reg descriptor-reg)))
+ (:temporary (:sc unsigned-reg :offset eax-offset) eax)
+ (:ignore eax)
+ (:conditional)
+ (:info target not-p)
+ (:policy :fast-safe))
+
+;;; Simpler VOP that don't need a temporary register.
+(define-vop (simple-check-type)
+ (:args (value :target result :scs (any-reg descriptor-reg)))
+ (:results (result :scs (any-reg descriptor-reg)
+ :load-if (not (and (sc-is value any-reg descriptor-reg)
+ (sc-is result control-stack)))))
+ (:vop-var vop)
+ (:save-p :compute-only))
+
+(define-vop (simple-type-predicate)
+ (:args (value :scs (any-reg descriptor-reg control-stack)))
+ (:conditional)
+ (:info target not-p)
+ (:policy :fast-safe))
+
+(eval-when (:compile-toplevel :execute)
+
+(defun cost-to-test-types (type-codes)
+ (+ (* 2 (length type-codes))
+ (if (> (apply #'max type-codes) lowtag-limit) 7 2)))
+
+); EVAL-WHEN
+
+;;; FIXME: DEF-TYPE-VOPS and DEF-SIMPLE-TYPE-VOPS are only used in
+;;; this file, so they should be in the EVAL-WHEN above, or otherwise
+;;; tweaked so that they don't appear in the target system.
+
+(defmacro def-type-vops (pred-name check-name ptype error-code
+ &rest type-codes)
+ (let ((cost (cost-to-test-types (mapcar #'eval type-codes))))
+ `(progn
+ ,@(when pred-name
+ `((define-vop (,pred-name type-predicate)
+ (:translate ,pred-name)
+ (:generator ,cost
+ (test-type value target not-p ,@type-codes)))))
+ ,@(when check-name
+ `((define-vop (,check-name check-type)
+ (:generator ,cost
+ (let ((err-lab
+ (generate-error-code vop ,error-code value)))
+ (test-type value err-lab t ,@type-codes)
+ (move result value))))))
+ ,@(when ptype
+ `((primitive-type-vop ,check-name (:check) ,ptype))))))
+
+(defmacro def-simple-type-vops (pred-name check-name ptype error-code
+ &rest type-codes)
+ (let ((cost (cost-to-test-types (mapcar #'eval type-codes))))
+ `(progn
+ ,@(when pred-name
+ `((define-vop (,pred-name simple-type-predicate)
+ (:translate ,pred-name)
+ (:generator ,cost
+ (test-type value target not-p ,@type-codes)))))
+ ,@(when check-name
+ `((define-vop (,check-name simple-check-type)
+ (:generator ,cost
+ (let ((err-lab
+ (generate-error-code vop ,error-code value)))
+ (test-type value err-lab t ,@type-codes)
+ (move result value))))))
+ ,@(when ptype
+ `((primitive-type-vop ,check-name (:check) ,ptype))))))
+
+(def-simple-type-vops fixnump check-fixnum fixnum object-not-fixnum-error
+ even-fixnum-type odd-fixnum-type)
+
+(def-type-vops functionp check-function function
+ object-not-function-error function-pointer-type)
+
+(def-type-vops listp check-list list object-not-list-error
+ list-pointer-type)
+
+(def-type-vops %instancep check-instance instance object-not-instance-error
+ instance-pointer-type)
+
+(def-type-vops bignump check-bignum bignum
+ object-not-bignum-error bignum-type)
+
+(def-type-vops ratiop check-ratio ratio
+ object-not-ratio-error ratio-type)
+
+(def-type-vops complexp check-complex complex object-not-complex-error
+ complex-type complex-single-float-type complex-double-float-type
+ #!+long-float complex-long-float-type)
+
+(def-type-vops complex-rational-p check-complex-rational nil
+ object-not-complex-rational-error complex-type)
+
+(def-type-vops complex-float-p check-complex-float nil
+ object-not-complex-float-error
+ complex-single-float-type complex-double-float-type
+ #!+long-float complex-long-float-type)
+
+(def-type-vops complex-single-float-p check-complex-single-float
+ complex-single-float object-not-complex-single-float-error
+ complex-single-float-type)
+
+(def-type-vops complex-double-float-p check-complex-double-float
+ complex-double-float object-not-complex-double-float-error
+ complex-double-float-type)
+
+#!+long-float
+(def-type-vops complex-long-float-p check-complex-long-float
+ complex-long-float object-not-complex-long-float-error
+ complex-long-float-type)
+
+(def-type-vops single-float-p check-single-float single-float
+ object-not-single-float-error single-float-type)
+
+(def-type-vops double-float-p check-double-float double-float
+ object-not-double-float-error double-float-type)
+
+#!+long-float
+(def-type-vops long-float-p check-long-float long-float
+ object-not-long-float-error long-float-type)
+
+(def-type-vops simple-string-p check-simple-string simple-string
+ object-not-simple-string-error simple-string-type)
+
+(def-type-vops simple-bit-vector-p check-simple-bit-vector simple-bit-vector
+ object-not-simple-bit-vector-error simple-bit-vector-type)
+
+(def-type-vops simple-vector-p check-simple-vector simple-vector
+ object-not-simple-vector-error simple-vector-type)
+
+(def-type-vops simple-array-unsigned-byte-2-p
+ check-simple-array-unsigned-byte-2
+ simple-array-unsigned-byte-2
+ object-not-simple-array-unsigned-byte-2-error
+ simple-array-unsigned-byte-2-type)
+
+(def-type-vops simple-array-unsigned-byte-4-p
+ check-simple-array-unsigned-byte-4
+ simple-array-unsigned-byte-4
+ object-not-simple-array-unsigned-byte-4-error
+ simple-array-unsigned-byte-4-type)
+
+(def-type-vops simple-array-unsigned-byte-8-p
+ check-simple-array-unsigned-byte-8
+ simple-array-unsigned-byte-8
+ object-not-simple-array-unsigned-byte-8-error
+ simple-array-unsigned-byte-8-type)
+
+(def-type-vops simple-array-unsigned-byte-16-p
+ check-simple-array-unsigned-byte-16
+ simple-array-unsigned-byte-16
+ object-not-simple-array-unsigned-byte-16-error
+ simple-array-unsigned-byte-16-type)
+
+(def-type-vops simple-array-unsigned-byte-32-p
+ check-simple-array-unsigned-byte-32
+ simple-array-unsigned-byte-32
+ object-not-simple-array-unsigned-byte-32-error
+ simple-array-unsigned-byte-32-type)
+
+(def-type-vops simple-array-signed-byte-8-p
+ check-simple-array-signed-byte-8
+ simple-array-signed-byte-8
+ object-not-simple-array-signed-byte-8-error
+ simple-array-signed-byte-8-type)
+
+(def-type-vops simple-array-signed-byte-16-p
+ check-simple-array-signed-byte-16
+ simple-array-signed-byte-16
+ object-not-simple-array-signed-byte-16-error
+ simple-array-signed-byte-16-type)
+
+(def-type-vops simple-array-signed-byte-30-p
+ check-simple-array-signed-byte-30
+ simple-array-signed-byte-30
+ object-not-simple-array-signed-byte-30-error
+ simple-array-signed-byte-30-type)
+
+(def-type-vops simple-array-signed-byte-32-p
+ check-simple-array-signed-byte-32
+ simple-array-signed-byte-32
+ object-not-simple-array-signed-byte-32-error
+ simple-array-signed-byte-32-type)
+
+(def-type-vops simple-array-single-float-p check-simple-array-single-float
+ simple-array-single-float object-not-simple-array-single-float-error
+ simple-array-single-float-type)
+
+(def-type-vops simple-array-double-float-p check-simple-array-double-float
+ simple-array-double-float object-not-simple-array-double-float-error
+ simple-array-double-float-type)
+
+#!+long-float
+(def-type-vops simple-array-long-float-p check-simple-array-long-float
+ simple-array-long-float object-not-simple-array-long-float-error
+ simple-array-long-float-type)
+
+(def-type-vops simple-array-complex-single-float-p
+ check-simple-array-complex-single-float
+ simple-array-complex-single-float
+ object-not-simple-array-complex-single-float-error
+ simple-array-complex-single-float-type)
+
+(def-type-vops simple-array-complex-double-float-p
+ check-simple-array-complex-double-float
+ simple-array-complex-double-float
+ object-not-simple-array-complex-double-float-error
+ simple-array-complex-double-float-type)
+
+#!+long-float
+(def-type-vops simple-array-complex-long-float-p
+ check-simple-array-complex-long-float
+ simple-array-complex-long-float
+ object-not-simple-array-complex-long-float-error
+ simple-array-complex-long-float-type)
+
+(def-type-vops base-char-p check-base-char base-char
+ object-not-base-char-error base-char-type)
+
+(def-type-vops system-area-pointer-p check-system-area-pointer
+ system-area-pointer object-not-sap-error sap-type)
+
+(def-type-vops weak-pointer-p check-weak-pointer weak-pointer
+ object-not-weak-pointer-error weak-pointer-type)
+
+(def-type-vops code-component-p nil nil nil
+ code-header-type)
+
+(def-type-vops lra-p nil nil nil
+ return-pc-header-type)
+
+(def-type-vops fdefn-p nil nil nil
+ fdefn-type)
+
+(def-type-vops funcallable-instance-p nil nil nil
+ funcallable-instance-header-type)
+
+(def-type-vops array-header-p nil nil nil
+ simple-array-type complex-string-type complex-bit-vector-type
+ complex-vector-type complex-array-type)
+
+(def-type-vops nil check-function-or-symbol nil
+ object-not-function-or-symbol-error
+ function-pointer-type symbol-header-type)
+
+(def-type-vops stringp check-string nil object-not-string-error
+ simple-string-type complex-string-type)
+
+(def-type-vops bit-vector-p check-bit-vector nil object-not-bit-vector-error
+ simple-bit-vector-type complex-bit-vector-type)
+
+(def-type-vops vectorp check-vector nil object-not-vector-error
+ simple-string-type simple-bit-vector-type simple-vector-type
+ simple-array-unsigned-byte-2-type simple-array-unsigned-byte-4-type
+ simple-array-unsigned-byte-8-type simple-array-unsigned-byte-16-type
+ simple-array-unsigned-byte-32-type
+ simple-array-signed-byte-8-type simple-array-signed-byte-16-type
+ simple-array-signed-byte-30-type simple-array-signed-byte-32-type
+ simple-array-single-float-type simple-array-double-float-type
+ #!+long-float simple-array-long-float-type
+ simple-array-complex-single-float-type
+ simple-array-complex-double-float-type
+ #!+long-float simple-array-complex-long-float-type
+ complex-string-type complex-bit-vector-type complex-vector-type)
+
+;;; Note that this "type VOP" is sort of an oddball; it doesn't so
+;;; much test for a Lisp-level type as just expose a low-level type
+;;; code at the Lisp level. It is used as a building block to help us
+;;; to express things like the test for (TYPEP FOO '(VECTOR T))
+;;; efficiently in Lisp code, but it doesn't correspond to any type
+;;; expression which would actually occur in reasonable application
+;;; code. (Common Lisp doesn't have any natural way of expressing this
+;;; type.) Thus, there's no point in building up the full machinery of
+;;; associated backend type predicates and so forth as we do for
+;;; ordinary type VOPs.
+(def-type-vops complex-vector-p check-complex-vector nil object-not-complex-vector-error
+ complex-vector-type)
+
+(def-type-vops simple-array-p check-simple-array nil object-not-simple-array-error
+ simple-array-type simple-string-type simple-bit-vector-type
+ simple-vector-type simple-array-unsigned-byte-2-type
+ simple-array-unsigned-byte-4-type simple-array-unsigned-byte-8-type
+ simple-array-unsigned-byte-16-type simple-array-unsigned-byte-32-type
+ simple-array-signed-byte-8-type simple-array-signed-byte-16-type
+ simple-array-signed-byte-30-type simple-array-signed-byte-32-type
+ simple-array-single-float-type simple-array-double-float-type
+ #!+long-float simple-array-long-float-type
+ simple-array-complex-single-float-type
+ simple-array-complex-double-float-type
+ #!+long-float simple-array-complex-long-float-type)
+
+(def-type-vops arrayp check-array nil object-not-array-error
+ simple-array-type simple-string-type simple-bit-vector-type
+ simple-vector-type simple-array-unsigned-byte-2-type
+ simple-array-unsigned-byte-4-type simple-array-unsigned-byte-8-type
+ simple-array-unsigned-byte-16-type simple-array-unsigned-byte-32-type
+ simple-array-signed-byte-8-type simple-array-signed-byte-16-type
+ simple-array-signed-byte-30-type simple-array-signed-byte-32-type
+ simple-array-single-float-type simple-array-double-float-type
+ #!+long-float simple-array-long-float-type
+ simple-array-complex-single-float-type
+ simple-array-complex-double-float-type
+ #!+long-float simple-array-complex-long-float-type
+ complex-string-type complex-bit-vector-type complex-vector-type
+ complex-array-type)
+
+(def-type-vops numberp check-number nil object-not-number-error
+ even-fixnum-type odd-fixnum-type bignum-type ratio-type
+ single-float-type double-float-type #!+long-float long-float-type complex-type
+ complex-single-float-type complex-double-float-type
+ #!+long-float complex-long-float-type)
+
+(def-type-vops rationalp check-rational nil object-not-rational-error
+ even-fixnum-type odd-fixnum-type ratio-type bignum-type)
+
+(def-type-vops integerp check-integer nil object-not-integer-error
+ even-fixnum-type odd-fixnum-type bignum-type)
+
+(def-type-vops floatp check-float nil object-not-float-error
+ single-float-type double-float-type #!+long-float long-float-type)
+
+(def-type-vops realp check-real nil object-not-real-error
+ even-fixnum-type odd-fixnum-type ratio-type bignum-type
+ single-float-type double-float-type #!+long-float long-float-type)
+\f
+;;;; other integer ranges
+
+;;; A (SIGNED-BYTE 32) can be represented with either fixnum or a bignum with
+;;; exactly one digit.
+
+(define-vop (signed-byte-32-p type-predicate)
+ (:translate signed-byte-32-p)
+ (:generator 45
+ (multiple-value-bind (yep nope)
+ (if not-p
+ (values not-target target)
+ (values target not-target))
+ (generate-fixnum-test value)
+ (inst jmp :e yep)
+ (move eax-tn value)
+ (inst and al-tn lowtag-mask)
+ (inst cmp al-tn other-pointer-type)
+ (inst jmp :ne nope)
+ (loadw eax-tn value 0 other-pointer-type)
+ (inst cmp eax-tn (+ (ash 1 type-bits) bignum-type))
+ (inst jmp (if not-p :ne :e) target))
+ NOT-TARGET))
+
+(define-vop (check-signed-byte-32 check-type)
+ (:generator 45
+ (let ((nope (generate-error-code vop
+ object-not-signed-byte-32-error
+ value)))
+ (generate-fixnum-test value)
+ (inst jmp :e yep)
+ (move eax-tn value)
+ (inst and al-tn lowtag-mask)
+ (inst cmp al-tn other-pointer-type)
+ (inst jmp :ne nope)
+ (loadw eax-tn value 0 other-pointer-type)
+ (inst cmp eax-tn (+ (ash 1 type-bits) bignum-type))
+ (inst jmp :ne nope))
+ YEP
+ (move result value)))
+
+;;; An (unsigned-byte 32) can be represented with either a positive fixnum, a
+;;; bignum with exactly one positive digit, or a bignum with exactly two digits
+;;; and the second digit all zeros.
+
+(define-vop (unsigned-byte-32-p type-predicate)
+ (:translate unsigned-byte-32-p)
+ (:generator 45
+ (let ((not-target (gen-label))
+ (single-word (gen-label))
+ (fixnum (gen-label)))
+ (multiple-value-bind (yep nope)
+ (if not-p
+ (values not-target target)
+ (values target not-target))
+ ;; Is it a fixnum?
+ (generate-fixnum-test value)
+ (move eax-tn value)
+ (inst jmp :e fixnum)
+
+ ;; If not, is it an other pointer?
+ (inst and al-tn lowtag-mask)
+ (inst cmp al-tn other-pointer-type)
+ (inst jmp :ne nope)
+ ;; Get the header.
+ (loadw eax-tn value 0 other-pointer-type)
+ ;; Is it one?
+ (inst cmp eax-tn (+ (ash 1 type-bits) bignum-type))
+ (inst jmp :e single-word)
+ ;; If it's other than two, we can't be an (unsigned-byte 32)
+ (inst cmp eax-tn (+ (ash 2 type-bits) bignum-type))
+ (inst jmp :ne nope)
+ ;; Get the second digit.
+ (loadw eax-tn value (1+ bignum-digits-offset) other-pointer-type)
+ ;; All zeros, its an (unsigned-byte 32).
+ (inst or eax-tn eax-tn)
+ (inst jmp :z yep)
+ (inst jmp nope)
+
+ (emit-label single-word)
+ ;; Get the single digit.
+ (loadw eax-tn value bignum-digits-offset other-pointer-type)
+
+ ;; positive implies (unsigned-byte 32).
+ (emit-label fixnum)
+ (inst or eax-tn eax-tn)
+ (inst jmp (if not-p :s :ns) target)
+
+ (emit-label not-target)))))
+
+(define-vop (check-unsigned-byte-32 check-type)
+ (:generator 45
+ (let ((nope
+ (generate-error-code vop object-not-unsigned-byte-32-error value))
+ (yep (gen-label))
+ (fixnum (gen-label))
+ (single-word (gen-label)))
+
+ ;; Is it a fixnum?
+ (generate-fixnum-test value)
+ (move eax-tn value)
+ (inst jmp :e fixnum)
+
+ ;; If not, is it an other pointer?
+ (inst and al-tn lowtag-mask)
+ (inst cmp al-tn other-pointer-type)
+ (inst jmp :ne nope)
+ ;; Get the header.
+ (loadw eax-tn value 0 other-pointer-type)
+ ;; Is it one?
+ (inst cmp eax-tn (+ (ash 1 type-bits) bignum-type))
+ (inst jmp :e single-word)
+ ;; If it's other than two, we can't be an (unsigned-byte 32)
+ (inst cmp eax-tn (+ (ash 2 type-bits) bignum-type))
+ (inst jmp :ne nope)
+ ;; Get the second digit.
+ (loadw eax-tn value (1+ bignum-digits-offset) other-pointer-type)
+ ;; All zeros, its an (unsigned-byte 32).
+ (inst or eax-tn eax-tn)
+ (inst jmp :z yep)
+ (inst jmp nope)
+
+ (emit-label single-word)
+ ;; Get the single digit.
+ (loadw eax-tn value bignum-digits-offset other-pointer-type)
+
+ ;; positive implies (unsigned-byte 32).
+ (emit-label fixnum)
+ (inst or eax-tn eax-tn)
+ (inst jmp :s nope)
+
+ (emit-label yep)
+ (move result value))))
+\f
+;;;; list/symbol types
+;;;
+;;; symbolp (or symbol (eq nil))
+;;; consp (and list (not (eq nil)))
+
+(define-vop (symbolp type-predicate)
+ (:translate symbolp)
+ (:generator 12
+ (let ((is-symbol-label (if not-p drop-thru target)))
+ (inst cmp value *nil-value*)
+ (inst jmp :e is-symbol-label)
+ (test-type value target not-p symbol-header-type))
+ DROP-THRU))
+
+(define-vop (check-symbol check-type)
+ (:generator 12
+ (let ((error (generate-error-code vop object-not-symbol-error value)))
+ (inst cmp value *nil-value*)
+ (inst jmp :e drop-thru)
+ (test-type value error t symbol-header-type))
+ DROP-THRU
+ (move result value)))
+
+(define-vop (consp type-predicate)
+ (:translate consp)
+ (:generator 8
+ (let ((is-not-cons-label (if not-p target drop-thru)))
+ (inst cmp value *nil-value*)
+ (inst jmp :e is-not-cons-label)
+ (test-type value target not-p list-pointer-type))
+ DROP-THRU))
+
+(define-vop (check-cons check-type)
+ (:generator 8
+ (let ((error (generate-error-code vop object-not-cons-error value)))
+ (inst cmp value *nil-value*)
+ (inst jmp :e error)
+ (test-type value error t list-pointer-type)
+ (move result value))))
+\f
+) ; MACROLET
--- /dev/null
+;;;; unknown-values VOPs for the x86 VM
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!VM")
+
+(file-comment
+ "$Header$")
+
+(define-vop (reset-stack-pointer)
+ (:args (ptr :scs (any-reg)))
+ (:generator 1
+ (move esp-tn ptr)))
+
+;;; Push some values onto the stack, returning the start and number of values
+;;; pushed as results. It is assumed that the Vals are wired to the standard
+;;; argument locations. Nvals is the number of values to push.
+;;;
+;;; The generator cost is pseudo-random. We could get it right by defining a
+;;; bogus SC that reflects the costs of the memory-to-memory moves for each
+;;; operand, but this seems unworthwhile.
+(define-vop (push-values)
+ (:args (vals :more t))
+ (:temporary (:sc unsigned-reg :to (:result 0) :target start) temp)
+ (:results (start) (count))
+ (:info nvals)
+ (:generator 20
+ (move temp esp-tn) ; WARN pointing 1 below
+ (do ((val vals (tn-ref-across val)))
+ ((null val))
+ (inst push (tn-ref-tn val)))
+ (move start temp)
+ (inst mov count (fixnumize nvals))))
+
+;;; Push a list of values on the stack, returning Start and Count as used in
+;;; unknown values continuations.
+(define-vop (values-list)
+ (:args (arg :scs (descriptor-reg) :target list))
+ (:arg-types list)
+ (:policy :fast-safe)
+ (:results (start :scs (any-reg))
+ (count :scs (any-reg)))
+ (:temporary (:sc descriptor-reg :from (:argument 0) :to (:result 1)) list)
+ (:temporary (:sc descriptor-reg :to (:result 1)) nil-temp)
+ (:temporary (:sc unsigned-reg :offset eax-offset :to (:result 1)) eax)
+ (:vop-var vop)
+ (:save-p :compute-only)
+ (:generator 0
+ (move list arg)
+ (move start esp-tn) ; WARN pointing 1 below
+ (inst mov nil-temp *nil-value*)
+
+ LOOP
+ (inst cmp list nil-temp)
+ (inst jmp :e done)
+ (pushw list cons-car-slot list-pointer-type)
+ (loadw list list cons-cdr-slot list-pointer-type)
+ (inst mov eax list)
+ (inst and al-tn lowtag-mask)
+ (inst cmp al-tn list-pointer-type)
+ (inst jmp :e loop)
+ (error-call vop bogus-argument-to-values-list-error list)
+
+ DONE
+ (inst mov count start) ; start is high address
+ (inst sub count esp-tn))) ; stackp is low address
+
+;;; Copy the more arg block to the top of the stack so we can use them
+;;; as function arguments.
+;;;
+;;; Accepts a context as produced by more-arg-context; points to the first
+;;; value on the stack, not 4 bytes above as in other contexts.
+;;;
+;;; Return a context that is 4 bytes above the first value, suitable for
+;;; defining a new stack frame.
+(define-vop (%more-arg-values)
+ (:args (context :scs (descriptor-reg any-reg) :target src)
+ (skip :scs (any-reg immediate))
+ (num :scs (any-reg) :target count))
+ (:arg-types * positive-fixnum positive-fixnum)
+ (:temporary (:sc any-reg :offset esi-offset :from (:argument 0)) src)
+ (:temporary (:sc descriptor-reg :offset eax-offset) temp)
+ (:temporary (:sc unsigned-reg :offset ecx-offset) temp1)
+ (:results (start :scs (any-reg))
+ (count :scs (any-reg)))
+ (:generator 20
+ (sc-case skip
+ (immediate
+ (cond ((zerop (tn-value skip))
+ (move src context)
+ (move count num))
+ (t
+ (inst lea src (make-ea :dword :base context
+ :disp (- (* (tn-value skip) word-bytes))))
+ (move count num)
+ (inst sub count (* (tn-value skip) word-bytes)))))
+
+ (any-reg
+ (move src context)
+ (inst sub src skip)
+ (move count num)
+ (inst sub count skip)))
+
+ (move temp1 count)
+ (inst mov start esp-tn)
+ (inst jecxz done) ; check for 0 count?
+
+ (inst shr temp1 word-shift) ; convert the fixnum to a count.
+
+ (inst std) ; move down the stack as more value are copied to the bottom.
+ LOOP
+ (inst lods temp)
+ (inst push temp)
+ (inst loop loop)
+
+ DONE))
+
--- /dev/null
+;;;; miscellaneous VM definition noise for the x86
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!VM")
+
+(file-comment
+ "$Header$")
+
+;;; the size of an INTEGER representation of a SYSTEM-AREA-POINTER, i.e.
+;;; size of a native memory address
+(deftype sap-int-type () '(unsigned-byte 32))
+;;; FIXME: This should just named be SAP-INT, not SAP-INT-TYPE. And
+;;; grep for SAPINT in the code and replace it with SAP-INT as
+;;; appropriate.
+\f
+;;;; register specs
+
+(macrolet ((defreg (name offset size)
+ (let ((offset-sym (symbolicate name "-OFFSET"))
+ (names-vector (symbolicate "*" size "-REGISTER-NAMES*")))
+ `(progn
+ (eval-when (:compile-toplevel :execute :load-toplevel)
+ (defconstant ,offset-sym ,offset))
+ (setf (svref ,names-vector ,offset-sym)
+ ,(symbol-name name)))))
+ ;; FIXME: It looks to me as though DEFREGSET should also define the
+ ;; *FOO-REGISTER-NAMES* variable.
+ (defregset (name &rest regs)
+ `(eval-when (:compile-toplevel :execute :load-toplevel)
+ (defconstant ,name
+ (list ,@(mapcar (lambda (name)
+ (symbolicate name "-OFFSET"))
+ regs))))))
+
+ ;; byte registers
+ ;;
+ ;; Note: the encoding here is different then that used by the chip. We
+ ;; use this encoding so that the compiler thinks that AX (and EAX) overlap
+ ;; AL and AH instead of AL and CL.
+ (eval-when (:compile-toplevel :load-toplevel :execute)
+ (defvar *byte-register-names* (make-array 8 :initial-element nil)))
+ (defreg al 0 :byte)
+ (defreg ah 1 :byte)
+ (defreg cl 2 :byte)
+ (defreg ch 3 :byte)
+ (defreg dl 4 :byte)
+ (defreg dh 5 :byte)
+ (defreg bl 6 :byte)
+ (defreg bh 7 :byte)
+ (defregset byte-regs al ah cl ch dl dh bl bh)
+
+ ;; word registers
+ (eval-when (:compile-toplevel :load-toplevel :execute)
+ (defvar *word-register-names* (make-array 16 :initial-element nil)))
+ (defreg ax 0 :word)
+ (defreg cx 2 :word)
+ (defreg dx 4 :word)
+ (defreg bx 6 :word)
+ (defreg sp 8 :word)
+ (defreg bp 10 :word)
+ (defreg si 12 :word)
+ (defreg di 14 :word)
+ (defregset word-regs ax cx dx bx si di)
+
+ ;; double word registers
+ (eval-when (:compile-toplevel :load-toplevel :execute)
+ (defvar *dword-register-names* (make-array 16 :initial-element nil)))
+ (defreg eax 0 :dword)
+ (defreg ecx 2 :dword)
+ (defreg edx 4 :dword)
+ (defreg ebx 6 :dword)
+ (defreg esp 8 :dword)
+ (defreg ebp 10 :dword)
+ (defreg esi 12 :dword)
+ (defreg edi 14 :dword)
+ (defregset dword-regs eax ecx edx ebx esi edi)
+
+ ;; floating point registers
+ (eval-when (:compile-toplevel :load-toplevel :execute)
+ (defvar *float-register-names* (make-array 8 :initial-element nil)))
+ (defreg fr0 0 :float)
+ (defreg fr1 1 :float)
+ (defreg fr2 2 :float)
+ (defreg fr3 3 :float)
+ (defreg fr4 4 :float)
+ (defreg fr5 5 :float)
+ (defreg fr6 6 :float)
+ (defreg fr7 7 :float)
+ (defregset float-regs fr0 fr1 fr2 fr3 fr4 fr5 fr6 fr7)
+
+ ;; registers used to pass arguments
+ ;;
+ ;; the number of arguments/return values passed in registers
+ (defconstant register-arg-count 3)
+ ;; names and offsets for registers used to pass arguments
+ (defconstant register-arg-names '(edx edi esi))
+ (defregset register-arg-offsets edx edi esi))
+\f
+;;;; SB definitions
+
+;;; Despite the fact that there are only 8 different registers, we consider
+;;; them 16 in order to describe the overlap of byte registers. The only
+;;; thing we need to represent is what registers overlap. Therefore, we
+;;; consider bytes to take one unit, and words or dwords to take two. We
+;;; don't need to tell the difference between words and dwords, because
+;;; you can't put two words in a dword register.
+(define-storage-base registers :finite :size 16)
+
+;;; jrd changed this from size 1 to size 8. It doesn't seem to make much
+;;; sense to use the 387's idea of a stack; 8 separate registers is easier
+;;; to deal with.
+;;; the old way:
+;;; (define-storage-base float-registers :finite :size 1)
+;;; the new way:
+(define-storage-base float-registers :finite :size 8)
+
+(define-storage-base stack :unbounded :size 8)
+(define-storage-base constant :non-packed)
+(define-storage-base immediate-constant :non-packed)
+(define-storage-base noise :unbounded :size 2)
+\f
+;;;; SC definitions
+
+;;; a handy macro so we don't have to keep changing all the numbers whenever
+;;; we insert a new storage class
+;;;
+;;; FIXME: This macro is not needed in the runtime target.
+(defmacro define-storage-classes (&rest classes)
+ (collect ((forms))
+ (let ((index 0))
+ (dolist (class classes)
+ (let* ((sc-name (car class))
+ (constant-name (symbolicate sc-name "-SC-NUMBER")))
+ (forms `(define-storage-class ,sc-name ,index
+ ,@(cdr class)))
+ (forms `(defconstant ,constant-name ,index))
+ (forms `(let ((sb!int::*rogue-export* "DEFINE-STORAGE-CLASSES"))
+ (export ',constant-name)))
+ (incf index))))
+ `(progn
+ ,@(forms))))
+
+;;; The DEFINE-STORAGE-CLASS call for CATCH-BLOCK refers to the size of
+;;; CATCH-BLOCK. The size of CATCH-BLOCK isn't calculated until later in
+;;; the build process, and the calculation is entangled with code which has
+;;; lots of predependencies, including dependencies on the prior call of
+;;; DEFINE-STORAGE-CLASS. The proper way to unscramble this would be to
+;;; untangle the code, so that the code which calculates the size of
+;;; CATCH-BLOCK can be separated from the other lots-of-dependencies code, so
+;;; that the code which calculates the size of CATCH-BLOCK can be executed
+;;; early, so that this value is known properly at this point in compilation.
+;;; However, that would be a lot of editing of code that I (WHN 19990131) can't
+;;; test until the project is complete. So instead, I set the correct value by
+;;; hand here (a sort of nondeterministic guess of the right answer:-) and add
+;;; an assertion later, after the value is calculated, that the original guess
+;;; was correct.
+;;;
+;;; (What a KLUDGE! Anyone who wants to come in and clean up this mess has my
+;;; gratitude.) (FIXME: Maybe this should be me..)
+(defconstant sb!vm::kludge-nondeterministic-catch-block-size 6)
+
+(define-storage-classes
+
+ ;; non-immediate contstants in the constant pool
+ (constant constant)
+
+ ;; some FP constants can be generated in the i387 silicon
+ (fp-constant immediate-constant)
+
+ (immediate immediate-constant)
+
+ ;;
+ ;; the stacks
+ ;;
+
+ ;; the control stack
+ (control-stack stack) ; may be pointers, scanned by GC
+
+ ;; the non-descriptor stacks
+ (signed-stack stack) ; (signed-byte 32)
+ (unsigned-stack stack) ; (unsigned-byte 32)
+ (base-char-stack stack) ; non-descriptor characters.
+ (sap-stack stack) ; System area pointers.
+ (single-stack stack) ; single-floats
+ (double-stack stack :element-size 2) ; double-floats.
+ #!+long-float
+ (long-stack stack :element-size 3) ; long-floats.
+ (complex-single-stack stack :element-size 2) ; complex-single-floats
+ (complex-double-stack stack :element-size 4) ; complex-double-floats
+ #!+long-float
+ (complex-long-stack stack :element-size 6) ; complex-long-floats
+
+ ;;
+ ;; magic SCs
+ ;;
+
+ (ignore-me noise)
+
+ ;;
+ ;; things that can go in the integer registers
+ ;;
+
+ ;; On the X86, we don't have to distinguish between descriptor and
+ ;; non-descriptor registers, because of the conservative GC.
+ ;; Therefore, we use different scs only to distinguish between
+ ;; descriptor and non-descriptor values and to specify size.
+
+ ;; immediate descriptor objects. Don't have to be seen by GC, but nothing
+ ;; bad will happen if they are. (fixnums, characters, header values, etc).
+ (any-reg registers
+ :locations #.dword-regs
+ :element-size 2
+; :reserve-locations (#.eax-offset)
+ :constant-scs (immediate)
+ :save-p t
+ :alternate-scs (control-stack))
+
+ ;; pointer descriptor objects -- must be seen by GC
+ (descriptor-reg registers
+ :locations #.dword-regs
+ :element-size 2
+; :reserve-locations (#.eax-offset)
+ :constant-scs (constant immediate)
+ :save-p t
+ :alternate-scs (control-stack))
+
+ ;; non-descriptor characters
+ (base-char-reg registers
+ :locations #.byte-regs
+ :reserve-locations (#.ah-offset #.al-offset)
+ :constant-scs (immediate)
+ :save-p t
+ :alternate-scs (base-char-stack))
+
+ ;; non-descriptor SAPs (arbitrary pointers into address space)
+ (sap-reg registers
+ :locations #.dword-regs
+ :element-size 2
+; :reserve-locations (#.eax-offset)
+ :constant-scs (immediate)
+ :save-p t
+ :alternate-scs (sap-stack))
+
+ ;; non-descriptor (signed or unsigned) numbers
+ (signed-reg registers
+ :locations #.dword-regs
+ :element-size 2
+; :reserve-locations (#.eax-offset)
+ :constant-scs (immediate)
+ :save-p t
+ :alternate-scs (signed-stack))
+ (unsigned-reg registers
+ :locations #.dword-regs
+ :element-size 2
+; :reserve-locations (#.eax-offset)
+ :constant-scs (immediate)
+ :save-p t
+ :alternate-scs (unsigned-stack))
+
+ ;; miscellaneous objects that must not be seen by GC. Used only as
+ ;; temporaries.
+ (word-reg registers
+ :locations #.word-regs
+ :element-size 2
+; :reserve-locations (#.ax-offset)
+ )
+ (byte-reg registers
+ :locations #.byte-regs
+; :reserve-locations (#.al-offset #.ah-offset)
+ )
+
+ ;; that can go in the floating point registers
+
+ ;; non-descriptor SINGLE-FLOATs
+ (single-reg float-registers
+ :locations (0 1 2 3 4 5 6 7)
+ :constant-scs (fp-constant)
+ :save-p t
+ :alternate-scs (single-stack))
+
+ ;; non-descriptor DOUBLE-FLOATs
+ (double-reg float-registers
+ :locations (0 1 2 3 4 5 6 7)
+ :constant-scs (fp-constant)
+ :save-p t
+ :alternate-scs (double-stack))
+
+ ;; non-descriptor LONG-FLOATs
+ #!+long-float
+ (long-reg float-registers
+ :locations (0 1 2 3 4 5 6 7)
+ :constant-scs (fp-constant)
+ :save-p t
+ :alternate-scs (long-stack))
+
+ (complex-single-reg float-registers
+ :locations (0 2 4 6)
+ :element-size 2
+ :constant-scs ()
+ :save-p t
+ :alternate-scs (complex-single-stack))
+
+ (complex-double-reg float-registers
+ :locations (0 2 4 6)
+ :element-size 2
+ :constant-scs ()
+ :save-p t
+ :alternate-scs (complex-double-stack))
+
+ #!+long-float
+ (complex-long-reg float-registers
+ :locations (0 2 4 6)
+ :element-size 2
+ :constant-scs ()
+ :save-p t
+ :alternate-scs (complex-long-stack))
+
+ ;; a catch or unwind block
+ (catch-block stack
+ :element-size sb!vm::kludge-nondeterministic-catch-block-size))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+
+(defconstant byte-sc-names '(base-char-reg byte-reg base-char-stack))
+(defconstant word-sc-names '(word-reg))
+(defconstant dword-sc-names
+ '(any-reg descriptor-reg sap-reg signed-reg unsigned-reg control-stack
+ signed-stack unsigned-stack sap-stack single-stack constant))
+
+;;; added by jrd. I guess the right thing to do is to treat floats
+;;; as a separate size...
+;;;
+;;; These are used to (at least) determine operand size.
+(defconstant float-sc-names '(single-reg))
+(defconstant double-sc-names '(double-reg double-stack))
+
+) ; EVAL-WHEN
+\f
+;;;; miscellaneous TNs for the various registers
+
+(macrolet ((def-misc-reg-tns (sc-name &rest reg-names)
+ (collect ((forms))
+ (dolist (reg-name reg-names)
+ (let ((tn-name (symbolicate reg-name "-TN"))
+ (offset-name (symbolicate reg-name "-OFFSET")))
+ ;; FIXME: Couldn't shouldn't this be DEFCONSTANT
+ ;; instead of DEFPARAMETER?
+ (forms `(defparameter ,tn-name
+ (make-random-tn :kind :normal
+ :sc (sc-or-lose ',sc-name)
+ :offset
+ ,offset-name)))))
+ `(progn ,@(forms)))))
+
+ (def-misc-reg-tns unsigned-reg eax ebx ecx edx ebp esp edi esi)
+ (def-misc-reg-tns word-reg ax bx cx dx bp sp di si)
+ (def-misc-reg-tns byte-reg al ah bl bh cl ch dl dh)
+ (def-misc-reg-tns single-reg fr0 fr1 fr2 fr3 fr4 fr5 fr6 fr7))
+
+;;; TNs for registers used to pass arguments
+(defparameter *register-arg-tns*
+ (mapcar (lambda (register-arg-name)
+ (symbol-value (symbolicate register-arg-name "-TN")))
+ register-arg-names))
+
+;;; FIXME: doesn't seem to be used in SBCL
+#|
+;;; added by pw
+(defparameter fp-constant-tn
+ (make-random-tn :kind :normal
+ :sc (sc-or-lose 'fp-constant)
+ :offset 31)) ; Offset doesn't get used.
+|#
+\f
+;;; IMMEDIATE-CONSTANT-SC
+;;;
+;;; If value can be represented as an immediate constant, then return the
+;;; appropriate SC number, otherwise return NIL.
+(def-vm-support-routine immediate-constant-sc (value)
+ (typecase value
+ ((or fixnum #-sb-xc-host system-area-pointer character)
+ (sc-number-or-lose 'immediate))
+ (symbol
+ (when (static-symbol-p value)
+ (sc-number-or-lose 'immediate)))
+ (single-float
+ (when (or (eql value 0f0) (eql value 1f0))
+ (sc-number-or-lose 'fp-constant)))
+ (double-float
+ (when (or (eql value 0d0) (eql value 1d0))
+ (sc-number-or-lose 'fp-constant)))
+ #!+long-float
+ (long-float
+ (when (or (eql value 0l0) (eql value 1l0)
+ (eql value pi)
+ (eql value (log 10l0 2l0))
+ (eql value (log 2.718281828459045235360287471352662L0 2l0))
+ (eql value (log 2l0 10l0))
+ (eql value (log 2l0 2.718281828459045235360287471352662L0)))
+ (sc-number-or-lose 'fp-constant)))))
+\f
+;;;; miscellaneous function call parameters
+
+;;; offsets of special stack frame locations
+(defconstant ocfp-save-offset 0)
+(defconstant return-pc-save-offset 1)
+(defconstant code-save-offset 2)
+
+;;; FIXME: This is a bad comment (changed since when?) and there are others
+;;; like it in this file. It'd be nice to clarify them. Failing that deleting
+;;; them or flagging them with KLUDGE might be better than nothing.
+;;;
+;;; names of these things seem to have changed. these aliases by jrd
+(defconstant lra-save-offset return-pc-save-offset)
+
+(defconstant cfp-offset ebp-offset) ; pfw - needed by stuff in /code
+ ; related to signal context stuff
+
+;;; SINGLE-VALUE-RETURN-BYTE-OFFSET
+;;;
+;;; This is used by the debugger.
+(defconstant single-value-return-byte-offset 2)
+\f
+;;; This function is called by debug output routines that want a pretty name
+;;; for a TN's location. It returns a thing that can be printed with PRINC.
+(def-vm-support-routine location-print-name (tn)
+ (declare (type tn tn))
+ (let* ((sc (tn-sc tn))
+ (sb (sb-name (sc-sb sc)))
+ (offset (tn-offset tn)))
+ (ecase sb
+ (registers
+ (let* ((sc-name (sc-name sc))
+ (name-vec (cond ((member sc-name byte-sc-names)
+ *byte-register-names*)
+ ((member sc-name word-sc-names)
+ *word-register-names*)
+ ((member sc-name dword-sc-names)
+ *dword-register-names*))))
+ (or (and name-vec
+ (< -1 offset (length name-vec))
+ (svref name-vec offset))
+ ;; FIXME: Shouldn't this be an ERROR?
+ (format nil "<unknown reg: off=~D, sc=~A>" offset sc-name))))
+ (float-registers (format nil "FR~D" offset))
+ (stack (format nil "S~D" offset))
+ (constant (format nil "Const~D" offset))
+ (immediate-constant "Immed")
+ (noise (symbol-name (sc-name sc))))))
+;;; FIXME: Could this, and everything that uses it, be made #!+SB-SHOW?
+\f
+;;; The loader uses this to convert alien names to the form they need in
+;;; the symbol table (for example, prepending an underscore).
+(defun extern-alien-name (name)
+ (declare (type simple-string name))
+ name)
--- /dev/null
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+
+;;;; This software is derived from software originally released by Xerox
+;;;; Corporation. Copyright and release statements follow. Later modifications
+;;;; to the software are in the public domain and are provided with
+;;;; absolutely no warranty. See the COPYING and CREDITS files for more
+;;;; information.
+
+;;;; copyright information from original PCL sources:
+;;;;
+;;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
+;;;; All rights reserved.
+;;;;
+;;;; Use and copying of this software and preparation of derivative works based
+;;;; upon this software are permitted. Any distribution of this software or
+;;;; derivative works must comply with all applicable United States export
+;;;; control laws.
+;;;;
+;;;; This software is made available AS IS, and Xerox Corporation makes no
+;;;; warranty about the software, its performance or its conformity to any
+;;;; specification.
+
+(in-package "SB-PCL")
+
+(sb-int:file-comment
+ "$Header$")
+\f
+#|
+
+The CommonLoops evaluator is meta-circular.
+
+Most of the code in PCL is methods on generic functions, including
+most of the code that actually implements generic functions and method
+lookup.
+
+So, we have a classic bootstrapping problem. The solution to this is
+to first get a cheap implementation of generic functions running,
+these are called early generic functions. These early generic
+functions and the corresponding early methods and early method lookup
+are used to get enough of the system running that it is possible to
+create real generic functions and methods and implement real method
+lookup. At that point (done in the file FIXUP) the function
+fix-early-generic-functions is called to convert all the early generic
+functions to real generic functions.
+
+The cheap generic functions are built using the same
+funcallable-instance objects real generic-functions are made out of.
+This means that as PCL is being bootstrapped, the cheap generic
+function objects which are being created are the same objects which
+will later be real generic functions. This is good because:
+ - we don't cons garbage structure, and
+ - we can keep pointers to the cheap generic function objects
+ during booting because those pointers will still point to
+ the right object after the generic functions are all fixed up.
+
+This file defines the defmethod macro and the mechanism used to expand
+it. This includes the mechanism for processing the body of a method.
+DEFMETHOD basically expands into a call to LOAD-DEFMETHOD, which
+basically calls ADD-METHOD to add the method to the generic-function.
+These expansions can be loaded either during bootstrapping or when PCL
+is fully up and running.
+
+An important effect of this arrangement is it means we can compile
+files with defmethod forms in them in a completely running PCL, but
+then load those files back in during bootstrapping. This makes
+development easier. It also means there is only one set of code for
+processing defmethod. Bootstrapping works by being sure to have
+load-method be careful to call only primitives which work during
+bootstrapping.
+
+|#
+
+;;; FIXME: SB-KERNEL::PCL-CHECK-WRAPPER-VALIDITY-HOOK shouldn't be a
+;;; separate function. Instead, we should define a simple placeholder
+;;; version of SB-PCL:CHECK-WRAPPER-VALIDITY where
+;;; SB-KERNEL::PCL-CHECK-WRAPPER-VALIDITY is defined now, then just
+;;; let the later real PCL DEFUN of SB-PCL:CHECK-WRAPPER-VALIDITY
+;;; overwrite it.
+(setf (symbol-function 'sb-kernel::pcl-check-wrapper-validity-hook)
+ #'check-wrapper-validity)
+
+(declaim (notinline make-a-method
+ add-named-method
+ ensure-generic-function-using-class
+
+ add-method
+ remove-method))
+
+(defvar *early-functions*
+ '((make-a-method early-make-a-method
+ real-make-a-method)
+ (add-named-method early-add-named-method
+ real-add-named-method)
+ ))
+
+;;; For each of the early functions, arrange to have it point to its early
+;;; definition. Do this in a way that makes sure that if we redefine one
+;;; of the early definitions the redefinition will take effect. This makes
+;;; development easier.
+;;;
+;;; The function which generates the redirection closure is pulled out into
+;;; a separate piece of code because of a bug in ExCL which causes this not
+;;; to work if it is inlined.
+;;; FIXME: We no longer need to worry about ExCL now, so we could unscrew this.
+(eval-when (:load-toplevel :execute)
+
+(defun redirect-early-function-internal (real early)
+ (setf (gdefinition real)
+ (set-function-name
+ #'(lambda (&rest args)
+ (apply (the function (symbol-function early)) args))
+ real)))
+
+(dolist (fns *early-functions*)
+ (let ((name (car fns))
+ (early-name (cadr fns)))
+ (redirect-early-function-internal name early-name)))
+
+) ; EVAL-WHEN
+
+;;; *GENERIC-FUNCTION-FIXUPS* is used by fix-early-generic-functions to
+;;; convert the few functions in the bootstrap which are supposed to be
+;;; generic functions but can't be early on.
+(defvar *generic-function-fixups*
+ '((add-method
+ ((generic-function method) ;lambda-list
+ (standard-generic-function method) ;specializers
+ real-add-method)) ;method-function
+ (remove-method
+ ((generic-function method)
+ (standard-generic-function method)
+ real-remove-method))
+ (get-method
+ ((generic-function qualifiers specializers &optional (errorp t))
+ (standard-generic-function t t)
+ real-get-method))
+ (ensure-generic-function-using-class
+ ((generic-function function-name
+ &key generic-function-class environment
+ &allow-other-keys)
+ (generic-function t)
+ real-ensure-gf-using-class--generic-function)
+ ((generic-function function-name
+ &key generic-function-class environment
+ &allow-other-keys)
+ (null t)
+ real-ensure-gf-using-class--null))
+ (make-method-lambda
+ ((proto-generic-function proto-method lambda-expression environment)
+ (standard-generic-function standard-method t t)
+ real-make-method-lambda))
+ (make-method-initargs-form
+ ((proto-generic-function proto-method
+ lambda-expression
+ lambda-list environment)
+ (standard-generic-function standard-method t t t)
+ real-make-method-initargs-form))
+ (compute-effective-method
+ ((generic-function combin applicable-methods)
+ (generic-function standard-method-combination t)
+ standard-compute-effective-method))))
+\f
+(defmacro defgeneric (function-name lambda-list &body options)
+ (expand-defgeneric function-name lambda-list options))
+
+(defun expand-defgeneric (function-name lambda-list options)
+ (when (listp function-name)
+ (do-standard-defsetf-1 (sb-int:function-name-block-name function-name)))
+ (let ((initargs ())
+ (methods ()))
+ (flet ((duplicate-option (name)
+ (error 'sb-kernel:simple-program-error
+ :format-control "The option ~S appears more than once."
+ :format-arguments (list name)))
+ (expand-method-definition (qab) ; QAB = qualifiers, arglist, body
+ (let* ((arglist-pos (position-if #'listp qab))
+ (arglist (elt qab arglist-pos))
+ (qualifiers (subseq qab 0 arglist-pos))
+ (body (nthcdr (1+ arglist-pos) qab)))
+ (when (not (equal (cadr (getf initargs :method-combination))
+ qualifiers))
+ (error "bad method specification in DEFGENERIC ~A~%~
+ -- qualifier mismatch for lambda list ~A"
+ function-name arglist))
+ `(defmethod ,function-name ,@qualifiers ,arglist ,@body))))
+ (macrolet ((initarg (key) `(getf initargs ,key)))
+ (dolist (option options)
+ (let ((car-option (car option)))
+ (case car-option
+ (declare
+ (push (cdr option) (initarg :declarations)))
+ ((:argument-precedence-order :method-combination)
+ (if (initarg car-option)
+ (duplicate-option car-option)
+ (setf (initarg car-option)
+ `',(cdr option))))
+ ((:documentation :generic-function-class :method-class)
+ (unless (sb-int:proper-list-of-length-p option 2)
+ (error "bad list length for ~S" option))
+ (if (initarg car-option)
+ (duplicate-option car-option)
+ (setf (initarg car-option) `',(cadr option))))
+ (:method
+ (push (cdr option) methods))
+ (t
+ ;; ANSI requires that unsupported things must get a
+ ;; PROGRAM-ERROR.
+ (error 'sb-kernel:simple-program-error
+ :format-control "unsupported option ~S"
+ :format-arguments (list option))))))
+
+ (when (initarg :declarations)
+ (setf (initarg :declarations)
+ `',(initarg :declarations))))
+ `(progn
+ (eval-when (:compile-toplevel :load-toplevel :execute)
+ (compile-or-load-defgeneric ',function-name))
+ ,(make-top-level-form
+ `(defgeneric ,function-name)
+ *defgeneric-times*
+ `(load-defgeneric ',function-name ',lambda-list ,@initargs))
+ ,@(mapcar #'expand-method-definition methods)
+ `,(function ,function-name)))))
+
+(defun compile-or-load-defgeneric (function-name)
+ (sb-kernel:proclaim-as-function-name function-name)
+ (sb-kernel:note-name-defined function-name :function)
+ (unless (eq (sb-int:info :function :where-from function-name) :declared)
+ (setf (sb-int:info :function :where-from function-name) :defined)
+ (setf (sb-int:info :function :type function-name)
+ (sb-kernel:specifier-type 'function))))
+
+(defun load-defgeneric (function-name lambda-list &rest initargs)
+ (when (listp function-name)
+ (do-standard-defsetf-1 (cadr function-name)))
+ (when (fboundp function-name)
+ (sb-kernel::style-warn "redefining ~S in DEFGENERIC" function-name))
+ (apply #'ensure-generic-function
+ function-name
+ :lambda-list lambda-list
+ :definition-source `((defgeneric ,function-name)
+ ,*load-truename*)
+ initargs))
+\f
+(defmacro defmethod (&rest args &environment env)
+ (declare (arglist name
+ {method-qualifier}*
+ specialized-lambda-list
+ &body body))
+ (multiple-value-bind (name qualifiers lambda-list body)
+ (parse-defmethod args)
+ (multiple-value-bind (proto-gf proto-method)
+ (prototypes-for-make-method-lambda name)
+ (expand-defmethod name
+ proto-gf
+ proto-method
+ qualifiers
+ lambda-list
+ body
+ env))))
+
+(defun prototypes-for-make-method-lambda (name)
+ (if (not (eq *boot-state* 'complete))
+ (values nil nil)
+ (let ((gf? (and (gboundp name)
+ (gdefinition name))))
+ (if (or (null gf?)
+ (not (generic-function-p gf?)))
+ (values (class-prototype (find-class 'standard-generic-function))
+ (class-prototype (find-class 'standard-method)))
+ (values gf?
+ (class-prototype (or (generic-function-method-class gf?)
+ (find-class 'standard-method))))))))
+
+;;; takes a name which is either a generic function name or a list specifying
+;;; a setf generic function (like: (SETF <generic-function-name>)). Returns
+;;; the prototype instance of the method-class for that generic function.
+;;;
+;;; If there is no generic function by that name, this returns the default
+;;; value, the prototype instance of the class STANDARD-METHOD. This default
+;;; value is also returned if the spec names an ordinary function or even a
+;;; macro. In effect, this leaves the signalling of the appropriate error
+;;; until load time.
+;;;
+;;; Note: During bootstrapping, this function is allowed to return NIL.
+(defun method-prototype-for-gf (name)
+ (let ((gf? (and (gboundp name)
+ (gdefinition name))))
+ (cond ((neq *boot-state* 'complete) nil)
+ ((or (null gf?)
+ (not (generic-function-p gf?))) ; Someone else MIGHT
+ ; error at load time.
+ (class-prototype (find-class 'standard-method)))
+ (t
+ (class-prototype (or (generic-function-method-class gf?)
+ (find-class 'standard-method)))))))
+\f
+(defvar *optimize-asv-funcall-p* nil)
+(defvar *asv-readers*)
+(defvar *asv-writers*)
+(defvar *asv-boundps*)
+
+(defun expand-defmethod (name
+ proto-gf
+ proto-method
+ qualifiers
+ lambda-list
+ body
+ env)
+ (when (listp name)
+ (do-standard-defsetf-1 (cadr name)))
+ (let ((*make-instance-function-keys* nil)
+ (*optimize-asv-funcall-p* t)
+ (*asv-readers* nil) (*asv-writers* nil) (*asv-boundps* nil))
+ (declare (special *make-instance-function-keys*))
+ (multiple-value-bind (method-lambda unspecialized-lambda-list specializers)
+ (add-method-declarations name qualifiers lambda-list body env)
+ (multiple-value-bind (method-function-lambda initargs)
+ (make-method-lambda proto-gf proto-method method-lambda env)
+ (let ((initargs-form (make-method-initargs-form proto-gf
+ proto-method
+ method-function-lambda
+ initargs
+ env)))
+ `(progn
+ ;; Note: We could DECLAIM the type of the generic
+ ;; function here, since ANSI specifies that we create it
+ ;; if it does not exist. However, I chose not to, because
+ ;; I think it's more useful to support a style of
+ ;; programming where every generic function has an
+ ;; explicit DEFGENERIC and any typos in DEFMETHODs are
+ ;; warned about. Otherwise
+ ;; (DEFGENERIC FOO-BAR-BLETCH ((X T)))
+ ;; (DEFMETHOD FOO-BAR-BLETCH ((X HASH-TABLE)) ..)
+ ;; (DEFMETHOD FOO-BRA-BLETCH ((X SIMPLE-VECTOR)) ..)
+ ;; (DEFMETHOD FOO-BAR-BLETCH ((X VECTOR)) ..)
+ ;; (DEFMETHOD FOO-BAR-BLETCH ((X ARRAY)) ..)
+ ;; (DEFMETHOD FOO-BAR-BLETCH ((X LIST)) ..)
+ ;; compiles without raising an error and runs without
+ ;; raising an error (since SIMPLE-VECTOR cases fall
+ ;; through to VECTOR) but still doesn't do what was
+ ;; intended. I hate that kind of bug (code which silently
+ ;; gives the wrong answer), so we don't do a DECLAIM
+ ;; here. -- WHN 20000229
+ ,@(when *make-instance-function-keys*
+ `((get-make-instance-functions
+ ',*make-instance-function-keys*)))
+ ,@(when (or *asv-readers* *asv-writers* *asv-boundps*)
+ `((initialize-internal-slot-gfs*
+ ',*asv-readers* ',*asv-writers* ',*asv-boundps*)))
+ ,(make-defmethod-form name qualifiers specializers
+ unspecialized-lambda-list
+ (if proto-method
+ (class-name (class-of proto-method))
+ 'standard-method)
+ initargs-form
+ (getf (getf initargs ':plist)
+ ':pv-table-symbol))))))))
+
+(defun interned-symbol-p (x)
+ (and (symbolp x) (symbol-package x)))
+
+(defun make-defmethod-form (name qualifiers specializers
+ unspecialized-lambda-list method-class-name
+ initargs-form &optional pv-table-symbol)
+ (let (fn
+ fn-lambda)
+ (if (and (interned-symbol-p (sb-int:function-name-block-name name))
+ (every #'interned-symbol-p qualifiers)
+ (every #'(lambda (s)
+ (if (consp s)
+ (and (eq (car s) 'eql)
+ (constantp (cadr s))
+ (let ((sv (eval (cadr s))))
+ (or (interned-symbol-p sv)
+ (integerp sv)
+ (and (characterp sv)
+ (standard-char-p sv)))))
+ (interned-symbol-p s)))
+ specializers)
+ (consp initargs-form)
+ (eq (car initargs-form) 'list*)
+ (memq (cadr initargs-form) '(:function :fast-function))
+ (consp (setq fn (caddr initargs-form)))
+ (eq (car fn) 'function)
+ (consp (setq fn-lambda (cadr fn)))
+ (eq (car fn-lambda) 'lambda))
+ (let* ((specls (mapcar (lambda (specl)
+ (if (consp specl)
+ `(,(car specl) ,(eval (cadr specl)))
+ specl))
+ specializers))
+ (mname `(,(if (eq (cadr initargs-form) ':function)
+ 'method 'fast-method)
+ ,name ,@qualifiers ,specls))
+ (mname-sym (intern (let ((*print-pretty* nil))
+ (format nil "~S" mname)))))
+ `(eval-when ,*defmethod-times*
+ (defun ,mname-sym ,(cadr fn-lambda)
+ ,@(cddr fn-lambda))
+ ,(make-defmethod-form-internal
+ name qualifiers `',specls
+ unspecialized-lambda-list method-class-name
+ `(list* ,(cadr initargs-form)
+ #',mname-sym
+ ,@(cdddr initargs-form))
+ pv-table-symbol)))
+ (make-top-level-form
+ `(defmethod ,name ,@qualifiers ,specializers)
+ *defmethod-times*
+ (make-defmethod-form-internal
+ name qualifiers
+ `(list ,@(mapcar #'(lambda (specializer)
+ (if (consp specializer)
+ ``(,',(car specializer)
+ ,,(cadr specializer))
+ `',specializer))
+ specializers))
+ unspecialized-lambda-list method-class-name
+ initargs-form
+ pv-table-symbol)))))
+
+(defun make-defmethod-form-internal
+ (name qualifiers specializers-form unspecialized-lambda-list
+ method-class-name initargs-form &optional pv-table-symbol)
+ `(load-defmethod
+ ',method-class-name
+ ',name
+ ',qualifiers
+ ,specializers-form
+ ',unspecialized-lambda-list
+ ,initargs-form
+ ;; Paper over a bug in KCL by passing the cache-symbol here in addition to
+ ;; in the list. FIXME: We should no longer need to do this.
+ ',pv-table-symbol))
+
+(defmacro make-method-function (method-lambda &environment env)
+ (make-method-function-internal method-lambda env))
+
+(defun make-method-function-internal (method-lambda &optional env)
+ (multiple-value-bind (proto-gf proto-method)
+ (prototypes-for-make-method-lambda nil)
+ (multiple-value-bind (method-function-lambda initargs)
+ (make-method-lambda proto-gf proto-method method-lambda env)
+ (make-method-initargs-form proto-gf
+ proto-method
+ method-function-lambda
+ initargs
+ env))))
+
+(defun add-method-declarations (name qualifiers lambda-list body env)
+ (multiple-value-bind (parameters unspecialized-lambda-list specializers)
+ (parse-specialized-lambda-list lambda-list)
+ (declare (ignore parameters))
+ (multiple-value-bind (documentation declarations real-body)
+ (extract-declarations body env)
+ (values `(lambda ,unspecialized-lambda-list
+ ,@(when documentation `(,documentation))
+ (declare (method-name ,(list name qualifiers specializers)))
+ (declare (method-lambda-list ,@lambda-list))
+ ,@declarations
+ ,@real-body)
+ unspecialized-lambda-list specializers))))
+
+(defun real-make-method-initargs-form (proto-gf proto-method
+ method-lambda initargs env)
+ (declare (ignore proto-gf proto-method))
+ (unless (and (consp method-lambda) (eq (car method-lambda) 'lambda))
+ (error "The METHOD-LAMBDA argument to MAKE-METHOD-FUNCTION, ~S,~
+ is not a lambda form."
+ method-lambda))
+ (make-method-initargs-form-internal method-lambda initargs env))
+
+(unless (fboundp 'make-method-initargs-form)
+ (setf (gdefinition 'make-method-initargs-form)
+ (symbol-function 'real-make-method-initargs-form)))
+
+(defun real-make-method-lambda (proto-gf proto-method method-lambda env)
+ (declare (ignore proto-gf proto-method))
+ (make-method-lambda-internal method-lambda env))
+
+(defun make-method-lambda-internal (method-lambda &optional env)
+ (unless (and (consp method-lambda) (eq (car method-lambda) 'lambda))
+ (error "The METHOD-LAMBDA argument to MAKE-METHOD-LAMBDA, ~S,~
+ is not a lambda form."
+ method-lambda))
+ (multiple-value-bind (documentation declarations real-body)
+ (extract-declarations (cddr method-lambda) env)
+ (let* ((name-decl (get-declaration 'method-name declarations))
+ (sll-decl (get-declaration 'method-lambda-list declarations))
+ (method-name (when (consp name-decl) (car name-decl)))
+ (generic-function-name (when method-name (car method-name)))
+ (specialized-lambda-list (or sll-decl (cadr method-lambda))))
+ (multiple-value-bind (parameters lambda-list specializers)
+ (parse-specialized-lambda-list specialized-lambda-list)
+ (let* ((required-parameters
+ (mapcar #'(lambda (r s) (declare (ignore s)) r)
+ parameters
+ specializers))
+ (slots (mapcar #'list required-parameters))
+ (calls (list nil))
+ (parameters-to-reference
+ (make-parameter-references specialized-lambda-list
+ required-parameters
+ declarations
+ method-name
+ specializers))
+ (class-declarations
+ `(declare
+ ;; FIXME: Are these (DECLARE (SB-PCL::CLASS FOO BAR))
+ ;; declarations used for anything any more?
+ ,@(remove nil
+ (mapcar (lambda (a s) (and (symbolp s)
+ (neq s 't)
+ `(class ,a ,s)))
+ parameters
+ specializers))
+ ;; These TYPE declarations weren't in the original
+ ;; PCL code, but Python likes them a lot. (We're
+ ;; telling the compiler about our knowledge of
+ ;; specialized argument types so that it can avoid
+ ;; run-time type overhead, which can be a big win
+ ;; for Python.)
+ ,@(mapcar (lambda (a s)
+ (cond ((and (consp s)
+ (eql (car s) 'eql))
+ ;; KLUDGE: ANSI, in its wisdom, says
+ ;; that EQL-SPECIALIZER-FORMs in EQL
+ ;; specializers are evaluated at
+ ;; DEFMETHOD expansion time. Thus,
+ ;; although one might think that in
+ ;; (DEFMETHOD FOO ((X PACKAGE)
+ ;; (Y (EQL 12))
+ ;; ..))
+ ;; the PACKAGE and (EQL 12) forms are
+ ;; both parallel type names, they're
+ ;; not, as is made clear when you do
+ ;; (DEFMETHOD FOO ((X PACKAGE)
+ ;; (Y (EQL 'BAR)))
+ ;; ..)
+ ;; where Y needs to be a symbol
+ ;; named "BAR", not some cons made by
+ ;; (CONS 'QUOTE 'BAR). I.e. when
+ ;; the EQL-SPECIALIZER-FORM is (EQL 'X),
+ ;; it requires an argument to be of
+ ;; type (EQL X). It'd be easy to transform
+ ;; one to the other, but it'd be somewhat
+ ;; messier to do so while ensuring that
+ ;; the EQL-SPECIALIZER-FORM is only
+ ;; EVAL'd once. (The new code wouldn't
+ ;; be messy, but it'd require a big
+ ;; transformation of the old code.)
+ ;; So instead we punt. -- WHN 20000610
+ '(ignorable))
+ ((not (eq *boot-state* 'complete))
+ ;; KLUDGE: PCL, in its wisdom,
+ ;; sometimes calls methods with
+ ;; types which don't match their
+ ;; specializers. (Specifically, it calls
+ ;; ENSURE-CLASS-USING-CLASS (T NULL)
+ ;; with a non-NULL second argument.)
+ ;; Hopefully it only does this kind
+ ;; of weirdness when bootstrapping..
+ ;; -- WHN 20000610
+ '(ignorable))
+ (t
+ ;; Otherwise, we can make Python
+ ;; very happy.
+ `(type ,s ,a))))
+ parameters
+ specializers)))
+ (method-lambda
+ ;; Remove the documentation string and insert the
+ ;; appropriate class declarations. The documentation
+ ;; string is removed to make it easy for us to insert
+ ;; new declarations later, they will just go after the
+ ;; cadr of the method lambda. The class declarations
+ ;; are inserted to communicate the class of the method's
+ ;; arguments to the code walk.
+ `(lambda ,lambda-list
+ ,class-declarations
+ ,@declarations
+ (declare (ignorable ,@parameters-to-reference))
+
+ ;; FIXME: should become FUNCTION-NAME-BLOCK-NAME
+ (block ,(if (listp generic-function-name)
+ (cadr generic-function-name)
+ generic-function-name)
+ ,@real-body)))
+ (constant-value-p (and (null (cdr real-body))
+ (constantp (car real-body))))
+ (constant-value (and constant-value-p
+ (eval (car real-body))))
+ ;; FIXME: This can become a bare AND (no IF), just like
+ ;; the expression for CONSTANT-VALUE just above.
+ (plist (if (and constant-value-p
+ (or (typep constant-value
+ '(or number character))
+ (and (symbolp constant-value)
+ (symbol-package constant-value))))
+ (list :constant-value constant-value)
+ ()))
+ (applyp (dolist (p lambda-list nil)
+ (cond ((memq p '(&optional &rest &key))
+ (return t))
+ ((eq p '&aux)
+ (return nil))))))
+ (multiple-value-bind
+ (walked-lambda call-next-method-p closurep next-method-p-p)
+ (walk-method-lambda method-lambda
+ required-parameters
+ env
+ slots
+ calls)
+ (multiple-value-bind
+ (ignore walked-declarations walked-lambda-body)
+ (extract-declarations (cddr walked-lambda))
+ (declare (ignore ignore))
+ (when (or next-method-p-p call-next-method-p)
+ (setq plist (list* :needs-next-methods-p 't plist)))
+ (when (some #'cdr slots)
+ (multiple-value-bind (slot-name-lists call-list)
+ (slot-name-lists-from-slots slots calls)
+ (let ((pv-table-symbol (make-symbol "pv-table")))
+ (setq plist
+ `(,@(when slot-name-lists
+ `(:slot-name-lists ,slot-name-lists))
+ ,@(when call-list
+ `(:call-list ,call-list))
+ :pv-table-symbol ,pv-table-symbol
+ ,@plist))
+ (setq walked-lambda-body
+ `((pv-binding (,required-parameters
+ ,slot-name-lists
+ ,pv-table-symbol)
+ ,@walked-lambda-body))))))
+ (when (and (memq '&key lambda-list)
+ (not (memq '&allow-other-keys lambda-list)))
+ (let ((aux (memq '&aux lambda-list)))
+ (setq lambda-list (nconc (ldiff lambda-list aux)
+ (list '&allow-other-keys)
+ aux))))
+ (values `(lambda (.method-args. .next-methods.)
+ (simple-lexical-method-functions
+ (,lambda-list .method-args. .next-methods.
+ :call-next-method-p
+ ,call-next-method-p
+ :next-method-p-p ,next-method-p-p
+ :closurep ,closurep
+ :applyp ,applyp)
+ ,@walked-declarations
+ ,@walked-lambda-body))
+ `(,@(when plist
+ `(:plist ,plist))
+ ,@(when documentation
+ `(:documentation ,documentation)))))))))))
+
+(unless (fboundp 'make-method-lambda)
+ (setf (gdefinition 'make-method-lambda)
+ (symbol-function 'real-make-method-lambda)))
+
+(defmacro simple-lexical-method-functions ((lambda-list
+ method-args
+ next-methods
+ &rest lmf-options)
+ &body body)
+ `(progn
+ ,method-args ,next-methods
+ (bind-simple-lexical-method-macros (,method-args ,next-methods)
+ (bind-lexical-method-functions (,@lmf-options)
+ (bind-args (,lambda-list ,method-args)
+ ,@body)))))
+
+(defmacro fast-lexical-method-functions ((lambda-list
+ next-method-call
+ args
+ rest-arg
+ &rest lmf-options)
+ &body body)
+ `(bind-fast-lexical-method-macros (,args ,rest-arg ,next-method-call)
+ (bind-lexical-method-functions (,@lmf-options)
+ (bind-args (,(nthcdr (length args) lambda-list) ,rest-arg)
+ ,@body))))
+
+(defmacro bind-simple-lexical-method-macros ((method-args next-methods)
+ &body body)
+ `(macrolet ((call-next-method-bind (&body body)
+ `(let ((.next-method. (car ,',next-methods))
+ (,',next-methods (cdr ,',next-methods)))
+ .next-method. ,',next-methods
+ ,@body))
+ (call-next-method-body (cnm-args)
+ `(if .next-method.
+ (funcall (if (std-instance-p .next-method.)
+ (method-function .next-method.)
+ .next-method.) ; for early methods
+ (or ,cnm-args ,',method-args)
+ ,',next-methods)
+ (error "no next method")))
+ (next-method-p-body ()
+ `(not (null .next-method.))))
+ ,@body))
+
+(defstruct method-call
+ (function #'identity :type function)
+ call-method-args)
+
+#-sb-fluid (declaim (sb-ext:freeze-type method-call))
+
+(defmacro invoke-method-call1 (function args cm-args)
+ `(let ((.function. ,function)
+ (.args. ,args)
+ (.cm-args. ,cm-args))
+ (if (and .cm-args. (null (cdr .cm-args.)))
+ (funcall .function. .args. (car .cm-args.))
+ (apply .function. .args. .cm-args.))))
+
+(defmacro invoke-method-call (method-call restp &rest required-args+rest-arg)
+ `(invoke-method-call1 (method-call-function ,method-call)
+ ,(if restp
+ `(list* ,@required-args+rest-arg)
+ `(list ,@required-args+rest-arg))
+ (method-call-call-method-args ,method-call)))
+
+(defstruct fast-method-call
+ (function #'identity :type function)
+ pv-cell
+ next-method-call
+ arg-info)
+
+#-sb-fluid (declaim (sb-ext:freeze-type fast-method-call))
+
+(defmacro fmc-funcall (fn pv-cell next-method-call &rest args)
+ `(funcall ,fn ,pv-cell ,next-method-call ,@args))
+
+(defmacro invoke-fast-method-call (method-call &rest required-args+rest-arg)
+ `(fmc-funcall (fast-method-call-function ,method-call)
+ (fast-method-call-pv-cell ,method-call)
+ (fast-method-call-next-method-call ,method-call)
+ ,@required-args+rest-arg))
+
+(defstruct fast-instance-boundp
+ (index 0 :type fixnum))
+
+#-sb-fluid (declaim (sb-ext:freeze-type fast-instance-boundp))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+
+(defvar *allow-emf-call-tracing-p* nil)
+(defvar *enable-emf-call-tracing-p* #-testing nil #+testing t)
+
+) ; EVAL-WHEN
+\f
+;;;; effective method functions
+
+(defvar *emf-call-trace-size* 200)
+(defvar *emf-call-trace* nil)
+(defvar *emf-call-trace-index* 0)
+
+;;; This function was in the CMU CL version of PCL (ca Debian 2.4.8)
+;;; without explanation. It appears to be intended for debugging, so
+;;; it might be useful someday, so I haven't deleted it.
+;;; But it isn't documented and isn't used for anything now, so
+;;; I've conditionalized it out of the base system. -- WHN 19991213
+#+sb-show
+(defun show-emf-call-trace ()
+ (when *emf-call-trace*
+ (let ((j *emf-call-trace-index*)
+ (*enable-emf-call-tracing-p* nil))
+ (format t "~&(The oldest entries are printed first)~%")
+ (dotimes-fixnum (i *emf-call-trace-size*)
+ (let ((ct (aref *emf-call-trace* j)))
+ (when ct (print ct)))
+ (incf j)
+ (when (= j *emf-call-trace-size*)
+ (setq j 0))))))
+
+(defun trace-emf-call-internal (emf format args)
+ (unless *emf-call-trace*
+ (setq *emf-call-trace* (make-array *emf-call-trace-size*)))
+ (setf (aref *emf-call-trace* *emf-call-trace-index*)
+ (list* emf format args))
+ (incf *emf-call-trace-index*)
+ (when (= *emf-call-trace-index* *emf-call-trace-size*)
+ (setq *emf-call-trace-index* 0)))
+
+(defmacro trace-emf-call (emf format args)
+ (when *allow-emf-call-tracing-p*
+ `(when *enable-emf-call-tracing-p*
+ (trace-emf-call-internal ,emf ,format ,args))))
+
+(defmacro invoke-effective-method-function-fast
+ (emf restp &rest required-args+rest-arg)
+ `(progn
+ (trace-emf-call ,emf ,restp (list ,@required-args+rest-arg))
+ (invoke-fast-method-call ,emf ,@required-args+rest-arg)))
+
+(defmacro invoke-effective-method-function (emf restp
+ &rest required-args+rest-arg)
+ (unless (constantp restp)
+ (error "The RESTP argument is not constant."))
+ (setq restp (eval restp))
+ `(progn
+ (trace-emf-call ,emf ,restp (list ,@required-args+rest-arg))
+ (cond ((typep ,emf 'fast-method-call)
+ (invoke-fast-method-call ,emf ,@required-args+rest-arg))
+ ,@(when (and (null restp) (= 1 (length required-args+rest-arg)))
+ `(((typep ,emf 'fixnum)
+ (let* ((.slots. (get-slots-or-nil
+ ,(car required-args+rest-arg)))
+ (value (when .slots. (%instance-ref .slots. ,emf))))
+ (if (eq value ',*slot-unbound*)
+ (slot-unbound-internal ,(car required-args+rest-arg)
+ ,emf)
+ value)))))
+ ,@(when (and (null restp) (= 2 (length required-args+rest-arg)))
+ `(((typep ,emf 'fixnum)
+ (let ((.new-value. ,(car required-args+rest-arg))
+ (.slots. (get-slots-or-nil
+ ,(car required-args+rest-arg))))
+ (when .slots. ; just to avoid compiler warnings
+ (setf (%instance-ref .slots. ,emf) .new-value.))))))
+ #||
+ ,@(when (and (null restp) (= 1 (length required-args+rest-arg)))
+ `(((typep ,emf 'fast-instance-boundp)
+ (let ((.slots. (get-slots-or-nil
+ ,(car required-args+rest-arg))))
+ (and .slots.
+ (not (eq (%instance-ref
+ .slots. (fast-instance-boundp-index ,emf))
+ ',*slot-unbound*)))))))
+ ||#
+ (t
+ (etypecase ,emf
+ (method-call
+ (invoke-method-call ,emf ,restp ,@required-args+rest-arg))
+ (function
+ ,(if restp
+ `(apply (the function ,emf) ,@required-args+rest-arg)
+ `(funcall (the function ,emf)
+ ,@required-args+rest-arg))))))))
+
+(defun invoke-emf (emf args)
+ (trace-emf-call emf t args)
+ (etypecase emf
+ (fast-method-call
+ (let* ((arg-info (fast-method-call-arg-info emf))
+ (restp (cdr arg-info))
+ (nreq (car arg-info)))
+ (if restp
+ (let* ((rest-args (nthcdr nreq args))
+ (req-args (ldiff args rest-args)))
+ (apply (fast-method-call-function emf)
+ (fast-method-call-pv-cell emf)
+ (fast-method-call-next-method-call emf)
+ (nconc req-args (list rest-args))))
+ (cond ((null args)
+ (if (eql nreq 0)
+ (invoke-fast-method-call emf)
+ (error "wrong number of args")))
+ ((null (cdr args))
+ (if (eql nreq 1)
+ (invoke-fast-method-call emf (car args))
+ (error "wrong number of args")))
+ ((null (cddr args))
+ (if (eql nreq 2)
+ (invoke-fast-method-call emf (car args) (cadr args))
+ (error "wrong number of args")))
+ (t
+ (apply (fast-method-call-function emf)
+ (fast-method-call-pv-cell emf)
+ (fast-method-call-next-method-call emf)
+ args))))))
+ (method-call
+ (apply (method-call-function emf)
+ args
+ (method-call-call-method-args emf)))
+ (fixnum
+ (cond ((null args) (error "1 or 2 args were expected."))
+ ((null (cdr args))
+ (let ((value (%instance-ref (get-slots (car args)) emf)))
+ (if (eq value *slot-unbound*)
+ (slot-unbound-internal (car args) emf)
+ value)))
+ ((null (cddr args))
+ (setf (%instance-ref (get-slots (cadr args)) emf)
+ (car args)))
+ (t (error "1 or 2 args were expected."))))
+ (fast-instance-boundp
+ (if (or (null args) (cdr args))
+ (error "1 arg was expected.")
+ (not (eq (%instance-ref (get-slots (car args))
+ (fast-instance-boundp-index emf))
+ *slot-unbound*))))
+ (function
+ (apply emf args))))
+
+;; KLUDGE: A comment from the original PCL said "This can be improved alot."
+(defun gf-make-function-from-emf (gf emf)
+ (etypecase emf
+ (fast-method-call (let* ((arg-info (gf-arg-info gf))
+ (nreq (arg-info-number-required arg-info))
+ (restp (arg-info-applyp arg-info)))
+ #'(lambda (&rest args)
+ (trace-emf-call emf t args)
+ (apply (fast-method-call-function emf)
+ (fast-method-call-pv-cell emf)
+ (fast-method-call-next-method-call emf)
+ (if restp
+ (let* ((rest-args (nthcdr nreq args))
+ (req-args (ldiff args
+ rest-args)))
+ (nconc req-args rest-args))
+ args)))))
+ (method-call #'(lambda (&rest args)
+ (trace-emf-call emf t args)
+ (apply (method-call-function emf)
+ args
+ (method-call-call-method-args emf))))
+ (function emf)))
+\f
+(defmacro bind-fast-lexical-method-macros ((args rest-arg next-method-call)
+ &body body)
+ `(macrolet ((call-next-method-bind (&body body)
+ `(let () ,@body))
+ (call-next-method-body (cnm-args)
+ `(if ,',next-method-call
+ ,(if (and (null ',rest-arg)
+ (consp cnm-args)
+ (eq (car cnm-args) 'list))
+ `(invoke-effective-method-function
+ ,',next-method-call nil
+ ,@(cdr cnm-args))
+ (let ((call `(invoke-effective-method-function
+ ,',next-method-call
+ ,',(not (null rest-arg))
+ ,@',args
+ ,@',(when rest-arg `(,rest-arg)))))
+ `(if ,cnm-args
+ (bind-args ((,@',args
+ ,@',(when rest-arg
+ `(&rest ,rest-arg)))
+ ,cnm-args)
+ ,call)
+ ,call)))
+ (error "no next method")))
+ (next-method-p-body ()
+ `(not (null ,',next-method-call))))
+ ,@body))
+
+(defmacro bind-lexical-method-functions
+ ((&key call-next-method-p next-method-p-p closurep applyp)
+ &body body)
+ (cond ((and (null call-next-method-p) (null next-method-p-p)
+ (null closurep)
+ (null applyp))
+ `(let () ,@body))
+ ((and (null closurep)
+ (null applyp))
+ ;; OK to use MACROLET, and all args are mandatory
+ ;; (else APPLYP would be true).
+ `(call-next-method-bind
+ (macrolet ((call-next-method (&rest cnm-args)
+ `(call-next-method-body ,(when cnm-args
+ `(list ,@cnm-args))))
+ (next-method-p ()
+ `(next-method-p-body)))
+ ,@body)))
+ (t
+ `(call-next-method-bind
+ (flet (,@(and call-next-method-p
+ '((call-next-method (&rest cnm-args)
+ (call-next-method-body cnm-args))))
+ ,@(and next-method-p-p
+ '((next-method-p ()
+ (next-method-p-body)))))
+ ,@body)))))
+
+(defmacro bind-args ((lambda-list args) &body body)
+ (let ((args-tail '.args-tail.)
+ (key '.key.)
+ (state 'required))
+ (flet ((process-var (var)
+ (if (memq var lambda-list-keywords)
+ (progn
+ (case var
+ (&optional (setq state 'optional))
+ (&key (setq state 'key))
+ (&allow-other-keys)
+ (&rest (setq state 'rest))
+ (&aux (setq state 'aux))
+ (otherwise
+ (error "encountered the non-standard lambda list keyword ~S"
+ var)))
+ nil)
+ (case state
+ (required `((,var (pop ,args-tail))))
+ (optional (cond ((not (consp var))
+ `((,var (when ,args-tail
+ (pop ,args-tail)))))
+ ((null (cddr var))
+ `((,(car var) (if ,args-tail
+ (pop ,args-tail)
+ ,(cadr var)))))
+ (t
+ `((,(caddr var) ,args-tail)
+ (,(car var) (if ,args-tail
+ (pop ,args-tail)
+ ,(cadr var)))))))
+ (rest `((,var ,args-tail)))
+ (key (cond ((not (consp var))
+ `((,var (get-key-arg ,(make-keyword var)
+ ,args-tail))))
+ ((null (cddr var))
+ (multiple-value-bind (keyword variable)
+ (if (consp (car var))
+ (values (caar var)
+ (cadar var))
+ (values (make-keyword (car var))
+ (car var)))
+ `((,key (get-key-arg1 ,keyword ,args-tail))
+ (,variable (if (consp ,key)
+ (car ,key)
+ ,(cadr var))))))
+ (t
+ (multiple-value-bind (keyword variable)
+ (if (consp (car var))
+ (values (caar var)
+ (cadar var))
+ (values (make-keyword (car var))
+ (car var)))
+ `((,key (get-key-arg1 ,keyword ,args-tail))
+ (,(caddr var) ,key)
+ (,variable (if (consp ,key)
+ (car ,key)
+ ,(cadr var))))))))
+ (aux `(,var))))))
+ (let ((bindings (mapcan #'process-var lambda-list)))
+ `(let* ((,args-tail ,args)
+ ,@bindings)
+ (declare (ignorable ,args-tail))
+ ,@body)))))
+
+(defun get-key-arg (keyword list)
+ (loop (when (atom list) (return nil))
+ (when (eq (car list) keyword) (return (cadr list)))
+ (setq list (cddr list))))
+
+(defun get-key-arg1 (keyword list)
+ (loop (when (atom list) (return nil))
+ (when (eq (car list) keyword) (return (cdr list)))
+ (setq list (cddr list))))
+
+(defun walk-method-lambda (method-lambda required-parameters env slots calls)
+ (let ((call-next-method-p nil) ; flag indicating that CALL-NEXT-METHOD
+ ; should be in the method definition
+ (closurep nil) ; flag indicating that #'CALL-NEXT-METHOD
+ ; was seen in the body of a method
+ (next-method-p-p nil)) ; flag indicating that NEXT-METHOD-P
+ ; should be in the method definition
+ (flet ((walk-function (form context env)
+ (cond ((not (eq context ':eval)) form)
+ ;; FIXME: Jumping to a conclusion from the way it's used
+ ;; above, perhaps CONTEXT should be called SITUATION
+ ;; (after the term used in the ANSI specification of
+ ;; EVAL-WHEN) and given modern ANSI keyword values
+ ;; like :LOAD-TOPLEVEL.
+ ((not (listp form)) form)
+ ((eq (car form) 'call-next-method)
+ (setq call-next-method-p 't)
+ form)
+ ((eq (car form) 'next-method-p)
+ (setq next-method-p-p 't)
+ form)
+ ((and (eq (car form) 'function)
+ (cond ((eq (cadr form) 'call-next-method)
+ (setq call-next-method-p 't)
+ (setq closurep t)
+ form)
+ ((eq (cadr form) 'next-method-p)
+ (setq next-method-p-p 't)
+ (setq closurep t)
+ form)
+ (t nil))))
+ (;; FIXME: should be MEMQ or FIND :TEST #'EQ
+ (and (or (eq (car form) 'slot-value)
+ (eq (car form) 'set-slot-value)
+ (eq (car form) 'slot-boundp))
+ (constantp (caddr form)))
+ (let ((parameter (can-optimize-access form
+ required-parameters
+ env)))
+ ;; FIXME: could be
+ ;; (LET ((FUN (ECASE (CAR FORM) ..)))
+ ;; (FUNCALL FUN SLOTS PARAMETER FORM))
+ (ecase (car form)
+ (slot-value
+ (optimize-slot-value slots parameter form))
+ (set-slot-value
+ (optimize-set-slot-value slots parameter form))
+ (slot-boundp
+ (optimize-slot-boundp slots parameter form)))))
+ ((and (eq (car form) 'apply)
+ (consp (cadr form))
+ (eq (car (cadr form)) 'function)
+ (generic-function-name-p (cadr (cadr form))))
+ (optimize-generic-function-call
+ form required-parameters env slots calls))
+ ((generic-function-name-p (car form))
+ (optimize-generic-function-call
+ form required-parameters env slots calls))
+ ((and (eq (car form) 'asv-funcall)
+ *optimize-asv-funcall-p*)
+ (case (fourth form)
+ (reader (push (third form) *asv-readers*))
+ (writer (push (third form) *asv-writers*))
+ (boundp (push (third form) *asv-boundps*)))
+ `(,(second form) ,@(cddddr form)))
+ (t form))))
+
+ (let ((walked-lambda (walk-form method-lambda env #'walk-function)))
+ (values walked-lambda
+ call-next-method-p
+ closurep
+ next-method-p-p)))))
+
+(defun generic-function-name-p (name)
+ (and (sb-int:legal-function-name-p name)
+ (gboundp name)
+ (if (eq *boot-state* 'complete)
+ (standard-generic-function-p (gdefinition name))
+ (funcallable-instance-p (gdefinition name)))))
+
+(defun make-parameter-references (specialized-lambda-list
+ required-parameters
+ declarations
+ method-name
+ specializers)
+ (flet ((ignoredp (symbol)
+ (dolist (decl (cdar declarations))
+ (when (and (eq (car decl) 'ignore)
+ (memq symbol (cdr decl)))
+ (return t)))))
+ (gathering ((references (collecting)))
+ (iterate ((s (list-elements specialized-lambda-list))
+ (p (list-elements required-parameters)))
+ (progn p)
+ (cond ((not (listp s)))
+ ((ignoredp (car s))
+ (warn "In DEFMETHOD ~S, there is a~%~
+ redundant IGNORE declaration for the parameter ~S."
+ method-name
+ specializers
+ (car s)))
+ (t
+ (gather (car s) references)))))))
+\f
+(defvar *method-function-plist* (make-hash-table :test 'eq))
+(defvar *mf1* nil)
+(defvar *mf1p* nil)
+(defvar *mf1cp* nil)
+(defvar *mf2* nil)
+(defvar *mf2p* nil)
+(defvar *mf2cp* nil)
+
+(defun method-function-plist (method-function)
+ (unless (eq method-function *mf1*)
+ (rotatef *mf1* *mf2*)
+ (rotatef *mf1p* *mf2p*)
+ (rotatef *mf1cp* *mf2cp*))
+ (unless (or (eq method-function *mf1*) (null *mf1cp*))
+ (setf (gethash *mf1* *method-function-plist*) *mf1p*))
+ (unless (eq method-function *mf1*)
+ (setf *mf1* method-function
+ *mf1cp* nil
+ *mf1p* (gethash method-function *method-function-plist*)))
+ *mf1p*)
+
+(defun #-setf SETF\ SB-PCL\ METHOD-FUNCTION-PLIST
+ #+setf (setf method-function-plist)
+ (val method-function)
+ (unless (eq method-function *mf1*)
+ (rotatef *mf1* *mf2*)
+ (rotatef *mf1cp* *mf2cp*)
+ (rotatef *mf1p* *mf2p*))
+ (unless (or (eq method-function *mf1*) (null *mf1cp*))
+ (setf (gethash *mf1* *method-function-plist*) *mf1p*))
+ (setf *mf1* method-function
+ *mf1cp* t
+ *mf1p* val))
+
+(defun method-function-get (method-function key &optional default)
+ (getf (method-function-plist method-function) key default))
+
+(defun #-setf SETF\ SB-PCL\ METHOD-FUNCTION-GET
+ #+setf (setf method-function-get)
+ (val method-function key)
+ (setf (getf (method-function-plist method-function) key) val))
+
+(defun method-function-pv-table (method-function)
+ (method-function-get method-function :pv-table))
+
+(defun method-function-method (method-function)
+ (method-function-get method-function :method))
+
+(defun method-function-needs-next-methods-p (method-function)
+ (method-function-get method-function :needs-next-methods-p t))
+\f
+(defmacro method-function-closure-generator (method-function)
+ `(method-function-get ,method-function 'closure-generator))
+
+(defun load-defmethod
+ (class name quals specls ll initargs &optional pv-table-symbol)
+ (when (listp name) (do-standard-defsetf-1 (cadr name)))
+ (setq initargs (copy-tree initargs))
+ (let ((method-spec (or (getf initargs ':method-spec)
+ (make-method-spec name quals specls))))
+ (setf (getf initargs ':method-spec) method-spec)
+ (record-definition 'method method-spec)
+ (load-defmethod-internal class name quals specls
+ ll initargs pv-table-symbol)))
+
+(defun load-defmethod-internal
+ (method-class gf-spec qualifiers specializers lambda-list
+ initargs pv-table-symbol)
+ (when (listp gf-spec) (do-standard-defsetf-1 (cadr gf-spec)))
+ (when pv-table-symbol
+ (setf (getf (getf initargs ':plist) :pv-table-symbol)
+ pv-table-symbol))
+ ;; FIXME: It seems as though I should be able to get this to work.
+ ;; But it keeps on screwing up PCL bootstrapping.
+ #+nil
+ (when (and (eq *boot-state* 'complete)
+ (fboundp gf-spec))
+ (let* ((gf (symbol-function gf-spec))
+ (method (and (generic-function-p gf)
+ (find-method gf
+ qualifiers
+ (mapcar #'find-class specializers)
+ nil))))
+ (when method
+ (sb-kernel::style-warn "redefining ~S~{ ~S~} ~S in DEFMETHOD"
+ gf-spec qualifiers specializers))))
+ (let ((method (apply #'add-named-method
+ gf-spec qualifiers specializers lambda-list
+ :definition-source `((defmethod ,gf-spec
+ ,@qualifiers
+ ,specializers)
+ ,*load-truename*)
+ initargs)))
+ (unless (or (eq method-class 'standard-method)
+ (eq (find-class method-class nil) (class-of method)))
+ ;; FIXME: should be STYLE-WARNING?
+ (format *error-output*
+ "~&At the time the method with qualifiers ~:S and~%~
+ specializers ~:S on the generic function ~S~%~
+ was compiled, the method-class for that generic function was~%~
+ ~S. But, the method class is now ~S, this~%~
+ may mean that this method was compiled improperly.~%"
+ qualifiers specializers gf-spec
+ method-class (class-name (class-of method))))
+ method))
+
+(defun make-method-spec (gf-spec qualifiers unparsed-specializers)
+ `(method ,gf-spec ,@qualifiers ,unparsed-specializers))
+
+(defun initialize-method-function (initargs &optional return-function-p method)
+ (let* ((mf (getf initargs ':function))
+ (method-spec (getf initargs ':method-spec))
+ (plist (getf initargs ':plist))
+ (pv-table-symbol (getf plist ':pv-table-symbol))
+ (pv-table nil)
+ (mff (getf initargs ':fast-function)))
+ (flet ((set-mf-property (p v)
+ (when mf
+ (setf (method-function-get mf p) v))
+ (when mff
+ (setf (method-function-get mff p) v))))
+ (when method-spec
+ (when mf
+ (setq mf (set-function-name mf method-spec)))
+ (when mff
+ (let ((name `(,(or (get (car method-spec) 'fast-sym)
+ (setf (get (car method-spec) 'fast-sym)
+ ;; KLUDGE: If we're going to be
+ ;; interning private symbols in our
+ ;; a this way, it would be cleanest
+ ;; to use a separate package
+ ;; %PCL-PRIVATE or something, and
+ ;; failing that, to use a special
+ ;; symbol prefix denoting privateness.
+ ;; -- WHN 19991201
+ (intern (format nil "FAST-~A"
+ (car method-spec))
+ *pcl-package*)))
+ ,@(cdr method-spec))))
+ (set-function-name mff name)
+ (unless mf
+ (set-mf-property :name name)))))
+ (when plist
+ (let ((snl (getf plist :slot-name-lists))
+ (cl (getf plist :call-list)))
+ (when (or snl cl)
+ (setq pv-table (intern-pv-table :slot-name-lists snl
+ :call-list cl))
+ (when pv-table (set pv-table-symbol pv-table))
+ (set-mf-property :pv-table pv-table)))
+ (loop (when (null plist) (return nil))
+ (set-mf-property (pop plist) (pop plist)))
+ (when method
+ (set-mf-property :method method))
+ (when return-function-p
+ (or mf (method-function-from-fast-function mff)))))))
+\f
+(defun analyze-lambda-list (lambda-list)
+ ;;(declare (values nrequired noptional keysp restp allow-other-keys-p
+ ;; keywords keyword-parameters))
+ (flet ((parse-keyword-argument (arg)
+ (if (listp arg)
+ (if (listp (car arg))
+ (caar arg)
+ (make-keyword (car arg)))
+ (make-keyword arg))))
+ (let ((nrequired 0)
+ (noptional 0)
+ (keysp nil)
+ (restp nil)
+ (allow-other-keys-p nil)
+ (keywords ())
+ (keyword-parameters ())
+ (state 'required))
+ (dolist (x lambda-list)
+ (if (memq x lambda-list-keywords)
+ (case x
+ (&optional (setq state 'optional))
+ (&key (setq keysp 't
+ state 'key))
+ (&allow-other-keys (setq allow-other-keys-p 't))
+ (&rest (setq restp 't
+ state 'rest))
+ (&aux (return t))
+ (otherwise
+ (error "encountered the non-standard lambda list keyword ~S" x)))
+ (ecase state
+ (required (incf nrequired))
+ (optional (incf noptional))
+ (key (push (parse-keyword-argument x) keywords)
+ (push x keyword-parameters))
+ (rest ()))))
+ (values nrequired noptional keysp restp allow-other-keys-p
+ (reverse keywords)
+ (reverse keyword-parameters)))))
+
+(defun keyword-spec-name (x)
+ (let ((key (if (atom x) x (car x))))
+ (if (atom key)
+ (intern (symbol-name key) *keyword-package*)
+ (car key))))
+
+(defun ftype-declaration-from-lambda-list (lambda-list name)
+ (multiple-value-bind (nrequired noptional keysp restp allow-other-keys-p
+ keywords keyword-parameters)
+ (analyze-lambda-list lambda-list)
+ (declare (ignore keyword-parameters))
+ (let* ((old (sb-c::info :function :type name)) ;FIXME:FDOCUMENTATION instead?
+ (old-ftype (if (sb-c::function-type-p old) old nil))
+ (old-restp (and old-ftype (sb-c::function-type-rest old-ftype)))
+ (old-keys (and old-ftype
+ (mapcar #'sb-c::key-info-name
+ (sb-c::function-type-keywords old-ftype))))
+ (old-keysp (and old-ftype (sb-c::function-type-keyp old-ftype)))
+ (old-allowp (and old-ftype (sb-c::function-type-allowp old-ftype)))
+ (keywords (union old-keys (mapcar #'keyword-spec-name keywords))))
+ `(function ,(append (make-list nrequired :initial-element 't)
+ (when (plusp noptional)
+ (append '(&optional)
+ (make-list noptional :initial-element 't)))
+ (when (or restp old-restp)
+ '(&rest t))
+ (when (or keysp old-keysp)
+ (append '(&key)
+ (mapcar #'(lambda (key)
+ `(,key t))
+ keywords)
+ (when (or allow-other-keys-p old-allowp)
+ '(&allow-other-keys)))))
+ *))))
+
+(defun defgeneric-declaration (spec lambda-list)
+ (when (consp spec)
+ (setq spec (get-setf-function-name (cadr spec))))
+ `(ftype ,(ftype-declaration-from-lambda-list lambda-list spec) ,spec))
+\f
+;;;; early generic function support
+
+(defvar *early-generic-functions* ())
+
+(defun ensure-generic-function (function-name
+ &rest all-keys
+ &key environment
+ &allow-other-keys)
+ (declare (ignore environment))
+ (let ((existing (and (gboundp function-name)
+ (gdefinition function-name))))
+ (if (and existing
+ (eq *boot-state* 'complete)
+ (null (generic-function-p existing)))
+ (generic-clobbers-function function-name)
+ (apply #'ensure-generic-function-using-class
+ existing function-name all-keys))))
+
+(defun generic-clobbers-function (function-name)
+ (error 'sb-kernel:simple-program-error
+ :format-control
+ "~S already names an ordinary function or a macro."
+ :format-arguments (list function-name)))
+
+(defvar *sgf-wrapper*
+ (boot-make-wrapper (early-class-size 'standard-generic-function)
+ 'standard-generic-function))
+
+(defvar *sgf-slots-init*
+ (mapcar #'(lambda (canonical-slot)
+ (if (memq (getf canonical-slot :name) '(arg-info source))
+ *slot-unbound*
+ (let ((initfunction (getf canonical-slot :initfunction)))
+ (if initfunction
+ (funcall initfunction)
+ *slot-unbound*))))
+ (early-collect-inheritance 'standard-generic-function)))
+
+(defvar *sgf-method-class-index*
+ (bootstrap-slot-index 'standard-generic-function 'method-class))
+
+(defun early-gf-p (x)
+ (and (fsc-instance-p x)
+ (eq (instance-ref (get-slots x) *sgf-method-class-index*)
+ *slot-unbound*)))
+
+(defvar *sgf-methods-index*
+ (bootstrap-slot-index 'standard-generic-function 'methods))
+
+(defmacro early-gf-methods (gf)
+ `(instance-ref (get-slots ,gf) *sgf-methods-index*))
+
+(defvar *sgf-arg-info-index*
+ (bootstrap-slot-index 'standard-generic-function 'arg-info))
+
+(defmacro early-gf-arg-info (gf)
+ `(instance-ref (get-slots ,gf) *sgf-arg-info-index*))
+
+(defvar *sgf-dfun-state-index*
+ (bootstrap-slot-index 'standard-generic-function 'dfun-state))
+
+(defstruct (arg-info
+ (:conc-name nil)
+ (:constructor make-arg-info ()))
+ (arg-info-lambda-list :no-lambda-list)
+ arg-info-precedence
+ arg-info-metatypes
+ arg-info-number-optional
+ arg-info-key/rest-p
+ arg-info-keywords ;nil no keyword or rest allowed
+ ;(k1 k2 ..) each method must accept these keyword arguments
+ ;T must have &key or &rest
+
+ gf-info-simple-accessor-type ; nil, reader, writer, boundp
+ (gf-precompute-dfun-and-emf-p nil) ; set by set-arg-info
+
+ gf-info-static-c-a-m-emf
+ (gf-info-c-a-m-emf-std-p t)
+ gf-info-fast-mf-p)
+
+#-sb-fluid (declaim (sb-ext:freeze-type arg-info))
+
+(defun arg-info-valid-p (arg-info)
+ (not (null (arg-info-number-optional arg-info))))
+
+(defun arg-info-applyp (arg-info)
+ (or (plusp (arg-info-number-optional arg-info))
+ (arg-info-key/rest-p arg-info)))
+
+(defun arg-info-number-required (arg-info)
+ (length (arg-info-metatypes arg-info)))
+
+(defun arg-info-nkeys (arg-info)
+ (count-if #'(lambda (x) (neq x 't)) (arg-info-metatypes arg-info)))
+
+;;; Keep pages clean by not setting if the value is already the same.
+(defmacro esetf (pos val)
+ (let ((valsym (gensym "value")))
+ `(let ((,valsym ,val))
+ (unless (equal ,pos ,valsym)
+ (setf ,pos ,valsym)))))
+
+(defun set-arg-info (gf &key new-method (lambda-list nil lambda-list-p)
+ argument-precedence-order)
+ (let* ((arg-info (if (eq *boot-state* 'complete)
+ (gf-arg-info gf)
+ (early-gf-arg-info gf)))
+ (methods (if (eq *boot-state* 'complete)
+ (generic-function-methods gf)
+ (early-gf-methods gf)))
+ (was-valid-p (integerp (arg-info-number-optional arg-info)))
+ (first-p (and new-method (null (cdr methods)))))
+ (when (and (not lambda-list-p) methods)
+ (setq lambda-list (gf-lambda-list gf)))
+ (when (or lambda-list-p
+ (and first-p
+ (eq (arg-info-lambda-list arg-info) ':no-lambda-list)))
+ (multiple-value-bind (nreq nopt keysp restp allow-other-keys-p keywords)
+ (analyze-lambda-list lambda-list)
+ (when (and methods (not first-p))
+ (let ((gf-nreq (arg-info-number-required arg-info))
+ (gf-nopt (arg-info-number-optional arg-info))
+ (gf-key/rest-p (arg-info-key/rest-p arg-info)))
+ (unless (and (= nreq gf-nreq)
+ (= nopt gf-nopt)
+ (eq (or keysp restp) gf-key/rest-p))
+ (error "The lambda-list ~S is incompatible with ~
+ existing methods of ~S."
+ lambda-list gf))))
+ (when lambda-list-p
+ (esetf (arg-info-lambda-list arg-info) lambda-list))
+ (when (or lambda-list-p argument-precedence-order
+ (null (arg-info-precedence arg-info)))
+ (esetf (arg-info-precedence arg-info)
+ (compute-precedence lambda-list nreq
+ argument-precedence-order)))
+ (esetf (arg-info-metatypes arg-info) (make-list nreq))
+ (esetf (arg-info-number-optional arg-info) nopt)
+ (esetf (arg-info-key/rest-p arg-info) (not (null (or keysp restp))))
+ (esetf (arg-info-keywords arg-info)
+ (if lambda-list-p
+ (if allow-other-keys-p t keywords)
+ (arg-info-key/rest-p arg-info)))))
+ (when new-method
+ (check-method-arg-info gf arg-info new-method))
+ (set-arg-info1 gf arg-info new-method methods was-valid-p first-p)
+ arg-info))
+
+(defun check-method-arg-info (gf arg-info method)
+ (multiple-value-bind (nreq nopt keysp restp allow-other-keys-p keywords)
+ (analyze-lambda-list (if (consp method)
+ (early-method-lambda-list method)
+ (method-lambda-list method)))
+ (flet ((lose (string &rest args)
+ (error
+ "attempt to add the method ~S to the generic function ~S.~%~
+ But ~A"
+ method
+ gf
+ (apply #'format nil string args)))
+ (compare (x y)
+ (if (> x y) "more" "fewer")))
+ (let ((gf-nreq (arg-info-number-required arg-info))
+ (gf-nopt (arg-info-number-optional arg-info))
+ (gf-key/rest-p (arg-info-key/rest-p arg-info))
+ (gf-keywords (arg-info-keywords arg-info)))
+ (unless (= nreq gf-nreq)
+ (lose
+ "the method has ~A required arguments than the generic function."
+ (compare nreq gf-nreq)))
+ (unless (= nopt gf-nopt)
+ (lose
+ "the method has ~S optional arguments than the generic function."
+ (compare nopt gf-nopt)))
+ (unless (eq (or keysp restp) gf-key/rest-p)
+ (error
+ "The method and generic function differ in whether they accept~%~
+ &REST or &KEY arguments."))
+ (when (consp gf-keywords)
+ (unless (or (and restp (not keysp))
+ allow-other-keys-p
+ (every #'(lambda (k) (memq k keywords)) gf-keywords))
+ (lose "the method does not accept each of the keyword arguments~%~
+ ~S."
+ gf-keywords)))))))
+
+(defun set-arg-info1 (gf arg-info new-method methods was-valid-p first-p)
+ (let* ((existing-p (and methods (cdr methods) new-method))
+ (nreq (length (arg-info-metatypes arg-info)))
+ (metatypes (if existing-p
+ (arg-info-metatypes arg-info)
+ (make-list nreq)))
+ (type (if existing-p
+ (gf-info-simple-accessor-type arg-info)
+ nil)))
+ (when (arg-info-valid-p arg-info)
+ (dolist (method (if new-method (list new-method) methods))
+ (let* ((specializers (if (or (eq *boot-state* 'complete)
+ (not (consp method)))
+ (method-specializers method)
+ (early-method-specializers method t)))
+ (class (if (or (eq *boot-state* 'complete) (not (consp method)))
+ (class-of method)
+ (early-method-class method)))
+ (new-type (when (and class
+ (or (not (eq *boot-state* 'complete))
+ (eq (generic-function-method-combination gf)
+ *standard-method-combination*)))
+ (cond ((eq class *the-class-standard-reader-method*)
+ 'reader)
+ ((eq class *the-class-standard-writer-method*)
+ 'writer)
+ ((eq class *the-class-standard-boundp-method*)
+ 'boundp)))))
+ (setq metatypes (mapcar #'raise-metatype metatypes specializers))
+ (setq type (cond ((null type) new-type)
+ ((eq type new-type) type)
+ (t nil)))))
+ (esetf (arg-info-metatypes arg-info) metatypes)
+ (esetf (gf-info-simple-accessor-type arg-info) type)))
+ (when (or (not was-valid-p) first-p)
+ (multiple-value-bind (c-a-m-emf std-p)
+ (if (early-gf-p gf)
+ (values t t)
+ (compute-applicable-methods-emf gf))
+ (esetf (gf-info-static-c-a-m-emf arg-info) c-a-m-emf)
+ (esetf (gf-info-c-a-m-emf-std-p arg-info) std-p)
+ (unless (gf-info-c-a-m-emf-std-p arg-info)
+ (esetf (gf-info-simple-accessor-type arg-info) t))))
+ (unless was-valid-p
+ (let ((name (if (eq *boot-state* 'complete)
+ (generic-function-name gf)
+ (early-gf-name gf))))
+ (esetf (gf-precompute-dfun-and-emf-p arg-info)
+ (let* ((sym (if (atom name) name (cadr name)))
+ (pkg-list (cons *pcl-package*
+ (package-use-list *pcl-package*))))
+ (and sym (symbolp sym)
+ (not (null (memq (symbol-package sym) pkg-list)))
+ (not (find #\space (symbol-name sym))))))))
+ (esetf (gf-info-fast-mf-p arg-info)
+ (or (not (eq *boot-state* 'complete))
+ (let* ((method-class (generic-function-method-class gf))
+ (methods (compute-applicable-methods
+ #'make-method-lambda
+ (list gf (class-prototype method-class)
+ '(lambda) nil))))
+ (and methods (null (cdr methods))
+ (let ((specls (method-specializers (car methods))))
+ (and (classp (car specls))
+ (eq 'standard-generic-function
+ (class-name (car specls)))
+ (classp (cadr specls))
+ (eq 'standard-method
+ (class-name (cadr specls)))))))))
+ arg-info)
+
+;;; This is the early definition of ensure-generic-function-using-class.
+;;;
+;;; The static-slots field of the funcallable instances used as early generic
+;;; functions is used to store the early methods and early discriminator code
+;;; for the early generic function. The static slots field of the fins
+;;; contains a list whose:
+;;; CAR - a list of the early methods on this early gf
+;;; CADR - the early discriminator code for this method
+(defun ensure-generic-function-using-class (existing spec &rest keys
+ &key (lambda-list nil lambda-list-p)
+ &allow-other-keys)
+ (declare (ignore keys))
+ (cond ((and existing (early-gf-p existing))
+ existing)
+ ((assoc spec *generic-function-fixups* :test #'equal)
+ (if existing
+ (make-early-gf spec lambda-list lambda-list-p existing)
+ (error "The function ~S is not already defined." spec)))
+ (existing
+ (error "~S should be on the list ~S."
+ spec
+ '*generic-function-fixups*))
+ (t
+ (pushnew spec *early-generic-functions* :test #'equal)
+ (make-early-gf spec lambda-list lambda-list-p))))
+
+(defun make-early-gf (spec &optional lambda-list lambda-list-p function)
+ (let ((fin (allocate-funcallable-instance *sgf-wrapper* *sgf-slots-init*)))
+ (set-funcallable-instance-function
+ fin
+ (or function
+ (if (eq spec 'print-object)
+ #'(sb-kernel:instance-lambda (instance stream)
+ (print-unreadable-object (instance stream :identity t)
+ (format stream "std-instance")))
+ #'(sb-kernel:instance-lambda (&rest args)
+ (declare (ignore args))
+ (error "The function of the funcallable-instance ~S~
+ has not been set." fin)))))
+ (setf (gdefinition spec) fin)
+ (bootstrap-set-slot 'standard-generic-function fin 'name spec)
+ (bootstrap-set-slot 'standard-generic-function fin 'source *load-truename*)
+ (set-function-name fin spec)
+ (let ((arg-info (make-arg-info)))
+ (setf (early-gf-arg-info fin) arg-info)
+ (when lambda-list-p
+ (proclaim (defgeneric-declaration spec lambda-list))
+ (set-arg-info fin :lambda-list lambda-list)))
+ fin))
+
+(defun set-dfun (gf &optional dfun cache info)
+ (when cache
+ (setf (cache-owner cache) gf))
+ (let ((new-state (if (and dfun (or cache info))
+ (list* dfun cache info)
+ dfun)))
+ (if (eq *boot-state* 'complete)
+ (setf (gf-dfun-state gf) new-state)
+ (setf (instance-ref (get-slots gf) *sgf-dfun-state-index*) new-state)))
+ dfun)
+
+(defun gf-dfun-cache (gf)
+ (let ((state (if (eq *boot-state* 'complete)
+ (gf-dfun-state gf)
+ (instance-ref (get-slots gf) *sgf-dfun-state-index*))))
+ (typecase state
+ (function nil)
+ (cons (cadr state)))))
+
+(defun gf-dfun-info (gf)
+ (let ((state (if (eq *boot-state* 'complete)
+ (gf-dfun-state gf)
+ (instance-ref (get-slots gf) *sgf-dfun-state-index*))))
+ (typecase state
+ (function nil)
+ (cons (cddr state)))))
+
+(defvar *sgf-name-index*
+ (bootstrap-slot-index 'standard-generic-function 'name))
+
+(defun early-gf-name (gf)
+ (instance-ref (get-slots gf) *sgf-name-index*))
+
+(defun gf-lambda-list (gf)
+ (let ((arg-info (if (eq *boot-state* 'complete)
+ (gf-arg-info gf)
+ (early-gf-arg-info gf))))
+ (if (eq ':no-lambda-list (arg-info-lambda-list arg-info))
+ (let ((methods (if (eq *boot-state* 'complete)
+ (generic-function-methods gf)
+ (early-gf-methods gf))))
+ (if (null methods)
+ (progn
+ (warn "no way to determine the lambda list for ~S" gf)
+ nil)
+ (let* ((method (car (last methods)))
+ (ll (if (consp method)
+ (early-method-lambda-list method)
+ (method-lambda-list method)))
+ (k (member '&key ll)))
+ (if k
+ (append (ldiff ll (cdr k)) '(&allow-other-keys))
+ ll))))
+ (arg-info-lambda-list arg-info))))
+
+(defmacro real-ensure-gf-internal (gf-class all-keys env)
+ `(progn
+ (cond ((symbolp ,gf-class)
+ (setq ,gf-class (find-class ,gf-class t ,env)))
+ ((classp ,gf-class))
+ (t
+ (error "The :GENERIC-FUNCTION-CLASS argument (~S) was neither a~%~
+ class nor a symbol that names a class."
+ ,gf-class)))
+ (remf ,all-keys :generic-function-class)
+ (remf ,all-keys :environment)
+ (let ((combin (getf ,all-keys :method-combination '.shes-not-there.)))
+ (unless (eq combin '.shes-not-there.)
+ (setf (getf ,all-keys :method-combination)
+ (find-method-combination (class-prototype ,gf-class)
+ (car combin)
+ (cdr combin)))))))
+
+(defun real-ensure-gf-using-class--generic-function
+ (existing
+ function-name
+ &rest all-keys
+ &key environment (lambda-list nil lambda-list-p)
+ (generic-function-class 'standard-generic-function gf-class-p)
+ &allow-other-keys)
+ (real-ensure-gf-internal generic-function-class all-keys environment)
+ (unless (or (null gf-class-p)
+ (eq (class-of existing) generic-function-class))
+ (change-class existing generic-function-class))
+ (prog1
+ (apply #'reinitialize-instance existing all-keys)
+ (when lambda-list-p
+ (proclaim (defgeneric-declaration function-name lambda-list)))))
+
+(defun real-ensure-gf-using-class--null
+ (existing
+ function-name
+ &rest all-keys
+ &key environment (lambda-list nil lambda-list-p)
+ (generic-function-class 'standard-generic-function)
+ &allow-other-keys)
+ (declare (ignore existing))
+ (real-ensure-gf-internal generic-function-class all-keys environment)
+ (prog1
+ (setf (gdefinition function-name)
+ (apply #'make-instance generic-function-class
+ :name function-name all-keys))
+ (when lambda-list-p
+ (proclaim (defgeneric-declaration function-name lambda-list)))))
+\f
+(defun get-generic-function-info (gf)
+ ;; values nreq applyp metatypes nkeys arg-info
+ (multiple-value-bind (applyp metatypes arg-info)
+ (let* ((arg-info (if (early-gf-p gf)
+ (early-gf-arg-info gf)
+ (gf-arg-info gf)))
+ (metatypes (arg-info-metatypes arg-info)))
+ (values (arg-info-applyp arg-info)
+ metatypes
+ arg-info))
+ (values (length metatypes) applyp metatypes
+ (count-if #'(lambda (x) (neq x 't)) metatypes)
+ arg-info)))
+
+(defun early-make-a-method (class qualifiers arglist specializers initargs doc
+ &optional slot-name)
+ (initialize-method-function initargs)
+ (let ((parsed ())
+ (unparsed ()))
+ ;; Figure out whether we got class objects or class names as the
+ ;; specializers and set parsed and unparsed appropriately. If we
+ ;; got class objects, then we can compute unparsed, but if we got
+ ;; class names we don't try to compute parsed.
+ ;;
+ ;; Note that the use of not symbolp in this call to every should be
+ ;; read as 'classp' we can't use classp itself because it doesn't
+ ;; exist yet.
+ (if (every #'(lambda (s) (not (symbolp s))) specializers)
+ (setq parsed specializers
+ unparsed (mapcar #'(lambda (s)
+ (if (eq s 't) 't (class-name s)))
+ specializers))
+ (setq unparsed specializers
+ parsed ()))
+ (list :early-method ;This is an early method dammit!
+
+ (getf initargs ':function)
+ (getf initargs ':fast-function)
+
+ parsed ;The parsed specializers. This is used
+ ;by early-method-specializers to cache
+ ;the parse. Note that this only comes
+ ;into play when there is more than one
+ ;early method on an early gf.
+
+ (list class ;A list to which real-make-a-method
+ qualifiers ;can be applied to make a real method
+ arglist ;corresponding to this early one.
+ unparsed
+ initargs
+ doc
+ slot-name))))
+
+(defun real-make-a-method
+ (class qualifiers lambda-list specializers initargs doc
+ &optional slot-name)
+ (setq specializers (parse-specializers specializers))
+ (apply #'make-instance class
+ :qualifiers qualifiers
+ :lambda-list lambda-list
+ :specializers specializers
+ :documentation doc
+ :slot-name slot-name
+ :allow-other-keys t
+ initargs))
+
+(defun early-method-function (early-method)
+ (values (cadr early-method) (caddr early-method)))
+
+(defun early-method-class (early-method)
+ (find-class (car (fifth early-method))))
+
+(defun early-method-standard-accessor-p (early-method)
+ (let ((class (first (fifth early-method))))
+ (or (eq class 'standard-reader-method)
+ (eq class 'standard-writer-method)
+ (eq class 'standard-boundp-method))))
+
+(defun early-method-standard-accessor-slot-name (early-method)
+ (seventh (fifth early-method)))
+
+;;; Fetch the specializers of an early method. This is basically just a
+;;; simple accessor except that when the second argument is t, this converts
+;;; the specializers from symbols into class objects. The class objects
+;;; are cached in the early method, this makes bootstrapping faster because
+;;; the class objects only have to be computed once.
+;;; NOTE:
+;;; the second argument should only be passed as T by early-lookup-method.
+;;; this is to implement the rule that only when there is more than one
+;;; early method on a generic function is the conversion from class names
+;;; to class objects done.
+;;; the corresponds to the fact that we are only allowed to have one method
+;;; on any generic function up until the time classes exist.
+(defun early-method-specializers (early-method &optional objectsp)
+ (if (and (listp early-method)
+ (eq (car early-method) :early-method))
+ (cond ((eq objectsp 't)
+ (or (fourth early-method)
+ (setf (fourth early-method)
+ (mapcar #'find-class (cadddr (fifth early-method))))))
+ (t
+ (cadddr (fifth early-method))))
+ (error "~S is not an early-method." early-method)))
+
+(defun early-method-qualifiers (early-method)
+ (cadr (fifth early-method)))
+
+(defun early-method-lambda-list (early-method)
+ (caddr (fifth early-method)))
+
+(defun early-add-named-method (generic-function-name
+ qualifiers
+ specializers
+ arglist
+ &rest initargs)
+ (let* ((gf (ensure-generic-function generic-function-name))
+ (existing
+ (dolist (m (early-gf-methods gf))
+ (when (and (equal (early-method-specializers m) specializers)
+ (equal (early-method-qualifiers m) qualifiers))
+ (return m))))
+ (new (make-a-method 'standard-method
+ qualifiers
+ arglist
+ specializers
+ initargs
+ ())))
+ (when existing (remove-method gf existing))
+ (add-method gf new)))
+
+;;; This is the early version of add-method. Later this will become a
+;;; generic function. See fix-early-generic-functions which has special
+;;; knowledge about add-method.
+(defun add-method (generic-function method)
+ (when (not (fsc-instance-p generic-function))
+ (error "Early add-method didn't get a funcallable instance."))
+ (when (not (and (listp method) (eq (car method) :early-method)))
+ (error "Early add-method didn't get an early method."))
+ (push method (early-gf-methods generic-function))
+ (set-arg-info generic-function :new-method method)
+ (unless (assoc (early-gf-name generic-function) *generic-function-fixups*
+ :test #'equal)
+ (update-dfun generic-function)))
+
+;;; This is the early version of REMOVE-METHOD..
+(defun remove-method (generic-function method)
+ (when (not (fsc-instance-p generic-function))
+ (error "An early remove-method didn't get a funcallable instance."))
+ (when (not (and (listp method) (eq (car method) :early-method)))
+ (error "An early remove-method didn't get an early method."))
+ (setf (early-gf-methods generic-function)
+ (remove method (early-gf-methods generic-function)))
+ (set-arg-info generic-function)
+ (unless (assoc (early-gf-name generic-function) *generic-function-fixups*
+ :test #'equal)
+ (update-dfun generic-function)))
+
+;;; ..and the early version of GET-METHOD.
+(defun get-method (generic-function qualifiers specializers
+ &optional (errorp t))
+ (if (early-gf-p generic-function)
+ (or (dolist (m (early-gf-methods generic-function))
+ (when (and (or (equal (early-method-specializers m nil)
+ specializers)
+ (equal (early-method-specializers m 't)
+ specializers))
+ (equal (early-method-qualifiers m) qualifiers))
+ (return m)))
+ (if errorp
+ (error "can't get early method")
+ nil))
+ (real-get-method generic-function qualifiers specializers errorp)))
+
+(defvar *fegf-debug-p* nil)
+
+(defun fix-early-generic-functions (&optional (noisyp *fegf-debug-p*))
+ (let ((accessors nil))
+ ;; Rearrange *EARLY-GENERIC-FUNCTIONS* to speed up
+ ;; FIX-EARLY-GENERIC-FUNCTIONS.
+ (dolist (early-gf-spec *early-generic-functions*)
+ (when (every #'early-method-standard-accessor-p
+ (early-gf-methods (gdefinition early-gf-spec)))
+ (push early-gf-spec accessors)))
+ (dolist (spec (nconc accessors
+ '(accessor-method-slot-name
+ generic-function-methods
+ method-specializers
+ specializerp
+ specializer-type
+ specializer-class
+ slot-definition-location
+ slot-definition-name
+ class-slots
+ gf-arg-info
+ class-precedence-list
+ slot-boundp-using-class
+ (setf slot-value-using-class)
+ slot-value-using-class
+ structure-class-p
+ standard-class-p
+ funcallable-standard-class-p
+ specializerp)))
+ (setq *early-generic-functions*
+ (cons spec (delete spec *early-generic-functions* :test #'equal))))
+
+ (dolist (early-gf-spec *early-generic-functions*)
+ (when noisyp (format t "~&~S..." early-gf-spec))
+ (let* ((gf (gdefinition early-gf-spec))
+ (methods (mapcar #'(lambda (early-method)
+ (let ((args (copy-list (fifth
+ early-method))))
+ (setf (fourth args)
+ (early-method-specializers
+ early-method t))
+ (apply #'real-make-a-method args)))
+ (early-gf-methods gf))))
+ (setf (generic-function-method-class gf) *the-class-standard-method*)
+ (setf (generic-function-method-combination gf)
+ *standard-method-combination*)
+ (set-methods gf methods)))
+
+ (dolist (fns *early-functions*)
+ (setf (gdefinition (car fns)) (symbol-function (caddr fns))))
+
+ (dolist (fixup *generic-function-fixups*)
+ (let* ((fspec (car fixup))
+ (gf (gdefinition fspec))
+ (methods (mapcar #'(lambda (method)
+ (let* ((lambda-list (first method))
+ (specializers (second method))
+ (method-fn-name (third method))
+ (fn-name (or method-fn-name fspec))
+ (fn (symbol-function fn-name))
+ (initargs
+ (list :function
+ (set-function-name
+ #'(lambda (args next-methods)
+ (declare (ignore
+ next-methods))
+ (apply fn args))
+ `(call ,fn-name)))))
+ (declare (type function fn))
+ (make-a-method 'standard-method
+ ()
+ lambda-list
+ specializers
+ initargs
+ nil)))
+ (cdr fixup))))
+ (setf (generic-function-method-class gf) *the-class-standard-method*)
+ (setf (generic-function-method-combination gf)
+ *standard-method-combination*)
+ (set-methods gf methods)))))
+\f
+;;; PARSE-DEFMETHOD is used by DEFMETHOD to parse the &REST argument into
+;;; the 'real' arguments. This is where the syntax of DEFMETHOD is really
+;;; implemented.
+(defun parse-defmethod (cdr-of-form)
+ ;;(declare (values name qualifiers specialized-lambda-list body))
+ (let ((name (pop cdr-of-form))
+ (qualifiers ())
+ (spec-ll ()))
+ (loop (if (and (car cdr-of-form) (atom (car cdr-of-form)))
+ (push (pop cdr-of-form) qualifiers)
+ (return (setq qualifiers (nreverse qualifiers)))))
+ (setq spec-ll (pop cdr-of-form))
+ (values name qualifiers spec-ll cdr-of-form)))
+
+(defun parse-specializers (specializers)
+ (flet ((parse (spec)
+ (let ((result (specializer-from-type spec)))
+ (if (specializerp result)
+ result
+ (if (symbolp spec)
+ (error "~S was used as a specializer,~%~
+ but is not the name of a class."
+ spec)
+ (error "~S is not a legal specializer." spec))))))
+ (mapcar #'parse specializers)))
+
+(defun unparse-specializers (specializers-or-method)
+ (if (listp specializers-or-method)
+ (flet ((unparse (spec)
+ (if (specializerp spec)
+ (let ((type (specializer-type spec)))
+ (if (and (consp type)
+ (eq (car type) 'class))
+ (let* ((class (cadr type))
+ (class-name (class-name class)))
+ (if (eq class (find-class class-name nil))
+ class-name
+ type))
+ type))
+ (error "~S is not a legal specializer." spec))))
+ (mapcar #'unparse specializers-or-method))
+ (unparse-specializers (method-specializers specializers-or-method))))
+
+(defun parse-method-or-spec (spec &optional (errorp t))
+ ;;(declare (values generic-function method method-name))
+ (let (gf method name temp)
+ (if (method-p spec)
+ (setq method spec
+ gf (method-generic-function method)
+ temp (and gf (generic-function-name gf))
+ name (if temp
+ (intern-function-name
+ (make-method-spec temp
+ (method-qualifiers method)
+ (unparse-specializers
+ (method-specializers method))))
+ (make-symbol (format nil "~S" method))))
+ (multiple-value-bind (gf-spec quals specls)
+ (parse-defmethod spec)
+ (and (setq gf (and (or errorp (gboundp gf-spec))
+ (gdefinition gf-spec)))
+ (let ((nreq (compute-discriminating-function-arglist-info gf)))
+ (setq specls (append (parse-specializers specls)
+ (make-list (- nreq (length specls))
+ :initial-element
+ *the-class-t*)))
+ (and
+ (setq method (get-method gf quals specls errorp))
+ (setq name
+ (intern-function-name (make-method-spec gf-spec
+ quals
+ specls))))))))
+ (values gf method name)))
+\f
+(defun extract-parameters (specialized-lambda-list)
+ (multiple-value-bind (parameters ignore1 ignore2)
+ (parse-specialized-lambda-list specialized-lambda-list)
+ (declare (ignore ignore1 ignore2))
+ parameters))
+
+(defun extract-lambda-list (specialized-lambda-list)
+ (multiple-value-bind (ignore1 lambda-list ignore2)
+ (parse-specialized-lambda-list specialized-lambda-list)
+ (declare (ignore ignore1 ignore2))
+ lambda-list))
+
+(defun extract-specializer-names (specialized-lambda-list)
+ (multiple-value-bind (ignore1 ignore2 specializers)
+ (parse-specialized-lambda-list specialized-lambda-list)
+ (declare (ignore ignore1 ignore2))
+ specializers))
+
+(defun extract-required-parameters (specialized-lambda-list)
+ (multiple-value-bind (ignore1 ignore2 ignore3 required-parameters)
+ (parse-specialized-lambda-list specialized-lambda-list)
+ (declare (ignore ignore1 ignore2 ignore3))
+ required-parameters))
+
+(defun parse-specialized-lambda-list (arglist &optional post-keyword)
+ ;;(declare (values parameters lambda-list specializers required-parameters))
+ (let ((arg (car arglist)))
+ (cond ((null arglist) (values nil nil nil nil))
+ ((eq arg '&aux)
+ (values nil arglist nil))
+ ((memq arg lambda-list-keywords)
+ (unless (memq arg '(&optional &rest &key &allow-other-keys &aux))
+ ;; Warn about non-standard lambda-list-keywords, but then
+ ;; go on to treat them like a standard lambda-list-keyword
+ ;; what with the warning its probably ok.
+ ;;
+ ;; FIXME: This shouldn't happen now that this is maintained
+ ;; as part of SBCL, should it? Perhaps this is now
+ ;; "internal error: unrecognized lambda-list keyword ~S"?
+ (warn "Unrecognized lambda-list keyword ~S in arglist.~%~
+ Assuming that the symbols following it are parameters,~%~
+ and not allowing any parameter specializers to follow~%~
+ to follow it."
+ arg))
+ ;; When we are at a lambda-list keyword, the parameters don't
+ ;; include the lambda-list keyword; the lambda-list does include
+ ;; the lambda-list keyword; and no specializers are allowed to
+ ;; follow the lambda-list keywords (at least for now).
+ (multiple-value-bind (parameters lambda-list)
+ (parse-specialized-lambda-list (cdr arglist) t)
+ (values parameters
+ (cons arg lambda-list)
+ ()
+ ())))
+ (post-keyword
+ ;; After a lambda-list keyword there can be no specializers.
+ (multiple-value-bind (parameters lambda-list)
+ (parse-specialized-lambda-list (cdr arglist) t)
+ (values (cons (if (listp arg) (car arg) arg) parameters)
+ (cons arg lambda-list)
+ ()
+ ())))
+ (t
+ (multiple-value-bind (parameters lambda-list specializers required)
+ (parse-specialized-lambda-list (cdr arglist))
+ (values (cons (if (listp arg) (car arg) arg) parameters)
+ (cons (if (listp arg) (car arg) arg) lambda-list)
+ (cons (if (listp arg) (cadr arg) 't) specializers)
+ (cons (if (listp arg) (car arg) arg) required)))))))
+\f
+(eval-when (:load-toplevel :execute)
+ (setq *boot-state* 'early))
+\f
+;;; FIXME: In here there was a #-CMU definition of SYMBOL-MACROLET which used
+;;; %WALKER stuff. That suggests to me that maybe the code walker stuff was
+;;; only used for implementing stuff like that; maybe it's not needed any more?
+;;; Hunt down what it was used for and see.
+
+(defmacro with-slots (slots instance &body body)
+ (let ((in (gensym)))
+ `(let ((,in ,instance))
+ (declare (ignorable ,in))
+ ,@(let ((instance (if (and (consp instance) (eq (car instance) 'the))
+ (third instance)
+ instance)))
+ (and (symbolp instance)
+ `((declare (variable-rebinding ,in ,instance)))))
+ ,in
+ (symbol-macrolet ,(mapcar #'(lambda (slot-entry)
+ (let ((variable-name
+ (if (symbolp slot-entry)
+ slot-entry
+ (car slot-entry)))
+ (slot-name
+ (if (symbolp slot-entry)
+ slot-entry
+ (cadr slot-entry))))
+ `(,variable-name
+ (slot-value ,in ',slot-name))))
+ slots)
+ ,@body))))
+
+(defmacro with-accessors (slots instance &body body)
+ (let ((in (gensym)))
+ `(let ((,in ,instance))
+ (declare (ignorable ,in))
+ ,@(let ((instance (if (and (consp instance) (eq (car instance) 'the))
+ (third instance)
+ instance)))
+ (and (symbolp instance)
+ `((declare (variable-rebinding ,in ,instance)))))
+ ,in
+ (symbol-macrolet ,(mapcar #'(lambda (slot-entry)
+ (let ((variable-name (car slot-entry))
+ (accessor-name (cadr slot-entry)))
+ `(,variable-name
+ (,accessor-name ,in))))
+ slots)
+ ,@body))))
--- /dev/null
+;;;; bootstrapping the meta-braid
+;;;;
+;;;; The code in this file takes the early definitions that have been saved
+;;;; up and actually builds those class objects. This work is largely driven
+;;;; off of those class definitions, but the fact that STANDARD-CLASS is the
+;;;; class of all metaclasses in the braid is built into this code pretty
+;;;; deeply.
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+
+;;;; This software is derived from software originally released by Xerox
+;;;; Corporation. Copyright and release statements follow. Later modifications
+;;;; to the software are in the public domain and are provided with
+;;;; absolutely no warranty. See the COPYING and CREDITS files for more
+;;;; information.
+
+;;;; copyright information from original PCL sources:
+;;;;
+;;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
+;;;; All rights reserved.
+;;;;
+;;;; Use and copying of this software and preparation of derivative works based
+;;;; upon this software are permitted. Any distribution of this software or
+;;;; derivative works must comply with all applicable United States export
+;;;; control laws.
+;;;;
+;;;; This software is made available AS IS, and Xerox Corporation makes no
+;;;; warranty about the software, its performance or its conformity to any
+;;;; specification.
+
+(in-package "SB-PCL")
+
+(sb-int:file-comment
+ "$Header$")
+\f
+(defun allocate-standard-instance (wrapper
+ &optional (slots-init nil slots-init-p))
+ (let ((instance (%%allocate-instance--class))
+ (no-of-slots (wrapper-no-of-instance-slots wrapper)))
+ (setf (std-instance-wrapper instance) wrapper)
+ (setf (std-instance-slots instance)
+ (cond (slots-init-p
+ ;; Inline the slots vector allocation and initialization.
+ (let ((slots (make-array no-of-slots :initial-element 0)))
+ (do ((rem-slots slots-init (rest rem-slots))
+ (i 0 (1+ i)))
+ ((>= i no-of-slots)) ;endp rem-slots))
+ (declare (list rem-slots)
+ (type sb-kernel:index i))
+ (setf (aref slots i) (first rem-slots)))
+ slots))
+ (t
+ (make-array no-of-slots
+ :initial-element sb-pcl::*slot-unbound*))))
+ instance))
+
+(defmacro allocate-funcallable-instance-slots (wrapper &optional
+ slots-init-p slots-init)
+ `(let ((no-of-slots (wrapper-no-of-instance-slots ,wrapper)))
+ ,(if slots-init-p
+ `(if ,slots-init-p
+ (make-array no-of-slots :initial-contents ,slots-init)
+ (make-array no-of-slots :initial-element *slot-unbound*))
+ `(make-array no-of-slots :initial-element *slot-unbound*))))
+
+(defun allocate-funcallable-instance (wrapper &optional
+ (slots-init nil slots-init-p))
+ (let ((fin (allocate-funcallable-instance-1)))
+ (set-funcallable-instance-function
+ fin
+ #'(sb-kernel:instance-lambda (&rest args)
+ (declare (ignore args))
+ (error "The function of the funcallable-instance ~S has not been set."
+ fin)))
+ (setf (fsc-instance-wrapper fin) wrapper
+ (fsc-instance-slots fin) (allocate-funcallable-instance-slots
+ wrapper slots-init-p slots-init))
+ fin))
+
+(defun allocate-structure-instance (wrapper &optional
+ (slots-init nil slots-init-p))
+ (let* ((class (wrapper-class wrapper))
+ (constructor (class-defstruct-constructor class)))
+ (if constructor
+ (let ((instance (funcall constructor))
+ (slots (class-slots class)))
+ (when slots-init-p
+ (dolist (slot slots)
+ (setf (slot-value-using-class class instance slot)
+ (pop slots-init))))
+ instance)
+ (error "can't allocate an instance of class ~S" (class-name class)))))
+\f
+;;;; BOOTSTRAP-META-BRAID
+;;;;
+;;;; This function builds the base metabraid from the early class definitions.
+;;;;
+;;;; FIXME: This, like lotso the other stuff in PCL, is not needed in target
+;;;; Lisp, only at bootstrap time. Perhaps we should do something kludgy like
+;;;; putting a special character (#\$, perhaps) at the beginning of each
+;;;; needed-only-at-bootstrap-time symbol and then UNINTERN them all once we're
+;;;; done bootstrapping?
+
+(defmacro initial-classes-and-wrappers (&rest classes)
+ `(progn
+ ,@(mapcar #'(lambda (class)
+ (let ((wr (intern (format nil "~A-WRAPPER" class)
+ *pcl-package*)))
+ `(setf ,wr ,(if (eq class 'standard-generic-function)
+ '*sgf-wrapper*
+ `(boot-make-wrapper
+ (early-class-size ',class)
+ ',class))
+ ,class (allocate-standard-instance
+ ,(if (eq class 'standard-generic-function)
+ 'funcallable-standard-class-wrapper
+ 'standard-class-wrapper))
+ (wrapper-class ,wr) ,class
+ (find-class ',class) ,class)))
+ classes)))
+
+(defun bootstrap-meta-braid ()
+ (let* ((name 'class)
+ (predicate-name (make-type-predicate-name name)))
+ (setf (gdefinition predicate-name)
+ #'(lambda (x) (declare (ignore x)) t))
+ (do-satisfies-deftype name predicate-name))
+ (let* ((*create-classes-from-internal-structure-definitions-p* nil)
+ std-class-wrapper std-class
+ standard-class-wrapper standard-class
+ funcallable-standard-class-wrapper funcallable-standard-class
+ slot-class-wrapper slot-class
+ built-in-class-wrapper built-in-class
+ structure-class-wrapper structure-class
+ standard-direct-slot-definition-wrapper
+ standard-direct-slot-definition
+ standard-effective-slot-definition-wrapper
+ standard-effective-slot-definition
+ class-eq-specializer-wrapper class-eq-specializer
+ standard-generic-function-wrapper standard-generic-function)
+ (initial-classes-and-wrappers
+ standard-class funcallable-standard-class
+ slot-class built-in-class structure-class std-class
+ standard-direct-slot-definition standard-effective-slot-definition
+ class-eq-specializer standard-generic-function)
+ ;; First, make a class metaobject for each of the early classes. For
+ ;; each metaobject we also set its wrapper. Except for the class T,
+ ;; the wrapper is always that of STANDARD-CLASS.
+ (dolist (definition *early-class-definitions*)
+ (let* ((name (ecd-class-name definition))
+ (meta (ecd-metaclass definition))
+ (wrapper (ecase meta
+ (slot-class slot-class-wrapper)
+ (std-class std-class-wrapper)
+ (standard-class standard-class-wrapper)
+ (funcallable-standard-class
+ funcallable-standard-class-wrapper)
+ (built-in-class built-in-class-wrapper)
+ (structure-class structure-class-wrapper)))
+ (class (or (find-class name nil)
+ (allocate-standard-instance wrapper))))
+ (when (or (eq meta 'standard-class)
+ (eq meta 'funcallable-standard-class))
+ (inform-type-system-about-std-class name))
+ (setf (find-class name) class)))
+ (dolist (definition *early-class-definitions*)
+ (let ((name (ecd-class-name definition))
+ (meta (ecd-metaclass definition))
+ (source (ecd-source definition))
+ (direct-supers (ecd-superclass-names definition))
+ (direct-slots (ecd-canonical-slots definition))
+ (other-initargs (ecd-other-initargs definition)))
+ (let ((direct-default-initargs
+ (getf other-initargs :direct-default-initargs)))
+ (multiple-value-bind (slots cpl default-initargs direct-subclasses)
+ (early-collect-inheritance name)
+ (let* ((class (find-class name))
+ (wrapper (cond ((eq class slot-class)
+ slot-class-wrapper)
+ ((eq class std-class)
+ std-class-wrapper)
+ ((eq class standard-class)
+ standard-class-wrapper)
+ ((eq class funcallable-standard-class)
+ funcallable-standard-class-wrapper)
+ ((eq class standard-direct-slot-definition)
+ standard-direct-slot-definition-wrapper)
+ ((eq class
+ standard-effective-slot-definition)
+ standard-effective-slot-definition-wrapper)
+ ((eq class built-in-class)
+ built-in-class-wrapper)
+ ((eq class structure-class)
+ structure-class-wrapper)
+ ((eq class class-eq-specializer)
+ class-eq-specializer-wrapper)
+ ((eq class standard-generic-function)
+ standard-generic-function-wrapper)
+ (t
+ (boot-make-wrapper (length slots) name))))
+ (proto nil))
+ (when (eq name 't) (setq *the-wrapper-of-t* wrapper))
+ (set (intern (format nil "*THE-CLASS-~A*" (symbol-name name))
+ *pcl-package*)
+ class)
+ (dolist (slot slots)
+ (unless (eq (getf slot :allocation :instance) :instance)
+ (error "Slot allocation ~S is not supported in bootstrap.")))
+
+ (when (typep wrapper 'wrapper)
+ (setf (wrapper-instance-slots-layout wrapper)
+ (mapcar #'canonical-slot-name slots))
+ (setf (wrapper-class-slots wrapper)
+ ()))
+
+ (setq proto (if (eq meta 'funcallable-standard-class)
+ (allocate-funcallable-instance wrapper)
+ (allocate-standard-instance wrapper)))
+
+ (setq direct-slots
+ (bootstrap-make-slot-definitions
+ name class direct-slots
+ standard-direct-slot-definition-wrapper nil))
+ (setq slots
+ (bootstrap-make-slot-definitions
+ name class slots
+ standard-effective-slot-definition-wrapper t))
+
+ (case meta
+ ((std-class standard-class funcallable-standard-class)
+ (bootstrap-initialize-class
+ meta
+ class name class-eq-specializer-wrapper source
+ direct-supers direct-subclasses cpl wrapper proto
+ direct-slots slots direct-default-initargs default-initargs))
+ (built-in-class ; *the-class-t*
+ (bootstrap-initialize-class
+ meta
+ class name class-eq-specializer-wrapper source
+ direct-supers direct-subclasses cpl wrapper proto))
+ (slot-class ; *the-class-slot-object*
+ (bootstrap-initialize-class
+ meta
+ class name class-eq-specializer-wrapper source
+ direct-supers direct-subclasses cpl wrapper proto))
+ (structure-class ; *the-class-structure-object*
+ (bootstrap-initialize-class
+ meta
+ class name class-eq-specializer-wrapper source
+ direct-supers direct-subclasses cpl wrapper))))))))
+
+ (let* ((smc-class (find-class 'standard-method-combination))
+ (smc-wrapper (bootstrap-get-slot 'standard-class
+ smc-class
+ 'wrapper))
+ (smc (allocate-standard-instance smc-wrapper)))
+ (flet ((set-slot (name value)
+ (bootstrap-set-slot 'standard-method-combination
+ smc
+ name
+ value)))
+ (set-slot 'source *load-truename*)
+ (set-slot 'type 'standard)
+ (set-slot 'documentation "The standard method combination.")
+ (set-slot 'options ()))
+ (setq *standard-method-combination* smc))))
+
+;;; Initialize a class metaobject.
+;;;
+;;; FIXME: This and most stuff in this file is probably only needed at init
+;;; time.
+(defun bootstrap-initialize-class
+ (metaclass-name class name
+ class-eq-wrapper source direct-supers direct-subclasses cpl wrapper
+ &optional
+ proto direct-slots slots direct-default-initargs default-initargs)
+ (flet ((classes (names) (mapcar #'find-class names))
+ (set-slot (slot-name value)
+ (bootstrap-set-slot metaclass-name class slot-name value)))
+ (set-slot 'name name)
+ (set-slot 'source source)
+ (set-slot 'type (if (eq class (find-class 't))
+ t
+ `(class ,class)))
+ (set-slot 'class-eq-specializer
+ (let ((spec (allocate-standard-instance class-eq-wrapper)))
+ (bootstrap-set-slot 'class-eq-specializer spec 'type
+ `(class-eq ,class))
+ (bootstrap-set-slot 'class-eq-specializer spec 'object
+ class)
+ spec))
+ (set-slot 'class-precedence-list (classes cpl))
+ (set-slot 'can-precede-list (classes (cdr cpl)))
+ (set-slot 'incompatible-superclass-list nil)
+ (set-slot 'direct-superclasses (classes direct-supers))
+ (set-slot 'direct-subclasses (classes direct-subclasses))
+ (set-slot 'direct-methods (cons nil nil))
+ (set-slot 'wrapper wrapper)
+ (set-slot 'predicate-name (or (cadr (assoc name *early-class-predicates*))
+ (make-class-predicate-name name)))
+ (set-slot 'plist
+ `(,@(and direct-default-initargs
+ `(direct-default-initargs ,direct-default-initargs))
+ ,@(and default-initargs
+ `(default-initargs ,default-initargs))))
+ (when (memq metaclass-name '(standard-class funcallable-standard-class
+ structure-class slot-class std-class))
+ (set-slot 'direct-slots direct-slots)
+ (set-slot 'slots slots)
+ (set-slot 'initialize-info nil))
+ (if (eq metaclass-name 'structure-class)
+ (let ((constructor-sym '|STRUCTURE-OBJECT class constructor|))
+ (set-slot 'predicate-name (or (cadr (assoc name
+ *early-class-predicates*))
+ (make-class-predicate-name name)))
+ (set-slot 'defstruct-form
+ `(defstruct (structure-object (:constructor
+ ,constructor-sym))))
+ (set-slot 'defstruct-constructor constructor-sym)
+ (set-slot 'from-defclass-p t)
+ (set-slot 'plist nil)
+ (set-slot 'prototype (funcall constructor-sym)))
+ (set-slot 'prototype (or proto (allocate-standard-instance wrapper))))
+ class))
+
+(defun bootstrap-make-slot-definitions (name class slots wrapper effective-p)
+ (let ((index -1))
+ (mapcar #'(lambda (slot)
+ (incf index)
+ (bootstrap-make-slot-definition
+ name class slot wrapper effective-p index))
+ slots)))
+
+(defun bootstrap-make-slot-definition
+ (name class slot wrapper effective-p index)
+ (let* ((slotd-class-name (if effective-p
+ 'standard-effective-slot-definition
+ 'standard-direct-slot-definition))
+ (slotd (allocate-standard-instance wrapper))
+ (slot-name (getf slot :name)))
+ (flet ((get-val (name) (getf slot name))
+ (set-val (name val)
+ (bootstrap-set-slot slotd-class-name slotd name val)))
+ (set-val 'name slot-name)
+ (set-val 'initform (get-val :initform))
+ (set-val 'initfunction (get-val :initfunction))
+ (set-val 'initargs (get-val :initargs))
+ (set-val 'readers (get-val :readers))
+ (set-val 'writers (get-val :writers))
+ (set-val 'allocation :instance)
+ (set-val 'type (or (get-val :type) t))
+ (set-val 'documentation (or (get-val :documentation) ""))
+ (set-val 'class class)
+ (when effective-p
+ (set-val 'location index)
+ (let ((fsc-p nil))
+ (set-val 'reader-function (make-optimized-std-reader-method-function
+ fsc-p slot-name index))
+ (set-val 'writer-function (make-optimized-std-writer-method-function
+ fsc-p slot-name index))
+ (set-val 'boundp-function (make-optimized-std-boundp-method-function
+ fsc-p slot-name index)))
+ (set-val 'accessor-flags 7)
+ (let ((table (or (gethash slot-name *name->class->slotd-table*)
+ (setf (gethash slot-name *name->class->slotd-table*)
+ (make-hash-table :test 'eq :size 5)))))
+ (setf (gethash class table) slotd)))
+ (when (and (eq name 'standard-class)
+ (eq slot-name 'slots) effective-p)
+ (setq *the-eslotd-standard-class-slots* slotd))
+ (when (and (eq name 'funcallable-standard-class)
+ (eq slot-name 'slots) effective-p)
+ (setq *the-eslotd-funcallable-standard-class-slots* slotd))
+ slotd)))
+
+(defun bootstrap-accessor-definitions (early-p)
+ (let ((*early-p* early-p))
+ (dolist (definition *early-class-definitions*)
+ (let ((name (ecd-class-name definition))
+ (meta (ecd-metaclass definition)))
+ (unless (eq meta 'built-in-class)
+ (let ((direct-slots (ecd-canonical-slots definition)))
+ (dolist (slotd direct-slots)
+ (let ((slot-name (getf slotd :name))
+ (readers (getf slotd :readers))
+ (writers (getf slotd :writers)))
+ (bootstrap-accessor-definitions1
+ name
+ slot-name
+ readers
+ writers
+ nil)
+ (bootstrap-accessor-definitions1
+ 'slot-object
+ slot-name
+ (list (slot-reader-symbol slot-name))
+ (list (slot-writer-symbol slot-name))
+ (list (slot-boundp-symbol slot-name)))))))))))
+
+(defun bootstrap-accessor-definition (class-name accessor-name slot-name type)
+ (multiple-value-bind (accessor-class make-method-function arglist specls doc)
+ (ecase type
+ (reader (values 'standard-reader-method
+ #'make-std-reader-method-function
+ (list class-name)
+ (list class-name)
+ "automatically generated reader method"))
+ (writer (values 'standard-writer-method
+ #'make-std-writer-method-function
+ (list 'new-value class-name)
+ (list 't class-name)
+ "automatically generated writer method"))
+ (boundp (values 'standard-boundp-method
+ #'make-std-boundp-method-function
+ (list class-name)
+ (list class-name)
+ "automatically generated boundp method")))
+ (let ((gf (ensure-generic-function accessor-name)))
+ (if (find specls (early-gf-methods gf)
+ :key #'early-method-specializers
+ :test 'equal)
+ (unless (assoc accessor-name *generic-function-fixups*
+ :test #'equal)
+ (update-dfun gf))
+ (add-method gf
+ (make-a-method accessor-class
+ ()
+ arglist specls
+ (funcall make-method-function
+ class-name slot-name)
+ doc
+ slot-name))))))
+
+(defun bootstrap-accessor-definitions1 (class-name
+ slot-name
+ readers
+ writers
+ boundps)
+ (flet ((do-reader-definition (reader)
+ (bootstrap-accessor-definition class-name
+ reader
+ slot-name
+ 'reader))
+ (do-writer-definition (writer)
+ (bootstrap-accessor-definition class-name
+ writer
+ slot-name
+ 'writer))
+ (do-boundp-definition (boundp)
+ (bootstrap-accessor-definition class-name
+ boundp
+ slot-name
+ 'boundp)))
+ (dolist (reader readers) (do-reader-definition reader))
+ (dolist (writer writers) (do-writer-definition writer))
+ (dolist (boundp boundps) (do-boundp-definition boundp))))
+
+(defun bootstrap-class-predicates (early-p)
+ (let ((*early-p* early-p))
+ (dolist (definition *early-class-definitions*)
+ (let* ((name (ecd-class-name definition))
+ (class (find-class name)))
+ (setf (find-class-predicate name)
+ (make-class-predicate class (class-predicate-name class)))))))
+
+(defun bootstrap-built-in-classes ()
+
+ ;; First make sure that all the supers listed in
+ ;; *BUILT-IN-CLASS-LATTICE* are themselves defined by
+ ;; *BUILT-IN-CLASS-LATTICE*. This is just to check for typos and
+ ;; other sorts of brainos.
+ (dolist (e *built-in-classes*)
+ (dolist (super (cadr e))
+ (unless (or (eq super 't)
+ (assq super *built-in-classes*))
+ (error "in *BUILT-IN-CLASSES*: ~S has ~S as a super,~%~
+ but ~S is not itself a class in *BUILT-IN-CLASSES*."
+ (car e) super super))))
+
+ ;; In the first pass, we create a skeletal object to be bound to the
+ ;; class name.
+ (let* ((built-in-class (find-class 'built-in-class))
+ (built-in-class-wrapper (class-wrapper built-in-class)))
+ (dolist (e *built-in-classes*)
+ (let ((class (allocate-standard-instance built-in-class-wrapper)))
+ (setf (find-class (car e)) class))))
+
+ ;; In the second pass, we initialize the class objects.
+ (let ((class-eq-wrapper (class-wrapper (find-class 'class-eq-specializer))))
+ (dolist (e *built-in-classes*)
+ (destructuring-bind (name supers subs cpl prototype) e
+ (let* ((class (find-class name))
+ (lclass (cl:find-class name))
+ (wrapper (sb-kernel:class-layout lclass)))
+ (set (get-built-in-class-symbol name) class)
+ (set (get-built-in-wrapper-symbol name) wrapper)
+ (setf (sb-kernel:class-pcl-class lclass) class)
+
+ (bootstrap-initialize-class 'built-in-class class
+ name class-eq-wrapper nil
+ supers subs
+ (cons name cpl)
+ wrapper prototype)))))
+
+ (dolist (e *built-in-classes*)
+ (let* ((name (car e))
+ (class (find-class name)))
+ (setf (find-class-predicate name)
+ (make-class-predicate class (class-predicate-name class))))))
+\f
+(defmacro wrapper-of-macro (x)
+ `(sb-kernel:layout-of ,x))
+
+(defun class-of (x)
+ (wrapper-class* (wrapper-of-macro x)))
+
+;;; FIXME: We probably don't need both WRAPPER-OF and WRAPPER-OF-MACRO.
+#-sb-fluid (declaim (inline wrapper-of))
+(defun wrapper-of (x)
+ (wrapper-of-macro x))
+
+(defvar *find-structure-class* nil)
+
+(defun eval-form (form)
+ #'(lambda () (eval form)))
+
+(defun slot-initargs-from-structure-slotd (slotd)
+ `(:name ,(structure-slotd-name slotd)
+ :defstruct-accessor-symbol ,(structure-slotd-accessor-symbol slotd)
+ :internal-reader-function ,(structure-slotd-reader-function slotd)
+ :internal-writer-function ,(structure-slotd-writer-function slotd)
+ :type ,(or (structure-slotd-type slotd) t)
+ :initform ,(structure-slotd-init-form slotd)
+ :initfunction ,(eval-form (structure-slotd-init-form slotd))))
+
+(defun find-structure-class (symbol)
+ (if (structure-type-p symbol)
+ (unless (eq *find-structure-class* symbol)
+ (let ((*find-structure-class* symbol))
+ (ensure-class symbol
+ :metaclass 'structure-class
+ :name symbol
+ :direct-superclasses
+ (cond ;; Handle our CMU-CL-ish structure-based
+ ;; conditions.
+ ((cl:subtypep symbol 'condition)
+ (mapcar #'cl:class-name
+ (sb-kernel:class-direct-superclasses
+ (cl:find-class symbol))))
+ ;; a hack to add the STREAM class as a
+ ;; mixin to the LISP-STREAM class.
+ ((eq symbol 'sb-sys:lisp-stream)
+ '(structure-object stream))
+ ((structure-type-included-type-name symbol)
+ (list (structure-type-included-type-name
+ symbol))))
+ :direct-slots
+ (mapcar #'slot-initargs-from-structure-slotd
+ (structure-type-slot-description-list
+ symbol)))))
+ (error "~S is not a legal structure class name." symbol)))
+\f
+(defun method-function-returning-nil (args next-methods)
+ (declare (ignore args next-methods))
+ nil)
+
+(defun method-function-returning-t (args next-methods)
+ (declare (ignore args next-methods))
+ t)
+
+(defun make-class-predicate (class name)
+ (let* ((gf (ensure-generic-function name))
+ (mlist (if (eq *boot-state* 'complete)
+ (generic-function-methods gf)
+ (early-gf-methods gf))))
+ (unless mlist
+ (unless (eq class *the-class-t*)
+ (let* ((default-method-function #'method-function-returning-nil)
+ (default-method-initargs (list :function
+ default-method-function))
+ (default-method (make-a-method 'standard-method
+ ()
+ (list 'object)
+ (list *the-class-t*)
+ default-method-initargs
+ "class predicate default method")))
+ (setf (method-function-get default-method-function :constant-value)
+ nil)
+ (add-method gf default-method)))
+ (let* ((class-method-function #'method-function-returning-t)
+ (class-method-initargs (list :function
+ class-method-function))
+ (class-method (make-a-method 'standard-method
+ ()
+ (list 'object)
+ (list class)
+ class-method-initargs
+ "class predicate class method")))
+ (setf (method-function-get class-method-function :constant-value) t)
+ (add-method gf class-method)))
+ gf))
+
+;;; Set the inherits from CPL, and register the layout. This actually
+;;; installs the class in the Lisp type system.
+(defun update-lisp-class-layout (class layout)
+ (let ((lclass (sb-kernel:layout-class layout)))
+ (unless (eq (sb-kernel:class-layout lclass) layout)
+ (setf (sb-kernel:layout-inherits layout)
+ (map 'vector #'class-wrapper
+ (reverse (rest (class-precedence-list class)))))
+ (sb-kernel:register-layout layout :invalidate nil)
+
+ ;; Subclasses of formerly forward-referenced-class may be unknown
+ ;; to CL:FIND-CLASS and also anonymous. This functionality moved
+ ;; here from (SETF FIND-CLASS).
+ (let ((name (class-name class)))
+ (setf (cl:find-class name) lclass
+ ;; FIXME: It's nasty to use double colons. Perhaps the
+ ;; best way to fix this is not to export CLASS-%NAME
+ ;; from SB-KERNEL, but instead to move the whole
+ ;; UPDATE-LISP-CLASS-LAYOUT function to SB-KERNEL, and
+ ;; export it. (since it's also nasty for us to be
+ ;; reaching into %KERNEL implementation details my
+ ;; messing with raw CLASS-%NAME)
+ (sb-kernel::class-%name lclass) name)))))
+
+(eval-when (:load-toplevel :execute)
+
+ (clrhash *find-class*)
+ (bootstrap-meta-braid)
+ (bootstrap-accessor-definitions t)
+ (bootstrap-class-predicates t)
+ (bootstrap-accessor-definitions nil)
+ (bootstrap-class-predicates nil)
+ (bootstrap-built-in-classes)
+
+ (sb-int:dohash (name x *find-class*)
+ (let* ((class (find-class-from-cell name x))
+ (layout (class-wrapper class))
+ (lclass (sb-kernel:layout-class layout))
+ (lclass-pcl-class (sb-kernel:class-pcl-class lclass))
+ (olclass (cl:find-class name nil)))
+ (if lclass-pcl-class
+ (assert (eq class lclass-pcl-class))
+ (setf (sb-kernel:class-pcl-class lclass) class))
+
+ (update-lisp-class-layout class layout)
+
+ (cond (olclass
+ (assert (eq lclass olclass)))
+ (t
+ (setf (cl:find-class name) lclass)))))
+
+ (setq *boot-state* 'braid)
+
+ ) ; EVAL-WHEN
+
+(defmethod no-applicable-method (generic-function &rest args)
+ ;; FIXME: probably could be ERROR instead of CERROR
+ (cerror "Retry call to ~S."
+ "There is no matching method for the generic function ~S~@
+ when called with arguments ~S."
+ generic-function
+ args)
+ (apply generic-function args))
--- /dev/null
+;;;; the basics of the PCL wrapper cache mechanism
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+
+;;;; This software is derived from software originally released by Xerox
+;;;; Corporation. Copyright and release statements follow. Later modifications
+;;;; to the software are in the public domain and are provided with
+;;;; absolutely no warranty. See the COPYING and CREDITS files for more
+;;;; information.
+
+;;;; copyright information from original PCL sources:
+;;;;
+;;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
+;;;; All rights reserved.
+;;;;
+;;;; Use and copying of this software and preparation of derivative works based
+;;;; upon this software are permitted. Any distribution of this software or
+;;;; derivative works must comply with all applicable United States export
+;;;; control laws.
+;;;;
+;;;; This software is made available AS IS, and Xerox Corporation makes no
+;;;; warranty about the software, its performance or its conformity to any
+;;;; specification.
+
+(in-package "SB-PCL")
+
+(sb-int:file-comment
+ "$Header$")
+\f
+;;; FIXME: SB-PCL should probably USE-PACKAGE SB-KERNEL, since SB-PCL is built
+;;; on SB-KERNEL, and in the absence of USE-PACKAGE, it ends up using a
+;;; thundering herd of explicit prefixes to get to SB-KERNEL symbols.
+;;; Using the SB-INT and SB-EXT packages as well would help reduce
+;;; prefixing and make it more natural to reuse things (ONCE-ONLY,
+;;; *KEYWORD-PACKAGE*..) used in the main body of the system.
+;;; However, that would cause a conflict between the SB-ITERATE:ITERATE
+;;; macro and the SB-INT:ITERATE macro. (This could be resolved by
+;;; renaming SB-INT:ITERATE to SB-INT:NAMED-LET, or with
+;;; more gruntwork by punting the SB-ITERATE package and replacing
+;;; calls to SB-ITERATE:ITERATE with calls to CL:LOOP.
+
+;;; The caching algorithm implemented:
+;;;
+;;; << put a paper here >>
+;;;
+;;; For now, understand that as far as most of this code goes, a cache has
+;;; two important properties. The first is the number of wrappers used as
+;;; keys in each cache line. Throughout this code, this value is always
+;;; called NKEYS. The second is whether or not the cache lines of a cache
+;;; store a value. Throughout this code, this always called VALUEP.
+;;;
+;;; Depending on these values, there are three kinds of caches.
+;;;
+;;; NKEYS = 1, VALUEP = NIL
+;;;
+;;; In this kind of cache, each line is 1 word long. No cache locking is
+;;; needed since all read's in the cache are a single value. Nevertheless
+;;; line 0 (location 0) is reserved, to ensure that invalid wrappers will
+;;; not get a first probe hit.
+;;;
+;;; To keep the code simpler, a cache lock count does appear in location 0
+;;; of these caches, that count is incremented whenever data is written to
+;;; the cache. But, the actual lookup code (see make-dlap) doesn't need to
+;;; do locking when reading the cache.
+;;;
+;;; NKEYS = 1, VALUEP = T
+;;;
+;;; In this kind of cache, each line is 2 words long. Cache locking must
+;;; be done to ensure the synchronization of cache reads. Line 0 of the
+;;; cache (location 0) is reserved for the cache lock count. Location 1
+;;; of the cache is unused (in effect wasted).
+;;;
+;;; NKEYS > 1
+;;;
+;;; In this kind of cache, the 0 word of the cache holds the lock count.
+;;; The 1 word of the cache is line 0. Line 0 of these caches is not
+;;; reserved.
+;;;
+;;; This is done because in this sort of cache, the overhead of doing the
+;;; cache probe is high enough that the 1+ required to offset the location
+;;; is not a significant cost. In addition, because of the larger line
+;;; sizes, the space that would be wasted by reserving line 0 to hold the
+;;; lock count is more significant.
+\f
+;;; caches
+;;;
+;;; A cache is essentially just a vector. The use of the individual `words'
+;;; in the vector depends on particular properties of the cache as described
+;;; above.
+;;;
+;;; This defines an abstraction for caches in terms of their most obvious
+;;; implementation as simple vectors. But, please notice that part of the
+;;; implementation of this abstraction, is the function lap-out-cache-ref.
+;;; This means that most port-specific modifications to the implementation
+;;; of caches will require corresponding port-specific modifications to the
+;;; lap code assembler.
+(defmacro cache-vector-ref (cache-vector location)
+ `(svref (the simple-vector ,cache-vector)
+ (sb-ext:truly-the fixnum ,location)))
+
+(defmacro cache-vector-size (cache-vector)
+ `(array-dimension (the simple-vector ,cache-vector) 0))
+
+(defun allocate-cache-vector (size)
+ (make-array size :adjustable nil))
+
+(defmacro cache-vector-lock-count (cache-vector)
+ `(cache-vector-ref ,cache-vector 0))
+
+(defun flush-cache-vector-internal (cache-vector)
+ (without-interrupts
+ (fill (the simple-vector cache-vector) nil)
+ (setf (cache-vector-lock-count cache-vector) 0))
+ cache-vector)
+
+(defmacro modify-cache (cache-vector &body body)
+ `(without-interrupts
+ (multiple-value-prog1
+ (progn ,@body)
+ (let ((old-count (cache-vector-lock-count ,cache-vector)))
+ (declare (fixnum old-count))
+ (setf (cache-vector-lock-count ,cache-vector)
+ (if (= old-count most-positive-fixnum)
+ 1 (the fixnum (1+ old-count))))))))
+
+(deftype field-type ()
+ '(integer 0 ;#.(position 'number wrapper-layout)
+ 7)) ;#.(position 'number wrapper-layout :from-end t)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+(defun power-of-two-ceiling (x)
+ (declare (fixnum x))
+ ;;(expt 2 (ceiling (log x 2)))
+ (the fixnum (ash 1 (integer-length (1- x)))))
+
+(defconstant *nkeys-limit* 256)
+) ; EVAL-WHEN
+
+(defstruct (cache (:constructor make-cache ())
+ (:copier copy-cache-internal))
+ (owner nil)
+ (nkeys 1 :type (integer 1 #.*nkeys-limit*))
+ (valuep nil :type (member nil t))
+ (nlines 0 :type fixnum)
+ (field 0 :type field-type)
+ (limit-fn #'default-limit-fn :type function)
+ (mask 0 :type fixnum)
+ (size 0 :type fixnum)
+ (line-size 1 :type (integer 1 #.(power-of-two-ceiling (1+ *nkeys-limit*))))
+ (max-location 0 :type fixnum)
+ (vector #() :type simple-vector)
+ (overflow nil :type list))
+
+#-sb-fluid (declaim (sb-ext:freeze-type cache))
+
+(defmacro cache-lock-count (cache)
+ `(cache-vector-lock-count (cache-vector ,cache)))
+\f
+;;; some facilities for allocation and freeing caches as they are needed
+
+;;; This is done on the assumption that a better port of PCL will arrange
+;;; to cons these all in the same static area. Given that, the fact that
+;;; PCL tries to reuse them should be a win.
+
+(defvar *free-cache-vectors* (make-hash-table :size 16 :test 'eql))
+
+;;; Return a cache that has had flush-cache-vector-internal called on it. This
+;;; returns a cache of exactly the size requested, it won't ever return a
+;;; larger cache.
+(defun get-cache-vector (size)
+ (let ((entry (gethash size *free-cache-vectors*)))
+ (without-interrupts
+ (cond ((null entry)
+ (setf (gethash size *free-cache-vectors*) (cons 0 nil))
+ (get-cache-vector size))
+ ((null (cdr entry))
+ (incf (car entry))
+ (flush-cache-vector-internal (allocate-cache-vector size)))
+ (t
+ (let ((cache (cdr entry)))
+ (setf (cdr entry) (cache-vector-ref cache 0))
+ (flush-cache-vector-internal cache)))))))
+
+(defun free-cache-vector (cache-vector)
+ (let ((entry (gethash (cache-vector-size cache-vector) *free-cache-vectors*)))
+ (without-interrupts
+ (if (null entry)
+ (error
+ "attempt to free a cache-vector not allocated by GET-CACHE-VECTOR")
+ (let ((thread (cdr entry)))
+ (loop (unless thread (return))
+ (when (eq thread cache-vector)
+ (error "freeing a cache twice"))
+ (setq thread (cache-vector-ref thread 0)))
+ (flush-cache-vector-internal cache-vector) ; to help the GC
+ (setf (cache-vector-ref cache-vector 0) (cdr entry))
+ (setf (cdr entry) cache-vector)
+ nil)))))
+
+;;; This is just for debugging and analysis. It shows the state of the free
+;;; cache resource.
+#+sb-show
+(defun show-free-cache-vectors ()
+ (let ((elements ()))
+ (maphash #'(lambda (s e) (push (list s e) elements)) *free-cache-vectors*)
+ (setq elements (sort elements #'< :key #'car))
+ (dolist (e elements)
+ (let* ((size (car e))
+ (entry (cadr e))
+ (allocated (car entry))
+ (head (cdr entry))
+ (free 0))
+ (loop (when (null head) (return t))
+ (setq head (cache-vector-ref head 0))
+ (incf free))
+ (format t
+ "~&There ~4D are caches of size ~4D. (~D free ~3D%)"
+ allocated
+ size
+ free
+ (floor (* 100 (/ free (float allocated)))))))))
+\f
+;;;; wrapper cache numbers
+
+;;; The constant WRAPPER-CACHE-NUMBER-ADDS-OK controls the number of non-zero
+;;; bits wrapper cache numbers will have.
+;;;
+;;; The value of this constant is the number of wrapper cache numbers which
+;;; can be added and still be certain the result will be a fixnum. This is
+;;; used by all the code that computes primary cache locations from multiple
+;;; wrappers.
+;;;
+;;; The value of this constant is used to derive the next two which are the
+;;; forms of this constant which it is more convenient for the runtime code
+;;; to use.
+(defconstant wrapper-cache-number-length
+ (integer-length sb-kernel:layout-clos-hash-max))
+(defconstant wrapper-cache-number-mask sb-kernel:layout-clos-hash-max)
+(defconstant wrapper-cache-number-adds-ok
+ (truncate most-positive-fixnum sb-kernel:layout-clos-hash-max))
+\f
+;;;; wrappers themselves
+
+;;; This caching algorithm requires that wrappers have more than one wrapper
+;;; cache number. You should think of these multiple numbers as being in
+;;; columns. That is, for a given cache, the same column of wrapper cache
+;;; numbers will be used.
+;;;
+;;; If at some point the cache distribution of a cache gets bad, the cache
+;;; can be rehashed by switching to a different column.
+;;;
+;;; The columns are referred to by field number which is that number which,
+;;; when used as a second argument to wrapper-ref, will return that column
+;;; of wrapper cache number.
+;;;
+;;; This code is written to allow flexibility as to how many wrapper cache
+;;; numbers will be in each wrapper, and where they will be located. It is
+;;; also set up to allow port specific modifications to `pack' the wrapper
+;;; cache numbers on machines where the addressing modes make that a good
+;;; idea.
+
+;;; In SBCL, as in CMU CL, we want to do type checking as early as possible;
+;;; structures help this.
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defconstant wrapper-cache-number-vector-length
+ sb-kernel:layout-clos-hash-length)
+ (defconstant wrapper-layout (make-list wrapper-cache-number-vector-length
+ :initial-element 'number)))
+
+(unless (boundp '*the-class-t*)
+ (setq *the-class-t* nil))
+
+;;; Note that for SBCL, as for CMU CL, the WRAPPER of a built-in or structure
+;;; class will be some other kind of SB-KERNEL:LAYOUT, but this shouldn't
+;;; matter, since the only two slots that WRAPPER adds are meaningless in those
+;;; cases.
+(defstruct (wrapper
+ (:include sb-kernel:layout
+ ;; KLUDGE: In CMU CL, the initialization default for
+ ;; LAYOUT-INVALID was NIL. In SBCL, that has changed to
+ ;; :UNINITIALIZED, but PCL code might still expect NIL
+ ;; for the initialization default of WRAPPER-INVALID.
+ ;; Instead of trying to find out, I just overrode the
+ ;; LAYOUT default here. -- WHN 19991204
+ (invalid nil))
+ (:conc-name %wrapper-)
+ (:constructor make-wrapper-internal))
+ (instance-slots-layout nil :type list)
+ (class-slots nil :type list))
+#-sb-fluid (declaim (sb-ext:freeze-type wrapper))
+
+(defmacro wrapper-class (wrapper)
+ `(sb-kernel:class-pcl-class (sb-kernel:layout-class ,wrapper)))
+(defmacro wrapper-no-of-instance-slots (wrapper)
+ `(sb-kernel:layout-length ,wrapper))
+
+;;; WRAPPER-STATE returns T (not generalized boolean, but T exactly) iff the
+;;; wrapper is valid. Any other return value denotes some invalid state.
+;;; Special conventions have been set up for certain invalid states, e.g.
+;;; obsoleteness or flushedness, but I (WHN 19991204) haven't been motivated to
+;;; reverse engineer them from the code and document them here.
+;;;
+;;; FIXME: This is awkward and unmnemonic. There is a function
+;;; (INVALID-WRAPPER-P) to test this return result abstractly for invalidness
+;;; but it's not called consistently; the functions that need to know whether a
+;;; wrapper is invalid often test (EQ (WRAPPER-STATE X) T), ick. It would be
+;;; good to use the abstract test instead. It would probably be even better to
+;;; switch the sense of the WRAPPER-STATE function, renaming it to
+;;; WRAPPER-INVALID and making it synonymous with LAYOUT-INVALID. Then the
+;;; INVALID-WRAPPER-P function would become trivial and would go away (replaced
+;;; with WRAPPER-INVALID), since all the various invalid wrapper states would
+;;; become generalized boolean "true" values. -- WHN 19991204
+#-sb-fluid (declaim (inline wrapper-state (setf wrapper-state)))
+(defun wrapper-state (wrapper)
+ (let ((invalid (sb-kernel:layout-invalid wrapper)))
+ (cond ((null invalid)
+ t)
+ ((atom invalid)
+ ;; some non-PCL object. INVALID is probably :INVALID. We should
+ ;; arguably compute the new wrapper here instead of returning NIL,
+ ;; but we don't bother, since OBSOLETE-INSTANCE-TRAP can't use it.
+ '(:obsolete nil))
+ (t
+ invalid))))
+(defun (setf wrapper-state) (new-value wrapper)
+ (setf (sb-kernel:layout-invalid wrapper)
+ (if (eq new-value 't)
+ nil
+ new-value)))
+
+(defmacro wrapper-instance-slots-layout (wrapper)
+ `(%wrapper-instance-slots-layout ,wrapper))
+(defmacro wrapper-class-slots (wrapper)
+ `(%wrapper-class-slots ,wrapper))
+(defmacro wrapper-cache-number-vector (x) x)
+
+;;; This is called in BRAID when we are making wrappers for classes whose slots
+;;; are not initialized yet, and which may be built-in classes. We pass in the
+;;; class name in addition to the class.
+(defun boot-make-wrapper (length name &optional class)
+ (let ((found (cl:find-class name nil)))
+ (cond
+ (found
+ (unless (sb-kernel:class-pcl-class found)
+ (setf (sb-kernel:class-pcl-class found) class))
+ (assert (eq (sb-kernel:class-pcl-class found) class))
+ (let ((layout (sb-kernel:class-layout found)))
+ (assert layout)
+ layout))
+ (t
+ (make-wrapper-internal
+ :length length
+ :class (sb-kernel:make-standard-class :name name :pcl-class class))))))
+
+;;; The following variable may be set to a standard-class that has
+;;; already been created by the lisp code and which is to be redefined
+;;; by PCL. This allows standard-classes to be defined and used for
+;;; type testing and dispatch before PCL is loaded.
+(defvar *pcl-class-boot* nil)
+
+;;; In SBCL, as in CMU CL, the layouts (a.k.a wrappers) for built-in and
+;;; structure classes already exist when PCL is initialized, so we don't
+;;; necessarily always make a wrapper. Also, we help maintain the mapping
+;;; between cl:class and pcl::class objects.
+(defun make-wrapper (length class)
+ (cond
+ ((typep class 'std-class)
+ (make-wrapper-internal
+ :length length
+ :class
+ (let ((owrap (class-wrapper class)))
+ (cond (owrap
+ (sb-kernel:layout-class owrap))
+ ((*subtypep (class-of class)
+ *the-class-standard-class*)
+ (cond ((and *pcl-class-boot*
+ (eq (slot-value class 'name) *pcl-class-boot*))
+ (let ((found (cl:find-class (slot-value class 'name))))
+ (unless (sb-kernel:class-pcl-class found)
+ (setf (sb-kernel:class-pcl-class found) class))
+ (assert (eq (sb-kernel:class-pcl-class found) class))
+ found))
+ (t
+ (sb-kernel:make-standard-class :pcl-class class))))
+ (t
+ (sb-kernel:make-random-pcl-class :pcl-class class))))))
+ (t
+ (let* ((found (cl:find-class (slot-value class 'name)))
+ (layout (sb-kernel:class-layout found)))
+ (unless (sb-kernel:class-pcl-class found)
+ (setf (sb-kernel:class-pcl-class found) class))
+ (assert (eq (sb-kernel:class-pcl-class found) class))
+ (assert layout)
+ layout))))
+
+;;; FIXME: The immediately following macros could become inline functions.
+
+(defmacro first-wrapper-cache-number-index ()
+ 0)
+
+(defmacro next-wrapper-cache-number-index (field-number)
+ `(and (< ,field-number #.(1- wrapper-cache-number-vector-length))
+ (1+ ,field-number)))
+
+(defmacro cache-number-vector-ref (cnv n)
+ `(wrapper-cache-number-vector-ref ,cnv ,n))
+
+(defmacro wrapper-cache-number-vector-ref (wrapper n)
+ `(sb-kernel:layout-clos-hash ,wrapper ,n))
+
+(defmacro class-no-of-instance-slots (class)
+ `(wrapper-no-of-instance-slots (class-wrapper ,class)))
+
+(defmacro wrapper-class* (wrapper)
+ `(let ((wrapper ,wrapper))
+ (or (wrapper-class wrapper)
+ (find-structure-class
+ (cl:class-name (sb-kernel:layout-class wrapper))))))
+
+;;; The wrapper cache machinery provides general mechanism for trapping on the
+;;; next access to any instance of a given class. This mechanism is used to
+;;; implement the updating of instances when the class is redefined
+;;; (MAKE-INSTANCES-OBSOLETE). The same mechanism is also used to update
+;;; generic function caches when there is a change to the superclasses of a
+;;; class.
+;;;
+;;; Basically, a given wrapper can be valid or invalid. If it is invalid,
+;;; it means that any attempt to do a wrapper cache lookup using the wrapper
+;;; should trap. Also, methods on SLOT-VALUE-USING-CLASS check the wrapper
+;;; validity as well. This is done by calling CHECK-WRAPPER-VALIDITY.
+
+;;; FIXME: could become inline function
+(defmacro invalid-wrapper-p (wrapper)
+ `(neq (wrapper-state ,wrapper) 't))
+
+(defvar *previous-nwrappers* (make-hash-table))
+
+(defun invalidate-wrapper (owrapper state nwrapper)
+ (ecase state
+ ((:flush :obsolete)
+ (let ((new-previous ()))
+ ;; First off, a previous call to invalidate-wrapper may have recorded
+ ;; owrapper as an nwrapper to update to. Since owrapper is about to
+ ;; be invalid, it no longer makes sense to update to it.
+ ;;
+ ;; We go back and change the previously invalidated wrappers so that
+ ;; they will now update directly to nwrapper. This corresponds to a
+ ;; kind of transitivity of wrapper updates.
+ (dolist (previous (gethash owrapper *previous-nwrappers*))
+ (when (eq state ':obsolete)
+ (setf (car previous) ':obsolete))
+ (setf (cadr previous) nwrapper)
+ (push previous new-previous))
+
+ (let ((ocnv (wrapper-cache-number-vector owrapper)))
+ (iterate ((type (list-elements wrapper-layout))
+ (i (interval :from 0)))
+ (when (eq type 'number) (setf (cache-number-vector-ref ocnv i) 0))))
+ (push (setf (wrapper-state owrapper) (list state nwrapper))
+ new-previous)
+
+ (setf (gethash owrapper *previous-nwrappers*) ()
+ (gethash nwrapper *previous-nwrappers*) new-previous)))))
+
+(defun check-wrapper-validity (instance)
+ (let* ((owrapper (wrapper-of instance))
+ (state (wrapper-state owrapper)))
+ (if (eq state 't)
+ owrapper
+ (let ((nwrapper
+ (ecase (car state)
+ (:flush
+ (flush-cache-trap owrapper (cadr state) instance))
+ (:obsolete
+ (obsolete-instance-trap owrapper (cadr state) instance)))))
+ ;; This little bit of error checking is superfluous. It only
+ ;; checks to see whether the person who implemented the trap
+ ;; handling screwed up. Since that person is hacking internal
+ ;; PCL code, and is not a user, this should be needless. Also,
+ ;; since this directly slows down instance update and generic
+ ;; function cache refilling, feel free to take it out sometime
+ ;; soon.
+ ;;
+ ;; FIXME: We probably need to add a #+SB-PARANOID feature to make
+ ;; stuff like this optional. Until then, it stays in.
+ (cond ((neq nwrapper (wrapper-of instance))
+ (error "wrapper returned from trap not wrapper of instance"))
+ ((invalid-wrapper-p nwrapper)
+ (error "wrapper returned from trap invalid")))
+ nwrapper))))
+
+(defmacro check-wrapper-validity1 (object)
+ (let ((owrapper (gensym)))
+ `(let ((,owrapper (sb-kernel:layout-of object)))
+ (if (sb-kernel:layout-invalid ,owrapper)
+ (check-wrapper-validity ,object)
+ ,owrapper))))
+\f
+(defvar *free-caches* nil)
+
+(defun get-cache (nkeys valuep limit-fn nlines)
+ (let ((cache (or (without-interrupts (pop *free-caches*)) (make-cache))))
+ (declare (type cache cache))
+ (multiple-value-bind (cache-mask actual-size line-size nlines)
+ (compute-cache-parameters nkeys valuep nlines)
+ (setf (cache-nkeys cache) nkeys
+ (cache-valuep cache) valuep
+ (cache-nlines cache) nlines
+ (cache-field cache) (first-wrapper-cache-number-index)
+ (cache-limit-fn cache) limit-fn
+ (cache-mask cache) cache-mask
+ (cache-size cache) actual-size
+ (cache-line-size cache) line-size
+ (cache-max-location cache) (let ((line (1- nlines)))
+ (if (= nkeys 1)
+ (* line line-size)
+ (1+ (* line line-size))))
+ (cache-vector cache) (get-cache-vector actual-size)
+ (cache-overflow cache) nil)
+ cache)))
+
+(defun get-cache-from-cache (old-cache new-nlines
+ &optional (new-field (first-wrapper-cache-number-index)))
+ (let ((nkeys (cache-nkeys old-cache))
+ (valuep (cache-valuep old-cache))
+ (cache (or (without-interrupts (pop *free-caches*)) (make-cache))))
+ (declare (type cache cache))
+ (multiple-value-bind (cache-mask actual-size line-size nlines)
+ (if (= new-nlines (cache-nlines old-cache))
+ (values (cache-mask old-cache) (cache-size old-cache)
+ (cache-line-size old-cache) (cache-nlines old-cache))
+ (compute-cache-parameters nkeys valuep new-nlines))
+ (setf (cache-owner cache) (cache-owner old-cache)
+ (cache-nkeys cache) nkeys
+ (cache-valuep cache) valuep
+ (cache-nlines cache) nlines
+ (cache-field cache) new-field
+ (cache-limit-fn cache) (cache-limit-fn old-cache)
+ (cache-mask cache) cache-mask
+ (cache-size cache) actual-size
+ (cache-line-size cache) line-size
+ (cache-max-location cache) (let ((line (1- nlines)))
+ (if (= nkeys 1)
+ (* line line-size)
+ (1+ (* line line-size))))
+ (cache-vector cache) (get-cache-vector actual-size)
+ (cache-overflow cache) nil)
+ cache)))
+
+(defun copy-cache (old-cache)
+ (let* ((new-cache (copy-cache-internal old-cache))
+ (size (cache-size old-cache))
+ (old-vector (cache-vector old-cache))
+ (new-vector (get-cache-vector size)))
+ (declare (simple-vector old-vector new-vector))
+ (dotimes-fixnum (i size)
+ (setf (svref new-vector i) (svref old-vector i)))
+ (setf (cache-vector new-cache) new-vector)
+ new-cache))
+
+(defun free-cache (cache)
+ (free-cache-vector (cache-vector cache))
+ (setf (cache-vector cache) #())
+ (setf (cache-owner cache) nil)
+ (push cache *free-caches*)
+ nil)
+
+(defun compute-line-size (x)
+ (power-of-two-ceiling x))
+
+(defun compute-cache-parameters (nkeys valuep nlines-or-cache-vector)
+ ;;(declare (values cache-mask actual-size line-size nlines))
+ (declare (fixnum nkeys))
+ (if (= nkeys 1)
+ (let* ((line-size (if valuep 2 1))
+ (cache-size (if (typep nlines-or-cache-vector 'fixnum)
+ (the fixnum
+ (* line-size
+ (the fixnum
+ (power-of-two-ceiling
+ nlines-or-cache-vector))))
+ (cache-vector-size nlines-or-cache-vector))))
+ (declare (fixnum line-size cache-size))
+ (values (logxor (the fixnum (1- cache-size)) (the fixnum (1- line-size)))
+ cache-size
+ line-size
+ (the fixnum (floor cache-size line-size))))
+ (let* ((line-size (power-of-two-ceiling (if valuep (1+ nkeys) nkeys)))
+ (cache-size (if (typep nlines-or-cache-vector 'fixnum)
+ (the fixnum
+ (* line-size
+ (the fixnum
+ (power-of-two-ceiling
+ nlines-or-cache-vector))))
+ (1- (cache-vector-size nlines-or-cache-vector)))))
+ (declare (fixnum line-size cache-size))
+ (values (logxor (the fixnum (1- cache-size)) (the fixnum (1- line-size)))
+ (the fixnum (1+ cache-size))
+ line-size
+ (the fixnum (floor cache-size line-size))))))
+\f
+;;; the various implementations of computing a primary cache location from
+;;; wrappers. Because some implementations of this must run fast there are
+;;; several implementations of the same algorithm.
+;;;
+;;; The algorithm is:
+;;;
+;;; SUM over the wrapper cache numbers,
+;;; ENSURING that the result is a fixnum
+;;; MASK the result against the mask argument.
+
+;;; COMPUTE-PRIMARY-CACHE-LOCATION
+;;;
+;;; The basic functional version. This is used by the cache miss code to
+;;; compute the primary location of an entry.
+(defun compute-primary-cache-location (field mask wrappers)
+
+ (declare (type field-type field) (fixnum mask))
+ (if (not (listp wrappers))
+ (logand mask
+ (the fixnum (wrapper-cache-number-vector-ref wrappers field)))
+ (let ((location 0) (i 0))
+ (declare (fixnum location i))
+ (dolist (wrapper wrappers)
+ ;; First add the cache number of this wrapper to location.
+ (let ((wrapper-cache-number (wrapper-cache-number-vector-ref wrapper
+ field)))
+ (declare (fixnum wrapper-cache-number))
+ (if (zerop wrapper-cache-number)
+ (return-from compute-primary-cache-location 0)
+ (setq location
+ (the fixnum (+ location wrapper-cache-number)))))
+ ;; Then, if we are working with lots of wrappers, deal with
+ ;; the wrapper-cache-number-mask stuff.
+ (when (and (not (zerop i))
+ (zerop (mod i wrapper-cache-number-adds-ok)))
+ (setq location
+ (logand location wrapper-cache-number-mask)))
+ (incf i))
+ (the fixnum (1+ (logand mask location))))))
+
+;;; COMPUTE-PRIMARY-CACHE-LOCATION-FROM-LOCATION
+;;;
+;;; This version is called on a cache line. It fetches the wrappers from
+;;; the cache line and determines the primary location. Various parts of
+;;; the cache filling code call this to determine whether it is appropriate
+;;; to displace a given cache entry.
+;;;
+;;; If this comes across a wrapper whose cache-no is 0, it returns the symbol
+;;; invalid to suggest to its caller that it would be provident to blow away
+;;; the cache line in question.
+(defun compute-primary-cache-location-from-location (to-cache
+ from-location
+ &optional
+ (from-cache to-cache))
+ (declare (type cache to-cache from-cache) (fixnum from-location))
+ (let ((result 0)
+ (cache-vector (cache-vector from-cache))
+ (field (cache-field to-cache))
+ (mask (cache-mask to-cache))
+ (nkeys (cache-nkeys to-cache)))
+ (declare (type field-type field) (fixnum result mask nkeys)
+ (simple-vector cache-vector))
+ (dotimes-fixnum (i nkeys)
+ (let* ((wrapper (cache-vector-ref cache-vector (+ i from-location)))
+ (wcn (wrapper-cache-number-vector-ref wrapper field)))
+ (declare (fixnum wcn))
+ (setq result (+ result wcn)))
+ (when (and (not (zerop i))
+ (zerop (mod i wrapper-cache-number-adds-ok)))
+ (setq result (logand result wrapper-cache-number-mask))))
+ (if (= nkeys 1)
+ (logand mask result)
+ (the fixnum (1+ (logand mask result))))))
+\f
+;;; NIL means nothing so far, no actual arg info has NILs
+;;; in the metatype
+;;; CLASS seen all sorts of metaclasses
+;;; (specifically, more than one of the next 4 values)
+;;; T means everything so far is the class T
+;;; STANDARD-CLASS seen only standard classes
+;;; BUILT-IN-CLASS seen only built in classes
+;;; STRUCTURE-CLASS seen only structure classes
+(defun raise-metatype (metatype new-specializer)
+ (let ((slot (find-class 'slot-class))
+ (std (find-class 'std-class))
+ (standard (find-class 'standard-class))
+ (fsc (find-class 'funcallable-standard-class))
+ (structure (find-class 'structure-class))
+ (built-in (find-class 'built-in-class)))
+ (flet ((specializer->metatype (x)
+ (let ((meta-specializer
+ (if (eq *boot-state* 'complete)
+ (class-of (specializer-class x))
+ (class-of x))))
+ (cond ((eq x *the-class-t*) t)
+ ((*subtypep meta-specializer std)
+ 'standard-instance)
+ ((*subtypep meta-specializer standard)
+ 'standard-instance)
+ ((*subtypep meta-specializer fsc)
+ 'standard-instance)
+ ((*subtypep meta-specializer structure)
+ 'structure-instance)
+ ((*subtypep meta-specializer built-in)
+ 'built-in-instance)
+ ((*subtypep meta-specializer slot)
+ 'slot-instance)
+ (t (error "PCL cannot handle the specializer ~S (meta-specializer ~S)."
+ new-specializer
+ meta-specializer))))))
+ ;; We implement the following table. The notation is
+ ;; that X and Y are distinct meta specializer names.
+ ;;
+ ;; NIL <anything> ===> <anything>
+ ;; X X ===> X
+ ;; X Y ===> CLASS
+ (let ((new-metatype (specializer->metatype new-specializer)))
+ (cond ((eq new-metatype 'slot-instance) 'class)
+ ((null metatype) new-metatype)
+ ((eq metatype new-metatype) new-metatype)
+ (t 'class))))))
+
+(defmacro with-dfun-wrappers ((args metatypes)
+ (dfun-wrappers invalid-wrapper-p
+ &optional wrappers classes types)
+ invalid-arguments-form
+ &body body)
+ `(let* ((args-tail ,args) (,invalid-wrapper-p nil) (invalid-arguments-p nil)
+ (,dfun-wrappers nil) (dfun-wrappers-tail nil)
+ ,@(when wrappers
+ `((wrappers-rev nil) (types-rev nil) (classes-rev nil))))
+ (dolist (mt ,metatypes)
+ (unless args-tail
+ (setq invalid-arguments-p t)
+ (return nil))
+ (let* ((arg (pop args-tail))
+ (wrapper nil)
+ ,@(when wrappers
+ `((class *the-class-t*)
+ (type 't))))
+ (unless (eq mt 't)
+ (setq wrapper (wrapper-of arg))
+ (when (invalid-wrapper-p wrapper)
+ (setq ,invalid-wrapper-p t)
+ (setq wrapper (check-wrapper-validity arg)))
+ (cond ((null ,dfun-wrappers)
+ (setq ,dfun-wrappers wrapper))
+ ((not (consp ,dfun-wrappers))
+ (setq dfun-wrappers-tail (list wrapper))
+ (setq ,dfun-wrappers (cons ,dfun-wrappers dfun-wrappers-tail)))
+ (t
+ (let ((new-dfun-wrappers-tail (list wrapper)))
+ (setf (cdr dfun-wrappers-tail) new-dfun-wrappers-tail)
+ (setf dfun-wrappers-tail new-dfun-wrappers-tail))))
+ ,@(when wrappers
+ `((setq class (wrapper-class* wrapper))
+ (setq type `(class-eq ,class)))))
+ ,@(when wrappers
+ `((push wrapper wrappers-rev)
+ (push class classes-rev)
+ (push type types-rev)))))
+ (if invalid-arguments-p
+ ,invalid-arguments-form
+ (let* (,@(when wrappers
+ `((,wrappers (nreverse wrappers-rev))
+ (,classes (nreverse classes-rev))
+ (,types (mapcar #'(lambda (class)
+ `(class-eq ,class))
+ ,classes)))))
+ ,@body))))
+\f
+;;;; some support stuff for getting a hold of symbols that we need when
+;;;; building the discriminator codes. It's OK for these to be interned
+;;;; symbols because we don't capture any user code in the scope in which
+;;;; these symbols are bound.
+
+(defvar *dfun-arg-symbols* '(.ARG0. .ARG1. .ARG2. .ARG3.))
+
+(defun dfun-arg-symbol (arg-number)
+ (or (nth arg-number (the list *dfun-arg-symbols*))
+ (intern (format nil ".ARG~A." arg-number) *pcl-package*)))
+
+(defvar *slot-vector-symbols* '(.SLOTS0. .SLOTS1. .SLOTS2. .SLOTS3.))
+
+(defun slot-vector-symbol (arg-number)
+ (or (nth arg-number (the list *slot-vector-symbols*))
+ (intern (format nil ".SLOTS~A." arg-number) *pcl-package*)))
+
+(defun make-dfun-lambda-list (metatypes applyp)
+ (gathering1 (collecting)
+ (iterate ((i (interval :from 0))
+ (s (list-elements metatypes)))
+ (progn s)
+ (gather1 (dfun-arg-symbol i)))
+ (when applyp
+ (gather1 '&rest)
+ (gather1 '.dfun-rest-arg.))))
+
+(defun make-dlap-lambda-list (metatypes applyp)
+ (gathering1 (collecting)
+ (iterate ((i (interval :from 0))
+ (s (list-elements metatypes)))
+ (progn s)
+ (gather1 (dfun-arg-symbol i)))
+ (when applyp
+ (gather1 '&rest))))
+
+(defun make-emf-call (metatypes applyp fn-variable &optional emf-type)
+ (let ((required
+ (gathering1 (collecting)
+ (iterate ((i (interval :from 0))
+ (s (list-elements metatypes)))
+ (progn s)
+ (gather1 (dfun-arg-symbol i))))))
+ `(,(if (eq emf-type 'fast-method-call)
+ 'invoke-effective-method-function-fast
+ 'invoke-effective-method-function)
+ ,fn-variable ,applyp ,@required ,@(when applyp `(.dfun-rest-arg.)))))
+
+(defun make-dfun-call (metatypes applyp fn-variable)
+ (let ((required
+ (gathering1 (collecting)
+ (iterate ((i (interval :from 0))
+ (s (list-elements metatypes)))
+ (progn s)
+ (gather1 (dfun-arg-symbol i))))))
+ (if applyp
+ `(function-apply ,fn-variable ,@required .dfun-rest-arg.)
+ `(function-funcall ,fn-variable ,@required))))
+
+(defun make-dfun-arg-list (metatypes applyp)
+ (let ((required
+ (gathering1 (collecting)
+ (iterate ((i (interval :from 0))
+ (s (list-elements metatypes)))
+ (progn s)
+ (gather1 (dfun-arg-symbol i))))))
+ (if applyp
+ `(list* ,@required .dfun-rest-arg.)
+ `(list ,@required))))
+
+(defun make-fast-method-call-lambda-list (metatypes applyp)
+ (gathering1 (collecting)
+ (gather1 '.pv-cell.)
+ (gather1 '.next-method-call.)
+ (iterate ((i (interval :from 0))
+ (s (list-elements metatypes)))
+ (progn s)
+ (gather1 (dfun-arg-symbol i)))
+ (when applyp
+ (gather1 '.dfun-rest-arg.))))
+\f
+;;;; a comment from some PCL implementor:
+;;;; Its too bad Common Lisp compilers freak out when you have a
+;;;; DEFUN with a lot of LABELS in it. If I could do that I could
+;;;; make this code much easier to read and work with.
+;;;; Ahh Scheme...
+;;;; In the absence of that, the following little macro makes the
+;;;; code that follows a little bit more reasonable. I would like to
+;;;; add that having to practically write my own compiler in order to
+;;;; get just this simple thing is something of a drag.
+;;;;
+;;;; KLUDGE: Maybe we could actually implement this as LABELS now, since AFAIK
+;;;; CMU CL doesn't freak out when you have a defun with a lot of LABELS in it
+;;;; (and if it does we can fix it instead of working around it). -- WHN
+;;;; 19991204
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+
+(defvar *cache* nil)
+
+;;; FIXME:
+;;; (1) shouldn't be DEFCONSTANT, since it's not an EQL thing
+;;; (2) should be undefined after bootstrapping
+(defconstant *local-cache-functions*
+ '((cache () .cache.)
+ (nkeys () (cache-nkeys .cache.))
+ (line-size () (cache-line-size .cache.))
+ (vector () (cache-vector .cache.))
+ (valuep () (cache-valuep .cache.))
+ (nlines () (cache-nlines .cache.))
+ (max-location () (cache-max-location .cache.))
+ (limit-fn () (cache-limit-fn .cache.))
+ (size () (cache-size .cache.))
+ (mask () (cache-mask .cache.))
+ (field () (cache-field .cache.))
+ (overflow () (cache-overflow .cache.))
+
+ ;; Return T IFF this cache location is reserved. The only time
+ ;; this is true is for line number 0 of an nkeys=1 cache.
+ (line-reserved-p (line)
+ (declare (fixnum line))
+ (and (= (nkeys) 1)
+ (= line 0)))
+ (location-reserved-p (location)
+ (declare (fixnum location))
+ (and (= (nkeys) 1)
+ (= location 0)))
+ ;; Given a line number, return the cache location. This is the
+ ;; value that is the second argument to cache-vector-ref. Basically,
+ ;; this deals with the offset of nkeys>1 caches and multiplies
+ ;; by line size.
+ (line-location (line)
+ (declare (fixnum line))
+ (when (line-reserved-p line)
+ (error "Line is reserved."))
+ (if (= (nkeys) 1)
+ (the fixnum (* line (line-size)))
+ (the fixnum (1+ (the fixnum (* line (line-size)))))))
+
+ ;; Given a cache location, return the line. This is the inverse
+ ;; of LINE-LOCATION.
+ (location-line (location)
+ (declare (fixnum location))
+ (if (= (nkeys) 1)
+ (floor location (line-size))
+ (floor (the fixnum (1- location)) (line-size))))
+
+ ;; Given a line number, return the wrappers stored at that line.
+ ;; As usual, if nkeys=1, this returns a single value. Only when
+ ;; nkeys>1 does it return a list. An error is signalled if the
+ ;; line is reserved.
+ (line-wrappers (line)
+ (declare (fixnum line))
+ (when (line-reserved-p line) (error "Line is reserved."))
+ (location-wrappers (line-location line)))
+ (location-wrappers (location) ; avoid multiplies caused by line-location
+ (declare (fixnum location))
+ (if (= (nkeys) 1)
+ (cache-vector-ref (vector) location)
+ (let ((list (make-list (nkeys)))
+ (vector (vector)))
+ (declare (simple-vector vector))
+ (dotimes-fixnum (i (nkeys) list)
+ (setf (nth i list) (cache-vector-ref vector (+ location i)))))))
+
+ ;; Given a line number, return true IFF the line's
+ ;; wrappers are the same as wrappers.
+ (line-matches-wrappers-p (line wrappers)
+ (declare (fixnum line))
+ (and (not (line-reserved-p line))
+ (location-matches-wrappers-p (line-location line) wrappers)))
+ (location-matches-wrappers-p (loc wrappers) ; must not be reserved
+ (declare (fixnum loc))
+ (let ((cache-vector (vector)))
+ (declare (simple-vector cache-vector))
+ (if (= (nkeys) 1)
+ (eq wrappers (cache-vector-ref cache-vector loc))
+ (dotimes-fixnum (i (nkeys) t)
+ (unless (eq (pop wrappers)
+ (cache-vector-ref cache-vector (+ loc i)))
+ (return nil))))))
+
+ ;; Given a line number, return the value stored at that line.
+ ;; If valuep is NIL, this returns NIL. As with line-wrappers,
+ ;; an error is signalled if the line is reserved.
+ (line-value (line)
+ (declare (fixnum line))
+ (when (line-reserved-p line) (error "Line is reserved."))
+ (location-value (line-location line)))
+ (location-value (loc)
+ (declare (fixnum loc))
+ (and (valuep)
+ (cache-vector-ref (vector) (+ loc (nkeys)))))
+
+ ;; Given a line number, return true iff that line has data in
+ ;; it. The state of the wrappers stored in the line is not
+ ;; checked. An error is signalled if line is reserved.
+ (line-full-p (line)
+ (when (line-reserved-p line) (error "Line is reserved."))
+ (not (null (cache-vector-ref (vector) (line-location line)))))
+
+ ;; Given a line number, return true iff the line is full and
+ ;; there are no invalid wrappers in the line, and the line's
+ ;; wrappers are different from wrappers.
+ ;; An error is signalled if the line is reserved.
+ (line-valid-p (line wrappers)
+ (declare (fixnum line))
+ (when (line-reserved-p line) (error "Line is reserved."))
+ (location-valid-p (line-location line) wrappers))
+ (location-valid-p (loc wrappers)
+ (declare (fixnum loc))
+ (let ((cache-vector (vector))
+ (wrappers-mismatch-p (null wrappers)))
+ (declare (simple-vector cache-vector))
+ (dotimes-fixnum (i (nkeys) wrappers-mismatch-p)
+ (let ((wrapper (cache-vector-ref cache-vector (+ loc i))))
+ (when (or (null wrapper)
+ (invalid-wrapper-p wrapper))
+ (return nil))
+ (unless (and wrappers
+ (eq wrapper
+ (if (consp wrappers) (pop wrappers) wrappers)))
+ (setq wrappers-mismatch-p t))))))
+
+ ;; how many unreserved lines separate line-1 and line-2
+ (line-separation (line-1 line-2)
+ (declare (fixnum line-1 line-2))
+ (let ((diff (the fixnum (- line-2 line-1))))
+ (declare (fixnum diff))
+ (when (minusp diff)
+ (setq diff (+ diff (nlines)))
+ (when (line-reserved-p 0)
+ (setq diff (1- diff))))
+ diff))
+
+ ;; Given a cache line, get the next cache line. This will not
+ ;; return a reserved line.
+ (next-line (line)
+ (declare (fixnum line))
+ (if (= line (the fixnum (1- (nlines))))
+ (if (line-reserved-p 0) 1 0)
+ (the fixnum (1+ line))))
+ (next-location (loc)
+ (declare (fixnum loc))
+ (if (= loc (max-location))
+ (if (= (nkeys) 1)
+ (line-size)
+ 1)
+ (the fixnum (+ loc (line-size)))))
+
+ ;; Given a line which has a valid entry in it, this will return
+ ;; the primary cache line of the wrappers in that line. We just
+ ;; call COMPUTE-PRIMARY-CACHE-LOCATION-FROM-LOCATION, this is an
+ ;; easier packaging up of the call to it.
+ (line-primary (line)
+ (declare (fixnum line))
+ (location-line (line-primary-location line)))
+ (line-primary-location (line)
+ (declare (fixnum line))
+ (compute-primary-cache-location-from-location
+ (cache) (line-location line)))))
+
+(defmacro with-local-cache-functions ((cache) &body body)
+ `(let ((.cache. ,cache))
+ (declare (type cache .cache.))
+ (macrolet ,(mapcar #'(lambda (fn)
+ `(,(car fn) ,(cadr fn)
+ `(let (,,@(mapcar #'(lambda (var)
+ ``(,',var ,,var))
+ (cadr fn)))
+ ,@',(cddr fn))))
+ *local-cache-functions*)
+ ,@body)))
+
+) ; EVAL-WHEN
+\f
+;;; Here is where we actually fill, recache and expand caches.
+;;;
+;;; The functions FILL-CACHE and PROBE-CACHE are the ONLY external
+;;; entrypoints into this code.
+;;;
+;;; FILL-CACHE returns 1 value: a new cache
+;;;
+;;; a wrapper field number
+;;; a cache
+;;; a mask
+;;; an absolute cache size (the size of the actual vector)
+;;; It tries to re-adjust the cache every time it makes a new fill. The
+;;; intuition here is that we want uniformity in the number of probes needed to
+;;; find an entry. Furthermore, adjusting has the nice property of throwing out
+;;; any entries that are invalid.
+(defvar *cache-expand-threshold* 1.25)
+
+(defun fill-cache (cache wrappers value &optional free-cache-p)
+
+ ;; FILL-CACHE won't return if WRAPPERS is nil, might as well check..
+ (unless wrappers
+ (error "fill-cache: WRAPPERS arg is NIL!"))
+
+ (or (fill-cache-p nil cache wrappers value)
+ (and (< (ceiling (* (cache-count cache) 1.25))
+ (if (= (cache-nkeys cache) 1)
+ (1- (cache-nlines cache))
+ (cache-nlines cache)))
+ (adjust-cache cache wrappers value free-cache-p))
+ (expand-cache cache wrappers value free-cache-p)))
+
+(defvar *check-cache-p* nil)
+
+(defmacro maybe-check-cache (cache)
+ `(progn
+ (when *check-cache-p*
+ (check-cache ,cache))
+ ,cache))
+
+(defun check-cache (cache)
+ (with-local-cache-functions (cache)
+ (let ((location (if (= (nkeys) 1) 0 1))
+ (limit (funcall (limit-fn) (nlines))))
+ (dotimes-fixnum (i (nlines) cache)
+ (when (and (not (location-reserved-p location))
+ (line-full-p i))
+ (let* ((home-loc (compute-primary-cache-location-from-location
+ cache location))
+ (home (location-line (if (location-reserved-p home-loc)
+ (next-location home-loc)
+ home-loc)))
+ (sep (when home (line-separation home i))))
+ (when (and sep (> sep limit))
+ (error "bad cache ~S ~@
+ value at location ~D: ~D lines from its home. The limit is ~D."
+ cache location sep limit))))
+ (setq location (next-location location))))))
+
+(defun probe-cache (cache wrappers &optional default limit-fn)
+ ;;(declare (values value))
+ (unless wrappers
+ ;; FIXME: This and another earlier test on a WRAPPERS arg can
+ ;; be compact assertoids.
+ (error "WRAPPERS arg is NIL!"))
+ (with-local-cache-functions (cache)
+ (let* ((location (compute-primary-cache-location (field) (mask) wrappers))
+ (limit (funcall (or limit-fn (limit-fn)) (nlines))))
+ (declare (fixnum location limit))
+ (when (location-reserved-p location)
+ (setq location (next-location location)))
+ (dotimes-fixnum (i (1+ limit))
+ (when (location-matches-wrappers-p location wrappers)
+ (return-from probe-cache (or (not (valuep))
+ (location-value location))))
+ (setq location (next-location location)))
+ (dolist (entry (overflow))
+ (when (equal (car entry) wrappers)
+ (return-from probe-cache (or (not (valuep))
+ (cdr entry)))))
+ default)))
+
+(defun map-cache (function cache &optional set-p)
+ (with-local-cache-functions (cache)
+ (let ((set-p (and set-p (valuep))))
+ (dotimes-fixnum (i (nlines) cache)
+ (unless (or (line-reserved-p i) (not (line-valid-p i nil)))
+ (let ((value (funcall function (line-wrappers i) (line-value i))))
+ (when set-p
+ (setf (cache-vector-ref (vector) (+ (line-location i) (nkeys)))
+ value)))))
+ (dolist (entry (overflow))
+ (let ((value (funcall function (car entry) (cdr entry))))
+ (when set-p
+ (setf (cdr entry) value))))))
+ cache)
+
+(defun cache-count (cache)
+ (with-local-cache-functions (cache)
+ (let ((count 0))
+ (declare (fixnum count))
+ (dotimes-fixnum (i (nlines) count)
+ (unless (line-reserved-p i)
+ (when (line-full-p i)
+ (incf count)))))))
+
+(defun entry-in-cache-p (cache wrappers value)
+ (declare (ignore value))
+ (with-local-cache-functions (cache)
+ (dotimes-fixnum (i (nlines))
+ (unless (line-reserved-p i)
+ (when (equal (line-wrappers i) wrappers)
+ (return t))))))
+
+;;; returns T or NIL
+(defun fill-cache-p (forcep cache wrappers value)
+ (with-local-cache-functions (cache)
+ (let* ((location (compute-primary-cache-location (field) (mask) wrappers))
+ (primary (location-line location)))
+ (declare (fixnum location primary))
+ (multiple-value-bind (free emptyp)
+ (find-free-cache-line primary cache wrappers)
+ (when (or forcep emptyp)
+ (when (not emptyp)
+ (push (cons (line-wrappers free) (line-value free))
+ (cache-overflow cache)))
+ ;;(fill-line free wrappers value)
+ (let ((line free))
+ (declare (fixnum line))
+ (when (line-reserved-p line)
+ (error "attempt to fill a reserved line"))
+ (let ((loc (line-location line))
+ (cache-vector (vector)))
+ (declare (fixnum loc) (simple-vector cache-vector))
+ (cond ((= (nkeys) 1)
+ (setf (cache-vector-ref cache-vector loc) wrappers)
+ (when (valuep)
+ (setf (cache-vector-ref cache-vector (1+ loc)) value)))
+ (t
+ (let ((i 0))
+ (declare (fixnum i))
+ (dolist (w wrappers)
+ (setf (cache-vector-ref cache-vector (+ loc i)) w)
+ (setq i (the fixnum (1+ i)))))
+ (when (valuep)
+ (setf (cache-vector-ref cache-vector (+ loc (nkeys)))
+ value))))
+ (maybe-check-cache cache))))))))
+
+(defun fill-cache-from-cache-p (forcep cache from-cache from-line)
+ (declare (fixnum from-line))
+ (with-local-cache-functions (cache)
+ (let ((primary (location-line
+ (compute-primary-cache-location-from-location
+ cache (line-location from-line) from-cache))))
+ (declare (fixnum primary))
+ (multiple-value-bind (free emptyp)
+ (find-free-cache-line primary cache)
+ (when (or forcep emptyp)
+ (when (not emptyp)
+ (push (cons (line-wrappers free) (line-value free))
+ (cache-overflow cache)))
+ ;;(transfer-line from-cache-vector from-line cache-vector free)
+ (let ((from-cache-vector (cache-vector from-cache))
+ (to-cache-vector (vector))
+ (to-line free))
+ (declare (fixnum to-line))
+ (if (line-reserved-p to-line)
+ (error "transferring something into a reserved cache line")
+ (let ((from-loc (line-location from-line))
+ (to-loc (line-location to-line)))
+ (declare (fixnum from-loc to-loc))
+ (modify-cache to-cache-vector
+ (dotimes-fixnum (i (line-size))
+ (setf (cache-vector-ref to-cache-vector
+ (+ to-loc i))
+ (cache-vector-ref from-cache-vector
+ (+ from-loc i)))))))
+ (maybe-check-cache cache)))))))
+
+;;; Returns NIL or (values <field> <cache-vector>)
+;;;
+;;; This is only called when it isn't possible to put the entry in the cache
+;;; the easy way. That is, this function assumes that FILL-CACHE-P has been
+;;; called as returned NIL.
+;;;
+;;; If this returns NIL, it means that it wasn't possible to find a wrapper
+;;; field for which all of the entries could be put in the cache (within the
+;;; limit).
+(defun adjust-cache (cache wrappers value free-old-cache-p)
+ (with-local-cache-functions (cache)
+ (let ((ncache (get-cache-from-cache cache (nlines) (field))))
+ (do ((nfield (cache-field ncache) (next-wrapper-cache-number-index nfield)))
+ ((null nfield) (free-cache ncache) nil)
+ (setf (cache-field ncache) nfield)
+ (labels ((try-one-fill-from-line (line)
+ (fill-cache-from-cache-p nil ncache cache line))
+ (try-one-fill (wrappers value)
+ (fill-cache-p nil ncache wrappers value)))
+ (if (and (dotimes-fixnum (i (nlines) t)
+ (when (and (null (line-reserved-p i))
+ (line-valid-p i wrappers))
+ (unless (try-one-fill-from-line i) (return nil))))
+ (dolist (wrappers+value (cache-overflow cache) t)
+ (unless (try-one-fill (car wrappers+value) (cdr wrappers+value))
+ (return nil)))
+ (try-one-fill wrappers value))
+ (progn (when free-old-cache-p (free-cache cache))
+ (return (maybe-check-cache ncache)))
+ (flush-cache-vector-internal (cache-vector ncache))))))))
+
+;;; returns: (values <cache>)
+(defun expand-cache (cache wrappers value free-old-cache-p)
+ ;;(declare (values cache))
+ (with-local-cache-functions (cache)
+ (let ((ncache (get-cache-from-cache cache (* (nlines) 2))))
+ (labels ((do-one-fill-from-line (line)
+ (unless (fill-cache-from-cache-p nil ncache cache line)
+ (do-one-fill (line-wrappers line) (line-value line))))
+ (do-one-fill (wrappers value)
+ (setq ncache (or (adjust-cache ncache wrappers value t)
+ (fill-cache-p t ncache wrappers value))))
+ (try-one-fill (wrappers value)
+ (fill-cache-p nil ncache wrappers value)))
+ (dotimes-fixnum (i (nlines))
+ (when (and (null (line-reserved-p i))
+ (line-valid-p i wrappers))
+ (do-one-fill-from-line i)))
+ (dolist (wrappers+value (cache-overflow cache))
+ (unless (try-one-fill (car wrappers+value) (cdr wrappers+value))
+ (do-one-fill (car wrappers+value) (cdr wrappers+value))))
+ (unless (try-one-fill wrappers value)
+ (do-one-fill wrappers value))
+ (when free-old-cache-p (free-cache cache))
+ (maybe-check-cache ncache)))))
+\f
+;;; This is the heart of the cache filling mechanism. It implements the
+;;; decisions about where entries are placed.
+;;;
+;;; Find a line in the cache at which a new entry can be inserted.
+;;;
+;;; <line>
+;;; <empty?> is <line> in fact empty?
+(defun find-free-cache-line (primary cache &optional wrappers)
+ ;;(declare (values line empty?))
+ (declare (fixnum primary))
+ (with-local-cache-functions (cache)
+ (when (line-reserved-p primary) (setq primary (next-line primary)))
+ (let ((limit (funcall (limit-fn) (nlines)))
+ (wrappedp nil)
+ (lines nil)
+ (p primary) (s primary))
+ (declare (fixnum p s limit))
+ (block find-free
+ (loop
+ ;; Try to find a free line starting at <s>. <p> is the
+ ;; primary line of the entry we are finding a free
+ ;; line for, it is used to compute the separations.
+ (do* ((line s (next-line line))
+ (nsep (line-separation p s) (1+ nsep)))
+ (())
+ (declare (fixnum line nsep))
+ (when (null (line-valid-p line wrappers)) ;If this line is empty or
+ (push line lines) ;invalid, just use it.
+ (return-from find-free))
+ (when (and wrappedp (>= line primary))
+ ;; have gone all the way around the cache, time to quit
+ (return-from find-free-cache-line (values primary nil)))
+ (let ((osep (line-separation (line-primary line) line)))
+ (when (>= osep limit)
+ (return-from find-free-cache-line (values primary nil)))
+ (when (cond ((= nsep limit) t)
+ ((= nsep osep) (zerop (random 2)))
+ ((> nsep osep) t)
+ (t nil))
+ ;; See whether we can displace what is in this line so that we
+ ;; can use the line.
+ (when (= line (the fixnum (1- (nlines)))) (setq wrappedp t))
+ (setq p (line-primary line))
+ (setq s (next-line line))
+ (push line lines)
+ (return nil)))
+ (when (= line (the fixnum (1- (nlines)))) (setq wrappedp t)))))
+ ;; Do all the displacing.
+ (loop
+ (when (null (cdr lines)) (return nil))
+ (let ((dline (pop lines))
+ (line (car lines)))
+ (declare (fixnum dline line))
+ ;;Copy from line to dline (dline is known to be free).
+ (let ((from-loc (line-location line))
+ (to-loc (line-location dline))
+ (cache-vector (vector)))
+ (declare (fixnum from-loc to-loc) (simple-vector cache-vector))
+ (modify-cache cache-vector
+ (dotimes-fixnum (i (line-size))
+ (setf (cache-vector-ref cache-vector
+ (+ to-loc i))
+ (cache-vector-ref cache-vector
+ (+ from-loc i)))
+ (setf (cache-vector-ref cache-vector
+ (+ from-loc i))
+ nil))))))
+ (values (car lines) t))))
+
+(defun default-limit-fn (nlines)
+ (case nlines
+ ((1 2 4) 1)
+ ((8 16) 4)
+ (otherwise 6)))
+
+(defvar *empty-cache* (make-cache)) ; for defstruct slot initial value forms
+\f
+;;; Pre-allocate generic function caches. The hope is that this will put
+;;; them nicely together in memory, and that that may be a win. Of course
+;;; the first gc copy will probably blow that out, this really wants to be
+;;; wrapped in something that declares the area static.
+;;;
+;;; This preallocation only creates about 25% more caches than PCL itself
+;;; uses. Some ports may want to preallocate some more of these.
+;;;
+;;; KLUDGE: Isn't something very similar going on in precom1.lisp? Do we need
+;;; it both here and there? Why? -- WHN 19991203
+(eval-when (:load-toplevel)
+ (dolist (n-size '((1 513)(3 257)(3 129)(14 128)(6 65)(2 64)(7 33)(16 32)
+ (16 17)(32 16)(64 9)(64 8)(6 5)(128 4)(35 2)))
+ (let ((n (car n-size))
+ (size (cadr n-size)))
+ (mapcar #'free-cache-vector
+ (mapcar #'get-cache-vector
+ (make-list n :initial-element size))))))
+
+(defun caches-to-allocate ()
+ (sort (let ((l nil))
+ (maphash #'(lambda (size entry)
+ (push (list (car entry) size) l))
+ sb-pcl::*free-caches*)
+ l)
+ #'>
+ :key #'cadr))
--- /dev/null
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+
+;;;; This software is derived from software originally released by Xerox
+;;;; Corporation. Copyright and release statements follow. Later modifications
+;;;; to the software are in the public domain and are provided with
+;;;; absolutely no warranty. See the COPYING and CREDITS files for more
+;;;; information.
+
+;;;; copyright information from original PCL sources:
+;;;;
+;;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
+;;;; All rights reserved.
+;;;;
+;;;; Use and copying of this software and preparation of derivative works based
+;;;; upon this software are permitted. Any distribution of this software or
+;;;; derivative works must comply with all applicable United States export
+;;;; control laws.
+;;;;
+;;;; This software is made available AS IS, and Xerox Corporation makes no
+;;;; warranty about the software, its performance or its conformity to any
+;;;; specification.
+
+(in-package "SB-PCL")
+
+(sb-int:file-comment
+ "$Header$")
+\f
+(defun get-method-function (method &optional method-alist wrappers)
+ (let ((fn (cadr (assoc method method-alist))))
+ (if fn
+ (values fn nil nil nil)
+ (multiple-value-bind (mf fmf)
+ (if (listp method)
+ (early-method-function method)
+ (values nil (method-fast-function method)))
+ (let* ((pv-table (and fmf (method-function-pv-table fmf))))
+ (if (and fmf (or (null pv-table) wrappers))
+ (let* ((pv-wrappers (when pv-table
+ (pv-wrappers-from-all-wrappers
+ pv-table wrappers)))
+ (pv-cell (when (and pv-table pv-wrappers)
+ (pv-table-lookup pv-table pv-wrappers))))
+ (values mf t fmf pv-cell))
+ (values
+ (or mf (if (listp method)
+ (setf (cadr method)
+ (method-function-from-fast-function fmf))
+ (method-function method)))
+ t nil nil)))))))
+
+(defun make-effective-method-function (generic-function form &optional
+ method-alist wrappers)
+ (funcall (make-effective-method-function1 generic-function form
+ (not (null method-alist))
+ (not (null wrappers)))
+ method-alist wrappers))
+
+(defun make-effective-method-function1 (generic-function form
+ method-alist-p wrappers-p)
+ (if (and (listp form)
+ (eq (car form) 'call-method))
+ (make-effective-method-function-simple generic-function form)
+ ;; We have some sort of `real' effective method. Go off and get a
+ ;; compiled function for it. Most of the real hair here is done by
+ ;; the GET-FUNCTION mechanism.
+ (make-effective-method-function-internal generic-function form
+ method-alist-p wrappers-p)))
+
+(defun make-effective-method-function-type (generic-function form
+ method-alist-p wrappers-p)
+ (if (and (listp form)
+ (eq (car form) 'call-method))
+ (let* ((cm-args (cdr form))
+ (method (car cm-args)))
+ (when method
+ (if (if (listp method)
+ (eq (car method) ':early-method)
+ (method-p method))
+ (if method-alist-p
+ 't
+ (multiple-value-bind (mf fmf)
+ (if (listp method)
+ (early-method-function method)
+ (values nil (method-fast-function method)))
+ (declare (ignore mf))
+ (let* ((pv-table (and fmf (method-function-pv-table fmf))))
+ (if (and fmf (or (null pv-table) wrappers-p))
+ 'fast-method-call
+ 'method-call))))
+ (if (and (consp method) (eq (car method) 'make-method))
+ (make-effective-method-function-type
+ generic-function (cadr method) method-alist-p wrappers-p)
+ (type-of method)))))
+ 'fast-method-call))
+
+(defun make-effective-method-function-simple
+ (generic-function form &optional no-fmf-p)
+ ;; The effective method is just a call to call-method. This opens up
+ ;; the possibility of just using the method function of the method as
+ ;; the effective method function.
+ ;;
+ ;; But we have to be careful. If that method function will ask for
+ ;; the next methods we have to provide them. We do not look to see
+ ;; if there are next methods, we look at whether the method function
+ ;; asks about them. If it does, we must tell it whether there are
+ ;; or aren't to prevent the leaky next methods bug.
+ (let* ((cm-args (cdr form))
+ (fmf-p (and (null no-fmf-p)
+ (or (not (eq *boot-state* 'complete))
+ (gf-fast-method-function-p generic-function))
+ (null (cddr cm-args))))
+ (method (car cm-args))
+ (cm-args1 (cdr cm-args)))
+ #'(lambda (method-alist wrappers)
+ (make-effective-method-function-simple1 generic-function method cm-args1 fmf-p
+ method-alist wrappers))))
+
+(defun make-emf-from-method
+ (method cm-args &optional gf fmf-p method-alist wrappers)
+ (multiple-value-bind (mf real-mf-p fmf pv-cell)
+ (get-method-function method method-alist wrappers)
+ (if fmf
+ (let* ((next-methods (car cm-args))
+ (next (make-effective-method-function-simple1
+ gf (car next-methods)
+ (list* (cdr next-methods) (cdr cm-args))
+ fmf-p method-alist wrappers))
+ (arg-info (method-function-get fmf ':arg-info)))
+ (make-fast-method-call :function fmf
+ :pv-cell pv-cell
+ :next-method-call next
+ :arg-info arg-info))
+ (if real-mf-p
+ (make-method-call :function mf
+ :call-method-args cm-args)
+ mf))))
+
+(defun make-effective-method-function-simple1
+ (gf method cm-args fmf-p &optional method-alist wrappers)
+ (when method
+ (if (if (listp method)
+ (eq (car method) ':early-method)
+ (method-p method))
+ (make-emf-from-method method cm-args gf fmf-p method-alist wrappers)
+ (if (and (consp method) (eq (car method) 'make-method))
+ (make-effective-method-function gf
+ (cadr method)
+ method-alist wrappers)
+ method))))
+
+(defvar *global-effective-method-gensyms* ())
+(defvar *rebound-effective-method-gensyms*)
+
+(defun get-effective-method-gensym ()
+ (or (pop *rebound-effective-method-gensyms*)
+ (let ((new (intern (format nil
+ "EFFECTIVE-METHOD-GENSYM-~D"
+ (length *global-effective-method-gensyms*))
+ *pcl-package*)))
+ (setq *global-effective-method-gensyms*
+ (append *global-effective-method-gensyms* (list new)))
+ new)))
+
+(let ((*rebound-effective-method-gensyms* ()))
+ (dotimes-fixnum (i 10) (get-effective-method-gensym)))
+
+(defun expand-effective-method-function (gf effective-method &optional env)
+ (declare (ignore env))
+ (multiple-value-bind (nreq applyp metatypes nkeys arg-info)
+ (get-generic-function-info gf)
+ (declare (ignore nreq nkeys arg-info))
+ (let ((ll (make-fast-method-call-lambda-list metatypes applyp))
+ ;; When there are no primary methods and a next-method call occurs
+ ;; effective-method is (error "No mumble..") and the defined
+ ;; args are not used giving a compiler warning.
+ (error-p (eq (first effective-method) 'error)))
+ `(lambda ,ll
+ (declare (ignore ,@(if error-p ll '(.pv-cell. .next-method-call.))))
+ ,effective-method))))
+
+(defun expand-emf-call-method (gf form metatypes applyp env)
+ (declare (ignore gf metatypes applyp env))
+ `(call-method ,(cdr form)))
+
+(defmacro call-method (&rest args)
+ (declare (ignore args))
+ `(error "~S outside of a effective method form" 'call-method))
+
+(defun memf-test-converter (form generic-function method-alist-p wrappers-p)
+ (cond ((and (consp form) (eq (car form) 'call-method))
+ (case (make-effective-method-function-type
+ generic-function form method-alist-p wrappers-p)
+ (fast-method-call
+ '.fast-call-method.)
+ (t
+ '.call-method.)))
+ ((and (consp form) (eq (car form) 'call-method-list))
+ (case (if (every #'(lambda (form)
+ (eq 'fast-method-call
+ (make-effective-method-function-type
+ generic-function form
+ method-alist-p wrappers-p)))
+ (cdr form))
+ 'fast-method-call
+ 't)
+ (fast-method-call
+ '.fast-call-method-list.)
+ (t
+ '.call-method-list.)))
+ (t
+ (default-test-converter form))))
+
+(defun memf-code-converter
+ (form generic-function metatypes applyp method-alist-p wrappers-p)
+ (cond ((and (consp form) (eq (car form) 'call-method))
+ (let ((gensym (get-effective-method-gensym)))
+ (values (make-emf-call metatypes applyp gensym
+ (make-effective-method-function-type
+ generic-function form method-alist-p wrappers-p))
+ (list gensym))))
+ ((and (consp form) (eq (car form) 'call-method-list))
+ (let ((gensym (get-effective-method-gensym))
+ (type (if (every #'(lambda (form)
+ (eq 'fast-method-call
+ (make-effective-method-function-type
+ generic-function form
+ method-alist-p wrappers-p)))
+ (cdr form))
+ 'fast-method-call
+ 't)))
+ (values `(dolist (emf ,gensym nil)
+ ,(make-emf-call metatypes applyp 'emf type))
+ (list gensym))))
+ (t
+ (default-code-converter form))))
+
+(defun memf-constant-converter (form generic-function)
+ (cond ((and (consp form) (eq (car form) 'call-method))
+ (list (cons '.meth.
+ (make-effective-method-function-simple
+ generic-function form))))
+ ((and (consp form) (eq (car form) 'call-method-list))
+ (list (cons '.meth-list.
+ (mapcar #'(lambda (form)
+ (make-effective-method-function-simple
+ generic-function form))
+ (cdr form)))))
+ (t
+ (default-constant-converter form))))
+
+(defun make-effective-method-function-internal
+ (generic-function effective-method method-alist-p wrappers-p)
+ (multiple-value-bind (nreq applyp metatypes nkeys arg-info)
+ (get-generic-function-info generic-function)
+ (declare (ignore nkeys arg-info))
+ (let* ((*rebound-effective-method-gensyms*
+ *global-effective-method-gensyms*)
+ (name (if (early-gf-p generic-function)
+ (early-gf-name generic-function)
+ (generic-function-name generic-function)))
+ (arg-info (cons nreq applyp))
+ (effective-method-lambda (expand-effective-method-function
+ generic-function effective-method)))
+ (multiple-value-bind (cfunction constants)
+ (get-function1 effective-method-lambda
+ #'(lambda (form)
+ (memf-test-converter form generic-function
+ method-alist-p wrappers-p))
+ #'(lambda (form)
+ (memf-code-converter form generic-function
+ metatypes applyp
+ method-alist-p wrappers-p))
+ #'(lambda (form)
+ (memf-constant-converter form generic-function)))
+ #'(lambda (method-alist wrappers)
+ (let* ((constants
+ (mapcar #'(lambda (constant)
+ (if (consp constant)
+ (case (car constant)
+ (.meth.
+ (funcall (cdr constant)
+ method-alist wrappers))
+ (.meth-list.
+ (mapcar #'(lambda (fn)
+ (funcall fn
+ method-alist
+ wrappers))
+ (cdr constant)))
+ (t constant))
+ constant))
+ constants))
+ (function (set-function-name
+ (apply cfunction constants)
+ `(combined-method ,name))))
+ (make-fast-method-call :function function
+ :arg-info arg-info)))))))
+
+(defmacro call-method-list (&rest calls)
+ `(progn ,@calls))
+
+(defun make-call-methods (methods)
+ `(call-method-list
+ ,@(mapcar #'(lambda (method) `(call-method ,method ())) methods)))
+
+(defun standard-compute-effective-method (generic-function combin applicable-methods)
+ (declare (ignore combin))
+ (let ((before ())
+ (primary ())
+ (after ())
+ (around ()))
+ (dolist (m applicable-methods)
+ (let ((qualifiers (if (listp m)
+ (early-method-qualifiers m)
+ (method-qualifiers m))))
+ (cond ((member ':before qualifiers) (push m before))
+ ((member ':after qualifiers) (push m after))
+ ((member ':around qualifiers) (push m around))
+ (t
+ (push m primary)))))
+ (setq before (reverse before)
+ after (reverse after)
+ primary (reverse primary)
+ around (reverse around))
+ (cond ((null primary)
+ `(error "There is no primary method for the generic function ~S."
+ ',generic-function))
+ ((and (null before) (null after) (null around))
+ ;; By returning a single call-method `form' here we enable an
+ ;; important implementation-specific optimization.
+ `(call-method ,(first primary) ,(rest primary)))
+ (t
+ (let ((main-effective-method
+ (if (or before after)
+ `(multiple-value-prog1
+ (progn ,(make-call-methods before)
+ (call-method ,(first primary)
+ ,(rest primary)))
+ ,(make-call-methods (reverse after)))
+ `(call-method ,(first primary) ,(rest primary)))))
+ (if around
+ `(call-method ,(first around)
+ (,@(rest around)
+ (make-method ,main-effective-method)))
+ main-effective-method))))))
+\f
+;;;; the STANDARD method combination type. This is coded by hand (rather than
+;;;; with define-method-combination) for bootstrapping and efficiency reasons.
+;;;; Note that the definition of the find-method-combination-method appears in
+;;;; the file defcombin.lisp. This is because EQL methods can't appear in the
+;;;; bootstrap.
+;;;;
+;;;; The defclass for the METHOD-COMBINATION and STANDARD-METHOD-COMBINATION
+;;;; classes has to appear here for this reason. This code must conform to
+;;;; the code in the file defcombin.lisp, look there for more details.
+
+(defun compute-effective-method (generic-function combin applicable-methods)
+ (standard-compute-effective-method generic-function
+ combin
+ applicable-methods))
+
+(defvar *invalid-method-error*
+ #'(lambda (&rest args)
+ (declare (ignore args))
+ (error
+ "INVALID-METHOD-ERROR was called outside the dynamic scope~%~
+ of a method combination function (inside the body of~%~
+ DEFINE-METHOD-COMBINATION or a method on the generic~%~
+ function COMPUTE-EFFECTIVE-METHOD).")))
+
+(defvar *method-combination-error*
+ #'(lambda (&rest args)
+ (declare (ignore args))
+ (error
+ "METHOD-COMBINATION-ERROR was called outside the dynamic scope~%~
+ of a method combination function (inside the body of~%~
+ DEFINE-METHOD-COMBINATION or a method on the generic~%~
+ function COMPUTE-EFFECTIVE-METHOD).")))
+
+;(defmethod compute-effective-method :around ;issue with magic
+; ((generic-function generic-function) ;generic functions
+; (method-combination method-combination)
+; applicable-methods)
+; (declare (ignore applicable-methods))
+; (flet ((real-invalid-method-error (method format-string &rest args)
+; (declare (ignore method))
+; (apply #'error format-string args))
+; (real-method-combination-error (format-string &rest args)
+; (apply #'error format-string args)))
+; (let ((*invalid-method-error* #'real-invalid-method-error)
+; (*method-combination-error* #'real-method-combination-error))
+; (call-next-method))))
+
+(defun invalid-method-error (&rest args)
+ (declare (arglist method format-string &rest format-arguments))
+ (apply *invalid-method-error* args))
+
+(defun method-combination-error (&rest args)
+ (declare (arglist format-string &rest format-arguments))
+ (apply *method-combination-error* args))
+
+;This definition now appears in defcombin.lisp.
+;
+;(defmethod find-method-combination ((generic-function generic-function)
+; (type (eql 'standard))
+; options)
+; (when options
+; (method-combination-error
+; "The method combination type STANDARD accepts no options."))
+; *standard-method-combination*)
--- /dev/null
+;;;; This file defines the defconstructor and other make-instance optimization
+;;;; mechanisms.
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+
+;;;; This software is derived from software originally released by Xerox
+;;;; Corporation. Copyright and release statements follow. Later modifications
+;;;; to the software are in the public domain and are provided with
+;;;; absolutely no warranty. See the COPYING and CREDITS files for more
+;;;; information.
+
+;;;; copyright information from original PCL sources:
+;;;;
+;;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
+;;;; All rights reserved.
+;;;;
+;;;; Use and copying of this software and preparation of derivative works based
+;;;; upon this software are permitted. Any distribution of this software or
+;;;; derivative works must comply with all applicable United States export
+;;;; control laws.
+;;;;
+;;;; This software is made available AS IS, and Xerox Corporation makes no
+;;;; warranty about the software, its performance or its conformity to any
+;;;; specification.
+
+(in-package "SB-PCL")
+
+(sb-int:file-comment
+ "$Header$")
+\f
+;;; defconstructor is used to define special purpose functions which just
+;;; call make-instance with a symbol as the first argument. The semantics
+;;; of defconstructor is that it is equivalent to defining a function which
+;;; just calls make-instance. The purpose of defconstructor is to provide
+;;; PCL with a way of noticing these calls to make-instance so that it can
+;;; optimize them. Specific ports of PCL could just have their compiler
+;;; spot these calls to make-instance and then call this code. Having the
+;;; special defconstructor facility is the best we can do portably.
+;;;
+;;; A call to defconstructor like:
+;;;
+;;; (defconstructor make-foo foo (a b &rest r) a a :mumble b baz r)
+;;;
+;;; Is equivalent to a defun like:
+;;;
+;;; (defun make-foo (a b &rest r)
+;;; (make-instance 'foo 'a a ':mumble b 'baz r))
+;;;
+;;; Calls like the following are also legal:
+;;;
+;;; (defconstructor make-foo foo ())
+;;; (defconstructor make-bar bar () :x *x* :y *y*)
+;;; (defconstructor make-baz baz (a b c) a-b (list a b) b-c (list b c))
+;;;
+;;; The general idea of this implementation is that the expansion of the
+;;; defconstructor form includes the creation of closure generators which
+;;; can be called to create constructor code for the class. The ways that
+;;; a constructor can be optimized depends not only on the defconstructor
+;;; form, but also on the state of the class and the generic functions in
+;;; the initialization protocol. Because of this, the determination of the
+;;; form of constructor code to be used is a two part process.
+;;;
+;;; At compile time, make-constructor-code-generators looks at the actual
+;;; defconstructor form and makes a list of appropriate constructor code
+;;; generators. All that is really taken into account here is whether
+;;; any initargs are supplied in the call to make-instance, and whether
+;;; any of those are constant.
+;;;
+;;; At constructor code generation time (see note about lazy evaluation)
+;;; compute-constructor-code calls each of the constructor code generators
+;;; to try to get code for this constructor. Each generator looks at the
+;;; state of the class and initialization protocol generic functions and
+;;; decides whether its type of code is appropriate. This depends on things
+;;; like whether there are any applicable methods on initialize-instance,
+;;; whether class slots are affected by initialization etc.
+;;;
+;;; Constructor objects are funcallable instances, the protocol followed to
+;;; to compute the constructor code for them is quite similar to the protocol
+;;; followed to compute the discriminator code for a generic function. When
+;;; the constructor is first loaded, we install as its code a function which
+;;; will compute the actual constructor code the first time it is called.
+;;;
+;;; If there is an update to the class structure which might invalidate the
+;;; optimized constructor, the special lazy constructor installer is put back
+;;; so that it can compute the appropriate constructor when it is called.
+;;; This is the same kind of lazy evaluation update strategy used elswhere
+;;; in PCL.
+;;;
+;;; To allow for flexibility in the PCL implementation and to allow PCL users
+;;; to specialize this constructor facility for their own metaclasses, there
+;;; is an internal protocol followed by the code which loads and installs
+;;; the constructors. This is documented in the comments in the code.
+;;;
+;;; This code is also designed so that one of its levels, can be used to
+;;; implement optimization of calls to make-instance which can't go through
+;;; the defconstructor facility. This has not been implemented yet, but the
+;;; hooks are there.
+
+(defmacro defconstructor
+ (name class lambda-list &rest initialization-arguments)
+ (expand-defconstructor class
+ name
+ lambda-list
+ (copy-list initialization-arguments)))
+
+(defun expand-defconstructor (class-name name lambda-list supplied-initargs)
+ (let ((class (find-class class-name nil))
+ (supplied-initarg-names
+ (gathering1 (collecting)
+ (iterate ((name (*list-elements supplied-initargs :by #'cddr)))
+ (gather1 name)))))
+ (when (null class)
+ (error "defconstructor form being compiled (or evaluated) before~@
+ class ~S is defined."
+ class-name))
+ `(progn
+ ;; comments from PCL code back when it was portable:
+ ;; In order to avoid undefined function warnings, we want to
+ ;; tell the compile time environment that a function with this
+ ;; name and this argument list has been defined. The portable
+ ;; way to do this is with defun:
+ ;; #-cmu (declaim (notinline ,name))
+ ;; #-cmu
+ ;; (defun ,name ,lambda-list
+ ;; (declare (ignore ,@(extract-parameters lambda-list)))
+ ;; (error "Constructor ~S not loaded." ',name))
+ ;; But the derived result type for the above is wrong under CMU CL.
+ ;; So instead:
+ (declaim (ftype ,(ftype-declaration-from-lambda-list lambda-list name)
+ ,name))
+ ,(make-top-level-form `(defconstructor ,name)
+ '(load eval)
+ `(load-constructor
+ ',class-name
+ ',(class-name (class-of class))
+ ',name
+ ',supplied-initarg-names
+ ;; make-constructor-code-generators is called to return a list
+ ;; of constructor code generators. The actual interpretation
+ ;; of this list is left to compute-constructor-code, but the
+ ;; general idea is that it should be an plist where the keys
+ ;; name a kind of constructor code and the values are generator
+ ;; functions which return the actual constructor code. The
+ ;; constructor code is usually a closures over the arguments
+ ;; to the generator.
+ ,(make-constructor-code-generators class
+ name
+ lambda-list
+ supplied-initarg-names
+ supplied-initargs))))))
+
+(defun load-constructor (class-name metaclass-name constructor-name
+ supplied-initarg-names code-generators)
+ (let ((class (find-class class-name nil)))
+ (cond ((null class)
+ (error "defconstructor form being loaded (or evaluated) before~@
+ class ~S is defined."
+ class-name))
+ ((neq (class-name (class-of class)) metaclass-name)
+ (error "When defconstructor ~S was compiled, the metaclass of the~@
+ class ~S was ~S. The metaclass is now ~S.~@
+ The constructor must be recompiled."
+ constructor-name
+ class-name
+ metaclass-name
+ (class-name (class-of class))))
+ (t
+ (load-constructor-internal class
+ constructor-name
+ supplied-initarg-names
+ code-generators)
+ constructor-name))))
+
+;;; The actual constructor objects.
+(defclass constructor (funcallable-standard-object)
+ ((class ;The class with which this
+ :initarg :class ;constructor is associated.
+ :reader constructor-class) ;The actual class object,
+ ;not the class name.
+
+ (name ;The name of this constructor.
+ :initform nil ;This is the symbol in whose
+ :initarg :name ;function cell the constructor
+ :reader constructor-name) ;usually sits. Of course, this
+ ;is optional. defconstructor
+ ;makes named constructors, but
+ ;it is possible to manipulate
+ ;anonymous constructors also.
+
+ (code-type ;The type of code currently in
+ :initform nil ;use by this constructor. This
+ :accessor constructor-code-type) ;is mostly for debugging and
+ ;analysis purposes.
+ ;The lazy installer sets this
+ ;to LAZY. The most basic and
+ ;least optimized type of code
+ ;is called FALLBACK.
+
+ (supplied-initarg-names ;The names of the initargs this
+ :initarg :supplied-initarg-names ;constructor supplies when it
+ :reader ;"calls" make-instance.
+ constructor-supplied-initarg-names) ;
+
+ (code-generators ;Generators for the different
+ :initarg :code-generators ;types of code this constructor
+ :reader constructor-code-generators)) ;could use.
+ (:metaclass funcallable-standard-class))
+
+;;; Because the value in the code-type slot should always correspond to the
+;;; funcallable-instance-function of the constructor, this function should
+;;; always be used to set the both at the same time.
+(defun set-constructor-code (constructor code type)
+ (set-funcallable-instance-function constructor code)
+ (set-function-name constructor (constructor-name constructor))
+ (setf (constructor-code-type constructor) type))
+
+(defmethod describe-object ((constructor constructor) stream)
+ (format stream
+ "~S is a constructor for the class ~S.~%~
+ The current code type is ~S.~%~
+ Other possible code types are ~S."
+ constructor (constructor-class constructor)
+ (constructor-code-type constructor)
+ (gathering1 (collecting)
+ (doplist (key val) (constructor-code-generators constructor)
+ (gather1 key)))))
+
+;;; I am not in a hairy enough mood to make this implementation be metacircular
+;;; enough that it can support a defconstructor for constructor objects.
+(defun make-constructor (class name supplied-initarg-names code-generators)
+ (make-instance 'constructor
+ :class class
+ :name name
+ :supplied-initarg-names supplied-initarg-names
+ :code-generators code-generators))
+
+; This definition actually appears in std-class.lisp.
+;(defmethod class-constructors ((class std-class))
+; (with-slots (plist) class (getf plist 'constructors)))
+
+(defmethod add-constructor ((class slot-class)
+ (constructor constructor))
+ (with-slots (plist) class
+ (pushnew constructor (getf plist 'constructors))))
+
+(defmethod remove-constructor ((class slot-class)
+ (constructor constructor))
+ (with-slots (plist) class
+ (setf (getf plist 'constructors)
+ (delete constructor (getf plist 'constructors)))))
+
+(defmethod get-constructor ((class slot-class) name &optional (error-p t))
+ (or (dolist (c (class-constructors class))
+ (when (eq (constructor-name c) name) (return c)))
+ (if error-p
+ (error "Couldn't find a constructor with name ~S for class ~S."
+ name class)
+ ())))
+
+;;; This is called to actually load a defconstructor constructor. It must
+;;; install the lazy installer in the function cell of the constructor name,
+;;; and also add this constructor to the list of constructors the class has.
+(defmethod load-constructor-internal
+ ((class slot-class) name initargs generators)
+ (let ((constructor (make-constructor class name initargs generators))
+ (old (get-constructor class name nil)))
+ (when old (remove-constructor class old))
+ (install-lazy-constructor-installer constructor)
+ (add-constructor class constructor)
+ (setf (gdefinition name) constructor)))
+
+(defmethod install-lazy-constructor-installer ((constructor constructor))
+ (let ((class (constructor-class constructor)))
+ (set-constructor-code constructor
+ #'(sb-kernel:instance-lambda (&rest args)
+ (multiple-value-bind (code type)
+ (compute-constructor-code class constructor)
+ (set-constructor-code constructor code type)
+ (apply constructor args)))
+ 'lazy)))
+
+;;; The interface to keeping the constructors updated.
+;;;
+;;; add-method and remove-method (for standard-generic-function and -method),
+;;; promise to call maybe-update-constructors on the generic function and
+;;; the method.
+;;;
+;;; The class update code promises to call update-constructors whenever the
+;;; class is changed. That is, whenever the supers, slots or options change.
+;;; If user defined classes of constructor needs to be updated in more than
+;;; these circumstances, they should use the dependent updating mechanism to
+;;; make sure update-constructors is called.
+;;;
+;;; Bootstrapping concerns force the definitions of maybe-update-constructors
+;;; and update-constructors to be in the file std-class. For clarity, they
+;;; also appear below. Be sure to keep the definition here and there in sync.
+;(defvar *initialization-generic-functions*
+; (list #'make-instance
+; #'default-initargs
+; #'allocate-instance
+; #'initialize-instance
+; #'shared-initialize))
+;
+;(defmethod maybe-update-constructors
+; ((generic-function generic-function)
+; (method method))
+; (when (memq generic-function *initialization-generic-functions*)
+; (labels ((recurse (class)
+; (update-constructors class)
+; (dolist (subclass (class-direct-subclasses class))
+; (recurse subclass))))
+; (when (classp (car (method-specializers method)))
+; (recurse (car (method-specializers method)))))))
+;
+;(defmethod update-constructors ((class slot-class))
+; (dolist (cons (class-constructors class))
+; (install-lazy-constructor-installer cons)))
+;
+;(defmethod update-constructors ((class class))
+; ())
+\f
+;;; Here is the actual smarts for making the code generators and then trying
+;;; each generator to get constructor code. This extensible mechanism allows
+;;; new kinds of constructor code types to be added. A programmer defining a
+;;; specialization of the constructor class can either use this mechanism to
+;;; define new code types, or can override this mechanism by overriding the
+;;; methods on make-constructor-code-generators and compute-constructor-code.
+;;;
+;;; The function defined by define-constructor-code-type will receive the
+;;; class object, and the 4 original arguments to defconstructor. It can
+;;; return a constructor code generator, or return nil if this type of code
+;;; is determined to not be appropriate after looking at the defconstructor
+;;; arguments.
+;;;
+;;; When compute-constructor-code is called, it first performs basic checks
+;;; to make sure that the basic assumptions common to all the code types are
+;;; valid. (For details see method definition). If any of the tests fail,
+;;; the fallback constructor code type is used. If none of the tests fail,
+;;; the constructor code generators are called in order. They receive 5
+;;; arguments:
+;;;
+;;; CLASS the class the constructor is making instances of
+;;; WRAPPER that class's wrapper
+;;; DEFAULTS the result of calling class-default-initargs on class
+;;; INITIALIZE the applicable methods on initialize-instance
+;;; SHARED the applicable methosd on shared-initialize
+;;;
+;;; The first code generator to return code is used. The code generators are
+;;; called in reverse order of definition, so define-constructor-code-type
+;;; forms which define better code should appear after ones that define less
+;;; good code. The fallback code type appears first. Note that redefining a
+;;; code type does not change its position in the list. To do that, define
+;;; a new type at the end with the behavior.
+
+(defvar *constructor-code-types* ())
+
+(defmacro define-constructor-code-type (type arglist &body body)
+ (let ((fn-name (intern (format nil
+ "CONSTRUCTOR-CODE-GENERATOR ~A ~A"
+ (package-name (symbol-package type))
+ (symbol-name type))
+ *pcl-package*)))
+ `(progn
+ (defun ,fn-name ,arglist .,body)
+ (load-define-constructor-code-type ',type ',fn-name))))
+
+(defun load-define-constructor-code-type (type generator)
+ (let ((old-entry (assq type *constructor-code-types*)))
+ (if old-entry
+ (setf (cadr old-entry) generator)
+ (push (list type generator) *constructor-code-types*))
+ type))
+
+(defmethod make-constructor-code-generators
+ ((class slot-class)
+ name lambda-list supplied-initarg-names supplied-initargs)
+ (cons 'list
+ (gathering1 (collecting)
+ (dolist (entry *constructor-code-types*)
+ (let ((generator
+ (funcall (cadr entry) class name lambda-list
+ supplied-initarg-names
+ supplied-initargs)))
+ (when generator
+ (gather1 `',(car entry))
+ (gather1 generator)))))))
+
+(defmethod compute-constructor-code ((class slot-class)
+ (constructor constructor))
+ (let* ((proto (class-prototype class))
+ (wrapper (class-wrapper class))
+ (defaults (class-default-initargs class))
+ (make
+ (compute-applicable-methods (gdefinition 'make-instance) (list class)))
+ (supplied-initarg-names
+ (constructor-supplied-initarg-names constructor))
+ (default
+ (compute-applicable-methods (gdefinition 'default-initargs)
+ (list class supplied-initarg-names))) ;?
+ (allocate
+ (compute-applicable-methods (gdefinition 'allocate-instance)
+ (list class)))
+ (initialize
+ (compute-applicable-methods (gdefinition 'initialize-instance)
+ (list proto)))
+ (shared
+ (compute-applicable-methods (gdefinition 'shared-initialize)
+ (list proto t)))
+ (code-generators
+ (constructor-code-generators constructor)))
+ (flet ((call-code-generator (generator)
+ (when (null generator)
+ (unless (setq generator (getf code-generators 'fallback))
+ (error "No FALLBACK generator?")))
+ (funcall generator class wrapper defaults initialize shared)))
+ (if (or (cdr make)
+ (cdr default)
+ (cdr allocate)
+ (not (check-initargs-1 class
+ supplied-initarg-names
+ (append initialize shared)
+ nil nil)))
+ ;; These are basic shared assumptions, if one of the
+ ;; has been violated, we have to resort to the fallback
+ ;; case. Any of these assumptions could be moved out
+ ;; of here and into the individual code types if there
+ ;; was a need to do so.
+ (values (call-code-generator nil) 'fallback)
+ ;; Otherwise try all the generators until one produces
+ ;; code for us.
+ (doplist (type generator) code-generators
+ (let ((code (call-code-generator generator)))
+ (when code (return (values code type)))))))))
+
+;;; The facilities are useful for debugging, and to measure the performance
+;;; boost from constructors.
+;;;
+;;; FIXME: so they should probably be #+SB-SHOW instead of unconditional
+
+(defun map-constructors (fn)
+ (let ((nclasses 0)
+ (nconstructors 0))
+ (labels ((recurse (class)
+ (incf nclasses)
+ (dolist (constructor (class-constructors class))
+ (incf nconstructors)
+ (funcall fn constructor))
+ (dolist (subclass (class-direct-subclasses class))
+ (recurse subclass))))
+ (recurse (find-class 't))
+ (values nclasses nconstructors))))
+
+(defun reset-constructors ()
+ (multiple-value-bind (nclass ncons)
+ (map-constructors #'install-lazy-constructor-installer )
+ (format t "~&~D classes, ~D constructors." nclass ncons)))
+
+(defun disable-constructors ()
+ (multiple-value-bind (nclass ncons)
+ (map-constructors
+ #'(lambda (c)
+ (let ((gen (getf (constructor-code-generators c) 'fallback)))
+ (if (null gen)
+ (error "No fallback constructor for ~S." c)
+ (set-constructor-code c
+ (funcall gen
+ (constructor-class c)
+ () () () ())
+ 'fallback)))))
+ (format t "~&~D classes, ~D constructors." nclass ncons)))
+
+(defun enable-constructors ()
+ (reset-constructors))
+\f
+;;; helper functions and utilities that are shared by all of the code types
+;;; and by the main compute-constructor-code method as well
+
+(defvar *standard-initialize-instance-method*
+ (get-method #'initialize-instance
+ ()
+ (list *the-class-slot-object*)))
+
+(defvar *standard-shared-initialize-method*
+ (get-method #'shared-initialize
+ ()
+ (list *the-class-slot-object* *the-class-t*)))
+
+(defun non-pcl-initialize-instance-methods-p (methods)
+ (notevery #'(lambda (m) (eq m *standard-initialize-instance-method*))
+ methods))
+
+(defun non-pcl-shared-initialize-methods-p (methods)
+ (notevery #'(lambda (m) (eq m *standard-shared-initialize-method*))
+ methods))
+
+(defun non-pcl-or-after-initialize-instance-methods-p (methods)
+ (notevery #'(lambda (m) (or (eq m *standard-initialize-instance-method*)
+ (equal '(:after) (method-qualifiers m))))
+ methods))
+
+(defun non-pcl-or-after-shared-initialize-methods-p (methods)
+ (notevery #'(lambda (m) (or (eq m *standard-shared-initialize-method*)
+ (equal '(:after) (method-qualifiers m))))
+ methods))
+
+;;; This returns two values. The first is a vector which can be used as the
+;;; initial value of the slots vector for the instance. The second is a symbol
+;;; describing the initforms this class has.
+;;;
+;;; If the first value is:
+;;;
+;;; :UNSUPPLIED no slot has an initform
+;;; :CONSTANTS all slots have either a constant initform
+;;; or no initform at all
+;;; T there is at least one non-constant initform
+(defun compute-constant-vector (class)
+ ;;(declare (values constants flag))
+ (let* ((wrapper (class-wrapper class))
+ (layout (wrapper-instance-slots-layout wrapper))
+ (flag :unsupplied)
+ (constants ()))
+ (dolist (slotd (class-slots class))
+ (let ((name (slot-definition-name slotd))
+ (initform (slot-definition-initform slotd))
+ (initfn (slot-definition-initfunction slotd)))
+ (cond ((null (memq name layout)))
+ ((null initfn)
+ (push (cons name *slot-unbound*) constants))
+ ((constantp initform)
+ (push (cons name (eval initform)) constants)
+ (when (eq flag ':unsupplied) (setq flag ':constants)))
+ (t
+ (push (cons name *slot-unbound*) constants)
+ (setq flag 't)))))
+ (let* ((constants-alist (sort constants #'(lambda (x y)
+ (memq (car y)
+ (memq (car x) layout)))))
+ (constants-list (mapcar #'cdr constants-alist)))
+ (values constants-list flag))))
+
+;;; This takes a class and a list of initarg-names, and returns an alist
+;;; indicating the positions of the slots those initargs may fill. The
+;;; order of the initarg-names argument is important of course, since we
+;;; have to respect the rules about the leftmost initarg that fills a slot
+;;; having precedence. This function allows initarg names to appear twice
+;;; in the list, it only considers the first appearance.
+(defun compute-initarg-positions (class initarg-names)
+ (let* ((layout (wrapper-instance-slots-layout (class-wrapper class)))
+ (positions
+ (gathering1 (collecting)
+ (iterate ((slot-name (list-elements layout))
+ (position (interval :from 0)))
+ (gather1 (cons slot-name position)))))
+ (slot-initargs
+ (mapcar #'(lambda (slotd)
+ (list (slot-definition-initargs slotd)
+ (or (cdr (assq (slot-definition-name slotd)
+ positions))
+ ':class)))
+ (class-slots class))))
+ ;; Go through each of the initargs, and figure out what position
+ ;; it fills by replacing the entries in slot-initargs it fills.
+ (dolist (initarg initarg-names)
+ (dolist (slot-entry slot-initargs)
+ (let ((slot-initargs (car slot-entry)))
+ (when (and (listp slot-initargs)
+ (not (null slot-initargs))
+ (memq initarg slot-initargs))
+ (setf (car slot-entry) initarg)))))
+ (gathering1 (collecting)
+ (dolist (initarg initarg-names)
+ (let ((positions (gathering1 (collecting)
+ (dolist (slot-entry slot-initargs)
+ (when (eq (car slot-entry) initarg)
+ (gather1 (cadr slot-entry)))))))
+ (when positions
+ (gather1 (cons initarg positions))))))))
+\f
+;;; The FALLBACK case allows anything. This always works, and always appears
+;;; as the last of the generators for a constructor. It does a full call to
+;;; make-instance.
+(define-constructor-code-type fallback
+ (class name arglist supplied-initarg-names supplied-initargs)
+ (declare (ignore name supplied-initarg-names))
+ `(function
+ (lambda (&rest ignore)
+ (declare (ignore ignore))
+ (function
+ (sb-kernel:instance-lambda ,arglist
+ (make-instance
+ ',(class-name class)
+ ,@(gathering1 (collecting)
+ (iterate ((tail (*list-tails supplied-initargs :by #'cddr)))
+ (gather1 `',(car tail))
+ (gather1 (cadr tail))))))))))
+\f
+;;; The GENERAL case allows:
+;;; constant, unsupplied or non-constant initforms
+;;; constant or non-constant default initargs
+;;; supplied initargs
+;;; slot-filling initargs
+;;; :after methods on shared-initialize and initialize-instance
+(define-constructor-code-type general
+ (class name arglist supplied-initarg-names supplied-initargs)
+ (declare (ignore name))
+ (let ((raw-allocator (raw-instance-allocator class))
+ (slots-fetcher (slots-fetcher class)))
+ `(function
+ (lambda (class .wrapper. defaults init shared)
+ (multiple-value-bind (.constants.
+ .constant-initargs.
+ .initfns-initargs-and-positions.
+ .supplied-initarg-positions.
+ .shared-initfns.
+ .initfns.)
+ (general-generator-internal class
+ defaults
+ init
+ shared
+ ',supplied-initarg-names
+ ',supplied-initargs)
+ .supplied-initarg-positions.
+ (when (and .constants.
+ (null (non-pcl-or-after-initialize-instance-methods-p
+ init))
+ (null (non-pcl-or-after-shared-initialize-methods-p
+ shared)))
+ (function
+ (sb-kernel:instance-lambda ,arglist
+ (declare #.*optimize-speed*)
+ (let* ((.instance. (,raw-allocator .wrapper. .constants.))
+ (.slots. (,slots-fetcher .instance.))
+ (.positions. .supplied-initarg-positions.)
+ (.initargs. .constant-initargs.))
+ .positions.
+
+ (dolist (entry .initfns-initargs-and-positions.)
+ (let ((val (funcall (car entry)))
+ (initarg (cadr entry)))
+ (when initarg
+ (push val .initargs.)
+ (push initarg .initargs.))
+ (dolist (pos (cddr entry))
+ (setf (%instance-ref .slots. pos) val))))
+
+ ,@(gathering1 (collecting)
+ (doplist (initarg value) supplied-initargs
+ (unless (constantp value)
+ (gather1 `(let ((.value. ,value))
+ (push .value. .initargs.)
+ (push ',initarg .initargs.)
+ (dolist (.p. (pop .positions.))
+ (setf (%instance-ref .slots. .p.)
+ .value.)))))))
+
+ (dolist (fn .shared-initfns.)
+ (apply fn .instance. t .initargs.))
+ (dolist (fn .initfns.)
+ (apply fn .instance. .initargs.))
+
+ .instance.)))))))))
+
+(defun general-generator-internal
+ (class defaults init shared supplied-initarg-names supplied-initargs)
+ (flet ((bail-out () (return-from general-generator-internal nil)))
+ (let* ((constants (compute-constant-vector class))
+ (layout (wrapper-instance-slots-layout (class-wrapper class)))
+ (initarg-positions
+ (compute-initarg-positions class
+ (append supplied-initarg-names
+ (mapcar #'car defaults))))
+ (initfns-initargs-and-positions ())
+ (supplied-initarg-positions ())
+ (constant-initargs ())
+ (used-positions ()))
+
+ ;; Go through each of the supplied initargs for three reasons.
+ ;;
+ ;; - If it fills a class slot, bail out.
+ ;; - If its a constant form, fill the constant vector.
+ ;; - Otherwise remember the positions no two initargs
+ ;; will try to fill the same position, since compute
+ ;; initarg positions already took care of that, but
+ ;; we do need to know what initforms will and won't
+ ;; be needed.
+ (doplist (initarg val) supplied-initargs
+ (let ((positions (cdr (assq initarg initarg-positions))))
+ (cond ((memq :class positions) (bail-out))
+ ((constantp val)
+ (setq val (eval val))
+ (push val constant-initargs)
+ (push initarg constant-initargs)
+ (dolist (pos positions) (setf (svref constants pos) val)))
+ (t
+ (push positions supplied-initarg-positions)))
+ (setq used-positions (append positions used-positions))))
+
+ ;; Go through each of the default initargs, for three reasons.
+ ;;
+ ;; - If it fills a class slot, bail out.
+ ;; - If it is a constant, and it does fill a slot, put that
+ ;; into the constant vector.
+ ;; - If it isn't a constant, record its initfn and position.
+ (dolist (default defaults)
+ (let* ((name (car default))
+ (initfn (cadr default))
+ (form (caddr default))
+ (value ())
+ (positions (cdr (assq name initarg-positions))))
+ (unless (memq name supplied-initarg-names)
+ (cond ((memq :class positions) (bail-out))
+ ((constantp form)
+ (setq value (eval form))
+ (push value constant-initargs)
+ (push name constant-initargs)
+ (dolist (pos positions)
+ (setf (svref constants pos) value)))
+ (t
+ (push (list* initfn name positions)
+ initfns-initargs-and-positions)))
+ (setq used-positions (append positions used-positions)))))
+
+ ;; Go through each of the slot initforms:
+ ;;
+ ;; - If its position has already been filled, do nothing.
+ ;; The initfn won't need to be called, and the slot won't
+ ;; need to be touched.
+ ;; - If it is a class slot, and has an initform, bail out.
+ ;; - If its a constant or unsupplied, ignore it, it is
+ ;; already in the constant vector.
+ ;; - Otherwise, record its initfn and position
+ (dolist (slotd (class-slots class))
+ (let* ((alloc (slot-definition-allocation slotd))
+ (name (slot-definition-name slotd))
+ (form (slot-definition-initform slotd))
+ (initfn (slot-definition-initfunction slotd))
+ (position (position name layout)))
+ (cond ((neq alloc :instance)
+ (unless (null initfn)
+ (bail-out)))
+ ((member position used-positions))
+ ((or (constantp form)
+ (null initfn)))
+ (t
+ (push (list initfn nil position)
+ initfns-initargs-and-positions)))))
+
+ (values constants
+ constant-initargs
+ (nreverse initfns-initargs-and-positions)
+ (nreverse supplied-initarg-positions)
+ (mapcar #'method-function
+ (remove *standard-shared-initialize-method* shared))
+ (mapcar #'method-function
+ (remove *standard-initialize-instance-method* init))))))
+\f
+;;; The NO-METHODS case allows:
+;;; constant, unsupplied or non-constant initforms
+;;; constant or non-constant default initargs
+;;; supplied initargs that are arguments to constructor, or constants
+;;; slot-filling initargs
+(define-constructor-code-type no-methods
+ (class name arglist supplied-initarg-names supplied-initargs)
+ (declare (ignore name))
+ (let ((raw-allocator (raw-instance-allocator class))
+ (slots-fetcher (slots-fetcher class)))
+ `(function
+ (lambda (class .wrapper. defaults init shared)
+ (multiple-value-bind (.constants.
+ .initfns-and-positions.
+ .supplied-initarg-positions.)
+ (no-methods-generator-internal class
+ defaults
+ ',supplied-initarg-names
+ ',supplied-initargs)
+ .initfns-and-positions.
+ .supplied-initarg-positions.
+ (when (and .constants.
+ (null (non-pcl-initialize-instance-methods-p init))
+ (null (non-pcl-shared-initialize-methods-p shared)))
+ #'(sb-kernel:instance-lambda ,arglist
+ (declare #.*optimize-speed*)
+ (let* ((.instance. (,raw-allocator .wrapper. .constants.))
+ (.slots. (,slots-fetcher .instance.))
+ (.positions. .supplied-initarg-positions.))
+ .positions.
+
+ (dolist (entry .initfns-and-positions.)
+ (let ((val (funcall (car entry))))
+ (dolist (pos (cdr entry))
+ (setf (%instance-ref .slots. pos) val))))
+
+ ,@(gathering1 (collecting)
+ (doplist (initarg value) supplied-initargs
+ (unless (constantp value)
+ (gather1
+ `(let ((.value. ,value))
+ (dolist (.p. (pop .positions.))
+ (setf (%instance-ref .slots. .p.) .value.)))))))
+
+ .instance.))))))))
+
+(defun no-methods-generator-internal
+ (class defaults supplied-initarg-names supplied-initargs)
+ (flet ((bail-out () (return-from no-methods-generator-internal nil)))
+ (let* ((constants (compute-constant-vector class))
+ (layout (wrapper-instance-slots-layout (class-wrapper class)))
+ (initarg-positions
+ (compute-initarg-positions class
+ (append supplied-initarg-names
+ (mapcar #'car defaults))))
+ (initfns-and-positions ())
+ (supplied-initarg-positions ())
+ (used-positions ()))
+
+ ;; Go through each of the supplied initargs for three reasons.
+ ;;
+ ;; - If it fills a class slot, bail out.
+ ;; - If its a constant form, fill the constant vector.
+ ;; - Otherwise remember the positions, no two initargs
+ ;; will try to fill the same position, since compute
+ ;; initarg positions already took care of that, but
+ ;; we do need to know what initforms will and won't
+ ;; be needed.
+ (doplist (initarg val) supplied-initargs
+ (let ((positions (cdr (assq initarg initarg-positions))))
+ (cond ((memq :class positions) (bail-out))
+ ((constantp val)
+ (setq val (eval val))
+ (dolist (pos positions)
+ (setf (svref constants pos) val)))
+ (t
+ (push positions supplied-initarg-positions)))
+ (setq used-positions (append positions used-positions))))
+
+ ;; Go through each of the default initargs, for three reasons.
+ ;;
+ ;; - If it fills a class slot, bail out.
+ ;; - If it is a constant, and it does fill a slot, put that
+ ;; into the constant vector.
+ ;; - If it isn't a constant, record its initfn and position.
+ (dolist (default defaults)
+ (let* ((name (car default))
+ (initfn (cadr default))
+ (form (caddr default))
+ (value ())
+ (positions (cdr (assq name initarg-positions))))
+ (unless (memq name supplied-initarg-names)
+ (cond ((memq :class positions) (bail-out))
+ ((constantp form)
+ (setq value (eval form))
+ (dolist (pos positions)
+ (setf (svref constants pos) value)))
+ (t
+ (push (cons initfn positions)
+ initfns-and-positions)))
+ (setq used-positions (append positions used-positions)))))
+
+ ;; Go through each of the slot initforms:
+ ;;
+ ;; - If its position has already been filled, do nothing.
+ ;; The initfn won't need to be called, and the slot won't
+ ;; need to be touched.
+ ;; - If it is a class slot, and has an initform, bail out.
+ ;; - If its a constant or unsupplied, do nothing, we know
+ ;; that it is already in the constant vector.
+ ;; - Otherwise, record its initfn and position
+ (dolist (slotd (class-slots class))
+ (let* ((alloc (slot-definition-allocation slotd))
+ (name (slot-definition-name slotd))
+ (form (slot-definition-initform slotd))
+ (initfn (slot-definition-initfunction slotd))
+ (position (position name layout)))
+ (cond ((neq alloc :instance)
+ (unless (null initfn)
+ (bail-out)))
+ ((member position used-positions))
+ ((or (constantp form)
+ (null initfn)))
+ (t
+ (push (list initfn position) initfns-and-positions)))))
+
+ (values constants
+ (nreverse initfns-and-positions)
+ (nreverse supplied-initarg-positions)))))
+\f
+;;; The SIMPLE-SLOTS case allows:
+;;; constant or unsupplied initforms
+;;; constant default initargs
+;;; supplied initargs
+;;; slot filling initargs
+(define-constructor-code-type simple-slots
+ (class name arglist supplied-initarg-names supplied-initargs)
+ (declare (ignore name))
+ (let ((raw-allocator (raw-instance-allocator class))
+ (slots-fetcher (slots-fetcher class)))
+ `(function
+ (lambda (class .wrapper. defaults init shared)
+ (when (and (null (non-pcl-initialize-instance-methods-p init))
+ (null (non-pcl-shared-initialize-methods-p shared)))
+ (multiple-value-bind (.constants. .supplied-initarg-positions.)
+ (simple-slots-generator-internal class
+ defaults
+ ',supplied-initarg-names
+ ',supplied-initargs)
+ (when .constants.
+ (function
+ (sb-kernel:instance-lambda ,arglist
+ (declare #.*optimize-speed*)
+ (let* ((.instance. (,raw-allocator .wrapper. .constants.))
+ (.slots. (,slots-fetcher .instance.))
+ (.positions. .supplied-initarg-positions.))
+ .positions.
+
+ ,@(gathering1 (collecting)
+ (doplist (initarg value) supplied-initargs
+ (unless (constantp value)
+ (gather1
+ `(let ((.value. ,value))
+ (dolist (.p. (pop .positions.))
+ (setf (%instance-ref .slots. .p.)
+ .value.)))))))
+
+ .instance.))))))))))
+
+(defun simple-slots-generator-internal
+ (class defaults supplied-initarg-names supplied-initargs)
+ (flet ((bail-out () (return-from simple-slots-generator-internal nil)))
+ (let* ((constants (compute-constant-vector class))
+ (layout (wrapper-instance-slots-layout (class-wrapper class)))
+ (initarg-positions
+ (compute-initarg-positions class
+ (append supplied-initarg-names
+ (mapcar #'car defaults))))
+ (supplied-initarg-positions ())
+ (used-positions ()))
+
+ ;; Go through each of the supplied initargs for three reasons.
+ ;;
+ ;; - If it fills a class slot, bail out.
+ ;; - If its a constant form, fill the constant vector.
+ ;; - Otherwise remember the positions, no two initargs
+ ;; will try to fill the same position, since compute
+ ;; initarg positions already took care of that, but
+ ;; we do need to know what initforms will and won't
+ ;; be needed.
+ (doplist (initarg val) supplied-initargs
+ (let ((positions (cdr (assq initarg initarg-positions))))
+ (cond ((memq :class positions) (bail-out))
+ ((constantp val)
+ (setq val (eval val))
+ (dolist (pos positions)
+ (setf (svref constants pos) val)))
+ (t
+ (push positions supplied-initarg-positions)))
+ (setq used-positions (append used-positions positions))))
+
+ ;; Go through each of the default initargs for three reasons.
+ ;;
+ ;; - If it isn't a constant form, bail out.
+ ;; - If it fills a class slot, bail out.
+ ;; - If it is a constant, and it does fill a slot, put that
+ ;; into the constant vector.
+ (dolist (default defaults)
+ (let* ((name (car default))
+ (form (caddr default))
+ (value ())
+ (positions (cdr (assq name initarg-positions))))
+ (unless (memq name supplied-initarg-names)
+ (cond ((memq :class positions) (bail-out))
+ ((not (constantp form))
+ (bail-out))
+ (t
+ (setq value (eval form))
+ (dolist (pos positions)
+ (setf (svref constants pos) value)))))))
+
+ ;; Go through each of the slot initforms:
+ ;;
+ ;; - If its position has already been filled, do nothing.
+ ;; The initfn won't need to be called, and the slot won't
+ ;; need to be touched, we are OK.
+ ;; - If it has a non-constant initform, bail-out. This
+ ;; case doesn't handle those.
+ ;; - If it has a constant or unsupplied initform we don't
+ ;; really need to do anything, the value is in the
+ ;; constants vector.
+ (dolist (slotd (class-slots class))
+ (let* ((alloc (slot-definition-allocation slotd))
+ (name (slot-definition-name slotd))
+ (form (slot-definition-initform slotd))
+ (initfn (slot-definition-initfunction slotd))
+ (position (position name layout)))
+ (cond ((neq alloc :instance)
+ (unless (null initfn)
+ (bail-out)))
+ ((member position used-positions))
+ ((or (constantp form)
+ (null initfn)))
+ (t
+ (bail-out)))))
+
+ (values constants (nreverse supplied-initarg-positions)))))
+
--- /dev/null
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+
+;;;; This software is derived from software originally released by Xerox
+;;;; Corporation. Copyright and release statements follow. Later modifications
+;;;; to the software are in the public domain and are provided with
+;;;; absolutely no warranty. See the COPYING and CREDITS files for more
+;;;; information.
+
+;;;; copyright information from original PCL sources:
+;;;;
+;;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
+;;;; All rights reserved.
+;;;;
+;;;; Use and copying of this software and preparation of derivative works based
+;;;; upon this software are permitted. Any distribution of this software or
+;;;; derivative works must comply with all applicable United States export
+;;;; control laws.
+;;;;
+;;;; This software is made available AS IS, and Xerox Corporation makes no
+;;;; warranty about the software, its performance or its conformity to any
+;;;; specification.
+
+(in-package "SB-PCL")
+
+(sb-int:file-comment
+ "$Header$")
+\f
+;;; compute-class-precedence-list
+;;;
+;;; Knuth section 2.2.3 has some interesting notes on this.
+;;;
+;;; What appears here is basically the algorithm presented there.
+;;;
+;;; The key idea is that we use class-precedence-description (CPD) structures
+;;; to store the precedence information as we proceed. The CPD structure for
+;;; a class stores two critical pieces of information:
+;;;
+;;; - a count of the number of "reasons" why the class can't go
+;;; into the class precedence list yet.
+;;;
+;;; - a list of the "reasons" this class prevents others from
+;;; going in until after it
+;;
+;;; A "reason" is essentially a single local precedence constraint. If a
+;;; constraint between two classes arises more than once it generates more
+;;; than one reason. This makes things simpler, linear, and isn't a problem
+;;; as long as we make sure to keep track of each instance of a "reason".
+;;;
+;;; This code is divided into three phases.
+;;;
+;;; - the first phase simply generates the CPD's for each of the class
+;;; and its superclasses. The remainder of the code will manipulate
+;;; these CPDs rather than the class objects themselves. At the end
+;;; of this pass, the CPD-SUPERS field of a CPD is a list of the CPDs
+;;; of the direct superclasses of the class.
+;;;
+;;; - the second phase folds all the local constraints into the CPD
+;;; structure. The CPD-COUNT of each CPD is built up, and the
+;;; CPD-AFTER fields are augmented to include precedence constraints
+;;; from the CPD-SUPERS field and from the order of classes in other
+;;; CPD-SUPERS fields.
+;;;
+;;; After this phase, the CPD-AFTER field of a class includes all the
+;;; direct superclasses of the class plus any class that immediately
+;;; follows the class in the direct superclasses of another. There
+;;; can be duplicates in this list. The CPD-COUNT field is equal to
+;;; the number of times this class appears in the CPD-AFTER field of
+;;; all the other CPDs.
+;;;
+;;; - In the third phase, classes are put into the precedence list one
+;;; at a time, with only those classes with a CPD-COUNT of 0 being
+;;; candidates for insertion. When a class is inserted , every CPD
+;;; in its CPD-AFTER field has its count decremented.
+;;;
+;;; In the usual case, there is only one candidate for insertion at
+;;; any point. If there is more than one, the specified tiebreaker
+;;; rule is used to choose among them.
+
+(defmethod compute-class-precedence-list ((root slot-class))
+ (compute-std-cpl root (class-direct-superclasses root)))
+
+(defstruct (class-precedence-description
+ (:conc-name nil)
+ (:print-object (lambda (obj str)
+ (print-unreadable-object (obj str :type t)
+ (format str "~D" (cpd-count obj)))))
+ (:constructor make-cpd ()))
+ (cpd-class nil)
+ (cpd-supers ())
+ (cpd-after ())
+ (cpd-count 0))
+
+(defun compute-std-cpl (class supers)
+ (cond ((null supers) ;First two branches of COND
+ (list class)) ;are implementing the single
+ ((null (cdr supers)) ;inheritance optimization.
+ (cons class
+ (compute-std-cpl (car supers)
+ (class-direct-superclasses (car supers)))))
+ (t
+ (multiple-value-bind (all-cpds nclasses)
+ (compute-std-cpl-phase-1 class supers)
+ (compute-std-cpl-phase-2 all-cpds)
+ (compute-std-cpl-phase-3 class all-cpds nclasses)))))
+
+(defvar *compute-std-cpl-class->entry-table-size* 60)
+
+(defun compute-std-cpl-phase-1 (class supers)
+ (let ((nclasses 0)
+ (all-cpds ())
+ (table (make-hash-table :size *compute-std-cpl-class->entry-table-size*
+ :test #'eq)))
+ (declare (fixnum nclasses))
+ (labels ((get-cpd (c)
+ (or (gethash c table)
+ (setf (gethash c table) (make-cpd))))
+ (walk (c supers)
+ (if (forward-referenced-class-p c)
+ (cpl-forward-referenced-class-error class c)
+ (let ((cpd (get-cpd c)))
+ (unless (cpd-class cpd) ;If we have already done this
+ ;class before, we can quit.
+ (setf (cpd-class cpd) c)
+ (incf nclasses)
+ (push cpd all-cpds)
+ (setf (cpd-supers cpd) (mapcar #'get-cpd supers))
+ (dolist (super supers)
+ (walk super (class-direct-superclasses super))))))))
+ (walk class supers)
+ (values all-cpds nclasses))))
+
+(defun compute-std-cpl-phase-2 (all-cpds)
+ (dolist (cpd all-cpds)
+ (let ((supers (cpd-supers cpd)))
+ (when supers
+ (setf (cpd-after cpd) (nconc (cpd-after cpd) supers))
+ (incf (cpd-count (car supers)) 1)
+ (do* ((t1 supers t2)
+ (t2 (cdr t1) (cdr t1)))
+ ((null t2))
+ (incf (cpd-count (car t2)) 2)
+ (push (car t2) (cpd-after (car t1))))))))
+
+(defun compute-std-cpl-phase-3 (class all-cpds nclasses)
+ (let ((candidates ())
+ (next-cpd nil)
+ (rcpl ()))
+
+ ;; We have to bootstrap the collection of those CPD's that
+ ;; have a zero count. Once we get going, we will maintain
+ ;; this list incrementally.
+ (dolist (cpd all-cpds)
+ (when (zerop (cpd-count cpd)) (push cpd candidates)))
+
+ (loop
+ (when (null candidates)
+
+ ;; If there are no candidates, and enough classes have been put
+ ;; into the precedence list, then we are all done. Otherwise
+ ;; it means there is a consistency problem.
+ (if (zerop nclasses)
+ (return (reverse rcpl))
+ (cpl-inconsistent-error class all-cpds)))
+
+ ;; Try to find the next class to put in from among the candidates.
+ ;; If there is only one, its easy, otherwise we have to use the
+ ;; famous RPG tiebreaker rule. There is some hair here to avoid
+ ;; having to call DELETE on the list of candidates. I dunno if
+ ;; its worth it but what the hell.
+ (setq next-cpd
+ (if (null (cdr candidates))
+ (prog1 (car candidates)
+ (setq candidates ()))
+ (block tie-breaker
+ (dolist (c rcpl)
+ (let ((supers (class-direct-superclasses c)))
+ (if (memq (cpd-class (car candidates)) supers)
+ (return-from tie-breaker (pop candidates))
+ (do ((loc candidates (cdr loc)))
+ ((null (cdr loc)))
+ (let ((cpd (cadr loc)))
+ (when (memq (cpd-class cpd) supers)
+ (setf (cdr loc) (cddr loc))
+ (return-from tie-breaker cpd))))))))))
+ (decf nclasses)
+ (push (cpd-class next-cpd) rcpl)
+ (dolist (after (cpd-after next-cpd))
+ (when (zerop (decf (cpd-count after)))
+ (push after candidates))))))
+\f
+;;;; support code for signalling nice error messages
+
+(defun cpl-error (class format-string &rest format-args)
+ (error "While computing the class precedence list of the class ~A.~%~A"
+ (if (class-name class)
+ (format nil "named ~S" (class-name class))
+ class)
+ (apply #'format nil format-string format-args)))
+
+(defun cpl-forward-referenced-class-error (class forward-class)
+ (flet ((class-or-name (class)
+ (if (class-name class)
+ (format nil "named ~S" (class-name class))
+ class)))
+ (let ((names (mapcar #'class-or-name
+ (cdr (find-superclass-chain class forward-class)))))
+ (cpl-error class
+ "The class ~A is a forward referenced class.~@
+ The class ~A is ~A."
+ (class-or-name forward-class)
+ (class-or-name forward-class)
+ (if (null (cdr names))
+ (format nil
+ "a direct superclass of the class ~A"
+ (class-or-name class))
+ (format nil
+ "reached from the class ~A by following~@
+ the direct superclass chain through: ~A~
+ ~% ending at the class ~A"
+ (class-or-name class)
+ (format nil
+ "~{~% the class ~A,~}"
+ (butlast names))
+ (car (last names))))))))
+
+(defun find-superclass-chain (bottom top)
+ (labels ((walk (c chain)
+ (if (eq c top)
+ (return-from find-superclass-chain (nreverse chain))
+ (dolist (super (class-direct-superclasses c))
+ (walk super (cons super chain))))))
+ (walk bottom (list bottom))))
+
+(defun cpl-inconsistent-error (class all-cpds)
+ (let ((reasons (find-cycle-reasons all-cpds)))
+ (cpl-error class
+ "It is not possible to compute the class precedence list because~@
+ there ~A in the local precedence relations.~@
+ ~A because:~{~% ~A~}."
+ (if (cdr reasons) "are circularities" "is a circularity")
+ (if (cdr reasons) "These arise" "This arises")
+ (format-cycle-reasons (apply #'append reasons)))))
+
+(defun format-cycle-reasons (reasons)
+ (flet ((class-or-name (cpd)
+ (let ((class (cpd-class cpd)))
+ (if (class-name class)
+ (format nil "named ~S" (class-name class))
+ class))))
+ (mapcar
+ #'(lambda (reason)
+ (ecase (caddr reason)
+ (:super
+ (format
+ nil
+ "The class ~A appears in the supers of the class ~A."
+ (class-or-name (cadr reason))
+ (class-or-name (car reason))))
+ (:in-supers
+ (format
+ nil
+ "The class ~A follows the class ~A in the supers of the class ~A."
+ (class-or-name (cadr reason))
+ (class-or-name (car reason))
+ (class-or-name (cadddr reason))))))
+ reasons)))
+
+(defun find-cycle-reasons (all-cpds)
+ (let ((been-here ()) ; list of classes we have visited
+ (cycle-reasons ()))
+
+ (labels ((chase (path)
+ (if (memq (car path) (cdr path))
+ (record-cycle (memq (car path) (nreverse path)))
+ (unless (memq (car path) been-here)
+ (push (car path) been-here)
+ (dolist (after (cpd-after (car path)))
+ (chase (cons after path))))))
+ (record-cycle (cycle)
+ (let ((reasons ()))
+ (do* ((t1 cycle t2)
+ (t2 (cdr t1) (cdr t1)))
+ ((null t2))
+ (let ((c1 (car t1))
+ (c2 (car t2)))
+ (if (memq c2 (cpd-supers c1))
+ (push (list c1 c2 :super) reasons)
+ (dolist (cpd all-cpds)
+ (when (memq c2 (memq c1 (cpd-supers cpd)))
+ (return
+ (push (list c1 c2 :in-supers cpd) reasons)))))))
+ (push (nreverse reasons) cycle-reasons))))
+
+ (dolist (cpd all-cpds)
+ (unless (zerop (cpd-count cpd))
+ (chase (list cpd))))
+
+ cycle-reasons)))
+
--- /dev/null
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+
+;;;; This software is derived from software originally released by Xerox
+;;;; Corporation. Copyright and release statements follow. Later modifications
+;;;; to the software are in the public domain and are provided with
+;;;; absolutely no warranty. See the COPYING and CREDITS files for more
+;;;; information.
+
+;;;; copyright information from original PCL sources:
+;;;;
+;;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
+;;;; All rights reserved.
+;;;;
+;;;; Use and copying of this software and preparation of derivative works based
+;;;; upon this software are permitted. Any distribution of this software or
+;;;; derivative works must comply with all applicable United States export
+;;;; control laws.
+;;;;
+;;;; This software is made available AS IS, and Xerox Corporation makes no
+;;;; warranty about the software, its performance or its conformity to any
+;;;; specification.
+
+(in-package "SB-PCL")
+
+(sb-int:file-comment
+ "$Header$")
+\f
+;;; The built-in method combination types as taken from page 1-31 of 88-002R.
+;;; Note that the STANDARD method combination type is defined by hand in the
+;;; file combin.lisp.
+(define-method-combination + :identity-with-one-argument t)
+(define-method-combination and :identity-with-one-argument t)
+(define-method-combination append :identity-with-one-argument nil)
+(define-method-combination list :identity-with-one-argument nil)
+(define-method-combination max :identity-with-one-argument t)
+(define-method-combination min :identity-with-one-argument t)
+(define-method-combination nconc :identity-with-one-argument t)
+(define-method-combination or :identity-with-one-argument t)
+(define-method-combination progn :identity-with-one-argument t)
+
--- /dev/null
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+
+;;;; This software is derived from software originally released by Xerox
+;;;; Corporation. Copyright and release statements follow. Later modifications
+;;;; to the software are in the public domain and are provided with
+;;;; absolutely no warranty. See the COPYING and CREDITS files for more
+;;;; information.
+
+;;;; copyright information from original PCL sources:
+;;;;
+;;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
+;;;; All rights reserved.
+;;;;
+;;;; Use and copying of this software and preparation of derivative works based
+;;;; upon this software are permitted. Any distribution of this software or
+;;;; derivative works must comply with all applicable United States export
+;;;; control laws.
+;;;;
+;;;; This software is made available AS IS, and Xerox Corporation makes no
+;;;; warranty about the software, its performance or its conformity to any
+;;;; specification.
+
+(in-package "SB-PCL")
+
+(sb-int:file-comment
+ "$Header$")
+\f
+;;; MAKE-TOP-LEVEL-FORM is used by all PCL macros that appear `at top-level'.
+;;;
+;;; The original motiviation for this function was to deal with the bug in
+;;; the Genera compiler that prevents lambda expressions in top-level forms
+;;; other than DEFUN from being compiled.
+;;;
+;;; Now this function is used to grab other functionality as well. This
+;;; includes:
+;;; - Preventing the grouping of top-level forms. For example, a
+;;; DEFCLASS followed by a DEFMETHOD may not want to be grouped
+;;; into the same top-level form.
+;;; - Telling the programming environment what the pretty version
+;;; of the name of this form is. This is used by WARN.
+;;;
+;;; FIXME: It's not clear that this adds value any more. Couldn't
+;;; we just use EVAL-WHEN?
+(defun make-top-level-form (name times form)
+ (flet ((definition-name ()
+ (if (and (listp name)
+ (memq (car name)
+ '(defmethod defclass class
+ method method-combination)))
+ (format nil "~A~{ ~S~}"
+ (capitalize-words (car name) ()) (cdr name))
+ (format nil "~S" name))))
+ ;; FIXME: It appears that we're just consing up a string and then
+ ;; throwing it away?!
+ (definition-name)
+ (if (or (member 'compile times)
+ (member ':compile-toplevel times))
+ `(eval-when ,times ,form)
+ form)))
+
+(defun make-progn (&rest forms)
+ (let ((progn-form nil))
+ (labels ((collect-forms (forms)
+ (unless (null forms)
+ (collect-forms (cdr forms))
+ (if (and (listp (car forms))
+ (eq (caar forms) 'progn))
+ (collect-forms (cdar forms))
+ (push (car forms) progn-form)))))
+ (collect-forms forms)
+ (cons 'progn progn-form))))
+\f
+;;; Like the DEFMETHOD macro, the expansion of the DEFCLASS macro is fixed.
+;;; DEFCLASS always expands into a call to LOAD-DEFCLASS. Until the meta-
+;;; braid is set up, LOAD-DEFCLASS has a special definition which simply
+;;; collects all class definitions up, when the metabraid is initialized it
+;;; is done from those class definitions.
+;;;
+;;; After the metabraid has been setup, and the protocol for defining classes
+;;; has been defined, the real definition of LOAD-DEFCLASS is installed by the
+;;; file defclass.lisp
+(defmacro defclass (name direct-superclasses direct-slots &rest options)
+ (declare (indentation 2 4 3 1))
+ (expand-defclass name direct-superclasses direct-slots options))
+
+(defun expand-defclass (name supers slots options)
+ (declare (special *defclass-times* *boot-state* *the-class-structure-class*))
+ (setq supers (copy-tree supers)
+ slots (copy-tree slots)
+ options (copy-tree options))
+ (let ((metaclass 'standard-class))
+ (dolist (option options)
+ (if (not (listp option))
+ (error "~S is not a legal defclass option." option)
+ (when (eq (car option) ':metaclass)
+ (unless (legal-class-name-p (cadr option))
+ (error "The value of the :metaclass option (~S) is not a~%~
+ legal class name."
+ (cadr option)))
+ (setq metaclass
+ (case (cadr option)
+ (cl:standard-class 'standard-class)
+ (cl:structure-class 'structure-class)
+ (t (cadr option))))
+ (setf options (remove option options))
+ (return t))))
+
+ (let ((*initfunctions* ())
+ (*accessors* ()) ;Truly a crock, but we got
+ (*readers* ()) ;to have it to live nicely.
+ (*writers* ()))
+ (declare (special *initfunctions* *accessors* *readers* *writers*))
+ (let ((canonical-slots
+ (mapcar #'(lambda (spec)
+ (canonicalize-slot-specification name spec))
+ slots))
+ (other-initargs
+ (mapcar #'(lambda (option)
+ (canonicalize-defclass-option name option))
+ options))
+ (defstruct-p (and (eq *boot-state* 'complete)
+ (let ((mclass (find-class metaclass nil)))
+ (and mclass
+ (*subtypep mclass
+ *the-class-structure-class*))))))
+ (do-standard-defsetfs-for-defclass *accessors*)
+ (let ((defclass-form
+ (make-top-level-form `(defclass ,name)
+ (if defstruct-p '(:load-toplevel :execute) *defclass-times*)
+ `(progn
+ ,@(mapcar #'(lambda (x)
+ `(declaim (ftype (function (t) t) ,x)))
+ *readers*)
+ ,@(mapcar #'(lambda (x)
+ #-setf (when (consp x)
+ (setq x (get-setf-function-name (cadr x))))
+ `(declaim (ftype (function (t t) t) ,x)))
+ *writers*)
+ (let ,(mapcar #'cdr *initfunctions*)
+ (load-defclass ',name
+ ',metaclass
+ ',supers
+ (list ,@canonical-slots)
+ (list ,@(apply #'append
+ (when defstruct-p
+ '(:from-defclass-p t))
+ other-initargs))
+ ',*accessors*))))))
+ (if defstruct-p
+ (progn
+ (eval defclass-form) ; define the class now, so that
+ `(progn ; the defstruct can be compiled.
+ ,(class-defstruct-form (find-class name))
+ ,defclass-form))
+ (progn
+ (when (and (eq *boot-state* 'complete)
+ (not (member 'compile *defclass-times*)))
+ (inform-type-system-about-std-class name))
+ defclass-form)))))))
+
+(defun make-initfunction (initform)
+ (declare (special *initfunctions*))
+ (cond ((or (eq initform 't)
+ (equal initform ''t))
+ '(function true))
+ ((or (eq initform 'nil)
+ (equal initform ''nil))
+ '(function false))
+ ((or (eql initform '0)
+ (equal initform ''0))
+ '(function zero))
+ (t
+ (let ((entry (assoc initform *initfunctions* :test #'equal)))
+ (unless entry
+ (setq entry (list initform
+ (gensym)
+ `(function (lambda () ,initform))))
+ (push entry *initfunctions*))
+ (cadr entry)))))
+
+(defun canonicalize-slot-specification (class-name spec)
+ (declare (special *accessors* *readers* *writers*))
+ (cond ((and (symbolp spec)
+ (not (keywordp spec))
+ (not (memq spec '(t nil))))
+ `'(:name ,spec))
+ ((not (consp spec))
+ (error "~S is not a legal slot specification." spec))
+ ((null (cdr spec))
+ `'(:name ,(car spec)))
+ ((null (cddr spec))
+ (error "In DEFCLASS ~S, the slot specification ~S is obsolete.~%~
+ Convert it to ~S"
+ class-name spec (list (car spec) :initform (cadr spec))))
+ (t
+ (let* ((name (pop spec))
+ (readers ())
+ (writers ())
+ (initargs ())
+ (unsupplied (list nil))
+ (initform (getf spec :initform unsupplied)))
+ (doplist (key val) spec
+ (case key
+ (:accessor (push val *accessors*)
+ (push val readers)
+ (push `(setf ,val) writers))
+ (:reader (push val readers))
+ (:writer (push val writers))
+ (:initarg (push val initargs))))
+ (loop (unless (remf spec :accessor) (return)))
+ (loop (unless (remf spec :reader) (return)))
+ (loop (unless (remf spec :writer) (return)))
+ (loop (unless (remf spec :initarg) (return)))
+ (setq *writers* (append writers *writers*))
+ (setq *readers* (append readers *readers*))
+ (setq spec `(:name ',name
+ :readers ',readers
+ :writers ',writers
+ :initargs ',initargs
+ ',spec))
+ (if (eq initform unsupplied)
+ `(list* ,@spec)
+ `(list* :initfunction ,(make-initfunction initform) ,@spec))))))
+
+(defun canonicalize-defclass-option (class-name option)
+ (declare (ignore class-name))
+ (case (car option)
+ (:default-initargs
+ (let ((canonical ()))
+ (let (key val (tail (cdr option)))
+ (loop (when (null tail) (return nil))
+ (setq key (pop tail)
+ val (pop tail))
+ (push ``(,',key ,,(make-initfunction val) ,',val) canonical))
+ `(':direct-default-initargs (list ,@(nreverse canonical))))))
+ (:documentation
+ `(',(car option) ',(cadr option)))
+ (otherwise
+ `(',(car option) ',(cdr option)))))
+\f
+;;; This is the early definition of load-defclass. It just collects up
+;;; all the class definitions in a list. Later, in the file
+;;; braid1.lisp, these are actually defined.
+
+;;; Each entry in *EARLY-CLASS-DEFINITIONS* is an EARLY-CLASS-DEFINITION.
+(defparameter *early-class-definitions* ())
+
+(defun early-class-definition (class-name)
+ (or (find class-name *early-class-definitions* :key #'ecd-class-name)
+ (error "~S is not a class in *early-class-definitions*." class-name)))
+
+(defun make-early-class-definition
+ (name source metaclass
+ superclass-names canonical-slots other-initargs)
+ (list 'early-class-definition
+ name source metaclass
+ superclass-names canonical-slots other-initargs))
+
+(defun ecd-class-name (ecd) (nth 1 ecd))
+(defun ecd-source (ecd) (nth 2 ecd))
+(defun ecd-metaclass (ecd) (nth 3 ecd))
+(defun ecd-superclass-names (ecd) (nth 4 ecd))
+(defun ecd-canonical-slots (ecd) (nth 5 ecd))
+(defun ecd-other-initargs (ecd) (nth 6 ecd))
+
+(defvar *early-class-slots* nil)
+
+(defun canonical-slot-name (canonical-slot)
+ (getf canonical-slot :name))
+
+(defun early-class-slots (class-name)
+ (cdr (or (assoc class-name *early-class-slots*)
+ (let ((a (cons class-name
+ (mapcar #'canonical-slot-name
+ (early-collect-inheritance class-name)))))
+ (push a *early-class-slots*)
+ a))))
+
+(defun early-class-size (class-name)
+ (length (early-class-slots class-name)))
+
+(defun early-collect-inheritance (class-name)
+ ;;(declare (values slots cpl default-initargs direct-subclasses))
+ (let ((cpl (early-collect-cpl class-name)))
+ (values (early-collect-slots cpl)
+ cpl
+ (early-collect-default-initargs cpl)
+ (gathering1 (collecting)
+ (dolist (definition *early-class-definitions*)
+ (when (memq class-name (ecd-superclass-names definition))
+ (gather1 (ecd-class-name definition))))))))
+
+(defun early-collect-slots (cpl)
+ (let* ((definitions (mapcar #'early-class-definition cpl))
+ (super-slots (mapcar #'ecd-canonical-slots definitions))
+ (slots (apply #'append (reverse super-slots))))
+ (dolist (s1 slots)
+ (let ((name1 (canonical-slot-name s1)))
+ (dolist (s2 (cdr (memq s1 slots)))
+ (when (eq name1 (canonical-slot-name s2))
+ (error "More than one early class defines a slot with the~%~
+ name ~S. This can't work because the bootstrap~%~
+ object system doesn't know how to compute effective~%~
+ slots."
+ name1)))))
+ slots))
+
+(defun early-collect-cpl (class-name)
+ (labels ((walk (c)
+ (let* ((definition (early-class-definition c))
+ (supers (ecd-superclass-names definition)))
+ (cons c
+ (apply #'append (mapcar #'early-collect-cpl supers))))))
+ (remove-duplicates (walk class-name) :from-end nil :test #'eq)))
+
+(defun early-collect-default-initargs (cpl)
+ (let ((default-initargs ()))
+ (dolist (class-name cpl)
+ (let* ((definition (early-class-definition class-name))
+ (others (ecd-other-initargs definition)))
+ (loop (when (null others) (return nil))
+ (let ((initarg (pop others)))
+ (unless (eq initarg :direct-default-initargs)
+ (error "The defclass option ~S is not supported by the bootstrap~%~
+ object system."
+ initarg)))
+ (setq default-initargs
+ (nconc default-initargs (reverse (pop others)))))))
+ (reverse default-initargs)))
+
+(defun bootstrap-slot-index (class-name slot-name)
+ (or (position slot-name (early-class-slots class-name))
+ (error "~S not found" slot-name)))
+
+;;; bootstrap-get-slot and bootstrap-set-slot are used to access and change the
+;;; values of slots during bootstrapping. During bootstrapping, there are only
+;;; two kinds of objects whose slots we need to access, CLASSes and
+;;; SLOT-DEFINITIONs. The first argument to these functions tells whether the
+;;; object is a CLASS or a SLOT-DEFINITION.
+;;;
+;;; Note that the way this works it stores the slot in the same place in
+;;; memory that the full object system will expect to find it later. This
+;;; is critical to the bootstrapping process, the whole changeover to the
+;;; full object system is predicated on this.
+;;;
+;;; One important point is that the layout of standard classes and standard
+;;; slots must be computed the same way in this file as it is by the full
+;;; object system later.
+(defmacro bootstrap-get-slot (type object slot-name)
+ `(instance-ref (get-slots ,object) (bootstrap-slot-index ,type ,slot-name)))
+(defun bootstrap-set-slot (type object slot-name new-value)
+ (setf (bootstrap-get-slot type object slot-name) new-value))
+
+(defun early-class-name (class)
+ (bootstrap-get-slot 'class class 'name))
+
+(defun early-class-precedence-list (class)
+ (bootstrap-get-slot 'pcl-class class 'class-precedence-list))
+
+(defun early-class-name-of (instance)
+ (early-class-name (class-of instance)))
+
+(defun early-class-slotds (class)
+ (bootstrap-get-slot 'slot-class class 'slots))
+
+(defun early-slot-definition-name (slotd)
+ (bootstrap-get-slot 'standard-effective-slot-definition slotd 'name))
+
+(defun early-slot-definition-location (slotd)
+ (bootstrap-get-slot 'standard-effective-slot-definition slotd 'location))
+
+(defun early-accessor-method-slot-name (method)
+ (bootstrap-get-slot 'standard-accessor-method method 'slot-name))
+
+(unless (fboundp 'class-name-of)
+ (setf (symbol-function 'class-name-of)
+ (symbol-function 'early-class-name-of)))
+;;; FIXME: Can we then delete EARLY-CLASS-NAME-OF?
+
+(defun early-class-direct-subclasses (class)
+ (bootstrap-get-slot 'class class 'direct-subclasses))
+
+(declaim (notinline load-defclass))
+(defun load-defclass
+ (name metaclass supers canonical-slots canonical-options accessor-names)
+ (setq supers (copy-tree supers)
+ canonical-slots (copy-tree canonical-slots)
+ canonical-options (copy-tree canonical-options))
+ (do-standard-defsetfs-for-defclass accessor-names)
+ (when (eq metaclass 'standard-class)
+ (inform-type-system-about-std-class name))
+ (let ((ecd
+ (make-early-class-definition name
+ *load-truename*
+ metaclass
+ supers
+ canonical-slots
+ canonical-options))
+ (existing
+ (find name *early-class-definitions* :key #'ecd-class-name)))
+ (setq *early-class-definitions*
+ (cons ecd (remove existing *early-class-definitions*)))
+ ecd))
+
--- /dev/null
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+
+;;;; This software is derived from software originally released by Xerox
+;;;; Corporation. Copyright and release statements follow. Later modifications
+;;;; to the software are in the public domain and are provided with
+;;;; absolutely no warranty. See the COPYING and CREDITS files for more
+;;;; information.
+
+;;;; copyright information from original PCL sources:
+;;;;
+;;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
+;;;; All rights reserved.
+;;;;
+;;;; Use and copying of this software and preparation of derivative works based
+;;;; upon this software are permitted. Any distribution of this software or
+;;;; derivative works must comply with all applicable United States export
+;;;; control laws.
+;;;;
+;;;; This software is made available AS IS, and Xerox Corporation makes no
+;;;; warranty about the software, its performance or its conformity to any
+;;;; specification.
+
+(in-package "SB-PCL")
+
+(sb-int:file-comment
+ "$Header$")
+\f
+(defmacro define-method-combination (&whole form &rest args)
+ (declare (ignore args))
+ (if (and (cddr form)
+ (listp (caddr form)))
+ (expand-long-defcombin form)
+ (expand-short-defcombin form)))
+\f
+;;;; standard method combination
+
+;;; The STANDARD method combination type is implemented directly by the class
+;;; STANDARD-METHOD-COMBINATION. The method on COMPUTE-EFFECTIVE-METHOD does
+;;; standard method combination directly and is defined by hand in the file
+;;; combin.lisp. The method for FIND-METHOD-COMBINATION must appear in this
+;;; file for bootstrapping reasons.
+;;;
+;;; A commented out copy of this definition appears in combin.lisp.
+;;; If you change this definition here, be sure to change it there
+;;; also.
+(defmethod find-method-combination ((generic-function generic-function)
+ (type (eql 'standard))
+ options)
+ (when options
+ (method-combination-error
+ "The method combination type STANDARD accepts no options."))
+ *standard-method-combination*)
+\f
+;;;; short method combinations
+;;;;
+;;;; Short method combinations all follow the same rule for computing the
+;;;; effective method. So, we just implement that rule once. Each short
+;;;; method combination object just reads the parameters out of the object
+;;;; and runs the same rule.
+
+(defclass short-method-combination (standard-method-combination)
+ ((operator
+ :reader short-combination-operator
+ :initarg :operator)
+ (identity-with-one-argument
+ :reader short-combination-identity-with-one-argument
+ :initarg :identity-with-one-argument))
+ (:predicate-name short-method-combination-p))
+
+(defun expand-short-defcombin (whole)
+ (let* ((type (cadr whole))
+ (documentation
+ (getf (cddr whole) :documentation ""))
+ (identity-with-one-arg
+ (getf (cddr whole) :identity-with-one-argument nil))
+ (operator
+ (getf (cddr whole) :operator type)))
+ (make-top-level-form `(define-method-combination ,type)
+ '(:load-toplevel :execute)
+ `(load-short-defcombin
+ ',type ',operator ',identity-with-one-arg ',documentation))))
+
+(defun load-short-defcombin (type operator ioa doc)
+ (let* ((truename *load-truename*)
+ (specializers
+ (list (find-class 'generic-function)
+ (intern-eql-specializer type)
+ *the-class-t*))
+ (old-method
+ (get-method #'find-method-combination () specializers nil))
+ (new-method nil))
+ (setq new-method
+ (make-instance 'standard-method
+ :qualifiers ()
+ :specializers specializers
+ :lambda-list '(generic-function type options)
+ :function #'(lambda(args nms &rest cm-args)
+ (declare (ignore nms cm-args))
+ (apply
+ #'(lambda (gf type options)
+ (declare (ignore gf))
+ (do-short-method-combination
+ type options operator ioa new-method doc))
+ args))
+ :definition-source `((define-method-combination ,type) ,truename)))
+ (when old-method
+ (remove-method #'find-method-combination old-method))
+ (add-method #'find-method-combination new-method)))
+
+(defun do-short-method-combination (type options operator ioa method doc)
+ (cond ((null options) (setq options '(:most-specific-first)))
+ ((equal options '(:most-specific-first)))
+ ((equal options '(:most-specific-last)))
+ (t
+ (method-combination-error
+ "Illegal options to a short method combination type.~%~
+ The method combination type ~S accepts one option which~%~
+ must be either :MOST-SPECIFIC-FIRST or :MOST-SPECIFIC-LAST."
+ type)))
+ (make-instance 'short-method-combination
+ :type type
+ :options options
+ :operator operator
+ :identity-with-one-argument ioa
+ :definition-source method
+ :documentation doc))
+
+(defmethod compute-effective-method ((generic-function generic-function)
+ (combin short-method-combination)
+ applicable-methods)
+ (let ((type (method-combination-type combin))
+ (operator (short-combination-operator combin))
+ (ioa (short-combination-identity-with-one-argument combin))
+ (around ())
+ (primary ()))
+ (dolist (m applicable-methods)
+ (let ((qualifiers (method-qualifiers m)))
+ (flet ((lose (method why)
+ (invalid-method-error
+ method
+ "The method ~S ~A.~%~
+ The method combination type ~S was defined with the~%~
+ short form of DEFINE-METHOD-COMBINATION and so requires~%~
+ all methods have either the single qualifier ~S or the~%~
+ single qualifier :AROUND."
+ method why type type)))
+ (cond ((null qualifiers)
+ (lose m "has no qualifiers"))
+ ((cdr qualifiers)
+ (lose m "has more than one qualifier"))
+ ((eq (car qualifiers) :around)
+ (push m around))
+ ((eq (car qualifiers) type)
+ (push m primary))
+ (t
+ (lose m "has an illegal qualifier"))))))
+ (setq around (nreverse around)
+ primary (nreverse primary))
+ (let ((main-method
+ (if (and (null (cdr primary))
+ (not (null ioa)))
+ `(call-method ,(car primary) ())
+ `(,operator ,@(mapcar #'(lambda (m) `(call-method ,m ()))
+ primary)))))
+ (cond ((null primary)
+ `(error "No ~S methods for the generic function ~S."
+ ',type ',generic-function))
+ ((null around) main-method)
+ (t
+ `(call-method ,(car around)
+ (,@(cdr around) (make-method ,main-method))))))))
+\f
+;;;; long method combinations
+
+(defclass long-method-combination (standard-method-combination)
+ ((function :initarg :function
+ :reader long-method-combination-function)))
+
+(defun expand-long-defcombin (form)
+ (let ((type (cadr form))
+ (lambda-list (caddr form))
+ (method-group-specifiers (cadddr form))
+ (body (cddddr form))
+ (arguments-option ())
+ (gf-var nil))
+ (when (and (consp (car body)) (eq (caar body) :arguments))
+ (setq arguments-option (cdr (pop body))))
+ (when (and (consp (car body)) (eq (caar body) :generic-function))
+ (setq gf-var (cadr (pop body))))
+ (multiple-value-bind (documentation function)
+ (make-long-method-combination-function
+ type lambda-list method-group-specifiers arguments-option gf-var
+ body)
+ (make-top-level-form `(define-method-combination ,type)
+ '(:load-toplevel :execute)
+ `(load-long-defcombin ',type ',documentation #',function)))))
+
+(defvar *long-method-combination-functions* (make-hash-table :test 'eq))
+
+(defun load-long-defcombin (type doc function)
+ (let* ((specializers
+ (list (find-class 'generic-function)
+ (intern-eql-specializer type)
+ *the-class-t*))
+ (old-method
+ (get-method #'find-method-combination () specializers nil))
+ (new-method
+ (make-instance 'standard-method
+ :qualifiers ()
+ :specializers specializers
+ :lambda-list '(generic-function type options)
+ :function #'(lambda (args nms &rest cm-args)
+ (declare (ignore nms cm-args))
+ (apply
+ #'(lambda (generic-function type options)
+ (declare (ignore generic-function options))
+ (make-instance 'long-method-combination
+ :type type
+ :documentation doc))
+ args))
+ :definition-source `((define-method-combination ,type)
+ ,*load-truename*))))
+ (setf (gethash type *long-method-combination-functions*) function)
+ (when old-method (remove-method #'find-method-combination old-method))
+ (add-method #'find-method-combination new-method)))
+
+(defmethod compute-effective-method ((generic-function generic-function)
+ (combin long-method-combination)
+ applicable-methods)
+ (funcall (gethash (method-combination-type combin)
+ *long-method-combination-functions*)
+ generic-function
+ combin
+ applicable-methods))
+
+(defun make-long-method-combination-function
+ (type ll method-group-specifiers arguments-option gf-var body)
+ ;;(declare (values documentation function))
+ (declare (ignore type))
+ (multiple-value-bind (documentation declarations real-body)
+ (extract-declarations body)
+
+ (let ((wrapped-body
+ (wrap-method-group-specifier-bindings method-group-specifiers
+ declarations
+ real-body)))
+ (when gf-var
+ (push `(,gf-var .generic-function.) (cadr wrapped-body)))
+
+ (when arguments-option
+ (setq wrapped-body (deal-with-arguments-option wrapped-body
+ arguments-option)))
+
+ (when ll
+ (setq wrapped-body
+ `(apply #'(lambda ,ll ,wrapped-body)
+ (method-combination-options .method-combination.))))
+
+ (values
+ documentation
+ `(lambda (.generic-function. .method-combination. .applicable-methods.)
+ (progn .generic-function. .method-combination. .applicable-methods.)
+ (block .long-method-combination-function. ,wrapped-body))))))
+
+;; parse-method-group-specifiers parse the method-group-specifiers
+
+(defun wrap-method-group-specifier-bindings
+ (method-group-specifiers declarations real-body)
+ (with-gathering ((names (collecting))
+ (specializer-caches (collecting))
+ (cond-clauses (collecting))
+ (required-checks (collecting))
+ (order-cleanups (collecting)))
+ (dolist (method-group-specifier method-group-specifiers)
+ (multiple-value-bind (name tests description order required)
+ (parse-method-group-specifier method-group-specifier)
+ (declare (ignore description))
+ (let ((specializer-cache (gensym)))
+ (gather name names)
+ (gather specializer-cache specializer-caches)
+ (gather `((or ,@tests)
+ (if (equal ,specializer-cache .specializers.)
+ (return-from .long-method-combination-function.
+ '(error "More than one method of type ~S ~
+ with the same specializers."
+ ',name))
+ (setq ,specializer-cache .specializers.))
+ (push .method. ,name))
+ cond-clauses)
+ (when required
+ (gather `(when (null ,name)
+ (return-from .long-method-combination-function.
+ '(error "No ~S methods." ',name)))
+ required-checks))
+ (loop (unless (and (constantp order)
+ (neq order (setq order (eval order))))
+ (return t)))
+ (gather (cond ((eq order :most-specific-first)
+ `(setq ,name (nreverse ,name)))
+ ((eq order :most-specific-last) ())
+ (t
+ `(ecase ,order
+ (:most-specific-first
+ (setq ,name (nreverse ,name)))
+ (:most-specific-last))))
+ order-cleanups))))
+ `(let (,@names ,@specializer-caches)
+ ,@declarations
+ (dolist (.method. .applicable-methods.)
+ (let ((.qualifiers. (method-qualifiers .method.))
+ (.specializers. (method-specializers .method.)))
+ (progn .qualifiers. .specializers.)
+ (cond ,@cond-clauses)))
+ ,@required-checks
+ ,@order-cleanups
+ ,@real-body)))
+
+(defun parse-method-group-specifier (method-group-specifier)
+ ;;(declare (values name tests description order required))
+ (let* ((name (pop method-group-specifier))
+ (patterns ())
+ (tests
+ (gathering1 (collecting)
+ (block collect-tests
+ (loop
+ (if (or (null method-group-specifier)
+ (memq (car method-group-specifier)
+ '(:description :order :required)))
+ (return-from collect-tests t)
+ (let ((pattern (pop method-group-specifier)))
+ (push pattern patterns)
+ (gather1 (parse-qualifier-pattern name pattern)))))))))
+ (values name
+ tests
+ (getf method-group-specifier :description
+ (make-default-method-group-description patterns))
+ (getf method-group-specifier :order :most-specific-first)
+ (getf method-group-specifier :required nil))))
+
+(defun parse-qualifier-pattern (name pattern)
+ (cond ((eq pattern '()) `(null .qualifiers.))
+ ((eq pattern '*) 't)
+ ((symbolp pattern) `(,pattern .qualifiers.))
+ ((listp pattern) `(qualifier-check-runtime ',pattern .qualifiers.))
+ (t (error "In the method group specifier ~S,~%~
+ ~S isn't a valid qualifier pattern."
+ name pattern))))
+
+(defun qualifier-check-runtime (pattern qualifiers)
+ (loop (cond ((and (null pattern) (null qualifiers))
+ (return t))
+ ((eq pattern '*) (return t))
+ ((and pattern qualifiers (eq (car pattern) (car qualifiers)))
+ (pop pattern)
+ (pop qualifiers))
+ (t (return nil)))))
+
+(defun make-default-method-group-description (patterns)
+ (if (cdr patterns)
+ (format nil
+ "methods matching one of the patterns: ~{~S, ~} ~S"
+ (butlast patterns) (car (last patterns)))
+ (format nil
+ "methods matching the pattern: ~S"
+ (car patterns))))
+
+;;; This baby is a complete mess. I can't believe we put it in this
+;;; way. No doubt this is a large part of what drives MLY crazy.
+;;;
+;;; At runtime (when the effective-method is run), we bind an intercept
+;;; lambda-list to the arguments to the generic function.
+;;;
+;;; At compute-effective-method time, the symbols in the :arguments
+;;; option are bound to the symbols in the intercept lambda list.
+(defun deal-with-arguments-option (wrapped-body arguments-option)
+ (let* ((intercept-lambda-list
+ (gathering1 (collecting)
+ (dolist (arg arguments-option)
+ (if (memq arg lambda-list-keywords)
+ (gather1 arg)
+ (gather1 (gensym))))))
+ (intercept-rebindings
+ (gathering1 (collecting)
+ (iterate ((arg (list-elements arguments-option))
+ (int (list-elements intercept-lambda-list)))
+ (unless (memq arg lambda-list-keywords)
+ (gather1 `(,arg ',int)))))))
+
+ (setf (cadr wrapped-body)
+ (append intercept-rebindings (cadr wrapped-body)))
+
+ ;; Be sure to fill out the intercept lambda list so that it can
+ ;; be too short if it wants to.
+ (cond ((memq '&rest intercept-lambda-list))
+ ((memq '&allow-other-keys intercept-lambda-list))
+ ((memq '&key intercept-lambda-list)
+ (setq intercept-lambda-list
+ (append intercept-lambda-list '(&allow-other-keys))))
+ (t
+ (setq intercept-lambda-list
+ (append intercept-lambda-list '(&rest .ignore.)))))
+
+ `(let ((inner-result. ,wrapped-body))
+ `(apply #'(lambda ,',intercept-lambda-list
+ ,,(when (memq '.ignore. intercept-lambda-list)
+ ''(declare (ignore .ignore.)))
+ ,inner-result.)
+ .combined-method-args.))))
--- /dev/null
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+
+;;;; This software is derived from software originally released by Xerox
+;;;; Corporation. Copyright and release statements follow. Later modifications
+;;;; to the software are in the public domain and are provided with
+;;;; absolutely no warranty. See the COPYING and CREDITS files for more
+;;;; information.
+
+;;;; copyright information from original PCL sources:
+;;;;
+;;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
+;;;; All rights reserved.
+;;;;
+;;;; Use and copying of this software and preparation of derivative works based
+;;;; upon this software are permitted. Any distribution of this software or
+;;;; derivative works must comply with all applicable United States export
+;;;; control laws.
+;;;;
+;;;; This software is made available AS IS, and Xerox Corporation makes no
+;;;; warranty about the software, its performance or its conformity to any
+;;;; specification.
+
+(in-package "SB-PCL")
+
+(sb-int:file-comment
+ "$Header$")
+\f
+(eval-when (:compile-toplevel :load-toplevel :execute)
+
+;;; FIXME: These are non-ANSI hacks which it would be nice to get rid of.
+(defvar *defclass-times* '(:load-toplevel :execute)) ; You probably have
+ ; to change this if you use
+ ; DEFCONSTRUCTOR.
+(defvar *defmethod-times* '(:load-toplevel :execute))
+(defvar *defgeneric-times* '(:load-toplevel :execute))
+
+) ; EVAL-WHEN
+
+(eval-when (:load-toplevel :execute)
+ (when (eq *boot-state* 'complete)
+ (error "Trying to load (or compile) PCL in an environment in which it~%~
+ has already been loaded. This doesn't work, you will have to~%~
+ get a fresh lisp (reboot) and then load PCL."))
+ (when *boot-state*
+ (cerror "Try loading (or compiling) PCL anyways."
+ "Trying to load (or compile) PCL in an environment in which it~%~
+ has already been partially loaded. This may not work, you may~%~
+ need to get a fresh lisp (reboot) and then load PCL."))
+ ) ; EVAL-WHEN
+\f
+;;; This is like fdefinition on the Lispm. If Common Lisp had something like
+;;; function specs I wouldn't need this. On the other hand, I don't like the
+;;; way this really works so maybe function specs aren't really right either?
+;;;
+;;; I also don't understand the real implications of a Lisp-1 on this sort of
+;;; thing. Certainly some of the lossage in all of this is because these
+;;; SPECs name global definitions.
+;;;
+;;; Note that this implementation is set up so that an implementation which
+;;; has a 'real' function spec mechanism can use that instead and in that way
+;;; get rid of setf generic function names.
+(defmacro parse-gspec (spec
+ (non-setf-var . non-setf-case)
+ (setf-var . setf-case))
+ (declare (indentation 1 1))
+ #+setf (declare (ignore setf-var setf-case))
+ (once-only (spec)
+ `(cond (#-setf (symbolp ,spec) #+setf t
+ (let ((,non-setf-var ,spec)) ,@non-setf-case))
+ #-setf
+ ((and (listp ,spec)
+ (eq (car ,spec) 'setf)
+ (symbolp (cadr ,spec)))
+ (let ((,setf-var (cadr ,spec))) ,@setf-case))
+ #-setf
+ (t
+ (error
+ "Can't understand ~S as a generic function specifier.~%~
+ It must be either a symbol which can name a function or~%~
+ a list like ~S, where the car is the symbol ~S and the cadr~%~
+ is a symbol which can name a generic function."
+ ,spec '(setf <foo>) 'setf)))))
+
+;;; If symbol names a function which is traced or advised, return the
+;;; unadvised, traced etc. definition. This lets me get at the generic
+;;; function object even when it is traced.
+(defun unencapsulated-fdefinition (symbol)
+ (symbol-function symbol))
+
+;;; If symbol names a function which is traced or advised, redefine
+;;; the `real' definition without affecting the advise.
+(defun fdefine-carefully (name new-definition)
+ (progn
+ (sb-c::%%defun name new-definition nil)
+ (sb-c::note-name-defined name :function)
+ new-definition)
+ (setf (symbol-function name) new-definition))
+
+(defun gboundp (spec)
+ (parse-gspec spec
+ (name (fboundp name))
+ (name (fboundp (get-setf-function-name name)))))
+
+(defun gmakunbound (spec)
+ (parse-gspec spec
+ (name (fmakunbound name))
+ (name (fmakunbound (get-setf-function-name name)))))
+
+(defun gdefinition (spec)
+ (parse-gspec spec
+ (name (or #-setf (macro-function name) ;??
+ (unencapsulated-fdefinition name)))
+ (name (unencapsulated-fdefinition (get-setf-function-name name)))))
+
+(defun #-setf SETF\ SB-PCL\ GDEFINITION #+setf (setf gdefinition) (new-value
+ spec)
+ (parse-gspec spec
+ (name (fdefine-carefully name new-value))
+ (name (fdefine-carefully (get-setf-function-name name) new-value))))
+\f
+(declaim (special *the-class-t*
+ *the-class-vector* *the-class-symbol*
+ *the-class-string* *the-class-sequence*
+ *the-class-rational* *the-class-ratio*
+ *the-class-number* *the-class-null* *the-class-list*
+ *the-class-integer* *the-class-float* *the-class-cons*
+ *the-class-complex* *the-class-character*
+ *the-class-bit-vector* *the-class-array*
+ *the-class-stream*
+
+ *the-class-slot-object*
+ *the-class-structure-object*
+ *the-class-std-object*
+ *the-class-standard-object*
+ *the-class-funcallable-standard-object*
+ *the-class-class*
+ *the-class-generic-function*
+ *the-class-built-in-class*
+ *the-class-slot-class*
+ *the-class-structure-class*
+ *the-class-std-class*
+ *the-class-standard-class*
+ *the-class-funcallable-standard-class*
+ *the-class-method*
+ *the-class-standard-method*
+ *the-class-standard-reader-method*
+ *the-class-standard-writer-method*
+ *the-class-standard-boundp-method*
+ *the-class-standard-generic-function*
+ *the-class-standard-effective-slot-definition*
+
+ *the-eslotd-standard-class-slots*
+ *the-eslotd-funcallable-standard-class-slots*))
+
+(declaim (special *the-wrapper-of-t*
+ *the-wrapper-of-vector* *the-wrapper-of-symbol*
+ *the-wrapper-of-string* *the-wrapper-of-sequence*
+ *the-wrapper-of-rational* *the-wrapper-of-ratio*
+ *the-wrapper-of-number* *the-wrapper-of-null*
+ *the-wrapper-of-list* *the-wrapper-of-integer*
+ *the-wrapper-of-float* *the-wrapper-of-cons*
+ *the-wrapper-of-complex* *the-wrapper-of-character*
+ *the-wrapper-of-bit-vector* *the-wrapper-of-array*))
+\f
+;;;; type specifier hackery
+
+;;; internal to this file.
+(defun coerce-to-class (class &optional make-forward-referenced-class-p)
+ (if (symbolp class)
+ (or (find-class class (not make-forward-referenced-class-p))
+ (ensure-class class))
+ class))
+
+;;; Interface
+(defun specializer-from-type (type &aux args)
+ (when (consp type)
+ (setq args (cdr type) type (car type)))
+ (cond ((symbolp type)
+ (or (and (null args) (find-class type))
+ (ecase type
+ (class (coerce-to-class (car args)))
+ (prototype (make-instance 'class-prototype-specializer
+ :object (coerce-to-class (car args))))
+ (class-eq (class-eq-specializer (coerce-to-class (car args))))
+ (eql (intern-eql-specializer (car args))))))
+ ((and (null args) (typep type 'cl:class))
+ (or (sb-kernel:class-pcl-class type)
+ (find-structure-class (cl:class-name type))))
+ ((specializerp type) type)))
+
+;;; interface
+(defun type-from-specializer (specl)
+ (cond ((eq specl 't)
+ 't)
+ ((consp specl)
+ (unless (member (car specl) '(class prototype class-eq eql))
+ (error "~S is not a legal specializer type." specl))
+ specl)
+ ((progn
+ (when (symbolp specl)
+ ;;maybe (or (find-class specl nil) (ensure-class specl)) instead?
+ (setq specl (find-class specl)))
+ (or (not (eq *boot-state* 'complete))
+ (specializerp specl)))
+ (specializer-type specl))
+ (t
+ (error "~S is neither a type nor a specializer." specl))))
+
+(defun type-class (type)
+ (declare (special *the-class-t*))
+ (setq type (type-from-specializer type))
+ (if (atom type)
+ (if (eq type 't)
+ *the-class-t*
+ (error "bad argument to type-class"))
+ (case (car type)
+ (eql (class-of (cadr type)))
+ (prototype (class-of (cadr type))) ;?
+ (class-eq (cadr type))
+ (class (cadr type)))))
+
+(defun class-eq-type (class)
+ (specializer-type (class-eq-specializer class)))
+
+(defun inform-type-system-about-std-class (name)
+ (let ((predicate-name (make-type-predicate-name name)))
+ (setf (gdefinition predicate-name)
+ (make-type-predicate name))
+ (do-satisfies-deftype name predicate-name)))
+
+(defun make-type-predicate (name)
+ (let ((cell (find-class-cell name)))
+ #'(lambda (x)
+ (funcall (the function (find-class-cell-predicate cell)) x))))
+
+;This stuff isn't right. Good thing it isn't used.
+;The satisfies predicate has to be a symbol. There is no way to
+;construct such a symbol from a class object if class names change.
+(defun class-predicate (class)
+ (when (symbolp class) (setq class (find-class class)))
+ #'(lambda (object) (memq class (class-precedence-list (class-of object)))))
+
+(defun make-class-eq-predicate (class)
+ (when (symbolp class) (setq class (find-class class)))
+ #'(lambda (object) (eq class (class-of object))))
+
+(defun make-eql-predicate (eql-object)
+ #'(lambda (object) (eql eql-object object)))
+
+#|| ; The argument to satisfies must be a symbol.
+(deftype class (&optional class)
+ (if class
+ `(satisfies ,(class-predicate class))
+ `(satisfies ,(class-predicate 'class))))
+
+(deftype class-eq (class)
+ `(satisfies ,(make-class-eq-predicate class)))
+||#
+
+;;; internal to this file
+;;;
+;;; These functions are a pale imitiation of their namesake. They accept
+;;; class objects or types where they should.
+(defun *normalize-type (type)
+ (cond ((consp type)
+ (if (member (car type) '(not and or))
+ `(,(car type) ,@(mapcar #'*normalize-type (cdr type)))
+ (if (null (cdr type))
+ (*normalize-type (car type))
+ type)))
+ ((symbolp type)
+ (let ((class (find-class type nil)))
+ (if class
+ (let ((type (specializer-type class)))
+ (if (listp type) type `(,type)))
+ `(,type))))
+ ((or (not (eq *boot-state* 'complete))
+ (specializerp type))
+ (specializer-type type))
+ (t
+ (error "~S is not a type." type))))
+
+;;; Not used...
+#+nil
+(defun unparse-type-list (tlist)
+ (mapcar #'unparse-type tlist))
+
+;;; Not used...
+#+nil
+(defun unparse-type (type)
+ (if (atom type)
+ (if (specializerp type)
+ (unparse-type (specializer-type type))
+ type)
+ (case (car type)
+ (eql type)
+ (class-eq `(class-eq ,(class-name (cadr type))))
+ (class (class-name (cadr type)))
+ (t `(,(car type) ,@(unparse-type-list (cdr type)))))))
+
+;;; internal to this file...
+(defun convert-to-system-type (type)
+ (case (car type)
+ ((not and or) `(,(car type) ,@(mapcar #'convert-to-system-type
+ (cdr type))))
+ ((class class-eq) ; class-eq is impossible to do right
+ (sb-kernel:layout-class (class-wrapper (cadr type))))
+ (eql type)
+ (t (if (null (cdr type))
+ (car type)
+ type))))
+
+;;; not used...
+#+nil
+(defun *typep (object type)
+ (setq type (*normalize-type type))
+ (cond ((member (car type) '(eql wrapper-eq class-eq class))
+ (specializer-applicable-using-type-p type `(eql ,object)))
+ ((eq (car type) 'not)
+ (not (*typep object (cadr type))))
+ (t
+ (typep object (convert-to-system-type type)))))
+
+;;; Writing the missing NOT and AND clauses will improve
+;;; the quality of code generated by generate-discrimination-net, but
+;;; calling subtypep in place of just returning (values nil nil) can be
+;;; very slow. *SUBTYPEP is used by PCL itself, and must be fast.
+(defun *subtypep (type1 type2)
+ (if (equal type1 type2)
+ (values t t)
+ (if (eq *boot-state* 'early)
+ (values (eq type1 type2) t)
+ (let ((*in-precompute-effective-methods-p* t))
+ (declare (special *in-precompute-effective-methods-p*))
+ ;; *in-precompute-effective-methods-p* is not a good name.
+ ;; It changes the way class-applicable-using-class-p works.
+ (setq type1 (*normalize-type type1))
+ (setq type2 (*normalize-type type2))
+ (case (car type2)
+ (not
+ (values nil nil)) ; Should improve this.
+ (and
+ (values nil nil)) ; Should improve this.
+ ((eql wrapper-eq class-eq class)
+ (multiple-value-bind (app-p maybe-app-p)
+ (specializer-applicable-using-type-p type2 type1)
+ (values app-p (or app-p (not maybe-app-p)))))
+ (t
+ (subtypep (convert-to-system-type type1)
+ (convert-to-system-type type2))))))))
+
+(defun do-satisfies-deftype (name predicate)
+ (declare (ignore name predicate)))
+
+(defun make-type-predicate-name (name &optional kind)
+ (if (symbol-package name)
+ (intern (format nil
+ "~@[~A ~]TYPE-PREDICATE ~A ~A"
+ kind
+ (package-name (symbol-package name))
+ (symbol-name name))
+ *pcl-package*)
+ (make-symbol (format nil
+ "~@[~A ~]TYPE-PREDICATE ~A"
+ kind
+ (symbol-name name)))))
+\f
+(defvar *built-in-class-symbols* ())
+(defvar *built-in-wrapper-symbols* ())
+
+(defun get-built-in-class-symbol (class-name)
+ (or (cadr (assq class-name *built-in-class-symbols*))
+ (let ((symbol (intern (format nil
+ "*THE-CLASS-~A*"
+ (symbol-name class-name))
+ *pcl-package*)))
+ (push (list class-name symbol) *built-in-class-symbols*)
+ symbol)))
+
+(defun get-built-in-wrapper-symbol (class-name)
+ (or (cadr (assq class-name *built-in-wrapper-symbols*))
+ (let ((symbol (intern (format nil
+ "*THE-WRAPPER-OF-~A*"
+ (symbol-name class-name))
+ *pcl-package*)))
+ (push (list class-name symbol) *built-in-wrapper-symbols*)
+ symbol)))
+\f
+(pushnew 'class *variable-declarations*)
+(pushnew 'variable-rebinding *variable-declarations*)
+
+(defun variable-class (var env)
+ (caddr (variable-declaration 'class var env)))
+
+(defvar *name->class->slotd-table* (make-hash-table))
+
+;;; This is used by combined methods to communicate the next methods to
+;;; the methods they call. This variable is captured by a lexical variable
+;;; of the methods to give it the proper lexical scope.
+(defvar *next-methods* nil)
+
+(defvar *not-an-eql-specializer* '(not-an-eql-specializer))
+
+(defvar *umi-gfs*)
+(defvar *umi-complete-classes*)
+(defvar *umi-reorder*)
+
+(defvar *invalidate-discriminating-function-force-p* ())
+(defvar *invalid-dfuns-on-stack* ())
+
+(defvar *standard-method-combination*)
+
+(defvar *slotd-unsupplied* (list '*slotd-unsupplied*)) ;***
+\f
+(defmacro define-gf-predicate (predicate-name &rest classes)
+ `(progn
+ (defmethod ,predicate-name ((x t)) nil)
+ ,@(mapcar #'(lambda (c) `(defmethod ,predicate-name ((x ,c)) t))
+ classes)))
+
+(defun make-class-predicate-name (name)
+ (intern (format nil "~A::~A class predicate"
+ (package-name (symbol-package name))
+ name)
+ *pcl-package*))
+
+(defun plist-value (object name)
+ (getf (object-plist object) name))
+
+(defun #-setf SETF\ SB-PCL\ PLIST-VALUE #+setf (setf plist-value) (new-value
+ object
+ name)
+ (if new-value
+ (setf (getf (object-plist object) name) new-value)
+ (progn
+ (remf (object-plist object) name)
+ nil)))
+\f
+;;;; built-in classes
+
+;;; FIXME: This was the portable PCL way of setting up
+;;; *BUILT-IN-CLASSES*, but in SBCL (as in CMU CL) it's almost
+;;; entirely wasted motion, since it's immediately overwritten by a
+;;; result mostly derived from SB-KERNEL::*BUILT-IN-CLASSES*. However,
+;;; we can't just delete it, since the fifth element from each entry
+;;; (a prototype of the class) is still in the final result. It would
+;;; be nice to clean this up so that the other, never-used stuff is
+;;; gone, perhaps finding a tidier way to represent examples of each
+;;; class, too.
+;;;
+;;; FIXME: This can probably be blown away after bootstrapping.
+;;; And SB-KERNEL::*BUILT-IN-CLASSES*, too..
+#|
+(defvar *built-in-classes*
+ ;; name supers subs cdr of cpl
+ ;; prototype
+ '(;(t () (number sequence array character symbol) ())
+ (number (t) (complex float rational) (t))
+ (complex (number) () (number t)
+ #c(1 1))
+ (float (number) () (number t)
+ 1.0)
+ (rational (number) (integer ratio) (number t))
+ (integer (rational) () (rational number t)
+ 1)
+ (ratio (rational) () (rational number t)
+ 1/2)
+
+ (sequence (t) (list vector) (t))
+ (list (sequence) (cons null) (sequence t))
+ (cons (list) () (list sequence t)
+ (nil))
+
+ (array (t) (vector) (t)
+ #2A((nil)))
+ (vector (array
+ sequence) (string bit-vector) (array sequence t)
+ #())
+ (string (vector) () (vector array sequence t)
+ "")
+ (bit-vector (vector) () (vector array sequence t)
+ #*1)
+ (character (t) () (t)
+ #\c)
+
+ (symbol (t) (null) (t)
+ symbol)
+ (null (symbol
+ list) () (symbol list sequence t)
+ nil)))
+|#
+
+;;; Grovel over SB-KERNEL::*BUILT-IN-CLASSES* in order to set
+;;; SB-PCL:*BUILT-IN-CLASSES*.
+(sb-int:/show "about to set up SB-PCL::*BUILT-IN-CLASSES*")
+(defvar *built-in-classes*
+ (labels ((direct-supers (class)
+ (sb-int:/show "entering DIRECT-SUPERS" (sb-kernel::class-name class))
+ (if (typep class 'cl:built-in-class)
+ (sb-kernel:built-in-class-direct-superclasses class)
+ (let ((inherits (sb-kernel:layout-inherits
+ (sb-kernel:class-layout class))))
+ (sb-int:/show inherits)
+ (list (svref inherits (1- (length inherits)))))))
+ (direct-subs (class)
+ (sb-int:/show "entering DIRECT-SUBS" (sb-kernel::class-name class))
+ (sb-int:collect ((res))
+ (let ((subs (sb-kernel:class-subclasses class)))
+ (sb-int:/show subs)
+ (when subs
+ (sb-int:dohash (sub v subs)
+ (declare (ignore v))
+ (sb-int:/show sub)
+ (when (member class (direct-supers sub))
+ (res sub)))))
+ (res)))
+ (prototype (class-name)
+ (let ((assoc (assoc class-name
+ '((complex . #c(1 1))
+ (float . 1.0)
+ (integer . 1)
+ (ratio . 1/2)
+ (sequence . nil)
+ (list . nil)
+ (cons . (nil))
+ (array . #2a((nil)))
+ (vector . #())
+ (string . "")
+ (bit-vector . #*1)
+ (character . #\c)
+ (symbol . symbol)
+ (null . nil)))))
+ (if assoc
+ (cdr assoc)
+ ;; This is the default prototype value which was
+ ;; used, without explanation, by the CMU CL code
+ ;; we're derived from. Evidently it's safe in all
+ ;; relevant cases.
+ 42))))
+ (mapcar (lambda (kernel-bic-entry)
+ (sb-int:/show "setting up" kernel-bic-entry)
+ (let* ((name (car kernel-bic-entry))
+ (class (cl:find-class name)))
+ (sb-int:/show name class)
+ `(,name
+ ,(mapcar #'cl:class-name (direct-supers class))
+ ,(mapcar #'cl:class-name (direct-subs class))
+ ,(map 'list
+ (lambda (x)
+ (cl:class-name (sb-kernel:layout-class x)))
+ (reverse
+ (sb-kernel:layout-inherits
+ (sb-kernel:class-layout class))))
+ ,(prototype name))))
+ (remove-if (lambda (kernel-bic-entry)
+ (member (first kernel-bic-entry)
+ ;; I'm not sure why these are removed from
+ ;; the list, but that's what the original
+ ;; CMU CL code did. -- WHN 20000715
+ '(t sb-kernel:instance
+ sb-kernel:funcallable-instance
+ function stream)))
+ sb-kernel::*built-in-classes*))))
+(sb-int:/show "done setting up SB-PCL::*BUILT-IN-CLASSES*")
+\f
+;;;; the classes that define the kernel of the metabraid
+
+(defclass t () ()
+ (:metaclass built-in-class))
+
+(defclass sb-kernel:instance (t) ()
+ (:metaclass built-in-class))
+
+(defclass function (t) ()
+ (:metaclass built-in-class))
+
+(defclass sb-kernel:funcallable-instance (function) ()
+ (:metaclass built-in-class))
+
+(defclass stream (t) ()
+ (:metaclass built-in-class))
+
+(defclass slot-object (t) ()
+ (:metaclass slot-class))
+
+(defclass structure-object (slot-object sb-kernel:instance) ()
+ (:metaclass structure-class))
+
+(defstruct (dead-beef-structure-object
+ (:constructor |STRUCTURE-OBJECT class constructor|)))
+
+(defclass std-object (slot-object) ()
+ (:metaclass std-class))
+
+(defclass standard-object (std-object sb-kernel:instance) ())
+
+(defclass funcallable-standard-object (std-object
+ sb-kernel:funcallable-instance)
+ ()
+ (:metaclass funcallable-standard-class))
+
+(defclass specializer (standard-object)
+ ((type
+ :initform nil
+ :reader specializer-type)))
+
+(defclass definition-source-mixin (std-object)
+ ((source
+ :initform *load-truename*
+ :reader definition-source
+ :initarg :definition-source))
+ (:metaclass std-class))
+
+(defclass plist-mixin (std-object)
+ ((plist
+ :initform ()
+ :accessor object-plist))
+ (:metaclass std-class))
+
+(defclass documentation-mixin (plist-mixin)
+ ()
+ (:metaclass std-class))
+
+(defclass dependent-update-mixin (plist-mixin)
+ ()
+ (:metaclass std-class))
+
+;;; The class CLASS is a specified basic class. It is the common superclass
+;;; of any kind of class. That is any class that can be a metaclass must
+;;; have the class CLASS in its class precedence list.
+(defclass class (documentation-mixin dependent-update-mixin
+ definition-source-mixin specializer)
+ ((name
+ :initform nil
+ :initarg :name
+ :accessor class-name)
+ (class-eq-specializer
+ :initform nil
+ :reader class-eq-specializer)
+ (direct-superclasses
+ :initform ()
+ :reader class-direct-superclasses)
+ (direct-subclasses
+ :initform ()
+ :reader class-direct-subclasses)
+ (direct-methods
+ :initform (cons nil nil))
+ (predicate-name
+ :initform nil
+ :reader class-predicate-name)))
+
+;;; The class PCL-CLASS is an implementation-specific common superclass of
+;;; all specified subclasses of the class CLASS.
+(defclass pcl-class (class)
+ ((class-precedence-list
+ :reader class-precedence-list)
+ (can-precede-list
+ :initform ()
+ :reader class-can-precede-list)
+ (incompatible-superclass-list
+ :initform ()
+ :accessor class-incompatible-superclass-list)
+ (wrapper
+ :initform nil
+ :reader class-wrapper)
+ (prototype
+ :initform nil
+ :reader class-prototype)))
+
+(defclass slot-class (pcl-class)
+ ((direct-slots
+ :initform ()
+ :accessor class-direct-slots)
+ (slots
+ :initform ()
+ :accessor class-slots)
+ (initialize-info
+ :initform nil
+ :accessor class-initialize-info)))
+
+;;; The class STD-CLASS is an implementation-specific common superclass of
+;;; the classes STANDARD-CLASS and FUNCALLABLE-STANDARD-CLASS.
+(defclass std-class (slot-class)
+ ())
+
+(defclass standard-class (std-class)
+ ())
+
+(defclass funcallable-standard-class (std-class)
+ ())
+
+(defclass forward-referenced-class (pcl-class) ())
+
+(defclass built-in-class (pcl-class) ())
+
+(defclass structure-class (slot-class)
+ ((defstruct-form
+ :initform ()
+ :accessor class-defstruct-form)
+ (defstruct-constructor
+ :initform nil
+ :accessor class-defstruct-constructor)
+ (from-defclass-p
+ :initform nil
+ :initarg :from-defclass-p)))
+
+(defclass specializer-with-object (specializer) ())
+
+(defclass exact-class-specializer (specializer) ())
+
+(defclass class-eq-specializer (exact-class-specializer
+ specializer-with-object)
+ ((object :initarg :class
+ :reader specializer-class
+ :reader specializer-object)))
+
+(defclass class-prototype-specializer (specializer-with-object)
+ ((object :initarg :class
+ :reader specializer-class
+ :reader specializer-object)))
+
+(defclass eql-specializer (exact-class-specializer specializer-with-object)
+ ((object :initarg :object :reader specializer-object
+ :reader eql-specializer-object)))
+
+(defvar *eql-specializer-table* (make-hash-table :test 'eql))
+
+(defun intern-eql-specializer (object)
+ (or (gethash object *eql-specializer-table*)
+ (setf (gethash object *eql-specializer-table*)
+ (make-instance 'eql-specializer :object object))))
+\f
+;;;; slot definitions
+
+(defclass slot-definition (standard-object)
+ ((name
+ :initform nil
+ :initarg :name
+ :accessor slot-definition-name)
+ (initform
+ :initform nil
+ :initarg :initform
+ :accessor slot-definition-initform)
+ (initfunction
+ :initform nil
+ :initarg :initfunction
+ :accessor slot-definition-initfunction)
+ (readers
+ :initform nil
+ :initarg :readers
+ :accessor slot-definition-readers)
+ (writers
+ :initform nil
+ :initarg :writers
+ :accessor slot-definition-writers)
+ (initargs
+ :initform nil
+ :initarg :initargs
+ :accessor slot-definition-initargs)
+ (type
+ :initform t
+ :initarg :type
+ :accessor slot-definition-type)
+ (documentation
+ :initform ""
+ :initarg :documentation)
+ (class
+ :initform nil
+ :initarg :class
+ :accessor slot-definition-class)))
+
+(defclass standard-slot-definition (slot-definition)
+ ((allocation
+ :initform :instance
+ :initarg :allocation
+ :accessor slot-definition-allocation)))
+
+(defclass structure-slot-definition (slot-definition)
+ ((defstruct-accessor-symbol
+ :initform nil
+ :initarg :defstruct-accessor-symbol
+ :accessor slot-definition-defstruct-accessor-symbol)
+ (internal-reader-function
+ :initform nil
+ :initarg :internal-reader-function
+ :accessor slot-definition-internal-reader-function)
+ (internal-writer-function
+ :initform nil
+ :initarg :internal-writer-function
+ :accessor slot-definition-internal-writer-function)))
+
+(defclass direct-slot-definition (slot-definition)
+ ())
+
+(defclass effective-slot-definition (slot-definition)
+ ((reader-function ; #'(lambda (object) ...)
+ :accessor slot-definition-reader-function)
+ (writer-function ; #'(lambda (new-value object) ...)
+ :accessor slot-definition-writer-function)
+ (boundp-function ; #'(lambda (object) ...)
+ :accessor slot-definition-boundp-function)
+ (accessor-flags
+ :initform 0)))
+
+(defclass standard-direct-slot-definition (standard-slot-definition
+ direct-slot-definition)
+ ())
+
+(defclass standard-effective-slot-definition (standard-slot-definition
+ effective-slot-definition)
+ ((location ; nil, a fixnum, a cons: (slot-name . value)
+ :initform nil
+ :accessor slot-definition-location)))
+
+(defclass structure-direct-slot-definition (structure-slot-definition
+ direct-slot-definition)
+ ())
+
+(defclass structure-effective-slot-definition (structure-slot-definition
+ effective-slot-definition)
+ ())
+
+(defclass method (standard-object) ())
+
+(defclass standard-method (definition-source-mixin plist-mixin method)
+ ((generic-function
+ :initform nil
+ :accessor method-generic-function)
+; (qualifiers
+; :initform ()
+; :initarg :qualifiers
+; :reader method-qualifiers)
+ (specializers
+ :initform ()
+ :initarg :specializers
+ :reader method-specializers)
+ (lambda-list
+ :initform ()
+ :initarg :lambda-list
+ :reader method-lambda-list)
+ (function
+ :initform nil
+ :initarg :function) ;no writer
+ (fast-function
+ :initform nil
+ :initarg :fast-function ;no writer
+ :reader method-fast-function)
+; (documentation
+; :initform nil
+; :initarg :documentation
+; :reader method-documentation)
+ ))
+
+(defclass standard-accessor-method (standard-method)
+ ((slot-name :initform nil
+ :initarg :slot-name
+ :reader accessor-method-slot-name)
+ (slot-definition :initform nil
+ :initarg :slot-definition
+ :reader accessor-method-slot-definition)))
+
+(defclass standard-reader-method (standard-accessor-method) ())
+
+(defclass standard-writer-method (standard-accessor-method) ())
+
+(defclass standard-boundp-method (standard-accessor-method) ())
+
+(defclass generic-function (dependent-update-mixin
+ definition-source-mixin
+ documentation-mixin
+ funcallable-standard-object)
+ ()
+ (:metaclass funcallable-standard-class))
+
+(defclass standard-generic-function (generic-function)
+ ((name
+ :initform nil
+ :initarg :name
+ :accessor generic-function-name)
+ (methods
+ :initform ()
+ :accessor generic-function-methods
+ :type list)
+ (method-class
+ :initarg :method-class
+ :accessor generic-function-method-class)
+ (method-combination
+ :initarg :method-combination
+ :accessor generic-function-method-combination)
+ (arg-info
+ :initform (make-arg-info)
+ :reader gf-arg-info)
+ (dfun-state
+ :initform ()
+ :accessor gf-dfun-state)
+ (pretty-arglist
+ :initform ()
+ :accessor gf-pretty-arglist))
+ (:metaclass funcallable-standard-class)
+ (:default-initargs :method-class *the-class-standard-method*
+ :method-combination *standard-method-combination*))
+
+(defclass method-combination (standard-object) ())
+
+(defclass standard-method-combination
+ (definition-source-mixin method-combination)
+ ((type :reader method-combination-type
+ :initarg :type)
+ (documentation :reader method-combination-documentation
+ :initarg :documentation)
+ (options :reader method-combination-options
+ :initarg :options)))
+
+(defparameter *early-class-predicates*
+ '((specializer specializerp)
+ (exact-class-specializer exact-class-specializer-p)
+ (class-eq-specializer class-eq-specializer-p)
+ (eql-specializer eql-specializer-p)
+ (class classp)
+ (slot-class slot-class-p)
+ (std-class std-class-p)
+ (standard-class standard-class-p)
+ (funcallable-standard-class funcallable-standard-class-p)
+ (structure-class structure-class-p)
+ (forward-referenced-class forward-referenced-class-p)
+ (method method-p)
+ (standard-method standard-method-p)
+ (standard-accessor-method standard-accessor-method-p)
+ (standard-reader-method standard-reader-method-p)
+ (standard-writer-method standard-writer-method-p)
+ (standard-boundp-method standard-boundp-method-p)
+ (generic-function generic-function-p)
+ (standard-generic-function standard-generic-function-p)
+ (method-combination method-combination-p)))
+
--- /dev/null
+;;;; that part of the DESCRIBE mechanism which is based on code from
+;;;; PCL
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+
+;;;; This software is derived from software originally released by Xerox
+;;;; Corporation. Copyright and release statements follow. Later modifications
+;;;; to the software are in the public domain and are provided with
+;;;; absolutely no warranty. See the COPYING and CREDITS files for more
+;;;; information.
+
+;;;; copyright information from original PCL sources:
+;;;;
+;;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
+;;;; All rights reserved.
+;;;;
+;;;; Use and copying of this software and preparation of derivative works based
+;;;; upon this software are permitted. Any distribution of this software or
+;;;; derivative works must comply with all applicable United States export
+;;;; control laws.
+;;;;
+;;;; This software is made available AS IS, and Xerox Corporation makes no
+;;;; warranty about the software, its performance or its conformity to any
+;;;; specification.
+
+(in-package "SB-PCL")
+
+(sb-int:file-comment
+ "$Header$")
+
+(defmethod slots-to-inspect ((class slot-class) (object slot-object))
+ (class-slots class))
+
+(defmethod describe-object ((object slot-object) stream)
+
+ (let* ((class (class-of object))
+ (slotds (slots-to-inspect class object))
+ (max-slot-name-length 0)
+ (instance-slotds ())
+ (class-slotds ())
+ (other-slotds ()))
+
+ (flet ((adjust-slot-name-length (name)
+ (setq max-slot-name-length
+ (max max-slot-name-length
+ (length (the string (symbol-name name))))))
+ (describe-slot (name value &optional (allocation () alloc-p))
+ (if alloc-p
+ (format stream
+ "~% ~A ~S ~VT ~S"
+ name allocation (+ max-slot-name-length 7) value)
+ (format stream
+ "~% ~A~VT ~S"
+ name max-slot-name-length value))))
+
+ ;; Figure out a good width for the slot-name column.
+ (dolist (slotd slotds)
+ (adjust-slot-name-length (slot-definition-name slotd))
+ (case (slot-definition-allocation slotd)
+ (:instance (push slotd instance-slotds))
+ (:class (push slotd class-slotds))
+ (otherwise (push slotd other-slotds))))
+ (setq max-slot-name-length (min (+ max-slot-name-length 3) 30))
+ (format stream "~%~S is an instance of class ~S." object class)
+
+ ;; Now that we know the width, we can print.
+ (when instance-slotds
+ (format stream "~% The following slots have :INSTANCE allocation:")
+ (dolist (slotd (nreverse instance-slotds))
+ (describe-slot
+ (slot-definition-name slotd)
+ (slot-value-or-default object
+ (slot-definition-name slotd)))))
+ (when class-slotds
+ (format stream "~% The following slots have :CLASS allocation:")
+ (dolist (slotd (nreverse class-slotds))
+ (describe-slot
+ (slot-definition-name slotd)
+ (slot-value-or-default object
+ (slot-definition-name slotd)))))
+ (when other-slotds
+ (format stream "~% The following slots have allocation as shown:")
+ (dolist (slotd (nreverse other-slotds))
+ (describe-slot
+ (slot-definition-name slotd)
+ (slot-value-or-default object
+ (slot-definition-name slotd))
+ (slot-definition-allocation slotd)))))))
+
+(defvar *describe-metaobjects-as-objects-p* nil)
+
+(defmethod describe-object ((fun standard-generic-function) stream)
+ (format stream "~A is a generic function.~%" fun)
+ (format stream "Its arguments are:~% ~S~%"
+ (generic-function-pretty-arglist fun))
+ (format stream "Its methods are:")
+ (dolist (method (generic-function-methods fun))
+ (format stream "~2% ~{~S ~}~:S =>~%"
+ (method-qualifiers method)
+ (unparse-specializers method))
+ (describe-object (or (method-fast-function method)
+ (method-function method))
+ stream))
+ (when *describe-metaobjects-as-objects-p*
+ (call-next-method)))
+
+(defmethod describe-object ((class class) stream)
+ (flet ((pretty-class (c) (or (class-name c) c)))
+ (macrolet ((ft (string &rest args) `(format stream ,string ,@args)))
+ (ft "~&~S is a class, it is an instance of ~S.~%"
+ class (pretty-class (class-of class)))
+ (let ((name (class-name class)))
+ (if name
+ (if (eq class (find-class name nil))
+ (ft "Its proper name is ~S.~%" name)
+ (ft "Its name is ~S, but this is not a proper name.~%" name))
+ (ft "It has no name (the name is NIL).~%")))
+ (ft "The direct superclasses are: ~:S, and the direct~%~
+ subclasses are: ~:S. The class precedence list is:~%~S~%~
+ There are ~D methods specialized for this class."
+ (mapcar #'pretty-class (class-direct-superclasses class))
+ (mapcar #'pretty-class (class-direct-subclasses class))
+ (mapcar #'pretty-class (class-precedence-list class))
+ (length (specializer-direct-methods class)))))
+ (when *describe-metaobjects-as-objects-p*
+ (call-next-method)))
+
+(defmethod describe-object ((package package) stream)
+ (pprint-logical-block (stream nil)
+ (format stream "~&~S is a ~S." package (type-of package))
+ (format stream
+ "~@[~&It has nicknames ~{~:_~S~^ ~}~]"
+ (package-nicknames package))
+ (let* ((internal (sb-impl::package-internal-symbols package))
+ (internal-count (- (sb-impl::package-hashtable-size internal)
+ (sb-impl::package-hashtable-free internal)))
+ (external (sb-impl::package-external-symbols package))
+ (external-count (- (sb-impl::package-hashtable-size external)
+ (sb-impl::package-hashtable-free external))))
+ (format stream
+ "~&It has ~S internal and ~S external symbols."
+ internal-count external-count))
+ (format stream
+ "~@[~&It uses ~{~:_~S~^ ~}~]"
+ (package-use-list package))
+ (format stream
+ "~@[~&It is used by ~{~:_~S~^ ~}~]"
+ (package-used-by-list package))))
--- /dev/null
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+
+;;;; This software is derived from software originally released by Xerox
+;;;; Corporation. Copyright and release statements follow. Later modifications
+;;;; to the software are in the public domain and are provided with
+;;;; absolutely no warranty. See the COPYING and CREDITS files for more
+;;;; information.
+
+;;;; copyright information from original PCL sources:
+;;;;
+;;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
+;;;; All rights reserved.
+;;;;
+;;;; Use and copying of this software and preparation of derivative works based
+;;;; upon this software are permitted. Any distribution of this software or
+;;;; derivative works must comply with all applicable United States export
+;;;; control laws.
+;;;;
+;;;; This software is made available AS IS, and Xerox Corporation makes no
+;;;; warranty about the software, its performance or its conformity to any
+;;;; specification.
+
+(in-package "SB-PCL")
+
+(sb-int:file-comment
+ "$Header$")
+\f
+#|
+
+This implementation of method lookup was redone in early August of 89.
+
+It has the following properties:
+
+ - Its modularity makes it easy to modify the actual caching algorithm.
+ The caching algorithm is almost completely separated into the files
+ cache.lisp and dlap.lisp. This file just contains the various uses
+ of it. There will be more tuning as we get more results from Luis'
+ measurements of caching behavior.
+
+ - The metacircularity issues have been dealt with properly. All of
+ PCL now grounds out properly. Moreover, it is now possible to have
+ metaobject classes which are themselves not instances of standard
+ metaobject classes.
+
+** Modularity of the code **
+
+The actual caching algorithm is isolated in a modest number of functions.
+The code which generates cache lookup code is all found in cache.lisp and
+dlap.lisp. Certain non-wrapper-caching special cases are in this file.
+
+** Handling the metacircularity **
+
+In CLOS, method lookup is the potential source of infinite metacircular
+regress. The metaobject protocol specification gives us wide flexibility
+in how to address this problem. PCL uses a technique which handles the
+problem not only for the metacircular language described in Chapter 3, but
+also for the PCL protocol which includes additional generic functions
+which control more aspects of the CLOS implementation.
+
+The source of the metacircular regress can be seen in a number of ways.
+One is that the specified method lookup protocol must, as part of doing
+the method lookup (or at least the cache miss case), itself call generic
+functions. It is easy to see that if the method lookup for a generic
+function ends up calling that same generic function there can be trouble.
+
+Fortunately, there is an easy solution at hand. The solution is based on
+the restriction that portable code cannot change the class of a specified
+metaobject. This restriction implies that for specified generic functions,
+the method lookup protocol they follow is fixed.
+
+More precisely, for such specified generic functions, most generic functions
+that are called during their own method lookup will not run portable methods.
+This allows the implementation to usurp the actual generic function call in
+this case. In short, method lookup of a standard generic function, in the
+case where the only applicable methods are themselves standard doesn't
+have to do any method lookup to implement itself.
+
+And so, we are saved.
+
+|#
+\f
+;;; an alist in which each entry is of the form
+;;; (<generator> . (<subentry> ...)).
+;;; Each subentry is of the form
+;;; (<args> <constructor> <system>).
+(defvar *dfun-constructors* ())
+
+;;; If this is NIL, then the whole mechanism for caching dfun constructors is
+;;; turned off. The only time that makes sense is when debugging LAP code.
+(defvar *enable-dfun-constructor-caching* t)
+
+(defun show-dfun-constructors ()
+ (format t "~&DFUN constructor caching is ~A."
+ (if *enable-dfun-constructor-caching*
+ "enabled" "disabled"))
+ (dolist (generator-entry *dfun-constructors*)
+ (dolist (args-entry (cdr generator-entry))
+ (format t "~&~S ~S"
+ (cons (car generator-entry) (caar args-entry))
+ (caddr args-entry)))))
+
+(defvar *raise-metatypes-to-class-p* t)
+
+(defun get-dfun-constructor (generator &rest args)
+ (when (and *raise-metatypes-to-class-p*
+ (member generator '(emit-checking emit-caching
+ emit-in-checking-cache-p emit-constant-value)))
+ (setq args (cons (mapcar #'(lambda (mt)
+ (if (eq mt 't)
+ mt
+ 'class))
+ (car args))
+ (cdr args))))
+ (let* ((generator-entry (assq generator *dfun-constructors*))
+ (args-entry (assoc args (cdr generator-entry) :test #'equal)))
+ (if (null *enable-dfun-constructor-caching*)
+ (apply (symbol-function generator) args)
+ (or (cadr args-entry)
+ (multiple-value-bind (new not-best-p)
+ (apply (symbol-function generator) args)
+ (let ((entry (list (copy-list args) new (unless not-best-p 'pcl)
+ not-best-p)))
+ (if generator-entry
+ (push entry (cdr generator-entry))
+ (push (list generator entry)
+ *dfun-constructors*)))
+ (values new not-best-p))))))
+
+(defun load-precompiled-dfun-constructor (generator args system constructor)
+ (let* ((generator-entry (assq generator *dfun-constructors*))
+ (args-entry (assoc args (cdr generator-entry) :test #'equal)))
+ (if args-entry
+ (when (fourth args-entry)
+ (let* ((dfun-type (case generator
+ (emit-checking 'checking)
+ (emit-caching 'caching)
+ (emit-constant-value 'constant-value)
+ (emit-default-only 'default-method-only)))
+ (metatypes (car args))
+ (gfs (when dfun-type (gfs-of-type dfun-type))))
+ (dolist (gf gfs)
+ (when (and (equal metatypes (arg-info-metatypes (gf-arg-info gf)))
+ (let ((gf-name (generic-function-name gf)))
+ (and (not (eq gf-name 'slot-value-using-class))
+ (not (equal gf-name '(setf slot-value-using-class)))
+ (not (eq gf-name 'slot-boundp-using-class)))))
+ (update-dfun gf)))
+ (setf (second args-entry) constructor)
+ (setf (third args-entry) system)
+ (setf (fourth args-entry) nil)))
+ (let ((entry (list args constructor system nil)))
+ (if generator-entry
+ (push entry (cdr generator-entry))
+ (push (list generator entry) *dfun-constructors*))))))
+
+(defmacro precompile-dfun-constructors (&optional system)
+ (let ((*precompiling-lap* t))
+ `(progn
+ ,@(gathering1 (collecting)
+ (dolist (generator-entry *dfun-constructors*)
+ (dolist (args-entry (cdr generator-entry))
+ (when (or (null (caddr args-entry))
+ (eq (caddr args-entry) system))
+ (when system (setf (caddr args-entry) system))
+ (gather1
+ (make-top-level-form `(precompile-dfun-constructor
+ ,(car generator-entry))
+ '(:load-toplevel)
+ `(load-precompiled-dfun-constructor
+ ',(car generator-entry)
+ ',(car args-entry)
+ ',system
+ ,(apply (symbol-function (car generator-entry))
+ (car args-entry))))))))))))
+\f
+;;; When all the methods of a generic function are automatically generated
+;;; reader or writer methods a number of special optimizations are possible.
+;;; These are important because of the large number of generic functions of
+;;; this type.
+;;;
+;;; There are a number of cases:
+;;;
+;;; ONE-CLASS-ACCESSOR
+;;; In this case, the accessor generic function has only been called
+;;; with one class of argument. There is no cache vector, the wrapper
+;;; of the one class, and the slot index are stored directly as closure
+;;; variables of the discriminating function. This case can convert to
+;;; either of the next kind.
+;;;
+;;; TWO-CLASS-ACCESSOR
+;;; Like above, but two classes. This is common enough to do specially.
+;;; There is no cache vector. The two classes are stored a separate
+;;; closure variables.
+;;;
+;;; ONE-INDEX-ACCESSOR
+;;; In this case, the accessor generic function has seen more than one
+;;; class of argument, but the index of the slot is the same for all
+;;; the classes that have been seen. A cache vector is used to store
+;;; the wrappers that have been seen, the slot index is stored directly
+;;; as a closure variable of the discriminating function. This case
+;;; can convert to the next kind.
+;;;
+;;; N-N-ACCESSOR
+;;; This is the most general case. In this case, the accessor generic
+;;; function has seen more than one class of argument and more than one
+;;; slot index. A cache vector stores the wrappers and corresponding
+;;; slot indexes. Because each cache line is more than one element
+;;; long, a cache lock count is used.
+(defstruct (dfun-info (:constructor nil))
+ (cache nil))
+
+(defstruct (no-methods
+ (:constructor no-methods-dfun-info ())
+ (:include dfun-info)))
+
+(defstruct (initial
+ (:constructor initial-dfun-info ())
+ (:include dfun-info)))
+
+(defstruct (initial-dispatch
+ (:constructor initial-dispatch-dfun-info ())
+ (:include dfun-info)))
+
+(defstruct (dispatch
+ (:constructor dispatch-dfun-info ())
+ (:include dfun-info)))
+
+(defstruct (default-method-only
+ (:constructor default-method-only-dfun-info ())
+ (:include dfun-info)))
+
+;without caching:
+; dispatch one-class two-class default-method-only
+
+;with caching:
+; one-index n-n checking caching
+
+;accessor:
+; one-class two-class one-index n-n
+(defstruct (accessor-dfun-info
+ (:constructor nil)
+ (:include dfun-info))
+ accessor-type) ; (member reader writer)
+
+(defmacro dfun-info-accessor-type (di)
+ `(accessor-dfun-info-accessor-type ,di))
+
+(defstruct (one-index-dfun-info
+ (:constructor nil)
+ (:include accessor-dfun-info))
+ index)
+
+(defmacro dfun-info-index (di)
+ `(one-index-dfun-info-index ,di))
+
+(defstruct (n-n
+ (:constructor n-n-dfun-info (accessor-type cache))
+ (:include accessor-dfun-info)))
+
+(defstruct (one-class
+ (:constructor one-class-dfun-info (accessor-type index wrapper0))
+ (:include one-index-dfun-info))
+ wrapper0)
+
+(defmacro dfun-info-wrapper0 (di)
+ `(one-class-wrapper0 ,di))
+
+(defstruct (two-class
+ (:constructor two-class-dfun-info (accessor-type index wrapper0 wrapper1))
+ (:include one-class))
+ wrapper1)
+
+(defmacro dfun-info-wrapper1 (di)
+ `(two-class-wrapper1 ,di))
+
+(defstruct (one-index
+ (:constructor one-index-dfun-info
+ (accessor-type index cache))
+ (:include one-index-dfun-info)))
+
+(defstruct (checking
+ (:constructor checking-dfun-info (function cache))
+ (:include dfun-info))
+ function)
+
+(defmacro dfun-info-function (di)
+ `(checking-function ,di))
+
+(defstruct (caching
+ (:constructor caching-dfun-info (cache))
+ (:include dfun-info)))
+
+(defstruct (constant-value
+ (:constructor constant-value-dfun-info (cache))
+ (:include dfun-info)))
+
+(defmacro dfun-update (generic-function function &rest args)
+ `(multiple-value-bind (dfun cache info)
+ (funcall ,function ,generic-function ,@args)
+ (update-dfun ,generic-function dfun cache info)))
+
+(defun accessor-miss-function (gf dfun-info)
+ (ecase (dfun-info-accessor-type dfun-info)
+ (reader
+ #'(lambda (arg)
+ (declare (pcl-fast-call))
+ (accessor-miss gf nil arg dfun-info)))
+ (writer
+ #'(lambda (new arg)
+ (declare (pcl-fast-call))
+ (accessor-miss gf new arg dfun-info)))))
+
+#-sb-fluid (declaim (sb-ext:freeze-type dfun-info))
+\f
+(defun make-one-class-accessor-dfun (gf type wrapper index)
+ (let ((emit (if (eq type 'reader) 'emit-one-class-reader 'emit-one-class-writer))
+ (dfun-info (one-class-dfun-info type index wrapper)))
+ (values
+ (funcall (get-dfun-constructor emit (consp index))
+ wrapper index
+ (accessor-miss-function gf dfun-info))
+ nil
+ dfun-info)))
+
+(defun make-two-class-accessor-dfun (gf type w0 w1 index)
+ (let ((emit (if (eq type 'reader) 'emit-two-class-reader 'emit-two-class-writer))
+ (dfun-info (two-class-dfun-info type index w0 w1)))
+ (values
+ (funcall (get-dfun-constructor emit (consp index))
+ w0 w1 index
+ (accessor-miss-function gf dfun-info))
+ nil
+ dfun-info)))
+
+;;; std accessors same index dfun
+(defun make-one-index-accessor-dfun (gf type index &optional cache)
+ (let* ((emit (if (eq type 'reader) 'emit-one-index-readers 'emit-one-index-writers))
+ (cache (or cache (get-cache 1 nil #'one-index-limit-fn 4)))
+ (dfun-info (one-index-dfun-info type index cache)))
+ (declare (type cache cache))
+ (values
+ (funcall (get-dfun-constructor emit (consp index))
+ cache
+ index
+ (accessor-miss-function gf dfun-info))
+ cache
+ dfun-info)))
+
+(defun make-final-one-index-accessor-dfun (gf type index table)
+ (let ((cache (fill-dfun-cache table nil 1 #'one-index-limit-fn)))
+ (make-one-index-accessor-dfun gf type index cache)))
+
+(defun one-index-limit-fn (nlines)
+ (default-limit-fn nlines))
+
+(defun make-n-n-accessor-dfun (gf type &optional cache)
+ (let* ((emit (if (eq type 'reader) 'emit-n-n-readers 'emit-n-n-writers))
+ (cache (or cache (get-cache 1 t #'n-n-accessors-limit-fn 2)))
+ (dfun-info (n-n-dfun-info type cache)))
+ (declare (type cache cache))
+ (values
+ (funcall (get-dfun-constructor emit)
+ cache
+ (accessor-miss-function gf dfun-info))
+ cache
+ dfun-info)))
+
+(defun make-final-n-n-accessor-dfun (gf type table)
+ (let ((cache (fill-dfun-cache table t 1 #'n-n-accessors-limit-fn)))
+ (make-n-n-accessor-dfun gf type cache)))
+
+(defun n-n-accessors-limit-fn (nlines)
+ (default-limit-fn nlines))
+
+(defun make-checking-dfun (generic-function function &optional cache)
+ (unless cache
+ (when (use-caching-dfun-p generic-function)
+ (return-from make-checking-dfun (make-caching-dfun generic-function)))
+ (when (use-dispatch-dfun-p generic-function)
+ (return-from make-checking-dfun (make-dispatch-dfun generic-function))))
+ (multiple-value-bind (nreq applyp metatypes nkeys)
+ (get-generic-function-info generic-function)
+ (declare (ignore nreq))
+ (if (every #'(lambda (mt) (eq mt 't)) metatypes)
+ (let ((dfun-info (default-method-only-dfun-info)))
+ (values
+ (funcall (get-dfun-constructor 'emit-default-only metatypes applyp)
+ function)
+ nil
+ dfun-info))
+ (let* ((cache (or cache (get-cache nkeys nil #'checking-limit-fn 2)))
+ (dfun-info (checking-dfun-info function cache)))
+ (values
+ (funcall (get-dfun-constructor 'emit-checking metatypes applyp)
+ cache
+ function
+ #'(lambda (&rest args)
+ (declare (pcl-fast-call))
+ (checking-miss generic-function args dfun-info)))
+ cache
+ dfun-info)))))
+
+(defun make-final-checking-dfun (generic-function function
+ classes-list new-class)
+ (let ((metatypes (arg-info-metatypes (gf-arg-info generic-function))))
+ (if (every #'(lambda (mt) (eq mt 't)) metatypes)
+ (values #'(lambda (&rest args)
+ (invoke-emf function args))
+ nil (default-method-only-dfun-info))
+ (let ((cache (make-final-ordinary-dfun-internal
+ generic-function nil #'checking-limit-fn
+ classes-list new-class)))
+ (make-checking-dfun generic-function function cache)))))
+
+(defun use-default-method-only-dfun-p (generic-function)
+ (multiple-value-bind (nreq applyp metatypes nkeys)
+ (get-generic-function-info generic-function)
+ (declare (ignore nreq applyp nkeys))
+ (every #'(lambda (mt) (eq mt 't)) metatypes)))
+
+(defun use-caching-dfun-p (generic-function)
+ (some (lambda (method)
+ (let ((fmf (if (listp method)
+ (third method)
+ (method-fast-function method))))
+ (method-function-get fmf ':slot-name-lists)))
+ ;; KLUDGE: As of sbcl-0.6.4, it's very important for
+ ;; efficiency to know the type of the sequence argument to
+ ;; quantifiers (SOME/NOTANY/etc.) at compile time, but
+ ;; the compiler isn't smart enough to understand the :TYPE
+ ;; slot option for DEFCLASS, so we just tell
+ ;; it the type by hand here.
+ (the list
+ (if (early-gf-p generic-function)
+ (early-gf-methods generic-function)
+ (generic-function-methods generic-function)))))
+
+(defun checking-limit-fn (nlines)
+ (default-limit-fn nlines))
+\f
+(defun make-caching-dfun (generic-function &optional cache)
+ (unless cache
+ (when (use-constant-value-dfun-p generic-function)
+ (return-from make-caching-dfun (make-constant-value-dfun generic-function)))
+ (when (use-dispatch-dfun-p generic-function)
+ (return-from make-caching-dfun (make-dispatch-dfun generic-function))))
+ (multiple-value-bind (nreq applyp metatypes nkeys)
+ (get-generic-function-info generic-function)
+ (declare (ignore nreq))
+ (let* ((cache (or cache (get-cache nkeys t #'caching-limit-fn 2)))
+ (dfun-info (caching-dfun-info cache)))
+ (values
+ (funcall (get-dfun-constructor 'emit-caching metatypes applyp)
+ cache
+ #'(lambda (&rest args)
+ (declare (pcl-fast-call))
+ (caching-miss generic-function args dfun-info)))
+ cache
+ dfun-info))))
+
+(defun make-final-caching-dfun (generic-function classes-list new-class)
+ (let ((cache (make-final-ordinary-dfun-internal
+ generic-function t #'caching-limit-fn
+ classes-list new-class)))
+ (make-caching-dfun generic-function cache)))
+
+(defun caching-limit-fn (nlines)
+ (default-limit-fn nlines))
+
+(defun insure-caching-dfun (gf)
+ (multiple-value-bind (nreq applyp metatypes nkeys)
+ (get-generic-function-info gf)
+ (declare (ignore nreq nkeys))
+ (when (and metatypes
+ (not (null (car metatypes)))
+ (dolist (mt metatypes nil)
+ (unless (eq mt 't) (return t))))
+ (get-dfun-constructor 'emit-caching metatypes applyp))))
+
+(defun use-constant-value-dfun-p (gf &optional boolean-values-p)
+ (multiple-value-bind (nreq applyp metatypes nkeys)
+ (get-generic-function-info gf)
+ (declare (ignore nreq metatypes nkeys))
+ (let* ((early-p (early-gf-p gf))
+ (methods (if early-p
+ (early-gf-methods gf)
+ (generic-function-methods gf)))
+ (default '(unknown)))
+ (and (null applyp)
+ (or (not (eq *boot-state* 'complete))
+ (compute-applicable-methods-emf-std-p gf))
+ (notany #'(lambda (method)
+ (or (and (eq *boot-state* 'complete)
+ (some #'eql-specializer-p
+ (method-specializers method)))
+ (let ((value (method-function-get
+ (if early-p
+ (or (third method) (second method))
+ (or (method-fast-function method)
+ (method-function method)))
+ :constant-value default)))
+ (if boolean-values-p
+ (not (or (eq value 't) (eq value nil)))
+ (eq value default)))))
+ methods)))))
+
+(defun make-constant-value-dfun (generic-function &optional cache)
+ (multiple-value-bind (nreq applyp metatypes nkeys)
+ (get-generic-function-info generic-function)
+ (declare (ignore nreq applyp))
+ (let* ((cache (or cache (get-cache nkeys t #'caching-limit-fn 2)))
+ (dfun-info (constant-value-dfun-info cache)))
+ (values
+ (funcall (get-dfun-constructor 'emit-constant-value metatypes)
+ cache
+ #'(lambda (&rest args)
+ (declare (pcl-fast-call))
+ (constant-value-miss generic-function args dfun-info)))
+ cache
+ dfun-info))))
+
+(defun make-final-constant-value-dfun (generic-function classes-list new-class)
+ (let ((cache (make-final-ordinary-dfun-internal
+ generic-function :constant-value #'caching-limit-fn
+ classes-list new-class)))
+ (make-constant-value-dfun generic-function cache)))
+
+(defun use-dispatch-dfun-p (gf &optional (caching-p (use-caching-dfun-p gf)))
+ (when (eq *boot-state* 'complete)
+ (unless caching-p
+ ;; This should return T when almost all dispatching is by
+ ;; eql specializers or built-in classes. In other words,
+ ;; return NIL if we might ever need to do more than
+ ;; one (non built-in) typep.
+ ;; Otherwise, it is probably at least as fast to use
+ ;; a caching dfun first, possibly followed by secondary dispatching.
+
+ #||;;; Original found in cmu 17f -- S L O W
+ (< (dispatch-dfun-cost gf) (caching-dfun-cost gf))
+ ||#
+ ;; This uses improved dispatch-dfun-cost below
+ (let ((cdc (caching-dfun-cost gf))) ; fast
+ (> cdc (dispatch-dfun-cost gf cdc))))))
+
+(defparameter *non-built-in-typep-cost* 1)
+(defparameter *structure-typep-cost* 1)
+(defparameter *built-in-typep-cost* 0)
+
+;;; The execution time of this version is exponential to some function
+;;; of number of gf methods and argument lists. It was taking
+;;; literally hours to load the presentation methods from the
+;;; cl-http w3p kit.
+#+nil
+(defun dispatch-dfun-cost (gf)
+ (generate-discrimination-net-internal
+ gf (generic-function-methods gf) nil
+ #'(lambda (methods known-types)
+ (declare (ignore methods known-types))
+ 0)
+ #'(lambda (position type true-value false-value)
+ (declare (ignore position))
+ (+ (max true-value false-value)
+ (if (eq 'class (car type))
+ (let ((cpl (class-precedence-list (class-of (cadr type)))))
+ (cond((memq *the-class-built-in-class* cpl)
+ *built-in-typep-cost*)
+ ((memq *the-class-structure-class* cpl)
+ *structure-typep-cost*)
+ (t
+ *non-built-in-typep-cost*)))
+ 0)))
+ #'identity))
+
+;;; This version is from the pcl found in the gcl-2.1 distribution.
+;;; Someone added a cost limit so as to keep the execution time controlled
+(defun dispatch-dfun-cost (gf &optional limit)
+ (generate-discrimination-net-internal
+ gf (generic-function-methods gf) nil
+ #'(lambda (methods known-types)
+ (declare (ignore methods known-types))
+ 0)
+ #'(lambda (position type true-value false-value)
+ (declare (ignore position))
+ (let* ((type-test-cost
+ (if (eq 'class (car type))
+ (let* ((metaclass (class-of (cadr type)))
+ (mcpl (class-precedence-list metaclass)))
+ (cond ((memq *the-class-built-in-class* mcpl)
+ *built-in-typep-cost*)
+ ((memq *the-class-structure-class* mcpl)
+ *structure-typep-cost*)
+ (t
+ *non-built-in-typep-cost*)))
+ 0))
+ (max-cost-so-far
+ (+ (max true-value false-value) type-test-cost)))
+ (when (and limit (<= limit max-cost-so-far))
+ (return-from dispatch-dfun-cost max-cost-so-far))
+ max-cost-so-far))
+ #'identity))
+
+(defparameter *cache-lookup-cost* 1)
+(defparameter *wrapper-of-cost* 0)
+(defparameter *secondary-dfun-call-cost* 1)
+
+(defun caching-dfun-cost (gf)
+ (let* ((arg-info (gf-arg-info gf))
+ (nreq (length (arg-info-metatypes arg-info))))
+ (+ *cache-lookup-cost*
+ (* *wrapper-of-cost* nreq)
+ (if (methods-contain-eql-specializer-p
+ (generic-function-methods gf))
+ *secondary-dfun-call-cost*
+ 0))))
+
+(setq *non-built-in-typep-cost* 100)
+(setq *structure-typep-cost* 15)
+(setq *built-in-typep-cost* 5)
+(setq *cache-lookup-cost* 30)
+(setq *wrapper-of-cost* 15)
+(setq *secondary-dfun-call-cost* 30)
+
+(defun make-dispatch-dfun (gf)
+ (values (get-dispatch-function gf) nil (dispatch-dfun-info)))
+
+(defun get-dispatch-function (gf)
+ (let ((methods (generic-function-methods gf)))
+ (function-funcall (get-secondary-dispatch-function1 gf methods nil nil nil
+ nil nil t)
+ nil nil)))
+
+(defun make-final-dispatch-dfun (gf)
+ (make-dispatch-dfun gf))
+
+(defun update-dispatch-dfuns ()
+ (dolist (gf (gfs-of-type '(dispatch initial-dispatch)))
+ (dfun-update gf #'make-dispatch-dfun)))
+
+(defun fill-dfun-cache (table valuep nkeys limit-fn &optional cache)
+ (let ((cache (or cache (get-cache nkeys valuep limit-fn
+ (+ (hash-table-count table) 3)))))
+ (maphash #'(lambda (classes value)
+ (setq cache (fill-cache cache
+ (class-wrapper classes)
+ value
+ t)))
+ table)
+ cache))
+
+(defun make-final-ordinary-dfun-internal (generic-function valuep limit-fn
+ classes-list new-class)
+ (let* ((arg-info (gf-arg-info generic-function))
+ (nkeys (arg-info-nkeys arg-info))
+ (new-class (and new-class
+ (equal (type-of (gf-dfun-info generic-function))
+ (cond ((eq valuep t) 'caching)
+ ((eq valuep :constant-value) 'constant-value)
+ ((null valuep) 'checking)))
+ new-class))
+ (cache (if new-class
+ (copy-cache (gf-dfun-cache generic-function))
+ (get-cache nkeys (not (null valuep)) limit-fn 4))))
+ (make-emf-cache generic-function valuep cache classes-list new-class)))
+\f
+(defvar *dfun-miss-gfs-on-stack* ())
+
+(defmacro dfun-miss ((gf args wrappers invalidp nemf
+ &optional type index caching-p applicable)
+ &body body)
+ (unless applicable (setq applicable (gensym)))
+ `(multiple-value-bind (,nemf ,applicable ,wrappers ,invalidp
+ ,@(when type `(,type ,index)))
+ (cache-miss-values ,gf ,args ',(cond (caching-p 'caching)
+ (type 'accessor)
+ (t 'checking)))
+ (when (and ,applicable (not (memq ,gf *dfun-miss-gfs-on-stack*)))
+ (let ((*dfun-miss-gfs-on-stack* (cons ,gf *dfun-miss-gfs-on-stack*)))
+ ,@body))
+ (invoke-emf ,nemf ,args)))
+
+;;; The dynamically adaptive method lookup algorithm is implemented is
+;;; implemented as a kind of state machine. The kinds of discriminating
+;;; function is the state, the various kinds of reasons for a cache miss
+;;; are the state transitions.
+;;;
+;;; The code which implements the transitions is all in the miss handlers
+;;; for each kind of dfun. Those appear here.
+;;;
+;;; Note that within the states that cache, there are dfun updates which
+;;; simply select a new cache or cache field. Those are not considered
+;;; as state transitions.
+(defvar *lazy-dfun-compute-p* t)
+(defvar *early-p* nil)
+
+(defun make-initial-dfun (gf)
+ (let ((initial-dfun
+ #'(sb-kernel:instance-lambda (&rest args)
+ (initial-dfun gf args))))
+ (multiple-value-bind (dfun cache info)
+ (if (and (eq *boot-state* 'complete)
+ (compute-applicable-methods-emf-std-p gf))
+ (let* ((caching-p (use-caching-dfun-p gf))
+ (classes-list (precompute-effective-methods
+ gf caching-p
+ (not *lazy-dfun-compute-p*))))
+ (if *lazy-dfun-compute-p*
+ (cond ((use-dispatch-dfun-p gf caching-p)
+ (values initial-dfun
+ nil
+ (initial-dispatch-dfun-info)))
+ (caching-p
+ (insure-caching-dfun gf)
+ (values initial-dfun nil (initial-dfun-info)))
+ (t
+ (values initial-dfun nil (initial-dfun-info))))
+ (make-final-dfun-internal gf classes-list)))
+ (let ((arg-info (if (early-gf-p gf)
+ (early-gf-arg-info gf)
+ (gf-arg-info gf)))
+ (type nil))
+ (if (and (gf-precompute-dfun-and-emf-p arg-info)
+ (setq type (final-accessor-dfun-type gf)))
+ (if *early-p*
+ (values (make-early-accessor gf type) nil nil)
+ (make-final-accessor-dfun gf type))
+ (values initial-dfun nil (initial-dfun-info)))))
+ (set-dfun gf dfun cache info))))
+
+(defun make-early-accessor (gf type)
+ (let* ((methods (early-gf-methods gf))
+ (slot-name (early-method-standard-accessor-slot-name (car methods))))
+ (ecase type
+ (reader #'(sb-kernel:instance-lambda (instance)
+ (let* ((class (class-of instance))
+ (class-name (bootstrap-get-slot 'class class 'name)))
+ (bootstrap-get-slot class-name instance slot-name))))
+ (writer #'(sb-kernel:instance-lambda (new-value instance)
+ (let* ((class (class-of instance))
+ (class-name (bootstrap-get-slot 'class class 'name)))
+ (bootstrap-set-slot class-name instance slot-name new-value)))))))
+
+(defun initial-dfun (gf args)
+ (dfun-miss (gf args wrappers invalidp nemf ntype nindex)
+ (cond (invalidp)
+ ((and ntype nindex)
+ (dfun-update
+ gf #'make-one-class-accessor-dfun ntype wrappers nindex))
+ ((use-caching-dfun-p gf)
+ (dfun-update gf #'make-caching-dfun))
+ (t
+ (dfun-update
+ gf #'make-checking-dfun
+ ;; nemf is suitable only for caching, have to do this:
+ (cache-miss-values gf args 'checking))))))
+
+(defun make-final-dfun (gf &optional classes-list)
+ (multiple-value-bind (dfun cache info)
+ (make-final-dfun-internal gf classes-list)
+ (set-dfun gf dfun cache info)))
+
+(defvar *new-class* nil)
+
+(defvar *free-hash-tables* (mapcar #'list '(eq equal eql)))
+
+(defmacro with-hash-table ((table test) &body forms)
+ `(let* ((.free. (assoc ',test *free-hash-tables*))
+ (,table (if (cdr .free.)
+ (pop (cdr .free.))
+ (make-hash-table :test ',test))))
+ (multiple-value-prog1
+ (progn ,@forms)
+ (clrhash ,table)
+ (push ,table (cdr .free.)))))
+
+(defmacro with-eq-hash-table ((table) &body forms)
+ `(with-hash-table (,table eq) ,@forms))
+
+(defun final-accessor-dfun-type (gf)
+ (let ((methods (if (early-gf-p gf)
+ (early-gf-methods gf)
+ (generic-function-methods gf))))
+ (cond ((every #'(lambda (method)
+ (if (consp method)
+ (eq *the-class-standard-reader-method*
+ (early-method-class method))
+ (standard-reader-method-p method)))
+ methods)
+ 'reader)
+ ((every #'(lambda (method)
+ (if (consp method)
+ (eq *the-class-standard-writer-method*
+ (early-method-class method))
+ (standard-writer-method-p method)))
+ methods)
+ 'writer))))
+
+(defun make-final-accessor-dfun (gf type &optional classes-list new-class)
+ (with-eq-hash-table (table)
+ (multiple-value-bind (table all-index first second size no-class-slots-p)
+ (make-accessor-table gf type table)
+ (if table
+ (cond ((= size 1)
+ (let ((w (class-wrapper first)))
+ (make-one-class-accessor-dfun gf type w all-index)))
+ ((and (= size 2) (or (integerp all-index) (consp all-index)))
+ (let ((w0 (class-wrapper first))
+ (w1 (class-wrapper second)))
+ (make-two-class-accessor-dfun gf type w0 w1 all-index)))
+ ((or (integerp all-index) (consp all-index))
+ (make-final-one-index-accessor-dfun
+ gf type all-index table))
+ (no-class-slots-p
+ (make-final-n-n-accessor-dfun gf type table))
+ (t
+ (make-final-caching-dfun gf classes-list new-class)))
+ (make-final-caching-dfun gf classes-list new-class)))))
+
+(defun make-final-dfun-internal (gf &optional classes-list)
+ (let ((methods (generic-function-methods gf)) type
+ (new-class *new-class*) (*new-class* nil)
+ specls all-same-p)
+ (cond ((null methods)
+ (values
+ #'(sb-kernel:instance-lambda (&rest args)
+ (apply #'no-applicable-method gf args))
+ nil
+ (no-methods-dfun-info)))
+ ((setq type (final-accessor-dfun-type gf))
+ (make-final-accessor-dfun gf type classes-list new-class))
+ ((and (not (and (every #'(lambda (specl) (eq specl *the-class-t*))
+ (setq specls
+ (method-specializers (car methods))))
+ (setq all-same-p
+ (every #'(lambda (method)
+ (and (equal specls
+ (method-specializers
+ method))))
+ methods))))
+ (use-constant-value-dfun-p gf))
+ (make-final-constant-value-dfun gf classes-list new-class))
+ ((use-dispatch-dfun-p gf)
+ (make-final-dispatch-dfun gf))
+ ((and all-same-p (not (use-caching-dfun-p gf)))
+ (let ((emf (get-secondary-dispatch-function gf methods nil)))
+ (make-final-checking-dfun gf emf classes-list new-class)))
+ (t
+ (make-final-caching-dfun gf classes-list new-class)))))
+
+(defun accessor-miss (gf new object dfun-info)
+ (let* ((ostate (type-of dfun-info))
+ (otype (dfun-info-accessor-type dfun-info))
+ oindex ow0 ow1 cache
+ (args (ecase otype ; The congruence rules ensure
+ (reader (list object)) ; that this is safe despite not
+ (writer (list new object))))) ; knowing the new type yet.
+ (dfun-miss (gf args wrappers invalidp nemf ntype nindex)
+
+ ;; The following lexical functions change the state of the
+ ;; dfun to that which is their name. They accept arguments
+ ;; which are the parameters of the new state, and get other
+ ;; information from the lexical variables bound above.
+ (flet ((two-class (index w0 w1)
+ (when (zerop (random 2)) (psetf w0 w1 w1 w0))
+ (dfun-update gf
+ #'make-two-class-accessor-dfun
+ ntype
+ w0
+ w1
+ index))
+ (one-index (index &optional cache)
+ (dfun-update gf
+ #'make-one-index-accessor-dfun
+ ntype
+ index
+ cache))
+ (n-n (&optional cache)
+ (if (consp nindex)
+ (dfun-update gf #'make-checking-dfun nemf)
+ (dfun-update gf #'make-n-n-accessor-dfun ntype cache)))
+ (caching () ; because cached accessor emfs are much faster
+ ; for accessors
+ (dfun-update gf #'make-caching-dfun))
+ (do-fill (update-fn)
+ (let ((ncache (fill-cache cache wrappers nindex)))
+ (unless (eq ncache cache)
+ (funcall update-fn ncache)))))
+
+ (cond ((null ntype)
+ (caching))
+ ((or invalidp
+ (null nindex)))
+ ((not (pcl-instance-p object))
+ (caching))
+ ((or (neq ntype otype) (listp wrappers))
+ (caching))
+ (t
+ (ecase ostate
+ (one-class
+ (setq oindex (dfun-info-index dfun-info))
+ (setq ow0 (dfun-info-wrapper0 dfun-info))
+ (unless (eq ow0 wrappers)
+ (if (eql nindex oindex)
+ (two-class nindex ow0 wrappers)
+ (n-n))))
+ (two-class
+ (setq oindex (dfun-info-index dfun-info))
+ (setq ow0 (dfun-info-wrapper0 dfun-info))
+ (setq ow1 (dfun-info-wrapper1 dfun-info))
+ (unless (or (eq ow0 wrappers) (eq ow1 wrappers))
+ (if (eql nindex oindex)
+ (one-index nindex)
+ (n-n))))
+ (one-index
+ (setq oindex (dfun-info-index dfun-info))
+ (setq cache (dfun-info-cache dfun-info))
+ (if (eql nindex oindex)
+ (do-fill #'(lambda (ncache)
+ (one-index nindex ncache)))
+ (n-n)))
+ (n-n
+ (setq cache (dfun-info-cache dfun-info))
+ (if (consp nindex)
+ (caching)
+ (do-fill #'n-n))))))))))
+
+(defun checking-miss (generic-function args dfun-info)
+ (let ((oemf (dfun-info-function dfun-info))
+ (cache (dfun-info-cache dfun-info)))
+ (dfun-miss (generic-function args wrappers invalidp nemf)
+ (cond (invalidp)
+ ((eq oemf nemf)
+ (let ((ncache (fill-cache cache wrappers nil)))
+ (unless (eq ncache cache)
+ (dfun-update generic-function #'make-checking-dfun
+ nemf ncache))))
+ (t
+ (dfun-update generic-function #'make-caching-dfun))))))
+
+(defun caching-miss (generic-function args dfun-info)
+ (let ((ocache (dfun-info-cache dfun-info)))
+ (dfun-miss (generic-function args wrappers invalidp emf nil nil t)
+ (cond (invalidp)
+ (t
+ (let ((ncache (fill-cache ocache wrappers emf)))
+ (unless (eq ncache ocache)
+ (dfun-update generic-function
+ #'make-caching-dfun ncache))))))))
+
+(defun constant-value-miss (generic-function args dfun-info)
+ (let ((ocache (dfun-info-cache dfun-info)))
+ (dfun-miss (generic-function args wrappers invalidp emf nil nil t)
+ (cond (invalidp)
+ (t
+ (let* ((function (typecase emf
+ (fast-method-call (fast-method-call-function
+ emf))
+ (method-call (method-call-function emf))))
+ (value (method-function-get function :constant-value))
+ (ncache (fill-cache ocache wrappers value)))
+ (unless (eq ncache ocache)
+ (dfun-update generic-function
+ #'make-constant-value-dfun ncache))))))))
+\f
+;;; Given a generic function and a set of arguments to that generic function,
+;;; returns a mess of values.
+;;;
+;;; <function> The compiled effective method function for this set of
+;;; arguments.
+;;;
+;;; <applicable> Sorted list of applicable methods.
+;;;
+;;; <wrappers> Is a single wrapper if the generic function has only
+;;; one key, that is arg-info-nkeys of the arg-info is 1.
+;;; Otherwise a list of the wrappers of the specialized
+;;; arguments to the generic function.
+;;;
+;;; Note that all these wrappers are valid. This function
+;;; does invalid wrapper traps when it finds an invalid
+;;; wrapper and then returns the new, valid wrapper.
+;;;
+;;; <invalidp> True if any of the specialized arguments had an invalid
+;;; wrapper, false otherwise.
+;;;
+;;; <type> READER or WRITER when the only method that would be run
+;;; is a standard reader or writer method. To be specific,
+;;; the value is READER when the method combination is eq to
+;;; *standard-method-combination*; there are no applicable
+;;; :before, :after or :around methods; and the most specific
+;;; primary method is a standard reader method.
+;;;
+;;; <index> If <type> is READER or WRITER, and the slot accessed is
+;;; an :instance slot, this is the index number of that slot
+;;; in the object argument.
+(defun cache-miss-values (gf args state)
+ (if (null (if (early-gf-p gf)
+ (early-gf-methods gf)
+ (generic-function-methods gf)))
+ (apply #'no-applicable-method gf args)
+ (multiple-value-bind (nreq applyp metatypes nkeys arg-info)
+ (get-generic-function-info gf)
+ (declare (ignore nreq applyp nkeys))
+ (with-dfun-wrappers (args metatypes)
+ (dfun-wrappers invalid-wrapper-p wrappers classes types)
+ (error "The function ~S requires at least ~D arguments"
+ gf (length metatypes))
+ (multiple-value-bind (emf methods accessor-type index)
+ (cache-miss-values-internal gf arg-info wrappers classes types state)
+ (values emf methods
+ dfun-wrappers
+ invalid-wrapper-p
+ accessor-type index))))))
+
+(defun cache-miss-values-internal (gf arg-info wrappers classes types state)
+ (let* ((for-accessor-p (eq state 'accessor))
+ (for-cache-p (or (eq state 'caching) (eq state 'accessor)))
+ (cam-std-p (or (null arg-info)
+ (gf-info-c-a-m-emf-std-p arg-info))))
+ (multiple-value-bind (methods all-applicable-and-sorted-p)
+ (if cam-std-p
+ (compute-applicable-methods-using-types gf types)
+ (compute-applicable-methods-using-classes gf classes))
+ (let ((emf (if (or cam-std-p all-applicable-and-sorted-p)
+ (function-funcall (get-secondary-dispatch-function1
+ gf methods types nil (and for-cache-p wrappers)
+ all-applicable-and-sorted-p)
+ nil (and for-cache-p wrappers))
+ (default-secondary-dispatch-function gf))))
+ (multiple-value-bind (index accessor-type)
+ (and for-accessor-p all-applicable-and-sorted-p methods
+ (accessor-values gf arg-info classes methods))
+ (values (if (integerp index) index emf)
+ methods accessor-type index))))))
+
+(defun accessor-values (gf arg-info classes methods)
+ (declare (ignore gf))
+ (let* ((accessor-type (gf-info-simple-accessor-type arg-info))
+ (accessor-class (case accessor-type
+ (reader (car classes))
+ (writer (cadr classes))
+ (boundp (car classes)))))
+ (accessor-values-internal accessor-type accessor-class methods)))
+
+(defun accessor-values1 (gf accessor-type accessor-class)
+ (let* ((type `(class-eq ,accessor-class))
+ (types (if (eq accessor-type 'writer) `(t ,type) `(,type)))
+ (methods (compute-applicable-methods-using-types gf types)))
+ (accessor-values-internal accessor-type accessor-class methods)))
+
+(defun accessor-values-internal (accessor-type accessor-class methods)
+ (dolist (meth methods)
+ (when (if (consp meth)
+ (early-method-qualifiers meth)
+ (method-qualifiers meth))
+ (return-from accessor-values-internal (values nil nil))))
+ (let* ((meth (car methods))
+ (early-p (not (eq *boot-state* 'complete)))
+ (slot-name (when accessor-class
+ (if (consp meth)
+ (and (early-method-standard-accessor-p meth)
+ (early-method-standard-accessor-slot-name meth))
+ (and (member *the-class-std-object*
+ (if early-p
+ (early-class-precedence-list accessor-class)
+ (class-precedence-list accessor-class)))
+ (if early-p
+ (not (eq *the-class-standard-method*
+ (early-method-class meth)))
+ (standard-accessor-method-p meth))
+ (if early-p
+ (early-accessor-method-slot-name meth)
+ (accessor-method-slot-name meth))))))
+ (slotd (and accessor-class
+ (if early-p
+ (dolist (slot (early-class-slotds accessor-class) nil)
+ (when (eql slot-name (early-slot-definition-name slot))
+ (return slot)))
+ (find-slot-definition accessor-class slot-name)))))
+ (when (and slotd
+ (or early-p
+ (slot-accessor-std-p slotd accessor-type)))
+ (values (if early-p
+ (early-slot-definition-location slotd)
+ (slot-definition-location slotd))
+ accessor-type))))
+
+(defun make-accessor-table (gf type &optional table)
+ (unless table (setq table (make-hash-table :test 'eq)))
+ (let ((methods (if (early-gf-p gf)
+ (early-gf-methods gf)
+ (generic-function-methods gf)))
+ (all-index nil)
+ (no-class-slots-p t)
+ (early-p (not (eq *boot-state* 'complete)))
+ first second (size 0))
+ (declare (fixnum size))
+ ;; class -> {(specl slotd)}
+ (dolist (method methods)
+ (let* ((specializers (if (consp method)
+ (early-method-specializers method t)
+ (method-specializers method)))
+ (specl (if (eq type 'reader)
+ (car specializers)
+ (cadr specializers)))
+ (specl-cpl (if early-p
+ (early-class-precedence-list specl)
+ (and (class-finalized-p specl)
+ (class-precedence-list specl))))
+ (so-p (member *the-class-std-object* specl-cpl))
+ (slot-name (if (consp method)
+ (and (early-method-standard-accessor-p method)
+ (early-method-standard-accessor-slot-name method))
+ (accessor-method-slot-name method))))
+ (when (or (null specl-cpl)
+ (member *the-class-structure-object* specl-cpl))
+ (return-from make-accessor-table nil))
+ (maphash #'(lambda (class slotd)
+ (let ((cpl (if early-p
+ (early-class-precedence-list class)
+ (class-precedence-list class))))
+ (when (memq specl cpl)
+ (unless (and (or so-p
+ (member *the-class-std-object* cpl))
+ (or early-p
+ (slot-accessor-std-p slotd type)))
+ (return-from make-accessor-table nil))
+ (push (cons specl slotd) (gethash class table)))))
+ (gethash slot-name *name->class->slotd-table*))))
+ (maphash #'(lambda (class specl+slotd-list)
+ (dolist (sclass (if early-p
+ (early-class-precedence-list class)
+ (class-precedence-list class))
+ (error "This can't happen"))
+ (let ((a (assq sclass specl+slotd-list)))
+ (when a
+ (let* ((slotd (cdr a))
+ (index (if early-p
+ (early-slot-definition-location slotd)
+ (slot-definition-location slotd))))
+ (unless index (return-from make-accessor-table nil))
+ (setf (gethash class table) index)
+ (when (consp index) (setq no-class-slots-p nil))
+ (setq all-index (if (or (null all-index)
+ (eql all-index index))
+ index t))
+ (incf size)
+ (cond ((= size 1) (setq first class))
+ ((= size 2) (setq second class)))
+ (return nil))))))
+ table)
+ (values table all-index first second size no-class-slots-p)))
+
+(defun compute-applicable-methods-using-types (generic-function types)
+ (let ((definite-p t) (possibly-applicable-methods nil))
+ (dolist (method (if (early-gf-p generic-function)
+ (early-gf-methods generic-function)
+ (generic-function-methods generic-function)))
+ (let ((specls (if (consp method)
+ (early-method-specializers method t)
+ (method-specializers method)))
+ (types types)
+ (possibly-applicable-p t) (applicable-p t))
+ (dolist (specl specls)
+ (multiple-value-bind (specl-applicable-p specl-possibly-applicable-p)
+ (specializer-applicable-using-type-p specl (pop types))
+ (unless specl-applicable-p
+ (setq applicable-p nil))
+ (unless specl-possibly-applicable-p
+ (setq possibly-applicable-p nil)
+ (return nil))))
+ (when possibly-applicable-p
+ (unless applicable-p (setq definite-p nil))
+ (push method possibly-applicable-methods))))
+ (let ((precedence (arg-info-precedence (if (early-gf-p generic-function)
+ (early-gf-arg-info generic-function)
+ (gf-arg-info generic-function)))))
+ (values (sort-applicable-methods precedence
+ (nreverse possibly-applicable-methods)
+ types)
+ definite-p))))
+
+(defun sort-applicable-methods (precedence methods types)
+ (sort-methods methods
+ precedence
+ #'(lambda (class1 class2 index)
+ (let* ((class (type-class (nth index types)))
+ (cpl (if (eq *boot-state* 'complete)
+ (class-precedence-list class)
+ (early-class-precedence-list class))))
+ (if (memq class2 (memq class1 cpl))
+ class1 class2)))))
+
+(defun sort-methods (methods precedence compare-classes-function)
+ (flet ((sorter (method1 method2)
+ (dolist (index precedence)
+ (let* ((specl1 (nth index (if (listp method1)
+ (early-method-specializers method1 t)
+ (method-specializers method1))))
+ (specl2 (nth index (if (listp method2)
+ (early-method-specializers method2 t)
+ (method-specializers method2))))
+ (order (order-specializers
+ specl1 specl2 index compare-classes-function)))
+ (when order
+ (return-from sorter (eq order specl1)))))))
+ (stable-sort methods #'sorter)))
+
+(defun order-specializers (specl1 specl2 index compare-classes-function)
+ (let ((type1 (if (eq *boot-state* 'complete)
+ (specializer-type specl1)
+ (bootstrap-get-slot 'specializer specl1 'type)))
+ (type2 (if (eq *boot-state* 'complete)
+ (specializer-type specl2)
+ (bootstrap-get-slot 'specializer specl2 'type))))
+ (cond ((eq specl1 specl2)
+ nil)
+ ((atom type1)
+ specl2)
+ ((atom type2)
+ specl1)
+ (t
+ (case (car type1)
+ (class (case (car type2)
+ (class (funcall compare-classes-function specl1 specl2 index))
+ (t specl2)))
+ (prototype (case (car type2)
+ (class (funcall compare-classes-function specl1 specl2 index))
+ (t specl2)))
+ (class-eq (case (car type2)
+ (eql specl2)
+ (class-eq nil)
+ (class type1)))
+ (eql (case (car type2)
+ (eql nil)
+ (t specl1))))))))
+
+(defun map-all-orders (methods precedence function)
+ (let ((choices nil))
+ (flet ((compare-classes-function (class1 class2 index)
+ (declare (ignore index))
+ (let ((choice nil))
+ (dolist (c choices nil)
+ (when (or (and (eq (first c) class1)
+ (eq (second c) class2))
+ (and (eq (first c) class2)
+ (eq (second c) class1)))
+ (return (setq choice c))))
+ (unless choice
+ (setq choice
+ (if (class-might-precede-p class1 class2)
+ (if (class-might-precede-p class2 class1)
+ (list class1 class2 nil t)
+ (list class1 class2 t))
+ (if (class-might-precede-p class2 class1)
+ (list class2 class1 t)
+ (let ((name1 (class-name class1))
+ (name2 (class-name class2)))
+ (if (and name1 name2 (symbolp name1) (symbolp name2)
+ (string< (symbol-name name1)
+ (symbol-name name2)))
+ (list class1 class2 t)
+ (list class2 class1 t))))))
+ (push choice choices))
+ (car choice))))
+ (loop (funcall function
+ (sort-methods methods precedence #'compare-classes-function))
+ (unless (dolist (c choices nil)
+ (unless (third c)
+ (rotatef (car c) (cadr c))
+ (return (setf (third c) t))))
+ (return nil))))))
+
+(defvar *in-precompute-effective-methods-p* nil)
+
+;used only in map-all-orders
+(defun class-might-precede-p (class1 class2)
+ (if (not *in-precompute-effective-methods-p*)
+ (not (member class1 (cdr (class-precedence-list class2))))
+ (class-can-precede-p class1 class2)))
+
+(defun compute-precedence (lambda-list nreq argument-precedence-order)
+ (if (null argument-precedence-order)
+ (let ((list nil))
+ (dotimes-fixnum (i nreq list) (push (- (1- nreq) i) list)))
+ (mapcar (lambda (x) (position x lambda-list))
+ argument-precedence-order)))
+
+(defun saut-and (specl type)
+ (let ((applicable nil)
+ (possibly-applicable t))
+ (dolist (type (cdr type))
+ (multiple-value-bind (appl poss-appl)
+ (specializer-applicable-using-type-p specl type)
+ (when appl (return (setq applicable t)))
+ (unless poss-appl (return (setq possibly-applicable nil)))))
+ (values applicable possibly-applicable)))
+
+(defun saut-not (specl type)
+ (let ((ntype (cadr type)))
+ (values nil
+ (case (car ntype)
+ (class (saut-not-class specl ntype))
+ (class-eq (saut-not-class-eq specl ntype))
+ (prototype (saut-not-prototype specl ntype))
+ (eql (saut-not-eql specl ntype))
+ (t (error "~S cannot handle the second argument ~S"
+ 'specializer-applicable-using-type-p type))))))
+
+(defun saut-not-class (specl ntype)
+ (let* ((class (type-class specl))
+ (cpl (class-precedence-list class)))
+ (not (memq (cadr ntype) cpl))))
+
+(defun saut-not-prototype (specl ntype)
+ (let* ((class (case (car specl)
+ (eql (class-of (cadr specl)))
+ (class-eq (cadr specl))
+ (prototype (cadr specl))
+ (class (cadr specl))))
+ (cpl (class-precedence-list class)))
+ (not (memq (cadr ntype) cpl))))
+
+(defun saut-not-class-eq (specl ntype)
+ (let ((class (case (car specl)
+ (eql (class-of (cadr specl)))
+ (class-eq (cadr specl)))))
+ (not (eq class (cadr ntype)))))
+
+(defun saut-not-eql (specl ntype)
+ (case (car specl)
+ (eql (not (eql (cadr specl) (cadr ntype))))
+ (t t)))
+
+(defun class-applicable-using-class-p (specl type)
+ (let ((pred (memq specl (if (eq *boot-state* 'complete)
+ (class-precedence-list type)
+ (early-class-precedence-list type)))))
+ (values pred
+ (or pred
+ (if (not *in-precompute-effective-methods-p*)
+ ;; classes might get common subclass
+ (superclasses-compatible-p specl type)
+ ;; worry only about existing classes
+ (classes-have-common-subclass-p specl type))))))
+
+(defun classes-have-common-subclass-p (class1 class2)
+ (or (eq class1 class2)
+ (let ((class1-subs (class-direct-subclasses class1)))
+ (or (memq class2 class1-subs)
+ (dolist (class1-sub class1-subs nil)
+ (when (classes-have-common-subclass-p class1-sub class2)
+ (return t)))))))
+
+(defun saut-class (specl type)
+ (case (car specl)
+ (class (class-applicable-using-class-p (cadr specl) (cadr type)))
+ (t (values nil (let ((class (type-class specl)))
+ (memq (cadr type)
+ (class-precedence-list class)))))))
+
+(defun saut-class-eq (specl type)
+ (if (eq (car specl) 'eql)
+ (values nil (eq (class-of (cadr specl)) (cadr type)))
+ (let ((pred (case (car specl)
+ (class-eq
+ (eq (cadr specl) (cadr type)))
+ (class
+ (or (eq (cadr specl) (cadr type))
+ (memq (cadr specl)
+ (if (eq *boot-state* 'complete)
+ (class-precedence-list (cadr type))
+ (early-class-precedence-list (cadr type)))))))))
+ (values pred pred))))
+
+(defun saut-prototype (specl type)
+ (declare (ignore specl type))
+ (values nil nil)) ; fix this someday
+
+(defun saut-eql (specl type)
+ (let ((pred (case (car specl)
+ (eql (eql (cadr specl) (cadr type)))
+ (class-eq (eq (cadr specl) (class-of (cadr type))))
+ (class (memq (cadr specl)
+ (let ((class (class-of (cadr type))))
+ (if (eq *boot-state* 'complete)
+ (class-precedence-list class)
+ (early-class-precedence-list class))))))))
+ (values pred pred)))
+
+(defun specializer-applicable-using-type-p (specl type)
+ (setq specl (type-from-specializer specl))
+ (when (eq specl 't)
+ (return-from specializer-applicable-using-type-p (values t t)))
+ ;; This is used by c-a-m-u-t and generate-discrimination-net-internal,
+ ;; and has only what they need.
+ (if (or (atom type) (eq (car type) 't))
+ (values nil t)
+ (case (car type)
+ (and (saut-and specl type))
+ (not (saut-not specl type))
+ (class (saut-class specl type))
+ (prototype (saut-prototype specl type))
+ (class-eq (saut-class-eq specl type))
+ (eql (saut-eql specl type))
+ (t (error "~S cannot handle the second argument ~S."
+ 'specializer-applicable-using-type-p
+ type)))))
+
+(defun map-all-classes (function &optional (root 't))
+ (let ((braid-p (or (eq *boot-state* 'braid)
+ (eq *boot-state* 'complete))))
+ (labels ((do-class (class)
+ (mapc #'do-class
+ (if braid-p
+ (class-direct-subclasses class)
+ (early-class-direct-subclasses class)))
+ (funcall function class)))
+ (do-class (if (symbolp root)
+ (find-class root)
+ root)))))
+\f
+;;; NOTE: We are assuming a restriction on user code that the method
+;;; combination must not change once it is connected to the
+;;; generic function.
+;;;
+;;; This has to be legal, because otherwise any kind of method
+;;; lookup caching couldn't work. See this by saying that this
+;;; cache, is just a backing cache for the fast cache. If that
+;;; cache is legal, this one must be too.
+;;;
+;;; Don't clear this table!
+(defvar *effective-method-table* (make-hash-table :test 'eq))
+
+(defun get-secondary-dispatch-function (gf methods types &optional
+ method-alist wrappers)
+ (function-funcall (get-secondary-dispatch-function1
+ gf methods types
+ (not (null method-alist))
+ (not (null wrappers))
+ (not (methods-contain-eql-specializer-p methods)))
+ method-alist wrappers))
+
+(defun get-secondary-dispatch-function1 (gf methods types method-alist-p wrappers-p
+ &optional all-applicable-p
+ (all-sorted-p t) function-p)
+ (if (null methods)
+ (if function-p
+ #'(lambda (method-alist wrappers)
+ (declare (ignore method-alist wrappers))
+ #'(sb-kernel:instance-lambda (&rest args)
+ (apply #'no-applicable-method gf args)))
+ #'(lambda (method-alist wrappers)
+ (declare (ignore method-alist wrappers))
+ #'(lambda (&rest args)
+ (apply #'no-applicable-method gf args))))
+ (let* ((key (car methods))
+ (ht-value (or (gethash key *effective-method-table*)
+ (setf (gethash key *effective-method-table*)
+ (cons nil nil)))))
+ (if (and (null (cdr methods)) all-applicable-p ; the most common case
+ (null method-alist-p) wrappers-p (not function-p))
+ (or (car ht-value)
+ (setf (car ht-value)
+ (get-secondary-dispatch-function2
+ gf methods types method-alist-p wrappers-p
+ all-applicable-p all-sorted-p function-p)))
+ (let ((akey (list methods
+ (if all-applicable-p 'all-applicable types)
+ method-alist-p wrappers-p function-p)))
+ (or (cdr (assoc akey (cdr ht-value) :test #'equal))
+ (let ((value (get-secondary-dispatch-function2
+ gf methods types method-alist-p wrappers-p
+ all-applicable-p all-sorted-p function-p)))
+ (push (cons akey value) (cdr ht-value))
+ value)))))))
+
+(defun get-secondary-dispatch-function2 (gf methods types method-alist-p wrappers-p
+ all-applicable-p all-sorted-p function-p)
+ (if (and all-applicable-p all-sorted-p (not function-p))
+ (if (eq *boot-state* 'complete)
+ (let* ((combin (generic-function-method-combination gf))
+ (effective (compute-effective-method gf combin methods)))
+ (make-effective-method-function1 gf effective method-alist-p wrappers-p))
+ (let ((effective (standard-compute-effective-method gf nil methods)))
+ (make-effective-method-function1 gf effective method-alist-p wrappers-p)))
+ (let ((net (generate-discrimination-net
+ gf methods types all-sorted-p)))
+ (compute-secondary-dispatch-function1 gf net function-p))))
+
+(defun get-effective-method-function (gf methods &optional method-alist wrappers)
+ (function-funcall (get-secondary-dispatch-function1 gf methods nil
+ (not (null method-alist))
+ (not (null wrappers))
+ t)
+ method-alist wrappers))
+
+(defun get-effective-method-function1 (gf methods &optional (sorted-p t))
+ (get-secondary-dispatch-function1 gf methods nil nil nil t sorted-p))
+
+(defun methods-contain-eql-specializer-p (methods)
+ (and (eq *boot-state* 'complete)
+ (dolist (method methods nil)
+ (when (dolist (spec (method-specializers method) nil)
+ (when (eql-specializer-p spec) (return t)))
+ (return t)))))
+\f
+(defun update-dfun (generic-function &optional dfun cache info)
+ (let* ((early-p (early-gf-p generic-function))
+ (gf-name (if early-p
+ (early-gf-name generic-function)
+ (generic-function-name generic-function)))
+ (ocache (gf-dfun-cache generic-function)))
+ (set-dfun generic-function dfun cache info)
+ (let* ((dfun (if early-p
+ (or dfun (make-initial-dfun generic-function))
+ (compute-discriminating-function generic-function)))
+ (info (gf-dfun-info generic-function)))
+ (unless (eq 'default-method-only (type-of info))
+ (setq dfun (doctor-dfun-for-the-debugger
+ generic-function
+ dfun)))
+ (set-funcallable-instance-function generic-function dfun)
+ (set-function-name generic-function gf-name)
+ (when (and ocache (not (eq ocache cache))) (free-cache ocache))
+ dfun)))
+\f
+(defvar *dfun-count* nil)
+(defvar *dfun-list* nil)
+(defvar *minimum-cache-size-to-list*)
+
+(defun list-dfun (gf)
+ (let* ((sym (type-of (gf-dfun-info gf)))
+ (a (assq sym *dfun-list*)))
+ (unless a
+ (push (setq a (list sym)) *dfun-list*))
+ (push (generic-function-name gf) (cdr a))))
+
+(defun list-all-dfuns ()
+ (setq *dfun-list* nil)
+ (map-all-generic-functions #'list-dfun)
+ *dfun-list*)
+
+(defun list-large-cache (gf)
+ (let* ((sym (type-of (gf-dfun-info gf)))
+ (cache (gf-dfun-cache gf)))
+ (when cache
+ (let ((size (cache-size cache)))
+ (when (>= size *minimum-cache-size-to-list*)
+ (let ((a (assoc size *dfun-list*)))
+ (unless a
+ (push (setq a (list size)) *dfun-list*))
+ (push (let ((name (generic-function-name gf)))
+ (if (eq sym 'caching) name (list name sym)))
+ (cdr a))))))))
+
+(defun list-large-caches (&optional (*minimum-cache-size-to-list* 130))
+ (setq *dfun-list* nil)
+ (map-all-generic-functions #'list-large-cache)
+ (setq *dfun-list* (sort dfun-list #'< :key #'car))
+ (mapc #'print *dfun-list*)
+ (values))
+
+(defun count-dfun (gf)
+ (let* ((sym (type-of (gf-dfun-info gf)))
+ (cache (gf-dfun-cache gf))
+ (a (assq sym *dfun-count*)))
+ (unless a
+ (push (setq a (list sym 0 nil)) *dfun-count*))
+ (incf (cadr a))
+ (when cache
+ (let* ((size (cache-size cache))
+ (b (assoc size (third a))))
+ (unless b
+ (push (setq b (cons size 0)) (third a)))
+ (incf (cdr b))))))
+
+(defun count-all-dfuns ()
+ (setq *dfun-count* (mapcar #'(lambda (type) (list type 0 nil))
+ '(ONE-CLASS TWO-CLASS DEFAULT-METHOD-ONLY
+ ONE-INDEX N-N CHECKING CACHING
+ DISPATCH)))
+ (map-all-generic-functions #'count-dfun)
+ (mapc #'(lambda (type+count+sizes)
+ (setf (third type+count+sizes)
+ (sort (third type+count+sizes) #'< :key #'car)))
+ *dfun-count*)
+ (mapc #'(lambda (type+count+sizes)
+ (format t "~&There are ~D dfuns of type ~S."
+ (cadr type+count+sizes) (car type+count+sizes))
+ (format t "~% ~S~%" (caddr type+count+sizes)))
+ *dfun-count*)
+ (values))
+
+(defun gfs-of-type (type)
+ (unless (consp type) (setq type (list type)))
+ (let ((gf-list nil))
+ (map-all-generic-functions #'(lambda (gf)
+ (when (memq (type-of (gf-dfun-info gf)) type)
+ (push gf gf-list))))
+ gf-list))
--- /dev/null
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+
+;;;; This software is derived from software originally released by Xerox
+;;;; Corporation. Copyright and release statements follow. Later modifications
+;;;; to the software are in the public domain and are provided with
+;;;; absolutely no warranty. See the COPYING and CREDITS files for more
+;;;; information.
+
+;;;; copyright information from original PCL sources:
+;;;;
+;;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
+;;;; All rights reserved.
+;;;;
+;;;; Use and copying of this software and preparation of derivative works based
+;;;; upon this software are permitted. Any distribution of this software or
+;;;; derivative works must comply with all applicable United States export
+;;;; control laws.
+;;;;
+;;;; This software is made available AS IS, and Xerox Corporation makes no
+;;;; warranty about the software, its performance or its conformity to any
+;;;; specification.
+
+(in-package "SB-PCL")
+
+(sb-int:file-comment
+ "$Header$")
+\f
+;;; This file is (almost) functionally equivalent to dlap.lisp, but easier to
+;;; read.
+
+;;; Might generate faster code, too, depending on the compiler and whether an
+;;; implementation-specific lap assembler was used.
+
+(defun emit-one-class-reader (class-slot-p)
+ (emit-reader/writer :reader 1 class-slot-p))
+
+(defun emit-one-class-writer (class-slot-p)
+ (emit-reader/writer :writer 1 class-slot-p))
+
+(defun emit-two-class-reader (class-slot-p)
+ (emit-reader/writer :reader 2 class-slot-p))
+
+(defun emit-two-class-writer (class-slot-p)
+ (emit-reader/writer :writer 2 class-slot-p))
+
+;;; --------------------------------
+
+(defun emit-one-index-readers (class-slot-p)
+ (emit-one-or-n-index-reader/writer :reader nil class-slot-p))
+
+(defun emit-one-index-writers (class-slot-p)
+ (emit-one-or-n-index-reader/writer :writer nil class-slot-p))
+
+(defun emit-n-n-readers ()
+ (emit-one-or-n-index-reader/writer :reader t nil))
+
+(defun emit-n-n-writers ()
+ (emit-one-or-n-index-reader/writer :writer t nil))
+
+;;; --------------------------------
+
+(defun emit-checking (metatypes applyp)
+ (emit-checking-or-caching nil nil metatypes applyp))
+
+(defun emit-caching (metatypes applyp)
+ (emit-checking-or-caching t nil metatypes applyp))
+
+(defun emit-in-checking-cache-p (metatypes)
+ (emit-checking-or-caching nil t metatypes nil))
+
+(defun emit-constant-value (metatypes)
+ (emit-checking-or-caching t t metatypes nil))
+
+;;; --------------------------------
+
+(defvar *precompiling-lap* nil)
+(defvar *emit-function-p* t)
+
+(defun emit-default-only (metatypes applyp)
+ (when (and (null *precompiling-lap*) *emit-function-p*)
+ (return-from emit-default-only
+ (emit-default-only-function metatypes applyp)))
+ (let* ((dlap-lambda-list (make-dlap-lambda-list metatypes applyp))
+ (args (remove '&rest dlap-lambda-list))
+ (restl (when applyp '(.lap-rest-arg.))))
+ (generating-lisp '(emf)
+ dlap-lambda-list
+ `(invoke-effective-method-function emf ,applyp ,@args ,@restl))))
+
+(defmacro emit-default-only-macro (metatypes applyp)
+ (let ((*emit-function-p* nil)
+ (*precompiling-lap* t))
+ (values
+ (emit-default-only metatypes applyp))))
+
+;;; --------------------------------
+
+(defun generating-lisp (closure-variables args form)
+ (let* ((rest (memq '&rest args))
+ (ldiff (and rest (ldiff args rest)))
+ (args (if rest (append ldiff '(&rest .lap-rest-arg.)) args))
+ (lambda `(lambda ,closure-variables
+ ,@(when (member 'miss-fn closure-variables)
+ `((declare (type function miss-fn))))
+ #'(sb-kernel:instance-lambda ,args
+ (let ()
+ (declare #.*optimize-speed*)
+ ,form)))))
+ (values (if *precompiling-lap*
+ `#',lambda
+ (compile-lambda lambda))
+ nil)))
+
+;;; note on implementation for CMU 17 and later (including SBCL):
+;;; Since std-instance-p is weakened, that branch may run on non-pcl
+;;; instances (structures). The result will be the non-wrapper layout
+;;; for the structure, which will cause a miss. The "slots" will be
+;;; whatever the first slot is, but will be ignored. Similarly,
+;;; fsc-instance-p returns true on funcallable structures as well as
+;;; PCL fins.
+(defun emit-reader/writer (reader/writer 1-or-2-class class-slot-p)
+ (when (and (null *precompiling-lap*) *emit-function-p*)
+ (return-from emit-reader/writer
+ (emit-reader/writer-function reader/writer 1-or-2-class class-slot-p)))
+ (let ((instance nil)
+ (arglist ())
+ (closure-variables ())
+ (field (first-wrapper-cache-number-index))
+ (readp (eq reader/writer :reader))
+ (read-form (emit-slot-read-form class-slot-p 'index 'slots)))
+ ;;we need some field to do the fast obsolete check
+ (ecase reader/writer
+ (:reader (setq instance (dfun-arg-symbol 0)
+ arglist (list instance)))
+ (:writer (setq instance (dfun-arg-symbol 1)
+ arglist (list (dfun-arg-symbol 0) instance))))
+ (ecase 1-or-2-class
+ (1 (setq closure-variables '(wrapper-0 index miss-fn)))
+ (2 (setq closure-variables '(wrapper-0 wrapper-1 index miss-fn))))
+ (generating-lisp closure-variables
+ arglist
+ `(let* (,@(unless class-slot-p `((slots nil)))
+ (wrapper (cond ((std-instance-p ,instance)
+ ,@(unless class-slot-p
+ `((setq slots (std-instance-slots ,instance))))
+ (std-instance-wrapper ,instance))
+ ((fsc-instance-p ,instance)
+ ,@(unless class-slot-p
+ `((setq slots (fsc-instance-slots ,instance))))
+ (fsc-instance-wrapper ,instance)))))
+ (block access
+ (when (and wrapper
+ (/= (wrapper-cache-number-vector-ref wrapper ,field) 0)
+ ,@(if (eql 1 1-or-2-class)
+ `((eq wrapper wrapper-0))
+ `((or (eq wrapper wrapper-0)
+ (eq wrapper wrapper-1)))))
+ ,@(if readp
+ `((let ((value ,read-form))
+ (unless (eq value *slot-unbound*)
+ (return-from access value))))
+ `((return-from access (setf ,read-form ,(car arglist))))))
+ (funcall miss-fn ,@arglist))))))
+
+(defun emit-slot-read-form (class-slot-p index slots)
+ (if class-slot-p
+ `(cdr ,index)
+ `(%instance-ref ,slots ,index)))
+
+(defun emit-boundp-check (value-form miss-fn arglist)
+ `(let ((value ,value-form))
+ (if (eq value *slot-unbound*)
+ (funcall ,miss-fn ,@arglist)
+ value)))
+
+(defun emit-slot-access (reader/writer class-slot-p slots index miss-fn arglist)
+ (let ((read-form (emit-slot-read-form class-slot-p index slots)))
+ (ecase reader/writer
+ (:reader (emit-boundp-check read-form miss-fn arglist))
+ (:writer `(setf ,read-form ,(car arglist))))))
+
+(defmacro emit-reader/writer-macro (reader/writer 1-or-2-class class-slot-p)
+ (let ((*emit-function-p* nil)
+ (*precompiling-lap* t))
+ (values
+ (emit-reader/writer reader/writer 1-or-2-class class-slot-p))))
+
+(defun emit-one-or-n-index-reader/writer (reader/writer cached-index-p class-slot-p)
+ (when (and (null *precompiling-lap*) *emit-function-p*)
+ (return-from emit-one-or-n-index-reader/writer
+ (emit-one-or-n-index-reader/writer-function
+ reader/writer cached-index-p class-slot-p)))
+ (multiple-value-bind (arglist metatypes)
+ (ecase reader/writer
+ (:reader (values (list (dfun-arg-symbol 0))
+ '(standard-instance)))
+ (:writer (values (list (dfun-arg-symbol 0) (dfun-arg-symbol 1))
+ '(t standard-instance))))
+ (generating-lisp `(cache ,@(unless cached-index-p '(index)) miss-fn)
+ arglist
+ `(let (,@(unless class-slot-p '(slots))
+ ,@(when cached-index-p '(index)))
+ ,(emit-dlap arglist metatypes
+ (emit-slot-access reader/writer class-slot-p
+ 'slots 'index 'miss-fn arglist)
+ `(funcall miss-fn ,@arglist)
+ (when cached-index-p 'index)
+ (unless class-slot-p '(slots)))))))
+
+(defmacro emit-one-or-n-index-reader/writer-macro
+ (reader/writer cached-index-p class-slot-p)
+ (let ((*emit-function-p* nil)
+ (*precompiling-lap* t))
+ (values
+ (emit-one-or-n-index-reader/writer reader/writer cached-index-p class-slot-p))))
+
+(defun emit-miss (miss-fn args &optional applyp)
+ (let ((restl (when applyp '(.lap-rest-arg.))))
+ (if restl
+ `(apply ,miss-fn ,@args ,@restl)
+ `(funcall ,miss-fn ,@args ,@restl))))
+
+(defun emit-checking-or-caching (cached-emf-p return-value-p metatypes applyp)
+ (when (and (null *precompiling-lap*) *emit-function-p*)
+ (return-from emit-checking-or-caching
+ (emit-checking-or-caching-function
+ cached-emf-p return-value-p metatypes applyp)))
+ (let* ((dlap-lambda-list (make-dlap-lambda-list metatypes applyp))
+ (args (remove '&rest dlap-lambda-list))
+ (restl (when applyp '(.lap-rest-arg.))))
+ (generating-lisp `(cache ,@(unless cached-emf-p '(emf)) miss-fn)
+ dlap-lambda-list
+ `(let (,@(when cached-emf-p '(emf)))
+ ,(emit-dlap args
+ metatypes
+ (if return-value-p
+ (if cached-emf-p 'emf t)
+ `(invoke-effective-method-function emf ,applyp
+ ,@args ,@restl))
+ (emit-miss 'miss-fn args applyp)
+ (when cached-emf-p 'emf))))))
+
+(defmacro emit-checking-or-caching-macro (cached-emf-p return-value-p metatypes applyp)
+ (let ((*emit-function-p* nil)
+ (*precompiling-lap* t))
+ (values
+ (emit-checking-or-caching cached-emf-p return-value-p metatypes applyp))))
+
+(defun emit-dlap (args metatypes hit miss value-reg &optional slot-regs)
+ (let* ((index -1)
+ (wrapper-bindings (mapcan #'(lambda (arg mt)
+ (unless (eq mt 't)
+ (incf index)
+ `((,(intern (format nil
+ "WRAPPER-~D"
+ index)
+ *pcl-package*)
+ ,(emit-fetch-wrapper mt arg 'miss
+ (pop slot-regs))))))
+ args metatypes))
+ (wrappers (mapcar #'car wrapper-bindings)))
+ (declare (fixnum index))
+ (unless wrappers (error "Every metatype is T."))
+ `(block dfun
+ (tagbody
+ (let ((field (cache-field cache))
+ (cache-vector (cache-vector cache))
+ (mask (cache-mask cache))
+ (size (cache-size cache))
+ (overflow (cache-overflow cache))
+ ,@wrapper-bindings)
+ (declare (fixnum size field mask))
+ ,(cond ((cdr wrappers)
+ (emit-greater-than-1-dlap wrappers 'miss value-reg))
+ (value-reg
+ (emit-1-t-dlap (car wrappers) 'miss value-reg))
+ (t
+ (emit-1-nil-dlap (car wrappers) 'miss)))
+ (return-from dfun ,hit))
+ miss
+ (return-from dfun ,miss)))))
+
+(defun emit-1-nil-dlap (wrapper miss-label)
+ `(let* ((primary ,(emit-1-wrapper-compute-primary-cache-location wrapper miss-label))
+ (location primary))
+ (declare (fixnum primary location))
+ (block search
+ (loop (when (eq ,wrapper (cache-vector-ref cache-vector location))
+ (return-from search nil))
+ (setq location (the fixnum (+ location 1)))
+ (when (= location size)
+ (setq location 0))
+ (when (= location primary)
+ (dolist (entry overflow)
+ (when (eq (car entry) ,wrapper)
+ (return-from search nil)))
+ (go ,miss-label))))))
+
+(defmacro get-cache-vector-lock-count (cache-vector)
+ `(let ((lock-count (cache-vector-lock-count ,cache-vector)))
+ (unless (typep lock-count 'fixnum)
+ (error "My cache got freed somehow."))
+ (the fixnum lock-count)))
+
+(defun emit-1-t-dlap (wrapper miss-label value)
+ `(let ((primary ,(emit-1-wrapper-compute-primary-cache-location wrapper miss-label))
+ (initial-lock-count (get-cache-vector-lock-count cache-vector)))
+ (declare (fixnum primary initial-lock-count))
+ (let ((location primary))
+ (declare (fixnum location))
+ (block search
+ (loop (when (eq ,wrapper (cache-vector-ref cache-vector location))
+ (setq ,value (cache-vector-ref cache-vector (1+ location)))
+ (return-from search nil))
+ (setq location (the fixnum (+ location 2)))
+ (when (= location size)
+ (setq location 0))
+ (when (= location primary)
+ (dolist (entry overflow)
+ (when (eq (car entry) ,wrapper)
+ (setq ,value (cdr entry))
+ (return-from search nil)))
+ (go ,miss-label))))
+ (unless (= initial-lock-count
+ (get-cache-vector-lock-count cache-vector))
+ (go ,miss-label)))))
+
+(defun emit-greater-than-1-dlap (wrappers miss-label value)
+ (declare (type list wrappers))
+ (let ((cache-line-size (compute-line-size (+ (length wrappers) (if value 1 0)))))
+ `(let ((primary 0) (size-1 (the fixnum (- size 1))))
+ (declare (fixnum primary size-1))
+ ,(emit-n-wrapper-compute-primary-cache-location wrappers miss-label)
+ (let ((initial-lock-count (get-cache-vector-lock-count cache-vector)))
+ (declare (fixnum initial-lock-count))
+ (let ((location primary) (next-location 0))
+ (declare (fixnum location next-location))
+ (block search
+ (loop (setq next-location (the fixnum (+ location ,cache-line-size)))
+ (when (and ,@(mapcar
+ #'(lambda (wrapper)
+ `(eq ,wrapper
+ (cache-vector-ref cache-vector
+ (setq location
+ (the fixnum (+ location 1))))))
+ wrappers))
+ ,@(when value
+ `((setq location (the fixnum (+ location 1)))
+ (setq ,value (cache-vector-ref cache-vector location))))
+ (return-from search nil))
+ (setq location next-location)
+ (when (= location size-1)
+ (setq location 0))
+ (when (= location primary)
+ (dolist (entry overflow)
+ (let ((entry-wrappers (car entry)))
+ (when (and ,@(mapcar #'(lambda (wrapper)
+ `(eq ,wrapper (pop entry-wrappers)))
+ wrappers))
+ ,@(when value
+ `((setq ,value (cdr entry))))
+ (return-from search nil))))
+ (go ,miss-label))))
+ (unless (= initial-lock-count
+ (get-cache-vector-lock-count cache-vector))
+ (go ,miss-label)))))))
+
+(defun emit-1-wrapper-compute-primary-cache-location (wrapper miss-label)
+ `(let ((wrapper-cache-no (wrapper-cache-number-vector-ref ,wrapper field)))
+ (declare (fixnum wrapper-cache-no))
+ (when (zerop wrapper-cache-no) (go ,miss-label))
+ ,(let ((form `(logand mask wrapper-cache-no)))
+ `(the fixnum ,form))))
+
+(defun emit-n-wrapper-compute-primary-cache-location (wrappers miss-label)
+ (declare (type list wrappers))
+ ;; This returns 1 less that the actual location.
+ `(progn
+ ,@(let ((adds 0) (len (length wrappers)))
+ (declare (fixnum adds len))
+ (mapcar #'(lambda (wrapper)
+ `(let ((wrapper-cache-no (wrapper-cache-number-vector-ref
+ ,wrapper field)))
+ (declare (fixnum wrapper-cache-no))
+ (when (zerop wrapper-cache-no) (go ,miss-label))
+ (setq primary (the fixnum (+ primary wrapper-cache-no)))
+ ,@(progn
+ (incf adds)
+ (when (or (zerop (mod adds wrapper-cache-number-adds-ok))
+ (eql adds len))
+ `((setq primary
+ ,(let ((form `(logand primary mask)))
+ `(the fixnum ,form))))))))
+ wrappers))))
+
+;;; CMU17 (and SBCL) note: Since STD-INSTANCE-P is weakened in the CMU/SBCL
+;;; approach of using funcallable instances, that branch may run
+;;; on non-pcl instances (structures). The result will be the
+;;; non-wrapper layout for the structure, which will cause a miss. The "slots"
+;;; will be whatever the first slot is, but will be ignored. Similarly,
+;;; fsc-instance-p returns true on funcallable structures as well as PCL fins.
+(defun emit-fetch-wrapper (metatype argument miss-label &optional slot)
+ (ecase metatype
+ ((standard-instance)
+ `(cond ((std-instance-p ,argument)
+ ,@(when slot `((setq ,slot (std-instance-slots ,argument))))
+ (std-instance-wrapper ,argument))
+ ((fsc-instance-p ,argument)
+ ,@(when slot `((setq ,slot (fsc-instance-slots ,argument))))
+ (fsc-instance-wrapper ,argument))
+ (t
+ (go ,miss-label))))
+ (class
+ (when slot (error "can't do a slot reg for this metatype"))
+ `(wrapper-of-macro ,argument))
+ ((built-in-instance structure-instance)
+ (when slot (error "can't do a slot reg for this metatype"))
+ `(built-in-or-structure-wrapper
+ ,argument))))
+
--- /dev/null
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+
+;;;; This software is derived from software originally released by Xerox
+;;;; Corporation. Copyright and release statements follow. Later modifications
+;;;; to the software are in the public domain and are provided with
+;;;; absolutely no warranty. See the COPYING and CREDITS files for more
+;;;; information.
+
+;;;; copyright information from original PCL sources:
+;;;;
+;;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
+;;;; All rights reserved.
+;;;;
+;;;; Use and copying of this software and preparation of derivative works based
+;;;; upon this software are permitted. Any distribution of this software or
+;;;; derivative works must comply with all applicable United States export
+;;;; control laws.
+;;;;
+;;;; This software is made available AS IS, and Xerox Corporation makes no
+;;;; warranty about the software, its performance or its conformity to any
+;;;; specification.
+
+(in-package "SB-PCL")
+
+(sb-int:file-comment
+ "$Header$")
+\f
+(defun emit-reader/writer-function (reader/writer 1-or-2-class class-slot-p)
+ (values
+ (ecase reader/writer
+ (:reader (ecase 1-or-2-class
+ (1 (if class-slot-p
+ (emit-reader/writer-macro :reader 1 t)
+ (emit-reader/writer-macro :reader 1 nil)))
+ (2 (if class-slot-p
+ (emit-reader/writer-macro :reader 2 t)
+ (emit-reader/writer-macro :reader 2 nil)))))
+ (:writer (ecase 1-or-2-class
+ (1 (if class-slot-p
+ (emit-reader/writer-macro :writer 1 t)
+ (emit-reader/writer-macro :writer 1 nil)))
+ (2 (if class-slot-p
+ (emit-reader/writer-macro :writer 2 t)
+ (emit-reader/writer-macro :writer 2 nil))))))
+ nil))
+
+(defun emit-one-or-n-index-reader/writer-function
+ (reader/writer cached-index-p class-slot-p)
+ (values
+ (ecase reader/writer
+ (:reader (if cached-index-p
+ (if class-slot-p
+ (emit-one-or-n-index-reader/writer-macro :reader t t)
+ (emit-one-or-n-index-reader/writer-macro :reader t nil))
+ (if class-slot-p
+ (emit-one-or-n-index-reader/writer-macro :reader nil t)
+ (emit-one-or-n-index-reader/writer-macro :reader nil nil))))
+ (:writer (if cached-index-p
+ (if class-slot-p
+ (emit-one-or-n-index-reader/writer-macro :writer t t)
+ (emit-one-or-n-index-reader/writer-macro :writer t nil))
+ (if class-slot-p
+ (emit-one-or-n-index-reader/writer-macro :writer nil t)
+ (emit-one-or-n-index-reader/writer-macro :writer nil nil)))))
+ nil))
+
+;;; Note this list is setup in dlisp3.lisp when all the necessary
+;;; macros have been loaded.
+(defvar *checking-or-caching-function-list* nil)
+
+(defmacro emit-checking-or-caching-function-precompiled ()
+ `(cdr (assoc (list cached-emf-p return-value-p metatypes applyp)
+ *checking-or-caching-function-list*
+ :test #'equal)))
+
+(defun emit-checking-or-caching-function (cached-emf-p return-value-p metatypes applyp)
+ (let ((fn (emit-checking-or-caching-function-precompiled)))
+ (if fn
+ (values fn nil)
+ (values (emit-checking-or-caching-function-preliminary
+ cached-emf-p return-value-p metatypes applyp)
+ t))))
+
+(defvar *not-in-cache* (make-symbol "not in cache"))
+
+(defun emit-checking-or-caching-function-preliminary
+ (cached-emf-p return-value-p metatypes applyp)
+ (declare (ignore applyp))
+ (if cached-emf-p
+ #'(lambda (cache miss-fn)
+ (declare (type function miss-fn))
+ #'(sb-kernel:instance-lambda (&rest args)
+ (declare #.*optimize-speed*)
+ (with-dfun-wrappers (args metatypes)
+ (dfun-wrappers invalid-wrapper-p)
+ (apply miss-fn args)
+ (if invalid-wrapper-p
+ (apply miss-fn args)
+ (let ((emf (probe-cache cache dfun-wrappers *not-in-cache*)))
+ (if (eq emf *not-in-cache*)
+ (apply miss-fn args)
+ (if return-value-p
+ emf
+ (invoke-emf emf args))))))))
+ #'(lambda (cache emf miss-fn)
+ (declare (type function miss-fn))
+ #'(sb-kernel:instance-lambda (&rest args)
+ (declare #.*optimize-speed*)
+ (with-dfun-wrappers (args metatypes)
+ (dfun-wrappers invalid-wrapper-p)
+ (apply miss-fn args)
+ (if invalid-wrapper-p
+ (apply miss-fn args)
+ (let ((found-p (not (eq *not-in-cache*
+ (probe-cache cache dfun-wrappers
+ *not-in-cache*)))))
+ (if found-p
+ (invoke-emf emf args)
+ (if return-value-p
+ t
+ (apply miss-fn args))))))))))
+
+(defun emit-default-only-function (metatypes applyp)
+ (declare (ignore metatypes applyp))
+ (values #'(lambda (emf)
+ #'(lambda (&rest args)
+ (invoke-emf emf args)))
+ t))
--- /dev/null
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+
+;;;; This software is derived from software originally released by Xerox
+;;;; Corporation. Copyright and release statements follow. Later modifications
+;;;; to the software are in the public domain and are provided with
+;;;; absolutely no warranty. See the COPYING and CREDITS files for more
+;;;; information.
+
+;;;; copyright information from original PCL sources:
+;;;;
+;;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
+;;;; All rights reserved.
+;;;;
+;;;; Use and copying of this software and preparation of derivative works based
+;;;; upon this software are permitted. Any distribution of this software or
+;;;; derivative works must comply with all applicable United States export
+;;;; control laws.
+;;;;
+;;;; This software is made available AS IS, and Xerox Corporation makes no
+;;;; warranty about the software, its performance or its conformity to any
+;;;; specification.
+
+(in-package "SB-PCL")
+
+(sb-int:file-comment
+ "$Header$")
+\f
+(eval-when (:compile-toplevel :load-toplevel :execute)
+(defparameter *checking-or-caching-list*
+ '((t nil (class) nil)
+ (t nil (class class) nil)
+ (t nil (class class class) nil)
+ (t nil (class class t) nil)
+ (t nil (class class t t) nil)
+ (t nil (class class t t t) nil)
+ (t nil (class t) nil)
+ (t nil (class t t) nil)
+ (t nil (class t t t) nil)
+ (t nil (class t t t t) nil)
+ (t nil (class t t t t t) nil)
+ (t nil (class t t t t t t) nil)
+ (t nil (t class) nil)
+ (t nil (t class t) nil)
+ (t nil (t t class) nil)
+ (t nil (class) t)
+ (t nil (class class) t)
+ (t nil (class t) t)
+ (t nil (class t t) t)
+ (t nil (class t t t) t)
+ (t nil (t class) t)
+ (t t (class) nil)
+ (t t (class class) nil)
+ (t t (class class class) nil)
+ (nil nil (class) nil)
+ (nil nil (class class) nil)
+ (nil nil (class class t) nil)
+ (nil nil (class class t t) nil)
+ (nil nil (class t) nil)
+ (nil nil (t class t) nil)
+ (nil nil (class) t)
+ (nil nil (class class) t)))
+) ; EVAL-WHEN
+
+(defmacro make-checking-or-caching-function-list ()
+ `(list ,@(mapcar #'(lambda (key)
+ `(cons ',key (emit-checking-or-caching-macro ,@key)))
+ *checking-or-caching-list*)))
+
+;;; Rather than compiling the constructors here, just tickle the range
+;;; of shapes defined above, leaving the generation of the
+;;; constructors to precompile-dfun-constructors.
+(dolist (key *checking-or-caching-list*)
+ (destructuring-bind (cached-emf-p return-value-p metatypes applyp) key
+ (multiple-value-bind (args generator)
+ (if cached-emf-p
+ (if return-value-p
+ (values (list metatypes) 'emit-constant-value)
+ (values (list metatypes applyp) 'emit-caching))
+ (if return-value-p
+ (values (list metatypes) 'emit-in-checking-p)
+ (values (list metatypes applyp) 'emit-checking)))
+ (apply #'get-dfun-constructor generator args))))
--- /dev/null
+;;;; implementation of CL:DOCUMENTATION
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+
+;;;; This software is in the public domain and is provided with absolutely no
+;;;; warranty. See the COPYING and CREDITS files for more information.
+
+(sb-int:file-comment
+ "$Header$")
+
+(in-package "SB-PCL")
+
+;;; Note some cases are handled by the documentation methods in
+;;; std-class.lisp.
+;;; FIXME: Those should probably be moved into this file too.
+
+;;; FIXME: Lots of bare calls to INFO here could be handled
+;;; more cleanly by calling the FDOCUMENTATION function instead.
+
+;;; FIXME: Neither SBCL nor Debian CMU CL 2.4.17 handles
+;;; (DEFUN FOO ())
+;;; (SETF (DOCUMENTATION #'FOO 'FUNCTION) "testing")
+;;; They fail with
+;;; Can't change the documentation of #<interpreted function FOO {900BF51}>.
+;;; The coverage of the DOCUMENTATION methods ought to be systematically
+;;; compared to the ANSI specification of DOCUMENTATION.
+
+;;; functions, macros, and special forms
+(defmethod documentation ((x function) (doc-type (eql 't)))
+ (sb-impl::function-doc x))
+
+(defmethod documentation ((x function) (doc-type (eql 'function)))
+ (sb-impl::function-doc x))
+
+(defmethod documentation ((x list) (doc-type (eql 'function)))
+ ;; FIXME: could test harder to see whether it's a SETF function name,
+ ;; then call WARN
+ (when (eq (first x) 'setf) ; Give up if not a setf function name.
+ (or (values (sb-int:info :setf :documentation (second x)))
+ ;; Try the pcl function documentation.
+ (and (fboundp x) (documentation (fdefinition x) 't)))))
+
+(defmethod documentation ((x symbol) (doc-type (eql 'function)))
+ (or (values (sb-int:info :function :documentation x))
+ ;; Try the pcl function documentation.
+ (and (fboundp x) (documentation (fdefinition x) 't))))
+
+(defmethod documentation ((x symbol) (doc-type (eql 'setf)))
+ (values (sb-int:info :setf :documentation x)))
+
+(defmethod (setf documentation) (new-value (x list) (doc-type (eql 'function)))
+ (setf (sb-int:info :setf :documentation (cadr x)) new-value))
+
+(defmethod (setf documentation) (new-value
+ (x symbol)
+ (doc-type (eql 'function)))
+ (setf (sb-int:info :function :documentation x) new-value))
+
+(defmethod (setf documentation) (new-value (x symbol) (doc-type (eql 'setf)))
+ (setf (sb-int:info :setf :documentation x) new-value))
+
+;;; packages
+(defmethod documentation ((x package) (doc-type (eql 't)))
+ (sb-impl::package-doc-string x))
+
+(defmethod (setf documentation) (new-value (x package) (doc-type (eql 't)))
+ (setf (sb-impl::package-doc-string x) new-value))
+;;; KLUDGE: It's nasty having things like this accessor floating around
+;;; out in this mostly-unrelated source file. Perhaps it would be
+;;; better to support WARM-INIT-FORMS by analogy with the existing
+;;; !COLD-INIT-FORMS and have them be EVAL'ed after basic warm load is
+;;; done? That way things like this could be defined alongside the
+;;; other code which does low-level hacking of packages.. -- WHN 19991203
+
+;;; types, classes, and structure names
+(defmethod documentation ((x cl:structure-class) (doc-type (eql 't)))
+ (values (sb-int:info :type :documentation (cl:class-name x))))
+
+(defmethod documentation ((x structure-class) (doc-type (eql 't)))
+ (values (sb-int:info :type :documentation (class-name x))))
+
+(defmethod documentation ((x cl:standard-class) (doc-type (eql 't)))
+ (or (values (sb-int:info :type :documentation (cl:class-name x)))
+ (let ((pcl-class (sb-kernel:class-pcl-class x)))
+ (and pcl-class (plist-value pcl-class 'documentation)))))
+
+(defmethod documentation ((x cl:structure-class) (doc-type (eql 'type)))
+ (values (sb-int:info :type :documentation (cl:class-name x))))
+
+(defmethod documentation ((x structure-class) (doc-type (eql 'type)))
+ (values (sb-int:info :type :documentation (class-name x))))
+
+(defmethod documentation ((x cl:standard-class) (doc-type (eql 'type)))
+ (or (values (sb-int:info :type :documentation (cl:class-name x)))
+ (let ((pcl-class (sb-kernel:class-pcl-class x)))
+ (and pcl-class (plist-value pcl-class 'documentation)))))
+
+(defmethod documentation ((x symbol) (doc-type (eql 'type)))
+ (or (values (sb-int:info :type :documentation x))
+ (let ((class (find-class x nil)))
+ (when class
+ (plist-value class 'documentation)))))
+
+(defmethod documentation ((x symbol) (doc-type (eql 'structure)))
+ (when (eq (sb-int:info :type :kind x) :instance)
+ (values (sb-int:info :type :documentation x))))
+
+(defmethod (setf documentation) (new-value
+ (x cl:structure-class)
+ (doc-type (eql 't)))
+ (setf (sb-int:info :type :documentation (cl:class-name x)) new-value))
+
+(defmethod (setf documentation) (new-value
+ (x structure-class)
+ (doc-type (eql 't)))
+ (setf (sb-int:info :type :documentation (class-name x)) new-value))
+
+(defmethod (setf documentation) (new-value
+ (x cl:structure-class)
+ (doc-type (eql 'type)))
+ (setf (sb-int:info :type :documentation (cl:class-name x)) new-value))
+
+(defmethod (setf documentation) (new-value
+ (x structure-class)
+ (doc-type (eql 'type)))
+ (setf (sb-int:info :type :documentation (class-name x)) new-value))
+
+(defmethod (setf documentation) (new-value (x symbol) (doc-type (eql 'type)))
+ (if (structure-type-p x) ; Catch structures first.
+ (setf (sb-int:info :type :documentation x) new-value)
+ (let ((class (find-class x nil)))
+ (if class
+ (setf (plist-value class 'documentation) new-value)
+ (setf (sb-int:info :type :documentation x) new-value)))))
+
+(defmethod (setf documentation) (new-value
+ (x symbol)
+ (doc-type (eql 'structure)))
+ (unless (eq (sb-int:info :type :kind x) :instance)
+ (error "~S is not the name of a structure type." x))
+ (setf (sb-int:info :type :documentation x) new-value))
+
+;;; variables
+(defmethod documentation ((x symbol) (doc-type (eql 'variable)))
+ (values (sb-int:info :variable :documentation x)))
+
+(defmethod (setf documentation) (new-value
+ (x symbol)
+ (doc-type (eql 'variable)))
+ (setf (sb-int:info :variable :documentation x) new-value))
+
+;;; miscellaneous documentation. Compiler-macro documentation is stored
+;;; as random-documentation and handled here.
+(defmethod documentation ((x symbol) (doc-type symbol))
+ (cdr (assoc doc-type
+ (values (sb-int:info :random-documentation :stuff x)))))
+
+(defmethod (setf documentation) (new-value (x symbol) (doc-type symbol))
+ (let ((pair (assoc doc-type (sb-int:info :random-documentation :stuff x))))
+ (if pair
+ (setf (cdr pair) new-value)
+ (push (cons doc-type new-value)
+ (sb-int:info :random-documentation :stuff x))))
+ new-value)
+
+;;; FIXME: The ((X SYMBOL) (DOC-TYPE SYMBOL)) method and its setf method should
+;;; have parallel versions which accept LIST-valued X arguments (for function
+;;; names in the (SETF FOO) style).
+
+;;; Now that we have created the machinery for setting documentation, we can
+;;; set the documentation for the machinery for setting documentation.
+#+sb-doc
+(setf (documentation 'documentation 'function)
+ "Return the documentation string of Doc-Type for X, or NIL if
+ none exists. System doc-types are VARIABLE, FUNCTION, STRUCTURE, TYPE,
+ SETF, and T.")
--- /dev/null
+;;;; some code pulled out of CMU CL's low.lisp to solve build order problems,
+;;;; and some other stuff that just plain needs to be done early
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+
+;;;; This software is derived from software originally released by Xerox
+;;;; Corporation. Copyright and release statements follow. Later modifications
+;;;; to the software are in the public domain and are provided with
+;;;; absolutely no warranty. See the COPYING and CREDITS files for more
+;;;; information.
+
+;;;; copyright information from original PCL sources:
+;;;;
+;;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
+;;;; All rights reserved.
+;;;;
+;;;; Use and copying of this software and preparation of derivative works based
+;;;; upon this software are permitted. Any distribution of this software or
+;;;; derivative works must comply with all applicable United States export
+;;;; control laws.
+;;;;
+;;;; This software is made available AS IS, and Xerox Corporation makes no
+;;;; warranty about the software, its performance or its conformity to any
+;;;; specification.
+
+(sb-int:file-comment
+ "$Header$")
+
+(in-package "SB-PCL")
+\f
+;;; FIXME: The PCL package is internal and is used by code in potential
+;;; bottlenecks. Access to it might be faster through #.(find-package "SB-PCL")
+;;; than through *PCL-PACKAGE*. And since it's internal, no one should be
+;;; doing things like deleting and recreating it in a running target Lisp.
+;;; So perhaps we should replace it uses of *PCL-PACKAGE* with uses of
+;;; (PCL-PACKAGE), and make PCL-PACKAGE a macro which expands into
+;;; the SB-PCL package itself. Maybe we should even use this trick for
+;;; COMMON-LISP and KEYWORD, too. (And the definition of PCL-PACKAGE etc.
+;;; could be made less viciously brittle when SB-FLUID.)
+;;; (Or perhaps just define a macro
+;;; (DEFMACRO PKG (NAME)
+;;; #!-SB-FLUID (FIND-PACKAGE NAME)
+;;; #!+SB-FLUID `(FIND-PACKAGE ,NAME))
+;;; and use that to replace all three variables.)
+(defvar *pcl-package* (find-package "SB-PCL"))
+(defvar *slot-accessor-name-package* (find-package "SB-SLOT-ACCESSOR-NAME"))
+
+;;; This excludes structure types created with the :TYPE option to
+;;; DEFSTRUCT. It also doesn't try to deal with types created by
+;;; hairy DEFTYPEs, e.g.
+;;; (DEFTYPE CACHE-STRUCTURE (SIZE)
+;;; (IF (> SIZE 11) 'BIG-CS 'SMALL-CS)).
+;;; KLUDGE: In fact, it doesn't seem to deal with DEFTYPEs at all. Perhaps
+;;; it needs a more mnemonic name. -- WHN 19991204
+(defun structure-type-p (type)
+ (and (symbolp type)
+ (let ((class (cl:find-class type nil)))
+ (and class
+ (typep (sb-kernel:layout-info (sb-kernel:class-layout class))
+ 'sb-kernel:defstruct-description)))))
--- /dev/null
+;;;; basic environmental stuff
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+
+;;;; This software is derived from software originally released by Xerox
+;;;; Corporation. Copyright and release statements follow. Later modifications
+;;;; to the software are in the public domain and are provided with
+;;;; absolutely no warranty. See the COPYING and CREDITS files for more
+;;;; information.
+
+;;;; copyright information from original PCL sources:
+;;;;
+;;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
+;;;; All rights reserved.
+;;;;
+;;;; Use and copying of this software and preparation of derivative works based
+;;;; upon this software are permitted. Any distribution of this software or
+;;;; derivative works must comply with all applicable United States export
+;;;; control laws.
+;;;;
+;;;; This software is made available AS IS, and Xerox Corporation makes no
+;;;; warranty about the software, its performance or its conformity to any
+;;;; specification.
+
+(in-package "SB-PCL")
+
+(sb-int:file-comment
+ "$Header$")
+\f
+;;; FIXME: This stuff isn't part of the ANSI spec, and isn't even
+;;; exported from PCL, but it looks as though it might be useful,
+;;; so I don't want to just delete it. Perhaps it should go in
+;;; a contrib/ directory eventually?
+
+#|
+;;; TRACE-METHOD and UNTRACE-METHOD accept method specs as arguments. A
+;;; method-spec should be a list like:
+;;; (<generic-function-spec> qualifiers* (specializers*))
+;;; where <generic-function-spec> should be either a symbol or a list
+;;; of (SETF <symbol>).
+;;;
+;;; For example, to trace the method defined by:
+;;;
+;;; (defmethod foo ((x spaceship)) 'ss)
+;;;
+;;; You should say:
+;;;
+;;; (trace-method '(foo (spaceship)))
+;;;
+;;; You can also provide a method object in the place of the method
+;;; spec, in which case that method object will be traced.
+;;;
+;;; For untrace-method, if an argument is given, that method is untraced.
+;;; If no argument is given, all traced methods are untraced.
+(defclass traced-method (method)
+ ((method :initarg :method)
+ (function :initarg :function
+ :reader method-function)
+ (generic-function :initform nil
+ :accessor method-generic-function)))
+
+(defmethod method-lambda-list ((m traced-method))
+ (with-slots (method) m (method-lambda-list method)))
+
+(defmethod method-specializers ((m traced-method))
+ (with-slots (method) m (method-specializers method)))
+
+(defmethod method-qualifiers ((m traced-method))
+ (with-slots (method) m (method-qualifiers method)))
+
+(defmethod accessor-method-slot-name ((m traced-method))
+ (with-slots (method) m (accessor-method-slot-name method)))
+
+(defvar *traced-methods* ())
+
+(defun trace-method (spec &rest options)
+ (multiple-value-bind (gf omethod name)
+ (parse-method-or-spec spec)
+ (let* ((tfunction (trace-method-internal (method-function omethod)
+ name
+ options))
+ (tmethod (make-instance 'traced-method
+ :method omethod
+ :function tfunction)))
+ (remove-method gf omethod)
+ (add-method gf tmethod)
+ (pushnew tmethod *traced-methods*)
+ tmethod)))
+
+(defun untrace-method (&optional spec)
+ (flet ((untrace-1 (m)
+ (let ((gf (method-generic-function m)))
+ (when gf
+ (remove-method gf m)
+ (add-method gf (slot-value m 'method))
+ (setq *traced-methods* (remove m *traced-methods*))))))
+ (if (not (null spec))
+ (multiple-value-bind (gf method)
+ (parse-method-or-spec spec)
+ (declare (ignore gf))
+ (if (memq method *traced-methods*)
+ (untrace-1 method)
+ (error "~S is not a traced method?" method)))
+ (dolist (m *traced-methods*) (untrace-1 m)))))
+
+(defun trace-method-internal (ofunction name options)
+ (eval `(untrace ,name))
+ (setf (symbol-function name) ofunction)
+ (eval `(trace ,name ,@options))
+ (symbol-function name))
+|#
+\f
+;(defun compile-method (spec)
+; (multiple-value-bind (gf method name)
+; (parse-method-or-spec spec)
+; (declare (ignore gf))
+; (compile name (method-function method))
+; (setf (method-function method) (symbol-function name))))
+
+;;; not used in SBCL
+#|
+(defmacro undefmethod (&rest args)
+ (declare (arglist name {method-qualifier}* specializers))
+ `(undefmethod-1 ',args))
+
+(defun undefmethod-1 (args)
+ (multiple-value-bind (gf method)
+ (parse-method-or-spec args)
+ (when (and gf method)
+ (remove-method gf method)
+ method)))
+|#
+
+;;; FIXME: Delete these.
+#|
+(pushnew :pcl *features*)
+(pushnew :portable-commonloops *features*)
+(pushnew :pcl-structures *features*)
+|#
+
+;;; FIXME: This was for some unclean bootstrapping thing we don't
+;;; need in SBCL, right? So we can delete it, right?
+;;; #+cmu
+;;; (when (find-package "OLD-PCL")
+;;; (setf (symbol-function (find-symbol "PRINT-OBJECT" :old-pcl))
+;;; (symbol-function 'sb-pcl::print-object)))
+\f
+;;;; MAKE-LOAD-FORM
+
+;; Overwrite the old bootstrap non-generic MAKE-LOAD-FORM function with a
+;; shiny new generic function.
+(fmakunbound 'make-load-form)
+(defgeneric make-load-form (object &optional environment))
+
+;; Link bootstrap-time how-to-dump-it information into the shiny new
+;; CLOS system.
+(defmethod make-load-form ((obj sb-sys:structure!object)
+ &optional (env nil env-p))
+ (if env-p
+ (sb-sys:structure!object-make-load-form obj env)
+ (sb-sys:structure!object-make-load-form obj)))
+
+(defmethod make-load-form ((object wrapper) &optional env)
+ (declare (ignore env))
+ (let ((pname (sb-kernel:class-proper-name (sb-kernel:layout-class object))))
+ (unless pname
+ (error "can't dump wrapper for anonymous class:~% ~S"
+ (sb-kernel:layout-class object)))
+ `(sb-kernel:class-layout (cl:find-class ',pname))))
+\f
+;;;; The following are hacks to deal with CMU CL having two different CLASS
+;;;; classes.
+
+(defun coerce-to-pcl-class (class)
+ (if (typep class 'cl:class)
+ (or (sb-kernel:class-pcl-class class)
+ (find-structure-class (cl:class-name class)))
+ class))
+
+(defmethod make-instance ((class cl:class) &rest stuff)
+ (apply #'make-instance (coerce-to-pcl-class class) stuff))
+(defmethod change-class (instance (class cl:class))
+ (apply #'change-class instance (coerce-to-pcl-class class)))
+
+(macrolet ((frob (&rest names)
+ `(progn
+ ,@(mapcar #'(lambda (name)
+ `(defmethod ,name ((class cl:class))
+ (funcall #',name
+ (coerce-to-pcl-class class))))
+ names))))
+ (frob
+ class-direct-slots
+ class-prototype
+ class-precedence-list
+ class-direct-default-initargs
+ class-direct-superclasses
+ compute-class-precedence-list
+ class-default-initargs class-finalized-p
+ class-direct-subclasses class-slots
+ make-instances-obsolete))
--- /dev/null
+;;;; This file defines the optimized make-instance functions.
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+
+;;;; This software is derived from software originally released by Xerox
+;;;; Corporation. Copyright and release statements follow. Later modifications
+;;;; to the software are in the public domain and are provided with
+;;;; absolutely no warranty. See the COPYING and CREDITS files for more
+;;;; information.
+
+;;;; copyright information from original PCL sources:
+;;;;
+;;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
+;;;; All rights reserved.
+;;;;
+;;;; Use and copying of this software and preparation of derivative works based
+;;;; upon this software are permitted. Any distribution of this software or
+;;;; derivative works must comply with all applicable United States export
+;;;; control laws.
+;;;;
+;;;; This software is made available AS IS, and Xerox Corporation makes no
+;;;; warranty about the software, its performance or its conformity to any
+;;;; specification.
+
+(in-package "SB-PCL")
+
+(sb-int:file-comment
+ "$Header$")
+\f
+(defvar *compile-make-instance-functions-p* nil)
+
+(defun update-make-instance-function-table (&optional (class *the-class-t*))
+ (when (symbolp class) (setq class (find-class class)))
+ (when (eq class *the-class-t*) (setq class *the-class-slot-object*))
+ (when (memq *the-class-slot-object* (class-precedence-list class))
+ (map-all-classes #'reset-class-initialize-info class)))
+
+(defun constant-symbol-p (form)
+ (and (constantp form)
+ (let ((object (eval form)))
+ (and (symbolp object)
+ (symbol-package object)))))
+
+(defvar *make-instance-function-keys* nil)
+
+(defun expand-make-instance-form (form)
+ (let ((class (cadr form)) (initargs (cddr form))
+ (keys nil)(allow-other-keys-p nil) key value)
+ (when (and (constant-symbol-p class)
+ (let ((initargs-tail initargs))
+ (loop (when (null initargs-tail) (return t))
+ (unless (constant-symbol-p (car initargs-tail))
+ (return nil))
+ (setq key (eval (pop initargs-tail)))
+ (setq value (pop initargs-tail))
+ (when (eq ':allow-other-keys key)
+ (setq allow-other-keys-p value))
+ (push key keys))))
+ (let* ((class (eval class))
+ (keys (nreverse keys))
+ (key (list class keys allow-other-keys-p))
+ (sym (make-instance-function-symbol key)))
+ (push key *make-instance-function-keys*)
+ (when sym
+ `(,sym ',class (list ,@initargs)))))))
+
+(defmacro expanding-make-instance-top-level (&rest forms &environment env)
+ (let* ((*make-instance-function-keys* nil)
+ (form (macroexpand `(expanding-make-instance ,@forms) env)))
+ `(progn
+ ,@(when *make-instance-function-keys*
+ `((get-make-instance-functions ',*make-instance-function-keys*)))
+ ,form)))
+
+(defmacro expanding-make-instance (&rest forms &environment env)
+ `(progn
+ ,@(mapcar #'(lambda (form)
+ (walk-form form env
+ #'(lambda (subform context env)
+ (declare (ignore env))
+ (or (and (eq context ':eval)
+ (consp subform)
+ (eq (car subform) 'make-instance)
+ (expand-make-instance-form subform))
+ subform))))
+ forms)))
+
+(defmacro defconstructor
+ (name class lambda-list &rest initialization-arguments)
+ `(expanding-make-instance-top-level
+ (defun ,name ,lambda-list
+ (make-instance ',class ,@initialization-arguments))))
+
+(defun get-make-instance-functions (key-list)
+ (dolist (key key-list)
+ (let* ((cell (find-class-cell (car key)))
+ (make-instance-function-keys
+ (find-class-cell-make-instance-function-keys cell))
+ (mif-key (cons (cadr key) (caddr key))))
+ (unless (find mif-key make-instance-function-keys
+ :test #'equal)
+ (push mif-key (find-class-cell-make-instance-function-keys cell))
+ (let ((class (find-class-cell-class cell)))
+ (when (and class (not (forward-referenced-class-p class)))
+ (update-initialize-info-internal
+ (initialize-info class (car mif-key) nil (cdr mif-key))
+ 'make-instance-function)))))))
+
+(defun make-instance-function-symbol (key)
+ (let* ((class (car key))
+ (symbolp (symbolp class)))
+ (when (or symbolp (classp class))
+ (let* ((class-name (if (symbolp class) class (class-name class)))
+ (keys (cadr key))
+ (allow-other-keys-p (caddr key)))
+ (when (and (or symbolp
+ (and (symbolp class-name)
+ (eq class (find-class class-name nil))))
+ (symbol-package class-name))
+ (let ((*package* *pcl-package*)
+ (*print-length* nil)
+ (*print-level* nil)
+ (*print-circle* nil)
+ (*print-case* :upcase)
+ (*print-pretty* nil))
+ (intern (format nil
+ "MAKE-INSTANCE ~S ~S ~S"
+ class-name
+ keys
+ allow-other-keys-p))))))))
+
+(defun make-instance-1 (class initargs)
+ (apply #'make-instance class initargs))
+
+(defmacro define-cached-reader (type name trap)
+ (let ((reader-name (intern (format nil "~A-~A" type name)))
+ (cached-name (intern (format nil "~A-CACHED-~A" type name))))
+ `(defmacro ,reader-name (info)
+ `(let ((value (,',cached-name ,info)))
+ (if (eq value ':unknown)
+ (progn
+ (,',trap ,info ',',name)
+ (,',cached-name ,info))
+ value)))))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+(defparameter *initialize-info-cached-slots*
+ '(valid-p ; t or (:invalid key)
+ ri-valid-p
+ initargs-form-list
+ new-keys
+ default-initargs-function
+ shared-initialize-t-function
+ shared-initialize-nil-function
+ constants
+ combined-initialize-function ; allocate-instance + shared-initialize
+ make-instance-function ; nil means use gf
+ make-instance-function-symbol)))
+
+(defmacro define-initialize-info ()
+ (let ((cached-slot-names
+ (mapcar #'(lambda (name)
+ (intern (format nil "CACHED-~A" name)))
+ *initialize-info-cached-slots*))
+ (cached-names
+ (mapcar #'(lambda (name)
+ (intern (format nil "~A-CACHED-~A"
+ 'initialize-info name)))
+ *initialize-info-cached-slots*)))
+ `(progn
+ (defstruct initialize-info
+ key wrapper
+ ,@(mapcar #'(lambda (name)
+ `(,name :unknown))
+ cached-slot-names))
+ (defmacro reset-initialize-info-internal (info)
+ `(progn
+ ,@(mapcar #'(lambda (cname)
+ `(setf (,cname ,info) ':unknown))
+ ',cached-names)))
+ (defun initialize-info-bound-slots (info)
+ (let ((slots nil))
+ ,@(mapcar #'(lambda (name cached-name)
+ `(unless (eq ':unknown (,cached-name info))
+ (push ',name slots)))
+ *initialize-info-cached-slots* cached-names)
+ slots))
+ ,@(mapcar #'(lambda (name)
+ `(define-cached-reader initialize-info ,name
+ update-initialize-info-internal))
+ *initialize-info-cached-slots*))))
+
+(define-initialize-info)
+
+(defvar *initialize-info-cache-class* nil)
+(defvar *initialize-info-cache-initargs* nil)
+(defvar *initialize-info-cache-info* nil)
+
+(defvar *revert-initialize-info-p* nil)
+
+(defun reset-initialize-info (info)
+ (setf (initialize-info-wrapper info)
+ (class-wrapper (car (initialize-info-key info))))
+ (let ((slots-to-revert (if *revert-initialize-info-p*
+ (initialize-info-bound-slots info)
+ '(make-instance-function))))
+ (reset-initialize-info-internal info)
+ (dolist (slot slots-to-revert)
+ (update-initialize-info-internal info slot))
+ info))
+
+(defun reset-class-initialize-info (class)
+ (reset-class-initialize-info-1 (class-initialize-info class)))
+
+(defun reset-class-initialize-info-1 (cell)
+ (when (consp cell)
+ (when (car cell)
+ (reset-initialize-info (car cell)))
+ (let ((alist (cdr cell)))
+ (dolist (a alist)
+ (reset-class-initialize-info-1 (cdr a))))))
+
+(defun initialize-info (class initargs &optional (plist-p t) allow-other-keys-arg)
+ (let ((info nil))
+ (if (and (eq *initialize-info-cache-class* class)
+ (eq *initialize-info-cache-initargs* initargs))
+ (setq info *initialize-info-cache-info*)
+ (let ((initargs-tail initargs)
+ (cell (or (class-initialize-info class)
+ (setf (class-initialize-info class) (cons nil nil)))))
+ (loop (when (null initargs-tail) (return nil))
+ (let ((keyword (pop initargs-tail))
+ (alist-cell cell))
+ (when plist-p
+ (if (eq keyword :allow-other-keys)
+ (setq allow-other-keys-arg (pop initargs-tail))
+ (pop initargs-tail)))
+ (loop (let ((alist (cdr alist-cell)))
+ (when (null alist)
+ (setq cell (cons nil nil))
+ (setf (cdr alist-cell) (list (cons keyword cell)))
+ (return nil))
+ (when (eql keyword (caar alist))
+ (setq cell (cdar alist))
+ (return nil))
+ (setq alist-cell alist)))))
+ (setq info (or (car cell)
+ (setf (car cell) (make-initialize-info))))))
+ (let ((wrapper (initialize-info-wrapper info)))
+ (unless (eq wrapper (class-wrapper class))
+ (unless wrapper
+ (let* ((initargs-tail initargs)
+ (klist-cell (list nil))
+ (klist-tail klist-cell))
+ (loop (when (null initargs-tail) (return nil))
+ (let ((key (pop initargs-tail)))
+ (setf (cdr klist-tail) (list key)))
+ (setf klist-tail (cdr klist-tail))
+ (when plist-p (pop initargs-tail)))
+ (setf (initialize-info-key info)
+ (list class (cdr klist-cell) allow-other-keys-arg))))
+ (reset-initialize-info info)))
+ (setq *initialize-info-cache-class* class)
+ (setq *initialize-info-cache-initargs* initargs)
+ (setq *initialize-info-cache-info* info)
+ info))
+
+(defun update-initialize-info-internal (info name)
+ (let* ((key (initialize-info-key info))
+ (class (car key))
+ (keys (cadr key))
+ (allow-other-keys-arg (caddr key)))
+ (ecase name
+ ((initargs-form-list new-keys)
+ (multiple-value-bind (initargs-form-list new-keys)
+ (make-default-initargs-form-list class keys)
+ (setf (initialize-info-cached-initargs-form-list info) initargs-form-list)
+ (setf (initialize-info-cached-new-keys info) new-keys)))
+ ((default-initargs-function)
+ (let ((initargs-form-list (initialize-info-initargs-form-list info)))
+ (setf (initialize-info-cached-default-initargs-function info)
+ (initialize-instance-simple-function
+ 'default-initargs-function info
+ class initargs-form-list))))
+ ((valid-p ri-valid-p)
+ (flet ((compute-valid-p (methods)
+ (or (not (null allow-other-keys-arg))
+ (multiple-value-bind (legal allow-other-keys)
+ (check-initargs-values class methods)
+ (or (not (null allow-other-keys))
+ (dolist (key keys t)
+ (unless (member key legal)
+ (return (cons :invalid key)))))))))
+ (let ((proto (class-prototype class)))
+ (setf (initialize-info-cached-valid-p info)
+ (compute-valid-p
+ (list (list* 'allocate-instance class nil)
+ (list* 'initialize-instance proto nil)
+ (list* 'shared-initialize proto t nil))))
+ (setf (initialize-info-cached-ri-valid-p info)
+ (compute-valid-p
+ (list (list* 'reinitialize-instance proto nil)
+ (list* 'shared-initialize proto nil nil)))))))
+ ((shared-initialize-t-function)
+ (multiple-value-bind (initialize-form-list ignore)
+ (make-shared-initialize-form-list class keys t nil)
+ (declare (ignore ignore))
+ (setf (initialize-info-cached-shared-initialize-t-function info)
+ (initialize-instance-simple-function
+ 'shared-initialize-t-function info
+ class initialize-form-list))))
+ ((shared-initialize-nil-function)
+ (multiple-value-bind (initialize-form-list ignore)
+ (make-shared-initialize-form-list class keys nil nil)
+ (declare (ignore ignore))
+ (setf (initialize-info-cached-shared-initialize-nil-function info)
+ (initialize-instance-simple-function
+ 'shared-initialize-nil-function info
+ class initialize-form-list))))
+ ((constants combined-initialize-function)
+ (let ((initargs-form-list (initialize-info-initargs-form-list info))
+ (new-keys (initialize-info-new-keys info)))
+ (multiple-value-bind (initialize-form-list constants)
+ (make-shared-initialize-form-list class new-keys t t)
+ (setf (initialize-info-cached-constants info) constants)
+ (setf (initialize-info-cached-combined-initialize-function info)
+ (initialize-instance-simple-function
+ 'combined-initialize-function info
+ class (append initargs-form-list initialize-form-list))))))
+ ((make-instance-function-symbol)
+ (setf (initialize-info-cached-make-instance-function-symbol info)
+ (make-instance-function-symbol key)))
+ ((make-instance-function)
+ (let* ((function (get-make-instance-function key))
+ (symbol (initialize-info-make-instance-function-symbol info)))
+ (setf (initialize-info-cached-make-instance-function info) function)
+ (when symbol (setf (gdefinition symbol)
+ (or function #'make-instance-1)))))))
+ info)
+
+(defun get-make-instance-function (key)
+ (let* ((class (car key))
+ (keys (cadr key)))
+ (unless (eq *boot-state* 'complete)
+ (return-from get-make-instance-function nil))
+ (when (symbolp class)
+ (setq class (find-class class)))
+ (when (classp class)
+ (unless (class-finalized-p class) (finalize-inheritance class)))
+ (let* ((initargs (mapcan #'(lambda (key) (list key nil)) keys))
+ (class-and-initargs (list* class initargs))
+ (make-instance (gdefinition 'make-instance))
+ (make-instance-methods
+ (compute-applicable-methods make-instance class-and-initargs))
+ (std-mi-meth (find-standard-ii-method make-instance-methods 'class))
+ (class+initargs (list class initargs))
+ (default-initargs (gdefinition 'default-initargs))
+ (default-initargs-methods
+ (compute-applicable-methods default-initargs class+initargs))
+ (proto (and (classp class) (class-prototype class)))
+ (initialize-instance-methods
+ (when proto
+ (compute-applicable-methods (gdefinition 'initialize-instance)
+ (list* proto initargs))))
+ (shared-initialize-methods
+ (when proto
+ (compute-applicable-methods (gdefinition 'shared-initialize)
+ (list* proto t initargs)))))
+ (when (null make-instance-methods)
+ (return-from get-make-instance-function
+ #'(lambda (class initargs)
+ (apply #'no-applicable-method make-instance class initargs))))
+ (unless (and (null (cdr make-instance-methods))
+ (eq (car make-instance-methods) std-mi-meth)
+ (null (cdr default-initargs-methods))
+ (eq (car (method-specializers (car default-initargs-methods)))
+ *the-class-slot-class*)
+ (flet ((check-meth (meth)
+ (let ((quals (method-qualifiers meth)))
+ (if (null quals)
+ (eq (car (method-specializers meth))
+ *the-class-slot-object*)
+ (and (null (cdr quals))
+ (or (eq (car quals) ':before)
+ (eq (car quals) ':after)))))))
+ (and (every #'check-meth initialize-instance-methods)
+ (every #'check-meth shared-initialize-methods))))
+ (return-from get-make-instance-function nil))
+ (get-make-instance-function-internal
+ class key (default-initargs class initargs)
+ initialize-instance-methods shared-initialize-methods))))
+
+(defun get-make-instance-function-internal (class key initargs
+ initialize-instance-methods
+ shared-initialize-methods)
+ (let* ((keys (cadr key))
+ (allow-other-keys-p (caddr key))
+ (allocate-instance-methods
+ (compute-applicable-methods (gdefinition 'allocate-instance)
+ (list* class initargs))))
+ (unless allow-other-keys-p
+ (unless (check-initargs-1
+ class initargs
+ (append allocate-instance-methods
+ initialize-instance-methods
+ shared-initialize-methods)
+ t nil)
+ (return-from get-make-instance-function-internal nil)))
+ (if (or (cdr allocate-instance-methods)
+ (some #'complicated-instance-creation-method
+ initialize-instance-methods)
+ (some #'complicated-instance-creation-method
+ shared-initialize-methods))
+ (make-instance-function-complex
+ key class keys
+ initialize-instance-methods shared-initialize-methods)
+ (make-instance-function-simple
+ key class keys
+ initialize-instance-methods shared-initialize-methods))))
+
+(defun complicated-instance-creation-method (m)
+ (let ((qual (method-qualifiers m)))
+ (if qual
+ (not (and (null (cdr qual)) (eq (car qual) ':after)))
+ (let ((specl (car (method-specializers m))))
+ (or (not (classp specl))
+ (not (eq 'slot-object (class-name specl))))))))
+
+(defun find-standard-ii-method (methods class-names)
+ (dolist (m methods)
+ (when (null (method-qualifiers m))
+ (let ((specl (car (method-specializers m))))
+ (when (and (classp specl)
+ (if (listp class-names)
+ (member (class-name specl) class-names)
+ (eq (class-name specl) class-names)))
+ (return m))))))
+
+(defmacro call-initialize-function (initialize-function instance initargs)
+ `(let ((.function. ,initialize-function))
+ (if (and (consp .function.)
+ (eq (car .function.) 'call-initialize-instance-simple))
+ (initialize-instance-simple (cadr .function.) (caddr .function.)
+ ,instance ,initargs)
+ (funcall (the function .function.) ,instance ,initargs))))
+
+(defun make-instance-function-simple (key class keys
+ initialize-instance-methods
+ shared-initialize-methods)
+ (multiple-value-bind (initialize-function constants)
+ (get-simple-initialization-function class keys (caddr key))
+ (let* ((wrapper (class-wrapper class))
+ (lwrapper (list wrapper))
+ (allocate-function
+ (cond ((structure-class-p class)
+ #'allocate-structure-instance)
+ ((standard-class-p class)
+ #'allocate-standard-instance)
+ ((funcallable-standard-class-p class)
+ #'allocate-funcallable-instance)
+ (t
+ (error "error in make-instance-function-simple"))))
+ (std-si-meth (find-standard-ii-method shared-initialize-methods
+ 'slot-object))
+ (shared-initfns
+ (nreverse (mapcar #'(lambda (method)
+ (make-effective-method-function
+ #'shared-initialize
+ `(call-method ,method nil)
+ nil lwrapper))
+ (remove std-si-meth shared-initialize-methods))))
+ (std-ii-meth (find-standard-ii-method initialize-instance-methods
+ 'slot-object))
+ (initialize-initfns
+ (nreverse (mapcar #'(lambda (method)
+ (make-effective-method-function
+ #'initialize-instance
+ `(call-method ,method nil)
+ nil lwrapper))
+ (remove std-ii-meth
+ initialize-instance-methods)))))
+ #'(lambda (class1 initargs)
+ (if (not (eq wrapper (class-wrapper class)))
+ (let* ((info (initialize-info class1 initargs))
+ (fn (initialize-info-make-instance-function info)))
+ (declare (type function fn))
+ (funcall fn class1 initargs))
+ (let* ((instance (funcall allocate-function wrapper constants))
+ (initargs (call-initialize-function initialize-function
+ instance initargs)))
+ (dolist (fn shared-initfns)
+ (invoke-effective-method-function fn t instance t initargs))
+ (dolist (fn initialize-initfns)
+ (invoke-effective-method-function fn t instance initargs))
+ instance))))))
+
+(defun make-instance-function-complex (key class keys
+ initialize-instance-methods
+ shared-initialize-methods)
+ (multiple-value-bind (initargs-function initialize-function)
+ (get-complex-initialization-functions class keys (caddr key))
+ (let* ((wrapper (class-wrapper class))
+ (shared-initialize
+ (get-secondary-dispatch-function
+ #'shared-initialize shared-initialize-methods
+ `((class-eq ,class) t t)
+ `((,(find-standard-ii-method shared-initialize-methods 'slot-object)
+ ,#'(lambda (instance init-type &rest initargs)
+ (declare (ignore init-type))
+ (call-initialize-function initialize-function
+ instance initargs)
+ instance)))
+ (list wrapper *the-wrapper-of-t* *the-wrapper-of-t*)))
+ (initialize-instance
+ (get-secondary-dispatch-function
+ #'initialize-instance initialize-instance-methods
+ `((class-eq ,class) t)
+ `((,(find-standard-ii-method initialize-instance-methods 'slot-object)
+ ,#'(lambda (instance &rest initargs)
+ (invoke-effective-method-function
+ shared-initialize t instance t initargs))))
+ (list wrapper *the-wrapper-of-t*))))
+ #'(lambda (class1 initargs)
+ (if (not (eq wrapper (class-wrapper class)))
+ (let* ((info (initialize-info class1 initargs))
+ (fn (initialize-info-make-instance-function info)))
+ (declare (type function fn))
+ (funcall fn class1 initargs))
+ (let* ((initargs (call-initialize-function initargs-function
+ nil initargs))
+ (instance (apply #'allocate-instance class initargs)))
+ (invoke-effective-method-function
+ initialize-instance t instance initargs)
+ instance))))))
+
+(defun get-simple-initialization-function (class keys &optional allow-other-keys-arg)
+ (let ((info (initialize-info class keys nil allow-other-keys-arg)))
+ (values (initialize-info-combined-initialize-function info)
+ (initialize-info-constants info))))
+
+(defun get-complex-initialization-functions (class keys &optional allow-other-keys-arg
+ separate-p)
+ (let* ((info (initialize-info class keys nil allow-other-keys-arg))
+ (default-initargs-function (initialize-info-default-initargs-function info)))
+ (if separate-p
+ (values default-initargs-function
+ (initialize-info-shared-initialize-t-function info))
+ (values default-initargs-function
+ (initialize-info-shared-initialize-t-function
+ (initialize-info class (initialize-info-new-keys info)
+ nil allow-other-keys-arg))))))
+
+(defun add-forms (forms forms-list)
+ (when forms
+ (setq forms (copy-list forms))
+ (if (null (car forms-list))
+ (setf (car forms-list) forms)
+ (setf (cddr forms-list) forms))
+ (setf (cdr forms-list) (last forms)))
+ (car forms-list))
+
+(defun make-default-initargs-form-list (class keys &optional (separate-p t))
+ (let ((initargs-form-list (cons nil nil))
+ (default-initargs (class-default-initargs class))
+ (nkeys keys)
+ (slots-alist
+ (mapcan #'(lambda (slot)
+ (mapcar #'(lambda (arg)
+ (cons arg slot))
+ (slot-definition-initargs slot)))
+ (class-slots class)))
+ (nslots nil))
+ (dolist (key nkeys)
+ (pushnew (cdr (assoc key slots-alist)) nslots))
+ (dolist (default default-initargs)
+ (let* ((key (car default))
+ (slot (cdr (assoc key slots-alist)))
+ (function (cadr default)))
+ (unless (member slot nslots)
+ (add-forms `((funcall ,function) (push-initarg ,key))
+ initargs-form-list)
+ (push key nkeys)
+ (push slot nslots))))
+ (when separate-p
+ (add-forms `((update-initialize-info-cache
+ ,class ,(initialize-info class nkeys nil)))
+ initargs-form-list))
+ (add-forms `((finish-pushing-initargs))
+ initargs-form-list)
+ (values (car initargs-form-list) nkeys)))
+
+(defun make-shared-initialize-form-list (class keys si-slot-names simple-p)
+ (let* ((initialize-form-list (cons nil nil))
+ (type (cond ((structure-class-p class)
+ 'structure)
+ ((standard-class-p class)
+ 'standard)
+ ((funcallable-standard-class-p class)
+ 'funcallable)
+ (t (error "error in make-shared-initialize-form-list"))))
+ (wrapper (class-wrapper class))
+ (constants (when simple-p
+ (make-list (wrapper-no-of-instance-slots wrapper)
+ ':initial-element *slot-unbound*)))
+ (slots (class-slots class))
+ (slot-names (mapcar #'slot-definition-name slots))
+ (slots-key (mapcar #'(lambda (slot)
+ (let ((index most-positive-fixnum))
+ (dolist (key (slot-definition-initargs slot))
+ (let ((pos (position key keys)))
+ (when pos (setq index (min index pos)))))
+ (cons slot index)))
+ slots))
+ (slots (stable-sort slots-key #'< :key #'cdr)))
+ (let ((n-popped 0))
+ (dolist (slot+index slots)
+ (let* ((slot (car slot+index))
+ (name (slot-definition-name slot))
+ (npop (1+ (- (cdr slot+index) n-popped))))
+ (unless (eql (cdr slot+index) most-positive-fixnum)
+ (let* ((pv-offset (1+ (position name slot-names))))
+ (add-forms `(,@(when (plusp npop)
+ `((pop-initargs ,(* 2 npop))))
+ (instance-set ,pv-offset ,slot))
+ initialize-form-list))
+ (incf n-popped npop)))))
+ (dolist (slot+index slots)
+ (let* ((slot (car slot+index))
+ (name (slot-definition-name slot)))
+ (when (and (eql (cdr slot+index) most-positive-fixnum)
+ (or (eq si-slot-names 't)
+ (member name si-slot-names)))
+ (let* ((initform (slot-definition-initform slot))
+ (initfunction (slot-definition-initfunction slot))
+ (location (unless (eq type 'structure)
+ (slot-definition-location slot)))
+ (pv-offset (1+ (position name slot-names)))
+ (forms (cond ((null initfunction)
+ nil)
+ ((constantp initform)
+ (let ((value (funcall initfunction)))
+ (if (and simple-p (integerp location))
+ (progn (setf (nth location constants) value)
+ nil)
+ `((const ,value)
+ (instance-set ,pv-offset ,slot)))))
+ (t
+ `((funcall ,(slot-definition-initfunction slot))
+ (instance-set ,pv-offset ,slot))))))
+ (add-forms `(,@(unless (or simple-p (null forms))
+ `((skip-when-instance-boundp ,pv-offset ,slot
+ ,(length forms))))
+ ,@forms)
+ initialize-form-list)))))
+ (values (car initialize-form-list) constants)))
+
+(defvar *class-pv-table-table* (make-hash-table :test 'eq))
+
+(defun get-pv-cell-for-class (class)
+ (let* ((slot-names (mapcar #'slot-definition-name (class-slots class)))
+ (slot-name-lists (list (cons nil slot-names)))
+ (pv-table (gethash class *class-pv-table-table*)))
+ (unless (and pv-table
+ (equal slot-name-lists (pv-table-slot-name-lists pv-table)))
+ (setq pv-table (intern-pv-table :slot-name-lists slot-name-lists))
+ (setf (gethash class *class-pv-table-table*) pv-table))
+ (pv-table-lookup pv-table (class-wrapper class))))
+
+(defvar *initialize-instance-simple-alist* nil)
+(defvar *note-iis-entry-p* nil)
+
+(defvar *compiled-initialize-instance-simple-functions*
+ (make-hash-table :test 'equal))
+
+(defun initialize-instance-simple-function (use info class form-list)
+ (let* ((pv-cell (get-pv-cell-for-class class))
+ (key (initialize-info-key info))
+ (sf-key (list* use (class-name (car key)) (cdr key))))
+ (if (or *compile-make-instance-functions-p*
+ (gethash sf-key *compiled-initialize-instance-simple-functions*))
+ (multiple-value-bind (form args)
+ (form-list-to-lisp pv-cell form-list)
+ (let ((entry (assoc form *initialize-instance-simple-alist*
+ :test #'equal)))
+ (setf (gethash sf-key
+ *compiled-initialize-instance-simple-functions*)
+ t)
+ (if entry
+ (setf (cdddr entry) (union (list sf-key) (cdddr entry)
+ :test #'equal))
+ (progn
+ (setq entry (list* form nil nil (list sf-key)))
+ (setq *initialize-instance-simple-alist*
+ (nconc *initialize-instance-simple-alist*
+ (list entry)))))
+ (unless (or *note-iis-entry-p* (cadr entry))
+ (setf (cadr entry) (compile-lambda (car entry))))
+ (if (cadr entry)
+ (apply (the function (cadr entry)) args)
+ `(call-initialize-instance-simple ,pv-cell ,form-list))))
+ #||
+ #'(lambda (instance initargs)
+ (initialize-instance-simple pv-cell form-list instance initargs))
+ ||#
+ `(call-initialize-instance-simple ,pv-cell ,form-list))))
+
+(defun load-precompiled-iis-entry (form function system uses)
+ (let ((entry (assoc form *initialize-instance-simple-alist*
+ :test #'equal)))
+ (unless entry
+ (setq entry (list* form nil nil nil))
+ (setq *initialize-instance-simple-alist*
+ (nconc *initialize-instance-simple-alist*
+ (list entry))))
+ (setf (cadr entry) function)
+ (setf (caddr entry) system)
+ (dolist (use uses)
+ (setf (gethash use *compiled-initialize-instance-simple-functions*) t))
+ (setf (cdddr entry) (union uses (cdddr entry)
+ :test #'equal))))
+
+(defmacro precompile-iis-functions (&optional system)
+ (let ((index -1))
+ `(progn
+ ,@(gathering1 (collecting)
+ (dolist (iis-entry *initialize-instance-simple-alist*)
+ (when (or (null (caddr iis-entry))
+ (eq (caddr iis-entry) system))
+ (when system (setf (caddr iis-entry) system))
+ (gather1
+ (make-top-level-form
+ `(precompile-initialize-instance-simple ,system ,(incf index))
+ '(:load-toplevel)
+ `(load-precompiled-iis-entry
+ ',(car iis-entry)
+ #',(car iis-entry)
+ ',system
+ ',(cdddr iis-entry))))))))))
+
+(defun compile-iis-functions (after-p)
+ (let ((*compile-make-instance-functions-p* t)
+ (*revert-initialize-info-p* t)
+ (*note-iis-entry-p* (not after-p)))
+ (declare (special *compile-make-instance-functions-p*))
+ (when (eq *boot-state* 'complete)
+ (update-make-instance-function-table))))
+
+;(const const)
+;(funcall function)
+;(push-initarg const)
+;(pop-supplied count) ; a positive odd number
+;(instance-set pv-offset slotd)
+;(skip-when-instance-boundp pv-offset slotd n)
+
+(defun initialize-instance-simple (pv-cell form-list instance initargs)
+ (let ((pv (car pv-cell))
+ (initargs-tail initargs)
+ (slots (get-slots-or-nil instance))
+ (class (class-of instance))
+ value)
+ (loop (when (null form-list) (return nil))
+ (let ((form (pop form-list)))
+ (ecase (car form)
+ (push-initarg
+ (push value initargs)
+ (push (cadr form) initargs))
+ (const
+ (setq value (cadr form)))
+ (funcall
+ (setq value (funcall (the function (cadr form)))))
+ (pop-initargs
+ (setq initargs-tail (nthcdr (1- (cadr form)) initargs-tail))
+ (setq value (pop initargs-tail)))
+ (instance-set
+ (instance-write-internal
+ pv slots (cadr form) value
+ (setf (slot-value-using-class class instance (caddr form))
+ value)))
+ (skip-when-instance-boundp
+ (when (instance-boundp-internal
+ pv slots (cadr form)
+ (slot-boundp-using-class class instance (caddr form)))
+ (dotimes-fixnum (i (cadddr form))
+ (pop form-list))))
+ (update-initialize-info-cache
+ (when (consp initargs)
+ (setq initargs (cons (car initargs) (cdr initargs))))
+ (setq *initialize-info-cache-class* (cadr form))
+ (setq *initialize-info-cache-initargs* initargs)
+ (setq *initialize-info-cache-info* (caddr form)))
+ (finish-pushing-initargs
+ (setq initargs-tail initargs)))))
+ initargs))
+
+(defun add-to-cvector (cvector constant)
+ (or (position constant cvector)
+ (prog1 (fill-pointer cvector)
+ (vector-push-extend constant cvector))))
+
+(defvar *inline-iis-instance-locations-p* t)
+
+(defun first-form-to-lisp (forms cvector pv)
+ (flet ((const (constant)
+ (cond ((or (numberp constant) (characterp constant))
+ constant)
+ ((and (symbolp constant) (symbol-package constant))
+ `',constant)
+ (t
+ `(svref cvector ,(add-to-cvector cvector constant))))))
+ (let ((form (pop (car forms))))
+ (ecase (car form)
+ (push-initarg
+ `((push value initargs)
+ (push ,(const (cadr form)) initargs)))
+ (const
+ `((setq value ,(const (cadr form)))))
+ (funcall
+ `((setq value (funcall (the function ,(const (cadr form)))))))
+ (pop-initargs
+ `((setq initargs-tail (,@(let ((pop (1- (cadr form))))
+ (case pop
+ (1 `(cdr))
+ (3 `(cdddr))
+ (t `(nthcdr ,pop))))
+ initargs-tail))
+ (setq value (pop initargs-tail))))
+ (instance-set
+ (let* ((pv-offset (cadr form))
+ (location (pvref pv pv-offset))
+ (default `(setf (slot-value-using-class class instance
+ ,(const (caddr form)))
+ value)))
+ (if *inline-iis-instance-locations-p*
+ (typecase location
+ (fixnum `((setf (%instance-ref slots ,(const location)) value)))
+ (cons `((setf (cdr ,(const location)) value)))
+ (t `(,default)))
+ `((instance-write-internal pv slots ,(const pv-offset) value
+ ,default
+ ,(typecase location
+ (fixnum ':instance)
+ (cons ':class)
+ (t ':default)))))))
+ (skip-when-instance-boundp
+ (let* ((pv-offset (cadr form))
+ (location (pvref pv pv-offset))
+ (default `(slot-boundp-using-class class instance
+ ,(const (caddr form)))))
+ `((unless ,(if *inline-iis-instance-locations-p*
+ (typecase location
+ (fixnum `(not (eq (%instance-ref slots ,(const location))
+ ',*slot-unbound*)))
+ (cons `(not (eq (cdr ,(const location)) ',*slot-unbound*)))
+ (t default))
+ `(instance-boundp-internal pv slots ,(const pv-offset)
+ ,default
+ ,(typecase (pvref pv pv-offset)
+ (fixnum ':instance)
+ (cons ':class)
+ (t ':default))))
+ ,@(let ((sforms (cons nil nil)))
+ (dotimes-fixnum (i (cadddr form) (car sforms))
+ (add-forms (first-form-to-lisp forms cvector pv) sforms)))))))
+ (update-initialize-info-cache
+ `((when (consp initargs)
+ (setq initargs (cons (car initargs) (cdr initargs))))
+ (setq *initialize-info-cache-class* ,(const (cadr form)))
+ (setq *initialize-info-cache-initargs* initargs)
+ (setq *initialize-info-cache-info* ,(const (caddr form)))))
+ (finish-pushing-initargs
+ `((setq initargs-tail initargs)))))))
+
+(defmacro iis-body (&body forms)
+ `(let ((initargs-tail initargs)
+ (slots (get-slots-or-nil instance))
+ (class (class-of instance))
+ (pv (car pv-cell))
+ value)
+ initargs instance initargs-tail pv cvector slots class value
+ ,@forms))
+
+(defun form-list-to-lisp (pv-cell form-list)
+ (let* ((forms (list form-list))
+ (cvector (make-array (floor (length form-list) 2)
+ :fill-pointer 0 :adjustable t))
+ (pv (car pv-cell))
+ (body (let ((rforms (cons nil nil)))
+ (loop (when (null (car forms)) (return (car rforms)))
+ (add-forms (first-form-to-lisp forms cvector pv)
+ rforms))))
+ (cvector-type `(simple-vector ,(length cvector))))
+ (values
+ `(lambda (pv-cell cvector)
+ (declare (type ,cvector-type cvector))
+ #'(lambda (instance initargs)
+ (declare #.*optimize-speed*)
+ (iis-body ,@body)
+ initargs))
+ (list pv-cell (coerce cvector cvector-type)))))
+\f
+;;; The effect of this is to cause almost all of the overhead of MAKE-INSTANCE
+;;; to happen at load time (or maybe at precompile time, as explained in a
+;;; previous message) rather than the first time that MAKE-INSTANCE is called
+;;; with a given class-name and sequence of keywords.
+
+;;; This optimization applies only when the first argument and all the even
+;;; numbered arguments are constants evaluating to interned symbols.
+
+(declaim (ftype (function (t) symbol) get-make-instance-function-symbol))
+
+(define-compiler-macro make-instance (&whole form &rest args)
+ (declare (ignore args))
+ (let* ((*make-instance-function-keys* nil)
+ (expanded-form (expand-make-instance-form form)))
+ (if expanded-form
+ `(funcall (symbol-function
+ ;; The symbol is guaranteed to be fbound.
+ ;; Is there a way to declare this?
+ (load-time-value
+ (get-make-instance-function-symbol
+ ',(first *make-instance-function-keys*))))
+ ,@(cdr expanded-form))
+ form)))
+
+(defun get-make-instance-function-symbol (key)
+ (get-make-instance-functions (list key))
+ (make-instance-function-symbol key))
--- /dev/null
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+
+;;;; This software is derived from software originally released by Xerox
+;;;; Corporation. Copyright and release statements follow. Later modifications
+;;;; to the software are in the public domain and are provided with
+;;;; absolutely no warranty. See the COPYING and CREDITS files for more
+;;;; information.
+
+;;;; copyright information from original PCL sources:
+;;;;
+;;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
+;;;; All rights reserved.
+;;;;
+;;;; Use and copying of this software and preparation of derivative works based
+;;;; upon this software are permitted. Any distribution of this software or
+;;;; derivative works must comply with all applicable United States export
+;;;; control laws.
+;;;;
+;;;; This software is made available AS IS, and Xerox Corporation makes no
+;;;; warranty about the software, its performance or its conformity to any
+;;;; specification.
+
+(in-package "SB-PCL")
+
+(sb-int:file-comment
+ "$Header$")
+\f
+;;; Each implementation must provide the following functions and macros:
+;;;
+;;; ALLOCATE-FUNCALLABLE-INSTANCE-1 ()
+;;; should create and return a new funcallable instance. The
+;;; funcallable-instance-data slots must be initialized to NIL.
+;;; This is called by allocate-funcallable-instance and by the
+;;; bootstrapping code.
+;;;
+;;; FUNCALLABLE-INSTANCE-P (x)
+;;; the obvious predicate. This should be an INLINE function. It
+;;; must be funcallable, but it would be nice if it compiled open.
+;;;
+;;; SET-FUNCALLABLE-INSTANCE-FUNCTION (fin new-value)
+;;; change the fin so that when it is funcalled, the new-value
+;;; function is called. Note that it is legal for new-value
+;;; to be copied before it is installed in the fin, specifically
+;;; there is no accessor for a FIN's function so this function
+;;; does not have to preserve the actual new value. The new-value
+;;; argument can be any funcallable thing, a closure, lambda
+;;; compiled code etc. This function must coerce those values
+;;; if necessary.
+;;; NOTE: new-value is almost always a compiled closure. This
+;;; is the important case to optimize.
+;;;
+;;; FUNCALLABLE-INSTANCE-DATA-1 (fin data-name)
+;;; should return the value of the data named data-name in the fin.
+;;; data-name is one of the symbols in the list which is the value
+;;; of funcallable-instance-data. Since data-name is almost always
+;;; a quoted symbol and funcallable-instance-data is a constant, it
+;;; is possible (and worthwhile) to optimize the computation of
+;;; data-name's offset in the data part of the fin.
+;;; This must be SETF'able.
+\f
+;;;; implementation of funcallable instances for CMU Common Lisp
+
+(defstruct (pcl-funcallable-instance
+ (:alternate-metaclass sb-kernel:funcallable-instance
+ sb-kernel:random-pcl-class
+ sb-kernel:make-random-pcl-class)
+ (:type sb-kernel:funcallable-structure)
+ (:constructor allocate-funcallable-instance-1 ())
+ (:copier nil)
+ (:conc-name nil))
+ ;; Note: The PCL wrapper is in the layout slot.
+
+ ;; PCL data vector.
+ (pcl-funcallable-instance-slots nil)
+ ;; The debug-name for this function.
+ (funcallable-instance-name nil))
+
+(import 'sb-kernel:funcallable-instance-p)
+
+;;; Set the function that is called when FIN is called.
+(defun set-funcallable-instance-function (fin new-value)
+ (declare (type function new-value))
+ (assert (funcallable-instance-p fin))
+ (setf (sb-kernel:funcallable-instance-function fin) new-value))
+
+;;; This "works" on non-PCL FINs, which allows us to weaken
+;;; FUNCALLABLE-INSTANCE-P to return true for all FINs. This is also
+;;; necessary for bootstrapping to work, since the layouts for early GFs are
+;;; not initially initialized.
+(defmacro funcallable-instance-data-1 (fin slot)
+ (ecase (eval slot)
+ (wrapper `(sb-kernel:%funcallable-instance-layout ,fin))
+ (slots `(sb-kernel:%funcallable-instance-info ,fin 0))))
+\f
+;;;; slightly higher-level stuff built on the implementation-dependent stuff
+
+(defmacro fsc-instance-p (fin)
+ `(funcallable-instance-p ,fin))
+
+(defmacro fsc-instance-class (fin)
+ `(wrapper-class (funcallable-instance-data-1 ,fin 'wrapper)))
+
+(defmacro fsc-instance-wrapper (fin)
+ `(funcallable-instance-data-1 ,fin 'wrapper))
+
+(defmacro fsc-instance-slots (fin)
+ `(funcallable-instance-data-1 ,fin 'slots))
--- /dev/null
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+
+;;;; This software is derived from software originally released by Xerox
+;;;; Corporation. Copyright and release statements follow. Later modifications
+;;;; to the software are in the public domain and are provided with
+;;;; absolutely no warranty. See the COPYING and CREDITS files for more
+;;;; information.
+
+;;;; copyright information from original PCL sources:
+;;;;
+;;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
+;;;; All rights reserved.
+;;;;
+;;;; Use and copying of this software and preparation of derivative works based
+;;;; upon this software are permitted. Any distribution of this software or
+;;;; derivative works must comply with all applicable United States export
+;;;; control laws.
+;;;;
+;;;; This software is made available AS IS, and Xerox Corporation makes no
+;;;; warranty about the software, its performance or its conformity to any
+;;;; specification.
+
+(in-package "SB-PCL")
+
+(sb-int:file-comment
+ "$Header$")
+
+(fix-early-generic-functions)
+(setq *boot-state* 'complete)
+
+(defun print-std-instance (instance stream depth)
+ (declare (ignore depth))
+ (print-object instance stream))
--- /dev/null
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+
+;;;; This software is derived from software originally released by Xerox
+;;;; Corporation. Copyright and release statements follow. Later modifications
+;;;; to the software are in the public domain and are provided with
+;;;; absolutely no warranty. See the COPYING and CREDITS files for more
+;;;; information.
+
+;;;; copyright information from original PCL sources:
+;;;;
+;;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
+;;;; All rights reserved.
+;;;;
+;;;; Use and copying of this software and preparation of derivative works based
+;;;; upon this software are permitted. Any distribution of this software or
+;;;; derivative works must comply with all applicable United States export
+;;;; control laws.
+;;;;
+;;;; This software is made available AS IS, and Xerox Corporation makes no
+;;;; warranty about the software, its performance or its conformity to any
+;;;; specification.
+
+(in-package "SB-PCL")
+
+(sb-int:file-comment
+ "$Header$")
+\f
+;;; GET-FUNCTION is the main user interface to this code. It is like
+;;; COMPILE-LAMBDA, only more efficient. It achieves this efficiency by
+;;; reducing the number of times that the compiler needs to be called.
+;;; Calls to GET-FUNCTION in which the lambda forms differ only by constants
+;;; can use the same piece of compiled code. (For example, dispatch dfuns and
+;;; combined method functions can often be shared, if they differ only
+;;; by referring to different methods.)
+;;;
+;;; If GET-FUNCTION is called with a lambda expression only, it will return
+;;; a corresponding function. The optional constant-converter argument
+;;; can be a function which will be called to convert each constant appearing
+;;; in the lambda to whatever value should appear in the function.
+;;;
+;;; There are three internal functions which operate on the lambda argument
+;;; to GET-FUNCTION:
+;;; compute-test converts the lambda into a key to be used for lookup,
+;;; compute-code is used by get-new-function-generator-internal to
+;;; generate the actual lambda to be compiled, and
+;;; compute-constants is used to generate the argument list that is
+;;; to be passed to the compiled function.
+;;;
+;;; Whether the returned function is actually compiled depends on whether
+;;; the compiler is present (see COMPILE-LAMBDA) and whether this shape of
+;;; code was precompiled.
+(defun get-function (lambda
+ &optional (test-converter #'default-test-converter)
+ (code-converter #'default-code-converter)
+ (constant-converter #'default-constant-converter))
+ (function-apply (get-function-generator lambda test-converter code-converter)
+ (compute-constants lambda constant-converter)))
+
+(defun get-function1 (lambda
+ &optional (test-converter #'default-test-converter)
+ (code-converter #'default-code-converter)
+ (constant-converter #'default-constant-converter))
+ (values (the function (get-function-generator lambda test-converter code-converter))
+ (compute-constants lambda constant-converter)))
+
+(defun default-constantp (form)
+ (and (constantp form)
+ (not (typep (eval form) '(or symbol fixnum)))))
+
+(defun default-test-converter (form)
+ (if (default-constantp form)
+ '.constant.
+ form))
+
+(defun default-code-converter (form)
+ (if (default-constantp form)
+ (let ((gensym (gensym))) (values gensym (list gensym)))
+ form))
+
+(defun default-constant-converter (form)
+ (if (default-constantp form)
+ (list (eval form))
+ nil))
+\f
+;;; *FGENS* is a list of all the function generators we have so far. Each
+;;; element is a FGEN structure as implemented below. Don't ever touch this
+;;; list by hand, use STORE-FGEN.
+(defvar *fgens* ())
+
+(defun store-fgen (fgen)
+ (let ((old (lookup-fgen (fgen-test fgen))))
+ (if old
+ (setf (svref old 2) (fgen-generator fgen)
+ (svref old 4) (or (svref old 4)
+ (fgen-system fgen)))
+ (setq *fgens* (nconc *fgens* (list fgen))))))
+
+(defun lookup-fgen (test)
+ (find test (the list *fgens*) :key #'fgen-test :test #'equal))
+
+(defun make-fgen (test gensyms generator generator-lambda system)
+ (let ((new (make-array 6)))
+ (setf (svref new 0) test
+ (svref new 1) gensyms
+ (svref new 2) generator
+ (svref new 3) generator-lambda
+ (svref new 4) system)
+ new))
+
+(defun fgen-test (fgen) (svref fgen 0))
+(defun fgen-gensyms (fgen) (svref fgen 1))
+(defun fgen-generator (fgen) (svref fgen 2))
+(defun fgen-generator-lambda (fgen) (svref fgen 3))
+(defun fgen-system (fgen) (svref fgen 4))
+\f
+(defun get-function-generator (lambda test-converter code-converter)
+ (let* ((test (compute-test lambda test-converter))
+ (fgen (lookup-fgen test)))
+ (if fgen
+ (fgen-generator fgen)
+ (get-new-function-generator lambda test code-converter))))
+
+(defun get-new-function-generator (lambda test code-converter)
+ (multiple-value-bind (gensyms generator-lambda)
+ (get-new-function-generator-internal lambda code-converter)
+ (let* ((generator (compile-lambda generator-lambda))
+ (fgen (make-fgen test gensyms generator generator-lambda nil)))
+ (store-fgen fgen)
+ generator)))
+
+(defun get-new-function-generator-internal (lambda code-converter)
+ (multiple-value-bind (code gensyms)
+ (compute-code lambda code-converter)
+ (values gensyms `(lambda ,gensyms (function ,code)))))
+
+(defun compute-test (lambda test-converter)
+ (let ((*walk-form-expand-macros-p* t))
+ (walk-form lambda
+ nil
+ #'(lambda (f c e)
+ (declare (ignore e))
+ (if (neq c :eval)
+ f
+ (let ((converted (funcall test-converter f)))
+ (values converted (neq converted f))))))))
+
+(defun compute-code (lambda code-converter)
+ (let ((*walk-form-expand-macros-p* t)
+ (gensyms ()))
+ (values (walk-form lambda
+ nil
+ #'(lambda (f c e)
+ (declare (ignore e))
+ (if (neq c :eval)
+ f
+ (multiple-value-bind (converted gens)
+ (funcall code-converter f)
+ (when gens (setq gensyms (append gensyms gens)))
+ (values converted (neq converted f))))))
+ gensyms)))
+
+(defun compute-constants (lambda constant-converter)
+ (let ((*walk-form-expand-macros-p* t)) ; doesn't matter here.
+ (macrolet ((appending ()
+ `(let ((result ()))
+ (values #'(lambda (value) (setq result (append result value)))
+ #'(lambda ()result)))))
+ (gathering1 (appending)
+ (walk-form lambda
+ nil
+ #'(lambda (f c e)
+ (declare (ignore e))
+ (if (neq c :eval)
+ f
+ (let ((consts (funcall constant-converter f)))
+ (if consts
+ (progn (gather1 consts) (values f t))
+ f)))))))))
+\f
+(defmacro precompile-function-generators (&optional system)
+ (let ((index -1))
+ `(progn ,@(gathering1 (collecting)
+ (dolist (fgen *fgens*)
+ (when (or (null (fgen-system fgen))
+ (eq (fgen-system fgen) system))
+ (when system (setf (svref fgen 4) system))
+ (gather1
+ (make-top-level-form
+ `(precompile-function-generators ,system ,(incf index))
+ '(:load-toplevel)
+ `(load-function-generator
+ ',(fgen-test fgen)
+ ',(fgen-gensyms fgen)
+ (function ,(fgen-generator-lambda fgen))
+ ',(fgen-generator-lambda fgen)
+ ',system)))))))))
+
+(defun load-function-generator (test gensyms generator generator-lambda system)
+ (store-fgen (make-fgen test gensyms generator generator-lambda system)))
+
--- /dev/null
+;;;; This file contains the definition of the FUNCALLABLE-STANDARD-CLASS
+;;;; metaclass. Much of the implementation of this metaclass is actually
+;;;; defined on the class STD-CLASS. What appears in this file is a modest
+;;;; number of simple methods related to the low-level differences in the
+;;;; implementation of standard and funcallable-standard instances.
+;;;;
+;;;; As it happens, none of these differences are the ones reflected in
+;;;; the MOP specification; STANDARD-CLASS and FUNCALLABLE-STANDARD-CLASS
+;;;; share all their specified methods at STD-CLASS.
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+
+;;;; This software is derived from software originally released by Xerox
+;;;; Corporation. Copyright and release statements follow. Later modifications
+;;;; to the software are in the public domain and are provided with
+;;;; absolutely no warranty. See the COPYING and CREDITS files for more
+;;;; information.
+
+;;;; copyright information from original PCL sources:
+;;;;
+;;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
+;;;; All rights reserved.
+;;;;
+;;;; Use and copying of this software and preparation of derivative works based
+;;;; upon this software are permitted. Any distribution of this software or
+;;;; derivative works must comply with all applicable United States export
+;;;; control laws.
+;;;;
+;;;; This software is made available AS IS, and Xerox Corporation makes no
+;;;; warranty about the software, its performance or its conformity to any
+;;;; specification.
+
+(in-package "SB-PCL")
+
+(sb-int:file-comment
+ "$Header$")
+\f
+(defmethod wrapper-fetcher ((class funcallable-standard-class))
+ 'fsc-instance-wrapper)
+
+(defmethod slots-fetcher ((class funcallable-standard-class))
+ 'fsc-instance-slots)
+
+(defmethod raw-instance-allocator ((class funcallable-standard-class))
+ 'allocate-funcallable-instance)
+
+(defmethod validate-superclass ((fsc funcallable-standard-class)
+ (new-super std-class))
+ (let ((new-super-meta-class (class-of new-super)))
+ (or (eq new-super-meta-class *the-class-std-class*)
+ (eq (class-of fsc) new-super-meta-class))))
+
+(defmethod allocate-instance
+ ((class funcallable-standard-class) &rest initargs)
+ (declare (ignore initargs))
+ (unless (class-finalized-p class) (finalize-inheritance class))
+ (allocate-funcallable-instance (class-wrapper class)))
+
+(defmethod make-reader-method-function ((class funcallable-standard-class)
+ slot-name)
+ (make-std-reader-method-function (class-name class) slot-name))
+
+(defmethod make-writer-method-function ((class funcallable-standard-class)
+ slot-name)
+ (make-std-writer-method-function (class-name class) slot-name))
+
+;;;; See the comment about reader-function--std and writer-function--sdt.
+;;;;
+;(define-function-template reader-function--fsc () '(slot-name)
+; `(function
+; (lambda (instance)
+; (slot-value-using-class (wrapper-class (get-wrapper instance))
+; instance
+; slot-name))))
+;
+;(define-function-template writer-function--fsc () '(slot-name)
+; `(function
+; (lambda (nv instance)
+; (setf
+; (slot-value-using-class (wrapper-class (get-wrapper instance))
+; instance
+; slot-name)
+; nv))))
+;
+;(eval-when (:load-toplevel)
+; (pre-make-templated-function-constructor reader-function--fsc)
+; (pre-make-templated-function-constructor writer-function--fsc))
--- /dev/null
+;;;; Mostly this file contains generic functions. The exceptions are hacks.
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+
+;;;; 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 "SB-PCL")
+
+(sb-int:file-comment
+ "$Header$")
+\f
+;;;; class predicates
+
+(defgeneric class-eq-specializer-p (object))
+
+(defgeneric classp (object))
+
+(defgeneric eql-specializer-p (object))
+
+(defgeneric exact-class-specializer-p (object))
+
+(defgeneric forward-referenced-class-p (object))
+
+(defgeneric funcallable-standard-class-p (object))
+
+(defgeneric generic-function-p (object))
+
+(defgeneric legal-lambda-list-p (object x))
+
+(defgeneric method-combination-p (object))
+
+(defgeneric method-p (object))
+
+(defgeneric short-method-combination-p (object))
+
+(defgeneric slot-class-p (object))
+
+(defgeneric specializerp (object))
+
+(defgeneric standard-accessor-method-p (object))
+
+(defgeneric standard-boundp-method-p (object))
+
+(defgeneric standard-class-p (object))
+
+(defgeneric standard-generic-function-p (object))
+
+(defgeneric standard-method-p (object))
+
+(defgeneric standard-reader-method-p (object))
+
+(defgeneric standard-writer-method-p (object))
+
+(defgeneric structure-class-p (object))
+\f
+;;;; readers
+
+(defgeneric accessor-method-slot-definition (standard-accessor-method))
+
+(defgeneric class-can-precede-list (pcl-class))
+
+(defgeneric class-defstruct-constructor (structure-class))
+
+(defgeneric class-defstruct-form (structure-class))
+
+(defgeneric class-direct-subclasses (class))
+
+(defgeneric class-direct-superclasses (class))
+
+(defgeneric class-eq-specializer (class))
+
+(defgeneric class-incompatible-superclass-list (pcl-class))
+
+(defgeneric class-initialize-info (slot-class))
+
+(defgeneric class-name (class))
+
+(defgeneric class-precedence-list (pcl-class))
+
+(defgeneric class-predicate-name (class))
+
+(defgeneric class-wrapper (pcl-class))
+
+(defgeneric definition-source (definition-source-mixin))
+
+(defgeneric eql-specializer-object (eql-specializer))
+
+(defgeneric generic-function-method-class (standard-generic-function))
+
+(defgeneric generic-function-method-combination (standard-generic-function))
+
+(defgeneric generic-function-methods (standard-generic-function))
+
+(defgeneric generic-function-name (standard-generic-function))
+
+(defgeneric gf-arg-info (standard-generic-function))
+
+(defgeneric gf-dfun-state (standard-generic-function))
+
+(defgeneric gf-pretty-arglist (standard-generic-function))
+
+(defgeneric long-method-combination-function (long-method-combination))
+
+(defgeneric method-combination-documentation (standard-method-combination))
+
+(defgeneric method-combination-options (standard-method-combination))
+
+(defgeneric method-combination-type (standard-method-combination))
+
+(defgeneric method-fast-function (standard-method))
+
+(defgeneric method-generic-function (standard-method))
+
+(defgeneric object-plist (plist-mixin))
+
+(defgeneric short-combination-identity-with-one-argument
+ (short-method-combination))
+
+(defgeneric short-combination-operator (short-method-combination))
+
+(defgeneric slot-definition-boundp-function (effective-slot-definition))
+
+(defgeneric slot-definition-class (slot-definition))
+
+(defgeneric slot-definition-defstruct-accessor-symbol
+ (structure-slot-definition))
+
+(defgeneric slot-definition-initargs (slot-definition))
+
+(defgeneric slot-definition-initform (slot-definition))
+
+(defgeneric slot-definition-initfunction (slot-definition))
+
+(defgeneric slot-definition-internal-reader-function
+ (structure-slot-definition))
+
+(defgeneric slot-definition-internal-writer-function
+ (structure-slot-definition))
+
+(defgeneric slot-definition-location (standard-effective-slot-definition))
+
+(defgeneric slot-definition-name (slot-definition))
+
+(defgeneric slot-definition-reader-function (effective-slot-definition))
+
+(defgeneric slot-definition-readers (slot-definition))
+
+(defgeneric slot-definition-type (slot-definition))
+
+(defgeneric slot-definition-writer-function (effective-slot-definition))
+
+(defgeneric slot-definition-writers (slot-definition))
+
+(defgeneric specializer-object (class-eq-specializer))
+
+(defgeneric specializer-type (specializer))
+\f
+;;;; writers
+
+(defgeneric (setf class-defstruct-constructor) (new-value structure-class))
+
+(defgeneric (setf class-defstruct-form) (new-value structure-class))
+
+(defgeneric (setf class-direct-slots) (new-value slot-class))
+
+(defgeneric (setf class-incompatible-superclass-list) (new-value pcl-class))
+
+(defgeneric (setf class-initialize-info) (new-value slot-class))
+
+(defgeneric (setf class-name) (new-value class))
+
+(defgeneric (setf class-slots) (new-value slot-class))
+
+(defgeneric (setf generic-function-method-class) (new-value
+ standard-generic-function))
+
+(defgeneric (setf generic-function-method-combination)
+ (new-value standard-generic-function))
+
+(defgeneric (setf generic-function-methods) (new-value
+ standard-generic-function))
+
+(defgeneric (setf generic-function-name) (new-value standard-generic-function))
+
+(defgeneric (setf gf-dfun-state) (new-value standard-generic-function))
+
+(defgeneric (setf gf-pretty-arglist) (new-value standard-generic-function))
+
+(defgeneric (setf method-generic-function) (new-value standard-method))
+
+(defgeneric (setf object-plist) (new-value plist-mixin))
+
+(defgeneric (setf slot-definition-allocation) (new-value
+ standard-slot-definition))
+
+(defgeneric (setf slot-definition-boundp-function)
+ (new-value effective-slot-definition))
+
+(defgeneric (setf slot-definition-class) (new-value slot-definition))
+
+(defgeneric (setf slot-definition-defstruct-accessor-symbol)
+ (new-value structure-slot-definition))
+
+(defgeneric (setf slot-definition-initargs) (new-value slot-definition))
+
+(defgeneric (setf slot-definition-initform) (new-value slot-definition))
+
+(defgeneric (setf slot-definition-initfunction) (new-value slot-definition))
+
+(defgeneric (setf slot-definition-internal-reader-function)
+ (new-value structure-slot-definition))
+
+(defgeneric (setf slot-definition-internal-writer-function)
+ (new-value structure-slot-definition))
+
+(defgeneric (setf slot-definition-location)
+ (new-value standard-effective-slot-definition))
+
+(defgeneric (setf slot-definition-name) (new-value slot-definition))
+
+(defgeneric (setf slot-definition-reader-function) (new-value
+ effective-slot-definition))
+
+(defgeneric (setf slot-definition-readers) (new-value slot-definition))
+
+(defgeneric (setf slot-definition-type) (new-value slot-definition))
+
+(defgeneric (setf slot-definition-writer-function)
+ (new-value effective-slot-definition))
+
+(defgeneric (setf slot-definition-writers) (new-value slot-definition))
+\f
+;;;; 1 argument
+
+(defgeneric accessor-method-class (method))
+
+(defgeneric accessor-method-slot-name (m))
+
+(defgeneric class-constructors (class))
+
+(defgeneric class-default-initargs (class))
+
+(defgeneric class-direct-default-initargs (class))
+
+(defgeneric class-direct-slots (class))
+
+(defgeneric class-finalized-p (class))
+
+(defgeneric class-prototype (class))
+
+(defgeneric class-slot-cells (class))
+
+(defgeneric class-slots (class))
+
+(defgeneric compute-class-precedence-list (root))
+
+(defgeneric compute-default-initargs (class))
+
+(defgeneric compute-discriminating-function (gf))
+
+(defgeneric compute-discriminating-function-arglist-info (generic-function))
+
+(defgeneric compute-slots (class))
+
+(defgeneric finalize-inheritance (class))
+
+(defgeneric function-keywords (method))
+
+(defgeneric generic-function-lambda-list (gf))
+
+(defgeneric generic-function-pretty-arglist (generic-function))
+
+(defgeneric gf-fast-method-function-p (gf))
+
+(defgeneric initialize-internal-slot-functions (slotd))
+
+(defgeneric make-instances-obsolete (class))
+
+(defgeneric method-function (method))
+
+(defgeneric method-lambda-list (m))
+
+(defgeneric method-pretty-arglist (method))
+
+(defgeneric method-qualifiers (m))
+
+(defgeneric method-specializers (m))
+
+(defgeneric raw-instance-allocator (class))
+
+(defgeneric slot-definition-allocation (slotd))
+
+(defgeneric slots-fetcher (class))
+
+(defgeneric specializer-class (specializer))
+
+(defgeneric specializer-direct-generic-functions (specializer))
+
+(defgeneric specializer-direct-methods (specializer))
+
+(defgeneric specializer-method-table (specializer))
+
+(defgeneric update-constructors (class))
+
+(defgeneric wrapper-fetcher (class))
+\f
+;;;; 2 arguments
+
+(defgeneric add-dependent (metaobject dependent))
+
+(defgeneric add-direct-method (specializer method))
+
+(defgeneric add-direct-subclass (class subclass))
+
+(defgeneric add-method (generic-function method))
+
+(defgeneric change-class (instance new-class-name))
+
+(defgeneric class-slot-value (class slot-name))
+
+(defgeneric compatible-meta-class-change-p (class proto-new-class))
+
+(defgeneric compute-applicable-methods (generic-function arguments))
+
+(defgeneric compute-applicable-methods-using-classes
+ (generic-function classes))
+
+(defgeneric compute-effective-slot-definition (class dslotds))
+
+(defgeneric compute-effective-slot-definition-initargs (class direct-slotds))
+
+(defgeneric default-initargs (class supplied-initargs))
+
+(defgeneric describe-object (object stream))
+
+(defgeneric direct-slot-definition-class (class initargs))
+
+(defgeneric effective-slot-definition-class (class initargs))
+
+(defgeneric inform-type-system-about-class (class name))
+
+(defgeneric legal-documentation-p (object x))
+
+(defgeneric legal-method-function-p (object x))
+
+(defgeneric legal-qualifier-p (object x))
+
+(defgeneric legal-qualifiers-p (object x))
+
+(defgeneric legal-slot-name-p (object x))
+
+(defgeneric legal-specializer-p (object x))
+
+(defgeneric legal-specializers-p (object x))
+
+(defgeneric make-boundp-method-function (class slot-name))
+
+(defgeneric make-reader-method-function (class slot-name))
+
+(defgeneric make-writer-method-function (class slot-name))
+
+(defgeneric map-dependents (metaobject function))
+
+(defgeneric remove-boundp-method (class generic-function))
+
+(defgeneric remove-dependent (metaobject dependent))
+
+(defgeneric remove-direct-method (specializer method))
+
+(defgeneric remove-direct-subclass (class subclass))
+
+(defgeneric remove-method (generic-function method))
+
+(defgeneric remove-reader-method (class generic-function))
+
+(defgeneric remove-writer-method (class generic-function))
+
+(defgeneric same-specializer-p (specl1 specl2))
+
+(defgeneric slot-accessor-function (slotd type))
+
+(defgeneric slot-accessor-std-p (slotd type))
+
+;;; This controls DESCRIBE-OBJECT (SLOT-OBJECT STREAM) behavior.
+(defgeneric slots-to-inspect (class object))
+
+(defgeneric update-gf-dfun (class gf))
+
+(defgeneric validate-superclass (fsc class))
+
+(defgeneric (setf documentation) (new-value slotd doc-type)
+ (:argument-precedence-order doc-type slotd new-value))
+
+(defgeneric documentation (slotd doc-type)
+ (:argument-precedence-order doc-type slotd))
+\f
+;;;; 3 arguments
+
+(defgeneric add-boundp-method (class generic-function slot-name))
+
+(defgeneric add-reader-method (class generic-function slot-name))
+
+(defgeneric add-writer-method (class generic-function slot-name))
+
+(defgeneric (setf class-slot-value) (nv class slot-name))
+
+(defgeneric compute-effective-method (generic-function
+ combin
+ applicable-methods))
+
+(defgeneric compute-slot-accessor-info (slotd type gf))
+
+(defgeneric find-method-combination (generic-function type options))
+
+(defgeneric (setf slot-accessor-function) (function slotd type))
+
+(defgeneric (setf slot-accessor-std-p) (value slotd type))
+
+(defgeneric slot-boundp-using-class (class object slotd))
+
+(defgeneric slot-makunbound-using-class (class object slotd))
+
+(defgeneric slot-unbound (class instance slot-name))
+
+(defgeneric slot-value-using-class (class object slotd))
+\f
+;;;; 4 arguments
+
+(defgeneric make-method-lambda (proto-generic-function
+ proto-method
+ lambda-expression
+ environment))
+
+(defgeneric (setf slot-value-using-class) (new-value class object slotd))
+\f
+;;;; 5 arguments
+
+(defgeneric make-method-initargs-form (proto-generic-function
+ proto-method
+ lambda-expression
+ lambda-list
+ environment))
+\f
+;;;; optional arguments
+
+(defgeneric get-method (generic-function
+ qualifiers
+ specializers
+ &optional (errorp t)))
+
+(defgeneric find-method (generic-function
+ qualifiers
+ specializers
+ &optional (errorp t)))
+
+(defgeneric remove-named-method (generic-function-name
+ argument-specifiers
+ &optional extra))
+
+(defgeneric slot-missing (class
+ instance
+ slot-name
+ operation
+ &optional new-value))
+\f
+;;;; keyword arguments
+
+(defgeneric allocate-instance (class &rest initargs))
+
+(defgeneric ensure-class-using-class (name
+ class
+ &rest args
+ &key &allow-other-keys))
+
+(defgeneric ensure-generic-function-using-class (generic-function
+ function-name
+ &key &allow-other-keys))
+
+(defgeneric initialize-instance (gf &key &allow-other-keys))
+
+(defgeneric make-instance (class &rest initargs))
+
+(defgeneric no-applicable-method (generic-function &rest args))
+
+(defgeneric reader-method-class (class direct-slot &rest initargs))
+
+(defgeneric reinitialize-instance (gf &rest args &key &allow-other-keys))
+
+(defgeneric shared-initialize (generic-function
+ slot-names
+ &key &allow-other-keys))
+
+(defgeneric update-dependent (metaobject dependent &rest initargs))
+
+(defgeneric update-instance-for-different-class (previous
+ current
+ &rest initargs))
+
+(defgeneric update-instance-for-redefined-class (instance
+ added-slots
+ discarded-slots
+ property-list
+ &rest initargs))
+
+(defgeneric writer-method-class (class direct-slot &rest initargs))
--- /dev/null
+;;;; class definitions for the SBCL Gray streams implementation, based on the
+;;;; CMU CL Gray streams implementation, based on the stream-definition-by-user
+;;;; proposal by David N. Gray
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+
+;;;; 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 "SB-GRAY")
+
+(sb-int:file-comment
+ "$Header$")
+\f
+;;; Bootstrap the FUNDAMENTAL-STREAM class.
+(let ((sb-pcl::*pcl-class-boot* 'fundamental-stream))
+ (defclass fundamental-stream (standard-object stream)
+ ()
+ #+sb-doc
+ (:documentation "the base class for all CLOS streams")))
+
+;;; Define the stream classes.
+(defclass fundamental-input-stream (fundamental-stream))
+
+(defclass fundamental-output-stream (fundamental-stream))
+
+(defclass fundamental-character-stream (fundamental-stream))
+
+(defclass fundamental-binary-stream (fundamental-stream))
+
+(defclass fundamental-character-input-stream
+ (fundamental-input-stream fundamental-character-stream))
+
+(defclass fundamental-character-output-stream
+ (fundamental-output-stream fundamental-character-stream))
+
+(defclass fundamental-binary-input-stream
+ (fundamental-input-stream fundamental-binary-stream))
+
+(defclass fundamental-binary-output-stream
+ (fundamental-output-stream fundamental-binary-stream))
+\f
+;;; example character input and output streams
+
+(defclass character-output-stream (fundamental-character-output-stream)
+ ((lisp-stream :initarg :lisp-stream
+ :accessor character-output-stream-lisp-stream)))
+
+(defclass character-input-stream (fundamental-character-input-stream)
+ ((lisp-stream :initarg :lisp-stream
+ :accessor character-input-stream-lisp-stream)))
--- /dev/null
+;;;; Gray streams implementation for SBCL, based on the Gray streams
+;;;; implementation for CMU CL, based on the stream-definition-by-user proposal
+;;;; by David N. Gray.
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+
+;;;; 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 "SB-GRAY")
+
+(sb-int:file-comment
+ "$Header$")
+\f
+(fmakunbound 'stream-element-type)
+
+(defgeneric stream-element-type (stream)
+ #+sb-doc
+ (:documentation
+ "Returns a type specifier for the kind of object returned by the
+ Stream. Class FUNDAMENTAL-CHARACTER-STREAM provides a default method
+ which returns CHARACTER."))
+
+(defmethod stream-element-type ((stream lisp-stream))
+ (funcall (lisp-stream-misc stream) stream :element-type))
+
+(defmethod stream-element-type ((stream fundamental-character-stream))
+ 'character)
+\f
+(defgeneric pcl-open-stream-p (stream)
+ #+sb-doc
+ (:documentation
+ "Return true if Stream is not closed. A default method is provided
+ by class FUNDAMENTAL-STREAM which returns true if CLOSE has not been
+ called on the stream."))
+
+(defmethod pcl-open-stream-p ((stream lisp-stream))
+ (not (eq (lisp-stream-in stream) #'closed-flame)))
+
+(defmethod pcl-open-stream-p ((stream fundamental-stream))
+ nil)
+
+;;; bootstrapping hack
+(pcl-open-stream-p (make-string-output-stream))
+(setf (fdefinition 'open-stream-p) #'pcl-open-stream-p)
+\f
+(defgeneric pcl-close (stream &key abort)
+ #+sb-doc
+ (:documentation
+ "Closes the given Stream. No more I/O may be performed, but
+ inquiries may still be made. If :Abort is non-nil, an attempt is made
+ to clean up the side effects of having created the stream."))
+
+(defmethod pcl-close ((stream lisp-stream) &key abort)
+ (when (open-stream-p stream)
+ (funcall (lisp-stream-misc stream) stream :close abort))
+ t)
+
+(setf (fdefinition 'close) #'pcl-close)
+\f
+(fmakunbound 'input-stream-p)
+
+(defgeneric input-stream-p (stream)
+ #+sb-doc
+ (:documentation "Returns non-nil if the given Stream can perform input operations."))
+
+(defmethod input-stream-p ((stream lisp-stream))
+ (and (not (eq (lisp-stream-in stream) #'closed-flame))
+ (or (not (eq (lisp-stream-in stream) #'ill-in))
+ (not (eq (lisp-stream-bin stream) #'ill-bin)))))
+
+(defmethod input-stream-p ((stream fundamental-input-stream))
+ t)
+\f
+(fmakunbound 'output-stream-p)
+
+(defgeneric output-stream-p (stream)
+ #+sb-doc
+ (:documentation "Returns non-nil if the given Stream can perform output operations."))
+
+(defmethod output-stream-p ((stream lisp-stream))
+ (and (not (eq (lisp-stream-in stream) #'closed-flame))
+ (or (not (eq (lisp-stream-out stream) #'ill-out))
+ (not (eq (lisp-stream-bout stream) #'ill-bout)))))
+
+(defmethod output-stream-p ((stream fundamental-output-stream))
+ t)
+\f
+;;; character input streams
+;;;
+;;; A character input stream can be created by defining a class that
+;;; includes FUNDAMENTAL-CHARACTER-INPUT-STREAM and defining methods
+;;; for the generic functions below.
+
+(defgeneric stream-read-char (stream)
+ #+sb-doc
+ (:documentation
+ "This reads one character from the stream. It returns either a
+ character object, or the symbol :EOF if the stream is at end-of-file.
+ Every subclass of FUNDAMENTAL-CHARACTER-INPUT-STREAM must define a
+ method for this function."))
+
+(defgeneric stream-unread-char (stream character)
+ #+sb-doc
+ (:documentation
+ "Un-does the last call to STREAM-READ-CHAR, as in UNREAD-CHAR.
+ Returns NIL. Every subclass of FUNDAMENTAL-CHARACTER-INPUT-STREAM
+ must define a method for this function."))
+
+(defgeneric stream-read-char-no-hang (stream)
+ #+sb-doc
+ (:documentation
+ "This is used to implement READ-CHAR-NO-HANG. It returns either a
+ character, or NIL if no input is currently available, or :EOF if
+ end-of-file is reached. The default method provided by
+ FUNDAMENTAL-CHARACTER-INPUT-STREAM simply calls STREAM-READ-CHAR; this
+ is sufficient for file streams, but interactive streams should define
+ their own method."))
+
+(defmethod stream-read-char-no-hang ((stream fundamental-character-input-stream))
+ (stream-read-char stream))
+
+(defgeneric stream-peek-char (stream)
+ #+sb-doc
+ (:documentation
+ "Used to implement PEEK-CHAR; this corresponds to peek-type of NIL.
+ It returns either a character or :EOF. The default method calls
+ STREAM-READ-CHAR and STREAM-UNREAD-CHAR."))
+
+(defmethod stream-peek-char ((stream fundamental-character-input-stream))
+ (let ((char (stream-read-char stream)))
+ (unless (eq char :eof)
+ (stream-unread-char stream char))
+ char))
+
+(defgeneric stream-listen (stream)
+ #+sb-doc
+ (:documentation
+ "Used by LISTEN. Returns true or false. The default method uses
+ STREAM-READ-CHAR-NO-HANG and STREAM-UNREAD-CHAR. Most streams should
+ define their own method since it will usually be trivial and will
+ always be more efficient than the default method."))
+
+(defmethod stream-listen ((stream fundamental-character-input-stream))
+ (let ((char (stream-read-char-no-hang stream)))
+ (when (characterp char)
+ (stream-unread-char stream char)
+ t)))
+
+(defgeneric stream-read-line (stream)
+ #+sb-doc
+ (:documentation
+ "Used by READ-LINE. A string is returned as the first value. The
+ second value is true if the string was terminated by end-of-file
+ instead of the end of a line. The default method uses repeated
+ calls to STREAM-READ-CHAR."))
+
+(defmethod stream-read-line ((stream fundamental-character-input-stream))
+ (let ((res (make-string 80))
+ (len 80)
+ (index 0))
+ (loop
+ (let ((ch (stream-read-char stream)))
+ (cond ((eq ch :eof)
+ (return (values (shrink-vector res index) t)))
+ (t
+ (when (char= ch #\newline)
+ (return (values (shrink-vector res index) nil)))
+ (when (= index len)
+ (setq len (* len 2))
+ (let ((new (make-string len)))
+ (replace new res)
+ (setq res new)))
+ (setf (schar res index) ch)
+ (incf index)))))))
+
+(defgeneric stream-clear-input (stream)
+ #+sb-doc
+ (:documentation
+ "Implements CLEAR-INPUT for the stream, returning NIL. The default
+ method does nothing."))
+
+(defmethod stream-clear-input ((stream fundamental-character-input-stream))
+ nil)
+\f
+;;; character output streams
+;;;
+;;; A character output stream can be created by defining a class that
+;;; includes FUNDAMENTAL-CHARACTER-OUTPUT-STREAM and defining methods
+;;; for the generic functions below.
+
+(defgeneric stream-write-char (stream character)
+ #+sb-doc
+ (:documentation
+ "Writes character to the stream and returns the character. Every
+ subclass of FUNDAMENTAL-CHARACTER-OUTPUT-STREAM must have a method
+ defined for this function."))
+
+(defgeneric stream-line-column (stream)
+ #+sb-doc
+ (:documentation
+ "This function returns the column number where the next character
+ will be written, or NIL if that is not meaningful for this stream.
+ The first column on a line is numbered 0. This function is used in
+ the implementation of PPRINT and the FORMAT ~T directive. For every
+ character output stream class that is defined, a method must be
+ defined for this function, although it is permissible for it to
+ always return NIL."))
+
+;;; STREAM-LINE-LENGTH is a CMU CL extension to Gray streams.
+;;; FIXME: Should we support it? Probably not..
+(defgeneric stream-line-length (stream)
+ #+sb-doc
+ (:documentation "Return the stream line length or Nil."))
+
+(defmethod stream-line-length ((stream fundamental-character-output-stream))
+ nil)
+
+(defgeneric stream-start-line-p (stream)
+ #+sb-doc
+ (:documentation
+ "This is a predicate which returns T if the stream is positioned at
+ the beginning of a line, else NIL. It is permissible to always return
+ NIL. This is used in the implementation of FRESH-LINE. Note that
+ while a value of 0 from STREAM-LINE-COLUMN also indicates the
+ beginning of a line, there are cases where STREAM-START-LINE-P can be
+ meaningfully implemented although STREAM-LINE-COLUMN can't be. For
+ example, for a window using variable-width characters, the column
+ number isn't very meaningful, but the beginning of the line does have
+ a clear meaning. The default method for STREAM-START-LINE-P on class
+ FUNDAMENTAL-CHARACTER-OUTPUT-STREAM uses STREAM-LINE-COLUMN, so if
+ that is defined to return NIL, then a method should be provided for
+ either STREAM-START-LINE-P or STREAM-FRESH-LINE."))
+
+(defmethod stream-start-line-p ((stream fundamental-character-output-stream))
+ (eql (stream-line-column stream) 0))
+
+(defgeneric stream-write-string (stream string &optional (start 0) end)
+ #+sb-doc
+ (:documentation
+ "This is used by WRITE-STRING. It writes the string to the stream,
+ optionally delimited by start and end, which default to 0 and NIL.
+ The string argument is returned. The default method provided by
+ FUNDAMENTAL-CHARACTER-OUTPUT-STREAM uses repeated calls to
+ STREAM-WRITE-CHAR."))
+
+(defmethod stream-write-string ((stream fundamental-character-output-stream)
+ string &optional (start 0) end)
+ (declare (string string)
+ (fixnum start))
+ (let ((end (or end (length string))))
+ (declare (fixnum end))
+ (do ((pos start (1+ pos)))
+ ((>= pos end))
+ (declare (type index pos))
+ (stream-write-char stream (aref string pos))))
+ string)
+
+(defgeneric stream-terpri (stream)
+ #+sb-doc
+ (:documentation
+ "Writes an end of line, as for TERPRI. Returns NIL. The default
+ method does (STREAM-WRITE-CHAR stream #\NEWLINE)."))
+
+(defmethod stream-terpri ((stream fundamental-character-output-stream))
+ (stream-write-char stream #\Newline))
+
+(defgeneric stream-fresh-line (stream)
+ #+sb-doc
+ (:documentation
+ "Outputs a new line to the Stream if it is not positioned at the
+ begining of a line. Returns T if it output a new line, nil
+ otherwise. Used by FRESH-LINE. The default method uses
+ STREAM-START-LINE-P and STREAM-TERPRI."))
+
+(defmethod stream-fresh-line ((stream fundamental-character-output-stream))
+ (unless (stream-start-line-p stream)
+ (stream-terpri stream)
+ t))
+
+(defgeneric stream-finish-output (stream)
+ #+sb-doc
+ (:documentation
+ "Attempts to ensure that all output sent to the Stream has reached
+ its destination, and only then returns false. Implements
+ FINISH-OUTPUT. The default method does nothing."))
+
+(defmethod stream-finish-output ((stream fundamental-output-stream))
+ nil)
+
+(defgeneric stream-force-output (stream)
+ #+sb-doc
+ (:documentation
+ "Attempts to force any buffered output to be sent. Implements
+ FORCE-OUTPUT. The default method does nothing."))
+
+(defmethod stream-force-output ((stream fundamental-output-stream))
+ nil)
+
+(defgeneric stream-clear-output (stream)
+ #+sb-doc
+ (:documentation
+ "Clears the given output Stream. Implements CLEAR-OUTPUT. The
+ default method does nothing."))
+
+(defmethod stream-clear-output ((stream fundamental-output-stream))
+ nil)
+
+(defgeneric stream-advance-to-column (stream column)
+ #+sb-doc
+ (:documentation
+ "Writes enough blank space so that the next character will be
+ written at the specified column. Returns true if the operation is
+ successful, or NIL if it is not supported for this stream. This is
+ intended for use by by PPRINT and FORMAT ~T. The default method uses
+ STREAM-LINE-COLUMN and repeated calls to STREAM-WRITE-CHAR with a
+ #\SPACE character; it returns NIL if STREAM-LINE-COLUMN returns NIL."))
+
+(defmethod stream-advance-to-column ((stream fundamental-character-output-stream)
+ column)
+ (let ((current-column (stream-line-column stream)))
+ (when current-column
+ (let ((fill (- column current-column)))
+ (dotimes-fixnum (i fill)
+ (stream-write-char stream #\Space)))
+ T)))
+\f
+;;; binary streams
+;;;
+;;; Binary streams can be created by defining a class that includes
+;;; either FUNDAMENTAL-BINARY-INPUT-STREAM or
+;;; FUNDAMENTAL-BINARY-OUTPUT-STREAM (or both) and defining a method
+;;; for STREAM-ELEMENT-TYPE and for one or both of the following
+;;; generic functions.
+
+(defgeneric stream-read-byte (stream)
+ #+sb-doc
+ (:documentation
+ "Used by READ-BYTE; returns either an integer, or the symbol :EOF
+ if the stream is at end-of-file."))
+
+(defgeneric stream-write-byte (stream integer)
+ #+sb-doc
+ (:documentation
+ "Implements WRITE-BYTE; writes the integer to the stream and
+ returns the integer as the result."))
+\f
+;;; example character output stream encapsulating a lisp-stream
+(defun make-character-output-stream (lisp-stream)
+ (declare (type lisp-stream lisp-stream))
+ (make-instance 'character-output-stream :lisp-stream lisp-stream))
+
+(defmethod open-stream-p ((stream character-output-stream))
+ (open-stream-p (character-output-stream-lisp-stream stream)))
+
+(defmethod close ((stream character-output-stream) &key abort)
+ (close (character-output-stream-lisp-stream stream) :abort abort))
+
+(defmethod input-stream-p ((stream character-output-stream))
+ (input-stream-p (character-output-stream-lisp-stream stream)))
+
+(defmethod output-stream-p ((stream character-output-stream))
+ (output-stream-p (character-output-stream-lisp-stream stream)))
+
+(defmethod stream-write-char ((stream character-output-stream) character)
+ (write-char character (character-output-stream-lisp-stream stream)))
+
+(defmethod stream-line-column ((stream character-output-stream))
+ (charpos (character-output-stream-lisp-stream stream)))
+
+(defmethod stream-line-length ((stream character-output-stream))
+ (line-length (character-output-stream-lisp-stream stream)))
+
+(defmethod stream-finish-output ((stream character-output-stream))
+ (finish-output (character-output-stream-lisp-stream stream)))
+
+(defmethod stream-force-output ((stream character-output-stream))
+ (force-output (character-output-stream-lisp-stream stream)))
+
+(defmethod stream-clear-output ((stream character-output-stream))
+ (clear-output (character-output-stream-lisp-stream stream)))
+\f
+;;; example character input stream encapsulating a lisp-stream
+
+(defun make-character-input-stream (lisp-stream)
+ (declare (type lisp-stream lisp-stream))
+ (make-instance 'character-input-stream :lisp-stream lisp-stream))
+
+(defmethod open-stream-p ((stream character-input-stream))
+ (open-stream-p (character-input-stream-lisp-stream stream)))
+
+(defmethod close ((stream character-input-stream) &key abort)
+ (close (character-input-stream-lisp-stream stream) :abort abort))
+
+(defmethod input-stream-p ((stream character-input-stream))
+ (input-stream-p (character-input-stream-lisp-stream stream)))
+
+(defmethod output-stream-p ((stream character-input-stream))
+ (output-stream-p (character-input-stream-lisp-stream stream)))
+
+(defmethod stream-read-char ((stream character-input-stream))
+ (read-char (character-input-stream-lisp-stream stream)))
+
+(defmethod stream-unread-char ((stream character-input-stream) character)
+ (unread-char character (character-input-stream-lisp-stream stream)))
+
+(defmethod stream-read-char-no-hang ((stream character-input-stream))
+ (read-char-no-hang (character-input-stream-lisp-stream stream) nil :eof))
+
+#+nil
+(defmethod stream-peek-char ((stream character-input-stream))
+ (peek-char nil (character-input-stream-lisp-stream stream) nil :eof))
+
+#+nil
+(defmethod stream-listen ((stream character-input-stream))
+ (listen (character-input-stream-lisp-stream stream)))
+
+(defmethod stream-clear-input ((stream character-input-stream))
+ (clear-input (character-input-stream-lisp-stream stream)))
--- /dev/null
+;;;; This file defines the initialization and related protocols.
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+
+;;;; This software is derived from software originally released by Xerox
+;;;; Corporation. Copyright and release statements follow. Later modifications
+;;;; to the software are in the public domain and are provided with
+;;;; absolutely no warranty. See the COPYING and CREDITS files for more
+;;;; information.
+
+;;;; copyright information from original PCL sources:
+;;;;
+;;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
+;;;; All rights reserved.
+;;;;
+;;;; Use and copying of this software and preparation of derivative works based
+;;;; upon this software are permitted. Any distribution of this software or
+;;;; derivative works must comply with all applicable United States export
+;;;; control laws.
+;;;;
+;;;; This software is made available AS IS, and Xerox Corporation makes no
+;;;; warranty about the software, its performance or its conformity to any
+;;;; specification.
+
+(in-package "SB-PCL")
+
+(sb-int:file-comment
+ "$Header$")
+\f
+(defmethod make-instance ((class symbol) &rest initargs)
+ (apply #'make-instance (find-class class) initargs))
+
+(defmethod make-instance ((class class) &rest initargs)
+ (unless (class-finalized-p class) (finalize-inheritance class))
+ (setq initargs (default-initargs class initargs))
+ #||
+ (check-initargs-1
+ class initargs
+ (list (list* 'allocate-instance class initargs)
+ (list* 'initialize-instance (class-prototype class) initargs)
+ (list* 'shared-initialize (class-prototype class) t initargs)))
+ ||#
+ (let* ((info (initialize-info class initargs))
+ (valid-p (initialize-info-valid-p info)))
+ (when (and (consp valid-p) (eq (car valid-p) :invalid))
+ (error "Invalid initialization argument ~S for class ~S"
+ (cdr valid-p) (class-name class))))
+ (let ((instance (apply #'allocate-instance class initargs)))
+ (apply #'initialize-instance instance initargs)
+ instance))
+
+(defvar *default-initargs-flag* (list nil))
+
+(defmethod default-initargs ((class slot-class) supplied-initargs)
+ (call-initialize-function
+ (initialize-info-default-initargs-function
+ (initialize-info class supplied-initargs))
+ nil supplied-initargs)
+ #||
+ ;; This implementation of default initargs is critically dependent
+ ;; on all-default-initargs not having any duplicate initargs in it.
+ (let ((all-default (class-default-initargs class))
+ (miss *default-initargs-flag*))
+ (flet ((getf* (plist key)
+ (do ()
+ ((null plist) miss)
+ (if (eq (car plist) key)
+ (return (cadr plist))
+ (setq plist (cddr plist))))))
+ (labels ((default-1 (tail)
+ (if (null tail)
+ nil
+ (if (eq (getf* supplied-initargs (caar tail)) miss)
+ (list* (caar tail)
+ (funcall (cadar tail))
+ (default-1 (cdr tail)))
+ (default-1 (cdr tail))))))
+ (append supplied-initargs (default-1 all-default)))))
+ ||#)
+
+(defmethod initialize-instance ((instance slot-object) &rest initargs)
+ (apply #'shared-initialize instance t initargs))
+
+(defmethod reinitialize-instance ((instance slot-object) &rest initargs)
+ #||
+ (check-initargs-1
+ (class-of instance) initargs
+ (list (list* 'reinitialize-instance instance initargs)
+ (list* 'shared-initialize instance nil initargs)))
+ ||#
+ (let* ((class (class-of instance))
+ (info (initialize-info class initargs))
+ (valid-p (initialize-info-ri-valid-p info)))
+ (when (and (consp valid-p) (eq (car valid-p) :invalid))
+ (error "Invalid initialization argument ~S for class ~S"
+ (cdr valid-p) (class-name class))))
+ (apply #'shared-initialize instance nil initargs)
+ instance)
+
+(defmethod update-instance-for-different-class ((previous std-object)
+ (current std-object)
+ &rest initargs)
+ ;; First we must compute the newly added slots. The spec defines
+ ;; newly added slots as "those local slots for which no slot of
+ ;; the same name exists in the previous class."
+ (let ((added-slots '())
+ (current-slotds (class-slots (class-of current)))
+ (previous-slot-names (mapcar #'slot-definition-name
+ (class-slots (class-of previous)))))
+ (dolist (slotd current-slotds)
+ (if (and (not (memq (slot-definition-name slotd) previous-slot-names))
+ (eq (slot-definition-allocation slotd) ':instance))
+ (push (slot-definition-name slotd) added-slots)))
+ (check-initargs-1
+ (class-of current) initargs
+ (list (list* 'update-instance-for-different-class previous current initargs)
+ (list* 'shared-initialize current added-slots initargs)))
+ (apply #'shared-initialize current added-slots initargs)))
+
+(defmethod update-instance-for-redefined-class ((instance std-object)
+ added-slots
+ discarded-slots
+ property-list
+ &rest initargs)
+ (check-initargs-1
+ (class-of instance) initargs
+ (list (list* 'update-instance-for-redefined-class
+ instance added-slots discarded-slots property-list initargs)
+ (list* 'shared-initialize instance added-slots initargs)))
+ (apply #'shared-initialize instance added-slots initargs))
+
+(defmethod shared-initialize
+ ((instance slot-object) slot-names &rest initargs)
+ (when (eq slot-names 't)
+ (return-from shared-initialize
+ (call-initialize-function
+ (initialize-info-shared-initialize-t-function
+ (initialize-info (class-of instance) initargs))
+ instance initargs)))
+ (when (eq slot-names 'nil)
+ (return-from shared-initialize
+ (call-initialize-function
+ (initialize-info-shared-initialize-nil-function
+ (initialize-info (class-of instance) initargs))
+ instance initargs)))
+ ;; Initialize the instance's slots in a two step process:
+ ;; (1) A slot for which one of the initargs in initargs can set
+ ;; the slot, should be set by that initarg. If more than
+ ;; one initarg in initargs can set the slot, the leftmost
+ ;; one should set it.
+ ;; (2) Any slot not set by step 1, may be set from its initform
+ ;; by step 2. Only those slots specified by the slot-names
+ ;; argument are set. If slot-names is:
+ ;; T
+ ;; then any slot not set in step 1 is set from its
+ ;; initform.
+ ;; <list of slot names>
+ ;; then any slot in the list, and not set in step 1
+ ;; is set from its initform.
+ ;; ()
+ ;; then no slots are set from initforms.
+ (let* ((class (class-of instance))
+ (slotds (class-slots class))
+ (std-p (pcl-instance-p instance)))
+ (dolist (slotd slotds)
+ (let ((slot-name (slot-definition-name slotd))
+ (slot-initargs (slot-definition-initargs slotd)))
+ (unless (progn
+ ;; Try to initialize the slot from one of the initargs.
+ ;; If we succeed return T, otherwise return nil.
+ (doplist (initarg val) initargs
+ (when (memq initarg slot-initargs)
+ (setf (slot-value-using-class class
+ instance
+ slotd)
+ val)
+ (return 't))))
+ ;; Try to initialize the slot from its initform.
+ (if (and slot-names
+ (or (eq slot-names 't)
+ (memq slot-name slot-names))
+ (or (and (not std-p) (eq slot-names 't))
+ (not (slot-boundp-using-class class instance slotd))))
+ (let ((initfunction (slot-definition-initfunction slotd)))
+ (when initfunction
+ (setf (slot-value-using-class class instance slotd)
+ (funcall initfunction))))))))
+ instance))
+\f
+;;; If initargs are valid return nil, otherwise signal an error.
+(defun check-initargs-1 (class initargs call-list
+ &optional (plist-p t) (error-p t))
+ (multiple-value-bind (legal allow-other-keys)
+ (check-initargs-values class call-list)
+ (unless allow-other-keys
+ (if plist-p
+ (check-initargs-2-plist initargs class legal error-p)
+ (check-initargs-2-list initargs class legal error-p)))))
+
+(defun check-initargs-values (class call-list)
+ (let ((methods (mapcan #'(lambda (call)
+ (if (consp call)
+ (copy-list (compute-applicable-methods
+ (gdefinition (car call))
+ (cdr call)))
+ (list call)))
+ call-list))
+ (legal (apply #'append (mapcar #'slot-definition-initargs
+ (class-slots class)))))
+ ;; Add to the set of slot-filling initargs the set of
+ ;; initargs that are accepted by the methods. If at
+ ;; any point we come across &allow-other-keys, we can
+ ;; just quit.
+ (dolist (method methods)
+ (multiple-value-bind (nreq nopt keysp restp allow-other-keys keys)
+ (analyze-lambda-list (if (consp method)
+ (early-method-lambda-list method)
+ (method-lambda-list method)))
+ (declare (ignore nreq nopt keysp restp))
+ (when allow-other-keys
+ (return-from check-initargs-values (values nil t)))
+ (setq legal (append keys legal))))
+ (values legal nil)))
+
+(defun check-initargs-2-plist (initargs class legal &optional (error-p t))
+ (unless (getf initargs :allow-other-keys)
+ ;; Now check the supplied-initarg-names and the default initargs
+ ;; against the total set that we know are legal.
+ (doplist (key val) initargs
+ (unless (memq key legal)
+ (if error-p
+ (error "Invalid initialization argument ~S for class ~S"
+ key
+ (class-name class))
+ (return-from check-initargs-2-plist nil)))))
+ t)
+
+(defun check-initargs-2-list (initkeys class legal &optional (error-p t))
+ (unless (memq :allow-other-keys initkeys)
+ ;; Now check the supplied-initarg-names and the default initargs
+ ;; against the total set that we know are legal.
+ (dolist (key initkeys)
+ (unless (memq key legal)
+ (if error-p
+ (error "Invalid initialization argument ~S for class ~S"
+ key
+ (class-name class))
+ (return-from check-initargs-2-list nil)))))
+ t)
+
--- /dev/null
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+
+;;;; This software is derived from software originally released by Xerox
+;;;; Corporation. Copyright and release statements follow. Later modifications
+;;;; to the software are in the public domain and are provided with
+;;;; absolutely no warranty. See the COPYING and CREDITS files for more
+;;;; information.
+
+;;;; copyright information from original PCL sources:
+;;;;
+;;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
+;;;; All rights reserved.
+;;;;
+;;;; Use and copying of this software and preparation of derivative works based
+;;;; upon this software are permitted. Any distribution of this software or
+;;;; derivative works must comply with all applicable United States export
+;;;; control laws.
+;;;;
+;;;; This software is made available AS IS, and Xerox Corporation makes no
+;;;; warranty about the software, its performance or its conformity to any
+;;;; specification.
+
+(in-package "SB-ITERATE")
+
+(sb-int:file-comment
+ "$Header$")
+\f
+;;; Are warnings to be issued for iterate/gather forms that aren't optimized?
+;;; NIL => never
+;;; :USER => those resulting from user code
+;;; T => always, even if it's the iteration macro that's suboptimal.
+(defvar *iterate-warnings* :any)
+
+;;; ITERATE macro
+(defmacro iterate (clauses &body body &environment env)
+ (optimize-iterate-form clauses body env))
+
+(defun
+ simple-expand-iterate-form
+ (clauses body)
+
+ ;; Expand ITERATE. This is the "formal semantics" expansion, which we never
+ ;; use.
+ (let*
+ ((block-name (gensym))
+ (bound-var-lists (mapcar #'(lambda (clause)
+ (let ((names (first clause)))
+ (if (listp names)
+ names
+ (list names))))
+ clauses))
+ (generator-vars (mapcar #'(lambda (clause)
+ (declare (ignore clause))
+ (gensym))
+ clauses)))
+ `(block ,block-name
+ (let*
+ ,(mapcan #'(lambda (gvar clause var-list)
+ ;; For each clause, bind a generator temp to the clause,
+ ;; then bind the specified var(s).
+ (cons (list gvar (second clause))
+ (copy-list var-list)))
+ generator-vars clauses bound-var-lists)
+
+ ;; Note bug in formal semantics: there can be declarations in the head
+ ;; of BODY; they go here, rather than inside loop.
+ (loop
+ ,@(mapcar
+ #'(lambda (var-list gen-var)
+ ;; Set each bound variable (or set of vars) to the result of
+ ;; calling the corresponding generator.
+ `(multiple-value-setq ,var-list
+ (funcall ,gen-var #'(lambda nil (return-from
+ ,block-name)))))
+ bound-var-lists generator-vars)
+ ,@body)))))
+
+;;; temporary variable names used by ITERATE expansions
+(defparameter *iterate-temp-vars-list*
+ '(iterate-temp-1 iterate-temp-2 iterate-temp-3 iterate-temp-4
+ iterate-temp-5 iterate-temp-6 iterate-temp-7 iterate-temp-8))
+
+(defun
+ optimize-iterate-form
+ (clauses body iterate-env)
+ (let*
+ ((temp-vars *iterate-temp-vars-list*)
+ (block-name (gensym))
+ (finish-form `(return-from ,block-name))
+ (bound-vars (mapcan #'(lambda (clause)
+ (let ((names (first clause)))
+ (if (listp names)
+ (copy-list names)
+ (list names))))
+ clauses))
+ iterate-decls generator-decls update-forms bindings leftover-body)
+ (do ((tail bound-vars (cdr tail)))
+ ((null tail))
+ ;; Check for duplicates
+ (when (member (car tail)
+ (cdr tail))
+ (warn "Variable appears more than once in ITERATE: ~S" (car tail))))
+ (flet
+ ((get-iterate-temp nil
+
+ ;; Make temporary var. Note that it is ok to re-use these symbols
+ ;; in each iterate, because they are not used within BODY.
+ (or (pop temp-vars)
+ (gensym))))
+ (dolist (clause clauses)
+ (cond
+ ((or (not (consp clause))
+ (not (consp (cdr clause))))
+ (warn "bad syntax in ITERATE: clause not of form (var iterator): ~S"
+ clause))
+ (t
+ (unless (null (cddr clause))
+ (warn
+ "probable parenthesis error in ITERATE clause--more than 2 elements: ~S"
+ clause))
+ (multiple-value-bind
+ (let-body binding-type let-bindings localdecls otherdecls extra-body)
+ (expand-into-let (second clause)
+ 'iterate iterate-env)
+
+ ;; We have expanded the generator clause and parsed it into
+ ;; its LET pieces.
+ (prog*
+ ((vars (first clause))
+ gen-args renamed-vars)
+ (setq vars (if (listp vars)
+ (copy-list vars)
+ (list vars)))
+ ; VARS is now a (fresh) list of
+ ; all iteration vars bound in
+ ; this clause
+ (cond
+ ((eq let-body :abort)
+ ; Already issued a warning
+ ; about malformedness
+ )
+ ((null (setq let-body (function-lambda-p let-body 1)))
+ ; Not of the expected form
+ (let ((generator (second clause)))
+ (cond ((and (consp generator)
+ (fboundp (car generator)))
+ ; It looks ok--a macro or
+ ; function here--so the guy who
+ ; wrote it just didn't do it in
+ ; an optimizable way
+ (maybe-warn :definition "could not optimize iterate clause ~S because generator not of form (LET[*] ... (FUNCTION (LAMBDA (finish) ...)))"
+ generator))
+ (t ; Perhaps it's just a
+ ; misspelling? Probably user
+ ; error
+ (maybe-warn :user
+ "Iterate operator in clause ~S is not fboundp."
+ generator)))
+ (setq let-body :abort)))
+ (t
+
+ ;; We have something of the form #'(LAMBDA (finisharg) ...),
+ ;; possibly with some LET bindings around it. LET-BODY =
+ ;; ((finisharg) ...).
+ (setq let-body (cdr let-body))
+ (setq gen-args (pop let-body))
+ (when let-bindings
+
+ ;; The first transformation we want to perform is
+ ;; "LET-eversion": turn (let* ((generator (let (..bindings..)
+ ;; #'(lambda ...)))) ..body..) into (let* (..bindings..
+ ;; (generator #'(lambda ...))) ..body..). This
+ ;; transformation is valid if nothing in body refers to any
+ ;; of the bindings, something we can ensure by
+ ;; alpha-converting the inner let (substituting new names for
+ ;; each var). Of course, none of those vars can be special,
+ ;; but we already checked for that above.
+ (multiple-value-setq (let-bindings renamed-vars)
+ (rename-let-bindings let-bindings binding-type
+ iterate-env leftover-body #'get-iterate-temp))
+ (setq leftover-body nil)
+ ; If there was any leftover
+ ; from previous, it is now
+ ; consumed.
+ )
+
+ ;; The second transformation is substituting the body of the
+ ;; generator (LAMBDA (finish-arg) . gen-body) for its appearance
+ ;; in the update form (funcall generator #'(lambda ()
+ ;; finish-form)), then simplifying that form. The requirement
+ ;; for this part is that the generator body not refer to any
+ ;; variables that are bound between the generator binding and the
+ ;; appearance in the loop body. The only variables bound in that
+ ;; interval are generator temporaries, which have unique names so
+ ;; are no problem, and the iteration variables remaining for
+ ;; subsequent clauses. We'll discover the story as we walk the
+ ;; body.
+ (multiple-value-bind (finishdecl other rest)
+ (parse-declarations let-body gen-args)
+ (declare (ignore finishdecl))
+ ; Pull out declares, if any,
+ ; separating out the one(s)
+ ; referring to the finish arg,
+ ; which we will throw away.
+ (when other
+ ; Combine remaining decls with
+ ; decls extracted from the LET,
+ ; if any.
+ (setq otherdecls (nconc otherdecls other)))
+ (setq let-body (cond
+ (otherdecls
+ ; There are interesting
+ ; declarations, so have to keep
+ ; it wrapped.
+ `(let nil (declare ,@otherdecls)
+ ,@rest))
+ ((null (cdr rest))
+ ; Only one form left
+ (first rest))
+ (t `(progn ,@rest)))))
+ (unless (eq (setq let-body (iterate-transform-body let-body
+ iterate-env renamed-vars
+ (first gen-args)
+ finish-form bound-vars clause))
+ :abort)
+
+ ;; Skip the rest if transformation failed. Warning has
+ ;; already been issued.
+
+ ;; Note possible further optimization: if LET-BODY expanded
+ ;; into (prog1 oldvalue prepare-for-next-iteration), as so
+ ;; many do, then we could in most cases split the PROG1 into
+ ;; two pieces: do the (setq var oldvalue) here, and do the
+ ;; prepare-for-next-iteration at the bottom of the loop.
+ ;; This does a slight optimization of the PROG1 and also
+ ;; rearranges the code in a way that a reasonably clever
+ ;; compiler might detect how to get rid of redundant
+ ;; variables altogether (such as happens with INTERVAL and
+ ;; LIST-TAILS); that would make the whole thing closer to
+ ;; what you might have coded by hand. However, to do this
+ ;; optimization, we need to ensure that (a) the
+ ;; prepare-for-next-iteration refers freely to no vars other
+ ;; than the internal vars we have extracted from the LET, and
+ ;; (b) that the code has no side effects. These are both
+ ;; true for all the iterators defined by this module, but how
+ ;; shall we represent side-effect info and/or tap into the
+ ;; compiler's knowledge of same?
+ (when localdecls
+ ; There were declarations for
+ ; the generator locals--have to
+ ; keep them for later, and
+ ; rename the vars mentioned
+ (setq
+ generator-decls
+ (nconc
+ generator-decls
+ (mapcar
+ #'(lambda
+ (decl)
+ (let ((head (car decl)))
+ (cons head (if (eq head 'type)
+ (cons (second decl)
+ (sublis renamed-vars
+ (cddr decl)))
+ (sublis renamed-vars
+ (cdr decl))))))
+ localdecls)))))))
+
+ ;; Finished analyzing clause now. LET-BODY is the form which, when
+ ;; evaluated, returns updated values for the iteration variable(s)
+ ;; VARS.
+ (when (eq let-body :abort)
+
+ ;; Some punt case: go with the formal semantics: bind a var to
+ ;; the generator, then call it in the update section
+ (let
+ ((gvar (get-iterate-temp))
+ (generator (second clause)))
+ (setq
+ let-bindings
+ (list (list gvar
+ (cond
+ ;; FIXME: This conditional was here with this
+ ;; comment in old CMU CL PCL. Does Python really
+ ;; think it's unreachable?
+ ;;#-cmu ; Python thinks this is unreachable.
+ (leftover-body
+ ; Have to use this up
+ `(progn ,@(prog1 leftover-body (setq
+ leftover-body
+ nil))
+ generator))
+ (t generator)))))
+ (setq let-body `(funcall ,gvar #'(lambda nil ,finish-form)))))
+ (push (mv-setq (copy-list vars)
+ let-body)
+ update-forms)
+ (dolist (v vars)
+ (declare (ignore v))
+ ;; Pop off the vars we have now bound from the list of vars to
+ ;; watch out for -- we'll bind them right now.
+ (pop bound-vars))
+ (setq bindings
+ (nconc bindings let-bindings
+ (cond (extra-body
+ ;; There was some computation to do after the
+ ;; bindings--here's our chance.
+ (cons (list (first vars)
+ `(progn ,@extra-body nil))
+ (rest vars)))
+ (t vars))))))))))
+ (do ((tail body (cdr tail)))
+ ((not (and (consp tail)
+ (consp (car tail))
+ (eq (caar tail)
+ 'declare)))
+
+ ;; TAIL now points at first non-declaration. If there were
+ ;; declarations, pop them off so they appear in the right place
+ (unless (eq tail body)
+ (setq iterate-decls (ldiff body tail))
+ (setq body tail))))
+ `(block ,block-name
+ (let* ,bindings ,@(and generator-decls
+ `((declare ,@generator-decls)))
+ ,@iterate-decls
+ ,@leftover-body
+ (loop ,@(nreverse update-forms)
+ ,@body)))))
+
+(defun expand-into-let (clause parent-name env)
+
+ ;; Return values: Body, LET[*], bindings, localdecls, otherdecls, extra
+ ;; body, where BODY is a single form. If multiple forms in a LET, the
+ ;; preceding forms are returned as extra body. Returns :ABORT if it
+ ;; issued a punt warning.
+ (prog ((expansion clause)
+ expandedp binding-type let-bindings let-body)
+ expand
+ (multiple-value-setq (expansion expandedp)
+ (macroexpand-1 expansion env))
+ (cond ((not (consp expansion))
+ ; Shouldn't happen
+ )
+ ((symbolp (setq binding-type (first expansion)))
+ (case binding-type
+ ((let let*)
+ (setq let-bindings (second expansion))
+ ; List of variable bindings
+ (setq let-body (cddr expansion))
+ (go handle-let))))
+ ((and (consp binding-type)
+ (eq (car binding-type)
+ 'lambda)
+ (not (find-if #'(lambda (x)
+ (member x lambda-list-keywords)
+ )
+ (setq let-bindings (second binding-type)))
+ )
+ (eql (length (second expansion))
+ (length let-bindings))
+ (null (cddr expansion)))
+ ; A simple LAMBDA form can be
+ ; treated as LET
+ (setq let-body (cddr binding-type))
+ (setq let-bindings (mapcar #'list let-bindings (second
+ expansion))
+ )
+ (setq binding-type 'let)
+ (go handle-let)))
+
+ ;; Fall thru if not a LET
+ (cond (expandedp ; try expanding again
+ (go expand))
+ (t ; Boring--return form as the
+ ; body
+ (return expansion)))
+ handle-let
+ (return (let ((locals (variables-from-let let-bindings))
+ extra-body specials)
+ (multiple-value-bind (localdecls otherdecls let-body)
+ (parse-declarations let-body locals)
+ (cond ((setq specials (extract-special-bindings
+ locals localdecls))
+ (maybe-warn (cond ((find-if #'variable-globally-special-p
+ specials)
+ ; This could be the fault of a
+ ; user proclamation.
+ :user)
+ (t :definition))
+
+ "Couldn't optimize ~S because expansion of ~S binds specials ~(~S ~)"
+ parent-name clause specials)
+ :abort)
+ (t (values (cond ((not (consp let-body))
+
+ ; Null body of LET? unlikely,
+ ; but someone else will likely
+ ; complain
+ nil)
+ ((null (cdr let-body))
+
+ ; A single expression, which we
+ ; hope is (function
+ ; (lambda...))
+ (first let-body))
+ (t
+
+ ;; More than one expression. These are forms to
+ ;; evaluate after the bindings but before the
+ ;; generator form is returned. Save them to
+ ;; evaluate in the next convenient place. Note that
+ ;; this is ok, as there is no construct that can
+ ;; cause a LET to return prematurely (without
+ ;; returning also from some surrounding construct).
+ (setq extra-body
+ (butlast let-body))
+ (car (last let-body))))
+ binding-type let-bindings localdecls
+ otherdecls extra-body))))))))
+
+(defun variables-from-let (bindings)
+
+ ;; Return a list of the variables bound in the first argument to LET[*].
+ (mapcar #'(lambda (binding)
+ (if (consp binding)
+ (first binding)
+ binding))
+ bindings))
+
+(defun iterate-transform-body (let-body iterate-env renamed-vars finish-arg
+ finish-form bound-vars clause)
+
+;;; This is the second major transformation for a single iterate clause.
+;;; LET-BODY is the body of the iterator after we have extracted its local
+;;; variables and declarations. We have two main tasks: (1) Substitute
+;;; internal temporaries for occurrences of the LET variables; the alist
+;;; RENAMED-VARS specifies this transformation. (2) Substitute evaluation of
+;;; FINISH-FORM for any occurrence of (funcall FINISH-ARG). Along the way, we
+;;; check for forms that would invalidate these transformations: occurrence of
+;;; FINISH-ARG outside of a funcall, and free reference to any element of
+;;; BOUND-VARS. CLAUSE & TYPE are the original ITERATE clause and its type
+;;; (ITERATE or ITERATE*), for purpose of error messages. On success, we
+;;; return the transformed body; on failure, :ABORT.
+
+ (walk-form let-body iterate-env
+ #'(lambda (form context env)
+ (declare (ignore context))
+
+ ;; Need to substitute RENAMED-VARS, as well as turn
+ ;; (FUNCALL finish-arg) into the finish form
+ (cond ((symbolp form)
+ (let (renaming)
+ (cond ((and (eq form finish-arg)
+ (variable-same-p form env
+ iterate-env))
+ ; An occurrence of the finish
+ ; arg outside of FUNCALL
+ ; context--I can't handle this
+ (maybe-warn :definition "Couldn't optimize iterate form because generator ~S does something with its FINISH arg besides FUNCALL it."
+ (second clause))
+ (return-from iterate-transform-body
+ :abort))
+ ((and (setq renaming (assoc form
+ renamed-vars
+ ))
+ (variable-same-p form env
+ iterate-env))
+ ; Reference to one of the vars
+ ; we're renaming
+ (cdr renaming))
+ ((and (member form bound-vars)
+ (variable-same-p form env
+ iterate-env))
+ ; FORM is a var that is bound
+ ; in this same ITERATE, or
+ ; bound later in this ITERATE*.
+ ; This is a conflict.
+ (maybe-warn :user "Couldn't optimize iterate form because generator ~S is closed over ~S, in conflict with a subsequent iteration variable."
+ (second clause)
+ form)
+ (return-from iterate-transform-body
+ :abort))
+ (t form))))
+ ((and (consp form)
+ (eq (first form)
+ 'funcall)
+ (eq (second form)
+ finish-arg)
+ (variable-same-p (second form)
+ env iterate-env))
+ ; (FUNCALL finish-arg) =>
+ ; finish-form
+ (unless (null (cddr form))
+ (maybe-warn :definition
+ "Generator for ~S applied its finish arg to > 0 arguments ~S--ignored."
+ (second clause)
+ (cddr form)))
+ finish-form)
+ (t form)))))
+
+(defun
+ parse-declarations
+ (tail locals)
+
+ ;; Extract the declarations from the head of TAIL and divide them into 2
+ ;; classes: declares about variables in the list LOCALS, and all other
+ ;; declarations. Returns 3 values: those 2 lists plus the remainder of TAIL.
+ (let
+ (localdecls otherdecls form)
+ (loop
+ (unless (and tail (consp (setq form (car tail)))
+ (eq (car form)
+ 'declare))
+ (return (values localdecls otherdecls tail)))
+ (mapc
+ #'(lambda
+ (decl)
+ (case (first decl)
+ ((inline notinline optimize)
+ ; These don't talk about vars
+ (push decl otherdecls))
+ (t ; Assume all other kinds are
+ ; for vars
+ (let* ((vars (if (eq (first decl)
+ 'type)
+ (cddr decl)
+ (cdr decl)))
+ (l (intersection locals vars))
+ other)
+ (cond
+ ((null l)
+ ; None talk about LOCALS
+ (push decl otherdecls))
+ ((null (setq other (set-difference vars l)))
+ ; All talk about LOCALS
+ (push decl localdecls))
+ (t ; Some of each
+ (let ((head (cons 'type (and (eq (first decl)
+ 'type)
+ (list (second decl))))))
+ (push (append head other)
+ otherdecls)
+ (push (append head l)
+ localdecls))))))))
+ (cdr form))
+ (pop tail))))
+
+(defun extract-special-bindings (vars decls)
+
+ ;; Return the subset of VARS that are special, either globally or
+ ;; because of a declaration in DECLS
+ (let ((specials (remove-if-not #'variable-globally-special-p vars)))
+ (dolist (d decls)
+ (when (eq (car d)
+ 'special)
+ (setq specials (union specials (intersection vars
+ (cdr d))))))
+ specials))
+
+(defun function-lambda-p (form &optional nargs)
+
+ ;; If FORM is #'(LAMBDA bindings . body) and bindings is of length
+ ;; NARGS, return the lambda expression
+ (let (args body)
+ (and (consp form)
+ (eq (car form)
+ 'function)
+ (consp (setq form (cdr form)))
+ (null (cdr form))
+ (consp (setq form (car form)))
+ (eq (car form)
+ 'lambda)
+ (consp (setq body (cdr form)))
+ (listp (setq args (car body)))
+ (or (null nargs)
+ (eql (length args)
+ nargs))
+ form)))
+
+(defun
+ rename-let-bindings
+ (let-bindings binding-type env leftover-body &optional tempvarfn)
+
+ ;; Perform the alpha conversion required for "LET eversion" of
+ ;; (LET[*] LET-BINDINGS . body)--rename each of the variables to an
+ ;; internal name. Returns 2 values: a new set of LET bindings and the
+ ;; alist of old var names to new (so caller can walk the body doing
+ ;; the rest of the renaming). BINDING-TYPE is one of LET or LET*.
+ ;; LEFTOVER-BODY is optional list of forms that must be eval'ed
+ ;; before the first binding happens. ENV is the macro expansion
+ ;; environment, in case we have to walk a LET*. TEMPVARFN is a
+ ;; function of no args to return a temporary var; if omitted, we use
+ ;; GENSYM.
+ (let
+ (renamed-vars)
+ (values (mapcar #'(lambda (binding)
+ (let ((valueform (cond ((not (consp binding))
+
+ ; No initial value
+ nil)
+ ((or (eq binding-type
+ 'let)
+ (null renamed-vars))
+
+ ; All bindings are in parallel,
+ ; so none can refer to others
+ (second binding))
+ (t
+ ; In a LET*, have to substitute
+ ; vars in the 2nd and
+ ; subsequent initialization
+ ; forms
+ (rename-variables
+ (second binding)
+ renamed-vars env))))
+ (newvar (if tempvarfn
+ (funcall tempvarfn)
+ (gensym))))
+ (push (cons (if (consp binding)
+ (first binding)
+ binding)
+ newvar)
+ renamed-vars)
+ ; Add new variable to the list
+ ; AFTER we have walked the
+ ; initial value form
+ (when leftover-body
+ ;; Previous clause had some computation to do
+ ;; after its bindings. Here is the first
+ ;; opportunity to do it
+ (setq valueform `(progn ,@leftover-body
+ ,valueform))
+ (setq leftover-body nil))
+ (list newvar valueform)))
+ let-bindings)
+ renamed-vars)))
+
+(defun rename-variables (form alist env)
+
+ ;; Walks FORM, renaming occurrences of the key variables in ALIST with
+ ;; their corresponding values. ENV is FORM's environment, so we can
+ ;; make sure we are talking about the same variables.
+ (walk-form form env
+ #'(lambda (form context subenv)
+ (declare (ignore context))
+ (let (pair)
+ (cond ((and (symbolp form)
+ (setq pair (assoc form alist))
+ (variable-same-p form subenv env))
+ (cdr pair))
+ (t form))))))
+
+(defun
+ mv-setq
+ (vars expr)
+
+ ;; Produces (MULTIPLE-VALUE-SETQ vars expr), except that I'll optimize some
+ ;; of the simple cases for benefit of compilers that don't, and I don't care
+ ;; what the value is, and I know that the variables need not be set in
+ ;; parallel, since they can't be used free in EXPR
+ (cond
+ ((null vars)
+ ; EXPR is a side-effect
+ expr)
+ ((not (consp vars))
+ ; This is an error, but I'll
+ ; let MULTIPLE-VALUE-SETQ
+ ; report it
+ `(multiple-value-setq ,vars ,expr))
+ ((and (listp expr)
+ (eq (car expr)
+ 'values))
+
+ ;; (mv-setq (a b c) (values x y z)) can be reduced to a parallel setq
+ ;; (psetq returns nil, but I don't care about returned value). Do this
+ ;; even for the single variable case so that we catch (mv-setq (a) (values
+ ;; x y))
+ (pop expr)
+ ; VALUES
+ `(setq ,@(mapcon #'(lambda (tail)
+ (list (car tail)
+ (cond ((or (cdr tail)
+ (null (cdr expr)))
+ ; One result expression for
+ ; this var
+ (pop expr))
+ (t ; More expressions than vars,
+ ; so arrange to evaluate all
+ ; the rest now.
+ (cons 'prog1 expr)))))
+ vars)))
+ ((null (cdr vars))
+ ; Simple one variable case
+ `(setq ,(car vars)
+ ,expr))
+ (t ; General case--I know nothing
+ `(multiple-value-setq ,vars ,expr))))
+
+(defun variable-same-p (var env1 env2)
+ (eq (variable-lexical-p var env1)
+ (variable-lexical-p var env2)))
+
+(defun maybe-warn (type &rest warn-args)
+
+ ;; Issue a warning about not being able to optimize this thing. TYPE
+ ;; is one of :DEFINITION, meaning the definition is at fault, and
+ ;; :USER, meaning the user's code is at fault.
+ (when (case *iterate-warnings*
+ ((nil) nil)
+ ((:user) (eq type :user))
+ (t t))
+ (apply #'warn warn-args)))
+
+;;; sample iterators
+;;;
+;;; FIXME: If they're only samples, can they be commented out?
+
+(defmacro
+ interval
+ (&whole whole &key from downfrom to downto above below by type)
+ (cond
+ ((and from downfrom)
+ (error "Can't use both FROM and DOWNFROM in ~S" whole))
+ ((cdr (remove nil (list to downto above below)))
+ (error "Can't use more than one limit keyword in ~S" whole))
+ (t
+ (let*
+ ((down (or downfrom downto above))
+ (limit (or to downto above below))
+ (inc (cond ((null by)
+ 1)
+ ((constantp by)
+ ; Can inline this increment
+ by))))
+ `(let
+ ((from ,(or from downfrom 0))
+ ,@(and limit `((to ,limit)))
+ ,@(and (null inc)
+ `((by ,by))))
+ ,@(and type `((declare (type ,type from ,@(and limit '(to))
+ ,@(and (null inc)
+ `(by))))))
+ #'(lambda
+ (finish)
+ ,@(cond ((null limit)
+ ; We won't use the FINISH arg.
+ '((declare (ignore finish)))))
+ (prog1 ,(cond (limit ; Test the limit. If ok,
+ ; return current value and
+ ; increment, else quit
+ `(if (,(cond (above '>)
+ (below '<)
+ (down '>=)
+ (t '<=))
+ from to)
+ from
+ (funcall finish)))
+ (t ; No test
+ 'from))
+ (setq from (,(if down
+ '-
+ '+)
+ from
+ ,(or inc 'by))))))))))
+
+(defmacro list-elements (list &key (by '#'cdr))
+ `(let ((tail ,list))
+ #'(lambda (finish)
+ (prog1 (if (endp tail)
+ (funcall finish)
+ (first tail))
+ (setq tail (funcall ,by tail))))))
+
+(defmacro list-tails (list &key (by '#'cdr))
+ `(let ((tail ,list))
+ #'(lambda (finish)
+ (prog1 (if (endp tail)
+ (funcall finish)
+ tail)
+ (setq tail (funcall ,by tail))))))
+
+(defmacro
+ elements
+ (sequence)
+ "Generates successive elements of SEQUENCE, with second value being the index. Use (ELEMENTS (THE type arg)) if you care about the type."
+ (let*
+ ((type (and (consp sequence)
+ (eq (first sequence)
+ 'the)
+ (second sequence)))
+ (accessor (if type
+ (sequence-accessor type)
+ 'elt))
+ (listp (eq type 'list)))
+
+ ;; If type is given via THE, we may be able to generate a good accessor here
+ ;; for the benefit of implementations that aren't smart about (ELT (THE
+ ;; STRING FOO)). I'm not bothering to keep the THE inside the body,
+ ;; however, since I assume any compiler that would understand (AREF (THE
+ ;; SIMPLE-ARRAY S)) would also understand that (AREF S) is the same when I
+ ;; bound S to (THE SIMPLE-ARRAY foo) and never modified it.
+
+ ;; If sequence is declared to be a list, it's better to cdr down it, so we
+ ;; have some extra cases here. Normally folks would write LIST-ELEMENTS,
+ ;; but maybe they wanted to get the index for free...
+ `(let* ((index 0)
+ (s ,sequence)
+ ,@(and (not listp)
+ '((size (length s)))))
+ #'(lambda (finish)
+ (values (cond ,(if listp
+ '((not (endp s))
+ (pop s))
+ `((< index size)
+ (,accessor s index)))
+ (t (funcall finish)))
+ (prog1 index
+ (setq index (1+ index))))))))
+
+(defmacro
+ plist-elements
+ (plist)
+ "Generates each time 2 items, the indicator and the value."
+ `(let ((tail ,plist))
+ #'(lambda (finish)
+ (values (if (endp tail)
+ (funcall finish)
+ (first tail))
+ (prog1 (if (endp (setq tail (cdr tail)))
+ (funcall finish)
+ (first tail))
+ (setq tail (cdr tail)))))))
+
+(defun sequence-accessor (type)
+
+ ;; returns the function with which most efficiently to make accesses to
+ ;; a sequence of type TYPE.
+ (case (if (consp type)
+ ; e.g., (VECTOR FLOAT *)
+ (car type)
+ type)
+ ((array simple-array vector) 'aref)
+ (simple-vector 'svref)
+ (string 'char)
+ (simple-string 'schar)
+ (bit-vector 'bit)
+ (simple-bit-vector 'sbit)
+ (t 'elt)))
+
+;; These "iterators" may be withdrawn
+
+(defmacro eachtime (expr)
+ `#'(lambda (finish)
+ (declare (ignore finish))
+ ,expr))
+
+(defmacro while (expr)
+ `#'(lambda (finish)
+ (unless ,expr (funcall finish))))
+
+(defmacro until (expr)
+ `#'(lambda (finish)
+ (when ,expr (funcall finish))))
+
+ ; GATHERING macro
+
+(defmacro gathering (clauses &body body &environment env)
+ (or (optimize-gathering-form clauses body env)
+ (simple-expand-gathering-form clauses body env)))
+
+(defmacro with-gathering (clauses gather-body &body use-body)
+ "Binds the variables specified in CLAUSES to the result of (GATHERING clauses gather-body) and evaluates the forms in USE-BODY inside that contour."
+
+ ;; We may optimize this a little better later for those compilers that
+ ;; don't do a good job on (m-v-bind vars (... (values ...)) ...).
+ `(multiple-value-bind ,(mapcar #'car clauses)
+ (gathering ,clauses ,gather-body)
+ ,@use-body))
+
+(defun
+ simple-expand-gathering-form
+ (clauses body env)
+ (declare (ignore env))
+
+ ;; The "formal semantics" of GATHERING. We use this only in cases that can't
+ ;; be optimized.
+ (let
+ ((acc-names (mapcar #'first (if (symbolp clauses)
+ ; Shorthand using anonymous
+ ; gathering site
+ (setq clauses `((*anonymous-gathering-site*
+ (,clauses))))
+ clauses)))
+ (realizer-names (mapcar #'(lambda (binding)
+ (declare (ignore binding))
+ (gensym))
+ clauses)))
+ `(multiple-value-call
+ #'(lambda
+ ,(mapcan #'list acc-names realizer-names)
+ (flet ((gather (value &optional (accumulator *anonymous-gathering-site*)
+ )
+ (funcall accumulator value)))
+ ,@body
+ (values ,@(mapcar #'(lambda (rname)
+ `(funcall ,rname))
+ realizer-names))))
+ ,@(mapcar #'second clauses))))
+
+(defvar *active-gatherers* nil
+ "List of GATHERING bindings currently active during macro expansion)")
+
+(defvar *anonymous-gathering-site* nil "Variable used in formal expansion of an abbreviated GATHERING form (one with anonymous gathering site).")
+
+(defun optimize-gathering-form (clauses body gathering-env)
+ (let*
+ (acc-info leftover-body top-bindings finish-forms top-decls)
+ (dolist (clause (if (symbolp clauses)
+ ; a shorthand
+ `((*anonymous-gathering-site* (,clauses)))
+ clauses))
+ (multiple-value-bind
+ (let-body binding-type let-bindings localdecls otherdecls extra-body)
+ (expand-into-let (second clause)
+ 'gathering gathering-env)
+ (prog*
+ ((acc-var (first clause))
+ renamed-vars accumulator realizer)
+ (when (and (consp let-body)
+ (eq (car let-body)
+ 'values)
+ (consp (setq let-body (cdr let-body)))
+ (setq accumulator (function-lambda-p (car let-body)))
+ (consp (setq let-body (cdr let-body)))
+ (setq realizer (function-lambda-p (car let-body)
+ 0))
+ (null (cdr let-body)))
+
+ ;; Macro returned something of the form
+ ;; (VALUES #'(lambda (value) ...)
+ ;; #'(lambda () ...)),
+ ;; a function to accumulate values and a function to realize the
+ ;; result.
+ (when binding-type
+
+ ;; Gatherer expanded into a LET
+ (cond (otherdecls (maybe-warn :definition "Couldn't optimize GATHERING clause ~S because its expansion carries declarations about more than the bound variables: ~S"
+ (second clause)
+ `(declare ,@otherdecls))
+ (go punt)))
+ (when let-bindings
+
+ ;; The first transformation we want to perform is a
+ ;; variant of "LET-eversion": turn
+ ;; (mv-bind
+ ;; (acc real)
+ ;; (let (..bindings..)
+ ;; (values #'(lambda ...)
+ ;; #'(lambda ...)))
+ ;; ..body..)
+ ;; into
+ ;; (let* (..bindings..
+ ;; (acc #'(lambda ...))
+ ;; (real #'(lambda ...)))
+ ;; ..body..).
+ ;; This transformation is valid if nothing in body refers
+ ;; to any of the bindings, something we can ensure by
+ ;; alpha-converting the inner let (substituting new names
+ ;; for each var). Of course, none of those vars can be
+ ;; special, but we already checked for that above.
+ (multiple-value-setq (let-bindings renamed-vars)
+ (rename-let-bindings let-bindings binding-type
+ gathering-env leftover-body))
+ (setq top-bindings (nconc top-bindings let-bindings))
+ (setq leftover-body nil)
+ ; If there was any leftover
+ ; from previous, it is now
+ ; consumed
+ ))
+ (setq leftover-body (nconc leftover-body extra-body))
+ ; Computation to do after these
+ ; bindings
+ (push (cons acc-var (rename-and-capture-variables accumulator
+ renamed-vars gathering-env))
+ acc-info)
+ (setq realizer (rename-variables realizer renamed-vars
+ gathering-env))
+ (push (cond ((null (cdddr realizer))
+ ; Simple (LAMBDA () expr) =>
+ ; expr
+ (third realizer))
+ (t ; There could be declarations
+ ; or something, so leave as a
+ ; LET
+ (cons 'let (cdr realizer))))
+ finish-forms)
+ (unless (null localdecls)
+ ; Declarations about the LET
+ ; variables also has to
+ ; percolate up
+ (setq top-decls (nconc top-decls (sublis renamed-vars
+ localdecls))))
+ (return))
+ (maybe-warn :definition "Couldn't optimize GATHERING clause ~S because its expansion is not of the form (VALUES #'(LAMBDA ...) #'(LAMBDA () ...))"
+ (second clause))
+ punt
+ (let
+ ((gs (gensym))
+ (expansion `(multiple-value-list ,(second clause))))
+ ; Slow way--bind gensym to the
+ ; macro expansion, and we will
+ ; funcall it in the body
+ (push (list acc-var gs)
+ acc-info)
+ (push `(funcall (cadr ,gs))
+ finish-forms)
+ (setq
+ top-bindings
+ (nconc
+ top-bindings
+ (list (list gs (cond (leftover-body
+ `(progn ,@(prog1 leftover-body
+ (setq leftover-body nil))
+ ,expansion))
+ (t expansion))))))))))
+ (setq body (walk-gathering-body body gathering-env acc-info))
+ (cond ((eq body :abort)
+ ; Couldn't finish expansion
+ nil)
+ (t `(let* ,top-bindings
+ ,@(and top-decls `((declare ,@top-decls)))
+ ,body
+ ,(cond ((null (cdr finish-forms))
+ ; just a single value
+ (car finish-forms))
+ (t `(values ,@(reverse finish-forms)))))))))
+
+(defun rename-and-capture-variables (form alist env)
+
+ ;; Walks FORM, renaming occurrences of the key variables in ALIST with
+ ;; their corresponding values, and capturing any other free variables.
+ ;; Returns a list of the new form and the list of other closed-over
+ ;; vars. ENV is FORM's environment, so we can make sure we are talking
+ ;; about the same variables.
+ (let (closed)
+ (list (walk-form
+ form env
+ #'(lambda (form context subenv)
+ (declare (ignore context))
+ (let (pair)
+ (cond ((or (not (symbolp form))
+ (not (variable-same-p form subenv
+ env)))
+ ; non-variable or one that has
+ ; been rebound
+ form)
+ ((setq pair (assoc form alist))
+ ; One to rename
+ (cdr pair))
+ (t ; var is free
+ (pushnew form closed)
+ form)))))
+ closed)))
+
+(defun
+ walk-gathering-body
+ (body gathering-env acc-info)
+
+ ;; Walk the body of (GATHERING (...) . BODY) in environment GATHERING-ENV.
+ ;; ACC-INFO is a list of information about each of the gathering "bindings"
+ ;; in the form, in the form (var gatheringfn freevars env)
+ (let
+ ((*active-gatherers* (nconc (mapcar #'car acc-info)
+ *active-gatherers*)))
+
+ ;; *ACTIVE-GATHERERS* tells us what vars are currently legal as GATHER
+ ;; targets. This is so that when we encounter a GATHER not belonging to us
+ ;; we can know whether to warn about it.
+ (walk-form
+ (cons 'progn body)
+ gathering-env
+ #'(lambda
+ (form context env)
+ (declare (ignore context))
+ (let (info site)
+ (cond ((consp form)
+ (cond
+ ((not (eq (car form)
+ 'gather))
+ ; We only care about GATHER
+ (when (and (eq (car form)
+ 'function)
+ (eq (cadr form)
+ 'gather))
+ ; Passed as functional--can't
+ ; macroexpand
+ (maybe-warn :user
+ "Can't optimize GATHERING because of reference to #'GATHER."
+ )
+ (return-from walk-gathering-body :abort))
+ form)
+ ((setq info (assoc (setq site (if (null (cddr form))
+
+ '
+ *anonymous-gathering-site*
+ (third form)))
+ acc-info))
+ ; One of ours--expand (GATHER
+ ; value var). INFO = (var
+ ; gatheringfn freevars env)
+ (unless (null (cdddr form))
+ (warn "Extra arguments (> 2) in ~S discarded." form)
+ )
+ (let ((fn (second info)))
+ (cond ((symbolp fn)
+ ; Unoptimized case--just call
+ ; the gatherer. FN is the
+ ; gensym that we bound to the
+ ; list of two values returned
+ ; from the gatherer.
+ `(funcall (car ,fn)
+ ,(second form)))
+ (t ; FN = (lambda (value) ...)
+ (dolist (s (third info))
+ (unless (or (variable-same-p s env
+ gathering-env)
+ (and (variable-special-p
+ s env)
+ (variable-special-p
+ s gathering-env)))
+
+ ;; Some var used free in the LAMBDA form has been
+ ;; rebound between here and the parent GATHERING
+ ;; form, so can't substitute the lambda. Ok if it's
+ ;; a special reference both here and in the LAMBDA,
+ ;; because then it's not closed over.
+ (maybe-warn :user "Can't optimize GATHERING because the expansion closes over the variable ~S, which is rebound around a GATHER for it."
+ s)
+ (return-from walk-gathering-body
+ :abort)))
+
+ ;; Return ((lambda (value) ...) actual-value). In
+ ;; many cases we could simplify this further by
+ ;; substitution, but we'd have to be careful (for
+ ;; example, we would need to alpha-convert any LET
+ ;; we found inside). Any decent compiler will do it
+ ;; for us.
+ (list fn (second form))))))
+ ((and (setq info (member site *active-gatherers*))
+ (or (eq site '*anonymous-gathering-site*)
+ (variable-same-p site env (fourth info))))
+ ; Some other GATHERING will
+ ; take care of this form, so
+ ; pass it up for now.
+ ; Environment check is to make
+ ; sure nobody shadowed it
+ ; between here and there
+ form)
+ (t ; Nobody's going to handle it
+ (if (eq site '*anonymous-gathering-site*)
+ ; More likely that she forgot
+ ; to mention the site than
+ ; forget to write an anonymous
+ ; gathering.
+ (warn "There is no gathering site specified in ~S."
+ form)
+ (warn
+ "The site ~S in ~S is not defined in an enclosing GATHERING form."
+ site form))
+ ; Turn it into something else
+ ; so we don't warn twice in the
+ ; nested case
+ `(%orphaned-gather ,@(cdr form)))))
+ ((and (symbolp form)
+ (setq info (assoc form acc-info))
+ (variable-same-p form env gathering-env))
+ ; A variable reference to a
+ ; gather binding from
+ ; environment TEM
+ (maybe-warn :user "Can't optimize GATHERING because site variable ~S is used outside of a GATHER form."
+ form)
+ (return-from walk-gathering-body :abort))
+ (t form)))))))
+
+;; sample gatherers
+;;
+;; FIXME: If these are only samples, can we delete them?
+
+(defmacro
+ collecting
+ (&key initial-value)
+ `(let* ((head ,initial-value)
+ (tail ,(and initial-value `(last head))))
+ (values #'(lambda (value)
+ (if (null head)
+ (setq head (setq tail (list value)))
+ (setq tail (cdr (rplacd tail (list value))))))
+ #'(lambda nil head))))
+
+(defmacro joining (&key initial-value)
+ `(let ((result ,initial-value))
+ (values #'(lambda (value)
+ (setq result (nconc result value)))
+ #'(lambda nil result))))
+
+(defmacro
+ maximizing
+ (&key initial-value)
+ `(let ((result ,initial-value))
+ (values
+ #'(lambda (value)
+ (when ,(cond ((and (constantp initial-value)
+ (not (null (eval initial-value))))
+ ; Initial value is given and we
+ ; know it's not NIL, so leave
+ ; out the null check
+ '(> value result))
+ (t '(or (null result)
+ (> value result))))
+ (setq result value)))
+ #'(lambda nil result))))
+
+(defmacro
+ minimizing
+ (&key initial-value)
+ `(let ((result ,initial-value))
+ (values
+ #'(lambda (value)
+ (when ,(cond ((and (constantp initial-value)
+ (not (null (eval initial-value))))
+ ; Initial value is given and we
+ ; know it's not NIL, so leave
+ ; out the null check
+ '(< value result))
+ (t '(or (null result)
+ (< value result))))
+ (setq result value)))
+ #'(lambda nil result))))
+
+(defmacro summing (&key (initial-value 0))
+ `(let ((sum ,initial-value))
+ (values #'(lambda (value)
+ (setq sum (+ sum value)))
+ #'(lambda nil sum))))
+
+;;; It's easier to read expanded code if PROG1 gets left alone.
+(define-walker-template prog1 (nil return sb-walker::repeat (eval)))
--- /dev/null
+;;;; This file contains portable versions of low-level functions and macros
+;;;; which are ripe for implementation specific customization. None of the code
+;;;; in this file *has* to be customized for a particular Common Lisp
+;;;; implementation. Moreover, in some implementations it may not make any
+;;;; sense to customize some of this code.
+;;;;
+;;;; The original version was intended to support portable customization to
+;;;; lotso different Lisp implementations. This functionality is gone in the
+;;;; current version, and it now runs only under SBCL. (Now that ANSI Common
+;;;; Lisp has mixed CLOS into the insides of the system (e.g. error handling
+;;;; and printing) so deeply that it's not very meaningful to bootstrap Common
+;;;; Lisp without CLOS, the old functionality is of dubious use. -- WHN
+;;;; 19981108)
+
+;;;; This software is part of the SBCL system. See the README file for more
+;;;; information.
+
+;;;; This software is derived from software originally released by Xerox
+;;;; Corporation. Copyright and release statements follow. Later modifications
+;;;; to the software are in the public domain and are provided with
+;;;; absolutely no warranty. See the COPYING and CREDITS files for more
+;;;; information.
+
+;;;; copyright information from original PCL sources:
+;;;;
+;;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
+;;;; All rights reserved.
+;;;;
+;;;; Use and copying of this software and preparation of derivative works based
+;;;; upon this software are permitted. Any distribution of this software or
+;;;; derivative works must comply with all applicable United States export
+;;;; control laws.
+;;;;
+;;;; This software is made available AS IS, and Xerox Corporation makes no
+;;;; warranty about the software, its performance or its conformity to any
+;;;; specification.
+
+(in-package "SB-PCL")
+
+(sb-int:file-comment
+ "$Header$")
+\f
+(eval-when (:compile-toplevel :load-toplevel :execute)
+(defvar *optimize-speed* '(optimize (speed 3) (safety 0)))
+) ; EVAL-WHEN
+
+;;; FIXME: Do these definitions actually increase speed significantly?
+;;; Could we just use SVREF instead, possibly with a few extra
+;;; OPTIMIZE declarations added here and ther?
+(defmacro %svref (vector index)
+ `(locally (declare #.*optimize-speed*
+ (inline svref))
+ (svref (the simple-vector ,vector) (the fixnum ,index))))
+(defsetf %svref %set-svref)
+(defmacro %set-svref (vector index new-value)
+ `(locally (declare #.*optimize-speed*
+ (inline svref))
+ (setf (svref (the simple-vector ,vector) (the fixnum ,index))
+ ,new-value)))
+
+;;; I want the body to be evaluated in such a way that no other code that is
+;;; running PCL can be run during that evaluation. I agree that the body
+;;; won't take *long* to evaluate. That is to say that I will only use
+;;; WITHOUT-INTERRUPTS around relatively small computations.
+;;;
+;;; FIXME: We can get rid of this macro definitionand either USE package %SYS
+;;; or add an explicit SB-SYS: prefix to each reference to WITHOUT-INTERRUPTS.
+(defmacro without-interrupts (&rest stuff)
+ `(sb-sys:without-interrupts ,@stuff))
+
+(defmacro dotimes-fixnum ((var count &optional (result nil)) &body body)
+ `(dotimes (,var (the fixnum ,count) ,result)
+ (declare (fixnum ,var))
+ ,@body))
+\f
+;;;; very low-level representation of instances with meta-class
+;;;; STANDARD-CLASS
+
+;;; FIXME: more than one IN-PACKAGE in a source file, ick
+(in-package "SB-C")
+
+(defknown sb-pcl::pcl-instance-p (t) boolean
+ (movable foldable flushable explicit-check))
+
+(deftransform sb-pcl::pcl-instance-p ((object))
+ (let* ((otype (continuation-type object))
+ (std-obj (specifier-type 'sb-pcl::std-object)))
+ (cond
+ ;; Flush tests whose result is known at compile time.
+ ((csubtypep otype std-obj) 't)
+ ((not (types-intersect otype std-obj)) 'nil)
+ (t
+ `(typep (sb-kernel:layout-of object) 'sb-pcl::wrapper)))))
+
+(in-package "SB-PCL")
+
+;;; FIXME: What do these do? Could we use SB-KERNEL:INSTANCE-REF instead?
+(defmacro %instance-ref (slots index)
+ `(%svref ,slots ,index))
+(defmacro instance-ref (slots index)
+ `(svref ,slots ,index))
+
+;;; Note on implementation under CMU CL >=17 and SBCL: STD-INSTANCE-P is
+;;; only used to discriminate between functions (including FINs) and
+;;; normal instances, so we can return true on structures also. A few
+;;; uses of (or std-instance-p fsc-instance-p) are changed to
+;;; pcl-instance-p.
+(defmacro std-instance-p (x)
+ `(sb-kernel:%instancep ,x))
+
+(defmacro get-slots (inst)
+ `(cond ((std-instance-p ,inst) (std-instance-slots ,inst))
+ ((fsc-instance-p ,inst) (fsc-instance-slots ,inst))
+ (t (error "What kind of instance is this?"))))
+
+;; a temporary definition used for debugging the bootstrap
+#+sb-show
+(defun print-std-instance (instance stream depth)
+ (declare (ignore depth))
+ (print-unreadable-object (instance stream :type t :identity t)
+ (let ((class (class-of instance)))
+ (when (or (eq class (find-class 'standard-class nil))
+ (eq class (find-class 'funcallable-standard-class nil))
+ (eq class (find-class 'built-in-class nil)))
+ (princ (early-class-name instance) stream)))))
+
+;;; This is the value that we stick into a slot to tell us that it is unbound.
+;;; It may seem gross, but for performance reasons, we make this an interned
+;;; symbol. That means that the fast check to see whether a slot is unbound is
+;;; to say (EQ <val> '..SLOT-UNBOUND..). That is considerably faster than
+;;; looking at the value of a special variable. Be careful, there are places in
+;;; the code which actually use ..slot-unbound.. rather than this variable. So
+;;; much for modularity..
+;;;
+;;; FIXME: Now that we're tightly integrated into SBCL, we could use the
+;;; SBCL built-in unbound value token instead.
+(defconstant *slot-unbound* '..slot-unbound..)
+
+(defmacro %allocate-static-slot-storage--class (no-of-slots)
+ `(make-array ,no-of-slots :initial-element *slot-unbound*))
+
+(defmacro std-instance-class (instance)
+ `(wrapper-class* (std-instance-wrapper ,instance)))
+\f
+;;;; FUNCTION-ARGLIST
+
+;;; FIXME: Does FUNCTION-PRETTY-ARGLIST need to be settable at all?
+(defsetf function-pretty-arglist set-function-pretty-arglist)
+(defun set-function-pretty-arglist (function new-value)
+ (declare (ignore function))
+ new-value)
+
+;;; SET-FUNCTION-NAME
+;;;
+;;; When given a function should give this function the name <new-name>.
+;;; Note that <new-name> is sometimes a list. Some lisps get the upset
+;;; in the tummy when they start thinking about functions which have
+;;; lists as names. To deal with that there is set-function-name-intern
+;;; which takes a list spec for a function name and turns it into a symbol
+;;; if need be.
+;;;
+;;; When given a funcallable instance, set-function-name MUST side-effect
+;;; that FIN to give it the name. When given any other kind of function
+;;; set-function-name is allowed to return new function which is the 'same'
+;;; except that it has the name.
+;;;
+;;; In all cases, set-function-name must return the new (or same) function.
+;;; (Unlike other functions to set stuff, it does not return the new value.)
+(defun set-function-name (fcn new-name)
+ #+sb-doc
+ "Set the name of a compiled function object. Return the function."
+ (declare (special *boot-state* *the-class-standard-generic-function*))
+ (cond ((symbolp fcn)
+ (set-function-name (symbol-function fcn) new-name))
+ ((funcallable-instance-p fcn)
+ (if (if (eq *boot-state* 'complete)
+ (typep fcn 'generic-function)
+ (eq (class-of fcn) *the-class-standard-generic-function*))
+ (setf (sb-kernel:%funcallable-instance-info fcn 1) new-name)
+ (typecase fcn
+ (sb-kernel:byte-closure
+ (set-function-name (sb-kernel:byte-closure-function fcn)
+ new-name))
+ (sb-kernel:byte-function
+ (setf (sb-kernel:byte-function-name fcn) new-name))
+ (sb-eval:interpreted-function
+ (setf (sb-eval:interpreted-function-name fcn) new-name))))
+ fcn)
+ (t
+ ;; pw-- This seems wrong and causes trouble. Tests show
+ ;; that loading CL-HTTP resulted in ~5400 closures being
+ ;; passed through this code of which ~4000 of them pointed
+ ;; to but 16 closure-functions, including 1015 each of
+ ;; DEFUN MAKE-OPTIMIZED-STD-WRITER-METHOD-FUNCTION
+ ;; DEFUN MAKE-OPTIMIZED-STD-READER-METHOD-FUNCTION
+ ;; DEFUN MAKE-OPTIMIZED-STD-BOUNDP-METHOD-FUNCTION.
+ ;; Since the actual functions have been moved by PURIFY
+ ;; to memory not seen by GC, changing a pointer there
+ ;; not only clobbers the last change but leaves a dangling
+ ;; pointer invalid after the next GC. Comments in low.lisp
+ ;; indicate this code need do nothing. Setting the
+ ;; function-name to NIL loses some info, and not changing
+ ;; it loses some info of potential hacking value. So,
+ ;; lets not do this...
+ #+nil
+ (let ((header (sb-kernel:%closure-function fcn)))
+ (setf (sb-c::%function-name header) new-name))
+
+ ;; Maybe add better scheme here someday.
+ fcn)))
+
+(defun intern-function-name (name)
+ (cond ((symbolp name) name)
+ ((listp name)
+ (intern (let ((*package* *pcl-package*)
+ (*print-case* :upcase)
+ (*print-pretty* nil)
+ (*print-gensym* 't))
+ (format nil "~S" name))
+ *pcl-package*))))
+\f
+;;;; COMPILE-LAMBDA
+
+;;; This is like the Common Lisp function COMPILE. In fact, that is what it
+;;; ends up calling. The difference is that it deals with things like not
+;;; calling the compiler in certain cases.
+;;;
+;;; FIXME: I suspect that in SBCL, we should always call the compiler. (PCL
+;;; was originally designed to run even on systems with dog-slow call-out-to-C
+;;; compilers, and I suspect that this code is needed only for that.)
+(defun compile-lambda (lambda &optional (desirability :fast))
+ (cond ((eq desirability :fast)
+ (compile nil lambda))
+ (t
+ (compile-lambda-uncompiled lambda))))
+
+(defun compile-lambda-uncompiled (uncompiled)
+ #'(lambda (&rest args) (apply (coerce uncompiled 'function) args)))
+
+(defun compile-lambda-deferred (uncompiled)
+ (let ((function (coerce uncompiled 'function))
+ (compiled nil))
+ (declare (type (or function null) compiled))
+ #'(lambda (&rest args)
+ (if compiled
+ (apply compiled args)
+ (if (in-the-compiler-p)
+ (apply function args)
+ (progn (setq compiled (compile nil uncompiled))
+ (apply compiled args)))))))
+
+;;; FIXME: probably no longer needed after init
+(defmacro precompile-random-code-segments (&optional system)
+ `(progn
+ (eval-when (:compile-toplevel)
+ (update-dispatch-dfuns)
+ (compile-iis-functions nil))
+ (precompile-function-generators ,system)
+ (precompile-dfun-constructors ,system)
+ (precompile-iis-functions ,system)
+ (eval-when (:load-toplevel)
+ (compile-iis-functions t))))
+\f
+(defun record-definition (type spec &rest args)
+ (declare (ignore type spec args))
+ ())
+
+(defun doctor-dfun-for-the-debugger (gf dfun) (declare (ignore gf)) dfun)
+\f
+;;;; low level functions for structures I: functions on arbitrary objects
+
+;;; FIXME: Maybe we don't need this given the SBCL-specific
+;;; versions of the functions which would otherwise use it?
+(defvar *structure-table* (make-hash-table :test 'eq))
+
+(defun declare-structure (name included-name slot-description-list)
+ (setf (gethash name *structure-table*)
+ (cons included-name slot-description-list)))
+
+(unless (fboundp 'structure-functions-exist-p)
+ (setf (symbol-function 'structure-functions-exist-p)
+ #'(lambda () nil)))
+
+;;; FIXME: should probably be INLINE
+;;; FIXME: should probably be moved to package SB-INT along with
+;;; other nonstandard type predicates, or removed entirely
+(defun structurep (x)
+ (typep x 'cl:structure-object))
+\f
+;;; This definition is for interpreted code.
+(defun pcl-instance-p (x)
+ (typep (sb-kernel:layout-of x) 'wrapper))
+
+;;; We define this as STANDARD-INSTANCE, since we're going to clobber the
+;;; layout with some standard-instance layout as soon as we make it, and we
+;;; want the accessor to still be type-correct.
+(defstruct (standard-instance
+ (:predicate nil)
+ (:constructor %%allocate-instance--class ())
+ (:copier nil)
+ (:alternate-metaclass sb-kernel:instance cl:standard-class
+ sb-kernel:make-standard-class))
+ (slots nil))
+
+;;; Both of these operations "work" on structures, which allows the above
+;;; weakening of std-instance-p.
+(defmacro std-instance-slots (x) `(sb-kernel:%instance-ref ,x 1))
+(defmacro std-instance-wrapper (x) `(sb-kernel:%instance-layout ,x))
+
+(defmacro built-in-or-structure-wrapper (x) `(sb-kernel:layout-of ,x))
+
+(defmacro get-wrapper (inst)
+ (sb-int:once-only ((wrapper `(wrapper-of ,inst)))
+ `(progn
+ (assert (typep ,wrapper 'wrapper) () "What kind of instance is this?")
+ ,wrapper)))
+
+;;; FIXME: could be an inline function (like many other things around
+;;; here)
+(defmacro get-instance-wrapper-or-nil (inst)
+ (sb-int:once-only ((wrapper `(wrapper-of ,inst)))
+ `(if (typep ,wrapper 'wrapper)
+ ,wrapper
+ nil)))
+
+(defmacro get-slots-or-nil (inst)
+ (sb-int:once-only ((n-inst inst))
+ `(when (pcl-instance-p ,n-inst)
+ (if (std-instance-p ,n-inst)
+ (std-instance-slots ,n-inst)
+ (fsc-instance-slots ,n-inst)))))
+\f
+;;;; structure-instance stuff
+
+;;; FIXME: This can be removed by hardwiring uses of it to T.
+(defun structure-functions-exist-p ()
+ t)
+
+;;; The definition of STRUCTURE-TYPE-P was moved to early-low.lisp.
+
+(defun get-structure-dd (type)
+ (sb-kernel:layout-info (sb-kernel:class-layout (cl:find-class type))))
+
+(defun structure-type-included-type-name (type)
+ (let ((include (sb-kernel::dd-include (get-structure-dd type))))
+ (if (consp include)
+ (car include)
+ include)))
+
+(defun structure-type-slot-description-list (type)
+ (nthcdr (length (let ((include (structure-type-included-type-name type)))
+ (and include
+ (sb-kernel:dd-slots (get-structure-dd include)))))
+ (sb-kernel:dd-slots (get-structure-dd type))))
+
+(defun structure-slotd-name (slotd)
+ (sb-kernel:dsd-name slotd))
+
+(defun structure-slotd-accessor-symbol (slotd)
+ (sb-kernel:dsd-accessor slotd))
+
+(defun structure-slotd-reader-function (slotd)
+ (fdefinition (sb-kernel:dsd-accessor slotd)))
+
+(defun structure-slotd-writer-function (slotd)
+ (unless (sb-kernel:dsd-read-only slotd)
+ (fdefinition `(setf ,(sb-kernel:dsd-accessor slotd)))))
+
+(defun structure-slotd-type (slotd)
+ (sb-kernel:dsd-type slotd))
+
+(defun structure-slotd-init-form (slotd)
+ (sb-kernel::dsd-default slotd))
+
+;;; FIXME: more than one IN-PACKAGE in a source file, ick
+(in-package "SB-C")
+
+(def-source-context defmethod (name &rest stuff)
+ (let ((arg-pos (position-if #'listp stuff)))
+ (if arg-pos
+ `(defmethod ,name ,@(subseq stuff 0 arg-pos)
+ ,(nth-value 2 (sb-pcl::parse-specialized-lambda-list
+ (elt stuff arg-pos))))
+ `(defmethod ,name "<illegal syntax>"))))
--- /dev/null
+;;;; macros, global variable definitions, and other miscellaneous support stuff
+;;;; used by the rest of the PCL subsystem
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+
+;;;; This software is derived from software originally released by Xerox
+;;;; Corporation. Copyright and release statements follow. Later modifications
+;;;; to the software are in the public domain and are provided with
+;;;; absolutely no warranty. See the COPYING and CREDITS files for more
+;;;; information.
+
+;;;; copyright information from original PCL sources:
+;;;;
+;;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
+;;;; All rights reserved.
+;;;;
+;;;; Use and copying of this software and preparation of derivative works based
+;;;; upon this software are permitted. Any distribution of this software or
+;;;; derivative works must comply with all applicable United States export
+;;;; control laws.
+;;;;
+;;;; This software is made available AS IS, and Xerox Corporation makes no
+;;;; warranty about the software, its performance or its conformity to any
+;;;; specification.
+\f
+(in-package "SB-PCL")
+
+(sb-int:file-comment
+ "$Header$")
+
+(declaim (declaration
+ ;; FIXME: Since none of these are supported in SBCL, the
+ ;; declarations using them are just noise now that this is
+ ;; not a portable package any more, and could be deleted.
+ values ; I use this so that Zwei can remind
+ ; me what values a function returns.
+ arglist ; Tells me what the pretty arglist
+ ; of something (which probably takes
+ ; &REST args) is.
+ indentation ; Tells ZWEI how to indent things
+ ; like DEFCLASS.
+ class
+ variable-rebinding
+ pcl-fast-call
+ method-name
+ method-lambda-list))
+
+;;; These are age-old functions which CommonLisp cleaned-up away. They probably
+;;; exist in other packages in all CommonLisp implementations, but I will leave
+;;; it to the compiler to optimize into calls to them.
+;;;
+;;; FIXME: MEMQ, ASSQ, and DELQ are already defined in SBCL, and we should
+;;; use those. POSQ and NEQ aren't defined in SBCL, and are used too often
+;;; in PCL to make it appealing to hand expand all uses and then delete
+;;; the macros, so they should be boosted up to SBCL to stand by MEMQ,
+;;; ASSQ, and DELQ.
+(defmacro memq (item list) `(member ,item ,list :test #'eq))
+(defmacro assq (item list) `(assoc ,item ,list :test #'eq))
+(defmacro delq (item list) `(delete ,item ,list :test #'eq))
+(defmacro posq (item list) `(position ,item ,list :test #'eq))
+(defmacro neq (x y) `(not (eq ,x ,y)))
+
+;;; Rename these to CONSTANTLY-T, CONSTANTLY-NIL, and CONSTANTLY-0
+;;; and boost them up to SB-INT.
+(defun true (&rest ignore) (declare (ignore ignore)) t)
+(defun false (&rest ignore) (declare (ignore ignore)) nil)
+(defun zero (&rest ignore) (declare (ignore ignore)) 0)
+
+;;; ONCE-ONLY does the same thing as it does in zetalisp. I should have just
+;;; lifted it from there but I am honest. Not only that but this one is
+;;; written in Common Lisp. I feel a lot like bootstrapping, or maybe more
+;;; like rebuilding Rome.
+;;;
+;;; FIXME: We should only need one ONCE-ONLY in CMU CL, and there's one
+;;; in SB-EXT already (presently to go in SB-INT). Can we use
+;;; only one of these in both places?
+(defmacro once-only (vars &body body)
+ (let ((gensym-var (gensym))
+ (run-time-vars (gensym))
+ (run-time-vals (gensym))
+ (expand-time-val-forms ()))
+ (dolist (var vars)
+ (push `(if (or (symbolp ,var)
+ (numberp ,var)
+ (and (listp ,var)
+ (member (car ,var) '(quote function))))
+ ,var
+ (let ((,gensym-var (gensym)))
+ (push ,gensym-var ,run-time-vars)
+ (push ,var ,run-time-vals)
+ ,gensym-var))
+ expand-time-val-forms))
+ `(let* (,run-time-vars
+ ,run-time-vals
+ (wrapped-body
+ (let ,(mapcar #'list vars (reverse expand-time-val-forms))
+ ,@body)))
+ `(let ,(mapcar #'list (reverse ,run-time-vars)
+ (reverse ,run-time-vals))
+ ,wrapped-body))))
+
+;;; FIXME: This looks like SBCL's PARSE-BODY, and should be shared.
+(eval-when (:compile-toplevel :load-toplevel :execute)
+(defun extract-declarations (body &optional environment)
+ ;;(declare (values documentation declarations body))
+ (let (documentation
+ declarations
+ form)
+ (when (and (stringp (car body))
+ (cdr body))
+ (setq documentation (pop body)))
+ (block outer
+ (loop
+ (when (null body) (return-from outer nil))
+ (setq form (car body))
+ (when (block inner
+ (loop (cond ((not (listp form))
+ (return-from outer nil))
+ ((eq (car form) 'declare)
+ (return-from inner 't))
+ (t
+ (multiple-value-bind (newform macrop)
+ (macroexpand-1 form environment)
+ (if (or (not (eq newform form)) macrop)
+ (setq form newform)
+ (return-from outer nil)))))))
+ (pop body)
+ (dolist (declaration (cdr form))
+ (push declaration declarations)))))
+ (values documentation
+ (and declarations `((declare ,.(nreverse declarations))))
+ body)))
+) ; EVAL-WHEN
+
+;;; FIXME: This seems to only be used to get 'METHOD-NAME and
+;;; METHOD-LAMBDA-LIST declarations. They aren't ANSI. Are they important?
+(defun get-declaration (name declarations &optional default)
+ (dolist (d declarations default)
+ (dolist (form (cdr d))
+ (when (and (consp form) (eq (car form) name))
+ (return-from get-declaration (cdr form))))))
+
+;;; FIXME: This duplicates SB-EXT:*KEYWORD-PACKAGE*.
+(defvar *keyword-package* (find-package 'keyword))
+
+;;; FIXME: This duplicates some of the functionality of SB-EXT:KEYWORDICATE.
+(defun make-keyword (symbol)
+ (intern (symbol-name symbol) *keyword-package*))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+
+(defun string-append (&rest strings)
+ (setq strings (copy-list strings)) ;The TI Explorer can't even
+ ;RPLACA a &REST arg?
+ (do ((string-loc strings (cdr string-loc)))
+ ((null string-loc)
+ (apply #'concatenate 'string strings))
+ (rplaca string-loc (string (car string-loc)))))
+
+) ; EVAL-WHEN
+
+(defun symbol-append (sym1 sym2 &optional (package *package*))
+ (intern (string-append sym1 sym2) package))
+
+(defmacro collecting-once (&key initial-value)
+ `(let* ((head ,initial-value)
+ (tail ,(and initial-value `(last head))))
+ (values #'(lambda (value)
+ (if (null head)
+ (setq head (setq tail (list value)))
+ (unless (memq value head)
+ (setq tail
+ (cdr (rplacd tail (list value)))))))
+ #'(lambda nil head))))
+
+(defmacro doplist ((key val) plist &body body &environment env)
+ (multiple-value-bind (doc decls bod)
+ (extract-declarations body env)
+ (declare (ignore doc))
+ `(let ((.plist-tail. ,plist) ,key ,val)
+ ,@decls
+ (loop (when (null .plist-tail.) (return nil))
+ (setq ,key (pop .plist-tail.))
+ (when (null .plist-tail.)
+ (error "malformed plist in doplist, odd number of elements"))
+ (setq ,val (pop .plist-tail.))
+ (progn ,@bod)))))
+
+(defmacro dolist-carefully ((var list improper-list-handler) &body body)
+ `(let ((,var nil)
+ (.dolist-carefully. ,list))
+ (loop (when (null .dolist-carefully.) (return nil))
+ (if (consp .dolist-carefully.)
+ (progn
+ (setq ,var (pop .dolist-carefully.))
+ ,@body)
+ (,improper-list-handler)))))
+
+;;; FIXME: Do we really need this? It seems to be used only
+;;; for class names. Why not just the default ALL-CAPS?
+(defun capitalize-words (string &optional (dashes-p t))
+ (let ((string (copy-seq (string string))))
+ (declare (string string))
+ (do* ((flag t flag)
+ (length (length string) length)
+ (char nil char)
+ (i 0 (+ i 1)))
+ ((= i length) string)
+ (setq char (elt string i))
+ (cond ((both-case-p char)
+ (if flag
+ (and (setq flag (lower-case-p char))
+ (setf (elt string i) (char-upcase char)))
+ (and (not flag) (setf (elt string i) (char-downcase char))))
+ (setq flag nil))
+ ((char-equal char #\-)
+ (setq flag t)
+ (unless dashes-p (setf (elt string i) #\space)))
+ (t (setq flag nil))))))
+\f
+;;;; FIND-CLASS
+;;;;
+;;;; This is documented in the CLOS specification.
+;;;; KLUDGE: Except that SBCL deviates from the spec by having CL:FIND-CLASS
+;;;; distinct from PCL:FIND-CLASS, alas. -- WHN 19991203
+
+(defvar *find-class* (make-hash-table :test 'eq))
+
+(defun make-constant-function (value)
+ #'(lambda (object)
+ (declare (ignore object))
+ value))
+
+(defun function-returning-nil (x)
+ (declare (ignore x))
+ nil)
+
+(defun function-returning-t (x)
+ (declare (ignore x))
+ t)
+
+(defmacro find-class-cell-class (cell)
+ `(car ,cell))
+
+(defmacro find-class-cell-predicate (cell)
+ `(cadr ,cell))
+
+(defmacro find-class-cell-make-instance-function-keys (cell)
+ `(cddr ,cell))
+
+(defmacro make-find-class-cell (class-name)
+ (declare (ignore class-name))
+ '(list* nil #'function-returning-nil nil))
+
+(defun find-class-cell (symbol &optional dont-create-p)
+ (or (gethash symbol *find-class*)
+ (unless dont-create-p
+ (unless (legal-class-name-p symbol)
+ (error "~S is not a legal class name." symbol))
+ (setf (gethash symbol *find-class*) (make-find-class-cell symbol)))))
+
+(defvar *create-classes-from-internal-structure-definitions-p* t)
+
+(defun find-class-from-cell (symbol cell &optional (errorp t))
+ (or (find-class-cell-class cell)
+ (and *create-classes-from-internal-structure-definitions-p*
+ (structure-type-p symbol)
+ (find-structure-class symbol))
+ (cond ((null errorp) nil)
+ ((legal-class-name-p symbol)
+ (error "There is no class named ~S." symbol))
+ (t
+ (error "~S is not a legal class name." symbol)))))
+
+(defun find-class-predicate-from-cell (symbol cell &optional (errorp t))
+ (unless (find-class-cell-class cell)
+ (find-class-from-cell symbol cell errorp))
+ (find-class-cell-predicate cell))
+
+(defun legal-class-name-p (x)
+ (and (symbolp x)
+ (not (keywordp x))))
+
+(defun find-class (symbol &optional (errorp t) environment)
+ (declare (ignore environment))
+ (find-class-from-cell symbol
+ (find-class-cell symbol errorp)
+ errorp))
+
+(defun find-class-predicate (symbol &optional (errorp t) environment)
+ (declare (ignore environment))
+ (find-class-predicate-from-cell symbol
+ (find-class-cell symbol errorp)
+ errorp))
+\f
+;;; This DEFVAR was originally in defs.lisp, now moved here.
+;;;
+;;; Possible values are NIL, EARLY, BRAID, or COMPLETE.
+;;;
+;;; KLUDGE: This should probably become
+;;; (DECLAIM (TYPE (MEMBER NIL :EARLY :BRAID :COMPLETE) *BOOT-STATE*))
+(defvar *boot-state* nil)
+
+;;; Note that in SBCL as in CMU CL,
+;;; COMMON-LISP:FIND-CLASS /= SB-PCL:FIND-CLASS.
+;;; (Yes, this is a KLUDGE!)
+(define-compiler-macro find-class (&whole form
+ symbol &optional (errorp t) environment)
+ (declare (ignore environment))
+ (if (and (constantp symbol)
+ (legal-class-name-p (eval symbol))
+ (constantp errorp)
+ (member *boot-state* '(braid complete)))
+ (let ((symbol (eval symbol))
+ (errorp (not (null (eval errorp))))
+ (class-cell (make-symbol "CLASS-CELL")))
+ `(let ((,class-cell (load-time-value (find-class-cell ',symbol))))
+ (or (find-class-cell-class ,class-cell)
+ ,(if errorp
+ `(find-class-from-cell ',symbol ,class-cell t)
+ `(and (sb-kernel:class-cell-class
+ ',(sb-kernel:find-class-cell symbol))
+ (find-class-from-cell ',symbol ,class-cell nil))))))
+ form))
+
+;;; FIXME: These #-SETF forms are pretty ugly. Could they please go away?
+#-setf
+(defsetf find-class (symbol &optional (errorp t) environment) (new-value)
+ (declare (ignore errorp environment))
+ `(SETF\ SB-PCL\ FIND-CLASS ,new-value ,symbol))
+
+(defun #-setf SETF\ SB-PCL\ FIND-CLASS #+setf (setf find-class) (new-value
+ symbol)
+ (if (legal-class-name-p symbol)
+ (let ((cell (find-class-cell symbol)))
+ (setf (find-class-cell-class cell) new-value)
+ (when (or (eq *boot-state* 'complete)
+ (eq *boot-state* 'braid))
+ (when (and new-value (class-wrapper new-value))
+ (setf (find-class-cell-predicate cell)
+ (symbol-function (class-predicate-name new-value))))
+ (when (and new-value (not (forward-referenced-class-p new-value)))
+
+ (dolist (keys+aok (find-class-cell-make-instance-function-keys cell))
+ (update-initialize-info-internal
+ (initialize-info new-value (car keys+aok) nil (cdr keys+aok))
+ 'make-instance-function))))
+ new-value)
+ (error "~S is not a legal class name." symbol)))
+
+#-setf
+(defsetf find-class-predicate (symbol &optional (errorp t) environment) (new-value)
+ (declare (ignore errorp environment))
+ `(SETF\ SB-PCL\ FIND-CLASS-PREDICATE ,new-value ,symbol))
+
+(defun #-setf SETF\ SB-PCL\ FIND-CLASS-PREDICATE
+ #+setf (setf find-class-predicate)
+ (new-value symbol)
+ (if (legal-class-name-p symbol)
+ (setf (find-class-cell-predicate (find-class-cell symbol)) new-value)
+ (error "~S is not a legal class name." symbol)))
+
+(defun find-wrapper (symbol)
+ (class-wrapper (find-class symbol)))
+
+(defmacro gathering1 (gatherer &body body)
+ `(gathering ((.gathering1. ,gatherer))
+ (macrolet ((gather1 (x) `(gather ,x .gathering1.)))
+ ,@body)))
+
+(defmacro vectorizing (&key (size 0))
+ `(let* ((limit ,size)
+ (result (make-array limit))
+ (index 0))
+ (values #'(lambda (value)
+ (if (= index limit)
+ (error "vectorizing more elements than promised")
+ (progn
+ (setf (svref result index) value)
+ (incf index)
+ value)))
+ #'(lambda () result))))
+
+;;; These are augmented definitions of list-elements and list-tails from
+;;; iterate.lisp. These versions provide the extra :by keyword which can
+;;; be used to specify the step function through the list.
+(defmacro *list-elements (list &key (by #'cdr))
+ `(let ((tail ,list))
+ #'(lambda (finish)
+ (if (endp tail)
+ (funcall finish)
+ (prog1 (car tail)
+ (setq tail (funcall ,by tail)))))))
+
+(defmacro *list-tails (list &key (by #'cdr))
+ `(let ((tail ,list))
+ #'(lambda (finish)
+ (prog1 (if (endp tail)
+ (funcall finish)
+ tail)
+ (setq tail (funcall ,by tail))))))
+
+(defmacro function-funcall (form &rest args)
+ `(funcall (the function ,form) ,@args))
+
+(defmacro function-apply (form &rest args)
+ `(apply (the function ,form) ,@args))
+\f
+;;;; various nastiness to work around nonstandardness of SETF when PCL
+;;;; was written
+
+;;; Convert a function name to its standard SETF function name. We
+;;; have to do this hack because not all Common Lisps have yet
+;;; converted to having SETF function specs.
+;;;
+;;; KLUDGE: We probably don't have to do this any more. But in Debian
+;;; cmucl 2.4.8 the :SETF feature isn't set (?). Perhaps it's because of
+;;; the comment ca. 10 lines down about how the built-in setf mechanism
+;;; takes a hash table lookup each time? It would be nice to go one
+;;; way or another on this, perhaps some benchmarking would be in order..
+;;; (Oh, more info: In debian src/pcl/notes.text, which looks like stale
+;;; documentation from 1992, it says TO DO: When CMU CL improves its
+;;; SETF handling, remove the comment in macros.lisp beginning the line
+;;; #+CMU (PUSHNEW :SETF *FEATURES*). So since CMU CL's (and now SBCL's)
+;;; SETF handling seems OK to me these days, there's a fairly decent chance
+;;; this would work.) -- WHN 19991203
+;;;
+;;; In a port that does have SETF function specs you can use those just by
+;;; making the obvious simple changes to these functions. The rest of PCL
+;;; believes that there are function names like (SETF <foo>), this is the
+;;; only place that knows about this hack.
+(eval-when (:compile-toplevel :load-toplevel :execute)
+; In 15e (and also 16c), using the built-in SETF mechanism costs
+; a hash table lookup every time a SETF function is called.
+; Uncomment the next line to use the built in SETF mechanism.
+;#+cmu (pushnew :setf *features*)
+) ; EVAL-WHEN
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+
+#-setf
+(defvar *setf-function-names* (make-hash-table :size 200 :test 'eq))
+
+(defun get-setf-function-name (name)
+ #+setf `(setf ,name)
+ #-setf
+ (or (gethash name *setf-function-names*)
+ (setf (gethash name *setf-function-names*)
+ (let ((pkg (symbol-package name)))
+ (if pkg
+ (intern (format nil
+ "SETF ~A ~A"
+ (package-name pkg)
+ (symbol-name name))
+ *pcl-package*)
+ (make-symbol (format nil "SETF ~A" (symbol-name name))))))))
+
+;;; Call this to define a setf macro for a function with the same behavior as
+;;; specified by the SETF function cleanup proposal. Specifically, this will
+;;; cause: (SETF (FOO a b) x) to expand to (|SETF FOO| x a b).
+;;;
+;;; do-standard-defsetf A macro interface for use at top level
+;;; in files. Unfortunately, users may
+;;; have to use this for a while.
+;;;
+;;; do-standard-defsetfs-for-defclass A special version called by defclass.
+;;;
+;;; do-standard-defsetf-1 A functional interface called by the
+;;; above, defmethod and defgeneric.
+;;; Since this is all a crock anyways,
+;;; users are free to call this as well.
+;;;
+;;; FIXME: Once we fix up SETF, a lot of stuff around here should evaporate.
+(defmacro do-standard-defsetf (&rest function-names)
+ `(eval-when (:compile-toplevel :load-toplevel :execute)
+ (dolist (fn-name ',function-names) (do-standard-defsetf-1 fn-name))))
+
+(defun do-standard-defsetfs-for-defclass (accessors)
+ (dolist (name accessors) (do-standard-defsetf-1 name)))
+
+(defun do-standard-defsetf-1 (function-name)
+ #+setf
+ (declare (ignore function-name))
+ #+setf nil
+ #-setf
+ (unless (and (setfboundp function-name)
+ (get function-name 'standard-setf))
+ (setf (get function-name 'standard-setf) t)
+ (let* ((setf-function-name (get-setf-function-name function-name)))
+ (eval `(defsetf ,function-name (&rest accessor-args) (new-value)
+ (let* ((bindings (mapcar #'(lambda (x) `(,(gensym) ,x)) accessor-args))
+ (vars (mapcar #'car bindings)))
+ `(let ,bindings
+ (,',setf-function-name ,new-value ,@vars))))))))
+
+(defun setfboundp (symbol)
+ (fboundp `(setf ,symbol)))
+
+) ; EVAL-WHEN
+
+;;; PCL, like user code, must endure the fact that we don't have a
+;;; properly working SETF. Many things work because they get mentioned
+;;; by a DEFCLASS or DEFMETHOD before they are used, but others have
+;;; to be done by hand.
+;;;
+;;; FIXME: We don't have to do this stuff any more, do we?
+(do-standard-defsetf
+ class-wrapper ;***
+ generic-function-name
+ method-function-plist
+ method-function-get
+ plist-value
+ object-plist
+ gdefinition
+ slot-value-using-class)
+
+(defsetf slot-value set-slot-value)
--- /dev/null
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+
+;;;; This software is derived from software originally released by Xerox
+;;;; Corporation. Copyright and release statements follow. Later modifications
+;;;; to the software are in the public domain and are provided with
+;;;; absolutely no warranty. See the COPYING and CREDITS files for more
+;;;; information.
+
+;;;; copyright information from original PCL sources:
+;;;;
+;;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
+;;;; All rights reserved.
+;;;;
+;;;; Use and copying of this software and preparation of derivative works based
+;;;; upon this software are permitted. Any distribution of this software or
+;;;; derivative works must comply with all applicable United States export
+;;;; control laws.
+;;;;
+;;;; This software is made available AS IS, and Xerox Corporation makes no
+;;;; warranty about the software, its performance or its conformity to any
+;;;; specification.
+
+(in-package "SB-PCL")
+
+(sb-int:file-comment
+ "$Header$")
+\f
+(defmethod shared-initialize :after ((slotd standard-slot-definition)
+ slot-names &key)
+ (declare (ignore slot-names))
+ (with-slots (allocation class)
+ slotd
+ (setq allocation (if (eq allocation :class) class allocation))))
+
+(defmethod shared-initialize :after ((slotd structure-slot-definition)
+ slot-names
+ &key (allocation :instance))
+ (declare (ignore slot-names))
+ (unless (eq allocation :instance)
+ (error "Structure slots must have :INSTANCE allocation.")))
+
+(defmethod inform-type-system-about-class ((class structure-class) (name t))
+ nil)
+
+;;; methods
+;;;
+;;; Methods themselves are simple inanimate objects. Most properties of
+;;; methods are immutable, methods cannot be reinitialized. The following
+;;; properties of methods can be changed:
+;;; METHOD-GENERIC-FUNCTION
+;;; METHOD-FUNCTION ??
+
+(defmethod method-function ((method standard-method))
+ (or (slot-value method 'function)
+ (let ((fmf (slot-value method 'fast-function)))
+ (unless fmf ; The :BEFORE SHARED-INITIALIZE method prevents this.
+ (error "~S doesn't seem to have a METHOD-FUNCTION." method))
+ (setf (slot-value method 'function)
+ (method-function-from-fast-function fmf)))))
+
+(defmethod accessor-method-class ((method standard-accessor-method))
+ (car (slot-value method 'specializers)))
+
+(defmethod accessor-method-class ((method standard-writer-method))
+ (cadr (slot-value method 'specializers)))
+
+;;; initialization
+;;;
+;;; Error checking is done in before methods. Because of the simplicity of
+;;; standard method objects the standard primary method can fill the slots.
+;;;
+;;; Methods are not reinitializable.
+
+(defmethod reinitialize-instance ((method standard-method) &rest initargs)
+ (declare (ignore initargs))
+ (error "An attempt was made to reinitialize the method ~S.~%~
+ Method objects cannot be reinitialized."
+ method))
+
+(defmethod legal-documentation-p ((object standard-method) x)
+ (if (or (null x) (stringp x))
+ t
+ "a string or NULL"))
+
+(defmethod legal-lambda-list-p ((object standard-method) x)
+ (declare (ignore x))
+ t)
+
+(defmethod legal-method-function-p ((object standard-method) x)
+ (if (functionp x)
+ t
+ "a function"))
+
+(defmethod legal-qualifiers-p ((object standard-method) x)
+ (flet ((improper-list ()
+ (return-from legal-qualifiers-p "Is not a proper list.")))
+ (dolist-carefully (q x improper-list)
+ (let ((ok (legal-qualifier-p object q)))
+ (unless (eq ok t)
+ (return-from legal-qualifiers-p
+ (format nil "Contains ~S which ~A" q ok)))))
+ t))
+
+(defmethod legal-qualifier-p ((object standard-method) x)
+ (if (and x (atom x))
+ t
+ "is not a non-null atom"))
+
+(defmethod legal-slot-name-p ((object standard-method) x)
+ (cond ((not (symbolp x)) "is not a symbol and so cannot be bound")
+ ((keywordp x) "is a keyword and so cannot be bound")
+ ((memq x '(t nil)) "cannot be bound")
+ ((constantp x) "is a constant and so cannot be bound")
+ (t t)))
+
+(defmethod legal-specializers-p ((object standard-method) x)
+ (flet ((improper-list ()
+ (return-from legal-specializers-p "Is not a proper list.")))
+ (dolist-carefully (s x improper-list)
+ (let ((ok (legal-specializer-p object s)))
+ (unless (eq ok t)
+ (return-from legal-specializers-p
+ (format nil "Contains ~S which ~A" s ok)))))
+ t))
+
+(defvar *allow-experimental-specializers-p* nil)
+
+(defmethod legal-specializer-p ((object standard-method) x)
+ (if (if *allow-experimental-specializers-p*
+ (specializerp x)
+ (or (classp x)
+ (eql-specializer-p x)))
+ t
+ "is neither a class object nor an EQL specializer"))
+
+(defmethod shared-initialize :before ((method standard-method)
+ slot-names
+ &key qualifiers
+ lambda-list
+ specializers
+ function
+ fast-function
+ documentation)
+ (declare (ignore slot-names))
+ (flet ((lose (initarg value string)
+ (error "when initializing the method ~S:~%~
+ The ~S initialization argument was: ~S.~%~
+ which ~A."
+ method initarg value string)))
+ (let ((check-qualifiers (legal-qualifiers-p method qualifiers))
+ (check-lambda-list (legal-lambda-list-p method lambda-list))
+ (check-specializers (legal-specializers-p method specializers))
+ (check-function (legal-method-function-p method
+ (or function
+ fast-function)))
+ (check-documentation (legal-documentation-p method documentation)))
+ (unless (eq check-qualifiers t)
+ (lose :qualifiers qualifiers check-qualifiers))
+ (unless (eq check-lambda-list t)
+ (lose :lambda-list lambda-list check-lambda-list))
+ (unless (eq check-specializers t)
+ (lose :specializers specializers check-specializers))
+ (unless (eq check-function t)
+ (lose :function function check-function))
+ (unless (eq check-documentation t)
+ (lose :documentation documentation check-documentation)))))
+
+(defmethod shared-initialize :before ((method standard-accessor-method)
+ slot-names
+ &key slot-name slot-definition)
+ (declare (ignore slot-names))
+ (unless slot-definition
+ (let ((legalp (legal-slot-name-p method slot-name)))
+ ;; FIXME: nasty convention; should be renamed to ILLEGAL-SLOT-NAME-P and
+ ;; ILLEGALP, and the convention redone to be less twisty
+ (unless (eq legalp t)
+ (error "The value of the :SLOT-NAME initarg ~A." legalp)))))
+
+(defmethod shared-initialize :after ((method standard-method) slot-names
+ &rest initargs
+ &key qualifiers method-spec plist)
+ (declare (ignore slot-names method-spec plist))
+ (initialize-method-function initargs nil method)
+ (setf (plist-value method 'qualifiers) qualifiers)
+ #+ignore
+ (setf (slot-value method 'closure-generator)
+ (method-function-closure-generator (slot-value method 'function))))
+
+(defmethod shared-initialize :after ((method standard-accessor-method)
+ slot-names
+ &key)
+ (declare (ignore slot-names))
+ (with-slots (slot-name slot-definition)
+ method
+ (unless slot-definition
+ (let ((class (accessor-method-class method)))
+ (when (slot-class-p class)
+ (setq slot-definition (find slot-name (class-direct-slots class)
+ :key #'slot-definition-name)))))
+ (when (and slot-definition (null slot-name))
+ (setq slot-name (slot-definition-name slot-definition)))))
+
+(defmethod method-qualifiers ((method standard-method))
+ (plist-value method 'qualifiers))
+\f
+(defvar *the-class-generic-function*
+ (find-class 'generic-function))
+(defvar *the-class-standard-generic-function*
+ (find-class 'standard-generic-function))
+\f
+(defmethod shared-initialize :before
+ ((generic-function standard-generic-function)
+ slot-names
+ &key (name nil namep)
+ (lambda-list () lambda-list-p)
+ argument-precedence-order
+ declarations
+ documentation
+ (method-class nil method-class-supplied-p)
+ (method-combination nil method-combination-supplied-p))
+ (declare (ignore slot-names
+ declarations argument-precedence-order documentation
+ lambda-list lambda-list-p))
+
+ (when namep
+ (set-function-name generic-function name))
+
+ (flet ((initarg-error (initarg value string)
+ (error "when initializing the generic function ~S:~%~
+ The ~S initialization argument was: ~A.~%~
+ It must be ~A."
+ generic-function initarg value string)))
+ (cond (method-class-supplied-p
+ (when (symbolp method-class)
+ (setq method-class (find-class method-class)))
+ (unless (and (classp method-class)
+ (*subtypep (class-eq-specializer method-class)
+ *the-class-method*))
+ (initarg-error :method-class
+ method-class
+ "a subclass of the class METHOD"))
+ (setf (slot-value generic-function 'method-class) method-class))
+ ((slot-boundp generic-function 'method-class))
+ (t
+ (initarg-error :method-class
+ "not supplied"
+ "a subclass of the class METHOD")))
+ (cond (method-combination-supplied-p
+ (unless (method-combination-p method-combination)
+ (initarg-error :method-combination
+ method-combination
+ "a method combination object")))
+ ((slot-boundp generic-function 'method-combination))
+ (t
+ (initarg-error :method-combination
+ "not supplied"
+ "a method combination object")))))
+
+#||
+(defmethod reinitialize-instance ((generic-function standard-generic-function)
+ &rest initargs
+ &key name
+ lambda-list
+ argument-precedence-order
+ declarations
+ documentation
+ method-class
+ method-combination)
+ (declare (ignore documentation declarations argument-precedence-order
+ lambda-list name method-class method-combination))
+ (macrolet ((add-initarg (check name slot-name)
+ `(unless ,check
+ (push (slot-value generic-function ,slot-name) initargs)
+ (push ,name initargs))))
+; (add-initarg name :name 'name)
+; (add-initarg lambda-list :lambda-list 'lambda-list)
+; (add-initarg argument-precedence-order
+; :argument-precedence-order
+; 'argument-precedence-order)
+; (add-initarg declarations :declarations 'declarations)
+; (add-initarg documentation :documentation 'documentation)
+; (add-initarg method-class :method-class 'method-class)
+; (add-initarg method-combination :method-combination 'method-combination)
+ (apply #'call-next-method generic-function initargs)))
+||#
+\f
+;;; These three are scheduled for demolition.
+
+(defmethod remove-named-method (generic-function-name argument-specifiers
+ &optional extra)
+ (let ((generic-function ())
+ (method ()))
+ (cond ((or (null (fboundp generic-function-name))
+ (not (generic-function-p
+ (setq generic-function
+ (symbol-function generic-function-name)))))
+ (error "~S does not name a generic function."
+ generic-function-name))
+ ((null (setq method (get-method generic-function
+ extra
+ (parse-specializers
+ argument-specifiers)
+ nil)))
+ (error "There is no method for the generic function ~S~%~
+ which matches the ARGUMENT-SPECIFIERS ~S."
+ generic-function
+ argument-specifiers))
+ (t
+ (remove-method generic-function method)))))
+
+(defun real-add-named-method (generic-function-name
+ qualifiers
+ specializers
+ lambda-list
+ &rest other-initargs)
+ (unless (and (fboundp generic-function-name)
+ (typep (symbol-function generic-function-name)
+ 'generic-function))
+ (sb-kernel::style-warn "implicitly creating new generic function ~S"
+ generic-function-name))
+ ;; XXX What about changing the class of the generic function if
+ ;; there is one? Whose job is that, anyway? Do we need something
+ ;; kind of like CLASS-FOR-REDEFINITION?
+ (let* ((generic-function
+ (ensure-generic-function generic-function-name))
+ (specs (parse-specializers specializers))
+ (proto (method-prototype-for-gf generic-function-name))
+ (new (apply #'make-instance (class-of proto)
+ :qualifiers qualifiers
+ :specializers specs
+ :lambda-list lambda-list
+ other-initargs)))
+ (add-method generic-function new)))
+
+(defun real-get-method (generic-function qualifiers specializers
+ &optional (errorp t))
+ (let ((hit
+ (dolist (method (generic-function-methods generic-function))
+ (when (and (equal qualifiers (method-qualifiers method))
+ (every #'same-specializer-p specializers
+ (method-specializers method)))
+ (return method)))))
+ (cond (hit hit)
+ ((null errorp) nil)
+ (t
+ (error "no method on ~S with qualifiers ~:S and specializers ~:S"
+ generic-function qualifiers specializers)))))
+\f
+(defmethod find-method ((generic-function standard-generic-function)
+ qualifiers specializers &optional (errorp t))
+ (real-get-method generic-function qualifiers
+ (parse-specializers specializers) errorp))
+\f
+;;; Compute various information about a generic-function's arglist by looking
+;;; at the argument lists of the methods. The hair for trying not to use
+;;; &REST arguments lives here.
+;;; The values returned are:
+;;; number-of-required-arguments
+;;; the number of required arguments to this generic-function's
+;;; discriminating function
+;;; &rest-argument-p
+;;; whether or not this generic-function's discriminating
+;;; function takes an &rest argument.
+;;; specialized-argument-positions
+;;; a list of the positions of the arguments this generic-function
+;;; specializes (e.g. for a classical generic-function this is the
+;;; list: (1)).
+(defmethod compute-discriminating-function-arglist-info
+ ((generic-function standard-generic-function))
+ ;;(declare (values number-of-required-arguments &rest-argument-p
+ ;; specialized-argument-postions))
+ (let ((number-required nil)
+ (restp nil)
+ (specialized-positions ())
+ (methods (generic-function-methods generic-function)))
+ (dolist (method methods)
+ (multiple-value-setq (number-required restp specialized-positions)
+ (compute-discriminating-function-arglist-info-internal
+ generic-function method number-required restp specialized-positions)))
+ (values number-required restp (sort specialized-positions #'<))))
+
+(defun compute-discriminating-function-arglist-info-internal
+ (generic-function method number-of-requireds restp
+ specialized-argument-positions)
+ (declare (ignore generic-function)
+ (type (or null fixnum) number-of-requireds))
+ (let ((requireds 0))
+ (declare (fixnum requireds))
+ ;; Go through this methods arguments seeing how many are required,
+ ;; and whether there is an &rest argument.
+ (dolist (arg (method-lambda-list method))
+ (cond ((eq arg '&aux) (return))
+ ((memq arg '(&optional &rest &key))
+ (return (setq restp t)))
+ ((memq arg lambda-list-keywords))
+ (t (incf requireds))))
+ ;; Now go through this method's type specifiers to see which
+ ;; argument positions are type specified. Treat T specially
+ ;; in the usual sort of way. For efficiency don't bother to
+ ;; keep specialized-argument-positions sorted, rather depend
+ ;; on our caller to do that.
+ (iterate ((type-spec (list-elements (method-specializers method)))
+ (pos (interval :from 0)))
+ (unless (eq type-spec *the-class-t*)
+ (pushnew pos specialized-argument-positions)))
+ ;; Finally merge the values for this method into the values
+ ;; for the exisiting methods and return them. Note that if
+ ;; num-of-requireds is NIL it means this is the first method
+ ;; and we depend on that.
+ (values (min (or number-of-requireds requireds) requireds)
+ (or restp
+ (and number-of-requireds (/= number-of-requireds requireds)))
+ specialized-argument-positions)))
+
+(defun make-discriminating-function-arglist (number-required-arguments restp)
+ (nconc (gathering ((args (collecting)))
+ (iterate ((i (interval :from 0 :below number-required-arguments)))
+ (gather (intern (format nil "Discriminating Function Arg ~D" i))
+ args)))
+ (when restp
+ `(&rest ,(intern "Discriminating Function &rest Arg")))))
+\f
+(defmethod generic-function-lambda-list ((gf generic-function))
+ (gf-lambda-list gf))
+
+(defmethod gf-fast-method-function-p ((gf standard-generic-function))
+ (gf-info-fast-mf-p (slot-value gf 'arg-info)))
+
+(defmethod initialize-instance :after ((gf standard-generic-function)
+ &key (lambda-list nil lambda-list-p)
+ argument-precedence-order)
+ (with-slots (arg-info)
+ gf
+ (if lambda-list-p
+ (set-arg-info gf
+ :lambda-list lambda-list
+ :argument-precedence-order argument-precedence-order)
+ (set-arg-info gf))
+ (when (arg-info-valid-p arg-info)
+ (update-dfun gf))))
+
+(defmethod reinitialize-instance :after ((gf standard-generic-function)
+ &rest args
+ &key (lambda-list nil lambda-list-p)
+ (argument-precedence-order
+ nil argument-precedence-order-p))
+ (with-slots (arg-info)
+ gf
+ (if lambda-list-p
+ (if argument-precedence-order-p
+ (set-arg-info gf
+ :lambda-list lambda-list
+ :argument-precedence-order argument-precedence-order)
+ (set-arg-info gf
+ :lambda-list lambda-list))
+ (set-arg-info gf))
+ (when (and (arg-info-valid-p arg-info)
+ args
+ (or lambda-list-p (cddr args)))
+ (update-dfun gf))))
+
+(declaim (special *lazy-dfun-compute-p*))
+
+(defun set-methods (gf methods)
+ (setf (generic-function-methods gf) nil)
+ (loop (when (null methods) (return gf))
+ (real-add-method gf (pop methods) methods)))
+
+(defun real-add-method (generic-function method &optional skip-dfun-update-p)
+ (if (method-generic-function method)
+ (error "The method ~S is already part of the generic~@
+ function ~S. It can't be added to another generic~@
+ function until it is removed from the first one."
+ method (method-generic-function method))
+
+ (let* ((name (generic-function-name generic-function))
+ (qualifiers (method-qualifiers method))
+ (specializers (method-specializers method))
+ (existing (get-method generic-function
+ qualifiers
+ specializers
+ nil)))
+
+ ;; If there is already a method like this one then we must
+ ;; get rid of it before proceeding. Note that we call the
+ ;; generic function remove-method to remove it rather than
+ ;; doing it in some internal way.
+ (when existing (remove-method generic-function existing))
+
+ (setf (method-generic-function method) generic-function)
+ (pushnew method (generic-function-methods generic-function))
+ (dolist (specializer specializers)
+ (add-direct-method specializer method))
+ (set-arg-info generic-function :new-method method)
+ (unless skip-dfun-update-p
+ (when (member name
+ '(make-instance default-initargs
+ allocate-instance shared-initialize
+ initialize-instance))
+ (update-make-instance-function-table (type-class
+ (car specializers))))
+ (update-dfun generic-function))
+ method)))
+
+(defun real-remove-method (generic-function method)
+ ;; Note: Error check prohibited by ANSI spec removed.
+ (when (eq generic-function (method-generic-function method))
+ (let* ((name (generic-function-name generic-function))
+ (specializers (method-specializers method))
+ (methods (generic-function-methods generic-function))
+ (new-methods (remove method methods)))
+ (setf (method-generic-function method) nil)
+ (setf (generic-function-methods generic-function) new-methods)
+ (dolist (specializer (method-specializers method))
+ (remove-direct-method specializer method))
+ (set-arg-info generic-function)
+ (when (member name
+ '(make-instance
+ default-initargs
+ allocate-instance shared-initialize initialize-instance))
+ (update-make-instance-function-table (type-class (car specializers))))
+ (update-dfun generic-function)
+ generic-function)))
+\f
+(defun compute-applicable-methods-function (generic-function arguments)
+ (values (compute-applicable-methods-using-types
+ generic-function
+ (types-from-arguments generic-function arguments 'eql))))
+
+(defmethod compute-applicable-methods
+ ((generic-function generic-function) arguments)
+ (values (compute-applicable-methods-using-types
+ generic-function
+ (types-from-arguments generic-function arguments 'eql))))
+
+(defmethod compute-applicable-methods-using-classes
+ ((generic-function generic-function) classes)
+ (compute-applicable-methods-using-types
+ generic-function
+ (types-from-arguments generic-function classes 'class-eq)))
+
+(defun proclaim-incompatible-superclasses (classes)
+ (setq classes (mapcar #'(lambda (class)
+ (if (symbolp class)
+ (find-class class)
+ class))
+ classes))
+ (dolist (class classes)
+ (dolist (other-class classes)
+ (unless (eq class other-class)
+ (pushnew other-class (class-incompatible-superclass-list class))))))
+
+(defun superclasses-compatible-p (class1 class2)
+ (let ((cpl1 (class-precedence-list class1))
+ (cpl2 (class-precedence-list class2)))
+ (dolist (sc1 cpl1 t)
+ (dolist (ic (class-incompatible-superclass-list sc1))
+ (when (memq ic cpl2)
+ (return-from superclasses-compatible-p nil))))))
+
+(mapc
+ #'proclaim-incompatible-superclasses
+ '(;; superclass class
+ (built-in-class std-class structure-class) ; direct subclasses of pcl-class
+ (standard-class funcallable-standard-class)
+ ;; superclass metaobject
+ (class eql-specializer class-eq-specializer method method-combination
+ generic-function slot-definition)
+ ;; metaclass built-in-class
+ (number sequence character ; direct subclasses of t, but not array
+ standard-object structure-object) ; or symbol
+ (number array character symbol ; direct subclasses of t, but not
+ standard-object structure-object) ; sequence
+ (complex float rational) ; direct subclasses of number
+ (integer ratio) ; direct subclasses of rational
+ (list vector) ; direct subclasses of sequence
+ (cons null) ; direct subclasses of list
+ (string bit-vector) ; direct subclasses of vector
+ ))
+\f
+(defmethod same-specializer-p ((specl1 specializer) (specl2 specializer))
+ nil)
+
+(defmethod same-specializer-p ((specl1 class) (specl2 class))
+ (eq specl1 specl2))
+
+(defmethod specializer-class ((specializer class))
+ specializer)
+
+(defmethod same-specializer-p ((specl1 class-eq-specializer)
+ (specl2 class-eq-specializer))
+ (eq (specializer-class specl1) (specializer-class specl2)))
+
+(defmethod same-specializer-p ((specl1 eql-specializer)
+ (specl2 eql-specializer))
+ (eq (specializer-object specl1) (specializer-object specl2)))
+
+(defmethod specializer-class ((specializer eql-specializer))
+ (class-of (slot-value specializer 'object)))
+
+(defvar *in-gf-arg-info-p* nil)
+(setf (gdefinition 'arg-info-reader)
+ (let ((mf (initialize-method-function
+ (make-internal-reader-method-function
+ 'standard-generic-function 'arg-info)
+ t)))
+ #'(lambda (&rest args) (funcall mf args nil))))
+
+(defun types-from-arguments (generic-function arguments
+ &optional type-modifier)
+ (multiple-value-bind (nreq applyp metatypes nkeys arg-info)
+ (get-generic-function-info generic-function)
+ (declare (ignore applyp metatypes nkeys))
+ (let ((types-rev nil))
+ (dotimes-fixnum (i nreq)
+ i
+ (unless arguments
+ (error "The function ~S requires at least ~D arguments"
+ (generic-function-name generic-function)
+ nreq))
+ (let ((arg (pop arguments)))
+ (push (if type-modifier `(,type-modifier ,arg) arg) types-rev)))
+ (values (nreverse types-rev) arg-info))))
+
+(defun get-wrappers-from-classes (nkeys wrappers classes metatypes)
+ (let* ((w wrappers) (w-tail w) (mt-tail metatypes))
+ (dolist (class (if (listp classes) classes (list classes)))
+ (unless (eq 't (car mt-tail))
+ (let ((c-w (class-wrapper class)))
+ (unless c-w (return-from get-wrappers-from-classes nil))
+ (if (eql nkeys 1)
+ (setq w c-w)
+ (setf (car w-tail) c-w
+ w-tail (cdr w-tail)))))
+ (setq mt-tail (cdr mt-tail)))
+ w))
+
+(defun sdfun-for-caching (gf classes)
+ (let ((types (mapcar #'class-eq-type classes)))
+ (multiple-value-bind (methods all-applicable-and-sorted-p)
+ (compute-applicable-methods-using-types gf types)
+ (function-funcall (get-secondary-dispatch-function1
+ gf methods types nil t all-applicable-and-sorted-p)
+ nil (mapcar #'class-wrapper classes)))))
+
+(defun value-for-caching (gf classes)
+ (let ((methods (compute-applicable-methods-using-types
+ gf (mapcar #'class-eq-type classes))))
+ (method-function-get (or (method-fast-function (car methods))
+ (method-function (car methods)))
+ :constant-value)))
+
+(defun default-secondary-dispatch-function (generic-function)
+ #'(lambda (&rest args)
+ (let ((methods (compute-applicable-methods generic-function args)))
+ (if methods
+ (let ((emf (get-effective-method-function generic-function
+ methods)))
+ (invoke-emf emf args))
+ (apply #'no-applicable-method generic-function args)))))
+
+(defun list-eq (x y)
+ (loop (when (atom x) (return (eq x y)))
+ (when (atom y) (return nil))
+ (unless (eq (car x) (car y)) (return nil))
+ (setq x (cdr x) y (cdr y))))
+
+(defvar *std-cam-methods* nil)
+
+(defun compute-applicable-methods-emf (generic-function)
+ (if (eq *boot-state* 'complete)
+ (let* ((cam (gdefinition 'compute-applicable-methods))
+ (cam-methods (compute-applicable-methods-using-types
+ cam (list `(eql ,generic-function) t))))
+ (values (get-effective-method-function cam cam-methods)
+ (list-eq cam-methods
+ (or *std-cam-methods*
+ (setq *std-cam-methods*
+ (compute-applicable-methods-using-types
+ cam (list `(eql ,cam) t)))))))
+ (values #'compute-applicable-methods-function t)))
+
+(defun compute-applicable-methods-emf-std-p (gf)
+ (gf-info-c-a-m-emf-std-p (gf-arg-info gf)))
+
+(defvar *old-c-a-m-gf-methods* nil)
+
+(defun update-all-c-a-m-gf-info (c-a-m-gf)
+ (let ((methods (generic-function-methods c-a-m-gf)))
+ (if (and *old-c-a-m-gf-methods*
+ (every #'(lambda (old-method)
+ (member old-method methods))
+ *old-c-a-m-gf-methods*))
+ (let ((gfs-to-do nil)
+ (gf-classes-to-do nil))
+ (dolist (method methods)
+ (unless (member method *old-c-a-m-gf-methods*)
+ (let ((specl (car (method-specializers method))))
+ (if (eql-specializer-p specl)
+ (pushnew (specializer-object specl) gfs-to-do)
+ (pushnew (specializer-class specl) gf-classes-to-do)))))
+ (map-all-generic-functions
+ #'(lambda (gf)
+ (when (or (member gf gfs-to-do)
+ (dolist (class gf-classes-to-do nil)
+ (member class
+ (class-precedence-list (class-of gf)))))
+ (update-c-a-m-gf-info gf)))))
+ (map-all-generic-functions #'update-c-a-m-gf-info))
+ (setq *old-c-a-m-gf-methods* methods)))
+
+(defun update-gf-info (gf)
+ (update-c-a-m-gf-info gf)
+ (update-gf-simple-accessor-type gf))
+
+(defun update-c-a-m-gf-info (gf)
+ (unless (early-gf-p gf)
+ (multiple-value-bind (c-a-m-emf std-p)
+ (compute-applicable-methods-emf gf)
+ (let ((arg-info (gf-arg-info gf)))
+ (setf (gf-info-static-c-a-m-emf arg-info) c-a-m-emf)
+ (setf (gf-info-c-a-m-emf-std-p arg-info) std-p)))))
+
+(defun update-gf-simple-accessor-type (gf)
+ (let ((arg-info (gf-arg-info gf)))
+ (setf (gf-info-simple-accessor-type arg-info)
+ (let* ((methods (generic-function-methods gf))
+ (class (and methods (class-of (car methods))))
+ (type (and class
+ (cond ((eq class
+ *the-class-standard-reader-method*)
+ 'reader)
+ ((eq class
+ *the-class-standard-writer-method*)
+ 'writer)
+ ((eq class
+ *the-class-standard-boundp-method*)
+ 'boundp)))))
+ (when (and (gf-info-c-a-m-emf-std-p arg-info)
+ type
+ (dolist (method (cdr methods) t)
+ (unless (eq class (class-of method)) (return nil)))
+ (eq (generic-function-method-combination gf)
+ *standard-method-combination*))
+ type)))))
+
+(defun get-accessor-method-function (gf type class slotd)
+ (let* ((std-method (standard-svuc-method type))
+ (str-method (structure-svuc-method type))
+ (types1 `((eql ,class) (class-eq ,class) (eql ,slotd)))
+ (types (if (eq type 'writer) `(t ,@types1) types1))
+ (methods (compute-applicable-methods-using-types gf types))
+ (std-p (null (cdr methods))))
+ (values
+ (if std-p
+ (get-optimized-std-accessor-method-function class slotd type)
+ (get-accessor-from-svuc-method-function
+ class slotd
+ (get-secondary-dispatch-function
+ gf methods types
+ `((,(car (or (member std-method methods)
+ (member str-method methods)
+ (error "error in get-accessor-method-function")))
+ ,(get-optimized-std-slot-value-using-class-method-function
+ class slotd type)))
+ (unless (and (eq type 'writer)
+ (dolist (method methods t)
+ (unless (eq (car (method-specializers method))
+ *the-class-t*)
+ (return nil))))
+ (let ((wrappers (list (wrapper-of class)
+ (class-wrapper class)
+ (wrapper-of slotd))))
+ (if (eq type 'writer)
+ (cons (class-wrapper *the-class-t*) wrappers)
+ wrappers))))
+ type))
+ std-p)))
+
+;;; used by OPTIMIZE-SLOT-VALUE-BY-CLASS-P (vector.lisp)
+(defun update-slot-value-gf-info (gf type)
+ (unless *new-class*
+ (update-std-or-str-methods gf type))
+ (when (and (standard-svuc-method type) (structure-svuc-method type))
+ (flet ((update-class (class)
+ (when (class-finalized-p class)
+ (dolist (slotd (class-slots class))
+ (compute-slot-accessor-info slotd type gf)))))
+ (if *new-class*
+ (update-class *new-class*)
+ (map-all-classes #'update-class 'slot-object)))))
+
+(defvar *standard-slot-value-using-class-method* nil)
+(defvar *standard-setf-slot-value-using-class-method* nil)
+(defvar *standard-slot-boundp-using-class-method* nil)
+(defvar *structure-slot-value-using-class-method* nil)
+(defvar *structure-setf-slot-value-using-class-method* nil)
+(defvar *structure-slot-boundp-using-class-method* nil)
+
+(defun standard-svuc-method (type)
+ (case type
+ (reader *standard-slot-value-using-class-method*)
+ (writer *standard-setf-slot-value-using-class-method*)
+ (boundp *standard-slot-boundp-using-class-method*)))
+
+(defun set-standard-svuc-method (type method)
+ (case type
+ (reader (setq *standard-slot-value-using-class-method* method))
+ (writer (setq *standard-setf-slot-value-using-class-method* method))
+ (boundp (setq *standard-slot-boundp-using-class-method* method))))
+
+(defun structure-svuc-method (type)
+ (case type
+ (reader *structure-slot-value-using-class-method*)
+ (writer *structure-setf-slot-value-using-class-method*)
+ (boundp *structure-slot-boundp-using-class-method*)))
+
+(defun set-structure-svuc-method (type method)
+ (case type
+ (reader (setq *structure-slot-value-using-class-method* method))
+ (writer (setq *structure-setf-slot-value-using-class-method* method))
+ (boundp (setq *structure-slot-boundp-using-class-method* method))))
+
+(defun update-std-or-str-methods (gf type)
+ (dolist (method (generic-function-methods gf))
+ (let ((specls (method-specializers method)))
+ (when (and (or (not (eq type 'writer))
+ (eq (pop specls) *the-class-t*))
+ (every #'classp specls))
+ (cond ((and (eq (class-name (car specls))
+ 'std-class)
+ (eq (class-name (cadr specls))
+ 'std-object)
+ (eq (class-name (caddr specls))
+ 'standard-effective-slot-definition))
+ (set-standard-svuc-method type method))
+ ((and (eq (class-name (car specls))
+ 'structure-class)
+ (eq (class-name (cadr specls))
+ 'structure-object)
+ (eq (class-name (caddr specls))
+ 'structure-effective-slot-definition))
+ (set-structure-svuc-method type method)))))))
+
+(defun mec-all-classes-internal (spec precompute-p)
+ (cons (specializer-class spec)
+ (and (classp spec)
+ precompute-p
+ (not (or (eq spec *the-class-t*)
+ (eq spec *the-class-slot-object*)
+ (eq spec *the-class-std-object*)
+ (eq spec *the-class-standard-object*)
+ (eq spec *the-class-structure-object*)))
+ (let ((sc (class-direct-subclasses spec)))
+ (when sc
+ (mapcan #'(lambda (class)
+ (mec-all-classes-internal class precompute-p))
+ sc))))))
+
+(defun mec-all-classes (spec precompute-p)
+ (let ((classes (mec-all-classes-internal spec precompute-p)))
+ (if (null (cdr classes))
+ classes
+ (let* ((a-classes (cons nil classes))
+ (tail classes))
+ (loop (when (null (cdr tail))
+ (return (cdr a-classes)))
+ (let ((class (cadr tail))
+ (ttail (cddr tail)))
+ (if (dolist (c ttail nil)
+ (when (eq class c) (return t)))
+ (setf (cdr tail) (cddr tail))
+ (setf tail (cdr tail)))))))))
+
+(defun mec-all-class-lists (spec-list precompute-p)
+ (if (null spec-list)
+ (list nil)
+ (let* ((car-all-classes (mec-all-classes (car spec-list)
+ precompute-p))
+ (all-class-lists (mec-all-class-lists (cdr spec-list)
+ precompute-p)))
+ (mapcan #'(lambda (list)
+ (mapcar #'(lambda (c) (cons c list)) car-all-classes))
+ all-class-lists))))
+
+(defun make-emf-cache (generic-function valuep cache classes-list new-class)
+ (let* ((arg-info (gf-arg-info generic-function))
+ (nkeys (arg-info-nkeys arg-info))
+ (metatypes (arg-info-metatypes arg-info))
+ (wrappers (unless (eq nkeys 1) (make-list nkeys)))
+ (precompute-p (gf-precompute-dfun-and-emf-p arg-info))
+ (default '(default)))
+ (flet ((add-class-list (classes)
+ (when (or (null new-class) (memq new-class classes))
+ (let ((wrappers (get-wrappers-from-classes
+ nkeys wrappers classes metatypes)))
+ (when (and wrappers
+ (eq default (probe-cache cache wrappers default)))
+ (let ((value (cond ((eq valuep t)
+ (sdfun-for-caching generic-function
+ classes))
+ ((eq valuep :constant-value)
+ (value-for-caching generic-function
+ classes)))))
+ (setq cache (fill-cache cache wrappers value t))))))))
+ (if classes-list
+ (mapc #'add-class-list classes-list)
+ (dolist (method (generic-function-methods generic-function))
+ (mapc #'add-class-list
+ (mec-all-class-lists (method-specializers method)
+ precompute-p))))
+ cache)))
+
+(defmacro class-test (arg class)
+ (cond ((eq class *the-class-t*)
+ 't)
+ ((eq class *the-class-slot-object*)
+ `(not (cl:typep (cl:class-of ,arg) 'cl:built-in-class)))
+ ((eq class *the-class-std-object*)
+ `(or (std-instance-p ,arg) (fsc-instance-p ,arg)))
+ ((eq class *the-class-standard-object*)
+ `(std-instance-p ,arg))
+ ((eq class *the-class-funcallable-standard-object*)
+ `(fsc-instance-p ,arg))
+ (t
+ `(typep ,arg ',(class-name class)))))
+
+(defmacro class-eq-test (arg class)
+ `(eq (class-of ,arg) ',class))
+
+(defmacro eql-test (arg object)
+ `(eql ,arg ',object))
+
+(defun dnet-methods-p (form)
+ (and (consp form)
+ (or (eq (car form) 'methods)
+ (eq (car form) 'unordered-methods))))
+
+;;; This is CASE, but without gensyms.
+(defmacro scase (arg &rest clauses)
+ `(let ((.case-arg. ,arg))
+ (cond ,@(mapcar #'(lambda (clause)
+ (list* (cond ((null (car clause))
+ nil)
+ ((consp (car clause))
+ (if (null (cdar clause))
+ `(eql .case-arg.
+ ',(caar clause))
+ `(member .case-arg.
+ ',(car clause))))
+ ((member (car clause) '(t otherwise))
+ `t)
+ (t
+ `(eql .case-arg. ',(car clause))))
+ nil
+ (cdr clause)))
+ clauses))))
+
+(defmacro mcase (arg &rest clauses) `(scase ,arg ,@clauses))
+
+(defun generate-discrimination-net (generic-function methods types sorted-p)
+ (let* ((arg-info (gf-arg-info generic-function))
+ (precedence (arg-info-precedence arg-info)))
+ (generate-discrimination-net-internal
+ generic-function methods types
+ #'(lambda (methods known-types)
+ (if (or sorted-p
+ (block one-order-p
+ (let ((sorted-methods nil))
+ (map-all-orders
+ (copy-list methods) precedence
+ #'(lambda (methods)
+ (when sorted-methods (return-from one-order-p nil))
+ (setq sorted-methods methods)))
+ (setq methods sorted-methods))
+ t))
+ `(methods ,methods ,known-types)
+ `(unordered-methods ,methods ,known-types)))
+ #'(lambda (position type true-value false-value)
+ (let ((arg (dfun-arg-symbol position)))
+ (if (eq (car type) 'eql)
+ (let* ((false-case-p (and (consp false-value)
+ (or (eq (car false-value) 'scase)
+ (eq (car false-value) 'mcase))
+ (eq arg (cadr false-value))))
+ (false-clauses (if false-case-p
+ (cddr false-value)
+ `((t ,false-value))))
+ (case-sym (if (and (dnet-methods-p true-value)
+ (if false-case-p
+ (eq (car false-value) 'mcase)
+ (dnet-methods-p false-value)))
+ 'mcase
+ 'scase))
+ (type-sym `(,(cadr type))))
+ `(,case-sym ,arg
+ (,type-sym ,true-value)
+ ,@false-clauses))
+ `(if ,(let ((arg (dfun-arg-symbol position)))
+ (case (car type)
+ (class `(class-test ,arg ,(cadr type)))
+ (class-eq `(class-eq-test ,arg ,(cadr type)))))
+ ,true-value
+ ,false-value))))
+ #'identity)))
+
+(defun class-from-type (type)
+ (if (or (atom type) (eq (car type) 't))
+ *the-class-t*
+ (case (car type)
+ (and (dolist (type (cdr type) *the-class-t*)
+ (when (and (consp type) (not (eq (car type) 'not)))
+ (return (class-from-type type)))))
+ (not *the-class-t*)
+ (eql (class-of (cadr type)))
+ (class-eq (cadr type))
+ (class (cadr type)))))
+
+(defun precompute-effective-methods (gf caching-p &optional classes-list-p)
+ (let* ((arg-info (gf-arg-info gf))
+ (methods (generic-function-methods gf))
+ (precedence (arg-info-precedence arg-info))
+ (*in-precompute-effective-methods-p* t)
+ (classes-list nil))
+ (generate-discrimination-net-internal
+ gf methods nil
+ #'(lambda (methods known-types)
+ (when methods
+ (when classes-list-p
+ (push (mapcar #'class-from-type known-types) classes-list))
+ (let ((no-eql-specls-p (not (methods-contain-eql-specializer-p
+ methods))))
+ (map-all-orders
+ methods precedence
+ #'(lambda (methods)
+ (get-secondary-dispatch-function1
+ gf methods known-types
+ nil caching-p no-eql-specls-p))))))
+ #'(lambda (position type true-value false-value)
+ (declare (ignore position type true-value false-value))
+ nil)
+ #'(lambda (type)
+ (if (and (consp type) (eq (car type) 'eql))
+ `(class-eq ,(class-of (cadr type)))
+ type)))
+ classes-list))
+
+;;; We know that known-type implies neither new-type nor `(not ,new-type).
+(defun augment-type (new-type known-type)
+ (if (or (eq known-type 't)
+ (eq (car new-type) 'eql))
+ new-type
+ (let ((so-far (if (and (consp known-type) (eq (car known-type) 'and))
+ (cdr known-type)
+ (list known-type))))
+ (unless (eq (car new-type) 'not)
+ (setq so-far
+ (mapcan #'(lambda (type)
+ (unless (*subtypep new-type type)
+ (list type)))
+ so-far)))
+ (if (null so-far)
+ new-type
+ `(and ,new-type ,@so-far)))))
+
+(defun generate-discrimination-net-internal
+ (gf methods types methods-function test-function type-function)
+ (let* ((arg-info (gf-arg-info gf))
+ (precedence (arg-info-precedence arg-info))
+ (nreq (arg-info-number-required arg-info))
+ (metatypes (arg-info-metatypes arg-info)))
+ (labels ((do-column (p-tail contenders known-types)
+ (if p-tail
+ (let* ((position (car p-tail))
+ (known-type (or (nth position types) t)))
+ (if (eq (nth position metatypes) 't)
+ (do-column (cdr p-tail) contenders
+ (cons (cons position known-type)
+ known-types))
+ (do-methods p-tail contenders
+ known-type () known-types)))
+ (funcall methods-function contenders
+ (let ((k-t (make-list nreq)))
+ (dolist (index+type known-types)
+ (setf (nth (car index+type) k-t)
+ (cdr index+type)))
+ k-t))))
+ (do-methods (p-tail contenders known-type winners known-types)
+ ;; CONTENDERS
+ ;; is a (sorted) list of methods that must be discriminated.
+ ;; KNOWN-TYPE
+ ;; is the type of this argument, constructed from tests
+ ;; already made.
+ ;; WINNERS
+ ;; is a (sorted) list of methods that are potentially
+ ;; applicable after the discrimination has been made.
+ (if (null contenders)
+ (do-column (cdr p-tail)
+ winners
+ (cons (cons (car p-tail) known-type)
+ known-types))
+ (let* ((position (car p-tail))
+ (method (car contenders))
+ (specl (nth position (method-specializers method)))
+ (type (funcall type-function
+ (type-from-specializer specl))))
+ (multiple-value-bind (app-p maybe-app-p)
+ (specializer-applicable-using-type-p type known-type)
+ (flet ((determined-to-be (truth-value)
+ (if truth-value app-p (not maybe-app-p)))
+ (do-if (truth &optional implied)
+ (let ((ntype (if truth type `(not ,type))))
+ (do-methods p-tail
+ (cdr contenders)
+ (if implied
+ known-type
+ (augment-type ntype known-type))
+ (if truth
+ (append winners `(,method))
+ winners)
+ known-types))))
+ (cond ((determined-to-be nil) (do-if nil t))
+ ((determined-to-be t) (do-if t t))
+ (t (funcall test-function position type
+ (do-if t) (do-if nil))))))))))
+ (do-column precedence methods ()))))
+
+(defun compute-secondary-dispatch-function (generic-function net &optional
+ method-alist wrappers)
+ (function-funcall (compute-secondary-dispatch-function1 generic-function net)
+ method-alist wrappers))
+
+(defvar *eq-case-table-limit* 15)
+(defvar *case-table-limit* 10)
+
+(defun compute-mcase-parameters (case-list)
+ (unless (eq 't (caar (last case-list)))
+ (error "The key for the last case arg to mcase was not T"))
+ (let* ((eq-p (dolist (case case-list t)
+ (unless (or (eq (car case) 't)
+ (symbolp (caar case)))
+ (return nil))))
+ (len (1- (length case-list)))
+ (type (cond ((= len 1)
+ :simple)
+ ((<= len
+ (if eq-p
+ *eq-case-table-limit*
+ *case-table-limit*))
+ :assoc)
+ (t
+ :hash-table))))
+ (list eq-p type)))
+
+(defmacro mlookup (key info default &optional eq-p type)
+ (unless (or (eq eq-p 't) (null eq-p))
+ (error "Invalid eq-p argument"))
+ (ecase type
+ (:simple
+ `(if (,(if eq-p 'eq 'eql) ,key (car ,info))
+ (cdr ,info)
+ ,default))
+ (:assoc
+ `(dolist (e ,info ,default)
+ (when (,(if eq-p 'eq 'eql) (car e) ,key)
+ (return (cdr e)))))
+ (:hash-table
+ `(gethash ,key ,info ,default))))
+
+(defun net-test-converter (form)
+ (if (atom form)
+ (default-test-converter form)
+ (case (car form)
+ ((invoke-effective-method-function invoke-fast-method-call)
+ '.call.)
+ (methods
+ '.methods.)
+ (unordered-methods
+ '.umethods.)
+ (mcase
+ `(mlookup ,(cadr form)
+ nil
+ nil
+ ,@(compute-mcase-parameters (cddr form))))
+ (t (default-test-converter form)))))
+
+(defun net-code-converter (form)
+ (if (atom form)
+ (default-code-converter form)
+ (case (car form)
+ ((methods unordered-methods)
+ (let ((gensym (gensym)))
+ (values gensym
+ (list gensym))))
+ (mcase
+ (let ((mp (compute-mcase-parameters (cddr form)))
+ (gensym (gensym)) (default (gensym)))
+ (values `(mlookup ,(cadr form) ,gensym ,default ,@mp)
+ (list gensym default))))
+ (t
+ (default-code-converter form)))))
+
+(defun net-constant-converter (form generic-function)
+ (or (let ((c (methods-converter form generic-function)))
+ (when c (list c)))
+ (if (atom form)
+ (default-constant-converter form)
+ (case (car form)
+ (mcase
+ (let* ((mp (compute-mcase-parameters (cddr form)))
+ (list (mapcar #'(lambda (clause)
+ (let ((key (car clause))
+ (meth (cadr clause)))
+ (cons (if (consp key) (car key) key)
+ (methods-converter
+ meth generic-function))))
+ (cddr form)))
+ (default (car (last list))))
+ (list (list* ':mcase mp (nbutlast list))
+ (cdr default))))
+ (t
+ (default-constant-converter form))))))
+
+(defun methods-converter (form generic-function)
+ (cond ((and (consp form) (eq (car form) 'methods))
+ (cons '.methods.
+ (get-effective-method-function1 generic-function (cadr form))))
+ ((and (consp form) (eq (car form) 'unordered-methods))
+ (default-secondary-dispatch-function generic-function))))
+
+(defun convert-methods (constant method-alist wrappers)
+ (if (and (consp constant)
+ (eq (car constant) '.methods.))
+ (funcall (cdr constant) method-alist wrappers)
+ constant))
+
+(defun convert-table (constant method-alist wrappers)
+ (cond ((and (consp constant)
+ (eq (car constant) ':mcase))
+ (let ((alist (mapcar #'(lambda (k+m)
+ (cons (car k+m)
+ (convert-methods (cdr k+m)
+ method-alist
+ wrappers)))
+ (cddr constant)))
+ (mp (cadr constant)))
+ (ecase (cadr mp)
+ (:simple
+ (car alist))
+ (:assoc
+ alist)
+ (:hash-table
+ (let ((table (make-hash-table :test (if (car mp) 'eq 'eql))))
+ (dolist (k+m alist)
+ (setf (gethash (car k+m) table) (cdr k+m)))
+ table)))))))
+
+(defun compute-secondary-dispatch-function1 (generic-function net
+ &optional function-p)
+ (cond
+ ((and (eq (car net) 'methods) (not function-p))
+ (get-effective-method-function1 generic-function (cadr net)))
+ (t
+ (let* ((name (generic-function-name generic-function))
+ (arg-info (gf-arg-info generic-function))
+ (metatypes (arg-info-metatypes arg-info))
+ (applyp (arg-info-applyp arg-info))
+ (fmc-arg-info (cons (length metatypes) applyp))
+ (arglist (if function-p
+ (make-dfun-lambda-list metatypes applyp)
+ (make-fast-method-call-lambda-list metatypes applyp))))
+ (multiple-value-bind (cfunction constants)
+ (get-function1 `(,(if function-p
+ 'sb-kernel:instance-lambda
+ 'lambda)
+ ,arglist
+ ,@(unless function-p
+ `((declare (ignore .pv-cell.
+ .next-method-call.))))
+ (locally (declare #.*optimize-speed*)
+ (let ((emf ,net))
+ ,(make-emf-call metatypes applyp 'emf))))
+ #'net-test-converter
+ #'net-code-converter
+ #'(lambda (form)
+ (net-constant-converter form generic-function)))
+ #'(lambda (method-alist wrappers)
+ (let* ((alist (list nil))
+ (alist-tail alist))
+ (dolist (constant constants)
+ (let* ((a (or (dolist (a alist nil)
+ (when (eq (car a) constant)
+ (return a)))
+ (cons constant
+ (or (convert-table
+ constant method-alist wrappers)
+ (convert-methods
+ constant method-alist wrappers)))))
+ (new (list a)))
+ (setf (cdr alist-tail) new)
+ (setf alist-tail new)))
+ (let ((function (apply cfunction (mapcar #'cdr (cdr alist)))))
+ (if function-p
+ function
+ (make-fast-method-call
+ :function (set-function-name function
+ `(sdfun-method ,name))
+ :arg-info fmc-arg-info))))))))))
+
+(defvar *show-make-unordered-methods-emf-calls* nil)
+
+(defun make-unordered-methods-emf (generic-function methods)
+ (when *show-make-unordered-methods-emf-calls*
+ (format t "~&make-unordered-methods-emf ~S~%"
+ (generic-function-name generic-function)))
+ #'(lambda (&rest args)
+ (let* ((types (types-from-arguments generic-function args 'eql))
+ (smethods (sort-applicable-methods generic-function
+ methods
+ types))
+ (emf (get-effective-method-function generic-function smethods)))
+ (invoke-emf emf args))))
+\f
+;;; The value returned by compute-discriminating-function is a function
+;;; object. It is called a discriminating function because it is called
+;;; when the generic function is called and its role is to discriminate
+;;; on the arguments to the generic function and then call appropriate
+;;; method functions.
+;;;
+;;; A discriminating function can only be called when it is installed as
+;;; the funcallable instance function of the generic function for which
+;;; it was computed.
+;;;
+;;; More precisely, if compute-discriminating-function is called with an
+;;; argument <gf1>, and returns a result <df1>, that result must not be
+;;; passed to apply or funcall directly. Rather, <df1> must be stored as
+;;; the funcallable instance function of the same generic function <gf1>
+;;; (using set-funcallable-instance-function). Then the generic function
+;;; can be passed to funcall or apply.
+;;;
+;;; An important exception is that methods on this generic function are
+;;; permitted to return a function which itself ends up calling the value
+;;; returned by a more specific method. This kind of `encapsulation' of
+;;; discriminating function is critical to many uses of the MOP.
+;;;
+;;; As an example, the following canonical case is legal:
+;;;
+;;; (defmethod compute-discriminating-function ((gf my-generic-function))
+;;; (let ((std (call-next-method)))
+;;; #'(lambda (arg)
+;;; (print (list 'call-to-gf gf arg))
+;;; (funcall std arg))))
+;;;
+;;; Because many discriminating functions would like to use a dynamic
+;;; strategy in which the precise discriminating function changes with
+;;; time it is important to specify how a discriminating function is
+;;; permitted itself to change the funcallable instance function of the
+;;; generic function.
+;;;
+;;; Discriminating functions may set the funcallable instance function
+;;; of the generic function, but the new value must be generated by making
+;;; a call to COMPUTE-DISCRIMINATING-FUNCTION. This is to ensure that any
+;;; more specific methods which may have encapsulated the discriminating
+;;; function will get a chance to encapsulate the new, inner discriminating
+;;; function.
+;;;
+;;; This implies that if a discriminating function wants to modify itself
+;;; it should first store some information in the generic function proper,
+;;; and then call compute-discriminating-function. The appropriate method
+;;; on compute-discriminating-function will see the information stored in
+;;; the generic function and generate a discriminating function accordingly.
+;;;
+;;; The following is an example of a discriminating function which modifies
+;;; itself in accordance with this protocol:
+;;;
+;;; (defmethod compute-discriminating-function ((gf my-generic-function))
+;;; #'(lambda (arg)
+;;; (cond (<some condition>
+;;; <store some info in the generic function>
+;;; (set-funcallable-instance-function
+;;; gf
+;;; (compute-discriminating-function gf))
+;;; (funcall gf arg))
+;;; (t
+;;; <call-a-method-of-gf>))))
+;;;
+;;; Whereas this code would not be legal:
+;;;
+;;; (defmethod compute-discriminating-function ((gf my-generic-function))
+;;; #'(lambda (arg)
+;;; (cond (<some condition>
+;;; (set-funcallable-instance-function
+;;; gf
+;;; #'(lambda (a) ..))
+;;; (funcall gf arg))
+;;; (t
+;;; <call-a-method-of-gf>))))
+;;;
+;;; NOTE: All the examples above assume that all instances of the class
+;;; my-generic-function accept only one argument.
+
+(defun slot-value-using-class-dfun (class object slotd)
+ (declare (ignore class))
+ (function-funcall (slot-definition-reader-function slotd) object))
+
+(defun setf-slot-value-using-class-dfun (new-value class object slotd)
+ (declare (ignore class))
+ (function-funcall (slot-definition-writer-function slotd) new-value object))
+
+(defun slot-boundp-using-class-dfun (class object slotd)
+ (declare (ignore class))
+ (function-funcall (slot-definition-boundp-function slotd) object))
+
+(defmethod compute-discriminating-function ((gf standard-generic-function))
+ (with-slots (dfun-state arg-info) gf
+ (typecase dfun-state
+ (null (let ((name (generic-function-name gf)))
+ (when (eq name 'compute-applicable-methods)
+ (update-all-c-a-m-gf-info gf))
+ (cond ((eq name 'slot-value-using-class)
+ (update-slot-value-gf-info gf 'reader)
+ #'slot-value-using-class-dfun)
+ ((equal name '(setf slot-value-using-class))
+ (update-slot-value-gf-info gf 'writer)
+ #'setf-slot-value-using-class-dfun)
+ ((eq name 'slot-boundp-using-class)
+ (update-slot-value-gf-info gf 'boundp)
+ #'slot-boundp-using-class-dfun)
+ ((gf-precompute-dfun-and-emf-p arg-info)
+ (make-final-dfun gf))
+ (t
+ (make-initial-dfun gf)))))
+ (function dfun-state)
+ (cons (car dfun-state)))))
+
+(defmethod update-gf-dfun ((class std-class) gf)
+ (let ((*new-class* class)
+ #|| (name (generic-function-name gf)) ||#
+ (arg-info (gf-arg-info gf)))
+ (cond #||
+ ((eq name 'slot-value-using-class)
+ (update-slot-value-gf-info gf 'reader))
+ ((equal name '(setf slot-value-using-class))
+ (update-slot-value-gf-info gf 'writer))
+ ((eq name 'slot-boundp-using-class)
+ (update-slot-value-gf-info gf 'boundp))
+ ||#
+ ((gf-precompute-dfun-and-emf-p arg-info)
+ (multiple-value-bind (dfun cache info)
+ (make-final-dfun-internal gf)
+ (set-dfun gf dfun cache info) ; lest the cache be freed twice
+ (update-dfun gf dfun cache info))))))
+\f
+(defmethod function-keywords ((method standard-method))
+ (multiple-value-bind (nreq nopt keysp restp allow-other-keys-p keywords)
+ (analyze-lambda-list (if (consp method)
+ (early-method-lambda-list method)
+ (method-lambda-list method)))
+ (declare (ignore nreq nopt keysp restp))
+ (values keywords allow-other-keys-p)))
+
+(defun method-ll->generic-function-ll (ll)
+ (multiple-value-bind
+ (nreq nopt keysp restp allow-other-keys-p keywords keyword-parameters)
+ (analyze-lambda-list ll)
+ (declare (ignore nreq nopt keysp restp allow-other-keys-p keywords))
+ (remove-if #'(lambda (s)
+ (or (memq s keyword-parameters)
+ (eq s '&allow-other-keys)))
+ ll)))
+\f
+;;; This is based on the rules of method lambda list congruency defined in
+;;; the spec. The lambda list it constructs is the pretty union of the
+;;; lambda lists of all the methods. It doesn't take method applicability
+;;; into account at all yet.
+(defmethod generic-function-pretty-arglist
+ ((generic-function standard-generic-function))
+ (let ((methods (generic-function-methods generic-function))
+ (arglist ()))
+ (when methods
+ (multiple-value-bind (required optional rest key allow-other-keys)
+ (method-pretty-arglist (car methods))
+ (dolist (m (cdr methods))
+ (multiple-value-bind (method-key-keywords
+ method-allow-other-keys
+ method-key)
+ (function-keywords m)
+ ;; we've modified function-keywords to return what we want as
+ ;; the third value, no other change here.
+ (declare (ignore method-key-keywords))
+ (setq key (union key method-key))
+ (setq allow-other-keys (or allow-other-keys
+ method-allow-other-keys))))
+ (when allow-other-keys
+ (setq arglist '(&allow-other-keys)))
+ (when key
+ (setq arglist (nconc (list '&key) key arglist)))
+ (when rest
+ (setq arglist (nconc (list '&rest rest) arglist)))
+ (when optional
+ (setq arglist (nconc (list '&optional) optional arglist)))
+ (nconc required arglist)))))
+
+(defmethod method-pretty-arglist ((method standard-method))
+ (let ((required ())
+ (optional ())
+ (rest nil)
+ (key ())
+ (allow-other-keys nil)
+ (state 'required)
+ (arglist (method-lambda-list method)))
+ (dolist (arg arglist)
+ (cond ((eq arg '&optional) (setq state 'optional))
+ ((eq arg '&rest) (setq state 'rest))
+ ((eq arg '&key) (setq state 'key))
+ ((eq arg '&allow-other-keys) (setq allow-other-keys 't))
+ ((memq arg lambda-list-keywords))
+ (t
+ (ecase state
+ (required (push arg required))
+ (optional (push arg optional))
+ (key (push arg key))
+ (rest (setq rest arg))))))
+ (values (nreverse required)
+ (nreverse optional)
+ rest
+ (nreverse key)
+ allow-other-keys)))
+
--- /dev/null
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+
+;;;; This software is derived from software originally released by Xerox
+;;;; Corporation. Copyright and release statements follow. Later modifications
+;;;; to the software are in the public domain and are provided with
+;;;; absolutely no warranty. See the COPYING and CREDITS files for more
+;;;; information.
+
+;;;; copyright information from original PCL sources:
+;;;;
+;;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
+;;;; All rights reserved.
+;;;;
+;;;; Use and copying of this software and preparation of derivative works based
+;;;; upon this software are permitted. Any distribution of this software or
+;;;; derivative works must comply with all applicable United States export
+;;;; control laws.
+;;;;
+;;;; This software is made available AS IS, and Xerox Corporation makes no
+;;;; warranty about the software, its performance or its conformity to any
+;;;; specification.
+
+(in-package "SB-PCL")
+
+(sb-int:file-comment
+ "$Header$")
+\f
+;;; Pre-allocate generic function caches. The hope is that this will put
+;;; them nicely together in memory, and that that may be a win. Of course
+;;; the first gc copy will probably blow that out, this really wants to be
+;;; wrapped in something that declares the area static.
+;;;
+;;; This preallocation only creates about 25% more caches than PCL itself
+;;; uses need. Some ports may want to preallocate some more of these.
+(flet ((allocate (n size)
+ (mapcar #'free-cache-vector
+ (mapcar #'get-cache-vector
+ (make-list n :initial-element size)))))
+ (allocate 128 4)
+ (allocate 64 8)
+ (allocate 64 9)
+ (allocate 32 16)
+ (allocate 16 17)
+ (allocate 16 32)
+ (allocate 1 64))
--- /dev/null
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+
+;;;; This software is derived from software originally released by Xerox
+;;;; Corporation. Copyright and release statements follow. Later modifications
+;;;; to the software are in the public domain and are provided with
+;;;; absolutely no warranty. See the COPYING and CREDITS files for more
+;;;; information.
+
+;;;; copyright information from original PCL sources:
+;;;;
+;;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
+;;;; All rights reserved.
+;;;;
+;;;; Use and copying of this software and preparation of derivative works based
+;;;; upon this software are permitted. Any distribution of this software or
+;;;; derivative works must comply with all applicable United States export
+;;;; control laws.
+;;;;
+;;;; This software is made available AS IS, and Xerox Corporation makes no
+;;;; warranty about the software, its performance or its conformity to any
+;;;; specification.
+
+(in-package "SB-PCL")
+
+(sb-int:file-comment
+ "$Header$")
+
+(precompile-random-code-segments pcl)
--- /dev/null
+;;;; some basic PRINT-OBJECT functionality
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+
+;;;; This software is derived from software originally released by Xerox
+;;;; Corporation. Copyright and release statements follow. Later modifications
+;;;; to the software are in the public domain and are provided with
+;;;; absolutely no warranty. See the COPYING and CREDITS files for more
+;;;; information.
+
+;;;; Some of the text in this file was originally taken from various files of
+;;;; the PCL system from Xerox Corporation, which carried the following
+;;;; copyright information:
+;;;;
+;;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
+;;;; All rights reserved.
+;;;;
+;;;; Use and copying of this software and preparation of derivative works based
+;;;; upon this software are permitted. Any distribution of this software or
+;;;; derivative works must comply with all applicable United States export
+;;;; control laws.
+;;;;
+;;;; This software is made available AS IS, and Xerox Corporation makes no
+;;;; warranty about the software, its performance or its conformity to any
+;;;; specification.
+
+(sb-int:file-comment
+ "$Header$")
+
+(in-package "SB-PCL")
+\f
+;;;; the PRINT-OBJECT generic function
+
+;;; Blow away the old non-generic function placeholder which was used by the
+;;; printer doing bootstrapping, and immediately replace it with some new
+;;; printing logic, so that the Lisp printer stays crippled only for the
+;;; shortest necessary time.
+(let (;; (If we don't suppress /SHOW printing while the printer is
+ ;; crippled here, it becomes really easy to crash the bootstrap
+ ;; sequence by adding /SHOW statements e.g. to the compiler,
+ ;; which kinda defeats the purpose of /SHOW being a harmless
+ ;; tracing-style statement.)
+ #+sb-show (sb-int:*/show* nil))
+ (fmakunbound 'print-object)
+ (defgeneric print-object (object stream))
+ (defmethod print-object ((x t) stream)
+ (print-unreadable-object (x stream :type t :identity t))))
+\f
+;;;; a hook called by the printer to take care of dispatching to PRINT-OBJECT
+;;;; for appropriate FUNCALLABLE-INSTANCE objects
+
+;;; Now that CLOS is working, we can replace our old temporary placeholder code
+;;; for writing funcallable instances with permanent code:
+(defun sb-impl::printed-as-funcallable-standard-class (object stream)
+ (when (funcallable-standard-class-p (class-of object))
+ (print-object object stream)
+ t))
+\f
+;;;; PRINT-OBJECT methods for objects from PCL classes
+;;;;
+;;;; FIXME: Perhaps these should be moved back alongside the definitions of
+;;;; the classes they print. (Bootstrapping problems could be avoided by
+;;;; using DEF!METHOD to do this.)
+
+(defmethod print-object ((method standard-method) stream)
+ (print-unreadable-object (method stream :type t :identity t)
+ (if (slot-boundp method 'generic-function)
+ (let ((generic-function (method-generic-function method)))
+ (format stream "~S ~{~S ~}~:S"
+ (and generic-function
+ (generic-function-name generic-function))
+ (method-qualifiers method)
+ (unparse-specializers method)))
+ ;; FIXME: Why do we do CALL-NEXT-METHOD in this method (and
+ ;; in the PRINT-OBJECT STANDARD-ACCESSOR-METHOD method too)?
+ (call-next-method))))
+
+(defmethod print-object ((method standard-accessor-method) stream)
+ (print-unreadable-object (method stream :type t :identity t)
+ (if (slot-boundp method 'generic-function)
+ (let ((generic-function (method-generic-function method)))
+ (format stream "~S, slot:~S, ~:S"
+ (and generic-function
+ (generic-function-name generic-function))
+ (accessor-method-slot-name method)
+ (unparse-specializers method)))
+ (call-next-method))))
+
+(defmethod print-object ((mc standard-method-combination) stream)
+ (print-unreadable-object (mc stream :type t :identity t)
+ (format stream
+ "~S ~S"
+ (slot-value-or-default mc 'type)
+ (slot-value-or-default mc 'options))))
+
+(defun named-object-print-function (instance stream
+ &optional (extra nil extra-p))
+ (print-unreadable-object (instance stream :type t)
+ (if extra-p
+ (format stream
+ "~S ~:S"
+ (slot-value-or-default instance 'name)
+ extra)
+ (format stream
+ "~S"
+ (slot-value-or-default instance 'name)))))
+
+(defmethod print-object ((class class) stream)
+ (named-object-print-function class stream))
+
+(defmethod print-object ((slotd slot-definition) stream)
+ (named-object-print-function slotd stream))
+
+(defmethod print-object ((generic-function generic-function) stream)
+ (named-object-print-function
+ generic-function
+ stream
+ (if (slot-boundp generic-function 'methods)
+ (list (length (generic-function-methods generic-function)))
+ "?")))
+
+(defmethod print-object ((constructor constructor) stream)
+ (print-unreadable-object (constructor stream :type t :identity t)
+ (format stream
+ "~S (~S)"
+ (slot-value-or-default constructor 'name)
+ (slot-value-or-default constructor 'code-type))))
+
+(defmethod print-object ((cache cache) stream)
+ (print-unreadable-object (cache stream :type t :identity t)
+ (format stream
+ "~D ~S ~D"
+ (cache-nkeys cache)
+ (cache-valuep cache)
+ (cache-nlines cache))))
+
+(defmethod print-object ((wrapper wrapper) stream)
+ (print-unreadable-object (wrapper stream :type t :identity t)
+ (prin1 (wrapper-class wrapper) stream)))
+
+(defmethod print-object ((dfun-info dfun-info) stream)
+ (declare (type stream stream))
+ (print-unreadable-object (dfun-info stream :type t :identity t)))
--- /dev/null
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+
+;;;; This software is derived from software originally released by Xerox
+;;;; Corporation. Copyright and release statements follow. Later modifications
+;;;; to the software are in the public domain and are provided with
+;;;; absolutely no warranty. See the COPYING and CREDITS files for more
+;;;; information.
+
+;;;; copyright information from original PCL sources:
+;;;;
+;;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
+;;;; All rights reserved.
+;;;;
+;;;; Use and copying of this software and preparation of derivative works based
+;;;; upon this software are permitted. Any distribution of this software or
+;;;; derivative works must comply with all applicable United States export
+;;;; control laws.
+;;;;
+;;;; This software is made available AS IS, and Xerox Corporation makes no
+;;;; warranty about the software, its performance or its conformity to any
+;;;; specification.
+
+(in-package "SB-PCL")
+
+(sb-int:file-comment
+ "$Header$")
+\f
+(defmacro slot-symbol (slot-name type)
+ `(if (and (symbolp ,slot-name) (symbol-package ,slot-name))
+ (or (get ,slot-name ',(ecase type
+ (reader 'reader-symbol)
+ (writer 'writer-symbol)
+ (boundp 'boundp-symbol)))
+ (intern (format nil "~A ~A slot ~A"
+ (package-name (symbol-package ,slot-name))
+ (symbol-name ,slot-name)
+ ,(symbol-name type))
+ *slot-accessor-name-package*))
+ (progn
+ (error "Non-symbol and non-interned symbol slot name accessors~
+ are not yet implemented.")
+ ;;(make-symbol (format nil "~A ~A" ,slot-name ,type))
+ )))
+
+(defun slot-reader-symbol (slot-name)
+ (slot-symbol slot-name reader))
+
+(defun slot-writer-symbol (slot-name)
+ (slot-symbol slot-name writer))
+
+(defun slot-boundp-symbol (slot-name)
+ (slot-symbol slot-name boundp))
+
+(defmacro asv-funcall (sym slot-name type &rest args)
+ (declare (ignore type))
+ `(if (fboundp ',sym)
+ (,sym ,@args)
+ (no-slot ',sym ',slot-name)))
+
+(defun no-slot (sym slot-name)
+ (error "No class has a slot named ~S (~S has no function binding)."
+ slot-name sym))
+
+(defmacro accessor-slot-value (object slot-name)
+ (unless (constantp slot-name)
+ (error "~S requires its slot-name argument to be a constant"
+ 'accessor-slot-value))
+ (let* ((slot-name (eval slot-name))
+ (sym (slot-reader-symbol slot-name)))
+ `(asv-funcall ,sym ,slot-name reader ,object)))
+
+(defmacro accessor-set-slot-value (object slot-name new-value &environment env)
+ (unless (constantp slot-name)
+ (error "~S requires its slot-name argument to be a constant"
+ 'accessor-set-slot-value))
+ (setq object (macroexpand object env))
+ (setq slot-name (macroexpand slot-name env))
+ (let* ((slot-name (eval slot-name))
+ (bindings (unless (or (constantp new-value) (atom new-value))
+ (let ((object-var (gensym)))
+ (prog1 `((,object-var ,object))
+ (setq object object-var)))))
+ (sym (slot-writer-symbol slot-name))
+ (form `(asv-funcall ,sym ,slot-name writer ,new-value ,object)))
+ (if bindings
+ `(let ,bindings ,form)
+ form)))
+
+(defconstant *optimize-slot-boundp* nil)
+
+(defmacro accessor-slot-boundp (object slot-name)
+ (unless (constantp slot-name)
+ (error "~S requires its slot-name argument to be a constant"
+ 'accessor-slot-boundp))
+ (let* ((slot-name (eval slot-name))
+ (sym (slot-boundp-symbol slot-name)))
+ (if (not *optimize-slot-boundp*)
+ `(slot-boundp-normal ,object ',slot-name)
+ `(asv-funcall ,sym ,slot-name boundp ,object))))
+
+(defun structure-slot-boundp (object)
+ (declare (ignore object))
+ t)
+
+(defun make-structure-slot-boundp-function (slotd)
+ (let* ((reader (slot-definition-internal-reader-function slotd))
+ (fun #'(lambda (object)
+ (not (eq (funcall reader object) *slot-unbound*)))))
+ (declare (type function reader))
+ fun))
+
+(defun get-optimized-std-accessor-method-function (class slotd name)
+ (if (structure-class-p class)
+ (ecase name
+ (reader (slot-definition-internal-reader-function slotd))
+ (writer (slot-definition-internal-writer-function slotd))
+ (boundp (make-structure-slot-boundp-function slotd)))
+ (let* ((fsc-p (cond ((standard-class-p class) nil)
+ ((funcallable-standard-class-p class) t)
+ ((std-class-p class)
+ ;; Shouldn't be using the optimized-std-accessors
+ ;; in this case.
+ #+nil (format t "* warning: ~S ~S~% ~S~%"
+ name slotd class)
+ nil)
+ (t (error "~S is not a STANDARD-CLASS." class))))
+ (slot-name (slot-definition-name slotd))
+ (index (slot-definition-location slotd))
+ (function (ecase name
+ (reader #'make-optimized-std-reader-method-function)
+ (writer #'make-optimized-std-writer-method-function)
+ (boundp #'make-optimized-std-boundp-method-function)))
+ (value (funcall function fsc-p slot-name index)))
+ (declare (type function function))
+ (values value index))))
+
+(defun make-optimized-std-reader-method-function (fsc-p slot-name index)
+ (declare #.*optimize-speed*)
+ (set-function-name
+ (etypecase index
+ (fixnum (if fsc-p
+ #'(lambda (instance)
+ (let ((value (%instance-ref (fsc-instance-slots instance) index)))
+ (if (eq value *slot-unbound*)
+ (slot-unbound (class-of instance) instance slot-name)
+ value)))
+ #'(lambda (instance)
+ (let ((value (%instance-ref (std-instance-slots instance) index)))
+ (if (eq value *slot-unbound*)
+ (slot-unbound (class-of instance) instance slot-name)
+ value)))))
+ (cons #'(lambda (instance)
+ (let ((value (cdr index)))
+ (if (eq value *slot-unbound*)
+ (slot-unbound (class-of instance) instance slot-name)
+ value)))))
+ `(reader ,slot-name)))
+
+(defun make-optimized-std-writer-method-function (fsc-p slot-name index)
+ (declare #.*optimize-speed*)
+ (set-function-name
+ (etypecase index
+ (fixnum (if fsc-p
+ #'(lambda (nv instance)
+ (setf (%instance-ref (fsc-instance-slots instance) index) nv))
+ #'(lambda (nv instance)
+ (setf (%instance-ref (std-instance-slots instance) index) nv))))
+ (cons #'(lambda (nv instance)
+ (declare (ignore instance))
+ (setf (cdr index) nv))))
+ `(writer ,slot-name)))
+
+(defun make-optimized-std-boundp-method-function (fsc-p slot-name index)
+ (declare #.*optimize-speed*)
+ (set-function-name
+ (etypecase index
+ (fixnum (if fsc-p
+ #'(lambda (instance)
+ (not (eq (%instance-ref (fsc-instance-slots instance)
+ index)
+ *slot-unbound*)))
+ #'(lambda (instance)
+ (not (eq (%instance-ref (std-instance-slots instance)
+ index)
+ *slot-unbound*)))))
+ (cons #'(lambda (instance)
+ (declare (ignore instance))
+ (not (eq (cdr index) *slot-unbound*)))))
+ `(boundp ,slot-name)))
+
+(defun make-optimized-structure-slot-value-using-class-method-function (function)
+ (declare (type function function))
+ #'(lambda (class object slotd)
+ (let ((value (funcall function object)))
+ (if (eq value *slot-unbound*)
+ (slot-unbound class object (slot-definition-name slotd))
+ value))))
+
+(defun make-optimized-structure-setf-slot-value-using-class-method-function (function)
+ (declare (type function function))
+ #'(lambda (nv class object slotd)
+ (declare (ignore class slotd))
+ (funcall function nv object)))
+
+(defun make-optimized-structure-slot-boundp-using-class-method-function (function)
+ (declare (type function function))
+ #'(lambda (class object slotd)
+ (declare (ignore class slotd))
+ (not (eq (funcall function object) *slot-unbound*))))
+
+(defun get-optimized-std-slot-value-using-class-method-function (class slotd name)
+ (if (structure-class-p class)
+ (ecase name
+ (reader (make-optimized-structure-slot-value-using-class-method-function
+ (slot-definition-internal-reader-function slotd)))
+ (writer (make-optimized-structure-setf-slot-value-using-class-method-function
+ (slot-definition-internal-writer-function slotd)))
+ (boundp (make-optimized-structure-slot-boundp-using-class-method-function
+ (slot-definition-internal-writer-function slotd))))
+ (let* ((fsc-p (cond ((standard-class-p class) nil)
+ ((funcallable-standard-class-p class) t)
+ (t (error "~S is not a standard-class" class))))
+ (slot-name (slot-definition-name slotd))
+ (index (slot-definition-location slotd))
+ (function
+ (ecase name
+ (reader
+ #'make-optimized-std-slot-value-using-class-method-function)
+ (writer
+ #'make-optimized-std-setf-slot-value-using-class-method-function)
+ (boundp
+ #'make-optimized-std-slot-boundp-using-class-method-function))))
+ (declare (type function function))
+ (values (funcall function fsc-p slot-name index) index))))
+
+(defun make-optimized-std-slot-value-using-class-method-function
+ (fsc-p slot-name index)
+ (declare #.*optimize-speed*)
+ (etypecase index
+ (fixnum (if fsc-p
+ #'(lambda (class instance slotd)
+ (declare (ignore slotd))
+ (unless (fsc-instance-p instance) (error "not fsc"))
+ (let ((value (%instance-ref (fsc-instance-slots instance) index)))
+ (if (eq value *slot-unbound*)
+ (slot-unbound class instance slot-name)
+ value)))
+ #'(lambda (class instance slotd)
+ (declare (ignore slotd))
+ (unless (std-instance-p instance) (error "not std"))
+ (let ((value (%instance-ref (std-instance-slots instance) index)))
+ (if (eq value *slot-unbound*)
+ (slot-unbound class instance slot-name)
+ value)))))
+ (cons #'(lambda (class instance slotd)
+ (declare (ignore slotd))
+ (let ((value (cdr index)))
+ (if (eq value *slot-unbound*)
+ (slot-unbound class instance slot-name)
+ value))))))
+
+(defun make-optimized-std-setf-slot-value-using-class-method-function
+ (fsc-p slot-name index)
+ (declare #.*optimize-speed*)
+ (declare (ignore slot-name))
+ (etypecase index
+ (fixnum (if fsc-p
+ #'(lambda (nv class instance slotd)
+ (declare (ignore class slotd))
+ (setf (%instance-ref (fsc-instance-slots instance) index) nv))
+ #'(lambda (nv class instance slotd)
+ (declare (ignore class slotd))
+ (setf (%instance-ref (std-instance-slots instance) index) nv))))
+ (cons #'(lambda (nv class instance slotd)
+ (declare (ignore class instance slotd))
+ (setf (cdr index) nv)))))
+
+(defun make-optimized-std-slot-boundp-using-class-method-function
+ (fsc-p slot-name index)
+ (declare #.*optimize-speed*)
+ (declare (ignore slot-name))
+ (etypecase index
+ (fixnum (if fsc-p
+ #'(lambda (class instance slotd)
+ (declare (ignore class slotd))
+ (not (eq (%instance-ref (fsc-instance-slots instance)
+ index)
+ *slot-unbound* )))
+ #'(lambda (class instance slotd)
+ (declare (ignore class slotd))
+ (not (eq (%instance-ref (std-instance-slots instance)
+ index)
+ *slot-unbound* )))))
+ (cons #'(lambda (class instance slotd)
+ (declare (ignore class instance slotd))
+ (not (eq (cdr index) *slot-unbound*))))))
+
+(defun get-accessor-from-svuc-method-function (class slotd sdfun name)
+ (macrolet ((emf-funcall (emf &rest args)
+ `(invoke-effective-method-function ,emf nil ,@args)))
+ (set-function-name
+ (case name
+ (reader #'(lambda (instance) (emf-funcall sdfun class instance slotd)))
+ (writer #'(lambda (nv instance) (emf-funcall sdfun nv class instance slotd)))
+ (boundp #'(lambda (instance) (emf-funcall sdfun class instance slotd))))
+ `(,name ,(class-name class) ,(slot-definition-name slotd)))))
+
+(defun make-internal-reader-method-function (class-name slot-name)
+ (list* ':method-spec `(internal-reader-method ,class-name ,slot-name)
+ (make-method-function
+ (lambda (instance)
+ (let ((wrapper (get-instance-wrapper-or-nil instance)))
+ (if wrapper
+ (let* ((class (wrapper-class* wrapper))
+ (index (or (instance-slot-index wrapper slot-name)
+ (assq slot-name (wrapper-class-slots wrapper)))))
+ (typecase index
+ (fixnum
+ (let ((value (%instance-ref (get-slots instance) index)))
+ (if (eq value *slot-unbound*)
+ (slot-unbound (class-of instance) instance slot-name)
+ value)))
+ (cons
+ (let ((value (cdr index)))
+ (if (eq value *slot-unbound*)
+ (slot-unbound (class-of instance) instance slot-name)
+ value)))
+ (t
+ (error "The wrapper for class ~S does not have the slot ~S"
+ class slot-name))))
+ (slot-value instance slot-name)))))))
+\f
+(defun make-std-reader-method-function (class-name slot-name)
+ (let* ((pv-table-symbol (gensym))
+ (initargs (copy-tree
+ (make-method-function
+ (lambda (instance)
+ (pv-binding1 (.pv. .calls.
+ (symbol-value pv-table-symbol)
+ (instance) (instance-slots))
+ (instance-read-internal
+ .pv. instance-slots 1
+ (slot-value instance slot-name))))))))
+ (setf (getf (getf initargs ':plist) ':slot-name-lists)
+ (list (list nil slot-name)))
+ (setf (getf (getf initargs ':plist) ':pv-table-symbol) pv-table-symbol)
+ (list* ':method-spec `(reader-method ,class-name ,slot-name)
+ initargs)))
+
+(defun make-std-writer-method-function (class-name slot-name)
+ (let* ((pv-table-symbol (gensym))
+ (initargs (copy-tree
+ (make-method-function
+ (lambda (nv instance)
+ (pv-binding1 (.pv. .calls.
+ (symbol-value pv-table-symbol)
+ (instance) (instance-slots))
+ (instance-write-internal
+ .pv. instance-slots 1 nv
+ (setf (slot-value instance slot-name) nv))))))))
+ (setf (getf (getf initargs ':plist) ':slot-name-lists)
+ (list nil (list nil slot-name)))
+ (setf (getf (getf initargs ':plist) ':pv-table-symbol) pv-table-symbol)
+ (list* ':method-spec `(writer-method ,class-name ,slot-name)
+ initargs)))
+
+(defun make-std-boundp-method-function (class-name slot-name)
+ (let* ((pv-table-symbol (gensym))
+ (initargs (copy-tree
+ (make-method-function
+ (lambda (instance)
+ (pv-binding1 (.pv. .calls.
+ (symbol-value pv-table-symbol)
+ (instance) (instance-slots))
+ (instance-boundp-internal
+ .pv. instance-slots 1
+ (slot-boundp instance slot-name))))))))
+ (setf (getf (getf initargs ':plist) ':slot-name-lists)
+ (list (list nil slot-name)))
+ (setf (getf (getf initargs ':plist) ':pv-table-symbol) pv-table-symbol)
+ (list* ':method-spec `(boundp-method ,class-name ,slot-name)
+ initargs)))
+
+(defun initialize-internal-slot-gfs (slot-name &optional type)
+ (when (or (null type) (eq type 'reader))
+ (let* ((name (slot-reader-symbol slot-name))
+ (gf (ensure-generic-function name)))
+ (unless (generic-function-methods gf)
+ (add-reader-method *the-class-slot-object* gf slot-name))))
+ (when (or (null type) (eq type 'writer))
+ (let* ((name (slot-writer-symbol slot-name))
+ (gf (ensure-generic-function name)))
+ (unless (generic-function-methods gf)
+ (add-writer-method *the-class-slot-object* gf slot-name))))
+ (when (and *optimize-slot-boundp*
+ (or (null type) (eq type 'boundp)))
+ (let* ((name (slot-boundp-symbol slot-name))
+ (gf (ensure-generic-function name)))
+ (unless (generic-function-methods gf)
+ (add-boundp-method *the-class-slot-object* gf slot-name))))
+ nil)
+
+(defun initialize-internal-slot-gfs* (readers writers boundps)
+ (dolist (reader readers)
+ (initialize-internal-slot-gfs reader 'reader))
+ (dolist (writer writers)
+ (initialize-internal-slot-gfs writer 'writer))
+ (dolist (boundp boundps)
+ (initialize-internal-slot-gfs boundp 'boundp)))
--- /dev/null
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+
+;;;; This software is derived from software originally released by Xerox
+;;;; Corporation. Copyright and release statements follow. Later modifications
+;;;; to the software are in the public domain and are provided with
+;;;; absolutely no warranty. See the COPYING and CREDITS files for more
+;;;; information.
+
+;;;; copyright information from original PCL sources:
+;;;;
+;;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
+;;;; All rights reserved.
+;;;;
+;;;; Use and copying of this software and preparation of derivative works based
+;;;; upon this software are permitted. Any distribution of this software or
+;;;; derivative works must comply with all applicable United States export
+;;;; control laws.
+;;;;
+;;;; This software is made available AS IS, and Xerox Corporation makes no
+;;;; warranty about the software, its performance or its conformity to any
+;;;; specification.
+
+(in-package "SB-PCL")
+
+(sb-int:file-comment
+ "$Header$")
+\f
+;;;; ANSI CL condition for unbound slots
+
+(define-condition unbound-slot (cell-error)
+ ((instance :reader unbound-slot-instance :initarg :instance)
+ (slot :reader unbound-slot-slot :initarg :slot))
+ (:report (lambda(condition stream)
+ (format stream "The slot ~S is unbound in the object ~S"
+ (unbound-slot-slot condition)
+ (unbound-slot-instance condition)))))
+
+(defmethod wrapper-fetcher ((class standard-class))
+ 'std-instance-wrapper)
+
+(defmethod slots-fetcher ((class standard-class))
+ 'std-instance-slots)
+
+(defmethod raw-instance-allocator ((class standard-class))
+ 'allocate-standard-instance)
+
+;;; These four functions work on std-instances and fsc-instances. These are
+;;; instances for which it is possible to change the wrapper and the slots.
+;;;
+;;; For these kinds of instances, most specified methods from the instance
+;;; structure protocol are promoted to the implementation-specific class
+;;; std-class. Many of these methods call these four functions.
+
+(defun set-wrapper (inst new)
+ (cond ((std-instance-p inst)
+ (setf (std-instance-wrapper inst) new))
+ ((fsc-instance-p inst)
+ (setf (fsc-instance-wrapper inst) new))
+ (t
+ (error "unrecognized instance type"))))
+
+(defun swap-wrappers-and-slots (i1 i2)
+ (without-interrupts
+ (cond ((std-instance-p i1)
+ (let ((w1 (std-instance-wrapper i1))
+ (s1 (std-instance-slots i1)))
+ (setf (std-instance-wrapper i1) (std-instance-wrapper i2))
+ (setf (std-instance-slots i1) (std-instance-slots i2))
+ (setf (std-instance-wrapper i2) w1)
+ (setf (std-instance-slots i2) s1)))
+ ((fsc-instance-p i1)
+ (let ((w1 (fsc-instance-wrapper i1))
+ (s1 (fsc-instance-slots i1)))
+ (setf (fsc-instance-wrapper i1) (fsc-instance-wrapper i2))
+ (setf (fsc-instance-slots i1) (fsc-instance-slots i2))
+ (setf (fsc-instance-wrapper i2) w1)
+ (setf (fsc-instance-slots i2) s1)))
+ (t
+ (error "unrecognized instance type")))))
+\f
+(defun get-class-slot-value-1 (object wrapper slot-name)
+ (let ((entry (assoc slot-name (wrapper-class-slots wrapper))))
+ (if (null entry)
+ (slot-missing (wrapper-class wrapper) object slot-name 'slot-value)
+ (if (eq (cdr entry) *slot-unbound*)
+ (slot-unbound (wrapper-class wrapper) object slot-name)
+ (cdr entry)))))
+
+(defun set-class-slot-value-1 (new-value object wrapper slot-name)
+ (let ((entry (assoc slot-name (wrapper-class-slots wrapper))))
+ (if (null entry)
+ (slot-missing (wrapper-class wrapper)
+ object
+ slot-name
+ 'setf
+ new-value)
+ (setf (cdr entry) new-value))))
+
+(defmethod class-slot-value ((class std-class) slot-name)
+ (let ((wrapper (class-wrapper class))
+ (prototype (class-prototype class)))
+ (get-class-slot-value-1 prototype wrapper slot-name)))
+
+(defmethod (setf class-slot-value) (nv (class std-class) slot-name)
+ (let ((wrapper (class-wrapper class))
+ (prototype (class-prototype class)))
+ (set-class-slot-value-1 nv prototype wrapper slot-name)))
+\f
+(defun find-slot-definition (class slot-name)
+ (dolist (slot (class-slots class) nil)
+ (when (eql slot-name (slot-definition-name slot))
+ (return slot))))
+
+(defun slot-value (object slot-name)
+ (let* ((class (class-of object))
+ (slot-definition (find-slot-definition class slot-name)))
+ (if (null slot-definition)
+ (slot-missing class object slot-name 'slot-value)
+ (slot-value-using-class class object slot-definition))))
+
+(setf (gdefinition 'slot-value-normal) #'slot-value)
+
+(define-compiler-macro slot-value (object-form slot-name-form)
+ (if (and (constantp slot-name-form)
+ (let ((slot-name (eval slot-name-form)))
+ (and (symbolp slot-name) (symbol-package slot-name))))
+ `(accessor-slot-value ,object-form ,slot-name-form)
+ `(slot-value-normal ,object-form ,slot-name-form)))
+
+(defun set-slot-value (object slot-name new-value)
+ (let* ((class (class-of object))
+ (slot-definition (find-slot-definition class slot-name)))
+ (if (null slot-definition)
+ (slot-missing class object slot-name 'setf)
+ (setf (slot-value-using-class class object slot-definition)
+ new-value))))
+
+(setf (gdefinition 'set-slot-value-normal) #'set-slot-value)
+
+(define-compiler-macro set-slot-value (object-form slot-name-form new-value-form)
+ (if (and (constantp slot-name-form)
+ (let ((slot-name (eval slot-name-form)))
+ (and (symbolp slot-name) (symbol-package slot-name))))
+ `(accessor-set-slot-value ,object-form ,slot-name-form ,new-value-form)
+ `(set-slot-value-normal ,object-form ,slot-name-form ,new-value-form)))
+
+(defconstant *optimize-slot-boundp* nil)
+
+(defun slot-boundp (object slot-name)
+ (let* ((class (class-of object))
+ (slot-definition (find-slot-definition class slot-name)))
+ (if (null slot-definition)
+ (slot-missing class object slot-name 'slot-boundp)
+ (slot-boundp-using-class class object slot-definition))))
+
+(setf (gdefinition 'slot-boundp-normal) #'slot-boundp)
+
+(define-compiler-macro slot-boundp (object-form slot-name-form)
+ (if (and (constantp slot-name-form)
+ (let ((slot-name (eval slot-name-form)))
+ (and (symbolp slot-name) (symbol-package slot-name))))
+ `(accessor-slot-boundp ,object-form ,slot-name-form)
+ `(slot-boundp-normal ,object-form ,slot-name-form)))
+
+(defun slot-makunbound (object slot-name)
+ (let* ((class (class-of object))
+ (slot-definition (find-slot-definition class slot-name)))
+ (if (null slot-definition)
+ (slot-missing class object slot-name 'slot-makunbound)
+ (slot-makunbound-using-class class object slot-definition))))
+
+(defun slot-exists-p (object slot-name)
+ (let ((class (class-of object)))
+ (not (null (find-slot-definition class slot-name)))))
+
+;;; This isn't documented, but is used within PCL in a number of print
+;;; object methods. (See NAMED-OBJECT-PRINT-FUNCTION.)
+(defun slot-value-or-default (object slot-name &optional (default "unbound"))
+ (if (slot-boundp object slot-name)
+ (slot-value object slot-name)
+ default))
+\f
+(defun standard-instance-access (instance location)
+ (%instance-ref (std-instance-slots instance) location))
+
+(defun funcallable-standard-instance-access (instance location)
+ (%instance-ref (fsc-instance-slots instance) location))
+
+(defmethod slot-value-using-class ((class std-class)
+ (object std-object)
+ (slotd standard-effective-slot-definition))
+ (let* ((location (slot-definition-location slotd))
+ (value (typecase location
+ (fixnum
+ (cond ((std-instance-p object)
+ ;; FIXME: EQ T (WRAPPER-STATE ..) is better done
+ ;; through INVALID-WRAPPER-P (here and below).
+ (unless (eq 't (wrapper-state (std-instance-wrapper object)))
+ (check-wrapper-validity object))
+ (%instance-ref (std-instance-slots object) location))
+ ((fsc-instance-p object)
+ (unless (eq 't (wrapper-state (fsc-instance-wrapper object)))
+ (check-wrapper-validity object))
+ (%instance-ref (fsc-instance-slots object) location))
+ (t (error "unrecognized instance type"))))
+ (cons
+ (cdr location))
+ (t
+ (error "The slot ~S has neither :INSTANCE nor :CLASS allocation, ~@
+ so it can't be read by the default ~S method."
+ slotd 'slot-value-using-class)))))
+ (if (eq value *slot-unbound*)
+ (slot-unbound class object (slot-definition-name slotd))
+ value)))
+
+(defmethod (setf slot-value-using-class)
+ (new-value (class std-class)
+ (object std-object)
+ (slotd standard-effective-slot-definition))
+ (let ((location (slot-definition-location slotd)))
+ (typecase location
+ (fixnum
+ (cond ((std-instance-p object)
+ (unless (eq 't (wrapper-state (std-instance-wrapper object)))
+ (check-wrapper-validity object))
+ (setf (%instance-ref (std-instance-slots object) location) new-value))
+ ((fsc-instance-p object)
+ (unless (eq 't (wrapper-state (fsc-instance-wrapper object)))
+ (check-wrapper-validity object))
+ (setf (%instance-ref (fsc-instance-slots object) location) new-value))
+ (t (error "unrecognized instance type"))))
+ (cons
+ (setf (cdr location) new-value))
+ (t
+ (error "The slot ~S has neither :INSTANCE nor :CLASS allocation, ~@
+ so it can't be written by the default ~S method."
+ slotd '(setf slot-value-using-class))))))
+
+(defmethod slot-boundp-using-class
+ ((class std-class)
+ (object std-object)
+ (slotd standard-effective-slot-definition))
+ (let* ((location (slot-definition-location slotd))
+ (value (typecase location
+ (fixnum
+ (cond ((std-instance-p object)
+ (unless (eq 't (wrapper-state (std-instance-wrapper object)))
+ (check-wrapper-validity object))
+ (%instance-ref (std-instance-slots object) location))
+ ((fsc-instance-p object)
+ (unless (eq 't (wrapper-state (fsc-instance-wrapper object)))
+ (check-wrapper-validity object))
+ (%instance-ref (fsc-instance-slots object) location))
+ (t (error "unrecognized instance type"))))
+ (cons
+ (cdr location))
+ (t
+ (error "The slot ~S has neither :INSTANCE nor :CLASS allocation, ~@
+ so it can't be read by the default ~S method."
+ slotd 'slot-boundp-using-class)))))
+ (not (eq value *slot-unbound*))))
+
+(defmethod slot-makunbound-using-class
+ ((class std-class)
+ (object std-object)
+ (slotd standard-effective-slot-definition))
+ (let ((location (slot-definition-location slotd)))
+ (typecase location
+ (fixnum
+ (cond ((std-instance-p object)
+ (unless (eq 't (wrapper-state (std-instance-wrapper object)))
+ (check-wrapper-validity object))
+ (setf (%instance-ref (std-instance-slots object) location) *slot-unbound*))
+ ((fsc-instance-p object)
+ (unless (eq 't (wrapper-state (fsc-instance-wrapper object)))
+ (check-wrapper-validity object))
+ (setf (%instance-ref (fsc-instance-slots object) location) *slot-unbound*))
+ (t (error "unrecognized instance type"))))
+ (cons
+ (setf (cdr location) *slot-unbound*))
+ (t
+ (error "The slot ~S has neither :INSTANCE nor :CLASS allocation, ~@
+ so it can't be written by the default ~S method."
+ slotd 'slot-makunbound-using-class))))
+ nil)
+
+(defmethod slot-value-using-class
+ ((class structure-class)
+ (object structure-object)
+ (slotd structure-effective-slot-definition))
+ (let* ((function (slot-definition-internal-reader-function slotd))
+ (value (funcall function object)))
+ (declare (type function function))
+ (if (eq value *slot-unbound*)
+ (slot-unbound class object (slot-definition-name slotd))
+ value)))
+
+(defmethod (setf slot-value-using-class)
+ (new-value (class structure-class)
+ (object structure-object)
+ (slotd structure-effective-slot-definition))
+ (let ((function (slot-definition-internal-writer-function slotd)))
+ (declare (type function function))
+ (funcall function new-value object)))
+
+(defmethod slot-boundp-using-class
+ ((class structure-class)
+ (object structure-object)
+ (slotd structure-effective-slot-definition))
+ t)
+
+(defmethod slot-makunbound-using-class
+ ((class structure-class)
+ (object structure-object)
+ (slotd structure-effective-slot-definition))
+ (error "Structure slots can't be unbound."))
+\f
+(defmethod slot-missing
+ ((class t) instance slot-name operation &optional new-value)
+ (error "When attempting to ~A,~%the slot ~S is missing from the object ~S."
+ (ecase operation
+ (slot-value "read the slot's value (slot-value)")
+ (setf (format nil
+ "set the slot's value to ~S (setf of slot-value)"
+ new-value))
+ (slot-boundp "test to see whether slot is bound (slot-boundp)")
+ (slot-makunbound "make the slot unbound (slot-makunbound)"))
+ slot-name
+ instance))
+
+(defmethod slot-unbound ((class t) instance slot-name)
+ (error 'unbound-slot :slot slot-name :instance instance))
+
+(defun slot-unbound-internal (instance position)
+ (slot-unbound (class-of instance) instance
+ (etypecase position
+ (fixnum
+ (nth position
+ (wrapper-instance-slots-layout (wrapper-of instance))))
+ (cons
+ (car position)))))
+\f
+(defmethod allocate-instance ((class standard-class) &rest initargs)
+ (declare (ignore initargs))
+ (unless (class-finalized-p class) (finalize-inheritance class))
+ (allocate-standard-instance (class-wrapper class)))
+
+(defmethod allocate-instance ((class structure-class) &rest initargs)
+ (declare (ignore initargs))
+ (let ((constructor (class-defstruct-constructor class)))
+ (if constructor
+ (funcall constructor)
+ (error "can't allocate an instance of class ~S" (class-name class)))))
--- /dev/null
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+
+;;;; This software is derived from software originally released by Xerox
+;;;; Corporation. Copyright and release statements follow. Later modifications
+;;;; to the software are in the public domain and are provided with
+;;;; absolutely no warranty. See the COPYING and CREDITS files for more
+;;;; information.
+
+;;;; copyright information from original PCL sources:
+;;;;
+;;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
+;;;; All rights reserved.
+;;;;
+;;;; Use and copying of this software and preparation of derivative works based
+;;;; upon this software are permitted. Any distribution of this software or
+;;;; derivative works must comply with all applicable United States export
+;;;; control laws.
+;;;;
+;;;; This software is made available AS IS, and Xerox Corporation makes no
+;;;; warranty about the software, its performance or its conformity to any
+;;;; specification.
+
+(sb-int:file-comment
+ "$Header$")
+
+(in-package "SB-PCL")
+\f
+(defmethod slot-accessor-function ((slotd effective-slot-definition) type)
+ (ecase type
+ (reader (slot-definition-reader-function slotd))
+ (writer (slot-definition-writer-function slotd))
+ (boundp (slot-definition-boundp-function slotd))))
+
+(defmethod (setf slot-accessor-function) (function
+ (slotd effective-slot-definition)
+ type)
+ (ecase type
+ (reader (setf (slot-definition-reader-function slotd) function))
+ (writer (setf (slot-definition-writer-function slotd) function))
+ (boundp (setf (slot-definition-boundp-function slotd) function))))
+
+(defconstant *slotd-reader-function-std-p* 1)
+(defconstant *slotd-writer-function-std-p* 2)
+(defconstant *slotd-boundp-function-std-p* 4)
+(defconstant *slotd-all-function-std-p* 7)
+
+(defmethod slot-accessor-std-p ((slotd effective-slot-definition) type)
+ (let ((flags (slot-value slotd 'accessor-flags)))
+ (declare (type fixnum flags))
+ (if (eq type 'all)
+ (eql *slotd-all-function-std-p* flags)
+ (let ((mask (ecase type
+ (reader *slotd-reader-function-std-p*)
+ (writer *slotd-writer-function-std-p*)
+ (boundp *slotd-boundp-function-std-p*))))
+ (declare (type fixnum mask))
+ (not (zerop (the fixnum (logand mask flags))))))))
+
+(defmethod (setf slot-accessor-std-p) (value
+ (slotd effective-slot-definition)
+ type)
+ (let ((mask (ecase type
+ (reader *slotd-reader-function-std-p*)
+ (writer *slotd-writer-function-std-p*)
+ (boundp *slotd-boundp-function-std-p*)))
+ (flags (slot-value slotd 'accessor-flags)))
+ (declare (type fixnum mask flags))
+ (setf (slot-value slotd 'accessor-flags)
+ (if value
+ (the fixnum (logior mask flags))
+ (the fixnum (logand (the fixnum (lognot mask)) flags)))))
+ value)
+
+(defmethod initialize-internal-slot-functions ((slotd
+ effective-slot-definition))
+ (let* ((name (slot-value slotd 'name))
+ (class (slot-value slotd 'class)))
+ (let ((table (or (gethash name *name->class->slotd-table*)
+ (setf (gethash name *name->class->slotd-table*)
+ (make-hash-table :test 'eq :size 5)))))
+ (setf (gethash class table) slotd))
+ (dolist (type '(reader writer boundp))
+ (let* ((gf-name (ecase type
+ (reader 'slot-value-using-class)
+ (writer '(setf slot-value-using-class))
+ (boundp 'slot-boundp-using-class)))
+ (gf (gdefinition gf-name)))
+ (compute-slot-accessor-info slotd type gf)))
+ (initialize-internal-slot-gfs name)))
+
+(defmethod compute-slot-accessor-info ((slotd effective-slot-definition)
+ type gf)
+ (let* ((name (slot-value slotd 'name))
+ (class (slot-value slotd 'class))
+ (old-slotd (find-slot-definition class name))
+ (old-std-p (and old-slotd (slot-accessor-std-p old-slotd 'all))))
+ (multiple-value-bind (function std-p)
+ (if (eq *boot-state* 'complete)
+ (get-accessor-method-function gf type class slotd)
+ (get-optimized-std-accessor-method-function class slotd type))
+ (setf (slot-accessor-std-p slotd type) std-p)
+ (setf (slot-accessor-function slotd type) function))
+ (when (and old-slotd (not (eq old-std-p (slot-accessor-std-p slotd 'all))))
+ (push (cons class name) *pv-table-cache-update-info*))))
+
+(defmethod slot-definition-allocation ((slotd structure-slot-definition))
+ :instance)
+\f
+(defmethod shared-initialize :after ((object documentation-mixin)
+ slot-names
+ &key (documentation nil documentation-p))
+ (declare (ignore slot-names))
+ (when documentation-p
+ (setf (plist-value object 'documentation) documentation)))
+
+;;; default if DOC-TYPE doesn't match one of the specified types
+(defmethod documentation (object doc-type)
+ (warn "unsupported DOCUMENTATION: type ~S for object ~S"
+ doc-type
+ (type-of object))
+ nil)
+
+;;; default if DOC-TYPE doesn't match one of the specified types
+(defmethod (setf documentation) (new-value object doc-type)
+ ;; CMU CL made this an error, but since ANSI says that even for supported
+ ;; doc types an implementation is permitted to discard docs at any time
+ ;; for any reason, this feels to me more like a warning. -- WHN 19991214
+ (warn "discarding unsupported DOCUMENTATION of type ~S for object ~S"
+ doc-type
+ (type-of object))
+ new-value)
+
+(defmethod documentation ((object documentation-mixin) doc-type)
+ (declare (ignore doc-type))
+ (plist-value object 'documentation))
+
+(defmethod (setf documentation) (new-value
+ (object documentation-mixin)
+ doc-type)
+ (declare (ignore doc-type))
+ (setf (plist-value object 'documentation) new-value))
+
+(defmethod documentation ((slotd standard-slot-definition) doc-type)
+ (declare (ignore doc-type))
+ (slot-value slotd 'documentation))
+
+(defmethod (setf documentation) (new-value
+ (slotd standard-slot-definition)
+ doc-type)
+ (declare (ignore doc-type))
+ (setf (slot-value slotd 'documentation) new-value))
+\f
+;;;; various class accessors that are a little more complicated than can be
+;;;; done with automatically generated reader methods
+
+(defmethod class-finalized-p ((class pcl-class))
+ (with-slots (wrapper) class
+ (not (null wrapper))))
+
+(defmethod class-prototype ((class std-class))
+ (with-slots (prototype) class
+ (or prototype (setq prototype (allocate-instance class)))))
+
+(defmethod class-prototype ((class structure-class))
+ (with-slots (prototype wrapper defstruct-constructor) class
+ (or prototype
+ (setq prototype
+ (if defstruct-constructor
+ (allocate-instance class)
+ (allocate-standard-instance wrapper))))))
+
+(defmethod class-direct-default-initargs ((class slot-class))
+ (plist-value class 'direct-default-initargs))
+
+(defmethod class-default-initargs ((class slot-class))
+ (plist-value class 'default-initargs))
+
+(defmethod class-constructors ((class slot-class))
+ (plist-value class 'constructors))
+
+(defmethod class-slot-cells ((class std-class))
+ (plist-value class 'class-slot-cells))
+\f
+;;;; class accessors that are even a little bit more complicated than those
+;;;; above. These have a protocol for updating them, we must implement that
+;;;; protocol.
+
+;;; Maintaining the direct subclasses backpointers. The update methods are
+;;; here, the values are read by an automatically generated reader method.
+(defmethod add-direct-subclass ((class class) (subclass class))
+ (with-slots (direct-subclasses) class
+ (pushnew subclass direct-subclasses)
+ subclass))
+(defmethod remove-direct-subclass ((class class) (subclass class))
+ (with-slots (direct-subclasses) class
+ (setq direct-subclasses (remove subclass direct-subclasses))
+ subclass))
+
+;;; Maintaining the direct-methods and direct-generic-functions backpointers.
+;;;
+;;; There are four generic functions involved, each has one method for the
+;;; class case and another method for the damned EQL specializers. All of
+;;; these are specified methods and appear in their specified place in the
+;;; class graph.
+;;;
+;;; ADD-DIRECT-METHOD
+;;; REMOVE-DIRECT-METHOD
+;;; SPECIALIZER-DIRECT-METHODS
+;;; SPECIALIZER-DIRECT-GENERIC-FUNCTIONS
+;;;
+;;; In each case, we maintain one value which is a cons. The car is the list
+;;; methods. The cdr is a list of the generic functions. The cdr is always
+;;; computed lazily.
+(defmethod add-direct-method ((specializer class) (method method))
+ (with-slots (direct-methods) specializer
+ (setf (car direct-methods) (adjoin method (car direct-methods)) ;PUSH
+ (cdr direct-methods) ()))
+ method)
+(defmethod remove-direct-method ((specializer class) (method method))
+ (with-slots (direct-methods) specializer
+ (setf (car direct-methods) (remove method (car direct-methods))
+ (cdr direct-methods) ()))
+ method)
+
+(defmethod specializer-direct-methods ((specializer class))
+ (with-slots (direct-methods) specializer
+ (car direct-methods)))
+
+(defmethod specializer-direct-generic-functions ((specializer class))
+ (with-slots (direct-methods) specializer
+ (or (cdr direct-methods)
+ (setf (cdr direct-methods)
+ (gathering1 (collecting-once)
+ (dolist (m (car direct-methods))
+ (gather1 (method-generic-function m))))))))
+\f
+;;; This hash table is used to store the direct methods and direct generic
+;;; functions of EQL specializers. Each value in the table is the cons.
+(defvar *eql-specializer-methods* (make-hash-table :test 'eql))
+(defvar *class-eq-specializer-methods* (make-hash-table :test 'eq))
+
+(defmethod specializer-method-table ((specializer eql-specializer))
+ *eql-specializer-methods*)
+
+(defmethod specializer-method-table ((specializer class-eq-specializer))
+ *class-eq-specializer-methods*)
+
+(defmethod add-direct-method ((specializer specializer-with-object) (method method))
+ (let* ((object (specializer-object specializer))
+ (table (specializer-method-table specializer))
+ (entry (gethash object table)))
+ (unless entry
+ (setq entry
+ (setf (gethash object table)
+ (cons nil nil))))
+ (setf (car entry) (adjoin method (car entry))
+ (cdr entry) ())
+ method))
+
+(defmethod remove-direct-method ((specializer specializer-with-object) (method method))
+ (let* ((object (specializer-object specializer))
+ (entry (gethash object (specializer-method-table specializer))))
+ (when entry
+ (setf (car entry) (remove method (car entry))
+ (cdr entry) ()))
+ method))
+
+(defmethod specializer-direct-methods ((specializer specializer-with-object))
+ (car (gethash (specializer-object specializer)
+ (specializer-method-table specializer))))
+
+(defmethod specializer-direct-generic-functions ((specializer specializer-with-object))
+ (let* ((object (specializer-object specializer))
+ (entry (gethash object (specializer-method-table specializer))))
+ (when entry
+ (or (cdr entry)
+ (setf (cdr entry)
+ (gathering1 (collecting-once)
+ (dolist (m (car entry))
+ (gather1 (method-generic-function m)))))))))
+
+(defun map-specializers (function)
+ (map-all-classes #'(lambda (class)
+ (funcall function (class-eq-specializer class))
+ (funcall function class)))
+ (maphash #'(lambda (object methods)
+ (declare (ignore methods))
+ (intern-eql-specializer object))
+ *eql-specializer-methods*)
+ (maphash #'(lambda (object specl)
+ (declare (ignore object))
+ (funcall function specl))
+ *eql-specializer-table*)
+ nil)
+
+(defun map-all-generic-functions (function)
+ (let ((all-generic-functions (make-hash-table :test 'eq)))
+ (map-specializers #'(lambda (specl)
+ (dolist (gf (specializer-direct-generic-functions specl))
+ (unless (gethash gf all-generic-functions)
+ (setf (gethash gf all-generic-functions) t)
+ (funcall function gf))))))
+ nil)
+
+(defmethod shared-initialize :after ((specl class-eq-specializer) slot-names &key)
+ (declare (ignore slot-names))
+ (setf (slot-value specl 'type) `(class-eq ,(specializer-class specl))))
+
+(defmethod shared-initialize :after ((specl eql-specializer) slot-names &key)
+ (declare (ignore slot-names))
+ (setf (slot-value specl 'type) `(eql ,(specializer-object specl))))
+\f
+(defun real-load-defclass (name metaclass-name supers slots other accessors)
+ (do-standard-defsetfs-for-defclass accessors) ;***
+ (let ((res (apply #'ensure-class name :metaclass metaclass-name
+ :direct-superclasses supers
+ :direct-slots slots
+ :definition-source `((defclass ,name)
+ ,*load-truename*)
+ other)))
+ ;; Defclass of a class with a forward-referenced superclass does not
+ ;; have a wrapper. RES is the incomplete PCL class. The Lisp class
+ ;; does not yet exist. Maybe should return NIL in that case as RES
+ ;; is not useful to the user?
+ (and (class-wrapper res) (sb-kernel:layout-class (class-wrapper res)))))
+
+(setf (gdefinition 'load-defclass) #'real-load-defclass)
+
+(defun ensure-class (name &rest all)
+ (apply #'ensure-class-using-class name (find-class name nil) all))
+
+(defmethod ensure-class-using-class (name (class null) &rest args &key)
+ (multiple-value-bind (meta initargs)
+ (ensure-class-values class args)
+ (inform-type-system-about-class (class-prototype meta) name);***
+ (setf class (apply #'make-instance meta :name name initargs)
+ (find-class name) class)
+ (inform-type-system-about-class class name) ;***
+ class))
+
+(defmethod ensure-class-using-class (name (class pcl-class) &rest args &key)
+ (multiple-value-bind (meta initargs)
+ (ensure-class-values class args)
+ (unless (eq (class-of class) meta) (change-class class meta))
+ (apply #'reinitialize-instance class initargs)
+ (setf (find-class name) class)
+ (inform-type-system-about-class class name) ;***
+ class))
+
+(defmethod class-predicate-name ((class t))
+ 'function-returning-nil)
+
+(defun ensure-class-values (class args)
+ (let* ((initargs (copy-list args))
+ (unsupplied (list 1))
+ (supplied-meta (getf initargs :metaclass unsupplied))
+ (supplied-supers (getf initargs :direct-superclasses unsupplied))
+ (supplied-slots (getf initargs :direct-slots unsupplied))
+ (meta
+ (cond ((neq supplied-meta unsupplied)
+ (find-class supplied-meta))
+ ((or (null class)
+ (forward-referenced-class-p class))
+ *the-class-standard-class*)
+ (t
+ (class-of class)))))
+ (flet ((fix-super (s)
+ (cond ((classp s) s)
+ ((not (legal-class-name-p s))
+ (error "~S is not a class or a legal class name." s))
+ (t
+ (or (find-class s nil)
+ (setf (find-class s)
+ (make-instance 'forward-referenced-class
+ :name s)))))))
+ (loop (unless (remf initargs :metaclass) (return)))
+ (loop (unless (remf initargs :direct-superclasses) (return)))
+ (loop (unless (remf initargs :direct-slots) (return)))
+ (values meta
+ (list* :direct-superclasses
+ (and (neq supplied-supers unsupplied)
+ (mapcar #'fix-super supplied-supers))
+ :direct-slots
+ (and (neq supplied-slots unsupplied) supplied-slots)
+ initargs)))))
+\f
+#|| ; since it doesn't do anything
+(defmethod shared-initialize :before ((class std-class)
+ slot-names
+ &key direct-superclasses)
+ (declare (ignore slot-names))
+ ;; *** error checking
+ )
+||#
+
+(defmethod shared-initialize :after
+ ((class std-class)
+ slot-names
+ &key (direct-superclasses nil direct-superclasses-p)
+ (direct-slots nil direct-slots-p)
+ (direct-default-initargs nil direct-default-initargs-p)
+ (predicate-name nil predicate-name-p))
+ (declare (ignore slot-names))
+ (cond (direct-superclasses-p
+ (setq direct-superclasses
+ (or direct-superclasses
+ (list (if (funcallable-standard-class-p class)
+ *the-class-funcallable-standard-object*
+ *the-class-standard-object*))))
+ (dolist (superclass direct-superclasses)
+ (unless (validate-superclass class superclass)
+ (error "The class ~S was specified as a~%
+ super-class of the class ~S;~%~
+ but the meta-classes ~S and~%~S are incompatible.~@
+ Define a method for ~S to avoid this error."
+ superclass class (class-of superclass) (class-of class)
+ 'validate-superclass)))
+ (setf (slot-value class 'direct-superclasses) direct-superclasses))
+ (t
+ (setq direct-superclasses (slot-value class 'direct-superclasses))))
+ (setq direct-slots
+ (if direct-slots-p
+ (setf (slot-value class 'direct-slots)
+ (mapcar #'(lambda (pl) (make-direct-slotd class pl)) direct-slots))
+ (slot-value class 'direct-slots)))
+ (if direct-default-initargs-p
+ (setf (plist-value class 'direct-default-initargs) direct-default-initargs)
+ (setq direct-default-initargs (plist-value class 'direct-default-initargs)))
+ (setf (plist-value class 'class-slot-cells)
+ (gathering1 (collecting)
+ (dolist (dslotd direct-slots)
+ (when (eq (slot-definition-allocation dslotd) class)
+ (let ((initfunction (slot-definition-initfunction dslotd)))
+ (gather1 (cons (slot-definition-name dslotd)
+ (if initfunction
+ (funcall initfunction)
+ *slot-unbound*))))))))
+ (setq predicate-name (if predicate-name-p
+ (setf (slot-value class 'predicate-name)
+ (car predicate-name))
+ (or (slot-value class 'predicate-name)
+ (setf (slot-value class 'predicate-name)
+ (make-class-predicate-name (class-name class))))))
+ (add-direct-subclasses class direct-superclasses)
+ (update-class class nil)
+ (make-class-predicate class predicate-name)
+ (add-slot-accessors class direct-slots))
+
+(defmethod shared-initialize :before ((class class) slot-names &key name)
+ (declare (ignore slot-names name))
+ (setf (slot-value class 'type) `(class ,class))
+ (setf (slot-value class 'class-eq-specializer)
+ (make-instance 'class-eq-specializer :class class)))
+
+(defmethod reinitialize-instance :before ((class slot-class) &key)
+ (remove-direct-subclasses class (class-direct-superclasses class))
+ (remove-slot-accessors class (class-direct-slots class)))
+
+(defmethod reinitialize-instance :after ((class slot-class)
+ &rest initargs
+ &key)
+ (map-dependents class
+ #'(lambda (dependent)
+ (apply #'update-dependent class dependent initargs))))
+
+(defmethod shared-initialize :after
+ ((class structure-class)
+ slot-names
+ &key (direct-superclasses nil direct-superclasses-p)
+ (direct-slots nil direct-slots-p)
+ direct-default-initargs
+ (predicate-name nil predicate-name-p))
+ (declare (ignore slot-names direct-default-initargs))
+ (if direct-superclasses-p
+ (setf (slot-value class 'direct-superclasses)
+ (or direct-superclasses
+ (setq direct-superclasses
+ (and (not (eq (class-name class) 'structure-object))
+ (list *the-class-structure-object*)))))
+ (setq direct-superclasses (slot-value class 'direct-superclasses)))
+ (let* ((name (class-name class))
+ (from-defclass-p (slot-value class 'from-defclass-p))
+ (defstruct-p (or from-defclass-p (not (structure-type-p name)))))
+ (if direct-slots-p
+ (setf (slot-value class 'direct-slots)
+ (setq direct-slots
+ (mapcar #'(lambda (pl)
+ (when defstruct-p
+ (let* ((slot-name (getf pl :name))
+ (acc-name (format nil "~S structure class ~A"
+ name slot-name))
+ (accessor (intern acc-name)))
+ (setq pl (list* :defstruct-accessor-symbol accessor
+ pl))))
+ (make-direct-slotd class pl))
+ direct-slots)))
+ (setq direct-slots (slot-value class 'direct-slots)))
+ (when defstruct-p
+ (let* ((include (car (slot-value class 'direct-superclasses)))
+ (conc-name (intern (format nil "~S structure class " name)))
+ (constructor (intern (format nil "~A constructor" conc-name)))
+ (defstruct `(defstruct (,name
+ ,@(when include
+ `((:include ,(class-name include))))
+ (:print-function print-std-instance)
+ (:predicate nil)
+ (:conc-name ,conc-name)
+ (:constructor ,constructor ()))
+ ,@(mapcar #'(lambda (slot)
+ `(,(slot-definition-name slot)
+ *slot-unbound*))
+ direct-slots)))
+ (reader-names (mapcar #'(lambda (slotd)
+ (intern (format nil "~A~A reader" conc-name
+ (slot-definition-name slotd))))
+ direct-slots))
+ (writer-names (mapcar #'(lambda (slotd)
+ (intern (format nil "~A~A writer" conc-name
+ (slot-definition-name slotd))))
+ direct-slots))
+ (readers-init
+ (mapcar #'(lambda (slotd reader-name)
+ (let ((accessor
+ (slot-definition-defstruct-accessor-symbol slotd)))
+ `(defun ,reader-name (obj)
+ (declare (type ,name obj))
+ (,accessor obj))))
+ direct-slots reader-names))
+ (writers-init
+ (mapcar #'(lambda (slotd writer-name)
+ (let ((accessor
+ (slot-definition-defstruct-accessor-symbol slotd)))
+ `(defun ,writer-name (nv obj)
+ (declare (type ,name obj))
+ (setf (,accessor obj) nv))))
+ direct-slots writer-names))
+ (defstruct-form
+ `(progn
+ ,defstruct
+ ,@readers-init ,@writers-init
+ (declare-structure ',name nil nil))))
+ (unless (structure-type-p name) (eval defstruct-form))
+ (mapc #'(lambda (dslotd reader-name writer-name)
+ (let* ((reader (gdefinition reader-name))
+ (writer (when (gboundp writer-name)
+ (gdefinition writer-name))))
+ (setf (slot-value dslotd 'internal-reader-function) reader)
+ (setf (slot-value dslotd 'internal-writer-function) writer)))
+ direct-slots reader-names writer-names)
+ (setf (slot-value class 'defstruct-form) defstruct-form)
+ (setf (slot-value class 'defstruct-constructor) constructor))))
+ (add-direct-subclasses class direct-superclasses)
+ (setf (slot-value class 'class-precedence-list)
+ (compute-class-precedence-list class))
+ (setf (slot-value class 'slots) (compute-slots class))
+ (let ((lclass (cl:find-class (class-name class))))
+ (setf (sb-kernel:class-pcl-class lclass) class)
+ (setf (slot-value class 'wrapper) (sb-kernel:class-layout lclass)))
+ (update-pv-table-cache-info class)
+ (setq predicate-name (if predicate-name-p
+ (setf (slot-value class 'predicate-name)
+ (car predicate-name))
+ (or (slot-value class 'predicate-name)
+ (setf (slot-value class 'predicate-name)
+ (make-class-predicate-name (class-name class))))))
+ (make-class-predicate class predicate-name)
+ (add-slot-accessors class direct-slots))
+
+(defmethod direct-slot-definition-class ((class structure-class) initargs)
+ (declare (ignore initargs))
+ (find-class 'structure-direct-slot-definition))
+
+(defmethod finalize-inheritance ((class structure-class))
+ nil) ; always finalized
+\f
+(defun add-slot-accessors (class dslotds)
+ (fix-slot-accessors class dslotds 'add))
+
+(defun remove-slot-accessors (class dslotds)
+ (fix-slot-accessors class dslotds 'remove))
+
+(defun fix-slot-accessors (class dslotds add/remove)
+ (flet ((fix (gfspec name r/w)
+ (let ((gf (ensure-generic-function gfspec)))
+ (case r/w
+ (r (if (eq add/remove 'add)
+ (add-reader-method class gf name)
+ (remove-reader-method class gf)))
+ (w (if (eq add/remove 'add)
+ (add-writer-method class gf name)
+ (remove-writer-method class gf)))))))
+ (dolist (dslotd dslotds)
+ (let ((slot-name (slot-definition-name dslotd)))
+ (dolist (r (slot-definition-readers dslotd)) (fix r slot-name 'r))
+ (dolist (w (slot-definition-writers dslotd)) (fix w slot-name 'w))))))
+\f
+(defun add-direct-subclasses (class new)
+ (dolist (n new)
+ (unless (memq class (class-direct-subclasses class))
+ (add-direct-subclass n class))))
+
+(defun remove-direct-subclasses (class new)
+ (let ((old (class-direct-superclasses class)))
+ (dolist (o (set-difference old new))
+ (remove-direct-subclass o class))))
+\f
+(defmethod finalize-inheritance ((class std-class))
+ (update-class class t))
+\f
+(defun class-has-a-forward-referenced-superclass-p (class)
+ (or (forward-referenced-class-p class)
+ (some #'class-has-a-forward-referenced-superclass-p
+ (class-direct-superclasses class))))
+
+;;; This is called by :after shared-initialize whenever a class is initialized
+;;; or reinitialized. The class may or may not be finalized.
+(defun update-class (class finalizep)
+ (when (or finalizep (class-finalized-p class)
+ (not (class-has-a-forward-referenced-superclass-p class)))
+ (update-cpl class (compute-class-precedence-list class))
+ (update-slots class (compute-slots class))
+ (update-gfs-of-class class)
+ (update-inits class (compute-default-initargs class))
+ (update-make-instance-function-table class))
+ (unless finalizep
+ (dolist (sub (class-direct-subclasses class)) (update-class sub nil))))
+
+(defun update-cpl (class cpl)
+ (if (class-finalized-p class)
+ (unless (equal (class-precedence-list class) cpl)
+ ;; comment from the old CMU CL sources:
+ ;; Need to have the cpl setup before update-lisp-class-layout
+ ;; is called on CMU CL.
+ (setf (slot-value class 'class-precedence-list) cpl)
+ (force-cache-flushes class))
+ (setf (slot-value class 'class-precedence-list) cpl))
+ (update-class-can-precede-p cpl))
+
+(defun update-class-can-precede-p (cpl)
+ (when cpl
+ (let ((first (car cpl)))
+ (dolist (c (cdr cpl))
+ (pushnew c (slot-value first 'can-precede-list))))
+ (update-class-can-precede-p (cdr cpl))))
+
+(defun class-can-precede-p (class1 class2)
+ (member class2 (class-can-precede-list class1)))
+
+(defun update-slots (class eslotds)
+ (let ((instance-slots ())
+ (class-slots ()))
+ (dolist (eslotd eslotds)
+ (let ((alloc (slot-definition-allocation eslotd)))
+ (cond ((eq alloc :instance) (push eslotd instance-slots))
+ ((classp alloc) (push eslotd class-slots)))))
+
+ ;; If there is a change in the shape of the instances then the
+ ;; old class is now obsolete.
+ (let* ((nlayout (mapcar #'slot-definition-name
+ (sort instance-slots #'< :key #'slot-definition-location)))
+ (nslots (length nlayout))
+ (nwrapper-class-slots (compute-class-slots class-slots))
+ (owrapper (class-wrapper class))
+ (olayout (and owrapper (wrapper-instance-slots-layout owrapper)))
+ (owrapper-class-slots (and owrapper (wrapper-class-slots owrapper)))
+ (nwrapper
+ (cond ((null owrapper)
+ (make-wrapper nslots class))
+ ((and (equal nlayout olayout)
+ (not
+ (iterate ((o (list-elements owrapper-class-slots))
+ (n (list-elements nwrapper-class-slots)))
+ (unless (eq (car o) (car n)) (return t)))))
+ owrapper)
+ (t
+ ;; This will initialize the new wrapper to have the same
+ ;; state as the old wrapper. We will then have to change
+ ;; that. This may seem like wasted work (it is), but the
+ ;; spec requires that we call make-instances-obsolete.
+ (make-instances-obsolete class)
+ (class-wrapper class)))))
+
+ (with-slots (wrapper slots) class
+ (update-lisp-class-layout class nwrapper)
+ (setf slots eslotds
+ (wrapper-instance-slots-layout nwrapper) nlayout
+ (wrapper-class-slots nwrapper) nwrapper-class-slots
+ (wrapper-no-of-instance-slots nwrapper) nslots
+ wrapper nwrapper))
+
+ (unless (eq owrapper nwrapper)
+ (update-pv-table-cache-info class)))))
+
+(defun compute-class-slots (eslotds)
+ (gathering1 (collecting)
+ (dolist (eslotd eslotds)
+ (gather1
+ (assoc (slot-definition-name eslotd)
+ (class-slot-cells (slot-definition-allocation eslotd)))))))
+
+(defun compute-layout (cpl instance-eslotds)
+ (let* ((names
+ (gathering1 (collecting)
+ (dolist (eslotd instance-eslotds)
+ (when (eq (slot-definition-allocation eslotd) :instance)
+ (gather1 (slot-definition-name eslotd))))))
+ (order ()))
+ (labels ((rwalk (tail)
+ (when tail
+ (rwalk (cdr tail))
+ (dolist (ss (class-slots (car tail)))
+ (let ((n (slot-definition-name ss)))
+ (when (member n names)
+ (setq order (cons n order)
+ names (remove n names))))))))
+ (rwalk (if (slot-boundp (car cpl) 'slots)
+ cpl
+ (cdr cpl)))
+ (reverse (append names order)))))
+
+(defun update-gfs-of-class (class)
+ (when (and (class-finalized-p class)
+ (let ((cpl (class-precedence-list class)))
+ (or (member *the-class-slot-class* cpl)
+ (member *the-class-standard-effective-slot-definition* cpl))))
+ (let ((gf-table (make-hash-table :test 'eq)))
+ (labels ((collect-gfs (class)
+ (dolist (gf (specializer-direct-generic-functions class))
+ (setf (gethash gf gf-table) t))
+ (mapc #'collect-gfs (class-direct-superclasses class))))
+ (collect-gfs class)
+ (maphash #'(lambda (gf ignore)
+ (declare (ignore ignore))
+ (update-gf-dfun class gf))
+ gf-table)))))
+
+(defun update-inits (class inits)
+ (setf (plist-value class 'default-initargs) inits))
+\f
+(defmethod compute-default-initargs ((class slot-class))
+ (let ((cpl (class-precedence-list class))
+ (direct (class-direct-default-initargs class)))
+ (labels ((walk (tail)
+ (if (null tail)
+ nil
+ (let ((c (pop tail)))
+ (append (if (eq c class)
+ direct
+ (class-direct-default-initargs c))
+ (walk tail))))))
+ (let ((initargs (walk cpl)))
+ (delete-duplicates initargs :test #'eq :key #'car :from-end t)))))
+\f
+;;;; protocols for constructing direct and effective slot definitions
+
+(defmethod direct-slot-definition-class ((class std-class) initargs)
+ (declare (ignore initargs))
+ (find-class 'standard-direct-slot-definition))
+
+(defun make-direct-slotd (class initargs)
+ (let ((initargs (list* :class class initargs)))
+ (apply #'make-instance
+ (direct-slot-definition-class class initargs)
+ initargs)))
+
+(defmethod compute-slots ((class std-class))
+ ;; As specified, we must call COMPUTE-EFFECTIVE-SLOT-DEFINITION once
+ ;; for each different slot name we find in our superclasses. Each
+ ;; call receives the class and a list of the dslotds with that name.
+ ;; The list is in most-specific-first order.
+ (let ((name-dslotds-alist ()))
+ (dolist (c (class-precedence-list class))
+ (let ((dslotds (class-direct-slots c)))
+ (dolist (d dslotds)
+ (let* ((name (slot-definition-name d))
+ (entry (assq name name-dslotds-alist)))
+ (if entry
+ (push d (cdr entry))
+ (push (list name d) name-dslotds-alist))))))
+ (mapcar #'(lambda (direct)
+ (compute-effective-slot-definition class
+ (nreverse (cdr direct))))
+ name-dslotds-alist)))
+
+(defmethod compute-slots :around ((class std-class))
+ (let ((eslotds (call-next-method))
+ (cpl (class-precedence-list class))
+ (instance-slots ())
+ (class-slots ()))
+ (dolist (eslotd eslotds)
+ (let ((alloc (slot-definition-allocation eslotd)))
+ (cond ((eq alloc :instance) (push eslotd instance-slots))
+ ((classp alloc) (push eslotd class-slots)))))
+ (let ((nlayout (compute-layout cpl instance-slots)))
+ (dolist (eslotd instance-slots)
+ (setf (slot-definition-location eslotd)
+ (position (slot-definition-name eslotd) nlayout))))
+ (dolist (eslotd class-slots)
+ (setf (slot-definition-location eslotd)
+ (assoc (slot-definition-name eslotd)
+ (class-slot-cells (slot-definition-allocation eslotd)))))
+ (mapc #'initialize-internal-slot-functions eslotds)
+ eslotds))
+
+(defmethod compute-slots ((class structure-class))
+ (mapcan #'(lambda (superclass)
+ (mapcar #'(lambda (dslotd)
+ (compute-effective-slot-definition class
+ (list dslotd)))
+ (class-direct-slots superclass)))
+ (reverse (slot-value class 'class-precedence-list))))
+
+(defmethod compute-slots :around ((class structure-class))
+ (let ((eslotds (call-next-method)))
+ (mapc #'initialize-internal-slot-functions eslotds)
+ eslotds))
+
+(defmethod compute-effective-slot-definition ((class slot-class) dslotds)
+ (let* ((initargs (compute-effective-slot-definition-initargs class dslotds))
+ (class (effective-slot-definition-class class initargs)))
+ (apply #'make-instance class initargs)))
+
+(defmethod effective-slot-definition-class ((class std-class) initargs)
+ (declare (ignore initargs))
+ (find-class 'standard-effective-slot-definition))
+
+(defmethod effective-slot-definition-class ((class structure-class) initargs)
+ (declare (ignore initargs))
+ (find-class 'structure-effective-slot-definition))
+
+(defmethod compute-effective-slot-definition-initargs
+ ((class slot-class) direct-slotds)
+ (let* ((name nil)
+ (initfunction nil)
+ (initform nil)
+ (initargs nil)
+ (allocation nil)
+ (type t)
+ (namep nil)
+ (initp nil)
+ (allocp nil))
+
+ (dolist (slotd direct-slotds)
+ (when slotd
+ (unless namep
+ (setq name (slot-definition-name slotd)
+ namep t))
+ (unless initp
+ (when (slot-definition-initfunction slotd)
+ (setq initform (slot-definition-initform slotd)
+ initfunction (slot-definition-initfunction slotd)
+ initp t)))
+ (unless allocp
+ (setq allocation (slot-definition-allocation slotd)
+ allocp t))
+ (setq initargs (append (slot-definition-initargs slotd) initargs))
+ (let ((slotd-type (slot-definition-type slotd)))
+ (setq type (cond ((eq type 't) slotd-type)
+ ((*subtypep type slotd-type) type)
+ (t `(and ,type ,slotd-type)))))))
+ (list :name name
+ :initform initform
+ :initfunction initfunction
+ :initargs initargs
+ :allocation allocation
+ :type type
+ :class class)))
+
+(defmethod compute-effective-slot-definition-initargs :around
+ ((class structure-class) direct-slotds)
+ (let ((slotd (car direct-slotds)))
+ (list* :defstruct-accessor-symbol (slot-definition-defstruct-accessor-symbol slotd)
+ :internal-reader-function (slot-definition-internal-reader-function slotd)
+ :internal-writer-function (slot-definition-internal-writer-function slotd)
+ (call-next-method))))
+\f
+;;; NOTE: For bootstrapping considerations, these can't use make-instance
+;;; to make the method object. They have to use make-a-method which
+;;; is a specially bootstrapped mechanism for making standard methods.
+(defmethod reader-method-class ((class slot-class) direct-slot &rest initargs)
+ (declare (ignore direct-slot initargs))
+ (find-class 'standard-reader-method))
+
+(defmethod add-reader-method ((class slot-class) generic-function slot-name)
+ (add-method generic-function
+ (make-a-method 'standard-reader-method
+ ()
+ (list (or (class-name class) 'object))
+ (list class)
+ (make-reader-method-function class slot-name)
+ "automatically generated reader method"
+ slot-name)))
+
+(defmethod writer-method-class ((class slot-class) direct-slot &rest initargs)
+ (declare (ignore direct-slot initargs))
+ (find-class 'standard-writer-method))
+
+(defmethod add-writer-method ((class slot-class) generic-function slot-name)
+ (add-method generic-function
+ (make-a-method 'standard-writer-method
+ ()
+ (list 'new-value (or (class-name class) 'object))
+ (list *the-class-t* class)
+ (make-writer-method-function class slot-name)
+ "automatically generated writer method"
+ slot-name)))
+
+(defmethod add-boundp-method ((class slot-class) generic-function slot-name)
+ (add-method generic-function
+ (make-a-method 'standard-boundp-method
+ ()
+ (list (or (class-name class) 'object))
+ (list class)
+ (make-boundp-method-function class slot-name)
+ "automatically generated boundp method"
+ slot-name)))
+
+(defmethod remove-reader-method ((class slot-class) generic-function)
+ (let ((method (get-method generic-function () (list class) nil)))
+ (when method (remove-method generic-function method))))
+
+(defmethod remove-writer-method ((class slot-class) generic-function)
+ (let ((method
+ (get-method generic-function () (list *the-class-t* class) nil)))
+ (when method (remove-method generic-function method))))
+
+(defmethod remove-boundp-method ((class slot-class) generic-function)
+ (let ((method (get-method generic-function () (list class) nil)))
+ (when method (remove-method generic-function method))))
+\f
+;;; make-reader-method-function and make-write-method function are NOT part of
+;;; the standard protocol. They are however useful, PCL makes uses makes use
+;;; of them internally and documents them for PCL users.
+;;;
+;;; *** This needs work to make type testing by the writer functions which
+;;; *** do type testing faster. The idea would be to have one constructor
+;;; *** for each possible type test. In order to do this it would be nice
+;;; *** to have help from inform-type-system-about-class and friends.
+;;;
+;;; *** There is a subtle bug here which is going to have to be fixed.
+;;; *** Namely, the simplistic use of the template has to be fixed. We
+;;; *** have to give the optimize-slot-value method the user might have
+;;; *** defined for this metclass a chance to run.
+
+(defmethod make-reader-method-function ((class slot-class) slot-name)
+ (make-std-reader-method-function (class-name class) slot-name))
+
+(defmethod make-writer-method-function ((class slot-class) slot-name)
+ (make-std-writer-method-function (class-name class) slot-name))
+
+(defmethod make-boundp-method-function ((class slot-class) slot-name)
+ (make-std-boundp-method-function (class-name class) slot-name))
+\f
+;;;; inform-type-system-about-class
+;;;; make-type-predicate
+;;;
+;;; These are NOT part of the standard protocol. They are internal mechanism
+;;; which PCL uses to *try* and tell the type system about class definitions.
+;;; In a more fully integrated implementation of CLOS, the type system would
+;;; know about class objects and class names in a more fundamental way and
+;;; the mechanism used to inform the type system about new classes would be
+;;; different.
+(defmethod inform-type-system-about-class ((class std-class) name)
+ (inform-type-system-about-std-class name))
+\f
+(defmethod compatible-meta-class-change-p (class proto-new-class)
+ (eq (class-of class) (class-of proto-new-class)))
+
+(defmethod validate-superclass ((class class) (new-super class))
+ (or (eq new-super *the-class-t*)
+ (eq (class-of class) (class-of new-super))))
+
+(defmethod validate-superclass ((class standard-class) (new-super std-class))
+ (let ((new-super-meta-class (class-of new-super)))
+ (or (eq new-super-meta-class *the-class-std-class*)
+ (eq (class-of class) new-super-meta-class))))
+\f
+(defun force-cache-flushes (class)
+ (let* ((owrapper (class-wrapper class))
+ (state (wrapper-state owrapper)))
+ ;; We only need to do something if the state is still T. If the
+ ;; state isn't T, it will be FLUSH or OBSOLETE, and both of those
+ ;; will already be doing what we want. In particular, we must be
+ ;; sure we never change an OBSOLETE into a FLUSH since OBSOLETE
+ ;; means do what FLUSH does and then some.
+ (when (eq state 't) ; FIXME: should be done through INVALID-WRAPPER-P
+ (let ((nwrapper (make-wrapper (wrapper-no-of-instance-slots owrapper)
+ class)))
+ (setf (wrapper-instance-slots-layout nwrapper)
+ (wrapper-instance-slots-layout owrapper))
+ (setf (wrapper-class-slots nwrapper)
+ (wrapper-class-slots owrapper))
+ (without-interrupts
+ (update-lisp-class-layout class nwrapper)
+ (setf (slot-value class 'wrapper) nwrapper)
+ (invalidate-wrapper owrapper ':flush nwrapper))))))
+
+(defun flush-cache-trap (owrapper nwrapper instance)
+ (declare (ignore owrapper))
+ (set-wrapper instance nwrapper))
+\f
+;;; make-instances-obsolete can be called by user code. It will cause the
+;;; next access to the instance (as defined in 88-002R) to trap through the
+;;; update-instance-for-redefined-class mechanism.
+(defmethod make-instances-obsolete ((class std-class))
+ (let* ((owrapper (class-wrapper class))
+ (nwrapper (make-wrapper (wrapper-no-of-instance-slots owrapper)
+ class)))
+ (setf (wrapper-instance-slots-layout nwrapper)
+ (wrapper-instance-slots-layout owrapper))
+ (setf (wrapper-class-slots nwrapper)
+ (wrapper-class-slots owrapper))
+ (without-interrupts
+ (update-lisp-class-layout class nwrapper)
+ (setf (slot-value class 'wrapper) nwrapper)
+ (invalidate-wrapper owrapper ':obsolete nwrapper)
+ class)))
+
+(defmethod make-instances-obsolete ((class symbol))
+ (make-instances-obsolete (find-class class)))
+
+;;; obsolete-instance-trap is the internal trap that is called when we see
+;;; an obsolete instance. The times when it is called are:
+;;; - when the instance is involved in method lookup
+;;; - when attempting to access a slot of an instance
+;;;
+;;; It is not called by class-of, wrapper-of, or any of the low-level instance
+;;; access macros.
+;;;
+;;; Of course these times when it is called are an internal implementation
+;;; detail of PCL and are not part of the documented description of when the
+;;; obsolete instance update happens. The documented description is as it
+;;; appears in 88-002R.
+;;;
+;;; This has to return the new wrapper, so it counts on all the methods on
+;;; obsolete-instance-trap-internal to return the new wrapper. It also does
+;;; a little internal error checking to make sure that the traps are only
+;;; happening when they should, and that the trap methods are computing
+;;; appropriate new wrappers.
+
+;;; obsolete-instance-trap might be called on structure instances
+;;; after a structure is redefined. In most cases, obsolete-instance-trap
+;;; will not be able to fix the old instance, so it must signal an
+;;; error. The hard part of this is that the error system and debugger
+;;; might cause obsolete-instance-trap to be called again, so in that
+;;; case, we have to return some reasonable wrapper, instead.
+
+(defvar *in-obsolete-instance-trap* nil)
+(defvar *the-wrapper-of-structure-object*
+ (class-wrapper (find-class 'structure-object)))
+
+(define-condition obsolete-structure (error)
+ ((datum :reader obsolete-structure-datum :initarg :datum))
+ (:report
+ (lambda (condition stream)
+ ;; Don't try to print the structure, since it probably won't work.
+ (format stream
+ "obsolete structure error in ~S:~@
+ for a structure of type: ~S"
+ (sb-conditions::condition-function-name condition)
+ (type-of (obsolete-structure-datum condition))))))
+
+(defun obsolete-instance-trap (owrapper nwrapper instance)
+ (if (not (pcl-instance-p instance))
+ (if *in-obsolete-instance-trap*
+ *the-wrapper-of-structure-object*
+ (let ((*in-obsolete-instance-trap* t))
+ (error 'obsolete-structure :datum instance)))
+ (let* ((class (wrapper-class* nwrapper))
+ (copy (allocate-instance class)) ;??? allocate-instance ???
+ (olayout (wrapper-instance-slots-layout owrapper))
+ (nlayout (wrapper-instance-slots-layout nwrapper))
+ (oslots (get-slots instance))
+ (nslots (get-slots copy))
+ (oclass-slots (wrapper-class-slots owrapper))
+ (added ())
+ (discarded ())
+ (plist ()))
+ ;; local --> local transfer
+ ;; local --> shared discard
+ ;; local --> -- discard
+ ;; shared --> local transfer
+ ;; shared --> shared discard
+ ;; shared --> -- discard
+ ;; -- --> local add
+ ;; -- --> shared --
+
+ ;; Go through all the old local slots.
+ (iterate ((name (list-elements olayout))
+ (opos (interval :from 0)))
+ (let ((npos (posq name nlayout)))
+ (if npos
+ (setf (instance-ref nslots npos) (instance-ref oslots opos))
+ (progn
+ (push name discarded)
+ (unless (eq (instance-ref oslots opos) *slot-unbound*)
+ (setf (getf plist name) (instance-ref oslots opos)))))))
+
+ ;; Go through all the old shared slots.
+ (iterate ((oclass-slot-and-val (list-elements oclass-slots)))
+ (let ((name (car oclass-slot-and-val))
+ (val (cdr oclass-slot-and-val)))
+ (let ((npos (posq name nlayout)))
+ (if npos
+ (setf (instance-ref nslots npos) (cdr oclass-slot-and-val))
+ (progn (push name discarded)
+ (unless (eq val *slot-unbound*)
+ (setf (getf plist name) val)))))))
+
+ ;; Go through all the new local slots to compute the added slots.
+ (dolist (nlocal nlayout)
+ (unless (or (memq nlocal olayout)
+ (assq nlocal oclass-slots))
+ (push nlocal added)))
+
+ (swap-wrappers-and-slots instance copy)
+
+ (update-instance-for-redefined-class instance
+ added
+ discarded
+ plist)
+ nwrapper)))
+\f
+(defmacro copy-instance-internal (instance)
+ `(progn
+ (let* ((class (class-of instance))
+ (copy (allocate-instance class)))
+ (if (std-instance-p ,instance)
+ (setf (std-instance-slots ,instance)
+ (std-instance-slots ,instance))
+ (setf (fsc-instance-slots ,instance)
+ (fsc-instance-slots ,instance)))
+ copy)))
+
+(defun change-class-internal (instance new-class)
+ (let* ((old-class (class-of instance))
+ (copy (allocate-instance new-class))
+ (new-wrapper (get-wrapper copy))
+ (old-wrapper (class-wrapper old-class))
+ (old-layout (wrapper-instance-slots-layout old-wrapper))
+ (new-layout (wrapper-instance-slots-layout new-wrapper))
+ (old-slots (get-slots instance))
+ (new-slots (get-slots copy))
+ (old-class-slots (wrapper-class-slots old-wrapper)))
+
+ ;; "The values of local slots specified by both the class CTO and
+ ;; CFROM are retained. If such a local slot was unbound, it remains
+ ;; unbound."
+ (iterate ((new-slot (list-elements new-layout))
+ (new-position (interval :from 0)))
+ (let ((old-position (posq new-slot old-layout)))
+ (when old-position
+ (setf (instance-ref new-slots new-position)
+ (instance-ref old-slots old-position)))))
+
+ ;; "The values of slots specified as shared in the class CFROM and
+ ;; as local in the class CTO are retained."
+ (iterate ((slot-and-val (list-elements old-class-slots)))
+ (let ((position (posq (car slot-and-val) new-layout)))
+ (when position
+ (setf (instance-ref new-slots position) (cdr slot-and-val)))))
+
+ ;; Make the copy point to the old instance's storage, and make the
+ ;; old instance point to the new storage.
+ (swap-wrappers-and-slots instance copy)
+
+ (update-instance-for-different-class copy instance)
+ instance))
+
+(defmethod change-class ((instance standard-object)
+ (new-class standard-class))
+ (change-class-internal instance new-class))
+
+(defmethod change-class ((instance funcallable-standard-object)
+ (new-class funcallable-standard-class))
+ (change-class-internal instance new-class))
+
+(defmethod change-class ((instance standard-object)
+ (new-class funcallable-standard-class))
+ (error "You can't change the class of ~S to ~S~@
+ because it isn't already an instance with metaclass ~S."
+ instance new-class 'standard-class))
+
+(defmethod change-class ((instance funcallable-standard-object)
+ (new-class standard-class))
+ (error "You can't change the class of ~S to ~S~@
+ because it isn't already an instance with metaclass ~S."
+ instance new-class 'funcallable-standard-class))
+
+(defmethod change-class ((instance t) (new-class-name symbol))
+ (change-class instance (find-class new-class-name)))
+\f
+;;;; The metaclass BUILT-IN-CLASS
+;;;;
+;;;; This metaclass is something of a weird creature. By this point, all
+;;;; instances of it which will exist have been created, and no instance
+;;;; is ever created by calling MAKE-INSTANCE.
+;;;;
+;;;; But, there are other parts of the protocol we must follow and those
+;;;; definitions appear here.
+
+(defmethod shared-initialize :before
+ ((class built-in-class) slot-names &rest initargs)
+ (declare (ignore slot-names initargs))
+ (error "attempt to initialize or reinitialize a built in class"))
+
+(defmethod class-direct-slots ((class built-in-class)) ())
+(defmethod class-slots ((class built-in-class)) ())
+(defmethod class-direct-default-initargs ((class built-in-class)) ())
+(defmethod class-default-initargs ((class built-in-class)) ())
+
+(defmethod validate-superclass ((c class) (s built-in-class))
+ (or (eq s *the-class-t*)
+ (eq s *the-class-stream*)))
+\f
+(defmethod validate-superclass ((c slot-class)
+ (f forward-referenced-class))
+ 't)
+\f
+(defmethod add-dependent ((metaobject dependent-update-mixin) dependent)
+ (pushnew dependent (plist-value metaobject 'dependents)))
+
+(defmethod remove-dependent ((metaobject dependent-update-mixin) dependent)
+ (setf (plist-value metaobject 'dependents)
+ (delete dependent (plist-value metaobject 'dependents))))
+
+(defmethod map-dependents ((metaobject dependent-update-mixin) function)
+ (dolist (dependent (plist-value metaobject 'dependents))
+ (funcall function dependent)))
+
--- /dev/null
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+
+;;;; This software is derived from software originally released by Xerox
+;;;; Corporation. Copyright and release statements follow. Later modifications
+;;;; to the software are in the public domain and are provided with
+;;;; absolutely no warranty. See the COPYING and CREDITS files for more
+;;;; information.
+
+;;;; copyright information from original PCL sources:
+;;;;
+;;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
+;;;; All rights reserved.
+;;;;
+;;;; Use and copying of this software and preparation of derivative works based
+;;;; upon this software are permitted. Any distribution of this software or
+;;;; derivative works must comply with all applicable United States export
+;;;; control laws.
+;;;;
+;;;; This software is made available AS IS, and Xerox Corporation makes no
+;;;; warranty about the software, its performance or its conformity to any
+;;;; specification.
+
+(sb-int:file-comment
+ "$Header$")
+
+(in-package "SB-PCL")
+\f
+(defmethod initialize-internal-slot-functions :after
+ ((slotd structure-effective-slot-definition))
+ (let ((name (slot-definition-name slotd)))
+ (initialize-internal-slot-reader-gfs name)
+ (initialize-internal-slot-writer-gfs name)
+ (initialize-internal-slot-boundp-gfs name)))
+
+(defmethod slot-definition-allocation ((slotd structure-slot-definition))
+ :instance)
+
+(defmethod class-prototype ((class structure-class))
+ (with-slots (prototype) class
+ (or prototype
+ (setq prototype (make-class-prototype class)))))
+
+(defmethod make-class-prototype ((class structure-class))
+ (with-slots (wrapper defstruct-constructor) class
+ (if defstruct-constructor
+ (make-instance class)
+ (let* ((proto (%allocate-instance--class *empty-vector*)))
+ (shared-initialize proto T :check-initargs-legality-p NIL)
+ (setf (std-instance-wrapper proto) wrapper)
+ proto))))
+
+(defmethod make-direct-slotd ((class structure-class)
+ &rest initargs
+ &key
+ (name (error "Slot needs a name."))
+ (conc-name (class-defstruct-conc-name class))
+ (defstruct-accessor-symbol () acc-sym-p)
+ &allow-other-keys)
+ (declare (ignore defstruct-accessor-symbol))
+ (declare (type symbol name)
+ (type simple-string conc-name))
+ (let ((initargs (list* :class class :allow-other-keys T initargs)))
+ (unless acc-sym-p
+ (setf initargs
+ (list* :defstruct-accessor-symbol
+ (intern (concatenate 'simple-string conc-name (symbol-name name))
+ (symbol-package (class-name class)))
+ initargs)))
+ (apply #'make-instance (direct-slot-definition-class class initargs) initargs)))
+
+(defun slot-definition-defstruct-slot-description (slot)
+ (let ((type (slot-definition-type slot)))
+ `(,(slot-definition-name slot) ,(slot-definition-initform slot)
+ ,@(unless (eq type t) `(:type ,type)))))
+
+(defmethod shared-initialize :after
+ ((class structure-class)
+ slot-names
+ &key (direct-superclasses nil direct-superclasses-p)
+ (direct-slots nil direct-slots-p)
+ direct-default-initargs
+ (predicate-name nil predicate-name-p))
+ (declare (ignore slot-names direct-default-initargs))
+ (let* ((name (class-name class))
+ (from-defclass-p (slot-value class 'from-defclass-p))
+ (defstruct-form (defstruct-form name))
+ (conc-name
+ (or (if defstruct-form (defstruct-form-conc-name defstruct-form))
+ (slot-value class 'defstruct-conc-name)
+ (format nil "~S structure class " name)))
+ (defstruct-predicate
+ (if defstruct-form (defstruct-form-predicate-name defstruct-form)))
+ (pred-name ;; Predicate name for class
+ (or (if predicate-name-p (car predicate-name))
+ (if defstruct-form defstruct-predicate)
+ (slot-value class 'predicate-name)
+ (make-class-predicate-name name)))
+ (constructor
+ (or (if defstruct-form (defstruct-form-constructor defstruct-form))
+ (slot-value class 'defstruct-constructor)
+ (if from-defclass-p
+ (list (intern (format nil "~Aconstructor" conc-name)
+ (symbol-package name))
+ ())))))
+ (declare (type symbol name defstruct-predicate pred-name)
+ (type boolean from-defclass-p)
+ (type simple-string conc-name))
+ (if direct-superclasses-p
+ (setf (slot-value class 'direct-superclasses)
+ (or direct-superclasses
+ (setq direct-superclasses
+ (if (eq name 'structure-object)
+ nil
+ (list *the-class-structure-object*)))))
+ (setq direct-superclasses (slot-value class 'direct-superclasses)))
+ (setq direct-slots
+ (if direct-slots-p
+ (setf (slot-value class 'direct-slots)
+ (mapcar #'(lambda (pl)
+ (apply #'make-direct-slotd class
+ :conc-name conc-name pl))
+ direct-slots))
+ (slot-value class 'direct-slots)))
+ (when from-defclass-p
+ (do-defstruct-from-defclass
+ class direct-superclasses direct-slots conc-name pred-name constructor))
+ (compile-structure-class-internals
+ class direct-slots conc-name pred-name constructor)
+ (setf (slot-value class 'predicate-name) pred-name)
+ (setf (slot-value class 'defstruct-conc-name) conc-name)
+ (unless (extract-required-parameters (second constructor))
+ (setf (slot-value class 'defstruct-constructor) (car constructor)))
+ (when (and defstruct-predicate (not from-defclass-p))
+ (setf (symbol-function pred-name) (symbol-function defstruct-predicate)))
+ (unless (or from-defclass-p (slot-value class 'documentation))
+ (setf (slot-value class 'documentation)
+ (format nil "~S structure class made from Defstruct" name)))
+ (setf (find-class name) class)
+ (update-structure-class class direct-superclasses direct-slots)))
+
+(defun update-structure-class (class direct-superclasses direct-slots)
+ (add-direct-subclasses class direct-superclasses)
+ (setf (slot-value class 'class-precedence-list) (compute-class-precedence-list class))
+ (let* ((eslotds (compute-slots class))
+ (internal-slotds (mapcar #'slot-definition-internal-slotd eslotds)))
+ (setf (slot-value class 'slots) eslotds)
+ (setf (slot-value class 'internal-slotds) internal-slotds)
+ (setf (slot-value class 'side-effect-internal-slotds) internal-slotds))
+ (unless (slot-value class 'wrapper)
+ (setf (slot-value class 'finalized-p) T)
+ (setf (slot-value class 'wrapper) (make-wrapper class)))
+ (unless (slot-boundp class 'prototype)
+ (setf (slot-value class 'prototype) nil))
+ (setf (slot-value class 'default-initargs) nil)
+ (add-slot-accessors class direct-slots))
+
+(defmethod do-defstruct-from-defclass ((class structure-class)
+ direct-superclasses direct-slots
+ conc-name predicate constructor)
+ (declare (type simple-string conc-name))
+ (let* ((name (class-name class))
+ (original-defstruct-form
+ `(original-defstruct
+ (,name
+ ,@(when direct-superclasses
+ `((:include ,(class-name (car direct-superclasses)))))
+ (:print-function print-std-instance)
+ (:predicate ,predicate)
+ (:conc-name ,(intern conc-name (symbol-package name)))
+ (:constructor ,@constructor))
+ ,@(mapcar #'slot-definition-defstruct-slot-description
+ direct-slots))))
+ (eval original-defstruct-form)
+ (store-defstruct-form (cdr original-defstruct-form))))
+
+(defmethod compile-structure-class-internals ((class structure-class)
+ direct-slots conc-name
+ predicate-name constructor)
+ (declare (type simple-string conc-name))
+ (let* ((name (class-name class))
+ (package (symbol-package name))
+ (direct-slots-needing-internals
+ (if (slot-value class 'from-defclass-p)
+ direct-slots
+ (remove-if #'slot-definition-internal-reader-function
+ direct-slots)))
+ (reader-names
+ (mapcar #'(lambda (slotd)
+ (intern (format nil "~A~A reader" conc-name
+ (slot-definition-name slotd))
+ package))
+ direct-slots-needing-internals))
+ (writer-names
+ (mapcar #'(lambda (slotd)
+ (intern (format nil "~A~A writer" conc-name
+ (slot-definition-name slotd))
+ package))
+ direct-slots-needing-internals))
+ (defstruct-accessor-names
+ (mapcar #'slot-definition-defstruct-accessor-symbol
+ direct-slots-needing-internals))
+ (readers-init
+ (mapcar #'(lambda (defstruct-accessor reader-name)
+ `(progn
+ (force-compile ',defstruct-accessor)
+ (defun ,reader-name (obj)
+ (declare (type ,name obj) #.*optimize-speed*)
+ (,defstruct-accessor obj))
+ (force-compile ',reader-name)))
+ defstruct-accessor-names reader-names))
+ (writers-init
+ (mapcar #'(lambda (defstruct-accessor writer-name)
+ `(progn
+ (force-compile ',defstruct-accessor)
+ (defun ,writer-name (nv obj)
+ (declare (type ,name obj) #.*optimize-speed*)
+ (setf (,defstruct-accessor obj) nv))
+ (force-compile ',writer-name)))
+ defstruct-accessor-names writer-names))
+ (defstruct-extras-form
+ `(progn
+ ,@(when (car constructor)
+ `((force-compile ',(car constructor))))
+ ,@(when (fboundp predicate-name)
+ `((force-compile ',predicate-name)))
+ ,@readers-init
+ ,@writers-init)))
+ (declare (type package package))
+ (eval defstruct-extras-form)
+ (mapc #'(lambda (dslotd reader-name writer-name)
+ (setf (slot-value dslotd 'internal-reader-function)
+ (gdefinition reader-name))
+ (setf (slot-value dslotd 'internal-writer-function)
+ (gdefinition writer-name)))
+ direct-slots-needing-internals reader-names writer-names)))
+
+(defmethod reinitialize-instance :after ((class structure-class)
+ &rest initargs
+ &key)
+ (map-dependents class
+ #'(lambda (dependent)
+ (apply #'update-dependent class dependent initargs))))
+
+(defmethod direct-slot-definition-class ((class structure-class) initargs)
+ (declare (ignore initargs))
+ (find-class 'structure-direct-slot-definition))
+
+(defmethod effective-slot-definition-class ((class structure-class) initargs)
+ (declare (ignore initargs))
+ (find-class 'structure-effective-slot-definition))
+
+(defmethod finalize-inheritance ((class structure-class))
+ nil) ; always finalized
+
+(defmethod compute-slots ((class structure-class))
+ (mapcan #'(lambda (superclass)
+ (mapcar #'(lambda (dslotd)
+ (compute-effective-slot-definition
+ class (slot-definition-name dslotd) (list dslotd)))
+ (class-direct-slots superclass)))
+ (reverse (slot-value class 'class-precedence-list))))
+
+(defmethod compute-slots :around ((class structure-class))
+ (let ((eslotds (call-next-method)))
+ (mapc #'initialize-internal-slot-functions eslotds)
+ eslotds))
+
+(defmethod compute-effective-slot-definition ((class structure-class)
+ name dslotds)
+ (let* ((initargs (compute-effective-slot-definition-initargs class dslotds))
+ (class (effective-slot-definition-class class initargs))
+ (slot-definition (apply #'make-instance class initargs))
+ (internal-slotd
+ (make-internal-slotd
+ :name name
+ :slot-definition slot-definition
+ :initargs (slot-definition-initargs slot-definition)
+ :initfunction (slot-definition-initfunction slot-definition))))
+ (setf (fast-slot-value slot-definition 'internal-slotd) internal-slotd)
+ slot-definition))
+
+(defmethod compute-effective-slot-definition-initargs :around
+ ((class structure-class) direct-slotds)
+ (let ((slotd (car direct-slotds)))
+ (list* :defstruct-accessor-symbol (slot-definition-defstruct-accessor-symbol slotd)
+ :internal-reader-function (slot-definition-internal-reader-function slotd)
+ :internal-writer-function (slot-definition-internal-writer-function slotd)
+ (call-next-method))))
+
+(defmethod make-optimized-reader-method-function ((class structure-class)
+ generic-function
+ reader-method-prototype
+ slot-name)
+ (declare (ignore generic-function reader-method-prototype))
+ (make-structure-instance-reader-method-function slot-name))
+
+(defmethod make-optimized-writer-method-function ((class structure-class)
+ generic-function
+ writer-method-prototype
+ slot-name)
+ (declare (ignore generic-function writer-method-prototype))
+ (make-structure-instance-writer-method-function slot-name))
+
+(defmethod make-optimized-boundp-method-function ((class structure-class)
+ generic-function
+ boundp-method-prototype
+ slot-name)
+ (declare (ignore generic-function boundp-method-prototype))
+ (make-structure-instance-boundp-method-function slot-name))
+
+(defun make-structure-instance-reader-method-function (slot-name)
+ (declare #.*optimize-speed*)
+ #'(lambda (instance)
+ (structure-instance-slot-value instance slot-name)))
+
+(defun make-structure-instance-writer-method-function (slot-name)
+ (declare #.*optimize-speed*)
+ #'(lambda (nv instance)
+ (setf (structure-instance-slot-value instance slot-name) nv)))
+
+(defun make-structure-instance-boundp-method-function (slot-name)
+ (declare #.*optimize-speed*)
+ #'(lambda (instance)
+ (structure-instance-slot-boundp instance slot-name)))
+
+(defmethod wrapper-fetcher ((class structure-class))
+ 'wrapper-for-structure)
+
+(defmethod slots-fetcher ((class structure-class))
+ nil)
--- /dev/null
+;;;; FIXME: This should probably move to some separate tests or benchmarks
+;;;; directory.
+
+(in-package "SB-PCL")
+
+(sb-int:file-comment
+ "$Header$")
+
+(declaim (optimize (speed 3) (safety 0) (compilation-speed 0)))
+
+(defvar *tests*)
+(setq *tests* nil)
+
+(defvar m (car (generic-function-methods #'shared-initialize)))
+(defvar gf #'shared-initialize)
+(defvar c (find-class 'standard-class))
+
+(defclass str ()
+ ((slot :initform nil :reader str-slot))
+ (:metaclass structure-class))
+
+(defvar str (make-instance 'str))
+
+(push (cons "Time unoptimized slot-value. This is case (1) from notes.text. (standard)"
+ '(time-slot-value m 'plist 10000))
+ *tests*)
+(push (cons "Time unoptimized slot-value. This is case (1) from notes.text. (standard)"
+ '(time-slot-value m 'generic-function 10000))
+ *tests*)
+(push (cons "Time unoptimized slot-value. This is case (1) from notes.text. (structure)"
+ '(time-slot-value str 'slot 10000))
+ *tests*)
+(defun time-slot-value (object slot-name n)
+ (time (dotimes-fixnum (i n) (slot-value object slot-name))))
+
+(push (cons "Time optimized slot-value outside of a defmethod. Case (2). (standard)"
+ '(time-slot-value-function m 10000))
+ *tests*)
+(defun time-slot-value-function (object n)
+ (time (dotimes-fixnum (i n) (slot-value object 'function))))
+
+(push (cons "Time optimized slot-value outside of a defmethod. Case (2). (structure)"
+ '(time-slot-value-slot str 10000))
+ *tests*)
+(defun time-slot-value-slot (object n)
+ (time (dotimes-fixnum (i n) (slot-value object 'slot))))
+
+(push (cons "Time one-class dfun."
+ '(time-generic-function-methods gf 10000))
+ *tests*)
+(defun time-generic-function-methods (object n)
+ (time (dotimes-fixnum (i n) (generic-function-methods object))))
+
+(push (cons "Time one-index dfun."
+ '(time-class-precedence-list c 10000))
+ *tests*)
+(defun time-class-precedence-list (object n)
+ (time (dotimes-fixnum (i n) (class-precedence-list object))))
+
+(push (cons "Time n-n dfun."
+ '(time-method-function m 10000))
+ *tests*)
+(defun time-method-function (object n)
+ (time (dotimes-fixnum (i n) (method-function object))))
+
+(push (cons "Time caching dfun."
+ '(time-class-slots c 10000))
+ *tests*)
+(defun time-class-slots (object n)
+ (time (dotimes-fixnum (i n) (class-slots object))))
+
+(push (cons "Time typep for classes."
+ '(time-typep-standard-object m 10000))
+ *tests*)
+(defun time-typep-standard-object (object n)
+ (time (dotimes-fixnum (i n) (typep object 'standard-object))))
+
+(push (cons "Time default-initargs."
+ '(time-default-initargs (find-class 'plist-mixin) 1000))
+ *tests*)
+(defun time-default-initargs (class n)
+ (time (dotimes-fixnum (i n) (default-initargs class nil))))
+
+(push (cons "Time make-instance."
+ '(time-make-instance (find-class 'plist-mixin) 1000))
+ *tests*)
+(defun time-make-instance (class n)
+ (time (dotimes-fixnum (i n) (make-instance class))))
+
+(push (cons "Time constant-keys make-instance."
+ '(time-constant-keys-make-instance 1000))
+ *tests*)
+
+(expanding-make-instance-top-level
+(defun constant-keys-make-instance (n)
+ (dotimes-fixnum (i n) (make-instance 'plist-mixin))))
+
+(precompile-random-code-segments)
+
+(defun time-constant-keys-make-instance (n)
+ (time (constant-keys-make-instance n)))
+
+(defun expand-all-macros (form)
+ (walk-form form nil #'(lambda (form context env)
+ (if (and (eq context :eval)
+ (consp form)
+ (symbolp (car form))
+ (not (special-form-p (car form)))
+ (macro-function (car form)))
+ (values (macroexpand form env))
+ form))))
+
+(push (cons "Macroexpand meth-structure-slot-value"
+ '(pprint (multiple-value-bind (pgf pm)
+ (prototypes-for-make-method-lambda
+ 'meth-structure-slot-value)
+ (expand-defmethod
+ 'meth-structure-slot-value pgf pm
+ nil '((object str))
+ '(#'(lambda () (slot-value object 'slot)))
+ nil))))
+ *tests*)
+
+(push (cons "Show code for slot-value inside a defmethod for a structure-class. Case (3)."
+ '(disassemble (meth-structure-slot-value str)))
+ *tests*)
+(defmethod meth-structure-slot-value ((object str))
+ #'(lambda () (slot-value object 'slot)))
+
+#|| ; interesting, but long. (produces 100 lines of output)
+(push (cons "Macroexpand meth-standard-slot-value"
+ '(pprint (expand-all-macros
+ (expand-defmethod-internal 'meth-standard-slot-value
+ nil '((object standard-method))
+ '(#'(lambda () (slot-value object 'function)))
+ nil))))
+ *tests*)
+(push (cons "Show code for slot-value inside a defmethod for a standard-class. Case (4)."
+ '(disassemble (meth-standard-slot-value m)))
+ *tests*)
+(defmethod meth-standard-slot-value ((object standard-method))
+ #'(lambda () (slot-value object 'function)))
+||#
+
+(defun do-tests ()
+ (dolist (doc+form (reverse *tests*))
+ (format t "~&~%~A~%" (car doc+form))
+ (pprint (cdr doc+form))
+ (eval (cdr doc+form))))
--- /dev/null
+;;;; permutation vectors
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+
+;;;; This software is derived from software originally released by Xerox
+;;;; Corporation. Copyright and release statements follow. Later modifications
+;;;; to the software are in the public domain and are provided with
+;;;; absolutely no warranty. See the COPYING and CREDITS files for more
+;;;; information.
+
+;;;; copyright information from original PCL sources:
+;;;;
+;;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
+;;;; All rights reserved.
+;;;;
+;;;; Use and copying of this software and preparation of derivative works based
+;;;; upon this software are permitted. Any distribution of this software or
+;;;; derivative works must comply with all applicable United States export
+;;;; control laws.
+;;;;
+;;;; This software is made available AS IS, and Xerox Corporation makes no
+;;;; warranty about the software, its performance or its conformity to any
+;;;; specification.
+
+(in-package "SB-PCL")
+
+(sb-int:file-comment
+ "$Header$")
+\f
+(defmacro instance-slot-index (wrapper slot-name)
+ `(let ((pos 0))
+ (declare (fixnum pos))
+ (block loop
+ (dolist (sn (wrapper-instance-slots-layout ,wrapper))
+ (when (eq ,slot-name sn) (return-from loop pos))
+ (incf pos)))))
+\f
+(defun pv-cache-limit-fn (nlines)
+ (default-limit-fn nlines))
+
+(defstruct (pv-table
+ (:predicate pv-tablep)
+ (:constructor make-pv-table-internal
+ (slot-name-lists call-list)))
+ (cache nil :type (or cache null))
+ (pv-size 0 :type fixnum)
+ (slot-name-lists nil :type list)
+ (call-list nil :type list))
+
+#-sb-fluid (declaim (sb-ext:freeze-type pv-table))
+
+(defvar *initial-pv-table* (make-pv-table-internal nil nil))
+
+; help new slot-value-using-class methods affect fast iv access
+(defvar *all-pv-table-list* nil)
+
+(defun make-pv-table (&key slot-name-lists call-list)
+ (let ((pv-table (make-pv-table-internal slot-name-lists call-list)))
+ (push pv-table *all-pv-table-list*)
+ pv-table))
+
+(defun make-pv-table-type-declaration (var)
+ `(type pv-table ,var))
+
+(defvar *slot-name-lists-inner* (make-hash-table :test 'equal))
+(defvar *slot-name-lists-outer* (make-hash-table :test 'equal))
+
+;entries in this are lists of (table . pv-offset-list)
+(defvar *pv-key-to-pv-table-table* (make-hash-table :test 'equal))
+
+(defun intern-pv-table (&key slot-name-lists call-list)
+ (let ((new-p nil))
+ (flet ((inner (x)
+ (or (gethash x *slot-name-lists-inner*)
+ (setf (gethash x *slot-name-lists-inner*) (copy-list x))))
+ (outer (x)
+ (or (gethash x *slot-name-lists-outer*)
+ (setf (gethash x *slot-name-lists-outer*)
+ (let ((snl (copy-list (cdr x)))
+ (cl (car x)))
+ (setq new-p t)
+ (make-pv-table :slot-name-lists snl
+ :call-list cl))))))
+ (let ((pv-table (outer (mapcar #'inner (cons call-list slot-name-lists)))))
+ (when new-p
+ (let ((pv-index 1))
+ (dolist (slot-name-list slot-name-lists)
+ (dolist (slot-name (cdr slot-name-list))
+ (note-pv-table-reference slot-name pv-index pv-table)
+ (incf pv-index)))
+ (dolist (gf-call call-list)
+ (note-pv-table-reference gf-call pv-index pv-table)
+ (incf pv-index))
+ (setf (pv-table-pv-size pv-table) pv-index)))
+ pv-table))))
+
+(defun note-pv-table-reference (ref pv-offset pv-table)
+ (let ((entry (gethash ref *pv-key-to-pv-table-table*)))
+ (when (listp entry)
+ (let ((table-entry (assq pv-table entry)))
+ (when (and (null table-entry)
+ (> (length entry) 8))
+ (let ((new-table-table (make-hash-table :size 16 :test 'eq)))
+ (dolist (table-entry entry)
+ (setf (gethash (car table-entry) new-table-table)
+ (cdr table-entry)))
+ (setf (gethash ref *pv-key-to-pv-table-table*) new-table-table)))
+ (when (listp entry)
+ (if (null table-entry)
+ (let ((new (cons pv-table pv-offset)))
+ (if (consp entry)
+ (push new (cdr entry))
+ (setf (gethash ref *pv-key-to-pv-table-table*)
+ (list new))))
+ (push pv-offset (cdr table-entry)))
+ (return-from note-pv-table-reference nil))))
+ (let ((list (gethash pv-table entry)))
+ (if (consp list)
+ (push pv-offset (cdr list))
+ (setf (gethash pv-table entry) (list pv-offset)))))
+ nil)
+
+(defun map-pv-table-references-of (ref function)
+ (let ((entry (gethash ref *pv-key-to-pv-table-table*)))
+ (if (listp entry)
+ (dolist (table+pv-offset-list entry)
+ (funcall function
+ (car table+pv-offset-list)
+ (cdr table+pv-offset-list)))
+ (maphash function entry)))
+ ref)
+\f
+(defvar *pvs* (make-hash-table :test 'equal))
+
+(defun optimize-slot-value-by-class-p (class slot-name type)
+ (or (not (eq *boot-state* 'complete))
+ (let ((slotd (find-slot-definition class slot-name)))
+ (and slotd
+ (slot-accessor-std-p slotd type)))))
+
+(defun compute-pv-slot (slot-name wrapper class class-slots class-slot-p-cell)
+ (if (symbolp slot-name)
+ (when (optimize-slot-value-by-class-p class slot-name 'all)
+ (or (instance-slot-index wrapper slot-name)
+ (let ((cell (assq slot-name class-slots)))
+ (when cell
+ (setf (car class-slot-p-cell) t)
+ cell))))
+ (when (consp slot-name)
+ (dolist (type '(reader writer) nil)
+ (when (eq (car slot-name) type)
+ (return
+ (let* ((gf-name (cadr slot-name))
+ (gf (gdefinition gf-name))
+ (location (when (eq *boot-state* 'complete)
+ (accessor-values1 gf type class))))
+ (when (consp location)
+ (setf (car class-slot-p-cell) t))
+ location)))))))
+
+(defun compute-pv (slot-name-lists wrappers)
+ (unless (listp wrappers) (setq wrappers (list wrappers)))
+ (let* ((not-simple-p-cell (list nil))
+ (elements
+ (gathering1 (collecting)
+ (iterate ((slot-names (list-elements slot-name-lists)))
+ (when slot-names
+ (let* ((wrapper (pop wrappers))
+ (std-p (typep wrapper 'wrapper))
+ (class (wrapper-class* wrapper))
+ (class-slots (and std-p (wrapper-class-slots wrapper))))
+ (dolist (slot-name (cdr slot-names))
+ (gather1
+ (when std-p
+ (compute-pv-slot slot-name wrapper class
+ class-slots not-simple-p-cell))))))))))
+ (if (car not-simple-p-cell)
+ (make-permutation-vector (cons t elements))
+ (or (gethash elements *pvs*)
+ (setf (gethash elements *pvs*)
+ (make-permutation-vector (cons nil elements)))))))
+
+(defun compute-calls (call-list wrappers)
+ (declare (ignore call-list wrappers))
+ #||
+ (map 'vector
+ #'(lambda (call)
+ (compute-emf-from-wrappers call wrappers))
+ call-list)
+ ||#
+ '#())
+
+#|| ; Need to finish this, then write the maintenance functions.
+(defun compute-emf-from-wrappers (call wrappers)
+ (when call
+ (destructuring-bind (gf-name nreq restp arg-info) call
+ (if (eq gf-name 'make-instance)
+ (error "should not get here") ; there is another mechanism for this.
+ #'(lambda (&rest args)
+ (if (not (eq *boot-state* 'complete))
+ (apply (gdefinition gf-name) args)
+ (let* ((gf (gdefinition gf-name))
+ (arg-info (arg-info-reader gf))
+ (classes '?)
+ (types '?)
+ (emf (cache-miss-values-internal gf arg-info
+ wrappers classes types
+ 'caching)))
+ (update-all-pv-tables call wrappers emf)
+ (invoke-emf emf args))))))))
+||#
+
+(defun make-permutation-vector (indexes)
+ (make-array (length indexes) :initial-contents indexes))
+
+(defun pv-table-lookup (pv-table pv-wrappers)
+ (let* ((slot-name-lists (pv-table-slot-name-lists pv-table))
+ (call-list (pv-table-call-list pv-table))
+ (cache (or (pv-table-cache pv-table)
+ (setf (pv-table-cache pv-table)
+ (get-cache (- (length slot-name-lists)
+ (count nil slot-name-lists))
+ t
+ #'pv-cache-limit-fn
+ 2)))))
+ (or (probe-cache cache pv-wrappers)
+ (let* ((pv (compute-pv slot-name-lists pv-wrappers))
+ (calls (compute-calls call-list pv-wrappers))
+ (pv-cell (cons pv calls))
+ (new-cache (fill-cache cache pv-wrappers pv-cell)))
+ (unless (eq new-cache cache)
+ (setf (pv-table-cache pv-table) new-cache)
+ (free-cache cache))
+ pv-cell))))
+
+(defun make-pv-type-declaration (var)
+ `(type simple-vector ,var))
+
+(defvar *empty-pv* #())
+
+(defmacro pvref (pv index)
+ `(svref ,pv ,index))
+
+(defmacro copy-pv (pv)
+ `(copy-seq ,pv))
+
+(defun make-calls-type-declaration (var)
+ `(type simple-vector ,var))
+
+(defmacro callsref (calls index)
+ `(svref ,calls ,index))
+
+(defvar *pv-table-cache-update-info* nil)
+
+;called by:
+;(method shared-initialize :after (structure-class t))
+;update-slots
+(defun update-pv-table-cache-info (class)
+ (let ((slot-names-for-pv-table-update nil)
+ (new-icui nil))
+ (dolist (icu *pv-table-cache-update-info*)
+ (if (eq (car icu) class)
+ (pushnew (cdr icu) slot-names-for-pv-table-update)
+ (push icu new-icui)))
+ (setq *pv-table-cache-update-info* new-icui)
+ (when slot-names-for-pv-table-update
+ (update-all-pv-table-caches class slot-names-for-pv-table-update))))
+
+(defun update-all-pv-table-caches (class slot-names)
+ (let* ((cwrapper (class-wrapper class))
+ (std-p (typep cwrapper 'wrapper))
+ (class-slots (and std-p (wrapper-class-slots cwrapper)))
+ (class-slot-p-cell (list nil))
+ (new-values (mapcar #'(lambda (slot-name)
+ (cons slot-name
+ (when std-p
+ (compute-pv-slot
+ slot-name cwrapper class
+ class-slots class-slot-p-cell))))
+ slot-names))
+ (pv-tables nil))
+ (dolist (slot-name slot-names)
+ (map-pv-table-references-of
+ slot-name
+ #'(lambda (pv-table pv-offset-list)
+ (declare (ignore pv-offset-list))
+ (pushnew pv-table pv-tables))))
+ (dolist (pv-table pv-tables)
+ (let* ((cache (pv-table-cache pv-table))
+ (slot-name-lists (pv-table-slot-name-lists pv-table))
+ (pv-size (pv-table-pv-size pv-table))
+ (pv-map (make-array pv-size :initial-element nil)))
+ (let ((map-index 1)(param-index 0))
+ (dolist (slot-name-list slot-name-lists)
+ (dolist (slot-name (cdr slot-name-list))
+ (let ((a (assoc slot-name new-values)))
+ (setf (svref pv-map map-index)
+ (and a (cons param-index (cdr a)))))
+ (incf map-index))
+ (incf param-index)))
+ (when cache
+ (map-cache #'(lambda (wrappers pv-cell)
+ (setf (car pv-cell)
+ (update-slots-in-pv wrappers (car pv-cell)
+ cwrapper pv-size pv-map)))
+ cache))))))
+
+(defun update-slots-in-pv (wrappers pv cwrapper pv-size pv-map)
+ (if (not (if (atom wrappers)
+ (eq cwrapper wrappers)
+ (dolist (wrapper wrappers nil)
+ (when (eq wrapper cwrapper)
+ (return t)))))
+ pv
+ (let* ((old-intern-p (listp (pvref pv 0)))
+ (new-pv (if old-intern-p
+ (copy-pv pv)
+ pv))
+ (new-intern-p t))
+ (if (atom wrappers)
+ (dotimes-fixnum (i pv-size)
+ (when (consp (let ((map (svref pv-map i)))
+ (if map
+ (setf (pvref new-pv i) (cdr map))
+ (pvref new-pv i))))
+ (setq new-intern-p nil)))
+ (let ((param 0))
+ (dolist (wrapper wrappers)
+ (when (eq wrapper cwrapper)
+ (dotimes-fixnum (i pv-size)
+ (when (consp (let ((map (svref pv-map i)))
+ (if (and map (= (car map) param))
+ (setf (pvref new-pv i) (cdr map))
+ (pvref new-pv i))))
+ (setq new-intern-p nil))))
+ (incf param))))
+ (when new-intern-p
+ (setq new-pv (let ((list-pv (coerce pv 'list)))
+ (or (gethash (cdr list-pv) *pvs*)
+ (setf (gethash (cdr list-pv) *pvs*)
+ (if old-intern-p
+ new-pv
+ (make-permutation-vector list-pv)))))))
+ new-pv)))
+\f
+(defun maybe-expand-accessor-form (form required-parameters slots env)
+ (let* ((fname (car form))
+ #||(len (length form))||#
+ (gf (if (symbolp fname)
+ (unencapsulated-fdefinition fname)
+ (gdefinition fname))))
+ (macrolet ((maybe-optimize-reader ()
+ `(let ((parameter
+ (can-optimize-access1 (cadr form)
+ required-parameters env)))
+ (when parameter
+ (optimize-reader slots parameter gf-name form))))
+ (maybe-optimize-writer ()
+ `(let ((parameter
+ (can-optimize-access1 (caddr form)
+ required-parameters env)))
+ (when parameter
+ (optimize-writer slots parameter gf-name form)))))
+ (unless (and (consp (cadr form))
+ (eq 'instance-accessor-parameter (caadr form)))
+ (or #||
+ (cond ((and (= len 2) (symbolp fname))
+ (let ((gf-name (gethash fname *gf-declared-reader-table*)))
+ (when gf-name
+ (maybe-optimize-reader))))
+ ((= len 3)
+ (let ((gf-name (gethash fname *gf-declared-writer-table*)))
+ (when gf-name
+ (maybe-optimize-writer)))))
+ ||#
+ (when (and (eq *boot-state* 'complete)
+ (generic-function-p gf))
+ (let ((methods (generic-function-methods gf)))
+ (when methods
+ (let* ((gf-name (generic-function-name gf))
+ (arg-info (gf-arg-info gf))
+ (metatypes (arg-info-metatypes arg-info))
+ (nreq (length metatypes))
+ (applyp (arg-info-applyp arg-info)))
+ (when (null applyp)
+ (cond ((= nreq 1)
+ (when (some #'standard-reader-method-p methods)
+ (maybe-optimize-reader)))
+ ((and (= nreq 2)
+ (consp gf-name)
+ (eq (car gf-name) 'setf))
+ (when (some #'standard-writer-method-p methods)
+ (maybe-optimize-writer))))))))))))))
+
+(defun optimize-generic-function-call (form
+ required-parameters
+ env
+ slots
+ calls)
+ (declare (ignore required-parameters env slots calls))
+ (or (and (eq (car form) 'make-instance)
+ (expand-make-instance-form form))
+ #||
+ (maybe-expand-accessor-form form required-parameters slots env)
+ (let* ((fname (car form))
+ (len (length form))
+ (gf (if (symbolp fname)
+ (and (fboundp fname)
+ (unencapsulated-fdefinition fname))
+ (and (gboundp fname)
+ (gdefinition fname))))
+ (gf-name (and (fsc-instance-p gf)
+ (if (early-gf-p gf)
+ (early-gf-name gf)
+ (generic-function-name gf)))))
+ (when gf-name
+ (multiple-value-bind (nreq restp)
+ (get-generic-function-info gf)
+ (optimize-gf-call slots calls form nreq restp env))))
+ ||#
+ form))
+\f
+(defun can-optimize-access (form required-parameters env)
+ (let ((type (ecase (car form)
+ (slot-value 'reader)
+ (set-slot-value 'writer)
+ (slot-boundp 'boundp)))
+ (var (cadr form))
+ (slot-name (eval (caddr form)))) ; known to be constant
+ (can-optimize-access1 var required-parameters env type slot-name)))
+
+;;; FIXME: This looks like an internal helper function for CAN-OPTIMIZE-ACCESS,
+;;; and it is used that way, but
+;;; it's also called bare from several places in the code. Perhaps
+;;; the two functions should be renamed fo CAN-OPTIMIZE-ACCESS-FOR-FORM
+;;; and CAN-OPTIMIZE-ACCESS-FOR-VAR. If so, I'd just as soon use keyword
+;;; args instead of optional ones, too.
+(defun can-optimize-access1 (var required-parameters env
+ &optional type slot-name)
+ (when (and (consp var) (eq 'the (car var)))
+ ;; FIXME: We should assert list of length 3 here. Or maybe we should just
+ ;; define EXTRACT-THE, replace the whole
+ ;; (WHEN ..)
+ ;; form with
+ ;; (AWHEN (EXTRACT-THE VAR)
+ ;; (SETF VAR IT))
+ ;; and then use EXTRACT-THE similarly to clean up the other tests against
+ ;; 'THE scattered through the PCL code.
+ (setq var (caddr var)))
+ (when (symbolp var)
+ (let* ((rebound? (caddr (variable-declaration 'variable-rebinding
+ var
+ env)))
+ (parameter-or-nil (car (memq (or rebound? var)
+ required-parameters))))
+ (when parameter-or-nil
+ (let* ((class-name (caddr (variable-declaration 'class
+ parameter-or-nil
+ env)))
+ (class (find-class class-name nil)))
+ (when (or (not (eq *boot-state* 'complete))
+ (and class (not (class-finalized-p class))))
+ (setq class nil))
+ (when (and class-name (not (eq class-name 't)))
+ (when (or (null type)
+ (not (and class
+ (memq *the-class-structure-object*
+ (class-precedence-list class))))
+ (optimize-slot-value-by-class-p class slot-name type))
+ (cons parameter-or-nil (or class class-name)))))))))
+
+(defun optimize-slot-value (slots sparameter form)
+ (if sparameter
+ (destructuring-bind (ignore1 ignore2 slot-name-form) form
+ (declare (ignore ignore1 ignore2))
+ (let ((slot-name (eval slot-name-form)))
+ (optimize-instance-access slots :read sparameter slot-name nil)))
+ `(accessor-slot-value ,@(cdr form))))
+
+(defun optimize-set-slot-value (slots sparameter form)
+ (if sparameter
+ (destructuring-bind (ignore1 ignore2 slot-name-form new-value) form
+ (declare (ignore ignore1 ignore2))
+ (let ((slot-name (eval slot-name-form)))
+ (optimize-instance-access slots
+ :write
+ sparameter
+ slot-name
+ new-value)))
+ `(accessor-set-slot-value ,@(cdr form))))
+
+(defun optimize-slot-boundp (slots sparameter form)
+ (if sparameter
+ (destructuring-bind
+ ;; FIXME: In CMU CL ca. 19991205, this binding list had a fourth
+ ;; element in it, NEW-VALUE. It's hard to see how that could possibly
+ ;; be right, since SLOT-BOUNDP has no NEW-VALUE. Since it was causing
+ ;; a failure in building PCL for SBCL, so I changed it to match the
+ ;; definition of SLOT-BOUNDP (and also to match the list used in the
+ ;; similar OPTIMIZE-SLOT-VALUE, above). However, I'm weirded out by
+ ;; this, since this is old code which has worked for ages to build
+ ;; PCL for CMU CL, so it's hard to see why it should need a patch
+ ;; like this in order to build PCL for SBCL. I'd like to return to
+ ;; this and find a test case which exercises this function both in
+ ;; CMU CL, to see whether it's really a previously-unexercised bug or
+ ;; whether I've misunderstood something (and, presumably, patched it
+ ;; wrong).
+ (slot-boundp-symbol instance slot-name-form)
+ form
+ (declare (ignore slot-boundp-symbol instance))
+ (let ((slot-name (eval slot-name-form)))
+ (optimize-instance-access slots
+ :boundp
+ sparameter
+ slot-name
+ nil)))
+ `(accessor-slot-boundp ,@(cdr form))))
+
+(defun optimize-reader (slots sparameter gf-name form)
+ (if sparameter
+ (optimize-accessor-call slots :read sparameter gf-name nil)
+ form))
+
+(defun optimize-writer (slots sparameter gf-name form)
+ (if sparameter
+ (destructuring-bind (ignore1 ignore2 new-value) form
+ (declare (ignore ignore1 ignore2))
+ (optimize-accessor-call slots :write sparameter gf-name new-value))
+ form))
+
+;;; The SLOTS argument is an alist, the CAR of each entry is the name of
+;;; a required parameter to the function. The alist is in order, so the
+;;; position of an entry in the alist corresponds to the argument's position
+;;; in the lambda list.
+(defun optimize-instance-access (slots
+ read/write
+ sparameter
+ slot-name
+ new-value)
+ (let ((class (if (consp sparameter) (cdr sparameter) *the-class-t*))
+ (parameter (if (consp sparameter) (car sparameter) sparameter)))
+ (if (and (eq *boot-state* 'complete)
+ (classp class)
+ (memq *the-class-structure-object* (class-precedence-list class)))
+ (let ((slotd (find-slot-definition class slot-name)))
+ (ecase read/write
+ (:read
+ `(,(slot-definition-defstruct-accessor-symbol slotd) ,parameter))
+ (:write
+ `(setf (,(slot-definition-defstruct-accessor-symbol slotd)
+ ,parameter)
+ ,new-value))
+ (:boundp
+ 'T)))
+ (let* ((parameter-entry (assq parameter slots))
+ (slot-entry (assq slot-name (cdr parameter-entry)))
+ (position (posq parameter-entry slots))
+ (pv-offset-form (list 'pv-offset ''.PV-OFFSET.)))
+ (unless parameter-entry
+ (error "internal error in slot optimization"))
+ (unless slot-entry
+ (setq slot-entry (list slot-name))
+ (push slot-entry (cdr parameter-entry)))
+ (push pv-offset-form (cdr slot-entry))
+ (ecase read/write
+ (:read
+ `(instance-read ,pv-offset-form ,parameter ,position
+ ',slot-name ',class))
+ (:write
+ `(let ((.new-value. ,new-value))
+ (instance-write ,pv-offset-form ,parameter ,position
+ ',slot-name ',class .new-value.)))
+ (:boundp
+ `(instance-boundp ,pv-offset-form ,parameter ,position
+ ',slot-name ',class)))))))
+
+(defun optimize-accessor-call (slots read/write sparameter gf-name new-value)
+ (let* ((class (if (consp sparameter) (cdr sparameter) *the-class-t*))
+ (parameter (if (consp sparameter) (car sparameter) sparameter))
+ (parameter-entry (assq parameter slots))
+ (name (case read/write
+ (:read `(reader ,gf-name))
+ (:write `(writer ,gf-name))))
+ (slot-entry (assoc name (cdr parameter-entry) :test #'equal))
+ (position (posq parameter-entry slots))
+ (pv-offset-form (list 'pv-offset ''.PV-OFFSET.)))
+ (unless parameter-entry
+ (error "internal error in slot optimization"))
+ (unless slot-entry
+ (setq slot-entry (list name))
+ (push slot-entry (cdr parameter-entry)))
+ (push pv-offset-form (cdr slot-entry))
+ (ecase read/write
+ (:read
+ `(instance-reader ,pv-offset-form ,parameter ,position ,gf-name ',class))
+ (:write
+ `(let ((.new-value. ,new-value))
+ (instance-writer ,pv-offset-form ,parameter ,position ,gf-name ',class
+ .new-value.))))))
+
+(defvar *unspecific-arg* '..unspecific-arg..)
+
+(defun optimize-gf-call-internal (form slots env)
+ (when (and (consp form)
+ (eq (car form) 'the))
+ (setq form (caddr form)))
+ (or (and (symbolp form)
+ (let* ((rebound? (caddr (variable-declaration 'variable-rebinding
+ form env)))
+ (parameter-or-nil (car (assq (or rebound? form) slots))))
+ (when parameter-or-nil
+ (let* ((class-name (caddr (variable-declaration
+ 'class parameter-or-nil env))))
+ (when (and class-name (not (eq class-name 't)))
+ (position parameter-or-nil slots :key #'car))))))
+ (if (constantp form)
+ (let ((form (eval form)))
+ (if (symbolp form)
+ form
+ *unspecific-arg*))
+ *unspecific-arg*)))
+
+(defun optimize-gf-call (slots calls gf-call-form nreq restp env)
+ (unless (eq (car gf-call-form) 'make-instance) ; needs more work
+ (let* ((args (cdr gf-call-form))
+ (all-args-p (eq (car gf-call-form) 'make-instance))
+ (non-required-args (nthcdr nreq args))
+ (required-args (ldiff args non-required-args))
+ (call-spec (list (car gf-call-form) nreq restp
+ (mapcar #'(lambda (form)
+ (optimize-gf-call-internal form slots env))
+ (if all-args-p
+ args
+ required-args))))
+ (call-entry (assoc call-spec calls :test #'equal))
+ (pv-offset-form (list 'pv-offset ''.PV-OFFSET.)))
+ (unless (some #'integerp
+ (let ((spec-args (cdr call-spec)))
+ (if all-args-p
+ (ldiff spec-args (nthcdr nreq spec-args))
+ spec-args)))
+ (return-from optimize-gf-call nil))
+ (unless call-entry
+ (setq call-entry (list call-spec))
+ (push call-entry (cdr calls)))
+ (push pv-offset-form (cdr call-entry))
+ (if (eq (car call-spec) 'make-instance)
+ `(funcall (pv-ref .pv. ,pv-offset-form) ,@(cdr gf-call-form))
+ `(let ((.emf. (pv-ref .pv. ,pv-offset-form)))
+ (invoke-effective-method-function .emf. ,restp
+ ,@required-args ,@(when restp `((list ,@non-required-args)))))))))
+
+(define-walker-template pv-offset) ; These forms get munged by mutate slots.
+(defmacro pv-offset (arg) arg)
+(define-walker-template instance-accessor-parameter)
+(defmacro instance-accessor-parameter (x) x)
+
+;; It is safe for these two functions to be wrong.
+;; They just try to guess what the most likely case will be.
+(defun generate-fast-class-slot-access-p (class-form slot-name-form)
+ (let ((class (and (constantp class-form) (eval class-form)))
+ (slot-name (and (constantp slot-name-form) (eval slot-name-form))))
+ (and (eq *boot-state* 'complete)
+ (standard-class-p class)
+ (not (eq class *the-class-t*)) ; shouldn't happen, though.
+ (let ((slotd (find-slot-definition class slot-name)))
+ (and slotd (classp (slot-definition-allocation slotd)))))))
+
+(defun skip-fast-slot-access-p (class-form slot-name-form type)
+ (let ((class (and (constantp class-form) (eval class-form)))
+ (slot-name (and (constantp slot-name-form) (eval slot-name-form))))
+ (and (eq *boot-state* 'complete)
+ (standard-class-p class)
+ (not (eq class *the-class-t*)) ; shouldn't happen, though.
+ (let ((slotd (find-slot-definition class slot-name)))
+ (and slotd (skip-optimize-slot-value-by-class-p class slot-name type))))))
+
+(defun skip-optimize-slot-value-by-class-p (class slot-name type)
+ (let ((slotd (find-slot-definition class slot-name)))
+ (and slotd
+ (eq *boot-state* 'complete)
+ (not (slot-accessor-std-p slotd type)))))
+
+(defmacro instance-read-internal (pv slots pv-offset default &optional type)
+ (unless (member type '(nil :instance :class :default))
+ (error "illegal type argument to ~S: ~S" 'instance-read-internal type))
+ (if (eq type ':default)
+ default
+ (let* ((index (gensym))
+ (value index))
+ `(locally (declare #.*optimize-speed*)
+ (let ((,index (pvref ,pv ,pv-offset)))
+ (setq ,value (typecase ,index
+ ,@(when (or (null type) (eq type ':instance))
+ `((fixnum (%instance-ref ,slots ,index))))
+ ,@(when (or (null type) (eq type ':class))
+ `((cons (cdr ,index))))
+ (t ',*slot-unbound*)))
+ (if (eq ,value ',*slot-unbound*)
+ ,default
+ ,value))))))
+
+(defmacro instance-read (pv-offset parameter position slot-name class)
+ (if (skip-fast-slot-access-p class slot-name 'reader)
+ `(accessor-slot-value ,parameter ,slot-name)
+ `(instance-read-internal .pv. ,(slot-vector-symbol position)
+ ,pv-offset (accessor-slot-value ,parameter ,slot-name)
+ ,(if (generate-fast-class-slot-access-p class slot-name)
+ ':class ':instance))))
+
+(defmacro instance-reader (pv-offset parameter position gf-name class)
+ (declare (ignore class))
+ `(instance-read-internal .pv. ,(slot-vector-symbol position)
+ ,pv-offset
+ (,gf-name (instance-accessor-parameter ,parameter))
+ :instance))
+
+(defmacro instance-write-internal (pv slots pv-offset new-value default
+ &optional type)
+ (unless (member type '(nil :instance :class :default))
+ (error "illegal type argument to ~S: ~S" 'instance-write-internal type))
+ (if (eq type ':default)
+ default
+ (let* ((index (gensym)))
+ `(locally (declare #.*optimize-speed*)
+ (let ((,index (pvref ,pv ,pv-offset)))
+ (typecase ,index
+ ,@(when (or (null type) (eq type ':instance))
+ `((fixnum (setf (%instance-ref ,slots ,index) ,new-value))))
+ ,@(when (or (null type) (eq type ':class))
+ `((cons (setf (cdr ,index) ,new-value))))
+ (t ,default)))))))
+
+(defmacro instance-write (pv-offset
+ parameter
+ position
+ slot-name
+ class
+ new-value)
+ (if (skip-fast-slot-access-p class slot-name 'writer)
+ `(accessor-set-slot-value ,parameter ,slot-name ,new-value)
+ `(instance-write-internal .pv. ,(slot-vector-symbol position)
+ ,pv-offset ,new-value
+ (accessor-set-slot-value ,parameter ,slot-name ,new-value)
+ ,(if (generate-fast-class-slot-access-p class slot-name)
+ ':class ':instance))))
+
+(defmacro instance-writer (pv-offset
+ parameter
+ position
+ gf-name
+ class
+ new-value)
+ (declare (ignore class))
+ `(instance-write-internal .pv. ,(slot-vector-symbol position)
+ ,pv-offset ,new-value
+ (,(if (consp gf-name)
+ (get-setf-function-name gf-name)
+ gf-name)
+ (instance-accessor-parameter ,parameter)
+ ,new-value)
+ :instance))
+
+(defmacro instance-boundp-internal (pv slots pv-offset default
+ &optional type)
+ (unless (member type '(nil :instance :class :default))
+ (error "illegal type argument to ~S: ~S" 'instance-boundp-internal type))
+ (if (eq type ':default)
+ default
+ (let* ((index (gensym)))
+ `(locally (declare #.*optimize-speed*)
+ (let ((,index (pvref ,pv ,pv-offset)))
+ (typecase ,index
+ ,@(when (or (null type) (eq type ':instance))
+ `((fixnum (not (eq (%instance-ref ,slots ,index)
+ ',*slot-unbound*)))))
+ ,@(when (or (null type) (eq type ':class))
+ `((cons (not (eq (cdr ,index) ',*slot-unbound*)))))
+ (t ,default)))))))
+
+(defmacro instance-boundp (pv-offset parameter position slot-name class)
+ (if (skip-fast-slot-access-p class slot-name 'boundp)
+ `(accessor-slot-boundp ,parameter ,slot-name)
+ `(instance-boundp-internal .pv. ,(slot-vector-symbol position)
+ ,pv-offset (accessor-slot-boundp ,parameter ,slot-name)
+ ,(if (generate-fast-class-slot-access-p class slot-name)
+ ':class ':instance))))
+
+;;; This magic function has quite a job to do indeed.
+;;;
+;;; The careful reader will recall that <slots> contains all of the optimized
+;;; slot access forms produced by OPTIMIZE-INSTANCE-ACCESS. Each of these is
+;;; a call to either INSTANCE-READ or INSTANCE-WRITE.
+;;;
+;;; At the time these calls were produced, the first argument was specified as
+;;; the symbol .PV-OFFSET.; what we have to do now is convert those pv-offset
+;;; arguments into the actual number that is the correct offset into the pv.
+;;;
+;;; But first, oh but first, we sort <slots> a bit so that for each argument we
+;;; have the slots in alphabetical order. This canonicalizes the PV-TABLE's a
+;;; bit and will hopefully lead to having fewer PV's floating around. Even if
+;;; the gain is only modest, it costs nothing.
+(defun slot-name-lists-from-slots (slots calls)
+ (multiple-value-bind (slots calls) (mutate-slots-and-calls slots calls)
+ (let* ((slot-name-lists
+ (mapcar #'(lambda (parameter-entry)
+ (cons nil (mapcar #'car (cdr parameter-entry))))
+ slots))
+ (call-list
+ (mapcar #'car calls)))
+ (dolist (call call-list)
+ (dolist (arg (cdr call))
+ (when (integerp arg)
+ (setf (car (nth arg slot-name-lists)) t))))
+ (setq slot-name-lists (mapcar #'(lambda (r+snl)
+ (when (or (car r+snl) (cdr r+snl))
+ r+snl))
+ slot-name-lists))
+ (let ((cvt (apply #'vector
+ (let ((i -1))
+ (mapcar #'(lambda (r+snl)
+ (when r+snl (incf i)))
+ slot-name-lists)))))
+ (setq call-list (mapcar #'(lambda (call)
+ (cons (car call)
+ (mapcar #'(lambda (arg)
+ (if (integerp arg)
+ (svref cvt arg)
+ arg))
+ (cdr call))))
+ call-list)))
+ (values slot-name-lists call-list))))
+
+(defun mutate-slots-and-calls (slots calls)
+ (let ((sorted-slots (sort-slots slots))
+ (sorted-calls (sort-calls (cdr calls)))
+ (pv-offset 0)) ; index 0 is for info
+ (dolist (parameter-entry sorted-slots)
+ (dolist (slot-entry (cdr parameter-entry))
+ (incf pv-offset)
+ (dolist (form (cdr slot-entry))
+ (setf (cadr form) pv-offset))))
+ (dolist (call-entry sorted-calls)
+ (incf pv-offset)
+ (dolist (form (cdr call-entry))
+ (setf (cadr form) pv-offset)))
+ (values sorted-slots sorted-calls)))
+
+(defun symbol-pkg-name (sym)
+ (let ((pkg (symbol-package sym)))
+ (if pkg (package-name pkg) "")))
+
+;;; FIXME: Because of the existence of UNINTERN and RENAME-PACKAGE,
+;;; the part of this ordering which is based on SYMBOL-PKG-NAME is not
+;;; stable. This ordering is only used in to
+;;; SLOT-NAME-LISTS-FROM-SLOTS, where it serves to "canonicalize the
+;;; PV-TABLE's a bit and will hopefully lead to having fewer PV's
+;;; floating around", so it sounds as though the instability won't
+;;; actually lead to bugs, just small inefficiency. But still, it
+;;; would be better to reimplement this function as a comparison based
+;;; on SYMBOL-HASH:
+;;; * stable comparison
+;;; * smaller code (here, and in being able to discard SYMBOL-PKG-NAME)
+;;; * faster code.
+(defun symbol-lessp (a b)
+ (if (eq (symbol-package a)
+ (symbol-package b))
+ (string-lessp (symbol-name a)
+ (symbol-name b))
+ (string-lessp (symbol-pkg-name a)
+ (symbol-pkg-name b))))
+
+(defun symbol-or-cons-lessp (a b)
+ (etypecase a
+ (symbol (etypecase b
+ (symbol (symbol-lessp a b))
+ (cons t)))
+ (cons (etypecase b
+ (symbol nil)
+ (cons (if (eq (car a) (car b))
+ (symbol-or-cons-lessp (cdr a) (cdr b))
+ (symbol-or-cons-lessp (car a) (car b))))))))
+
+(defun sort-slots (slots)
+ (mapcar #'(lambda (parameter-entry)
+ (cons (car parameter-entry)
+ (sort (cdr parameter-entry) ;slot entries
+ #'symbol-or-cons-lessp
+ :key #'car)))
+ slots))
+
+(defun sort-calls (calls)
+ (sort calls #'symbol-or-cons-lessp :key #'car))
+\f
+;;; This needs to work in terms of metatypes and also needs to work for
+;;; automatically generated reader and writer functions.
+;;; -- Automatically generated reader and writer functions use this stuff too.
+
+(defmacro pv-binding ((required-parameters slot-name-lists pv-table-symbol)
+ &body body)
+ (with-gathering ((slot-vars (collecting))
+ (pv-parameters (collecting)))
+ (iterate ((slots (list-elements slot-name-lists))
+ (required-parameter (list-elements required-parameters))
+ (i (interval :from 0)))
+ (when slots
+ (gather required-parameter pv-parameters)
+ (gather (slot-vector-symbol i) slot-vars)))
+ `(pv-binding1 (.pv. .calls. ,pv-table-symbol ,pv-parameters ,slot-vars)
+ ,@body)))
+
+(defmacro pv-binding1 ((pv calls pv-table-symbol pv-parameters slot-vars)
+ &body body)
+ `(pv-env (,pv ,calls ,pv-table-symbol ,pv-parameters)
+ (let (,@(mapcar #'(lambda (slot-var p) `(,slot-var (get-slots-or-nil ,p)))
+ slot-vars pv-parameters))
+ ,@body)))
+
+;This gets used only when the default make-method-lambda is overriden.
+(defmacro pv-env ((pv calls pv-table-symbol pv-parameters)
+ &rest forms)
+ `(let* ((.pv-table. ,pv-table-symbol)
+ (.pv-cell. (pv-table-lookup-pv-args .pv-table. ,@pv-parameters))
+ (,pv (car .pv-cell.))
+ (,calls (cdr .pv-cell.)))
+ (declare ,(make-pv-type-declaration pv))
+ (declare ,(make-calls-type-declaration calls))
+ ,@(when (symbolp pv-table-symbol)
+ `((declare (special ,pv-table-symbol))))
+ ,pv ,calls
+ ,@forms))
+
+(defvar *non-variable-declarations*
+ ;; FIXME: VALUES was in this list, conditionalized with #+CMU, but
+ ;; I don't *think* CMU CL had, or SBCL has, VALUES declarations. If
+ ;; SBCL doesn't have 'em, VALUES should probably be removed from this list.
+ '(values method-name method-lambda-list
+ optimize ftype inline notinline))
+
+(defvar *variable-declarations-with-argument*
+ '(class
+ type))
+
+(defvar *variable-declarations-without-argument*
+ '(ignore ignorable special dynamic-extent
+ array atom base-char bignum bit bit-vector character compiled-function
+ complex cons double-float extended-char
+ fixnum float function hash-table integer
+ keyword list long-float nil null number package pathname random-state ratio
+ rational readtable sequence short-float signed-byte simple-array
+ simple-bit-vector simple-string simple-vector single-float standard-char
+ stream string symbol t unsigned-byte vector))
+
+(defun split-declarations (body args calls-next-method-p)
+ (let ((inner-decls nil) (outer-decls nil) decl)
+ (loop (when (null body) (return nil))
+ (setq decl (car body))
+ (unless (and (consp decl)
+ (eq (car decl) 'declare))
+ (return nil))
+ (dolist (form (cdr decl))
+ (when (consp form)
+ (let ((declaration-name (car form)))
+ (if (member declaration-name *non-variable-declarations*)
+ (push `(declare ,form) outer-decls)
+ (let ((arg-p
+ (member declaration-name
+ *variable-declarations-with-argument*))
+ (non-arg-p
+ (member declaration-name
+ *variable-declarations-without-argument*))
+ (dname (list (pop form)))
+ (inners nil) (outers nil))
+ (unless (or arg-p non-arg-p)
+ ;; FIXME: This warning should probably go away now
+ ;; that we're not trying to be portable between
+ ;; different CLTL1 hosts the way PCL was.
+ (warn "The declaration ~S is not understood by ~S.~@
+ Please put ~S on one of the lists ~S,~%~S, or~%~S.~@
+ (Assuming it is a variable declaration without argument)."
+ declaration-name 'split-declarations
+ declaration-name
+ '*non-variable-declarations*
+ '*variable-declarations-with-argument*
+ '*variable-declarations-without-argument*)
+ (push declaration-name
+ *variable-declarations-without-argument*))
+ (when arg-p
+ (setq dname (append dname (list (pop form)))))
+ (dolist (var form)
+ (if (member var args)
+ ;; Quietly remove IGNORE declarations on args when
+ ;; a next-method is involved, to prevent compiler
+ ;; warns about ignored args being read.
+ (unless (and calls-next-method-p
+ (eq (car dname) 'ignore))
+ (push var outers))
+ (push var inners)))
+ (when outers
+ (push `(declare (,@dname ,@outers)) outer-decls))
+ (when inners
+ (push `(declare (,@dname ,@inners)) inner-decls)))))))
+ (setq body (cdr body)))
+ (values outer-decls inner-decls body)))
+
+(defun make-method-initargs-form-internal (method-lambda initargs env)
+ (declare (ignore env))
+ (let (method-lambda-args lmf lmf-params)
+ (if (not (and (= 3 (length method-lambda))
+ (= 2 (length (setq method-lambda-args (cadr method-lambda))))
+ (consp (setq lmf (third method-lambda)))
+ (eq 'simple-lexical-method-functions (car lmf))
+ (eq (car method-lambda-args)
+ (cadr (setq lmf-params (cadr lmf))))
+ (eq (cadr method-lambda-args)
+ (caddr lmf-params))))
+ `(list* :function #',method-lambda
+ ',initargs)
+ (let* ((lambda-list (car lmf-params))
+ (nreq 0)(restp nil)(args nil))
+ (dolist (arg lambda-list)
+ (when (member arg '(&optional &rest &key))
+ (setq restp t)(return nil))
+ (when (eq arg '&aux) (return nil))
+ (incf nreq)(push arg args))
+ (setq args (nreverse args))
+ (setf (getf (getf initargs ':plist) ':arg-info) (cons nreq restp))
+ (make-method-initargs-form-internal1
+ initargs (cddr lmf) args lmf-params restp)))))
+
+(defun make-method-initargs-form-internal1
+ (initargs body req-args lmf-params restp)
+ (multiple-value-bind (outer-decls inner-decls body)
+ (split-declarations
+ body req-args (getf (cdr lmf-params) :call-next-method-p))
+ (let* ((rest-arg (when restp '.rest-arg.))
+ (args+rest-arg (if restp
+ (append req-args (list rest-arg))
+ req-args)))
+ `(list* :fast-function
+ #'(lambda (.pv-cell. .next-method-call. ,@args+rest-arg)
+ ,@outer-decls
+ .pv-cell. .next-method-call.
+ (macrolet ((pv-env ((pv calls pv-table-symbol pv-parameters)
+ &rest forms)
+ (declare (ignore pv-table-symbol pv-parameters))
+ `(let ((,pv (car .pv-cell.))
+ (,calls (cdr .pv-cell.)))
+ (declare ,(make-pv-type-declaration pv)
+ ,(make-calls-type-declaration calls))
+ ,pv ,calls
+ ,@forms)))
+ (fast-lexical-method-functions
+ (,(car lmf-params) .next-method-call. ,req-args ,rest-arg
+ ,@(cdddr lmf-params))
+ ,@inner-decls
+ ,@body)))
+ ',initargs))))
+
+;;; Use arrays and hash tables and the fngen stuff to make this much better. It
+;;; doesn't really matter, though, because a function returned by this will get
+;;; called only when the user explicitly funcalls a result of method-function.
+;;; BUT, this is needed to make early methods work.
+(defun method-function-from-fast-function (fmf)
+ (declare (type function fmf))
+ (let* ((method-function nil) (pv-table nil)
+ (arg-info (method-function-get fmf ':arg-info))
+ (nreq (car arg-info))
+ (restp (cdr arg-info)))
+ (setq method-function
+ #'(lambda (method-args next-methods)
+ (unless pv-table
+ (setq pv-table (method-function-pv-table fmf)))
+ (let* ((pv-cell (when pv-table
+ (get-method-function-pv-cell
+ method-function method-args pv-table)))
+ (nm (car next-methods))
+ (nms (cdr next-methods))
+ (nmc (when nm
+ (make-method-call :function (if (std-instance-p nm)
+ (method-function nm)
+ nm)
+ :call-method-args (list nms)))))
+ (if restp
+ (let* ((rest (nthcdr nreq method-args))
+ (args (ldiff method-args rest)))
+ (apply fmf pv-cell nmc (nconc args (list rest))))
+ (apply fmf pv-cell nmc method-args)))))
+ (let* ((fname (method-function-get fmf :name))
+ (name `(,(or (get (car fname) 'method-sym)
+ (setf (get (car fname) 'method-sym)
+ (let ((str (symbol-name (car fname))))
+ (if (string= "FAST-" str :end2 5)
+ (intern (subseq str 5) *pcl-package*)
+ (car fname)))))
+ ,@(cdr fname))))
+ (set-function-name method-function name))
+ (setf (method-function-get method-function :fast-function) fmf)
+ method-function))
+
+(defun get-method-function-pv-cell (method-function
+ method-args
+ &optional pv-table)
+ (let ((pv-table (or pv-table (method-function-pv-table method-function))))
+ (when pv-table
+ (let ((pv-wrappers (pv-wrappers-from-all-args pv-table method-args)))
+ (when pv-wrappers
+ (pv-table-lookup pv-table pv-wrappers))))))
+
+(defun pv-table-lookup-pv-args (pv-table &rest pv-parameters)
+ (pv-table-lookup pv-table (pv-wrappers-from-pv-args pv-parameters)))
+
+(defun pv-wrappers-from-pv-args (&rest args)
+ (let* ((nkeys (length args))
+ (pv-wrappers (make-list nkeys))
+ w
+ (w-t pv-wrappers))
+ (dolist (arg args)
+ (setq w (wrapper-of arg))
+ (unless (eq 't (wrapper-state w)) ; FIXME: should be INVALID-WRAPPER-P
+ (setq w (check-wrapper-validity arg)))
+ (setf (car w-t) w))
+ (setq w-t (cdr w-t))
+ (when (= nkeys 1) (setq pv-wrappers (car pv-wrappers)))
+ pv-wrappers))
+
+(defun pv-wrappers-from-all-args (pv-table args)
+ (let ((nkeys 0)
+ (slot-name-lists (pv-table-slot-name-lists pv-table)))
+ (dolist (sn slot-name-lists)
+ (when sn (incf nkeys)))
+ (let* ((pv-wrappers (make-list nkeys))
+ (pv-w-t pv-wrappers))
+ (dolist (sn slot-name-lists)
+ (when sn
+ (let* ((arg (car args))
+ (w (wrapper-of arg)))
+ (unless w ; CAN-OPTIMIZE-ACCESS prevents this from happening.
+ (error "error in PV-WRAPPERS-FROM-ALL-ARGS"))
+ (setf (car pv-w-t) w)
+ (setq pv-w-t (cdr pv-w-t))))
+ (setq args (cdr args)))
+ (when (= nkeys 1) (setq pv-wrappers (car pv-wrappers)))
+ pv-wrappers)))
+
+(defun pv-wrappers-from-all-wrappers (pv-table wrappers)
+ (let ((nkeys 0)
+ (slot-name-lists (pv-table-slot-name-lists pv-table)))
+ (dolist (sn slot-name-lists)
+ (when sn (incf nkeys)))
+ (let* ((pv-wrappers (make-list nkeys))
+ (pv-w-t pv-wrappers))
+ (dolist (sn slot-name-lists)
+ (when sn
+ (let ((w (car wrappers)))
+ (unless w ; CAN-OPTIMIZE-ACCESS prevents this from happening.
+ (error "error in PV-WRAPPERS-FROM-ALL-WRAPPERS"))
+ (setf (car pv-w-t) w)
+ (setq pv-w-t (cdr pv-w-t))))
+ (setq wrappers (cdr wrappers)))
+ (when (= nkeys 1) (setq pv-wrappers (car pv-wrappers)))
+ pv-wrappers)))
--- /dev/null
+;;;; a simple code walker for PCL
+;;;;
+;;;; The code which implements the macroexpansion environment manipulation
+;;;; mechanisms is in the first part of the file, the real walker follows it.
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+
+;;;; This software is derived from software originally released by Xerox
+;;;; Corporation. Copyright and release statements follow. Later modifications
+;;;; to the software are in the public domain and are provided with
+;;;; absolutely no warranty. See the COPYING and CREDITS files for more
+;;;; information.
+
+;;;; copyright information from original PCL sources:
+;;;;
+;;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
+;;;; All rights reserved.
+;;;;
+;;;; Use and copying of this software and preparation of derivative works based
+;;;; upon this software are permitted. Any distribution of this software or
+;;;; derivative works must comply with all applicable United States export
+;;;; control laws.
+;;;;
+;;;; This software is made available AS IS, and Xerox Corporation makes no
+;;;; warranty about the software, its performance or its conformity to any
+;;;; specification.
+
+(in-package "SB-WALKER")
+
+(sb-int:file-comment
+ "$Header$")
+\f
+;;;; environment frobbing stuff
+
+;;; Here in the original PCL were implementations of the
+;;; implementation-specific environment hacking functions for each of the
+;;; implementations this walker had been ported to. This functionality was
+;;; originally factored out in order to make PCL portable from one Common Lisp
+;;; to another. As of 19981107, that portability was fairly stale and (because
+;;; of the scarcity of CLTL1 implementations and the strong interdependence of
+;;; the rest of ANSI Common Lisp on the CLOS system) fairly irrelevant. It was
+;;; fairly thoroughly put out of its misery by WHN in his quest to clean up the
+;;; system enough that it can be built from scratch using any ANSI Common Lisp.
+;;;
+;;; This code just hacks 'macroexpansion environments'. That is, it is only
+;;; concerned with the function binding of symbols in the environment. The
+;;; walker needs to be able to tell if the symbol names a lexical macro or
+;;; function, and it needs to be able to build environments which contain
+;;; lexical macro or function bindings. It must be able, when walking a
+;;; MACROLET, FLET or LABELS form to construct an environment which reflects
+;;; the bindings created by that form. Note that the environment created
+;;; does NOT have to be sufficient to evaluate the body, merely to walk its
+;;; body. This means that definitions do not have to be supplied for lexical
+;;; functions, only the fact that that function is bound is important. For
+;;; macros, the macroexpansion function must be supplied.
+;;;
+;;; This code is organized in a way that lets it work in implementations that
+;;; stack cons their environments. That is reflected in the fact that the
+;;; only operation that lets a user build a new environment is a WITH-BODY
+;;; macro which executes its body with the specified symbol bound to the new
+;;; environment. No code in this walker or in PCL will hold a pointer to
+;;; these environments after the body returns. Other user code is free to do
+;;; so in implementations where it works, but that code is not considered
+;;; portable.
+;;;
+;;; There are 3 environment hacking tools. One macro,
+;;; WITH-AUGMENTED-ENVIRONMENT, which is used to create new environments, and
+;;; two functions, ENVIRONMENT-FUNCTION and ENVIRONMENT-MACRO, which are used
+;;; to access the bindings of existing environments
+
+;;; In SBCL, as in CMU CL before it, the environment is represented
+;;; with a structure that holds alists for the functional things,
+;;; variables, blocks, etc. Only the c::lexenv-functions slot is
+;;; relevant. It holds: Alist (name . what), where What is either a
+;;; Functional (a local function) or a list (MACRO . <function>) (a
+;;; local macro, with the specifier expander.) Note that Name may be a
+;;; (SETF <name>) function.
+
+(defmacro with-augmented-environment
+ ((new-env old-env &key functions macros) &body body)
+ `(let ((,new-env (with-augmented-environment-internal ,old-env
+ ,functions
+ ,macros)))
+ ,@body))
+
+;;; KLUDGE: In CMU CL, when X was an arbitrary list, even one which did
+;;; not name a function or describe a lambda expression, (EVAL
+;;; `(FUNCTION ,X)) would still return a FUNCTION object, and no error
+;;; would be signalled until/unless you tried to FUNCALL the resulting
+;;; FUNCTION object. (This behavior was also present in (COERCE X
+;;; 'FUNCTION), which was defined in terms of (EVAL `(FUNCTION ,X)).)
+;;; This function provides roughly the same behavior as the old CMU CL
+;;; (COERCE X 'FUNCTION), for the benefit of PCL code which relied
+;;; on being able to coerce bogus things without raising errors
+;;; as long as it never tried to actually call them.
+(defun bogo-coerce-to-function (x)
+ (or (ignore-errors (coerce x 'function))
+ (lambda (&rest rest)
+ (declare (ignore rest))
+ (error "can't FUNCALL bogo-coerced-to-function ~S" x))))
+
+(defun with-augmented-environment-internal (env functions macros)
+ ;; Note: In order to record the correct function definition, we
+ ;; would have to create an interpreted closure, but the
+ ;; with-new-definition macro down below makes no distinction between
+ ;; FLET and LABELS, so we have no idea what to use for the
+ ;; environment. So we just blow it off, 'cause anything real we do
+ ;; would be wrong. We still have to make an entry so we can tell
+ ;; functions from macros.
+ (let ((env (or env (sb-kernel:make-null-lexenv))))
+ (sb-c::make-lexenv
+ :default env
+ :functions
+ (append (mapcar (lambda (f)
+ (cons (car f) (sb-c::make-functional :lexenv env)))
+ functions)
+ (mapcar (lambda (m)
+ (list* (car m)
+ 'sb-c::macro
+ (bogo-coerce-to-function (cadr m))))
+ macros)))))
+
+(defun environment-function (env fn)
+ (when env
+ (let ((entry (assoc fn (sb-c::lexenv-functions env) :test #'equal)))
+ (and entry
+ (sb-c::functional-p (cdr entry))
+ (cdr entry)))))
+
+(defun environment-macro (env macro)
+ (when env
+ (let ((entry (assoc macro (sb-c::lexenv-functions env) :test #'eq)))
+ (and entry
+ (eq (cadr entry) 'sb-c::macro)
+ (function-lambda-expression (cddr entry))))))
+
+(defmacro with-new-definition-in-environment
+ ((new-env old-env macrolet/flet/labels-form) &body body)
+ (let ((functions (make-symbol "Functions"))
+ (macros (make-symbol "Macros")))
+ `(let ((,functions ())
+ (,macros ()))
+ (ecase (car ,macrolet/flet/labels-form)
+ ((flet labels)
+ (dolist (fn (cadr ,macrolet/flet/labels-form))
+ (push fn ,functions)))
+ ((macrolet)
+ (dolist (mac (cadr ,macrolet/flet/labels-form))
+ (push (list (car mac)
+ (convert-macro-to-lambda (cadr mac)
+ (cddr mac)
+ (string (car mac))))
+ ,macros))))
+ (with-augmented-environment
+ (,new-env ,old-env :functions ,functions :macros ,macros)
+ ,@body))))
+
+(defun convert-macro-to-lambda (llist body &optional (name "dummy macro"))
+ (let ((gensym (make-symbol name)))
+ (eval `(defmacro ,gensym ,llist ,@body))
+ (macro-function gensym)))
+\f
+;;; Now comes the real walker.
+;;;
+;;; As the walker walks over the code, it communicates information to itself
+;;; about the walk. This information includes the walk function, variable
+;;; bindings, declarations in effect etc. This information is inherently
+;;; lexical, so the walker passes it around in the actual environment the
+;;; walker passes to macroexpansion functions. This is what makes the
+;;; nested-walk-form facility work properly.
+(defmacro walker-environment-bind ((var env &rest key-args)
+ &body body)
+ `(with-augmented-environment
+ (,var ,env :macros (walker-environment-bind-1 ,env ,.key-args))
+ .,body))
+
+(defvar *key-to-walker-environment* (gensym))
+
+(defun env-lock (env)
+ (environment-macro env *key-to-walker-environment*))
+
+(defun walker-environment-bind-1 (env &key (walk-function nil wfnp)
+ (walk-form nil wfop)
+ (declarations nil decp)
+ (lexical-variables nil lexp))
+ (let ((lock (environment-macro env *key-to-walker-environment*)))
+ (list
+ (list *key-to-walker-environment*
+ (list (if wfnp walk-function (car lock))
+ (if wfop walk-form (cadr lock))
+ (if decp declarations (caddr lock))
+ (if lexp lexical-variables (cadddr lock)))))))
+
+(defun env-walk-function (env)
+ (car (env-lock env)))
+
+(defun env-walk-form (env)
+ (cadr (env-lock env)))
+
+(defun env-declarations (env)
+ (caddr (env-lock env)))
+
+(defun env-lexical-variables (env)
+ (cadddr (env-lock env)))
+
+(defun note-declaration (declaration env)
+ (push declaration (caddr (env-lock env))))
+
+(defun note-lexical-binding (thing env)
+ (push (list thing :lexical-var) (cadddr (env-lock env))))
+
+(defun variable-lexical-p (var env)
+ (let ((entry (member var (env-lexical-variables env) :key #'car)))
+ (when (eq (cadar entry) :lexical-var)
+ entry)))
+
+(defun variable-symbol-macro-p (var env)
+ (let ((entry (member var (env-lexical-variables env) :key #'car)))
+ (when (eq (cadar entry) :macro)
+ entry)))
+
+(defvar *variable-declarations* '(special))
+
+(defun variable-declaration (declaration var env)
+ (if (not (member declaration *variable-declarations*))
+ (error "~S is not a recognized variable declaration." declaration)
+ (let ((id (or (variable-lexical-p var env) var)))
+ (dolist (decl (env-declarations env))
+ (when (and (eq (car decl) declaration)
+ (eq (cadr decl) id))
+ (return decl))))))
+
+(defun variable-special-p (var env)
+ (or (not (null (variable-declaration 'special var env)))
+ (variable-globally-special-p var)))
+
+(defun variable-globally-special-p (symbol)
+ (eq (sb-int:info :variable :kind symbol) :special))
+\f
+;;;; handling of special forms
+
+;;; Here are some comments from the original PCL on the difficulty of doing
+;;; this portably across different CLTL1 implementations. This is no longer
+;;; directly relevant because this code now only runs on SBCL, but the comments
+;;; are retained for culture: they might help explain some of the design
+;;; decisions which were made in the code.
+;;;
+;;; and I quote...
+;;;
+;;; The set of special forms is purposely kept very small because
+;;; any program analyzing program (read code walker) must have
+;;; special knowledge about every type of special form. Such a
+;;; program needs no special knowledge about macros...
+;;;
+;;; So all we have to do here is a define a way to store and retrieve
+;;; templates which describe how to walk the 24 special forms and we are all
+;;; set...
+;;;
+;;; Well, its a nice concept, and I have to admit to being naive enough that
+;;; I believed it for a while, but not everyone takes having only 24 special
+;;; forms as seriously as might be nice. There are (at least) 3 ways to
+;;; lose:
+;;
+;;; 1 - Implementation x implements a Common Lisp special form as a macro
+;;; which expands into a special form which:
+;;; - Is a common lisp special form (not likely)
+;;; - Is not a common lisp special form (on the 3600 IF --> COND).
+;;;
+;;; * We can safe ourselves from this case (second subcase really) by
+;;; checking to see whether there is a template defined for something
+;;; before we check to see whether we can macroexpand it.
+;;;
+;;; 2 - Implementation x implements a Common Lisp macro as a special form.
+;;;
+;;; * This is a screw, but not so bad, we save ourselves from it by
+;;; defining extra templates for the macros which are *likely* to
+;;; be implemented as special forms. (DO, DO* ...)
+;;;
+;;; 3 - Implementation x has a special form which is not on the list of
+;;; Common Lisp special forms.
+;;;
+;;; * This is a bad sort of a screw and happens more than I would like
+;;; to think, especially in the implementations which provide more
+;;; than just Common Lisp (3600, Xerox etc.).
+;;; The fix is not terribly staisfactory, but will have to do for
+;;; now. There is a hook in get walker-template which can get a
+;;; template from the implementation's own walker. That template
+;;; has to be converted, and so it may be that the right way to do
+;;; this would actually be for that implementation to provide an
+;;; interface to its walker which looks like the interface to this
+;;; walker.
+
+;;; FIXME: In SBCL, we probably don't need to put DEFMACROs inside EVAL-WHEN.
+(eval-when (:compile-toplevel :load-toplevel :execute)
+
+(defmacro get-walker-template-internal (x) ;Has to be inside eval-when because
+ `(get ,x 'walker-template)) ;Golden Common Lisp doesn't hack
+ ;compile time definition of macros
+ ;right for setf.
+
+(defmacro define-walker-template (name
+ &optional (template '(nil repeat (eval))))
+ `(eval-when (:load-toplevel :execute)
+ (setf (get-walker-template-internal ',name) ',template)))
+
+) ; EVAL-WHEN
+
+(defun get-walker-template (x)
+ (cond ((symbolp x)
+ (or (get-walker-template-internal x)
+ (get-implementation-dependent-walker-template x)))
+ ((and (listp x) (eq (car x) 'lambda))
+ '(lambda repeat (eval)))
+ (t
+ (error "can't get template for ~S" x))))
+
+;;; FIXME: This can go away in SBCL.
+(defun get-implementation-dependent-walker-template (x)
+ (declare (ignore x))
+ ())
+\f
+;;;; the actual templates
+
+;;; ANSI special forms
+(define-walker-template block (nil nil repeat (eval)))
+(define-walker-template catch (nil eval repeat (eval)))
+(define-walker-template declare walk-unexpected-declare)
+(define-walker-template eval-when (nil quote repeat (eval)))
+(define-walker-template flet walk-flet)
+(define-walker-template function (nil call))
+(define-walker-template go (nil quote))
+(define-walker-template if walk-if)
+(define-walker-template labels walk-labels)
+(define-walker-template lambda walk-lambda)
+(define-walker-template let walk-let)
+(define-walker-template let* walk-let*)
+(define-walker-template locally walk-locally)
+(define-walker-template macrolet walk-macrolet)
+(define-walker-template multiple-value-call (nil eval repeat (eval)))
+(define-walker-template multiple-value-prog1 (nil return repeat (eval)))
+(define-walker-template multiple-value-setq walk-multiple-value-setq)
+(define-walker-template multiple-value-bind walk-multiple-value-bind)
+(define-walker-template progn (nil repeat (eval)))
+(define-walker-template progv (nil eval eval repeat (eval)))
+(define-walker-template quote (nil quote))
+(define-walker-template return-from (nil quote repeat (return)))
+(define-walker-template setq walk-setq)
+(define-walker-template symbol-macrolet walk-symbol-macrolet)
+(define-walker-template tagbody walk-tagbody)
+(define-walker-template the (nil quote eval))
+(define-walker-template throw (nil eval eval))
+(define-walker-template unwind-protect (nil return repeat (eval)))
+
+;;; SBCL-only special forms
+(define-walker-template sb-ext:truly-the (nil quote eval))
+
+;;; extra templates
+(define-walker-template do walk-do)
+(define-walker-template do* walk-do*)
+(define-walker-template prog walk-prog)
+(define-walker-template prog* walk-prog*)
+(define-walker-template cond (nil repeat ((test repeat (eval)))))
+\f
+(defvar *walk-form-expand-macros-p* nil)
+
+(defun macroexpand-all (form &optional environment)
+ (let ((*walk-form-expand-macros-p* t))
+ (walk-form form environment)))
+
+(defun walk-form (form
+ &optional environment
+ (walk-function
+ #'(lambda (subform context env)
+ (declare (ignore context env))
+ subform)))
+ (walker-environment-bind (new-env environment :walk-function walk-function)
+ (walk-form-internal form :eval new-env)))
+
+;;; NESTED-WALK-FORM provides an interface that allows nested macros, each
+;;; of which must walk their body, to just do one walk of the body of the
+;;; inner macro. That inner walk is done with a walk function which is the
+;;; composition of the two walk functions.
+;;;
+;;; This facility works by having the walker annotate the environment that
+;;; it passes to MACROEXPAND-1 to know which form is being macroexpanded.
+;;; If then the &WHOLE argument to the macroexpansion function is eq to
+;;; the ENV-WALK-FORM of the environment, NESTED-WALK-FORM can be certain
+;;; that there are no intervening layers and that a nested walk is OK.
+;;;
+;;; KLUDGE: There are some semantic problems with this facility. In particular,
+;;; if the outer walk function returns T as its WALK-NO-MORE-P value, this will
+;;; prevent the inner walk function from getting a chance to walk the subforms
+;;; of the form. This is almost never what you want, since it destroys the
+;;; equivalence between this NESTED-WALK-FORM function and two separate
+;;; WALK-FORMs.
+(defun nested-walk-form (whole form
+ &optional environment
+ (walk-function
+ #'(lambda (subform context env)
+ (declare (ignore context env))
+ subform)))
+ (if (eq whole (env-walk-form environment))
+ (let ((outer-walk-function (env-walk-function environment)))
+ (throw whole
+ (walk-form
+ form
+ environment
+ #'(lambda (f c e)
+ ;; First loop to make sure the inner walk function
+ ;; has done all it wants to do with this form.
+ ;; Basically, what we are doing here is providing
+ ;; the same contract walk-form-internal normally
+ ;; provides to the inner walk function.
+ (let ((inner-result nil)
+ (inner-no-more-p nil)
+ (outer-result nil)
+ (outer-no-more-p nil))
+ (loop
+ (multiple-value-setq (inner-result inner-no-more-p)
+ (funcall walk-function f c e))
+ (cond (inner-no-more-p (return))
+ ((not (eq inner-result f)))
+ ((not (consp inner-result)) (return))
+ ((get-walker-template (car inner-result)) (return))
+ (t
+ (multiple-value-bind (expansion macrop)
+ (walker-environment-bind
+ (new-env e :walk-form inner-result)
+ (macroexpand-1 inner-result new-env))
+ (if macrop
+ (setq inner-result expansion)
+ (return)))))
+ (setq f inner-result))
+ (multiple-value-setq (outer-result outer-no-more-p)
+ (funcall outer-walk-function
+ inner-result
+ c
+ e))
+ (values outer-result
+ (and inner-no-more-p outer-no-more-p)))))))
+ (walk-form form environment walk-function)))
+
+;;; WALK-FORM-INTERNAL is the main driving function for the code walker. It
+;;; takes a form and the current context and walks the form calling itself or
+;;; the appropriate template recursively.
+;;;
+;;; "It is recommended that a program-analyzing-program process a form
+;;; that is a list whose car is a symbol as follows:
+;;;
+;;; 1. If the program has particular knowledge about the symbol,
+;;; process the form using special-purpose code. All of the
+;;; standard special forms should fall into this category.
+;;; 2. Otherwise, if macro-function is true of the symbol apply
+;;; either macroexpand or macroexpand-1 and start over.
+;;; 3. Otherwise, assume it is a function call. "
+(defun walk-form-internal (form context env)
+ ;; First apply the walk-function to perform whatever translation
+ ;; the user wants to this form. If the second value returned
+ ;; by walk-function is T then we don't recurse...
+ (catch form
+ (multiple-value-bind (newform walk-no-more-p)
+ (funcall (env-walk-function env) form context env)
+ (catch newform
+ (cond
+ (walk-no-more-p newform)
+ ((not (eq form newform))
+ (walk-form-internal newform context env))
+ ((not (consp newform))
+ (let ((symmac (car (variable-symbol-macro-p newform env))))
+ (if symmac
+ (let ((newnewform (walk-form-internal (cddr symmac)
+ context
+ env)))
+ (if (eq newnewform (cddr symmac))
+ (if *walk-form-expand-macros-p* newnewform newform)
+ newnewform))
+ newform)))
+ (t
+ (let* ((fn (car newform))
+ (template (get-walker-template fn)))
+ (if template
+ (if (symbolp template)
+ (funcall template newform context env)
+ (walk-template newform template context env))
+ (multiple-value-bind (newnewform macrop)
+ (walker-environment-bind
+ (new-env env :walk-form newform)
+ (macroexpand-1 newform new-env))
+ (cond
+ (macrop
+ (let ((newnewnewform (walk-form-internal newnewform
+ context
+ env)))
+ (if (eq newnewnewform newnewform)
+ (if *walk-form-expand-macros-p* newnewform newform)
+ newnewnewform)))
+ ((and (symbolp fn)
+ (not (fboundp fn))
+ (special-operator-p fn))
+ ;; This shouldn't happen, since this walker is now
+ ;; maintained as part of SBCL, so it should know about all
+ ;; the special forms that SBCL knows about.
+ (error "unexpected special form ~S" fn))
+ (t
+ ;; Otherwise, walk the form as if it's just a standard
+ ;; function call using a template for standard function
+ ;; call.
+ (walk-template
+ newnewform '(call repeat (eval)) context env))))))))))))
+
+(defun walk-template (form template context env)
+ (if (atom template)
+ (ecase template
+ ((eval function test effect return)
+ (walk-form-internal form :eval env))
+ ((quote nil) form)
+ (set
+ (walk-form-internal form :set env))
+ ((lambda call)
+ (cond ((or (symbolp form)
+ (and (listp form)
+ (= (length form) 2)
+ (eq (car form) 'setf)))
+ form)
+ (t (walk-form-internal form context env)))))
+ (case (car template)
+ (repeat
+ (walk-template-handle-repeat form
+ (cdr template)
+ ;; For the case where nothing happens
+ ;; after the repeat optimize out the
+ ;; call to length.
+ (if (null (cddr template))
+ ()
+ (nthcdr (- (length form)
+ (length
+ (cddr template)))
+ form))
+ context
+ env))
+ (if
+ (walk-template form
+ (if (if (listp (cadr template))
+ (eval (cadr template))
+ (funcall (cadr template) form))
+ (caddr template)
+ (cadddr template))
+ context
+ env))
+ (remote
+ (walk-template form (cadr template) context env))
+ (otherwise
+ (cond ((atom form) form)
+ (t (recons form
+ (walk-template
+ (car form) (car template) context env)
+ (walk-template
+ (cdr form) (cdr template) context env))))))))
+
+(defun walk-template-handle-repeat (form template stop-form context env)
+ (if (eq form stop-form)
+ (walk-template form (cdr template) context env)
+ (walk-template-handle-repeat-1 form
+ template
+ (car template)
+ stop-form
+ context
+ env)))
+
+(defun walk-template-handle-repeat-1 (form template repeat-template
+ stop-form context env)
+ (cond ((null form) ())
+ ((eq form stop-form)
+ (if (null repeat-template)
+ (walk-template stop-form (cdr template) context env)
+ (error "while handling code walker REPEAT:
+ ~%ran into STOP while still in REPEAT template")))
+ ((null repeat-template)
+ (walk-template-handle-repeat-1
+ form template (car template) stop-form context env))
+ (t
+ (recons form
+ (walk-template (car form) (car repeat-template) context env)
+ (walk-template-handle-repeat-1 (cdr form)
+ template
+ (cdr repeat-template)
+ stop-form
+ context
+ env)))))
+
+(defun walk-repeat-eval (form env)
+ (and form
+ (recons form
+ (walk-form-internal (car form) :eval env)
+ (walk-repeat-eval (cdr form) env))))
+
+(defun recons (x car cdr)
+ (if (or (not (eq (car x) car))
+ (not (eq (cdr x) cdr)))
+ (cons car cdr)
+ x))
+
+(defun relist (x &rest args)
+ (if (null args)
+ nil
+ (relist-internal x args nil)))
+
+(defun relist* (x &rest args)
+ (relist-internal x args 't))
+
+(defun relist-internal (x args *p)
+ (if (null (cdr args))
+ (if *p
+ (car args)
+ (recons x (car args) nil))
+ (recons x
+ (car args)
+ (relist-internal (cdr x) (cdr args) *p))))
+\f
+;;;; special walkers
+
+(defun walk-declarations (body fn env
+ &optional doc-string-p declarations old-body
+ &aux (form (car body)) macrop new-form)
+ (cond ((and (stringp form) ;might be a doc string
+ (cdr body) ;isn't the returned value
+ (null doc-string-p) ;no doc string yet
+ (null declarations)) ;no declarations yet
+ (recons body
+ form
+ (walk-declarations (cdr body) fn env t)))
+ ((and (listp form) (eq (car form) 'declare))
+ ;; We got ourselves a real live declaration. Record it, look for more.
+ (dolist (declaration (cdr form))
+ (let ((type (car declaration))
+ (name (cadr declaration))
+ (args (cddr declaration)))
+ (if (member type *variable-declarations*)
+ (note-declaration `(,type
+ ,(or (variable-lexical-p name env) name)
+ ,.args)
+ env)
+ (note-declaration declaration env))
+ (push declaration declarations)))
+ (recons body
+ form
+ (walk-declarations
+ (cdr body) fn env doc-string-p declarations)))
+ ((and form
+ (listp form)
+ (null (get-walker-template (car form)))
+ (progn
+ (multiple-value-setq (new-form macrop)
+ (macroexpand-1 form env))
+ macrop))
+ ;; This form was a call to a macro. Maybe it expanded
+ ;; into a declare? Recurse to find out.
+ (walk-declarations (recons body new-form (cdr body))
+ fn env doc-string-p declarations
+ (or old-body body)))
+ (t
+ ;; Now that we have walked and recorded the declarations,
+ ;; call the function our caller provided to expand the body.
+ ;; We call that function rather than passing the real-body
+ ;; back, because we are RECONSING up the new body.
+ (funcall fn (or old-body body) env))))
+
+(defun walk-unexpected-declare (form context env)
+ (declare (ignore context env))
+ (warn "encountered DECLARE ~S in a place where a DECLARE was not expected"
+ form)
+ form)
+
+(defun walk-arglist (arglist context env &optional (destructuringp nil)
+ &aux arg)
+ (cond ((null arglist) ())
+ ((symbolp (setq arg (car arglist)))
+ (or (member arg lambda-list-keywords)
+ (note-lexical-binding arg env))
+ (recons arglist
+ arg
+ (walk-arglist (cdr arglist)
+ context
+ env
+ (and destructuringp
+ (not (member arg
+ lambda-list-keywords))))))
+ ((consp arg)
+ (prog1 (recons arglist
+ (if destructuringp
+ (walk-arglist arg context env destructuringp)
+ (relist* arg
+ (car arg)
+ (walk-form-internal (cadr arg) :eval env)
+ (cddr arg)))
+ (walk-arglist (cdr arglist) context env nil))
+ (if (symbolp (car arg))
+ (note-lexical-binding (car arg) env)
+ (note-lexical-binding (cadar arg) env))
+ (or (null (cddr arg))
+ (not (symbolp (caddr arg)))
+ (note-lexical-binding (caddr arg) env))))
+ (t
+ (error "Can't understand something in the arglist ~S" arglist))))
+
+(defun walk-let (form context env)
+ (walk-let/let* form context env nil))
+
+(defun walk-let* (form context env)
+ (walk-let/let* form context env t))
+
+(defun walk-prog (form context env)
+ (walk-prog/prog* form context env nil))
+
+(defun walk-prog* (form context env)
+ (walk-prog/prog* form context env t))
+
+(defun walk-do (form context env)
+ (walk-do/do* form context env nil))
+
+(defun walk-do* (form context env)
+ (walk-do/do* form context env t))
+
+(defun walk-let/let* (form context old-env sequentialp)
+ (walker-environment-bind (new-env old-env)
+ (let* ((let/let* (car form))
+ (bindings (cadr form))
+ (body (cddr form))
+ (walked-bindings
+ (walk-bindings-1 bindings
+ old-env
+ new-env
+ context
+ sequentialp))
+ (walked-body
+ (walk-declarations body #'walk-repeat-eval new-env)))
+ (relist*
+ form let/let* walked-bindings walked-body))))
+
+(defun walk-locally (form context env)
+ (declare (ignore context))
+ (let* ((locally (car form))
+ (body (cdr form))
+ (walked-body
+ (walk-declarations body #'walk-repeat-eval env)))
+ (relist*
+ form locally walked-body)))
+
+(defun walk-prog/prog* (form context old-env sequentialp)
+ (walker-environment-bind (new-env old-env)
+ (let* ((possible-block-name (second form))
+ (blocked-prog (and (symbolp possible-block-name)
+ (not (eq possible-block-name 'nil)))))
+ (multiple-value-bind (let/let* block-name bindings body)
+ (if blocked-prog
+ (values (car form) (cadr form) (caddr form) (cdddr form))
+ (values (car form) nil (cadr form) (cddr form)))
+ (let* ((walked-bindings
+ (walk-bindings-1 bindings
+ old-env
+ new-env
+ context
+ sequentialp))
+ (walked-body
+ (walk-declarations
+ body
+ #'(lambda (real-body real-env)
+ (walk-tagbody-1 real-body context real-env))
+ new-env)))
+ (if block-name
+ (relist*
+ form let/let* block-name walked-bindings walked-body)
+ (relist*
+ form let/let* walked-bindings walked-body)))))))
+
+(defun walk-do/do* (form context old-env sequentialp)
+ (walker-environment-bind (new-env old-env)
+ (let* ((do/do* (car form))
+ (bindings (cadr form))
+ (end-test (caddr form))
+ (body (cdddr form))
+ (walked-bindings (walk-bindings-1 bindings
+ old-env
+ new-env
+ context
+ sequentialp))
+ (walked-body
+ (walk-declarations body #'walk-repeat-eval new-env)))
+ (relist* form
+ do/do*
+ (walk-bindings-2 bindings walked-bindings context new-env)
+ (walk-template end-test '(test repeat (eval)) context new-env)
+ walked-body))))
+
+(defun walk-let-if (form context env)
+ (let ((test (cadr form))
+ (bindings (caddr form))
+ (body (cdddr form)))
+ (walk-form-internal
+ `(let ()
+ (declare (special ,@(mapcar #'(lambda (x) (if (listp x) (car x) x))
+ bindings)))
+ (flet ((.let-if-dummy. () ,@body))
+ (if ,test
+ (let ,bindings (.let-if-dummy.))
+ (.let-if-dummy.))))
+ context
+ env)))
+
+(defun walk-multiple-value-setq (form context env)
+ (let ((vars (cadr form)))
+ (if (some #'(lambda (var)
+ (variable-symbol-macro-p var env))
+ vars)
+ (let* ((temps (mapcar #'(lambda (var)
+ (declare (ignore var))
+ (gensym))
+ vars))
+ (sets (mapcar #'(lambda (var temp) `(setq ,var ,temp))
+ vars
+ temps))
+ (expanded `(multiple-value-bind ,temps ,(caddr form)
+ ,@sets))
+ (walked (walk-form-internal expanded context env)))
+ (if (eq walked expanded)
+ form
+ walked))
+ (walk-template form '(nil (repeat (set)) eval) context env))))
+
+(defun walk-multiple-value-bind (form context old-env)
+ (walker-environment-bind (new-env old-env)
+ (let* ((mvb (car form))
+ (bindings (cadr form))
+ (mv-form (walk-template (caddr form) 'eval context old-env))
+ (body (cdddr form))
+ walked-bindings
+ (walked-body
+ (walk-declarations
+ body
+ #'(lambda (real-body real-env)
+ (setq walked-bindings
+ (walk-bindings-1 bindings
+ old-env
+ new-env
+ context
+ nil))
+ (walk-repeat-eval real-body real-env))
+ new-env)))
+ (relist* form mvb walked-bindings mv-form walked-body))))
+
+(defun walk-bindings-1 (bindings old-env new-env context sequentialp)
+ (and bindings
+ (let ((binding (car bindings)))
+ (recons bindings
+ (if (symbolp binding)
+ (prog1 binding
+ (note-lexical-binding binding new-env))
+ (prog1 (relist* binding
+ (car binding)
+ (walk-form-internal (cadr binding)
+ context
+ (if sequentialp
+ new-env
+ old-env))
+ (cddr binding)) ; Save cddr for DO/DO*;
+ ; it is the next value
+ ; form. Don't walk it
+ ; now though.
+ (note-lexical-binding (car binding) new-env)))
+ (walk-bindings-1 (cdr bindings)
+ old-env
+ new-env
+ context
+ sequentialp)))))
+
+(defun walk-bindings-2 (bindings walked-bindings context env)
+ (and bindings
+ (let ((binding (car bindings))
+ (walked-binding (car walked-bindings)))
+ (recons bindings
+ (if (symbolp binding)
+ binding
+ (relist* binding
+ (car walked-binding)
+ (cadr walked-binding)
+ (walk-template (cddr binding)
+ '(eval)
+ context
+ env)))
+ (walk-bindings-2 (cdr bindings)
+ (cdr walked-bindings)
+ context
+ env)))))
+
+(defun walk-lambda (form context old-env)
+ (walker-environment-bind (new-env old-env)
+ (let* ((arglist (cadr form))
+ (body (cddr form))
+ (walked-arglist (walk-arglist arglist context new-env))
+ (walked-body
+ (walk-declarations body #'walk-repeat-eval new-env)))
+ (relist* form
+ (car form)
+ walked-arglist
+ walked-body))))
+
+(defun walk-named-lambda (form context old-env)
+ (walker-environment-bind (new-env old-env)
+ (let* ((name (cadr form))
+ (arglist (caddr form))
+ (body (cdddr form))
+ (walked-arglist (walk-arglist arglist context new-env))
+ (walked-body
+ (walk-declarations body #'walk-repeat-eval new-env)))
+ (relist* form
+ (car form)
+ name
+ walked-arglist
+ walked-body))))
+
+(defun walk-setq (form context env)
+ (if (cdddr form)
+ (let* ((expanded (let ((rforms nil)
+ (tail (cdr form)))
+ (loop (when (null tail) (return (nreverse rforms)))
+ (let ((var (pop tail)) (val (pop tail)))
+ (push `(setq ,var ,val) rforms)))))
+ (walked (walk-repeat-eval expanded env)))
+ (if (eq expanded walked)
+ form
+ `(progn ,@walked)))
+ (let* ((var (cadr form))
+ (val (caddr form))
+ (symmac (car (variable-symbol-macro-p var env))))
+ (if symmac
+ (let* ((expanded `(setf ,(cddr symmac) ,val))
+ (walked (walk-form-internal expanded context env)))
+ (if (eq expanded walked)
+ form
+ walked))
+ (relist form 'setq
+ (walk-form-internal var :set env)
+ (walk-form-internal val :eval env))))))
+
+(defun walk-symbol-macrolet (form context old-env)
+ (declare (ignore context))
+ (let* ((bindings (cadr form))
+ (body (cddr form)))
+ (walker-environment-bind
+ (new-env old-env
+ :lexical-variables
+ (append (mapcar #'(lambda (binding)
+ `(,(car binding)
+ :macro . ,(cadr binding)))
+ bindings)
+ (env-lexical-variables old-env)))
+ (relist* form 'symbol-macrolet bindings
+ (walk-declarations body #'walk-repeat-eval new-env)))))
+
+(defun walk-tagbody (form context env)
+ (recons form (car form) (walk-tagbody-1 (cdr form) context env)))
+
+(defun walk-tagbody-1 (form context env)
+ (and form
+ (recons form
+ (walk-form-internal (car form)
+ (if (symbolp (car form)) 'quote context)
+ env)
+ (walk-tagbody-1 (cdr form) context env))))
+
+(defun walk-macrolet (form context old-env)
+ (walker-environment-bind (macro-env
+ nil
+ :walk-function (env-walk-function old-env))
+ (labels ((walk-definitions (definitions)
+ (and definitions
+ (let ((definition (car definitions)))
+ (recons definitions
+ (relist* definition
+ (car definition)
+ (walk-arglist (cadr definition)
+ context
+ macro-env
+ t)
+ (walk-declarations (cddr definition)
+ #'walk-repeat-eval
+ macro-env))
+ (walk-definitions (cdr definitions)))))))
+ (with-new-definition-in-environment (new-env old-env form)
+ (relist* form
+ (car form)
+ (walk-definitions (cadr form))
+ (walk-declarations (cddr form)
+ #'walk-repeat-eval
+ new-env))))))
+
+(defun walk-flet (form context old-env)
+ (labels ((walk-definitions (definitions)
+ (if (null definitions)
+ ()
+ (recons definitions
+ (walk-lambda (car definitions) context old-env)
+ (walk-definitions (cdr definitions))))))
+ (recons form
+ (car form)
+ (recons (cdr form)
+ (walk-definitions (cadr form))
+ (with-new-definition-in-environment (new-env old-env form)
+ (walk-declarations (cddr form)
+ #'walk-repeat-eval
+ new-env))))))
+
+(defun walk-labels (form context old-env)
+ (with-new-definition-in-environment (new-env old-env form)
+ (labels ((walk-definitions (definitions)
+ (if (null definitions)
+ ()
+ (recons definitions
+ (walk-lambda (car definitions) context new-env)
+ (walk-definitions (cdr definitions))))))
+ (recons form
+ (car form)
+ (recons (cdr form)
+ (walk-definitions (cadr form))
+ (walk-declarations (cddr form)
+ #'walk-repeat-eval
+ new-env))))))
+
+(defun walk-if (form context env)
+ (let ((predicate (cadr form))
+ (arm1 (caddr form))
+ (arm2
+ (if (cddddr form)
+ ;; FIXME: This should go away now that we're no longer trying
+ ;; to support any old weird CLTL1.
+ (progn
+ (warn "In the form:~%~S~%~
+ IF only accepts three arguments, you are using ~D.~%~
+ It is true that some Common Lisps support this, but ~
+ it is not~%~
+ truly legal Common Lisp. For now, this code ~
+ walker is interpreting ~%~
+ the extra arguments as extra else clauses. ~
+ Even if this is what~%~
+ you intended, you should fix your source code."
+ form
+ (length (cdr form)))
+ (cons 'progn (cdddr form)))
+ (cadddr form))))
+ (relist form
+ 'if
+ (walk-form-internal predicate context env)
+ (walk-form-internal arm1 context env)
+ (walk-form-internal arm2 context env))))
+\f
+;;;; tests tests tests
+
+#|
+;;; Here are some examples of the kinds of things you should be able to do
+;;; with your implementation of the macroexpansion environment hacking
+;;; mechanism.
+;;;
+;;; WITH-LEXICAL-MACROS is kind of like MACROLET, but it only takes names
+;;; of the macros and actual macroexpansion functions to use to macroexpand
+;;; them. The win about that is that for macros which want to wrap several
+;;; MACROLETs around their body, they can do this but have the macroexpansion
+;;; functions be compiled. See the WITH-RPUSH example.
+;;;
+;;; If the implementation had a special way of communicating the augmented
+;;; environment back to the evaluator that would be totally great. It would
+;;; mean that we could just augment the environment then pass control back
+;;; to the implementations own compiler or interpreter. We wouldn't have
+;;; to call the actual walker. That would make this much faster. Since the
+;;; principal client of this is defmethod it would make compiling defmethods
+;;; faster and that would certainly be a win.
+
+(defmacro with-lexical-macros (macros &body body &environment old-env)
+ (with-augmented-environment (new-env old-env :macros macros)
+ (walk-form (cons 'progn body) :environment new-env)))
+
+(defun expand-rpush (form env)
+ `(push ,(caddr form) ,(cadr form)))
+
+(defmacro with-rpush (&body body)
+ `(with-lexical-macros ,(list (list 'rpush #'expand-rpush)) ,@body))
+
+;;; Unfortunately, I don't have an automatic tester for the walker.
+;;; Instead there is this set of test cases with a description of
+;;; how each one should go.
+(defmacro take-it-out-for-a-test-walk (form)
+ `(take-it-out-for-a-test-walk-1 ',form))
+
+(defun take-it-out-for-a-test-walk-1 (form)
+ (terpri)
+ (terpri)
+ (let ((copy-of-form (copy-tree form))
+ (result (walk-form form nil
+ #'(lambda (x y env)
+ (format t "~&Form: ~S ~3T Context: ~A" x y)
+ (when (symbolp x)
+ (let ((lexical (variable-lexical-p x env))
+ (special (variable-special-p x env)))
+ (when lexical
+ (format t ";~3T")
+ (format t "lexically bound"))
+ (when special
+ (format t ";~3T")
+ (format t "declared special"))
+ (when (boundp x)
+ (format t ";~3T")
+ (format t "bound: ~S " (eval x)))))
+ x))))
+ (cond ((not (equal result copy-of-form))
+ (format t "~%Warning: Result not EQUAL to copy of start."))
+ ((not (eq result form))
+ (format t "~%Warning: Result not EQ to copy of start.")))
+ (pprint result)
+ result))
+
+(defmacro foo (&rest ignore) ''global-foo)
+
+(defmacro bar (&rest ignore) ''global-bar)
+
+(take-it-out-for-a-test-walk (list arg1 arg2 arg3))
+(take-it-out-for-a-test-walk (list (cons 1 2) (list 3 4 5)))
+
+(take-it-out-for-a-test-walk (progn (foo) (bar 1)))
+
+(take-it-out-for-a-test-walk (block block-name a b c))
+(take-it-out-for-a-test-walk (block block-name (list a) b c))
+
+(take-it-out-for-a-test-walk (catch catch-tag (list a) b c))
+;;; This is a fairly simple macrolet case. While walking the body of the
+;;; macro, x should be lexically bound. In the body of the macrolet form
+;;; itself, x should not be bound.
+(take-it-out-for-a-test-walk
+ (macrolet ((foo (x) (list x) ''inner))
+ x
+ (foo 1)))
+
+;;; A slightly more complex macrolet case. In the body of the macro x
+;;; should not be lexically bound. In the body of the macrolet form itself
+;;; x should be bound. Note that THIS CASE WILL CAUSE AN ERROR when it
+;;; tries to macroexpand the call to foo.
+(take-it-out-for-a-test-walk
+ (let ((x 1))
+ (macrolet ((foo () (list x) ''inner))
+ x
+ (foo))))
+
+(take-it-out-for-a-test-walk
+ (flet ((foo (x) (list x y))
+ (bar (x) (list x y)))
+ (foo 1)))
+
+(take-it-out-for-a-test-walk
+ (let ((y 2))
+ (flet ((foo (x) (list x y))
+ (bar (x) (list x y)))
+ (foo 1))))
+
+(take-it-out-for-a-test-walk
+ (labels ((foo (x) (bar x))
+ (bar (x) (foo x)))
+ (foo 1)))
+
+(take-it-out-for-a-test-walk
+ (flet ((foo (x) (foo x)))
+ (foo 1)))
+
+(take-it-out-for-a-test-walk
+ (flet ((foo (x) (foo x)))
+ (flet ((bar (x) (foo x)))
+ (bar 1))))
+
+(take-it-out-for-a-test-walk (prog () (declare (special a b))))
+(take-it-out-for-a-test-walk (let (a b c)
+ (declare (special a b))
+ (foo a) b c))
+(take-it-out-for-a-test-walk (let (a b c)
+ (declare (special a) (special b))
+ (foo a) b c))
+(take-it-out-for-a-test-walk (let (a b c)
+ (declare (special a))
+ (declare (special b))
+ (foo a) b c))
+(take-it-out-for-a-test-walk (let (a b c)
+ (declare (special a))
+ (declare (special b))
+ (let ((a 1))
+ (foo a) b c)))
+(take-it-out-for-a-test-walk (eval-when ()
+ a
+ (foo a)))
+(take-it-out-for-a-test-walk (eval-when (eval when load)
+ a
+ (foo a)))
+
+(take-it-out-for-a-test-walk (multiple-value-bind (a b) (foo a b) (list a b)))
+(take-it-out-for-a-test-walk (multiple-value-bind (a b)
+ (foo a b)
+ (declare (special a))
+ (list a b)))
+(take-it-out-for-a-test-walk (progn (function foo)))
+(take-it-out-for-a-test-walk (progn a b (go a)))
+(take-it-out-for-a-test-walk (if a b c))
+(take-it-out-for-a-test-walk (if a b))
+(take-it-out-for-a-test-walk ((lambda (a b) (list a b)) 1 2))
+(take-it-out-for-a-test-walk ((lambda (a b) (declare (special a)) (list a b))
+ 1 2))
+(take-it-out-for-a-test-walk (let ((a a) (b a) (c b)) (list a b c)))
+(take-it-out-for-a-test-walk (let* ((a a) (b a) (c b)) (list a b c)))
+(take-it-out-for-a-test-walk (let ((a a) (b a) (c b))
+ (declare (special a b))
+ (list a b c)))
+(take-it-out-for-a-test-walk (let* ((a a) (b a) (c b))
+ (declare (special a b))
+ (list a b c)))
+(take-it-out-for-a-test-walk (let ((a 1) (b 2))
+ (foo bar)
+ (declare (special a))
+ (foo a b)))
+(take-it-out-for-a-test-walk (multiple-value-call #'foo a b c))
+(take-it-out-for-a-test-walk (multiple-value-prog1 a b c))
+(take-it-out-for-a-test-walk (progn a b c))
+(take-it-out-for-a-test-walk (progv vars vals a b c))
+(take-it-out-for-a-test-walk (quote a))
+(take-it-out-for-a-test-walk (return-from block-name a b c))
+(take-it-out-for-a-test-walk (setq a 1))
+(take-it-out-for-a-test-walk (setq a (foo 1) b (bar 2) c 3))
+(take-it-out-for-a-test-walk (tagbody a b c (go a)))
+(take-it-out-for-a-test-walk (the foo (foo-form a b c)))
+(take-it-out-for-a-test-walk (throw tag-form a))
+(take-it-out-for-a-test-walk (unwind-protect (foo a b) d e f))
+
+(defmacro flet-1 (a b) ''outer)
+(defmacro labels-1 (a b) ''outer)
+
+(take-it-out-for-a-test-walk
+ (flet ((flet-1 (a b) () (flet-1 a b) (list a b)))
+ (flet-1 1 2)
+ (foo 1 2)))
+(take-it-out-for-a-test-walk
+ (labels ((label-1 (a b) () (label-1 a b)(list a b)))
+ (label-1 1 2)
+ (foo 1 2)))
+(take-it-out-for-a-test-walk (macrolet ((macrolet-1 (a b) (list a b)))
+ (macrolet-1 a b)
+ (foo 1 2)))
+
+(take-it-out-for-a-test-walk (macrolet ((foo (a) `(inner-foo-expanded ,a)))
+ (foo 1)))
+
+(take-it-out-for-a-test-walk (progn (bar 1)
+ (macrolet ((bar (a)
+ `(inner-bar-expanded ,a)))
+ (bar 2))))
+
+(take-it-out-for-a-test-walk (progn (bar 1)
+ (macrolet ((bar (s)
+ (bar s)
+ `(inner-bar-expanded ,s)))
+ (bar 2))))
+
+(take-it-out-for-a-test-walk (cond (a b)
+ ((foo bar) a (foo a))))
+
+(let ((the-lexical-variables ()))
+ (walk-form '(let ((a 1) (b 2))
+ #'(lambda (x) (list a b x y)))
+ ()
+ #'(lambda (form context env)
+ (when (and (symbolp form)
+ (variable-lexical-p form env))
+ (push form the-lexical-variables))
+ form))
+ (or (and (= (length the-lexical-variables) 3)
+ (member 'a the-lexical-variables)
+ (member 'b the-lexical-variables)
+ (member 'x the-lexical-variables))
+ (error "Walker didn't do lexical variables of a closure properly.")))
+|#
--- /dev/null
+depend
+sbcl
+sbcl.h
+sbcl.nm
--- /dev/null
+CPPFLAGS = -I.
+
+CC = gcc -Wstrict-prototypes -fno-strength-reduce # -Wall
+LD = ld
+CPP = cpp
+CFLAGS = -g -O2 -DGENCGC -DPOSIX_SIGS
+ASFLAGS = -g -DGENCGC
+LINKFLAGS = -g
+NM = nm -gp
+
+ASSEM_SRC = x86-assem.S
+ARCH_SRC = x86-arch.c
+
+OS_SRC = bsd-os.c os-common.c undefineds.c
+OS_LINK_FLAGS=-static
+OS_LIBS=-lm # -ldl
+
+GC_SRC= gencgc.c
--- /dev/null
+CPPFLAGS = -I.
+
+CC = gcc -Wstrict-prototypes -O2 -fno-strength-reduce # -Wall
+LD = ld
+CPP = cpp
+CFLAGS = -g -O2 -DGENCGC
+ASFLAGS = -g -DGENCGC
+LINKFLAGS = -g
+NM = nm -p
+
+ASSEM_SRC = x86-assem.S linux-stubs.S
+ARCH_SRC = x86-arch.c
+
+OS_SRC = linux-os.c os-common.c
+OS_LINK_FLAGS=
+OS_LIBS= -ldl
+
+GC_SRC= gencgc.c
--- /dev/null
+# makefile for the C-level run-time support for SBCL
+
+# This software is part of the SBCL system. See the README file for
+# more information.
+#
+# This software is derived from the CMU CL system, which was
+# written at Carnegie Mellon University and released into the
+# public domain. The software is in the public domain and is
+# provided with absolutely no warranty. See the COPYING and CREDITS
+# files for more information.
+
+all: sbcl sbcl.nm
+.PHONY: all
+
+# defaults which might be overridden by values in the Config file
+CC = gcc
+DEPEND_FLAGS =
+
+# The Config file is the preferred place for tweaking options which
+# are appropriate for particular setups (OS, CPU, whatever). Make
+# a Config-foo file for setup foo, then set Config to be a symlink
+# to Config-foo.
+include Config
+
+SRCS = alloc.c backtrace.c breakpoint.c coreparse.c \
+ dynbind.c globals.c interr.c interrupt.c \
+ monitor.c parse.c print.c purify.c \
+ regnames.c runtime.c save.c search.c \
+ time.c validate.c vars.c \
+ ${ARCH_SRC} ${ASSEM_SRC} ${OS_SRC} ${GC_SRC}
+
+OBJS = $(patsubst %.c,%.o,$(patsubst %.S,%.o,$(patsubst %.s,%.o,$(SRCS))))
+
+sbcl.nm: sbcl
+ $(NM) sbcl | grep -v " F \| U " > ,$@
+ mv -f ,$@ $@
+
+sbcl: ${OBJS}
+ $(CC) ${LINKFLAGS} ${OS_LINK_FLAGS} -o $@ ${OBJS} ${OS_LIBS} -lm
+
+.PHONY: clean all
+clean:
+ rm -f depend *.o sbcl sbcl.nm core *.tmp ; true
+
+depend: ${SRCS} sbcl.h
+ $(CC) -MM -E ${DEPEND_FLAGS} ${CFLAGS} ${CPPFLAGS} $? > depend.tmp
+ mv -f depend.tmp depend
--- /dev/null
+/*
+ * allocation routines
+ */
+
+/*
+ * This software is part of the SBCL system. See the README file for
+ * more information.
+ *
+ * This software is derived from the CMU CL system, which was
+ * written at Carnegie Mellon University and released into the
+ * public domain. The software is in the public domain and is
+ * provided with absolutely no warranty. See the COPYING and CREDITS
+ * files for more information.
+ */
+
+/*
+ * $Header$
+ */
+
+#include "runtime.h"
+#include "sbcl.h"
+#include "alloc.h"
+#include "globals.h"
+#include "gc.h"
+
+#ifdef ibmrt
+#define GET_FREE_POINTER() ((lispobj *)SymbolValue(ALLOCATION_POINTER))
+#define SET_FREE_POINTER(new_value) \
+ (SetSymbolValue(ALLOCATION_POINTER,(lispobj)(new_value)))
+#define GET_GC_TRIGGER() ((lispobj *)SymbolValue(INTERNAL_GC_TRIGGER))
+#define SET_GC_TRIGGER(new_value) \
+ (SetSymbolValue(INTERNAL_GC_TRIGGER,(lispobj)(new_value)))
+#else
+#define GET_FREE_POINTER() current_dynamic_space_free_pointer
+#define SET_FREE_POINTER(new_value) \
+ (current_dynamic_space_free_pointer = (new_value))
+#define GET_GC_TRIGGER() current_auto_gc_trigger
+#define SET_GC_TRIGGER(new_value) \
+ clear_auto_gc_trigger(); set_auto_gc_trigger(new_value);
+#endif
+
+#define ALIGNED_SIZE(n) (n+lowtag_Mask) & ~lowtag_Mask
+
+#if defined(WANT_CGC) || defined(GENCGC)
+extern lispobj *alloc(int bytes);
+#else
+static lispobj *alloc(int bytes)
+{
+ lispobj *result;
+
+ /* Round to dual word boundary. */
+ bytes = (bytes + lowtag_Mask) & ~lowtag_Mask;
+
+ result = GET_FREE_POINTER();
+ SET_FREE_POINTER(result + (bytes / sizeof(lispobj)));
+
+ if (GET_GC_TRIGGER() && GET_FREE_POINTER() > GET_GC_TRIGGER()) {
+ SET_GC_TRIGGER((char *)GET_FREE_POINTER()
+ - (char *)current_dynamic_space);
+ }
+
+ return result;
+}
+#endif
+
+static lispobj *alloc_unboxed(int type, int words)
+{
+ lispobj *result;
+
+ result = alloc(ALIGNED_SIZE((1 + words) * sizeof(lispobj)));
+
+ *result = (lispobj) (words << type_Bits) | type;
+
+ return result;
+}
+
+static lispobj alloc_vector(int type, int length, int size)
+{
+ struct vector *result;
+
+ result = (struct vector *)
+ alloc(ALIGNED_SIZE((2 + (length*size + 31) / 32) * sizeof(lispobj)));
+
+ result->header = type;
+ result->length = make_fixnum(length);
+
+ return ((lispobj)result)|type_OtherPointer;
+}
+
+lispobj alloc_cons(lispobj car, lispobj cdr)
+{
+ struct cons *ptr = (struct cons *)alloc(ALIGNED_SIZE(sizeof(struct cons)));
+
+ ptr->car = car;
+ ptr->cdr = cdr;
+
+ return (lispobj)ptr | type_ListPointer;
+}
+
+lispobj alloc_number(long n)
+{
+ struct bignum *ptr;
+
+ if (-0x20000000 < n && n < 0x20000000)
+ return make_fixnum(n);
+ else {
+ ptr = (struct bignum *)alloc_unboxed(type_Bignum, 1);
+
+ ptr->digits[0] = n;
+
+ return (lispobj) ptr | type_OtherPointer;
+ }
+}
+
+lispobj alloc_string(char *str)
+{
+ int len = strlen(str);
+ lispobj result = alloc_vector(type_SimpleString, len+1, 8);
+ struct vector *vec = (struct vector *)PTR(result);
+
+ vec->length = make_fixnum(len);
+ strcpy((char *)vec->data, str);
+
+ return result;
+}
+
+lispobj alloc_sap(void *ptr)
+{
+ /* FIXME: It would probably be good to grep for "alpha" everywhere
+ * and replace this kind of weirdness with nicer parameterizations
+ * like N_WORDS_IN_POINTER. However, it might be hard to do this
+ * well enough to be useful without an Alpha to test on. What to do? */
+#ifndef alpha
+ struct sap *sap = (struct sap *)alloc_unboxed(type_Sap, 1);
+#else
+ struct sap *sap = (struct sap *)alloc_unboxed(type_Sap, 3);
+#endif
+ sap->pointer = ptr;
+
+ return (lispobj) sap | type_OtherPointer;
+}
--- /dev/null
+/*
+ * This software is part of the SBCL system. See the README file for
+ * more information.
+ *
+ * This software is derived from the CMU CL system, which was
+ * written at Carnegie Mellon University and released into the
+ * public domain. The software is in the public domain and is
+ * provided with absolutely no warranty. See the COPYING and CREDITS
+ * files for more information.
+ */
+
+/*
+ * $Header$
+ */
+
+#ifndef _ALLOC_H_
+#define _ALLOC_H_
+
+#include "runtime.h"
+
+extern lispobj alloc_cons(lispobj car, lispobj cdr);
+extern lispobj alloc_number(long n);
+extern lispobj alloc_string(char *str);
+extern lispobj alloc_sap(void *ptr);
+
+#endif _ALLOC_H_
--- /dev/null
+/*
+ * This software is part of the SBCL system. See the README file for
+ * more information.
+ *
+ * This software is derived from the CMU CL system, which was
+ * written at Carnegie Mellon University and released into the
+ * public domain. The software is in the public domain and is
+ * provided with absolutely no warranty. See the COPYING and CREDITS
+ * files for more information.
+ */
+
+/*
+ * $Header$
+ */
+
+#ifndef __ARCH_H__
+#define __ARCH_H__
+
+#include "os.h"
+#include "signal.h"
+
+extern void arch_init(void);
+extern void arch_skip_instruction(os_context_t*);
+extern boolean arch_pseudo_atomic_atomic(os_context_t*);
+extern void arch_set_pseudo_atomic_interrupted(os_context_t*);
+extern os_vm_address_t arch_get_bad_addr(int, siginfo_t*, os_context_t*);
+extern unsigned char *arch_internal_error_arguments(os_context_t*);
+extern unsigned long arch_install_breakpoint(void *pc);
+extern void arch_remove_breakpoint(void *pc, unsigned long orig_inst);
+extern void arch_install_interrupt_handlers(void);
+extern void arch_do_displaced_inst(os_context_t *context,
+ unsigned long orig_inst);
+extern lispobj funcall0(lispobj function);
+extern lispobj funcall1(lispobj function, lispobj arg0);
+extern lispobj funcall2(lispobj function, lispobj arg0, lispobj arg1);
+extern lispobj funcall3(lispobj function, lispobj arg0, lispobj arg1,
+ lispobj arg2);
+
+#endif /* __ARCH_H__ */
--- /dev/null
+/*
+ * simple backtrace facility
+ */
+
+/*
+ * This software is part of the SBCL system. See the README file for
+ * more information.
+ *
+ * This software is derived from the CMU CL system, which was
+ * written at Carnegie Mellon University and released into the
+ * public domain. The software is in the public domain and is
+ * provided with absolutely no warranty. See the COPYING and CREDITS
+ * files for more information.
+ */
+
+/*
+ * $Header$
+ */
+
+#include <stdio.h>
+#include <signal.h>
+#include "runtime.h"
+#include "sbcl.h"
+#include "globals.h"
+#include "os.h"
+#include "interrupt.h"
+#include "lispregs.h"
+
+#ifndef __i386__
+
+/* KLUDGE: Sigh ... I know what the call frame looks like and it had
+ * better not change. */
+
+struct call_frame {
+#ifndef alpha
+ struct call_frame *old_cont;
+#else
+ u32 old_cont;
+#endif
+ lispobj saved_lra;
+ lispobj code;
+ lispobj other_state[5];
+};
+
+struct call_info {
+#ifndef alpha
+ struct call_frame *frame;
+#else
+ u32 frame;
+#endif
+ int interrupted;
+#ifndef alpha
+ struct code *code;
+#else
+ u32 code;
+#endif
+ lispobj lra;
+ int pc; /* Note: this is the trace file offset, not the actual pc. */
+};
+
+#define HEADER_LENGTH(header) ((header)>>8)
+
+static int previous_info(struct call_info *info);
+
+static struct code *
+code_pointer(lispobj object)
+{
+ lispobj *headerp, header;
+ int type, len;
+
+ headerp = (lispobj *) PTR(object);
+ header = *headerp;
+ type = TypeOf(header);
+
+ switch (type) {
+ case type_CodeHeader:
+ break;
+ case type_ReturnPcHeader:
+ case type_FunctionHeader:
+ case type_ClosureFunctionHeader:
+ len = HEADER_LENGTH(header);
+ if (len == 0)
+ headerp = NULL;
+ else
+ headerp -= len;
+ break;
+ default:
+ headerp = NULL;
+ }
+
+ return (struct code *) headerp;
+}
+
+static boolean
+cs_valid_pointer_p(struct call_frame *pointer)
+{
+ return (((char *) control_stack <= (char *) pointer) &&
+ ((char *) pointer < (char *) current_control_stack_pointer));
+}
+
+static void
+call_info_from_lisp_state(struct call_info *info)
+{
+ info->frame = (struct call_frame *)current_control_frame_pointer;
+ info->interrupted = 0;
+ info->code = NULL;
+ info->lra = 0;
+ info->pc = 0;
+
+ previous_info(info);
+}
+
+static void
+call_info_from_context(struct call_info *info, os_context_t *context)
+{
+ unsigned long pc;
+
+ info->interrupted = 1;
+ if (LowtagOf(*os_context_register_addr(context, reg_CODE))
+ == type_FunctionPointer) {
+ /* We tried to call a function, but crapped out before $CODE could
+ * be fixed up. Probably an undefined function. */
+ info->frame =
+ (struct call_frame *)(*os_context_register_addr(context,
+ reg_OCFP));
+ info->lra = (lispobj)(*os_context_register_addr(context, reg_LRA));
+ info->code = code_pointer(info->lra);
+ pc = (unsigned long)PTR(info->lra);
+ }
+ else {
+ info->frame =
+ (struct call_frame *)(*os_context_register_addr(context, reg_CFP));
+ info->code =
+ code_pointer(*os_context_register_addr(context, reg_CODE));
+ info->lra = NIL;
+ pc = *os_context_pc_addr(context);
+ }
+ if (info->code != NULL)
+ info->pc = pc - (unsigned long) info->code -
+#ifndef alpha
+ (HEADER_LENGTH(info->code->header) * sizeof(lispobj));
+#else
+ (HEADER_LENGTH(((struct code *)info->code)->header) * sizeof(lispobj));
+#endif
+ else
+ info->pc = 0;
+}
+
+static int
+previous_info(struct call_info *info)
+{
+ struct call_frame *this_frame;
+ int free;
+
+ if (!cs_valid_pointer_p(info->frame)) {
+ printf("Bogus callee value (0x%08x).\n", (unsigned long)info->frame);
+ return 0;
+ }
+
+ this_frame = info->frame;
+ info->lra = this_frame->saved_lra;
+ info->frame = this_frame->old_cont;
+ info->interrupted = 0;
+
+ if (info->frame == NULL || info->frame == this_frame)
+ return 0;
+
+ if (info->lra == NIL) {
+ /* We were interrupted. Find the correct signal context. */
+ free = SymbolValue(FREE_INTERRUPT_CONTEXT_INDEX)>>2;
+ while (free-- > 0) {
+ os_context_t *context =
+ lisp_interrupt_contexts[free];
+ if ((struct call_frame *)(*os_context_register_addr(context,
+ reg_CFP))
+ == info->frame) {
+ call_info_from_context(info, context);
+ break;
+ }
+ }
+ }
+ else {
+ info->code = code_pointer(info->lra);
+ if (info->code != NULL)
+ info->pc = (unsigned long)PTR(info->lra) -
+ (unsigned long)info->code -
+#ifndef alpha
+ (HEADER_LENGTH(info->code->header) * sizeof(lispobj));
+#else
+ (HEADER_LENGTH(((struct code *)info->code)->header) * sizeof(lispobj));
+#endif
+ else
+ info->pc = 0;
+ }
+
+ return 1;
+}
+
+void
+backtrace(int nframes)
+{
+ struct call_info info;
+
+ call_info_from_lisp_state(&info);
+
+ do {
+ printf("<Frame 0x%08x%s, ", (unsigned long) info.frame,
+ info.interrupted ? " [interrupted]" : "");
+
+ if (info.code != (struct code *) 0) {
+ lispobj function;
+
+ printf("CODE: 0x%08X, ", (unsigned long) info.code | type_OtherPointer);
+
+#ifndef alpha
+ function = info.code->entry_points;
+#else
+ function = ((struct code *)info.code)->entry_points;
+#endif
+ while (function != NIL) {
+ struct function *header;
+ lispobj name;
+
+ header = (struct function *) PTR(function);
+ name = header->name;
+
+ if (LowtagOf(name) == type_OtherPointer) {
+ lispobj *object;
+
+ object = (lispobj *) PTR(name);
+
+ if (TypeOf(*object) == type_SymbolHeader) {
+ struct symbol *symbol;
+
+ symbol = (struct symbol *) object;
+ object = (lispobj *) PTR(symbol->name);
+ }
+ if (TypeOf(*object) == type_SimpleString) {
+ struct vector *string;
+
+ string = (struct vector *) object;
+ printf("%s, ", (char *) string->data);
+ } else
+ printf("(Not simple string??\?), ");
+ } else
+ printf("(Not other pointer??\?), ");
+
+
+ function = header->next;
+ }
+ }
+ else
+ printf("CODE: ???, ");
+
+ if (info.lra != NIL)
+ printf("LRA: 0x%08x, ", (unsigned long)info.lra);
+ else
+ printf("<no LRA>, ");
+
+ if (info.pc)
+ printf("PC: 0x%x>\n", info.pc);
+ else
+ printf("PC: ??\?>\n");
+
+ } while (--nframes > 0 && previous_info(&info));
+}
+
+#else
+
+void
+backtrace(int nframes)
+{
+ printf("Can't backtrace on this hardware platform.\n");
+}
+
+#endif
--- /dev/null
+/*
+ * This software is part of the SBCL system. See the README file for
+ * more information.
+ *
+ * This software is derived from the CMU CL system, which was
+ * written at Carnegie Mellon University and released into the
+ * public domain. The software is in the public domain and is
+ * provided with absolutely no warranty. See the COPYING and CREDITS
+ * files for more information.
+ */
+
+/*
+ * $Header$
+ */
+
+#include <stdio.h>
+#include <signal.h>
+
+#include "runtime.h"
+#include "os.h"
+#include "sbcl.h"
+#include "interrupt.h"
+#include "arch.h"
+#include "lispregs.h"
+#include "globals.h"
+#include "alloc.h"
+#include "breakpoint.h"
+
+#define REAL_LRA_SLOT 0
+#ifndef __i386__
+#define KNOWN_RETURN_P_SLOT 1
+#define BOGUS_LRA_CONSTANTS 2
+#else
+#define KNOWN_RETURN_P_SLOT 2
+#define BOGUS_LRA_CONSTANTS 3
+#endif
+
+static void *compute_pc(lispobj code_obj, int pc_offset)
+{
+ struct code *code;
+
+ code = (struct code *)PTR(code_obj);
+ return (void *)((char *)code + HeaderValue(code->header)*sizeof(lispobj)
+ + pc_offset);
+}
+
+unsigned long breakpoint_install(lispobj code_obj, int pc_offset)
+{
+ return arch_install_breakpoint(compute_pc(code_obj, pc_offset));
+}
+
+void breakpoint_remove(lispobj code_obj, int pc_offset,
+ unsigned long orig_inst)
+{
+ arch_remove_breakpoint(compute_pc(code_obj, pc_offset), orig_inst);
+}
+
+void breakpoint_do_displaced_inst(os_context_t* context,
+ unsigned long orig_inst)
+{
+#if !defined(hpux) && !defined(irix) && !defined(__i386__)
+ undo_fake_foreign_function_call(context);
+#endif
+ arch_do_displaced_inst(context, orig_inst);
+}
+
+#ifndef __i386__
+static lispobj find_code(os_context_t *context)
+{
+#ifdef reg_CODE
+ lispobj code = *os_context_register_addr(context, reg_CODE);
+ lispobj header;
+
+ if (LowtagOf(code) != type_OtherPointer)
+ return NIL;
+
+ header = *(lispobj *)(code-type_OtherPointer);
+
+ if (TypeOf(header) == type_CodeHeader)
+ return code;
+ else
+ return code - HeaderValue(header)*sizeof(lispobj);
+#else
+ return NIL;
+#endif
+}
+#endif
+
+#ifdef __i386__
+static lispobj find_code(os_context_t *context)
+{
+ lispobj codeptr = component_ptr_from_pc(*os_context_pc_addr(context));
+
+ if (codeptr == 0) {
+ return NIL;
+ } else {
+ return codeptr + type_OtherPointer;
+ }
+}
+#endif
+
+static int compute_offset(os_context_t *context, lispobj code)
+{
+ if (code == NIL)
+ return 0;
+ else {
+ unsigned long code_start;
+ struct code *codeptr = (struct code *)PTR(code);
+#ifdef parisc
+ unsigned long pc = *os_context_pc_addr(context) & ~3;
+#else
+ unsigned long pc = *os_context_pc_addr(context);
+#endif
+
+ code_start = (unsigned long)codeptr
+ + HeaderValue(codeptr->header)*sizeof(lispobj);
+ if (pc < code_start)
+ return 0;
+ else {
+ int offset = pc - code_start;
+ if (offset >= codeptr->code_size)
+ return 0;
+ else
+ return make_fixnum(offset);
+ }
+ }
+}
+
+#ifndef __i386__
+void handle_breakpoint(int signal, siginfo_t *info, os_context_t *context)
+{
+ lispobj code;
+
+ fake_foreign_function_call(context);
+
+ code = find_code(context);
+
+ funcall3(SymbolFunction(HANDLE_BREAKPOINT),
+ compute_offset(context, code),
+ code,
+ alloc_sap(context));
+
+ undo_fake_foreign_function_call(context);
+}
+#else
+void handle_breakpoint(int signal, siginfo_t* info, os_context_t *context)
+{
+ lispobj code, context_sap = alloc_sap(context);
+
+ fake_foreign_function_call(context);
+
+ code = find_code(context);
+
+ /* Don't disallow recursive breakpoint traps. Otherwise, we can't
+ * use debugger breakpoints anywhere in here. */
+ sigprocmask(SIG_SETMASK, os_context_sigmask_addr(context), 0);
+
+ funcall3(SymbolFunction(HANDLE_BREAKPOINT),
+ compute_offset(context, code),
+ code,
+ context_sap);
+
+ undo_fake_foreign_function_call(context);
+}
+#endif
+
+#ifndef __i386__
+void *handle_function_end_breakpoint(int signal, siginfo_t *info,
+ os_context_t *context)
+{
+ lispobj code, lra;
+ struct code *codeptr;
+
+ fake_foreign_function_call(context);
+
+ code = find_code(context);
+ codeptr = (struct code *)PTR(code);
+
+ funcall3(SymbolFunction(HANDLE_BREAKPOINT),
+ compute_offset(context, code),
+ code,
+ alloc_sap(context));
+
+ lra = codeptr->constants[REAL_LRA_SLOT];
+#ifdef reg_CODE
+ if (codeptr->constants[KNOWN_RETURN_P_SLOT] == NIL) {
+ *os_context_register_addr(context, reg_CODE) = lra;
+ }
+#endif
+ undo_fake_foreign_function_call(context);
+ return (void *)(lra-type_OtherPointer+sizeof(lispobj));
+}
+#else
+void *handle_function_end_breakpoint(int signal, siginfo_t *info,
+ os_context_t *context)
+{
+ lispobj code, context_sap = alloc_sap(context);
+ struct code *codeptr;
+
+ fake_foreign_function_call(context);
+
+ code = find_code(context);
+ codeptr = (struct code *)PTR(code);
+
+ /* Don't disallow recursive breakpoint traps. Otherwise, we can't
+ * use debugger breakpoints anywhere in here. */
+ sigprocmask(SIG_SETMASK, os_context_sigmask_addr(context), 0);
+
+ funcall3(SymbolFunction(HANDLE_BREAKPOINT),
+ compute_offset(context, code),
+ code,
+ context_sap);
+
+ undo_fake_foreign_function_call(context);
+
+ return compute_pc(codeptr->constants[REAL_LRA_SLOT],
+ fixnum_value(codeptr->constants[REAL_LRA_SLOT+1]));
+}
+#endif
--- /dev/null
+/*
+ * This software is part of the SBCL system. See the README file for
+ * more information.
+ *
+ * This software is derived from the CMU CL system, which was
+ * written at Carnegie Mellon University and released into the
+ * public domain. The software is in the public domain and is
+ * provided with absolutely no warranty. See the COPYING and CREDITS
+ * files for more information.
+ */
+
+/*
+ * $Header$
+ */
+
+#ifndef _BREAKPOINT_H_
+#define _BREAKPOINT_H_
+
+extern unsigned long breakpoint_install(lispobj code_obj, int pc_offset);
+extern void breakpoint_remove(lispobj code_obj,
+ int pc_offset,
+ unsigned long orig_inst);
+extern void breakpoint_do_displaced_inst(os_context_t *context,
+ unsigned long orig_inst);
+extern void handle_breakpoint(int signal, siginfo_t *info,
+ os_context_t *context);
+extern void *handle_function_end_breakpoint(int signal, siginfo_t *info,
+ os_context_t *context);
+
+#endif
--- /dev/null
+/*
+ * OS-dependent routines for FreeBSD (and could maybe be extended to all BSD?)
+ *
+ * This file (along with os.h) exports an OS-independent interface to
+ * the operating system VM facilities. This interface looks a lot like
+ * the Mach interface (but simpler in some places). For some operating
+ * systems, a subset of these functions will have to be emulated.
+ */
+
+/*
+ * This software is part of the SBCL system. See the README file for
+ * more information.
+ *
+ * This software is derived from the CMU CL system, which was
+ * written at Carnegie Mellon University and released into the
+ * public domain. The software is in the public domain and is
+ * provided with absolutely no warranty. See the COPYING and CREDITS
+ * files for more information.
+ */
+
+/*
+ * $Header$
+ */
+
+#include <stdio.h>
+#include <sys/param.h>
+#include <sys/file.h>
+#include "./signal.h"
+#include "os.h"
+#include "arch.h"
+#include "globals.h"
+#include "interrupt.h"
+#include "lispregs.h"
+#include "sbcl.h"
+
+#include <sys/types.h>
+#include <signal.h>
+/* #include <sys/sysinfo.h> */
+#include <sys/proc.h>
+#include "validate.h"
+vm_size_t os_vm_page_size;
+
+#if defined GENCGC
+#include "gencgc.h"
+#endif
+
+/* The different BSD variants have diverged in exactly where they
+ * store signal context information, but at least they tend to use the
+ * same stems to name the structure fields, so by using this macro we
+ * can share a fair amount of code between different variants. */
+#if defined __FreeBSD__
+#define CONTEXT_ADDR_FROM_STEM(stem) &context->uc_mcontext.mc_ ## stem
+#elif defined __OpenBSD__
+#define CONTEXT_ADDR_FROM_STEM(stem) &context->sc_ ## stem
+#else
+#error unsupported BSD variant
+#endif
+\f
+void
+os_init(void)
+{
+ os_vm_page_size = getpagesize();
+}
+
+/* KLUDGE: There is strong family resemblance in the signal context
+ * stuff in FreeBSD and OpenBSD, but in detail they're different in
+ * almost every line of code. It would be nice to find some way to
+ * factor out the commonality better; failing that, it might be best
+ * just to split this generic-BSD code into one variant for each BSD. */
+
+int *
+os_context_register_addr(os_context_t *context, int offset)
+{
+ switch(offset) {
+ case 0:
+ return CONTEXT_ADDR_FROM_STEM(eax);
+ case 2:
+ return CONTEXT_ADDR_FROM_STEM(ecx);
+ case 4:
+ return CONTEXT_ADDR_FROM_STEM(edx);
+ case 6:
+ return CONTEXT_ADDR_FROM_STEM(ebx);
+ case 8:
+ return CONTEXT_ADDR_FROM_STEM(esp);
+ case 10:
+ return CONTEXT_ADDR_FROM_STEM(ebp);
+ case 12:
+ return CONTEXT_ADDR_FROM_STEM(esi);
+ case 14:
+ return CONTEXT_ADDR_FROM_STEM(edi);
+ default:
+ return 0;
+ }
+}
+
+int *
+os_context_pc_addr(os_context_t *context)
+{
+#if defined __FreeBSD__
+ return CONTEXT_ADDR_FROM_STEM(eip);
+#elif defined __OpenBSD__
+ return CONTEXT_ADDR_FROM_STEM(pc);
+#else
+#error unsupported BSD variant
+#endif
+}
+
+int *
+os_context_sp_addr(os_context_t *context)
+{
+ return CONTEXT_ADDR_FROM_STEM(esp);
+}
+
+sigset_t *
+os_context_sigmask_addr(os_context_t *context)
+{
+ /* (Unlike most of the other context fields that we access, the
+ * signal mask field is a field of the basic, outermost context
+ * struct itself both in FreeBSD 4.0 and in OpenBSD 2.6.) */
+#if defined __FreeBSD__
+ return &context->uc_sigmask;
+#elif defined __OpenBSD__
+ return &context->sc_mask;
+#else
+#error unsupported BSD variant
+#endif
+}
+
+os_vm_address_t
+os_validate(os_vm_address_t addr, os_vm_size_t len)
+{
+ int flags = MAP_PRIVATE | MAP_ANON;
+
+ if (addr)
+ flags |= MAP_FIXED;
+
+ addr = mmap(addr, len, OS_VM_PROT_ALL, flags, -1, 0);
+
+ if (addr == MAP_FAILED) {
+ perror("mmap");
+ return NULL;
+ }
+
+ return addr;
+}
+
+void
+os_invalidate(os_vm_address_t addr, os_vm_size_t len)
+{
+ if (munmap(addr, len) == -1)
+ perror("munmap");
+}
+
+os_vm_address_t
+os_map(int fd, int offset, os_vm_address_t addr, os_vm_size_t len)
+{
+ addr = mmap(addr, len,
+ OS_VM_PROT_ALL,
+ MAP_PRIVATE | MAP_FILE | MAP_FIXED,
+ fd, (off_t) offset);
+
+ if (addr == MAP_FAILED) {
+ perror("mmap");
+ lose("unexpected mmap(..) failure");
+ }
+
+ return addr;
+}
+
+void
+os_flush_icache(os_vm_address_t address, os_vm_size_t length)
+{
+}
+
+void
+os_protect(os_vm_address_t address, os_vm_size_t length, os_vm_prot_t prot)
+{
+ if (mprotect(address, length, prot) == -1) {
+ perror("mprotect");
+ }
+}
+\f
+static boolean
+in_range_p(os_vm_address_t a, lispobj sbeg, size_t slen)
+{
+ char* beg = (char*) sbeg;
+ char* end = (char*) sbeg + slen;
+ char* adr = (char*) a;
+ return (adr >= beg && adr < end);
+}
+
+boolean
+is_valid_lisp_addr(os_vm_address_t addr)
+{
+ return in_range_p(addr, READ_ONLY_SPACE_START, READ_ONLY_SPACE_SIZE)
+ || in_range_p(addr, STATIC_SPACE_START , STATIC_SPACE_SIZE )
+ || in_range_p(addr, DYNAMIC_0_SPACE_START, DYNAMIC_SPACE_SIZE )
+ || in_range_p(addr, DYNAMIC_1_SPACE_START, DYNAMIC_SPACE_SIZE )
+ || in_range_p(addr, CONTROL_STACK_START , CONTROL_STACK_SIZE )
+ || in_range_p(addr, BINDING_STACK_START , BINDING_STACK_SIZE );
+}
+\f
+/*
+ * any OS-dependent special low-level handling for signals
+ */
+
+#if !defined GENCGC
+
+void
+os_install_interrupt_handlers(void)
+{}
+
+#else
+
+/*
+ * The GENCGC needs to be hooked into whatever signal is raised for
+ * page fault on this OS.
+ */
+static void
+memory_fault_handler(int signal, siginfo_t *siginfo, void *void_context)
+{
+ /* The way that we extract low level information like the fault
+ * address is not specified by POSIX. */
+#if defined __FreeBSD__
+ void *fault_addr = siginfo->si_addr;
+#elif defined __OpenBSD__
+ void *fault_addr = siginfo->si_addr;
+#else
+#error unsupported BSD variant
+#endif
+ if (!gencgc_handle_wp_violation(fault_addr)) {
+ interrupt_handle_now(signal, siginfo, void_context);
+ }
+}
+void
+os_install_interrupt_handlers(void)
+{
+#if defined __FreeBSD__
+ interrupt_install_low_level_handler(SIGBUS, memory_fault_handler);
+#elif defined __OpenBSD__
+ interrupt_install_low_level_handler(SIGSEGV, memory_fault_handler);
+#else
+#error unsupported BSD variant
+#endif
+}
+
+#endif /* !defined GENCGC */
--- /dev/null
+/*
+ * This software is part of the SBCL system. See the README file for
+ * more information.
+ *
+ * This software is derived from the CMU CL system, which was
+ * written at Carnegie Mellon University and released into the
+ * public domain. The software is in the public domain and is
+ * provided with absolutely no warranty. See the COPYING and CREDITS
+ * files for more information.
+ */
+
+/*
+ * $Header$
+ */
+
+#ifdef __FreeBSD__
+#include <osreldate.h>
+#endif
+
+#include <sys/types.h>
+#include <sys/mman.h>
+#include <sys/signal.h>
+
+typedef caddr_t os_vm_address_t;
+typedef vm_size_t os_vm_size_t;
+typedef off_t os_vm_offset_t;
+typedef int os_vm_prot_t;
+
+#if defined __FreeBSD__
+/* Note: The man page for sigaction(2) in FreeBSD 4.0 says that this
+ * is an mcontext_t, but according to comments by Raymond Wiker in the
+ * original FreeBSD port of SBCL, that's wrong, it's actually a
+ * ucontext_t. */
+typedef ucontext_t os_context_t;
+#elif defined __OpenBSD__
+typedef struct sigcontext os_context_t;
+#else
+#error unsupported BSD variant
+#endif
+
+#define OS_VM_PROT_READ PROT_READ
+#define OS_VM_PROT_WRITE PROT_WRITE
+#define OS_VM_PROT_EXECUTE PROT_EXEC
+
+#define OS_VM_DEFAULT_PAGESIZE 4096
--- /dev/null
+/*
+ * This software is part of the SBCL system. See the README file for
+ * more information.
+ *
+ * This software is derived from the CMU CL system, which was
+ * written at Carnegie Mellon University and released into the
+ * public domain. The software is in the public domain and is
+ * provided with absolutely no warranty. See the COPYING and CREDITS
+ * files for more information.
+ */
+
+/*
+ * $Header$
+ */
+
+#ifndef _CORE_H_
+#define _CORE_H_
+
+#include "runtime.h"
+
+#define CORE_PAGESIZE OS_VM_DEFAULT_PAGESIZE
+#define CORE_END 3840
+#define CORE_NDIRECTORY 3861
+#define CORE_VALIDATE 3845
+#define CORE_VERSION 3860
+#define CORE_MACHINE_STATE 3862
+#define CORE_INITIAL_FUNCTION 3863
+
+#define DYNAMIC_SPACE_ID (1)
+#define STATIC_SPACE_ID (2)
+#define READ_ONLY_SPACE_ID (3)
+
+struct ndir_entry {
+#ifndef alpha
+ long identifier;
+ long nwords;
+ long data_page;
+ long address;
+ long page_count;
+#else
+ u32 identifier;
+ u32 nwords;
+ u32 data_page;
+ u32 address;
+ u32 page_count;
+#endif
+};
+
+extern lispobj load_core_file(char *file);
+
+#endif
--- /dev/null
+/*
+ * A saved SBCL system is a .core file; the code here helps us accept
+ * such a file as input.
+ */
+
+/*
+ * This software is part of the SBCL system. See the README file for
+ * more information.
+ *
+ * This software is derived from the CMU CL system, which was
+ * written at Carnegie Mellon University and released into the
+ * public domain. The software is in the public domain and is
+ * provided with absolutely no warranty. See the COPYING and CREDITS
+ * files for more information.
+ */
+
+/*
+ * $Header$
+ */
+
+#include <stdio.h>
+#include <sys/types.h>
+#include <sys/file.h>
+
+#ifdef irix
+#include <fcntl.h>
+#include <stdlib.h>
+#endif
+
+#include "os.h"
+#include "runtime.h"
+#include "globals.h"
+#include "core.h"
+#include "sbcl.h"
+
+static void process_directory(int fd, long *ptr, int count)
+{
+ struct ndir_entry *entry;
+
+ FSHOW((stderr, "process_directory(..), count=%d\n", count));
+
+ for (entry = (struct ndir_entry *) ptr; --count>= 0; ++entry) {
+
+ long id = entry->identifier;
+ long offset = CORE_PAGESIZE * (1 + entry->data_page);
+ os_vm_address_t addr =
+ (os_vm_address_t) (CORE_PAGESIZE * entry->address);
+ lispobj *free_pointer = (lispobj *) addr + entry->nwords;
+ long len = CORE_PAGESIZE * entry->page_count;
+
+ if (len != 0) {
+ os_vm_address_t real_addr;
+ FSHOW((stderr, "mapping %ld bytes at 0x%lx\n", len, addr));
+ real_addr = os_map(fd, offset, addr, len);
+ if (real_addr != addr) {
+ lose("file mapped in wrong place! "
+ "(0x%08x != 0x%08lx)",
+ real_addr,
+ addr);
+ }
+ }
+
+ FSHOW((stderr, "space id = %d, free pointer = 0x%08x\n",
+ id, free_pointer));
+
+ switch (id) {
+ case DYNAMIC_SPACE_ID:
+ if (addr != (os_vm_address_t)dynamic_0_space
+ && addr != (os_vm_address_t)dynamic_1_space) {
+ lose("bizarre dynamic space!");
+ }
+ current_dynamic_space = (lispobj *)addr;
+#if defined(ibmrt) || defined(__i386__)
+ SetSymbolValue(ALLOCATION_POINTER, (lispobj)free_pointer);
+#else
+ current_dynamic_space_free_pointer = free_pointer;
+#endif
+ break;
+ case STATIC_SPACE_ID:
+ static_space = (lispobj *) addr;
+ break;
+ case READ_ONLY_SPACE_ID:
+ /* We don't care about read-only space. */
+ break;
+ default:
+ lose("unknown space ID %ld", id);
+ }
+ }
+}
+
+lispobj load_core_file(char *file)
+{
+ int fd = open(file, O_RDONLY), count;
+
+ /* KLUDGE: This kind of conditionalization everywhere that 32-bit
+ * ints are used is really nasty. It would be much nicer to define
+ * a typedef a la addr_as_int once and for all in each
+ * architecture file, then use that everywhere. -- WHN 19990904 */
+#ifndef alpha
+ long header[CORE_PAGESIZE / sizeof(long)], val, len, *ptr;
+ long remaining_len;
+#else
+ u32 header[CORE_PAGESIZE / sizeof(u32)], val, len, *ptr;
+ u32 remaining_len;
+#endif
+
+ lispobj initial_function = NIL;
+
+ if (fd < 0) {
+ fprintf(stderr, "could not open file \"%s\"\n", file);
+ perror("open");
+ exit(1);
+ }
+
+ count = read(fd, header, CORE_PAGESIZE);
+ if (count < CORE_PAGESIZE) {
+ lose("premature end of core file");
+ }
+
+ ptr = header;
+ val = *ptr++;
+
+ if (val != CORE_MAGIC) {
+ lose("invalid magic number in core: 0x%lx should have been 0x%x.",
+ val,
+ CORE_MAGIC);
+ }
+
+ while (val != CORE_END) {
+ val = *ptr++;
+ len = *ptr++;
+ remaining_len = len - 2; /* (-2 to cancel the two ++ operations) */
+
+ switch (val) {
+
+ case CORE_END:
+ break;
+
+ case CORE_VERSION:
+ if (*ptr != SBCL_CORE_VERSION_INTEGER) {
+ lose("core file version (%d) != runtime library version (%d)",
+ *ptr,
+ SBCL_CORE_VERSION_INTEGER);
+ }
+ break;
+
+ case CORE_NDIRECTORY:
+ process_directory(fd,
+ ptr,
+#ifndef alpha
+ remaining_len / (sizeof(struct ndir_entry) /
+ sizeof(long))
+#else
+ remaining_len / (sizeof(struct ndir_entry) /
+ sizeof(u32))
+#endif
+ );
+ break;
+
+ case CORE_INITIAL_FUNCTION:
+ initial_function = (lispobj)*ptr;
+ break;
+
+ default:
+ lose("unknown core file entry: %ld", val);
+ }
+
+ ptr += remaining_len;
+ }
+
+ return initial_function;
+}
--- /dev/null
+/*
+ * support for dynamic binding from C
+ */
+
+/*
+ * This software is part of the SBCL system. See the README file for
+ * more information.
+ *
+ * This software is derived from the CMU CL system, which was
+ * written at Carnegie Mellon University and released into the
+ * public domain. The software is in the public domain and is
+ * provided with absolutely no warranty. See the COPYING and CREDITS
+ * files for more information.
+ */
+
+/*
+ * $Header$
+ */
+
+#include "runtime.h"
+#include "sbcl.h"
+#include "globals.h"
+#include "dynbind.h"
+
+#if defined(ibmrt) || defined(__i386__)
+#define GetBSP() ((struct binding *)SymbolValue(BINDING_STACK_POINTER))
+#define SetBSP(value) SetSymbolValue(BINDING_STACK_POINTER, (lispobj)(value))
+#else
+#define GetBSP() ((struct binding *)current_binding_stack_pointer)
+#define SetBSP(value) (current_binding_stack_pointer=(lispobj *)(value))
+#endif
+
+void bind_variable(lispobj symbol, lispobj value)
+{
+ lispobj old_value;
+ struct binding *binding;
+
+ old_value = SymbolValue(symbol);
+ binding = GetBSP();
+ SetBSP(binding+1);
+
+ binding->value = old_value;
+ binding->symbol = symbol;
+ SetSymbolValue(symbol, value);
+}
+
+void unbind(void)
+{
+ struct binding *binding;
+ lispobj symbol;
+
+ binding = GetBSP() - 1;
+
+ symbol = binding->symbol;
+
+ SetSymbolValue(symbol, binding->value);
+
+ binding->symbol = 0;
+
+ SetBSP(binding);
+}
+
+void unbind_to_here(lispobj *bsp)
+{
+ struct binding *target = (struct binding *)bsp;
+ struct binding *binding = GetBSP();
+ lispobj symbol;
+
+ while (target < binding) {
+ binding--;
+
+ symbol = binding->symbol;
+
+ if (symbol) {
+ SetSymbolValue(symbol, binding->value);
+ binding->symbol = 0;
+ }
+
+ }
+ SetBSP(binding);
+}
--- /dev/null
+/*
+ * This software is part of the SBCL system. See the README file for
+ * more information.
+ *
+ * This software is derived from the CMU CL system, which was
+ * written at Carnegie Mellon University and released into the
+ * public domain. The software is in the public domain and is
+ * provided with absolutely no warranty. See the COPYING and CREDITS
+ * files for more information.
+ */
+
+/*
+ * $Header$
+ */
+
+#ifndef _DYNBIND_H_
+#define _DYNBIND_H_
+
+extern void bind_variable(lispobj symbol, lispobj value);
+extern void unbind(void);
+extern void unbind_to_here(lispobj *bsp);
+
+#endif
--- /dev/null
+/*
+ * garbage collection
+ */
+
+/*
+ * This software is part of the SBCL system. See the README file for
+ * more information.
+ *
+ * This software is derived from the CMU CL system, which was
+ * written at Carnegie Mellon University and released into the
+ * public domain. The software is in the public domain and is
+ * provided with absolutely no warranty. See the COPYING and CREDITS
+ * files for more information.
+ */
+
+/*
+ * $Header$
+ */
+
+#ifndef _GC_H_
+#define _GC_H_
+
+extern void gc_init(void);
+
+/* Note: CMU CL had two different argument conventions for
+ * collect_garbage(..), depending on whether gencgc was in use. SBCL
+ * should have only one, which is automatic right now (20000814) since
+ * we only support gencgc, but should also be maintained if someone
+ * adds another GC, or ports one of the other CMU CL GCs like gengc. */
+extern void collect_garbage(unsigned last_gen);
+
+#ifndef ibmrt
+
+#include "os.h"
+
+extern void set_auto_gc_trigger(os_vm_size_t usage);
+extern void clear_auto_gc_trigger(void);
+
+#endif ibmrt
+
+#endif _GC_H_
--- /dev/null
+/*
+ * GENerational Conservative Garbage Collector for SBCL x86
+ */
+
+/*
+ * This software is part of the SBCL system. See the README file for
+ * more information.
+ *
+ * This software is derived from the CMU CL system, which was
+ * written at Carnegie Mellon University and released into the
+ * public domain. The software is in the public domain and is
+ * provided with absolutely no warranty. See the COPYING and CREDITS
+ * files for more information.
+ */
+
+/*
+ * $Header$
+ */
+
+/*
+ * For a review of garbage collection techniques (e.g. generational
+ * GC) and terminology (e.g. "scavenging") see Paul R. Wilson,
+ * "Uniprocessor Garbage Collection Techniques". As of 20000618, this
+ * had been accepted for _ACM Computing Surveys_ and was available
+ * as a PostScript preprint through
+ * <http://www.cs.utexas.edu/users/oops/papers.html>
+ * as
+ * <ftp://ftp.cs.utexas.edu/pub/garbage/bigsurv.ps>.
+ */
+
+/*
+ * FIXME: GC :FULL T seems to be unable to recover a lot of unused
+ * space. After cold init is complete, GC :FULL T gets us down to
+ * about 44 Mb total used, but PURIFY gets us down to about 17 Mb
+ * total used.
+ */
+
+#include <stdio.h>
+#include <signal.h>
+#include "runtime.h"
+#include "sbcl.h"
+#include "os.h"
+#include "globals.h"
+#include "interrupt.h"
+#include "validate.h"
+#include "lispregs.h"
+#include "gc.h"
+#include "gencgc.h"
+
+/* a function defined externally in assembly language, called from
+ * this file */
+void do_pending_interrupt(void);
+\f
+/*
+ * GC parameters
+ */
+
+/* the number of actual generations. (The number of 'struct
+ * generation' objects is one more than this, because one serves as
+ * scratch when GC'ing.) */
+#define NUM_GENERATIONS 6
+
+/* Should we use page protection to help avoid the scavenging of pages
+ * that don't have pointers to younger generations? */
+boolean enable_page_protection = 1;
+
+/* Should we unmap a page and re-mmap it to have it zero filled? */
+#if defined(__FreeBSD__) || defined(__OpenBSD__)
+/* Note: this can waste a lot of swap on FreeBSD so don't unmap there.
+ *
+ * Presumably this behavior exists on OpenBSD too, so don't unmap
+ * there either. -- WHN 20000727 */
+boolean gencgc_unmap_zero = 0;
+#else
+boolean gencgc_unmap_zero = 1;
+#endif
+
+/* the minimum size (in bytes) for a large object*/
+unsigned large_object_size = 4 * 4096;
+
+/* Should we filter stack/register pointers? This could reduce the
+ * number of invalid pointers accepted. KLUDGE: It will probably
+ * degrades interrupt safety during object initialization. */
+boolean enable_pointer_filter = 1;
+\f
+/*
+ * debugging
+ */
+
+#define gc_abort() lose("GC invariant lost, file \"%s\", line %d", \
+ __FILE__, __LINE__)
+
+/* FIXME: In CMU CL, this was "#if 0" with no explanation. Find out
+ * how much it costs to make it "#if 1". If it's not too expensive,
+ * keep it. */
+#if 1
+#define gc_assert(ex) do { \
+ if (!(ex)) gc_abort(); \
+} while (0)
+#else
+#define gc_assert(ex)
+#endif
+
+/* the verbosity level. All non-error messages are disabled at level 0;
+ * and only a few rare messages are printed at level 1. */
+unsigned gencgc_verbose = (QSHOW ? 1 : 0);
+
+/* FIXME: At some point enable the various error-checking things below
+ * and see what they say. */
+
+/* We hunt for pointers to old-space, when GCing generations >= verify_gen.
+ * Set verify_gens to NUM_GENERATIONS to disable this kind of check. */
+int verify_gens = NUM_GENERATIONS;
+
+/* Should we do a pre-scan verify of generation 0 before it's GCed? */
+boolean pre_verify_gen_0 = 0;
+
+/* Should we check for bad pointers after gc_free_heap is called
+ * from Lisp PURIFY? */
+boolean verify_after_free_heap = 0;
+
+/* Should we print a note when code objects are found in the dynamic space
+ * during a heap verify? */
+boolean verify_dynamic_code_check = 0;
+
+/* Should we check code objects for fixup errors after they are transported? */
+boolean check_code_fixups = 0;
+
+/* Should we check that newly allocated regions are zero filled? */
+boolean gencgc_zero_check = 0;
+
+/* Should we check that the free space is zero filled? */
+boolean gencgc_enable_verify_zero_fill = 0;
+
+/* Should we check that free pages are zero filled during gc_free_heap
+ * called after Lisp PURIFY? */
+boolean gencgc_zero_check_during_free_heap = 0;
+\f
+/*
+ * GC structures and variables
+ */
+
+/* the total bytes allocated. These are seen by Lisp DYNAMIC-USAGE. */
+unsigned long bytes_allocated = 0;
+static unsigned long auto_gc_trigger = 0;
+
+/* the source and destination generations. These are set before a GC starts
+ * scavenging. */
+static int from_space;
+static int new_space;
+
+/* FIXME: It would be nice to use this symbolic constant instead of
+ * bare 4096 almost everywhere. We could also use an assertion that
+ * it's equal to getpagesize(). */
+#define PAGE_BYTES 4096
+
+/* An array of page structures is statically allocated.
+ * This helps quickly map between an address its page structure.
+ * NUM_PAGES is set from the size of the dynamic space. */
+struct page page_table[NUM_PAGES];
+
+/* To map addresses to page structures the address of the first page
+ * is needed. */
+static void *heap_base = NULL;
+
+/* Calculate the start address for the given page number. */
+inline void
+*page_address(int page_num)
+{
+ return (heap_base + (page_num * 4096));
+}
+
+/* Find the page index within the page_table for the given
+ * address. Return -1 on failure. */
+inline int
+find_page_index(void *addr)
+{
+ int index = addr-heap_base;
+
+ if (index >= 0) {
+ index = ((unsigned int)index)/4096;
+ if (index < NUM_PAGES)
+ return (index);
+ }
+
+ return (-1);
+}
+
+/* a structure to hold the state of a generation */
+struct generation {
+
+ /* the first page that gc_alloc checks on its next call */
+ int alloc_start_page;
+
+ /* the first page that gc_alloc_unboxed checks on its next call */
+ int alloc_unboxed_start_page;
+
+ /* the first page that gc_alloc_large (boxed) considers on its next
+ * call. (Although it always allocates after the boxed_region.) */
+ int alloc_large_start_page;
+
+ /* the first page that gc_alloc_large (unboxed) considers on its
+ * next call. (Although it always allocates after the
+ * current_unboxed_region.) */
+ int alloc_large_unboxed_start_page;
+
+ /* the bytes allocated to this generation */
+ int bytes_allocated;
+
+ /* the number of bytes at which to trigger a GC */
+ int gc_trigger;
+
+ /* to calculate a new level for gc_trigger */
+ int bytes_consed_between_gc;
+
+ /* the number of GCs since the last raise */
+ int num_gc;
+
+ /* the average age after which a GC will raise objects to the
+ * next generation */
+ int trigger_age;
+
+ /* the cumulative sum of the bytes allocated to this generation. It is
+ * cleared after a GC on this generations, and update before new
+ * objects are added from a GC of a younger generation. Dividing by
+ * the bytes_allocated will give the average age of the memory in
+ * this generation since its last GC. */
+ int cum_sum_bytes_allocated;
+
+ /* a minimum average memory age before a GC will occur helps
+ * prevent a GC when a large number of new live objects have been
+ * added, in which case a GC could be a waste of time */
+ double min_av_mem_age;
+};
+
+/* an array of generation structures. There needs to be one more
+ * generation structure than actual generations as the oldest
+ * generation is temporarily raised then lowered. */
+static struct generation generations[NUM_GENERATIONS+1];
+
+/* the oldest generation that is will currently be GCed by default.
+ * Valid values are: 0, 1, ... (NUM_GENERATIONS-1)
+ *
+ * The default of (NUM_GENERATIONS-1) enables GC on all generations.
+ *
+ * Setting this to 0 effectively disables the generational nature of
+ * the GC. In some applications generational GC may not be useful
+ * because there are no long-lived objects.
+ *
+ * An intermediate value could be handy after moving long-lived data
+ * into an older generation so an unnecessary GC of this long-lived
+ * data can be avoided. */
+unsigned int gencgc_oldest_gen_to_gc = NUM_GENERATIONS-1;
+
+/* The maximum free page in the heap is maintained and used to update
+ * ALLOCATION_POINTER which is used by the room function to limit its
+ * search of the heap. XX Gencgc obviously needs to be better
+ * integrated with the Lisp code. */
+static int last_free_page;
+static int last_used_page = 0;
+\f
+/*
+ * miscellaneous heap functions
+ */
+
+/* Count the number of pages which are write-protected within the
+ * given generation. */
+static int
+count_write_protect_generation_pages(int generation)
+{
+ int i;
+ int cnt = 0;
+
+ for (i = 0; i < last_free_page; i++)
+ if ((page_table[i].allocated != FREE_PAGE)
+ && (page_table[i].gen == generation)
+ && (page_table[i].write_protected == 1))
+ cnt++;
+ return(cnt);
+}
+
+/* Count the number of pages within the given generation */
+static int
+count_generation_pages(int generation)
+{
+ int i;
+ int cnt = 0;
+
+ for (i = 0; i < last_free_page; i++)
+ if ((page_table[i].allocated != 0)
+ && (page_table[i].gen == generation))
+ cnt++;
+ return(cnt);
+}
+
+/* Count the number of dont_move pages. */
+static int
+count_dont_move_pages(void)
+{
+ int i;
+ int cnt = 0;
+
+ for (i = 0; i < last_free_page; i++)
+ if ((page_table[i].allocated != 0)
+ && (page_table[i].dont_move != 0))
+ cnt++;
+ return(cnt);
+}
+
+/* Work through the pages and add up the number of bytes used for the
+ * given generation. */
+static int
+generation_bytes_allocated (int gen)
+{
+ int i;
+ int result = 0;
+
+ for (i = 0; i < last_free_page; i++) {
+ if ((page_table[i].allocated != 0) && (page_table[i].gen == gen))
+ result += page_table[i].bytes_used;
+ }
+ return result;
+}
+
+/* Return the average age of the memory in a generation. */
+static double
+gen_av_mem_age(int gen)
+{
+ if (generations[gen].bytes_allocated == 0)
+ return 0.0;
+
+ return
+ ((double)generations[gen].cum_sum_bytes_allocated)
+ / ((double)generations[gen].bytes_allocated);
+}
+
+/* The verbose argument controls how much to print: 0 for normal
+ * level of detail; 1 for debugging. */
+static void
+print_generation_stats(int verbose) /* FIXME: should take FILE argument */
+{
+ int i, gens;
+ int fpu_state[27];
+
+ /* This code uses the FP instructions which may be set up for Lisp
+ * so they need to be saved and reset for C. */
+ fpu_save(fpu_state);
+
+ /* number of generations to print */
+ if (verbose)
+ gens = NUM_GENERATIONS+1;
+ else
+ gens = NUM_GENERATIONS;
+
+ /* Print the heap stats. */
+ fprintf(stderr,
+ " Generation Boxed Unboxed LB LUB Alloc Waste Trig WP GCs Mem-age\n");
+
+ for (i = 0; i < gens; i++) {
+ int j;
+ int boxed_cnt = 0;
+ int unboxed_cnt = 0;
+ int large_boxed_cnt = 0;
+ int large_unboxed_cnt = 0;
+
+ for (j = 0; j < last_free_page; j++)
+ if (page_table[j].gen == i) {
+ /* Count the number of boxed pages within the given
+ * generation */
+ if (page_table[j].allocated == BOXED_PAGE)
+ if (page_table[j].large_object)
+ large_boxed_cnt++;
+ else
+ boxed_cnt++;
+
+ /* Count the number of unboxed pages within the given
+ * generation */
+ if (page_table[j].allocated == UNBOXED_PAGE)
+ if (page_table[j].large_object)
+ large_unboxed_cnt++;
+ else
+ unboxed_cnt++;
+ }
+
+ gc_assert(generations[i].bytes_allocated
+ == generation_bytes_allocated(i));
+ fprintf(stderr,
+ " %8d: %5d %5d %5d %5d %8d %5d %8d %4d %3d %7.4lf\n",
+ i,
+ boxed_cnt, unboxed_cnt, large_boxed_cnt, large_unboxed_cnt,
+ generations[i].bytes_allocated,
+ (count_generation_pages(i)*4096
+ - generations[i].bytes_allocated),
+ generations[i].gc_trigger,
+ count_write_protect_generation_pages(i),
+ generations[i].num_gc,
+ gen_av_mem_age(i));
+ }
+ fprintf(stderr," Total bytes allocated=%d\n", bytes_allocated);
+
+ fpu_restore(fpu_state);
+}
+\f
+/*
+ * allocation routines
+ */
+
+/*
+ * To support quick and inline allocation, regions of memory can be
+ * allocated and then allocated from with just a free pointer and a
+ * check against an end address.
+ *
+ * Since objects can be allocated to spaces with different properties
+ * e.g. boxed/unboxed, generation, ages; there may need to be many
+ * allocation regions.
+ *
+ * Each allocation region may be start within a partly used page. Many
+ * features of memory use are noted on a page wise basis, e.g. the
+ * generation; so if a region starts within an existing allocated page
+ * it must be consistent with this page.
+ *
+ * During the scavenging of the newspace, objects will be transported
+ * into an allocation region, and pointers updated to point to this
+ * allocation region. It is possible that these pointers will be
+ * scavenged again before the allocation region is closed, e.g. due to
+ * trans_list which jumps all over the place to cleanup the list. It
+ * is important to be able to determine properties of all objects
+ * pointed to when scavenging, e.g to detect pointers to the oldspace.
+ * Thus it's important that the allocation regions have the correct
+ * properties set when allocated, and not just set when closed. The
+ * region allocation routines return regions with the specified
+ * properties, and grab all the pages, setting their properties
+ * appropriately, except that the amount used is not known.
+ *
+ * These regions are used to support quicker allocation using just a
+ * free pointer. The actual space used by the region is not reflected
+ * in the pages tables until it is closed. It can't be scavenged until
+ * closed.
+ *
+ * When finished with the region it should be closed, which will
+ * update the page tables for the actual space used returning unused
+ * space. Further it may be noted in the new regions which is
+ * necessary when scavenging the newspace.
+ *
+ * Large objects may be allocated directly without an allocation
+ * region, the page tables are updated immediately.
+ *
+ * Unboxed objects don't contain pointers to other objects and so
+ * don't need scavenging. Further they can't contain pointers to
+ * younger generations so WP is not needed. By allocating pages to
+ * unboxed objects the whole page never needs scavenging or
+ * write-protecting. */
+
+/* We are only using two regions at present. Both are for the current
+ * newspace generation. */
+struct alloc_region boxed_region;
+struct alloc_region unboxed_region;
+
+/* XX hack. Current Lisp code uses the following. Need copying in/out. */
+void *current_region_free_pointer;
+void *current_region_end_addr;
+
+/* The generation currently being allocated to. */
+static int gc_alloc_generation;
+
+/* Find a new region with room for at least the given number of bytes.
+ *
+ * It starts looking at the current generation's alloc_start_page. So
+ * may pick up from the previous region if there is enough space. This
+ * keeps the allocation contiguous when scavenging the newspace.
+ *
+ * The alloc_region should have been closed by a call to
+ * gc_alloc_update_page_tables, and will thus be in an empty state.
+ *
+ * To assist the scavenging functions write-protected pages are not
+ * used. Free pages should not be write-protected.
+ *
+ * It is critical to the conservative GC that the start of regions be
+ * known. To help achieve this only small regions are allocated at a
+ * time.
+ *
+ * During scavenging, pointers may be found to within the current
+ * region and the page generation must be set so that pointers to the
+ * from space can be recognized. Therefore the generation of pages in
+ * the region are set to gc_alloc_generation. To prevent another
+ * allocation call using the same pages, all the pages in the region
+ * are allocated, although they will initially be empty.
+ */
+static void
+gc_alloc_new_region(int nbytes, int unboxed, struct alloc_region *alloc_region)
+{
+ int first_page;
+ int last_page;
+ int region_size;
+ int restart_page;
+ int bytes_found;
+ int num_pages;
+ int i;
+
+ /*
+ FSHOW((stderr,
+ "/alloc_new_region for %d bytes from gen %d\n",
+ nbytes, gc_alloc_generation));
+ */
+
+ /* Check that the region is in a reset state. */
+ gc_assert((alloc_region->first_page == 0)
+ && (alloc_region->last_page == -1)
+ && (alloc_region->free_pointer == alloc_region->end_addr));
+
+ if (unboxed) {
+ restart_page =
+ generations[gc_alloc_generation].alloc_unboxed_start_page;
+ } else {
+ restart_page =
+ generations[gc_alloc_generation].alloc_start_page;
+ }
+
+ /* Search for a contiguous free region of at least nbytes with the
+ * given properties: boxed/unboxed, generation. */
+ do {
+ first_page = restart_page;
+
+ /* First search for a page with at least 32 bytes free, which is
+ * not write-protected, and which is not marked dont_move. */
+ while ((first_page < NUM_PAGES)
+ && (page_table[first_page].allocated != FREE_PAGE) /* not free page */
+ && ((unboxed &&
+ (page_table[first_page].allocated != UNBOXED_PAGE))
+ || (!unboxed &&
+ (page_table[first_page].allocated != BOXED_PAGE))
+ || (page_table[first_page].large_object != 0)
+ || (page_table[first_page].gen != gc_alloc_generation)
+ || (page_table[first_page].bytes_used >= (4096-32))
+ || (page_table[first_page].write_protected != 0)
+ || (page_table[first_page].dont_move != 0)))
+ first_page++;
+ /* Check for a failure. */
+ if (first_page >= NUM_PAGES) {
+ fprintf(stderr,
+ "Argh! gc_alloc_new_region failed on first_page, nbytes=%d.\n",
+ nbytes);
+ print_generation_stats(1);
+ lose(NULL);
+ }
+
+ gc_assert(page_table[first_page].write_protected == 0);
+
+ /*
+ FSHOW((stderr,
+ "/first_page=%d bytes_used=%d\n",
+ first_page, page_table[first_page].bytes_used));
+ */
+
+ /* Now search forward to calculate the available region size. It
+ * tries to keeps going until nbytes are found and the number of
+ * pages is greater than some level. This helps keep down the
+ * number of pages in a region. */
+ last_page = first_page;
+ bytes_found = 4096 - page_table[first_page].bytes_used;
+ num_pages = 1;
+ while (((bytes_found < nbytes) || (num_pages < 2))
+ && (last_page < (NUM_PAGES-1))
+ && (page_table[last_page+1].allocated == FREE_PAGE)) {
+ last_page++;
+ num_pages++;
+ bytes_found += 4096;
+ gc_assert(page_table[last_page].write_protected == 0);
+ }
+
+ region_size = (4096 - page_table[first_page].bytes_used)
+ + 4096*(last_page-first_page);
+
+ gc_assert(bytes_found == region_size);
+
+ /*
+ FSHOW((stderr,
+ "/last_page=%d bytes_found=%d num_pages=%d\n",
+ last_page, bytes_found, num_pages));
+ */
+
+ restart_page = last_page + 1;
+ } while ((restart_page < NUM_PAGES) && (bytes_found < nbytes));
+
+ /* Check for a failure. */
+ if ((restart_page >= NUM_PAGES) && (bytes_found < nbytes)) {
+ fprintf(stderr,
+ "Argh! gc_alloc_new_region failed on restart_page, nbytes=%d.\n",
+ nbytes);
+ print_generation_stats(1);
+ lose(NULL);
+ }
+
+ /*
+ FSHOW((stderr,
+ "/gc_alloc_new_region gen %d: %d bytes: pages %d to %d: addr=%x\n",
+ gc_alloc_generation,
+ bytes_found,
+ first_page,
+ last_page,
+ page_address(first_page)));
+ */
+
+ /* Set up the alloc_region. */
+ alloc_region->first_page = first_page;
+ alloc_region->last_page = last_page;
+ alloc_region->start_addr = page_table[first_page].bytes_used
+ + page_address(first_page);
+ alloc_region->free_pointer = alloc_region->start_addr;
+ alloc_region->end_addr = alloc_region->start_addr + bytes_found;
+
+ if (gencgc_zero_check) {
+ int *p;
+ for (p = (int *)alloc_region->start_addr;
+ p < (int *)alloc_region->end_addr; p++) {
+ if (*p != 0) {
+ /* KLUDGE: It would be nice to use %lx and explicit casts
+ * (long) in code like this, so that it is less likely to
+ * break randomly when running on a machine with different
+ * word sizes. -- WHN 19991129 */
+ lose("The new region at %x is not zero.", p);
+ }
+ }
+ }
+
+ /* Set up the pages. */
+
+ /* The first page may have already been in use. */
+ if (page_table[first_page].bytes_used == 0) {
+ if (unboxed)
+ page_table[first_page].allocated = UNBOXED_PAGE;
+ else
+ page_table[first_page].allocated = BOXED_PAGE;
+ page_table[first_page].gen = gc_alloc_generation;
+ page_table[first_page].large_object = 0;
+ page_table[first_page].first_object_offset = 0;
+ }
+
+ if (unboxed)
+ gc_assert(page_table[first_page].allocated == UNBOXED_PAGE);
+ else
+ gc_assert(page_table[first_page].allocated == BOXED_PAGE);
+ gc_assert(page_table[first_page].gen == gc_alloc_generation);
+ gc_assert(page_table[first_page].large_object == 0);
+
+ for (i = first_page+1; i <= last_page; i++) {
+ if (unboxed)
+ page_table[i].allocated = UNBOXED_PAGE;
+ else
+ page_table[i].allocated = BOXED_PAGE;
+ page_table[i].gen = gc_alloc_generation;
+ page_table[i].large_object = 0;
+ /* This may not be necessary for unboxed regions (think it was
+ * broken before!) */
+ page_table[i].first_object_offset =
+ alloc_region->start_addr - page_address(i);
+ }
+
+ /* Bump up last_free_page. */
+ if (last_page+1 > last_free_page) {
+ last_free_page = last_page+1;
+ SetSymbolValue(ALLOCATION_POINTER,
+ (lispobj)(((char *)heap_base) + last_free_page*4096));
+ if (last_page+1 > last_used_page)
+ last_used_page = last_page+1;
+ }
+}
+
+/* If the record_new_objects flag is 2 then all new regions created
+ * are recorded.
+ *
+ * If it's 1 then then it is only recorded if the first page of the
+ * current region is <= new_areas_ignore_page. This helps avoid
+ * unnecessary recording when doing full scavenge pass.
+ *
+ * The new_object structure holds the page, byte offset, and size of
+ * new regions of objects. Each new area is placed in the array of
+ * these structures pointer to by new_areas. new_areas_index holds the
+ * offset into new_areas.
+ *
+ * If new_area overflows NUM_NEW_AREAS then it stops adding them. The
+ * later code must detect this and handle it, probably by doing a full
+ * scavenge of a generation. */
+#define NUM_NEW_AREAS 512
+static int record_new_objects = 0;
+static int new_areas_ignore_page;
+struct new_area {
+ int page;
+ int offset;
+ int size;
+};
+static struct new_area (*new_areas)[];
+static new_areas_index;
+int max_new_areas;
+
+/* Add a new area to new_areas. */
+static void
+add_new_area(int first_page, int offset, int size)
+{
+ unsigned new_area_start,c;
+ int i;
+
+ /* Ignore if full. */
+ if (new_areas_index >= NUM_NEW_AREAS)
+ return;
+
+ switch (record_new_objects) {
+ case 0:
+ return;
+ case 1:
+ if (first_page > new_areas_ignore_page)
+ return;
+ break;
+ case 2:
+ break;
+ default:
+ gc_abort();
+ }
+
+ new_area_start = 4096*first_page + offset;
+
+ /* Search backwards for a prior area that this follows from. If
+ found this will save adding a new area. */
+ for (i = new_areas_index-1, c = 0; (i >= 0) && (c < 8); i--, c++) {
+ unsigned area_end =
+ 4096*((*new_areas)[i].page)
+ + (*new_areas)[i].offset
+ + (*new_areas)[i].size;
+ /*FSHOW((stderr,
+ "/add_new_area S1 %d %d %d %d\n",
+ i, c, new_area_start, area_end));*/
+ if (new_area_start == area_end) {
+ /*FSHOW((stderr,
+ "/adding to [%d] %d %d %d with %d %d %d:\n",
+ i,
+ (*new_areas)[i].page,
+ (*new_areas)[i].offset,
+ (*new_areas)[i].size,
+ first_page,
+ offset,
+ size));*/
+ (*new_areas)[i].size += size;
+ return;
+ }
+ }
+ /*FSHOW((stderr, "/add_new_area S1 %d %d %d\n", i, c, new_area_start));*/
+
+ (*new_areas)[new_areas_index].page = first_page;
+ (*new_areas)[new_areas_index].offset = offset;
+ (*new_areas)[new_areas_index].size = size;
+ /*FSHOW((stderr,
+ "/new_area %d page %d offset %d size %d\n",
+ new_areas_index, first_page, offset, size));*/
+ new_areas_index++;
+
+ /* Note the max new_areas used. */
+ if (new_areas_index > max_new_areas)
+ max_new_areas = new_areas_index;
+}
+
+/* Update the tables for the alloc_region. The region maybe added to
+ * the new_areas.
+ *
+ * When done the alloc_region is set up so that the next quick alloc
+ * will fail safely and thus a new region will be allocated. Further
+ * it is safe to try to re-update the page table of this reset
+ * alloc_region. */
+void
+gc_alloc_update_page_tables(int unboxed, struct alloc_region *alloc_region)
+{
+ int more;
+ int first_page;
+ int next_page;
+ int bytes_used;
+ int orig_first_page_bytes_used;
+ int region_size;
+ int byte_cnt;
+
+ /*
+ FSHOW((stderr,
+ "/gc_alloc_update_page_tables to gen %d:\n",
+ gc_alloc_generation));
+ */
+
+ first_page = alloc_region->first_page;
+
+ /* Catch an unused alloc_region. */
+ if ((first_page == 0) && (alloc_region->last_page == -1))
+ return;
+
+ next_page = first_page+1;
+
+ /* Skip if no bytes were allocated */
+ if (alloc_region->free_pointer != alloc_region->start_addr) {
+ orig_first_page_bytes_used = page_table[first_page].bytes_used;
+
+ gc_assert(alloc_region->start_addr == (page_address(first_page) + page_table[first_page].bytes_used));
+
+ /* All the pages used need to be updated */
+
+ /* Update the first page. */
+
+ /* If the page was free then set up the gen, and
+ first_object_offset. */
+ if (page_table[first_page].bytes_used == 0)
+ gc_assert(page_table[first_page].first_object_offset == 0);
+
+ if (unboxed)
+ gc_assert(page_table[first_page].allocated == UNBOXED_PAGE);
+ else
+ gc_assert(page_table[first_page].allocated == BOXED_PAGE);
+ gc_assert(page_table[first_page].gen == gc_alloc_generation);
+ gc_assert(page_table[first_page].large_object == 0);
+
+ byte_cnt = 0;
+
+ /* Calc. the number of bytes used in this page. This is not always
+ the number of new bytes, unless it was free. */
+ more = 0;
+ if ((bytes_used = (alloc_region->free_pointer - page_address(first_page)))>4096) {
+ bytes_used = 4096;
+ more = 1;
+ }
+ page_table[first_page].bytes_used = bytes_used;
+ byte_cnt += bytes_used;
+
+
+ /* All the rest of the pages should be free. Need to set their
+ first_object_offset pointer to the start of the region, and set
+ the bytes_used. */
+ while (more) {
+ if (unboxed)
+ gc_assert(page_table[next_page].allocated == UNBOXED_PAGE);
+ else
+ gc_assert(page_table[next_page].allocated == BOXED_PAGE);
+ gc_assert(page_table[next_page].bytes_used == 0);
+ gc_assert(page_table[next_page].gen == gc_alloc_generation);
+ gc_assert(page_table[next_page].large_object == 0);
+
+ gc_assert(page_table[next_page].first_object_offset ==
+ alloc_region->start_addr - page_address(next_page));
+
+ /* Calculate the number of bytes used in this page. */
+ more = 0;
+ if ((bytes_used = (alloc_region->free_pointer
+ - page_address(next_page)))>4096) {
+ bytes_used = 4096;
+ more = 1;
+ }
+ page_table[next_page].bytes_used = bytes_used;
+ byte_cnt += bytes_used;
+
+ next_page++;
+ }
+
+ region_size = alloc_region->free_pointer - alloc_region->start_addr;
+ bytes_allocated += region_size;
+ generations[gc_alloc_generation].bytes_allocated += region_size;
+
+ gc_assert((byte_cnt- orig_first_page_bytes_used) == region_size);
+
+ /* Set the generations alloc restart page to the last page of
+ the region. */
+ if (unboxed)
+ generations[gc_alloc_generation].alloc_unboxed_start_page =
+ next_page-1;
+ else
+ generations[gc_alloc_generation].alloc_start_page = next_page-1;
+
+ /* Add the region to the new_areas if requested. */
+ if (!unboxed)
+ add_new_area(first_page,orig_first_page_bytes_used, region_size);
+
+ /*
+ FSHOW((stderr,
+ "/gc_alloc_update_page_tables update %d bytes to gen %d\n",
+ region_size,
+ gc_alloc_generation));
+ */
+ }
+ else
+ /* No bytes allocated. Unallocate the first_page if there are 0
+ bytes_used. */
+ if (page_table[first_page].bytes_used == 0)
+ page_table[first_page].allocated = FREE_PAGE;
+
+ /* Unallocate any unused pages. */
+ while (next_page <= alloc_region->last_page) {
+ gc_assert(page_table[next_page].bytes_used == 0);
+ page_table[next_page].allocated = FREE_PAGE;
+ next_page++;
+ }
+
+ /* Reset the alloc_region. */
+ alloc_region->first_page = 0;
+ alloc_region->last_page = -1;
+ alloc_region->start_addr = page_address(0);
+ alloc_region->free_pointer = page_address(0);
+ alloc_region->end_addr = page_address(0);
+}
+
+static inline void *gc_quick_alloc(int nbytes);
+
+/* Allocate a possibly large object. */
+static void
+*gc_alloc_large(int nbytes, int unboxed, struct alloc_region *alloc_region)
+{
+ int first_page;
+ int last_page;
+ int region_size;
+ int restart_page;
+ int bytes_found;
+ int num_pages;
+ int orig_first_page_bytes_used;
+ int byte_cnt;
+ int more;
+ int bytes_used;
+ int next_page;
+ int large = (nbytes >= large_object_size);
+
+ /*
+ if (nbytes > 200000)
+ FSHOW((stderr, "/alloc_large %d\n", nbytes));
+ */
+
+ /*
+ FSHOW((stderr,
+ "/gc_alloc_large for %d bytes from gen %d\n",
+ nbytes, gc_alloc_generation));
+ */
+
+ /* If the object is small, and there is room in the current region
+ then allocation it in the current region. */
+ if (!large
+ && ((alloc_region->end_addr-alloc_region->free_pointer) >= nbytes))
+ return gc_quick_alloc(nbytes);
+
+ /* Search for a contiguous free region of at least nbytes. If it's a
+ large object then align it on a page boundary by searching for a
+ free page. */
+
+ /* To allow the allocation of small objects without the danger of
+ using a page in the current boxed region, the search starts after
+ the current boxed free region. XX could probably keep a page
+ index ahead of the current region and bumped up here to save a
+ lot of re-scanning. */
+ if (unboxed)
+ restart_page = generations[gc_alloc_generation].alloc_large_unboxed_start_page;
+ else
+ restart_page = generations[gc_alloc_generation].alloc_large_start_page;
+ if (restart_page <= alloc_region->last_page)
+ restart_page = alloc_region->last_page+1;
+
+ do {
+ first_page = restart_page;
+
+ if (large)
+ while ((first_page < NUM_PAGES)
+ && (page_table[first_page].allocated != FREE_PAGE))
+ first_page++;
+ else
+ while ((first_page < NUM_PAGES)
+ && (page_table[first_page].allocated != FREE_PAGE)
+ && ((unboxed &&
+ (page_table[first_page].allocated != UNBOXED_PAGE))
+ || (!unboxed &&
+ (page_table[first_page].allocated != BOXED_PAGE))
+ || (page_table[first_page].large_object != 0)
+ || (page_table[first_page].gen != gc_alloc_generation)
+ || (page_table[first_page].bytes_used >= (4096-32))
+ || (page_table[first_page].write_protected != 0)
+ || (page_table[first_page].dont_move != 0)))
+ first_page++;
+
+ if (first_page >= NUM_PAGES) {
+ fprintf(stderr,
+ "Argh! gc_alloc_large failed (first_page), nbytes=%d.\n",
+ nbytes);
+ print_generation_stats(1);
+ lose(NULL);
+ }
+
+ gc_assert(page_table[first_page].write_protected == 0);
+
+ /*
+ FSHOW((stderr,
+ "/first_page=%d bytes_used=%d\n",
+ first_page, page_table[first_page].bytes_used));
+ */
+
+ last_page = first_page;
+ bytes_found = 4096 - page_table[first_page].bytes_used;
+ num_pages = 1;
+ while ((bytes_found < nbytes)
+ && (last_page < (NUM_PAGES-1))
+ && (page_table[last_page+1].allocated == FREE_PAGE)) {
+ last_page++;
+ num_pages++;
+ bytes_found += 4096;
+ gc_assert(page_table[last_page].write_protected == 0);
+ }
+
+ region_size = (4096 - page_table[first_page].bytes_used)
+ + 4096*(last_page-first_page);
+
+ gc_assert(bytes_found == region_size);
+
+ /*
+ FSHOW((stderr,
+ "/last_page=%d bytes_found=%d num_pages=%d\n",
+ last_page, bytes_found, num_pages));
+ */
+
+ restart_page = last_page + 1;
+ } while ((restart_page < NUM_PAGES) && (bytes_found < nbytes));
+
+ /* Check for a failure */
+ if ((restart_page >= NUM_PAGES) && (bytes_found < nbytes)) {
+ fprintf(stderr,
+ "Argh! gc_alloc_large failed (restart_page), nbytes=%d.\n",
+ nbytes);
+ print_generation_stats(1);
+ lose(NULL);
+ }
+
+ /*
+ if (large)
+ FSHOW((stderr,
+ "/gc_alloc_large gen %d: %d of %d bytes: from pages %d to %d: addr=%x\n",
+ gc_alloc_generation,
+ nbytes,
+ bytes_found,
+ first_page,
+ last_page,
+ page_address(first_page)));
+ */
+
+ gc_assert(first_page > alloc_region->last_page);
+ if (unboxed)
+ generations[gc_alloc_generation].alloc_large_unboxed_start_page =
+ last_page;
+ else
+ generations[gc_alloc_generation].alloc_large_start_page = last_page;
+
+ /* Set up the pages. */
+ orig_first_page_bytes_used = page_table[first_page].bytes_used;
+
+ /* If the first page was free then set up the gen, and
+ * first_object_offset. */
+ if (page_table[first_page].bytes_used == 0) {
+ if (unboxed)
+ page_table[first_page].allocated = UNBOXED_PAGE;
+ else
+ page_table[first_page].allocated = BOXED_PAGE;
+ page_table[first_page].gen = gc_alloc_generation;
+ page_table[first_page].first_object_offset = 0;
+ page_table[first_page].large_object = large;
+ }
+
+ if (unboxed)
+ gc_assert(page_table[first_page].allocated == UNBOXED_PAGE);
+ else
+ gc_assert(page_table[first_page].allocated == BOXED_PAGE);
+ gc_assert(page_table[first_page].gen == gc_alloc_generation);
+ gc_assert(page_table[first_page].large_object == large);
+
+ byte_cnt = 0;
+
+ /* Calc. the number of bytes used in this page. This is not
+ * always the number of new bytes, unless it was free. */
+ more = 0;
+ if ((bytes_used = nbytes+orig_first_page_bytes_used) > 4096) {
+ bytes_used = 4096;
+ more = 1;
+ }
+ page_table[first_page].bytes_used = bytes_used;
+ byte_cnt += bytes_used;
+
+ next_page = first_page+1;
+
+ /* All the rest of the pages should be free. We need to set their
+ * first_object_offset pointer to the start of the region, and
+ * set the bytes_used. */
+ while (more) {
+ gc_assert(page_table[next_page].allocated == FREE_PAGE);
+ gc_assert(page_table[next_page].bytes_used == 0);
+ if (unboxed)
+ page_table[next_page].allocated = UNBOXED_PAGE;
+ else
+ page_table[next_page].allocated = BOXED_PAGE;
+ page_table[next_page].gen = gc_alloc_generation;
+ page_table[next_page].large_object = large;
+
+ page_table[next_page].first_object_offset =
+ orig_first_page_bytes_used - 4096*(next_page-first_page);
+
+ /* Calculate the number of bytes used in this page. */
+ more = 0;
+ if ((bytes_used=(nbytes+orig_first_page_bytes_used)-byte_cnt) > 4096) {
+ bytes_used = 4096;
+ more = 1;
+ }
+ page_table[next_page].bytes_used = bytes_used;
+ byte_cnt += bytes_used;
+
+ next_page++;
+ }
+
+ gc_assert((byte_cnt-orig_first_page_bytes_used) == nbytes);
+
+ bytes_allocated += nbytes;
+ generations[gc_alloc_generation].bytes_allocated += nbytes;
+
+ /* Add the region to the new_areas if requested. */
+ if (!unboxed)
+ add_new_area(first_page,orig_first_page_bytes_used,nbytes);
+
+ /* Bump up last_free_page */
+ if (last_page+1 > last_free_page) {
+ last_free_page = last_page+1;
+ SetSymbolValue(ALLOCATION_POINTER,
+ (lispobj)(((char *)heap_base) + last_free_page*4096));
+ if (last_page+1 > last_used_page)
+ last_used_page = last_page+1;
+ }
+
+ return((void *)(page_address(first_page)+orig_first_page_bytes_used));
+}
+
+/* Allocate bytes from the boxed_region. It first checks if there is
+ * room, if not then it calls gc_alloc_new_region to find a new region
+ * with enough space. A pointer to the start of the region is returned. */
+static void
+*gc_alloc(int nbytes)
+{
+ void *new_free_pointer;
+
+ /* FSHOW((stderr, "/gc_alloc %d\n", nbytes)); */
+
+ /* Check whether there is room in the current alloc region. */
+ new_free_pointer = boxed_region.free_pointer + nbytes;
+
+ if (new_free_pointer <= boxed_region.end_addr) {
+ /* If so then allocate from the current alloc region. */
+ void *new_obj = boxed_region.free_pointer;
+ boxed_region.free_pointer = new_free_pointer;
+
+ /* Check whether the alloc region is almost empty. */
+ if ((boxed_region.end_addr - boxed_region.free_pointer) <= 32) {
+ /* If so finished with the current region. */
+ gc_alloc_update_page_tables(0, &boxed_region);
+ /* Set up a new region. */
+ gc_alloc_new_region(32, 0, &boxed_region);
+ }
+ return((void *)new_obj);
+ }
+
+ /* Else not enough free space in the current region. */
+
+ /* If there some room left in the current region, enough to be worth
+ * saving, then allocate a large object. */
+ /* FIXME: "32" should be a named parameter. */
+ if ((boxed_region.end_addr-boxed_region.free_pointer) > 32)
+ return gc_alloc_large(nbytes, 0, &boxed_region);
+
+ /* Else find a new region. */
+
+ /* Finished with the current region. */
+ gc_alloc_update_page_tables(0, &boxed_region);
+
+ /* Set up a new region. */
+ gc_alloc_new_region(nbytes, 0, &boxed_region);
+
+ /* Should now be enough room. */
+
+ /* Check whether there is room in the current region. */
+ new_free_pointer = boxed_region.free_pointer + nbytes;
+
+ if (new_free_pointer <= boxed_region.end_addr) {
+ /* If so then allocate from the current region. */
+ void *new_obj = boxed_region.free_pointer;
+ boxed_region.free_pointer = new_free_pointer;
+
+ /* Check whether the current region is almost empty. */
+ if ((boxed_region.end_addr - boxed_region.free_pointer) <= 32) {
+ /* If so find, finished with the current region. */
+ gc_alloc_update_page_tables(0, &boxed_region);
+
+ /* Set up a new region. */
+ gc_alloc_new_region(32, 0, &boxed_region);
+ }
+
+ return((void *)new_obj);
+ }
+
+ /* shouldn't happen */
+ gc_assert(0);
+}
+
+/* Allocate space from the boxed_region. If there is not enough free
+ * space then call gc_alloc to do the job. A pointer to the start of
+ * the region is returned. */
+static inline void
+*gc_quick_alloc(int nbytes)
+{
+ void *new_free_pointer;
+
+ /* Check whether there is room in the current region. */
+ new_free_pointer = boxed_region.free_pointer + nbytes;
+
+ if (new_free_pointer <= boxed_region.end_addr) {
+ /* If so then allocate from the current region. */
+ void *new_obj = boxed_region.free_pointer;
+ boxed_region.free_pointer = new_free_pointer;
+ return((void *)new_obj);
+ }
+
+ /* Else call gc_alloc */
+ return (gc_alloc(nbytes));
+}
+
+/* Allocate space for the boxed object. If it is a large object then
+ * do a large alloc else allocate from the current region. If there is
+ * not enough free space then call gc_alloc to do the job. A pointer
+ * to the start of the region is returned. */
+static inline void
+*gc_quick_alloc_large(int nbytes)
+{
+ void *new_free_pointer;
+
+ if (nbytes >= large_object_size)
+ return gc_alloc_large(nbytes, 0, &boxed_region);
+
+ /* Check whether there is room in the current region. */
+ new_free_pointer = boxed_region.free_pointer + nbytes;
+
+ if (new_free_pointer <= boxed_region.end_addr) {
+ /* If so then allocate from the current region. */
+ void *new_obj = boxed_region.free_pointer;
+ boxed_region.free_pointer = new_free_pointer;
+ return((void *)new_obj);
+ }
+
+ /* Else call gc_alloc */
+ return (gc_alloc(nbytes));
+}
+
+static void
+*gc_alloc_unboxed(int nbytes)
+{
+ void *new_free_pointer;
+
+ /*
+ FSHOW((stderr, "/gc_alloc_unboxed %d\n", nbytes));
+ */
+
+ /* Check whether there is room in the current region. */
+ new_free_pointer = unboxed_region.free_pointer + nbytes;
+
+ if (new_free_pointer <= unboxed_region.end_addr) {
+ /* If so then allocate from the current region. */
+ void *new_obj = unboxed_region.free_pointer;
+ unboxed_region.free_pointer = new_free_pointer;
+
+ /* Check whether the current region is almost empty. */
+ if ((unboxed_region.end_addr - unboxed_region.free_pointer) <= 32) {
+ /* If so finished with the current region. */
+ gc_alloc_update_page_tables(1, &unboxed_region);
+
+ /* Set up a new region. */
+ gc_alloc_new_region(32, 1, &unboxed_region);
+ }
+
+ return((void *)new_obj);
+ }
+
+ /* Else not enough free space in the current region. */
+
+ /* If there is a bit of room left in the current region then
+ allocate a large object. */
+ if ((unboxed_region.end_addr-unboxed_region.free_pointer) > 32)
+ return gc_alloc_large(nbytes,1,&unboxed_region);
+
+ /* Else find a new region. */
+
+ /* Finished with the current region. */
+ gc_alloc_update_page_tables(1, &unboxed_region);
+
+ /* Set up a new region. */
+ gc_alloc_new_region(nbytes, 1, &unboxed_region);
+
+ /* Should now be enough room. */
+
+ /* Check whether there is room in the current region. */
+ new_free_pointer = unboxed_region.free_pointer + nbytes;
+
+ if (new_free_pointer <= unboxed_region.end_addr) {
+ /* If so then allocate from the current region. */
+ void *new_obj = unboxed_region.free_pointer;
+ unboxed_region.free_pointer = new_free_pointer;
+
+ /* Check whether the current region is almost empty. */
+ if ((unboxed_region.end_addr - unboxed_region.free_pointer) <= 32) {
+ /* If so find, finished with the current region. */
+ gc_alloc_update_page_tables(1, &unboxed_region);
+
+ /* Set up a new region. */
+ gc_alloc_new_region(32, 1, &unboxed_region);
+ }
+
+ return((void *)new_obj);
+ }
+
+ /* shouldn't happen? */
+ gc_assert(0);
+}
+
+static inline void
+*gc_quick_alloc_unboxed(int nbytes)
+{
+ void *new_free_pointer;
+
+ /* Check whether there is room in the current region. */
+ new_free_pointer = unboxed_region.free_pointer + nbytes;
+
+ if (new_free_pointer <= unboxed_region.end_addr) {
+ /* If so then allocate from the current region. */
+ void *new_obj = unboxed_region.free_pointer;
+ unboxed_region.free_pointer = new_free_pointer;
+
+ return((void *)new_obj);
+ }
+
+ /* Else call gc_alloc */
+ return (gc_alloc_unboxed(nbytes));
+}
+
+/* Allocate space for the object. If it is a large object then do a
+ * large alloc else allocate from the current region. If there is not
+ * enough free space then call gc_alloc to do the job.
+ *
+ * A pointer to the start of the region is returned. */
+static inline void
+*gc_quick_alloc_large_unboxed(int nbytes)
+{
+ void *new_free_pointer;
+
+ if (nbytes >= large_object_size)
+ return gc_alloc_large(nbytes,1,&unboxed_region);
+
+ /* Check whether there is room in the current region. */
+ new_free_pointer = unboxed_region.free_pointer + nbytes;
+
+ if (new_free_pointer <= unboxed_region.end_addr) {
+ /* If so then allocate from the current region. */
+ void *new_obj = unboxed_region.free_pointer;
+ unboxed_region.free_pointer = new_free_pointer;
+
+ return((void *)new_obj);
+ }
+
+ /* Else call gc_alloc. */
+ return (gc_alloc_unboxed(nbytes));
+}
+\f
+/*
+ * scavenging/transporting routines derived from gc.c in CMU CL ca. 18b
+ */
+
+static int (*scavtab[256])(lispobj *where, lispobj object);
+static lispobj (*transother[256])(lispobj object);
+static int (*sizetab[256])(lispobj *where);
+
+static struct weak_pointer *weak_pointers;
+
+#define CEILING(x,y) (((x) + ((y) - 1)) & (~((y) - 1)))
+\f
+/*
+ * predicates
+ */
+
+static inline boolean
+from_space_p(lispobj obj)
+{
+ int page_index=(void*)obj - heap_base;
+ return ((page_index >= 0)
+ && ((page_index = ((unsigned int)page_index)/4096) < NUM_PAGES)
+ && (page_table[page_index].gen == from_space));
+}
+
+static inline boolean
+new_space_p(lispobj obj)
+{
+ int page_index = (void*)obj - heap_base;
+ return ((page_index >= 0)
+ && ((page_index = ((unsigned int)page_index)/4096) < NUM_PAGES)
+ && (page_table[page_index].gen == new_space));
+}
+\f
+/*
+ * copying objects
+ */
+
+/* to copy a boxed object */
+static inline lispobj
+copy_object(lispobj object, int nwords)
+{
+ int tag;
+ lispobj *new;
+ lispobj *source, *dest;
+
+ gc_assert(Pointerp(object));
+ gc_assert(from_space_p(object));
+ gc_assert((nwords & 0x01) == 0);
+
+ /* Get tag of object. */
+ tag = LowtagOf(object);
+
+ /* Allocate space. */
+ new = gc_quick_alloc(nwords*4);
+
+ dest = new;
+ source = (lispobj *) PTR(object);
+
+ /* Copy the object. */
+ while (nwords > 0) {
+ dest[0] = source[0];
+ dest[1] = source[1];
+ dest += 2;
+ source += 2;
+ nwords -= 2;
+ }
+
+ /* Return Lisp pointer of new object. */
+ return ((lispobj) new) | tag;
+}
+
+/* to copy a large boxed object. If the object is in a large object
+ * region then it is simply promoted, else it is copied. If it's large
+ * enough then it's copied to a large object region.
+ *
+ * Vectors may have shrunk. If the object is not copied the space
+ * needs to be reclaimed, and the page_tables corrected. */
+static lispobj
+copy_large_object(lispobj object, int nwords)
+{
+ int tag;
+ lispobj *new;
+ lispobj *source, *dest;
+ int first_page;
+
+ gc_assert(Pointerp(object));
+ gc_assert(from_space_p(object));
+ gc_assert((nwords & 0x01) == 0);
+
+ if ((nwords > 1024*1024) && gencgc_verbose) {
+ FSHOW((stderr, "/copy_large_object: %d bytes\n", nwords*4));
+ }
+
+ /* Check whether it's a large object. */
+ first_page = find_page_index((void *)object);
+ gc_assert(first_page >= 0);
+
+ if (page_table[first_page].large_object) {
+
+ /* Promote the object. */
+
+ int remaining_bytes;
+ int next_page;
+ int bytes_freed;
+ int old_bytes_used;
+
+ /* Note: Any page write-protection must be removed, else a
+ * later scavenge_newspace may incorrectly not scavenge these
+ * pages. This would not be necessary if they are added to the
+ * new areas, but let's do it for them all (they'll probably
+ * be written anyway?). */
+
+ gc_assert(page_table[first_page].first_object_offset == 0);
+
+ next_page = first_page;
+ remaining_bytes = nwords*4;
+ while (remaining_bytes > 4096) {
+ gc_assert(page_table[next_page].gen == from_space);
+ gc_assert(page_table[next_page].allocated == BOXED_PAGE);
+ gc_assert(page_table[next_page].large_object);
+ gc_assert(page_table[next_page].first_object_offset==
+ -4096*(next_page-first_page));
+ gc_assert(page_table[next_page].bytes_used == 4096);
+
+ page_table[next_page].gen = new_space;
+
+ /* Remove any write-protection. We should be able to rely
+ * on the write-protect flag to avoid redundant calls. */
+ if (page_table[next_page].write_protected) {
+ os_protect(page_address(next_page), 4096, OS_VM_PROT_ALL);
+ page_table[next_page].write_protected = 0;
+ }
+ remaining_bytes -= 4096;
+ next_page++;
+ }
+
+ /* Now only one page remains, but the object may have shrunk
+ * so there may be more unused pages which will be freed. */
+
+ /* The object may have shrunk but shouldn't have grown. */
+ gc_assert(page_table[next_page].bytes_used >= remaining_bytes);
+
+ page_table[next_page].gen = new_space;
+ gc_assert(page_table[next_page].allocated = BOXED_PAGE);
+
+ /* Adjust the bytes_used. */
+ old_bytes_used = page_table[next_page].bytes_used;
+ page_table[next_page].bytes_used = remaining_bytes;
+
+ bytes_freed = old_bytes_used - remaining_bytes;
+
+ /* Free any remaining pages; needs care. */
+ next_page++;
+ while ((old_bytes_used == 4096) &&
+ (page_table[next_page].gen == from_space) &&
+ (page_table[next_page].allocated == BOXED_PAGE) &&
+ page_table[next_page].large_object &&
+ (page_table[next_page].first_object_offset ==
+ -(next_page - first_page)*4096)) {
+ /* Checks out OK, free the page. Don't need to both zeroing
+ * pages as this should have been done before shrinking the
+ * object. These pages shouldn't be write-protected as they
+ * should be zero filled. */
+ gc_assert(page_table[next_page].write_protected == 0);
+
+ old_bytes_used = page_table[next_page].bytes_used;
+ page_table[next_page].allocated = FREE_PAGE;
+ page_table[next_page].bytes_used = 0;
+ bytes_freed += old_bytes_used;
+ next_page++;
+ }
+
+ if ((bytes_freed > 0) && gencgc_verbose)
+ FSHOW((stderr, "/copy_large_boxed bytes_freed=%d\n", bytes_freed));
+
+ generations[from_space].bytes_allocated -= 4*nwords + bytes_freed;
+ generations[new_space].bytes_allocated += 4*nwords;
+ bytes_allocated -= bytes_freed;
+
+ /* Add the region to the new_areas if requested. */
+ add_new_area(first_page,0,nwords*4);
+
+ return(object);
+ } else {
+ /* Get tag of object. */
+ tag = LowtagOf(object);
+
+ /* Allocate space. */
+ new = gc_quick_alloc_large(nwords*4);
+
+ dest = new;
+ source = (lispobj *) PTR(object);
+
+ /* Copy the object. */
+ while (nwords > 0) {
+ dest[0] = source[0];
+ dest[1] = source[1];
+ dest += 2;
+ source += 2;
+ nwords -= 2;
+ }
+
+ /* Return Lisp pointer of new object. */
+ return ((lispobj) new) | tag;
+ }
+}
+
+/* to copy unboxed objects */
+static inline lispobj
+copy_unboxed_object(lispobj object, int nwords)
+{
+ int tag;
+ lispobj *new;
+ lispobj *source, *dest;
+
+ gc_assert(Pointerp(object));
+ gc_assert(from_space_p(object));
+ gc_assert((nwords & 0x01) == 0);
+
+ /* Get tag of object. */
+ tag = LowtagOf(object);
+
+ /* Allocate space. */
+ new = gc_quick_alloc_unboxed(nwords*4);
+
+ dest = new;
+ source = (lispobj *) PTR(object);
+
+ /* Copy the object. */
+ while (nwords > 0) {
+ dest[0] = source[0];
+ dest[1] = source[1];
+ dest += 2;
+ source += 2;
+ nwords -= 2;
+ }
+
+ /* Return Lisp pointer of new object. */
+ return ((lispobj) new) | tag;
+}
+
+/* to copy large unboxed objects
+ *
+ * If the object is in a large object region then it is simply
+ * promoted, else it is copied. If it's large enough then it's copied
+ * to a large object region.
+ *
+ * Bignums and vectors may have shrunk. If the object is not copied
+ * the space needs to be reclaimed, and the page_tables corrected.
+ *
+ * KLUDGE: There's a lot of cut-and-paste duplication between this
+ * function and copy_large_object(..). -- WHN 20000619 */
+static lispobj
+copy_large_unboxed_object(lispobj object, int nwords)
+{
+ int tag;
+ lispobj *new;
+ lispobj *source, *dest;
+ int first_page;
+
+ gc_assert(Pointerp(object));
+ gc_assert(from_space_p(object));
+ gc_assert((nwords & 0x01) == 0);
+
+ if ((nwords > 1024*1024) && gencgc_verbose)
+ FSHOW((stderr, "/copy_large_unboxed_object: %d bytes\n", nwords*4));
+
+ /* Check whether it's a large object. */
+ first_page = find_page_index((void *)object);
+ gc_assert(first_page >= 0);
+
+ if (page_table[first_page].large_object) {
+ /* Promote the object. Note: Unboxed objects may have been
+ * allocated to a BOXED region so it may be necessary to
+ * change the region to UNBOXED. */
+ int remaining_bytes;
+ int next_page;
+ int bytes_freed;
+ int old_bytes_used;
+
+ gc_assert(page_table[first_page].first_object_offset == 0);
+
+ next_page = first_page;
+ remaining_bytes = nwords*4;
+ while (remaining_bytes > 4096) {
+ gc_assert(page_table[next_page].gen == from_space);
+ gc_assert((page_table[next_page].allocated == UNBOXED_PAGE)
+ || (page_table[next_page].allocated == BOXED_PAGE));
+ gc_assert(page_table[next_page].large_object);
+ gc_assert(page_table[next_page].first_object_offset==
+ -4096*(next_page-first_page));
+ gc_assert(page_table[next_page].bytes_used == 4096);
+
+ page_table[next_page].gen = new_space;
+ page_table[next_page].allocated = UNBOXED_PAGE;
+ remaining_bytes -= 4096;
+ next_page++;
+ }
+
+ /* Now only one page remains, but the object may have shrunk so
+ * there may be more unused pages which will be freed. */
+
+ /* Object may have shrunk but shouldn't have grown - check. */
+ gc_assert(page_table[next_page].bytes_used >= remaining_bytes);
+
+ page_table[next_page].gen = new_space;
+ page_table[next_page].allocated = UNBOXED_PAGE;
+
+ /* Adjust the bytes_used. */
+ old_bytes_used = page_table[next_page].bytes_used;
+ page_table[next_page].bytes_used = remaining_bytes;
+
+ bytes_freed = old_bytes_used - remaining_bytes;
+
+ /* Free any remaining pages; needs care. */
+ next_page++;
+ while ((old_bytes_used == 4096) &&
+ (page_table[next_page].gen == from_space) &&
+ ((page_table[next_page].allocated == UNBOXED_PAGE)
+ || (page_table[next_page].allocated == BOXED_PAGE)) &&
+ page_table[next_page].large_object &&
+ (page_table[next_page].first_object_offset ==
+ -(next_page - first_page)*4096)) {
+ /* Checks out OK, free the page. Don't need to both zeroing
+ * pages as this should have been done before shrinking the
+ * object. These pages shouldn't be write-protected, even if
+ * boxed they should be zero filled. */
+ gc_assert(page_table[next_page].write_protected == 0);
+
+ old_bytes_used = page_table[next_page].bytes_used;
+ page_table[next_page].allocated = FREE_PAGE;
+ page_table[next_page].bytes_used = 0;
+ bytes_freed += old_bytes_used;
+ next_page++;
+ }
+
+ if ((bytes_freed > 0) && gencgc_verbose)
+ FSHOW((stderr,
+ "/copy_large_unboxed bytes_freed=%d\n",
+ bytes_freed));
+
+ generations[from_space].bytes_allocated -= 4*nwords + bytes_freed;
+ generations[new_space].bytes_allocated += 4*nwords;
+ bytes_allocated -= bytes_freed;
+
+ return(object);
+ }
+ else {
+ /* Get tag of object. */
+ tag = LowtagOf(object);
+
+ /* Allocate space. */
+ new = gc_quick_alloc_large_unboxed(nwords*4);
+
+ dest = new;
+ source = (lispobj *) PTR(object);
+
+ /* Copy the object. */
+ while (nwords > 0) {
+ dest[0] = source[0];
+ dest[1] = source[1];
+ dest += 2;
+ source += 2;
+ nwords -= 2;
+ }
+
+ /* Return Lisp pointer of new object. */
+ return ((lispobj) new) | tag;
+ }
+}
+\f
+/*
+ * scavenging
+ */
+
+#define DIRECT_SCAV 0
+
+static void
+scavenge(lispobj *start, long nwords)
+{
+ while (nwords > 0) {
+ lispobj object;
+ int type, words_scavenged;
+
+ object = *start;
+
+/* FSHOW((stderr, "Scavenge: %p, %ld\n", start, nwords)); */
+
+ gc_assert(object != 0x01); /* not a forwarding pointer */
+
+#if DIRECT_SCAV
+ type = TypeOf(object);
+ words_scavenged = (scavtab[type])(start, object);
+#else
+ if (Pointerp(object)) {
+ /* It's a pointer. */
+ if (from_space_p(object)) {
+ /* It currently points to old space. Check for a forwarding
+ * pointer. */
+ lispobj *ptr = (lispobj *)PTR(object);
+ lispobj first_word = *ptr;
+
+ if (first_word == 0x01) {
+ /* Yep, there be a forwarding pointer. */
+ *start = ptr[1];
+ words_scavenged = 1;
+ }
+ else
+ /* Scavenge that pointer. */
+ words_scavenged = (scavtab[TypeOf(object)])(start, object);
+ } else {
+ /* It points somewhere other than oldspace. Leave it alone. */
+ words_scavenged = 1;
+ }
+ } else {
+ if ((object & 3) == 0) {
+ /* It's a fixnum. Real easy.. */
+ words_scavenged = 1;
+ } else {
+ /* It's some sort of header object or another. */
+ words_scavenged = (scavtab[TypeOf(object)])(start, object);
+ }
+ }
+#endif
+
+ start += words_scavenged;
+ nwords -= words_scavenged;
+ }
+ gc_assert(nwords == 0);
+}
+
+\f
+/*
+ * code and code-related objects
+ */
+
+#define RAW_ADDR_OFFSET (6*sizeof(lispobj) - type_FunctionPointer)
+
+static lispobj trans_function_header(lispobj object);
+static lispobj trans_boxed(lispobj object);
+
+#if DIRECT_SCAV
+static int
+scav_function_pointer(lispobj *where, lispobj object)
+{
+ gc_assert(Pointerp(object));
+
+ if (from_space_p(object)) {
+ lispobj first, *first_pointer;
+
+ /* object is a pointer into from space. Check to see whether
+ * it has been forwarded. */
+ first_pointer = (lispobj *) PTR(object);
+ first = *first_pointer;
+
+ if (first == 0x01) {
+ /* Forwarded */
+ *where = first_pointer[1];
+ return 1;
+ }
+ else {
+ int type;
+ lispobj copy;
+
+ /* must transport object -- object may point to either a
+ * function header, a closure function header, or to a
+ * closure header. */
+
+ type = TypeOf(first);
+ switch (type) {
+ case type_FunctionHeader:
+ case type_ClosureFunctionHeader:
+ copy = trans_function_header(object);
+ break;
+ default:
+ copy = trans_boxed(object);
+ break;
+ }
+
+ if (copy != object) {
+ /* Set forwarding pointer. */
+ first_pointer[0] = 0x01;
+ first_pointer[1] = copy;
+ }
+
+ first = copy;
+ }
+
+ gc_assert(Pointerp(first));
+ gc_assert(!from_space_p(first));
+
+ *where = first;
+ }
+ return 1;
+}
+#else
+static int
+scav_function_pointer(lispobj *where, lispobj object)
+{
+ lispobj *first_pointer;
+ lispobj copy;
+
+ gc_assert(Pointerp(object));
+
+ /* Object is a pointer into from space - no a FP. */
+ first_pointer = (lispobj *) PTR(object);
+
+ /* must transport object -- object may point to either a function
+ * header, a closure function header, or to a closure header. */
+
+ switch (TypeOf(*first_pointer)) {
+ case type_FunctionHeader:
+ case type_ClosureFunctionHeader:
+ copy = trans_function_header(object);
+ break;
+ default:
+ copy = trans_boxed(object);
+ break;
+ }
+
+ if (copy != object) {
+ /* Set forwarding pointer */
+ first_pointer[0] = 0x01;
+ first_pointer[1] = copy;
+ }
+
+ gc_assert(Pointerp(copy));
+ gc_assert(!from_space_p(copy));
+
+ *where = copy;
+
+ return 1;
+}
+#endif
+
+/* Scan a x86 compiled code object, looking for possible fixups that
+ * have been missed after a move.
+ *
+ * Two types of fixups are needed:
+ * 1. Absolute fixups to within the code object.
+ * 2. Relative fixups to outside the code object.
+ *
+ * Currently only absolute fixups to the constant vector, or to the
+ * code area are checked. */
+void
+sniff_code_object(struct code *code, unsigned displacement)
+{
+ int nheader_words, ncode_words, nwords;
+ lispobj fheaderl;
+ struct function *fheaderp;
+ void *p;
+ void *constants_start_addr, *constants_end_addr;
+ void *code_start_addr, *code_end_addr;
+ int fixup_found = 0;
+
+ if (!check_code_fixups)
+ return;
+
+ /* It's ok if it's byte compiled code. The trace table offset will
+ * be a fixnum if it's x86 compiled code - check. */
+ if (code->trace_table_offset & 0x3) {
+ FSHOW((stderr, "/Sniffing byte compiled code object at %x.\n", code));
+ return;
+ }
+
+ /* Else it's x86 machine code. */
+
+ ncode_words = fixnum_value(code->code_size);
+ nheader_words = HeaderValue(*(lispobj *)code);
+ nwords = ncode_words + nheader_words;
+
+ constants_start_addr = (void *)code + 5*4;
+ constants_end_addr = (void *)code + nheader_words*4;
+ code_start_addr = (void *)code + nheader_words*4;
+ code_end_addr = (void *)code + nwords*4;
+
+ /* Work through the unboxed code. */
+ for (p = code_start_addr; p < code_end_addr; p++) {
+ void *data = *(void **)p;
+ unsigned d1 = *((unsigned char *)p - 1);
+ unsigned d2 = *((unsigned char *)p - 2);
+ unsigned d3 = *((unsigned char *)p - 3);
+ unsigned d4 = *((unsigned char *)p - 4);
+ unsigned d5 = *((unsigned char *)p - 5);
+ unsigned d6 = *((unsigned char *)p - 6);
+
+ /* Check for code references. */
+ /* Check for a 32 bit word that looks like an absolute
+ reference to within the code adea of the code object. */
+ if ((data >= (code_start_addr-displacement))
+ && (data < (code_end_addr-displacement))) {
+ /* function header */
+ if ((d4 == 0x5e)
+ && (((unsigned)p - 4 - 4*HeaderValue(*((unsigned *)p-1))) == (unsigned)code)) {
+ /* Skip the function header */
+ p += 6*4 - 4 - 1;
+ continue;
+ }
+ /* the case of PUSH imm32 */
+ if (d1 == 0x68) {
+ fixup_found = 1;
+ FSHOW((stderr,
+ "/code ref @%x: %.2x %.2x %.2x %.2x %.2x %.2x (%.8x)\n",
+ p, d6, d5, d4, d3, d2, d1, data));
+ FSHOW((stderr, "/PUSH $0x%.8x\n", data));
+ }
+ /* the case of MOV [reg-8],imm32 */
+ if ((d3 == 0xc7)
+ && (d2==0x40 || d2==0x41 || d2==0x42 || d2==0x43
+ || d2==0x45 || d2==0x46 || d2==0x47)
+ && (d1 == 0xf8)) {
+ fixup_found = 1;
+ FSHOW((stderr,
+ "/code ref @%x: %.2x %.2x %.2x %.2x %.2x %.2x (%.8x)\n",
+ p, d6, d5, d4, d3, d2, d1, data));
+ FSHOW((stderr, "/MOV [reg-8],$0x%.8x\n", data));
+ }
+ /* the case of LEA reg,[disp32] */
+ if ((d2 == 0x8d) && ((d1 & 0xc7) == 5)) {
+ fixup_found = 1;
+ FSHOW((stderr,
+ "/code ref @%x: %.2x %.2x %.2x %.2x %.2x %.2x (%.8x)\n",
+ p, d6, d5, d4, d3, d2, d1, data));
+ FSHOW((stderr,"/LEA reg,[$0x%.8x]\n", data));
+ }
+ }
+
+ /* Check for constant references. */
+ /* Check for a 32 bit word that looks like an absolute
+ reference to within the constant vector. Constant references
+ will be aligned. */
+ if ((data >= (constants_start_addr-displacement))
+ && (data < (constants_end_addr-displacement))
+ && (((unsigned)data & 0x3) == 0)) {
+ /* Mov eax,m32 */
+ if (d1 == 0xa1) {
+ fixup_found = 1;
+ FSHOW((stderr,
+ "/abs const ref @%x: %.2x %.2x %.2x %.2x %.2x %.2x (%.8x)\n",
+ p, d6, d5, d4, d3, d2, d1, data));
+ FSHOW((stderr,"/MOV eax,0x%.8x\n", data));
+ }
+
+ /* the case of MOV m32,EAX */
+ if (d1 == 0xa3) {
+ fixup_found = 1;
+ FSHOW((stderr,
+ "/abs const ref @%x: %.2x %.2x %.2x %.2x %.2x %.2x (%.8x)\n",
+ p, d6, d5, d4, d3, d2, d1, data));
+ FSHOW((stderr, "/MOV 0x%.8x,eax\n", data));
+ }
+
+ /* the case of CMP m32,imm32 */
+ if ((d1 == 0x3d) && (d2 == 0x81)) {
+ fixup_found = 1;
+ FSHOW((stderr,
+ "/abs const ref @%x: %.2x %.2x %.2x %.2x %.2x %.2x (%.8x)\n",
+ p, d6, d5, d4, d3, d2, d1, data));
+ /* XX Check this */
+ FSHOW((stderr, "/CMP 0x%.8x,immed32\n", data));
+ }
+
+ /* Check for a mod=00, r/m=101 byte. */
+ if ((d1 & 0xc7) == 5) {
+ /* Cmp m32,reg */
+ if (d2 == 0x39) {
+ fixup_found = 1;
+ FSHOW((stderr,
+ "/abs const ref @%x: %.2x %.2x %.2x %.2x %.2x %.2x (%.8x)\n",
+ p, d6, d5, d4, d3, d2, d1, data));
+ FSHOW((stderr,"/CMP 0x%.8x,reg\n", data));
+ }
+ /* the case of CMP reg32,m32 */
+ if (d2 == 0x3b) {
+ fixup_found = 1;
+ FSHOW((stderr,
+ "/abs const ref @%x: %.2x %.2x %.2x %.2x %.2x %.2x (%.8x)\n",
+ p, d6, d5, d4, d3, d2, d1, data));
+ FSHOW((stderr, "/CMP reg32,0x%.8x\n", data));
+ }
+ /* the case of MOV m32,reg32 */
+ if (d2 == 0x89) {
+ fixup_found = 1;
+ FSHOW((stderr,
+ "/abs const ref @%x: %.2x %.2x %.2x %.2x %.2x %.2x (%.8x)\n",
+ p, d6, d5, d4, d3, d2, d1, data));
+ FSHOW((stderr, "/MOV 0x%.8x,reg32\n", data));
+ }
+ /* the case of MOV reg32,m32 */
+ if (d2 == 0x8b) {
+ fixup_found = 1;
+ FSHOW((stderr,
+ "/abs const ref @%x: %.2x %.2x %.2x %.2x %.2x %.2x (%.8x)\n",
+ p, d6, d5, d4, d3, d2, d1, data));
+ FSHOW((stderr, "/MOV reg32,0x%.8x\n", data));
+ }
+ /* the case of LEA reg32,m32 */
+ if (d2 == 0x8d) {
+ fixup_found = 1;
+ FSHOW((stderr,
+ "abs const ref @%x: %.2x %.2x %.2x %.2x %.2x %.2x (%.8x)\n",
+ p, d6, d5, d4, d3, d2, d1, data));
+ FSHOW((stderr, "/LEA reg32,0x%.8x\n", data));
+ }
+ }
+ }
+ }
+
+ /* If anything was found, print some information on the code
+ * object. */
+ if (fixup_found) {
+ FSHOW((stderr,
+ "/compiled code object at %x: header words = %d, code words = %d\n",
+ code, nheader_words, ncode_words));
+ FSHOW((stderr,
+ "/const start = %x, end = %x\n",
+ constants_start_addr, constants_end_addr));
+ FSHOW((stderr,
+ "/code start = %x, end = %x\n",
+ code_start_addr, code_end_addr));
+ }
+}
+
+static void
+apply_code_fixups(struct code *old_code, struct code *new_code)
+{
+ int nheader_words, ncode_words, nwords;
+ void *constants_start_addr, *constants_end_addr;
+ void *code_start_addr, *code_end_addr;
+ lispobj p;
+ lispobj fixups = NIL;
+ unsigned displacement = (unsigned)new_code - (unsigned)old_code;
+ struct vector *fixups_vector;
+
+ /* It's OK if it's byte compiled code. The trace table offset will
+ * be a fixnum if it's x86 compiled code - check. */
+ if (new_code->trace_table_offset & 0x3) {
+/* FSHOW((stderr, "/byte compiled code object at %x\n", new_code)); */
+ return;
+ }
+
+ /* Else it's x86 machine code. */
+ ncode_words = fixnum_value(new_code->code_size);
+ nheader_words = HeaderValue(*(lispobj *)new_code);
+ nwords = ncode_words + nheader_words;
+ /* FSHOW((stderr,
+ "/compiled code object at %x: header words = %d, code words = %d\n",
+ new_code, nheader_words, ncode_words)); */
+ constants_start_addr = (void *)new_code + 5*4;
+ constants_end_addr = (void *)new_code + nheader_words*4;
+ code_start_addr = (void *)new_code + nheader_words*4;
+ code_end_addr = (void *)new_code + nwords*4;
+ /*
+ FSHOW((stderr,
+ "/const start = %x, end = %x\n",
+ constants_start_addr,constants_end_addr));
+ FSHOW((stderr,
+ "/code start = %x; end = %x\n",
+ code_start_addr,code_end_addr));
+ */
+
+ /* The first constant should be a pointer to the fixups for this
+ code objects. Check. */
+ fixups = new_code->constants[0];
+
+ /* It will be 0 or the unbound-marker if there are no fixups, and
+ * will be an other pointer if it is valid. */
+ if ((fixups == 0) || (fixups == type_UnboundMarker) || !Pointerp(fixups)) {
+ /* Check for possible errors. */
+ if (check_code_fixups)
+ sniff_code_object(new_code, displacement);
+
+ /*fprintf(stderr,"Fixups for code object not found!?\n");
+ fprintf(stderr,"*** Compiled code object at %x: header_words=%d code_words=%d .\n",
+ new_code, nheader_words, ncode_words);
+ fprintf(stderr,"*** Const. start = %x; end= %x; Code start = %x; end = %x\n",
+ constants_start_addr,constants_end_addr,
+ code_start_addr,code_end_addr);*/
+ return;
+ }
+
+ fixups_vector = (struct vector *)PTR(fixups);
+
+ /* Could be pointing to a forwarding pointer. */
+ if (Pointerp(fixups) && (find_page_index((void*)fixups_vector) != -1)
+ && (fixups_vector->header == 0x01)) {
+ /* If so, then follow it. */
+ /*SHOW("following pointer to a forwarding pointer");*/
+ fixups_vector = (struct vector *)PTR((lispobj)fixups_vector->length);
+ }
+
+ /*SHOW("got fixups");*/
+
+ if (TypeOf(fixups_vector->header) == type_SimpleArrayUnsignedByte32) {
+ /* Got the fixups for the code block. Now work through the vector,
+ and apply a fixup at each address. */
+ int length = fixnum_value(fixups_vector->length);
+ int i;
+ for (i = 0; i < length; i++) {
+ unsigned offset = fixups_vector->data[i];
+ /* Now check the current value of offset. */
+ unsigned old_value =
+ *(unsigned *)((unsigned)code_start_addr + offset);
+
+ /* If it's within the old_code object then it must be an
+ * absolute fixup (relative ones are not saved) */
+ if ((old_value >= (unsigned)old_code)
+ && (old_value < ((unsigned)old_code + nwords*4)))
+ /* So add the dispacement. */
+ *(unsigned *)((unsigned)code_start_addr + offset) =
+ old_value + displacement;
+ else
+ /* It is outside the old code object so it must be a
+ * relative fixup (absolute fixups are not saved). So
+ * subtract the displacement. */
+ *(unsigned *)((unsigned)code_start_addr + offset) =
+ old_value - displacement;
+ }
+ }
+
+ /* Check for possible errors. */
+ if (check_code_fixups) {
+ sniff_code_object(new_code,displacement);
+ }
+}
+
+static struct code *
+trans_code(struct code *code)
+{
+ struct code *new_code;
+ lispobj l_code, l_new_code;
+ int nheader_words, ncode_words, nwords;
+ unsigned long displacement;
+ lispobj fheaderl, *prev_pointer;
+
+ /* FSHOW((stderr,
+ "\n/transporting code object located at 0x%08x\n",
+ (unsigned long) code)); */
+
+ /* If object has already been transported, just return pointer. */
+ if (*((lispobj *)code) == 0x01)
+ return (struct code*)(((lispobj *)code)[1]);
+
+ gc_assert(TypeOf(code->header) == type_CodeHeader);
+
+ /* Prepare to transport the code vector. */
+ l_code = (lispobj) code | type_OtherPointer;
+
+ ncode_words = fixnum_value(code->code_size);
+ nheader_words = HeaderValue(code->header);
+ nwords = ncode_words + nheader_words;
+ nwords = CEILING(nwords, 2);
+
+ l_new_code = copy_large_object(l_code, nwords);
+ new_code = (struct code *) PTR(l_new_code);
+
+ /* may not have been moved.. */
+ if (new_code == code)
+ return new_code;
+
+ displacement = l_new_code - l_code;
+
+ /*
+ FSHOW((stderr,
+ "/old code object at 0x%08x, new code object at 0x%08x\n",
+ (unsigned long) code,
+ (unsigned long) new_code));
+ FSHOW((stderr, "/Code object is %d words long.\n", nwords));
+ */
+
+ /* Set forwarding pointer. */
+ ((lispobj *)code)[0] = 0x01;
+ ((lispobj *)code)[1] = l_new_code;
+
+ /* Set forwarding pointers for all the function headers in the
+ * code object. Also fix all self pointers. */
+
+ fheaderl = code->entry_points;
+ prev_pointer = &new_code->entry_points;
+
+ while (fheaderl != NIL) {
+ struct function *fheaderp, *nfheaderp;
+ lispobj nfheaderl;
+
+ fheaderp = (struct function *) PTR(fheaderl);
+ gc_assert(TypeOf(fheaderp->header) == type_FunctionHeader);
+
+ /* Calculate the new function pointer and the new */
+ /* function header. */
+ nfheaderl = fheaderl + displacement;
+ nfheaderp = (struct function *) PTR(nfheaderl);
+
+ /* Set forwarding pointer. */
+ ((lispobj *)fheaderp)[0] = 0x01;
+ ((lispobj *)fheaderp)[1] = nfheaderl;
+
+ /* Fix self pointer. */
+ nfheaderp->self = nfheaderl + RAW_ADDR_OFFSET;
+
+ *prev_pointer = nfheaderl;
+
+ fheaderl = fheaderp->next;
+ prev_pointer = &nfheaderp->next;
+ }
+
+ /* sniff_code_object(new_code,displacement);*/
+ apply_code_fixups(code,new_code);
+
+ return new_code;
+}
+
+static int
+scav_code_header(lispobj *where, lispobj object)
+{
+ struct code *code;
+ int nheader_words, ncode_words, nwords;
+ lispobj fheaderl;
+ struct function *fheaderp;
+
+ code = (struct code *) where;
+ ncode_words = fixnum_value(code->code_size);
+ nheader_words = HeaderValue(object);
+ nwords = ncode_words + nheader_words;
+ nwords = CEILING(nwords, 2);
+
+ /* Scavenge the boxed section of the code data block. */
+ scavenge(where + 1, nheader_words - 1);
+
+ /* Scavenge the boxed section of each function object in the */
+ /* code data block. */
+ fheaderl = code->entry_points;
+ while (fheaderl != NIL) {
+ fheaderp = (struct function *) PTR(fheaderl);
+ gc_assert(TypeOf(fheaderp->header) == type_FunctionHeader);
+
+ scavenge(&fheaderp->name, 1);
+ scavenge(&fheaderp->arglist, 1);
+ scavenge(&fheaderp->type, 1);
+
+ fheaderl = fheaderp->next;
+ }
+
+ return nwords;
+}
+
+static lispobj
+trans_code_header(lispobj object)
+{
+ struct code *ncode;
+
+ ncode = trans_code((struct code *) PTR(object));
+ return (lispobj) ncode | type_OtherPointer;
+}
+
+static int
+size_code_header(lispobj *where)
+{
+ struct code *code;
+ int nheader_words, ncode_words, nwords;
+
+ code = (struct code *) where;
+
+ ncode_words = fixnum_value(code->code_size);
+ nheader_words = HeaderValue(code->header);
+ nwords = ncode_words + nheader_words;
+ nwords = CEILING(nwords, 2);
+
+ return nwords;
+}
+
+static int
+scav_return_pc_header(lispobj *where, lispobj object)
+{
+ lose("attempted to scavenge a return PC header where=0x%08x object=0x%08x",
+ (unsigned long) where,
+ (unsigned long) object);
+ return 0; /* bogus return value to satisfy static type checking */
+}
+
+static lispobj
+trans_return_pc_header(lispobj object)
+{
+ struct function *return_pc;
+ unsigned long offset;
+ struct code *code, *ncode;
+
+ SHOW("/trans_return_pc_header: Will this work?");
+
+ return_pc = (struct function *) PTR(object);
+ offset = HeaderValue(return_pc->header) * 4;
+
+ /* Transport the whole code object. */
+ code = (struct code *) ((unsigned long) return_pc - offset);
+ ncode = trans_code(code);
+
+ return ((lispobj) ncode + offset) | type_OtherPointer;
+}
+
+/* On the 386, closures hold a pointer to the raw address instead of the
+ * function object. */
+#ifdef __i386__
+static int
+scav_closure_header(lispobj *where, lispobj object)
+{
+ struct closure *closure;
+ lispobj fun;
+
+ closure = (struct closure *)where;
+ fun = closure->function - RAW_ADDR_OFFSET;
+ scavenge(&fun, 1);
+ /* The function may have moved so update the raw address. But
+ * don't write unnecessarily. */
+ if (closure->function != fun + RAW_ADDR_OFFSET)
+ closure->function = fun + RAW_ADDR_OFFSET;
+
+ return 2;
+}
+#endif
+
+static int
+scav_function_header(lispobj *where, lispobj object)
+{
+ lose("attempted to scavenge a function header where=0x%08x object=0x%08x",
+ (unsigned long) where,
+ (unsigned long) object);
+ return 0; /* bogus return value to satisfy static type checking */
+}
+
+static lispobj
+trans_function_header(lispobj object)
+{
+ struct function *fheader;
+ unsigned long offset;
+ struct code *code, *ncode;
+
+ fheader = (struct function *) PTR(object);
+ offset = HeaderValue(fheader->header) * 4;
+
+ /* Transport the whole code object. */
+ code = (struct code *) ((unsigned long) fheader - offset);
+ ncode = trans_code(code);
+
+ return ((lispobj) ncode + offset) | type_FunctionPointer;
+}
+\f
+/*
+ * instances
+ */
+
+#if DIRECT_SCAV
+static int
+scav_instance_pointer(lispobj *where, lispobj object)
+{
+ if (from_space_p(object)) {
+ lispobj first, *first_pointer;
+
+ /* Object is a pointer into from space. Check to see */
+ /* whether it has been forwarded. */
+ first_pointer = (lispobj *) PTR(object);
+ first = *first_pointer;
+
+ if (first == 0x01) {
+ /* forwarded */
+ first = first_pointer[1];
+ } else {
+ first = trans_boxed(object);
+ gc_assert(first != object);
+ /* Set forwarding pointer. */
+ first_pointer[0] = 0x01;
+ first_pointer[1] = first;
+ }
+ *where = first;
+ }
+ return 1;
+}
+#else
+static int
+scav_instance_pointer(lispobj *where, lispobj object)
+{
+ lispobj copy, *first_pointer;
+
+ /* Object is a pointer into from space - not a FP. */
+ copy = trans_boxed(object);
+
+ gc_assert(copy != object);
+
+ first_pointer = (lispobj *) PTR(object);
+
+ /* Set forwarding pointer. */
+ first_pointer[0] = 0x01;
+ first_pointer[1] = copy;
+ *where = copy;
+
+ return 1;
+}
+#endif
+\f
+/*
+ * lists and conses
+ */
+
+static lispobj trans_list(lispobj object);
+
+#if DIRECT_SCAV
+static int
+scav_list_pointer(lispobj *where, lispobj object)
+{
+ /* KLUDGE: There's lots of cut-and-paste duplication between this
+ * and scav_instance_pointer(..), scav_other_pointer(..), and
+ * perhaps other functions too. -- WHN 20000620 */
+
+ gc_assert(Pointerp(object));
+
+ if (from_space_p(object)) {
+ lispobj first, *first_pointer;
+
+ /* Object is a pointer into from space. Check to see whether it has
+ * been forwarded. */
+ first_pointer = (lispobj *) PTR(object);
+ first = *first_pointer;
+
+ if (first == 0x01) {
+ /* forwarded */
+ first = first_pointer[1];
+ } else {
+ first = trans_list(object);
+
+ /* Set forwarding pointer */
+ first_pointer[0] = 0x01;
+ first_pointer[1] = first;
+ }
+
+ gc_assert(Pointerp(first));
+ gc_assert(!from_space_p(first));
+ *where = first;
+ }
+ return 1;
+}
+#else
+static int
+scav_list_pointer(lispobj *where, lispobj object)
+{
+ lispobj first, *first_pointer;
+
+ gc_assert(Pointerp(object));
+
+ /* Object is a pointer into from space - not FP. */
+
+ first = trans_list(object);
+ gc_assert(first != object);
+
+ first_pointer = (lispobj *) PTR(object);
+
+ /* Set forwarding pointer */
+ first_pointer[0] = 0x01;
+ first_pointer[1] = first;
+
+ gc_assert(Pointerp(first));
+ gc_assert(!from_space_p(first));
+ *where = first;
+ return 1;
+}
+#endif
+
+static lispobj
+trans_list(lispobj object)
+{
+ lispobj new_list_pointer;
+ struct cons *cons, *new_cons;
+ int n = 0;
+ lispobj cdr;
+
+ gc_assert(from_space_p(object));
+
+ cons = (struct cons *) PTR(object);
+
+ /* Copy 'object'. */
+ new_cons = (struct cons *) gc_quick_alloc(sizeof(struct cons));
+ new_cons->car = cons->car;
+ new_cons->cdr = cons->cdr; /* updated later */
+ new_list_pointer = (lispobj)new_cons | LowtagOf(object);
+
+ /* Grab the cdr before it is clobbered. */
+ cdr = cons->cdr;
+
+ /* Set forwarding pointer (clobbers start of list). */
+ cons->car = 0x01;
+ cons->cdr = new_list_pointer;
+
+ /* Try to linearize the list in the cdr direction to help reduce
+ * paging. */
+ while (1) {
+ lispobj new_cdr;
+ struct cons *cdr_cons, *new_cdr_cons;
+
+ if (LowtagOf(cdr) != type_ListPointer || !from_space_p(cdr)
+ || (*((lispobj *)PTR(cdr)) == 0x01))
+ break;
+
+ cdr_cons = (struct cons *) PTR(cdr);
+
+ /* Copy 'cdr'. */
+ new_cdr_cons = (struct cons*) gc_quick_alloc(sizeof(struct cons));
+ new_cdr_cons->car = cdr_cons->car;
+ new_cdr_cons->cdr = cdr_cons->cdr;
+ new_cdr = (lispobj)new_cdr_cons | LowtagOf(cdr);
+
+ /* Grab the cdr before it is clobbered. */
+ cdr = cdr_cons->cdr;
+
+ /* Set forwarding pointer. */
+ cdr_cons->car = 0x01;
+ cdr_cons->cdr = new_cdr;
+
+ /* Update the cdr of the last cons copied into new space to
+ * keep the newspace scavenge from having to do it. */
+ new_cons->cdr = new_cdr;
+
+ new_cons = new_cdr_cons;
+ }
+
+ return new_list_pointer;
+}
+
+\f
+/*
+ * scavenging and transporting other pointers
+ */
+
+#if DIRECT_SCAV
+static int
+scav_other_pointer(lispobj *where, lispobj object)
+{
+ gc_assert(Pointerp(object));
+
+ if (from_space_p(object)) {
+ lispobj first, *first_pointer;
+
+ /* Object is a pointer into from space. Check to see */
+ /* whether it has been forwarded. */
+ first_pointer = (lispobj *) PTR(object);
+ first = *first_pointer;
+
+ if (first == 0x01) {
+ /* Forwarded. */
+ first = first_pointer[1];
+ *where = first;
+ } else {
+ first = (transother[TypeOf(first)])(object);
+
+ if (first != object) {
+ /* Set forwarding pointer */
+ first_pointer[0] = 0x01;
+ first_pointer[1] = first;
+ *where = first;
+ }
+ }
+
+ gc_assert(Pointerp(first));
+ gc_assert(!from_space_p(first));
+ }
+ return 1;
+}
+#else
+static int
+scav_other_pointer(lispobj *where, lispobj object)
+{
+ lispobj first, *first_pointer;
+
+ gc_assert(Pointerp(object));
+
+ /* Object is a pointer into from space - not FP. */
+ first_pointer = (lispobj *) PTR(object);
+
+ first = (transother[TypeOf(*first_pointer)])(object);
+
+ if (first != object) {
+ /* Set forwarding pointer. */
+ first_pointer[0] = 0x01;
+ first_pointer[1] = first;
+ *where = first;
+ }
+
+ gc_assert(Pointerp(first));
+ gc_assert(!from_space_p(first));
+
+ return 1;
+}
+#endif
+
+\f
+/*
+ * immediate, boxed, and unboxed objects
+ */
+
+static int
+size_pointer(lispobj *where)
+{
+ return 1;
+}
+
+static int
+scav_immediate(lispobj *where, lispobj object)
+{
+ return 1;
+}
+
+static lispobj
+trans_immediate(lispobj object)
+{
+ lose("trying to transport an immediate");
+ return NIL; /* bogus return value to satisfy static type checking */
+}
+
+static int
+size_immediate(lispobj *where)
+{
+ return 1;
+}
+
+
+static int
+scav_boxed(lispobj *where, lispobj object)
+{
+ return 1;
+}
+
+static lispobj
+trans_boxed(lispobj object)
+{
+ lispobj header;
+ unsigned long length;
+
+ gc_assert(Pointerp(object));
+
+ header = *((lispobj *) PTR(object));
+ length = HeaderValue(header) + 1;
+ length = CEILING(length, 2);
+
+ return copy_object(object, length);
+}
+
+static lispobj
+trans_boxed_large(lispobj object)
+{
+ lispobj header;
+ unsigned long length;
+
+ gc_assert(Pointerp(object));
+
+ header = *((lispobj *) PTR(object));
+ length = HeaderValue(header) + 1;
+ length = CEILING(length, 2);
+
+ return copy_large_object(object, length);
+}
+
+static int
+size_boxed(lispobj *where)
+{
+ lispobj header;
+ unsigned long length;
+
+ header = *where;
+ length = HeaderValue(header) + 1;
+ length = CEILING(length, 2);
+
+ return length;
+}
+
+static int
+scav_fdefn(lispobj *where, lispobj object)
+{
+ struct fdefn *fdefn;
+
+ fdefn = (struct fdefn *)where;
+
+ /* FSHOW((stderr, "scav_fdefn, function = %p, raw_addr = %p\n",
+ fdefn->function, fdefn->raw_addr)); */
+
+ if ((char *)(fdefn->function + RAW_ADDR_OFFSET) == fdefn->raw_addr) {
+ scavenge(where + 1, sizeof(struct fdefn)/sizeof(lispobj) - 1);
+
+ /* Don't write unnecessarily. */
+ if (fdefn->raw_addr != (char *)(fdefn->function + RAW_ADDR_OFFSET))
+ fdefn->raw_addr = (char *)(fdefn->function + RAW_ADDR_OFFSET);
+
+ return sizeof(struct fdefn) / sizeof(lispobj);
+ } else {
+ return 1;
+ }
+}
+
+static int
+scav_unboxed(lispobj *where, lispobj object)
+{
+ unsigned long length;
+
+ length = HeaderValue(object) + 1;
+ length = CEILING(length, 2);
+
+ return length;
+}
+
+static lispobj
+trans_unboxed(lispobj object)
+{
+ lispobj header;
+ unsigned long length;
+
+
+ gc_assert(Pointerp(object));
+
+ header = *((lispobj *) PTR(object));
+ length = HeaderValue(header) + 1;
+ length = CEILING(length, 2);
+
+ return copy_unboxed_object(object, length);
+}
+
+static lispobj
+trans_unboxed_large(lispobj object)
+{
+ lispobj header;
+ unsigned long length;
+
+
+ gc_assert(Pointerp(object));
+
+ header = *((lispobj *) PTR(object));
+ length = HeaderValue(header) + 1;
+ length = CEILING(length, 2);
+
+ return copy_large_unboxed_object(object, length);
+}
+
+static int
+size_unboxed(lispobj *where)
+{
+ lispobj header;
+ unsigned long length;
+
+ header = *where;
+ length = HeaderValue(header) + 1;
+ length = CEILING(length, 2);
+
+ return length;
+}
+\f
+/*
+ * vector-like objects
+ */
+
+#define NWORDS(x,y) (CEILING((x),(y)) / (y))
+
+static int
+scav_string(lispobj *where, lispobj object)
+{
+ struct vector *vector;
+ int length, nwords;
+
+ /* NOTE: Strings contain one more byte of data than the length */
+ /* slot indicates. */
+
+ vector = (struct vector *) where;
+ length = fixnum_value(vector->length) + 1;
+ nwords = CEILING(NWORDS(length, 4) + 2, 2);
+
+ return nwords;
+}
+
+static lispobj
+trans_string(lispobj object)
+{
+ struct vector *vector;
+ int length, nwords;
+
+ gc_assert(Pointerp(object));
+
+ /* NOTE: A string contains one more byte of data (a terminating
+ * '\0' to help when interfacing with C functions) than indicated
+ * by the length slot. */
+
+ vector = (struct vector *) PTR(object);
+ length = fixnum_value(vector->length) + 1;
+ nwords = CEILING(NWORDS(length, 4) + 2, 2);
+
+ return copy_large_unboxed_object(object, nwords);
+}
+
+static int
+size_string(lispobj *where)
+{
+ struct vector *vector;
+ int length, nwords;
+
+ /* NOTE: A string contains one more byte of data (a terminating
+ * '\0' to help when interfacing with C functions) than indicated
+ * by the length slot. */
+
+ vector = (struct vector *) where;
+ length = fixnum_value(vector->length) + 1;
+ nwords = CEILING(NWORDS(length, 4) + 2, 2);
+
+ return nwords;
+}
+
+/* FIXME: What does this mean? */
+int gencgc_hash = 1;
+
+static int
+scav_vector(lispobj *where, lispobj object)
+{
+ unsigned int kv_length;
+ lispobj *kv_vector;
+ unsigned int length;
+ lispobj *hash_table;
+ lispobj empty_symbol;
+ unsigned int *index_vector, *next_vector, *hash_vector;
+ lispobj weak_p_obj;
+ unsigned next_vector_length;
+
+ /* FIXME: A comment explaining this would be nice. It looks as
+ * though SB-VM:VECTOR-VALID-HASHING-SUBTYPE is set for EQ-based
+ * hash tables in the Lisp HASH-TABLE code, and nowhere else. */
+ if (HeaderValue(object) != subtype_VectorValidHashing)
+ return 1;
+
+ if (!gencgc_hash) {
+ /* This is set for backward compatibility. FIXME: Do we need
+ * this any more? */
+ *where = (subtype_VectorMustRehash << type_Bits) | type_SimpleVector;
+ return 1;
+ }
+
+ kv_length = fixnum_value(where[1]);
+ kv_vector = where + 2; /* Skip the header and length. */
+ /*FSHOW((stderr,"/kv_length = %d\n", kv_length));*/
+
+ /* Scavenge element 0, which may be a hash-table structure. */
+ scavenge(where+2, 1);
+ if (!Pointerp(where[2])) {
+ lose("no pointer at %x in hash table", where[2]);
+ }
+ hash_table = (lispobj *)PTR(where[2]);
+ /*FSHOW((stderr,"/hash_table = %x\n", hash_table));*/
+ if (TypeOf(hash_table[0]) != type_InstanceHeader) {
+ lose("hash table not instance (%x at %x)", hash_table[0], hash_table);
+ }
+
+ /* Scavenge element 1, which should be some internal symbol that
+ * the hash table code reserves for marking empty slots. */
+ scavenge(where+3, 1);
+ if (!Pointerp(where[3])) {
+ lose("not #:%EMPTY-HT-SLOT% symbol pointer: %x", where[3]);
+ }
+ empty_symbol = where[3];
+ /* fprintf(stderr,"* empty_symbol = %x\n", empty_symbol);*/
+ if (TypeOf(*(lispobj *)PTR(empty_symbol)) != type_SymbolHeader) {
+ lose("not a symbol where #:%EMPTY-HT-SLOT% expected: %x",
+ *(lispobj *)PTR(empty_symbol));
+ }
+
+ /* Scavenge hash table, which will fix the positions of the other
+ * needed objects. */
+ scavenge(hash_table, 16);
+
+ /* Cross-check the kv_vector. */
+ if (where != (lispobj *)PTR(hash_table[9])) {
+ lose("hash_table table!=this table %x", hash_table[9]);
+ }
+
+ /* WEAK-P */
+ weak_p_obj = hash_table[10];
+
+ /* index vector */
+ {
+ lispobj index_vector_obj = hash_table[13];
+
+ if (Pointerp(index_vector_obj) &&
+ (TypeOf(*(lispobj *)PTR(index_vector_obj)) == type_SimpleArrayUnsignedByte32)) {
+ index_vector = ((unsigned int *)PTR(index_vector_obj)) + 2;
+ /*FSHOW((stderr, "/index_vector = %x\n",index_vector));*/
+ length = fixnum_value(((unsigned int *)PTR(index_vector_obj))[1]);
+ /*FSHOW((stderr, "/length = %d\n", length));*/
+ } else {
+ lose("invalid index_vector %x", index_vector_obj);
+ }
+ }
+
+ /* next vector */
+ {
+ lispobj next_vector_obj = hash_table[14];
+
+ if (Pointerp(next_vector_obj) &&
+ (TypeOf(*(lispobj *)PTR(next_vector_obj)) == type_SimpleArrayUnsignedByte32)) {
+ next_vector = ((unsigned int *)PTR(next_vector_obj)) + 2;
+ /*FSHOW((stderr, "/next_vector = %x\n", next_vector));*/
+ next_vector_length = fixnum_value(((unsigned int *)PTR(next_vector_obj))[1]);
+ /*FSHOW((stderr, "/next_vector_length = %d\n", next_vector_length));*/
+ } else {
+ lose("invalid next_vector %x", next_vector_obj);
+ }
+ }
+
+ /* maybe hash vector */
+ {
+ /* FIXME: This bare "15" offset should become a symbolic
+ * expression of some sort. And all the other bare offsets
+ * too. And the bare "16" in scavenge(hash_table, 16). And
+ * probably other stuff too. Ugh.. */
+ lispobj hash_vector_obj = hash_table[15];
+
+ if (Pointerp(hash_vector_obj) &&
+ (TypeOf(*(lispobj *)PTR(hash_vector_obj))
+ == type_SimpleArrayUnsignedByte32)) {
+ hash_vector = ((unsigned int *)PTR(hash_vector_obj)) + 2;
+ /*FSHOW((stderr, "/hash_vector = %x\n", hash_vector));*/
+ gc_assert(fixnum_value(((unsigned int *)PTR(hash_vector_obj))[1])
+ == next_vector_length);
+ } else {
+ hash_vector = NULL;
+ /*FSHOW((stderr, "/no hash_vector: %x\n", hash_vector_obj));*/
+ }
+ }
+
+ /* These lengths could be different as the index_vector can be a
+ * different length from the others, a larger index_vector could help
+ * reduce collisions. */
+ gc_assert(next_vector_length*2 == kv_length);
+
+ /* now all set up.. */
+
+ /* Work through the KV vector. */
+ {
+ int i;
+ for (i = 1; i < next_vector_length; i++) {
+ lispobj old_key = kv_vector[2*i];
+ unsigned int old_index = (old_key & 0x1fffffff)%length;
+
+ /* Scavenge the key and value. */
+ scavenge(&kv_vector[2*i],2);
+
+ /* Check whether the key has moved and is EQ based. */
+ {
+ lispobj new_key = kv_vector[2*i];
+ unsigned int new_index = (new_key & 0x1fffffff)%length;
+
+ if ((old_index != new_index) &&
+ ((!hash_vector) || (hash_vector[i] == 0x80000000)) &&
+ ((new_key != empty_symbol) ||
+ (kv_vector[2*i] != empty_symbol))) {
+
+ /*FSHOW((stderr,
+ "* EQ key %d moved from %x to %x; index %d to %d\n",
+ i, old_key, new_key, old_index, new_index));*/
+
+ if (index_vector[old_index] != 0) {
+ /*FSHOW((stderr, "/P1 %d\n", index_vector[old_index]));*/
+
+ /* Unlink the key from the old_index chain. */
+ if (index_vector[old_index] == i) {
+ /*FSHOW((stderr, "/P2a %d\n", next_vector[i]));*/
+ index_vector[old_index] = next_vector[i];
+ /* Link it into the needing rehash chain. */
+ next_vector[i] = fixnum_value(hash_table[11]);
+ hash_table[11] = make_fixnum(i);
+ /*SHOW("P2");*/
+ } else {
+ unsigned prior = index_vector[old_index];
+ unsigned next = next_vector[prior];
+
+ /*FSHOW((stderr, "/P3a %d %d\n", prior, next));*/
+
+ while (next != 0) {
+ /*FSHOW((stderr, "/P3b %d %d\n", prior, next));*/
+ if (next == i) {
+ /* Unlink it. */
+ next_vector[prior] = next_vector[next];
+ /* Link it into the needing rehash
+ * chain. */
+ next_vector[next] =
+ fixnum_value(hash_table[11]);
+ hash_table[11] = make_fixnum(next);
+ /*SHOW("/P3");*/
+ break;
+ }
+ prior = next;
+ next = next_vector[next];
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ return (CEILING(kv_length + 2, 2));
+}
+
+static lispobj
+trans_vector(lispobj object)
+{
+ struct vector *vector;
+ int length, nwords;
+
+ gc_assert(Pointerp(object));
+
+ vector = (struct vector *) PTR(object);
+
+ length = fixnum_value(vector->length);
+ nwords = CEILING(length + 2, 2);
+
+ return copy_large_object(object, nwords);
+}
+
+static int
+size_vector(lispobj *where)
+{
+ struct vector *vector;
+ int length, nwords;
+
+ vector = (struct vector *) where;
+ length = fixnum_value(vector->length);
+ nwords = CEILING(length + 2, 2);
+
+ return nwords;
+}
+
+
+static int
+scav_vector_bit(lispobj *where, lispobj object)
+{
+ struct vector *vector;
+ int length, nwords;
+
+ vector = (struct vector *) where;
+ length = fixnum_value(vector->length);
+ nwords = CEILING(NWORDS(length, 32) + 2, 2);
+
+ return nwords;
+}
+
+static lispobj
+trans_vector_bit(lispobj object)
+{
+ struct vector *vector;
+ int length, nwords;
+
+ gc_assert(Pointerp(object));
+
+ vector = (struct vector *) PTR(object);
+ length = fixnum_value(vector->length);
+ nwords = CEILING(NWORDS(length, 32) + 2, 2);
+
+ return copy_large_unboxed_object(object, nwords);
+}
+
+static int
+size_vector_bit(lispobj *where)
+{
+ struct vector *vector;
+ int length, nwords;
+
+ vector = (struct vector *) where;
+ length = fixnum_value(vector->length);
+ nwords = CEILING(NWORDS(length, 32) + 2, 2);
+
+ return nwords;
+}
+
+
+static int
+scav_vector_unsigned_byte_2(lispobj *where, lispobj object)
+{
+ struct vector *vector;
+ int length, nwords;
+
+ vector = (struct vector *) where;
+ length = fixnum_value(vector->length);
+ nwords = CEILING(NWORDS(length, 16) + 2, 2);
+
+ return nwords;
+}
+
+static lispobj
+trans_vector_unsigned_byte_2(lispobj object)
+{
+ struct vector *vector;
+ int length, nwords;
+
+ gc_assert(Pointerp(object));
+
+ vector = (struct vector *) PTR(object);
+ length = fixnum_value(vector->length);
+ nwords = CEILING(NWORDS(length, 16) + 2, 2);
+
+ return copy_large_unboxed_object(object, nwords);
+}
+
+static int
+size_vector_unsigned_byte_2(lispobj *where)
+{
+ struct vector *vector;
+ int length, nwords;
+
+ vector = (struct vector *) where;
+ length = fixnum_value(vector->length);
+ nwords = CEILING(NWORDS(length, 16) + 2, 2);
+
+ return nwords;
+}
+
+
+static int
+scav_vector_unsigned_byte_4(lispobj *where, lispobj object)
+{
+ struct vector *vector;
+ int length, nwords;
+
+ vector = (struct vector *) where;
+ length = fixnum_value(vector->length);
+ nwords = CEILING(NWORDS(length, 8) + 2, 2);
+
+ return nwords;
+}
+
+static lispobj
+trans_vector_unsigned_byte_4(lispobj object)
+{
+ struct vector *vector;
+ int length, nwords;
+
+ gc_assert(Pointerp(object));
+
+ vector = (struct vector *) PTR(object);
+ length = fixnum_value(vector->length);
+ nwords = CEILING(NWORDS(length, 8) + 2, 2);
+
+ return copy_large_unboxed_object(object, nwords);
+}
+
+static int
+size_vector_unsigned_byte_4(lispobj *where)
+{
+ struct vector *vector;
+ int length, nwords;
+
+ vector = (struct vector *) where;
+ length = fixnum_value(vector->length);
+ nwords = CEILING(NWORDS(length, 8) + 2, 2);
+
+ return nwords;
+}
+
+static int
+scav_vector_unsigned_byte_8(lispobj *where, lispobj object)
+{
+ struct vector *vector;
+ int length, nwords;
+
+ vector = (struct vector *) where;
+ length = fixnum_value(vector->length);
+ nwords = CEILING(NWORDS(length, 4) + 2, 2);
+
+ return nwords;
+}
+
+static lispobj
+trans_vector_unsigned_byte_8(lispobj object)
+{
+ struct vector *vector;
+ int length, nwords;
+
+ gc_assert(Pointerp(object));
+
+ vector = (struct vector *) PTR(object);
+ length = fixnum_value(vector->length);
+ nwords = CEILING(NWORDS(length, 4) + 2, 2);
+
+ return copy_large_unboxed_object(object, nwords);
+}
+
+static int
+size_vector_unsigned_byte_8(lispobj *where)
+{
+ struct vector *vector;
+ int length, nwords;
+
+ vector = (struct vector *) where;
+ length = fixnum_value(vector->length);
+ nwords = CEILING(NWORDS(length, 4) + 2, 2);
+
+ return nwords;
+}
+
+
+static int
+scav_vector_unsigned_byte_16(lispobj *where, lispobj object)
+{
+ struct vector *vector;
+ int length, nwords;
+
+ vector = (struct vector *) where;
+ length = fixnum_value(vector->length);
+ nwords = CEILING(NWORDS(length, 2) + 2, 2);
+
+ return nwords;
+}
+
+static lispobj
+trans_vector_unsigned_byte_16(lispobj object)
+{
+ struct vector *vector;
+ int length, nwords;
+
+ gc_assert(Pointerp(object));
+
+ vector = (struct vector *) PTR(object);
+ length = fixnum_value(vector->length);
+ nwords = CEILING(NWORDS(length, 2) + 2, 2);
+
+ return copy_large_unboxed_object(object, nwords);
+}
+
+static int
+size_vector_unsigned_byte_16(lispobj *where)
+{
+ struct vector *vector;
+ int length, nwords;
+
+ vector = (struct vector *) where;
+ length = fixnum_value(vector->length);
+ nwords = CEILING(NWORDS(length, 2) + 2, 2);
+
+ return nwords;
+}
+
+static int
+scav_vector_unsigned_byte_32(lispobj *where, lispobj object)
+{
+ struct vector *vector;
+ int length, nwords;
+
+ vector = (struct vector *) where;
+ length = fixnum_value(vector->length);
+ nwords = CEILING(length + 2, 2);
+
+ return nwords;
+}
+
+static lispobj
+trans_vector_unsigned_byte_32(lispobj object)
+{
+ struct vector *vector;
+ int length, nwords;
+
+ gc_assert(Pointerp(object));
+
+ vector = (struct vector *) PTR(object);
+ length = fixnum_value(vector->length);
+ nwords = CEILING(length + 2, 2);
+
+ return copy_large_unboxed_object(object, nwords);
+}
+
+static int
+size_vector_unsigned_byte_32(lispobj *where)
+{
+ struct vector *vector;
+ int length, nwords;
+
+ vector = (struct vector *) where;
+ length = fixnum_value(vector->length);
+ nwords = CEILING(length + 2, 2);
+
+ return nwords;
+}
+
+static int
+scav_vector_single_float(lispobj *where, lispobj object)
+{
+ struct vector *vector;
+ int length, nwords;
+
+ vector = (struct vector *) where;
+ length = fixnum_value(vector->length);
+ nwords = CEILING(length + 2, 2);
+
+ return nwords;
+}
+
+static lispobj
+trans_vector_single_float(lispobj object)
+{
+ struct vector *vector;
+ int length, nwords;
+
+ gc_assert(Pointerp(object));
+
+ vector = (struct vector *) PTR(object);
+ length = fixnum_value(vector->length);
+ nwords = CEILING(length + 2, 2);
+
+ return copy_large_unboxed_object(object, nwords);
+}
+
+static int
+size_vector_single_float(lispobj *where)
+{
+ struct vector *vector;
+ int length, nwords;
+
+ vector = (struct vector *) where;
+ length = fixnum_value(vector->length);
+ nwords = CEILING(length + 2, 2);
+
+ return nwords;
+}
+
+static int
+scav_vector_double_float(lispobj *where, lispobj object)
+{
+ struct vector *vector;
+ int length, nwords;
+
+ vector = (struct vector *) where;
+ length = fixnum_value(vector->length);
+ nwords = CEILING(length * 2 + 2, 2);
+
+ return nwords;
+}
+
+static lispobj
+trans_vector_double_float(lispobj object)
+{
+ struct vector *vector;
+ int length, nwords;
+
+ gc_assert(Pointerp(object));
+
+ vector = (struct vector *) PTR(object);
+ length = fixnum_value(vector->length);
+ nwords = CEILING(length * 2 + 2, 2);
+
+ return copy_large_unboxed_object(object, nwords);
+}
+
+static int
+size_vector_double_float(lispobj *where)
+{
+ struct vector *vector;
+ int length, nwords;
+
+ vector = (struct vector *) where;
+ length = fixnum_value(vector->length);
+ nwords = CEILING(length * 2 + 2, 2);
+
+ return nwords;
+}
+
+#ifdef type_SimpleArrayLongFloat
+static int
+scav_vector_long_float(lispobj *where, lispobj object)
+{
+ struct vector *vector;
+ int length, nwords;
+
+ vector = (struct vector *) where;
+ length = fixnum_value(vector->length);
+ nwords = CEILING(length * 3 + 2, 2);
+
+ return nwords;
+}
+
+static lispobj
+trans_vector_long_float(lispobj object)
+{
+ struct vector *vector;
+ int length, nwords;
+
+ gc_assert(Pointerp(object));
+
+ vector = (struct vector *) PTR(object);
+ length = fixnum_value(vector->length);
+ nwords = CEILING(length * 3 + 2, 2);
+
+ return copy_large_unboxed_object(object, nwords);
+}
+
+static int
+size_vector_long_float(lispobj *where)
+{
+ struct vector *vector;
+ int length, nwords;
+
+ vector = (struct vector *) where;
+ length = fixnum_value(vector->length);
+ nwords = CEILING(length * 3 + 2, 2);
+
+ return nwords;
+}
+#endif
+
+
+#ifdef type_SimpleArrayComplexSingleFloat
+static int
+scav_vector_complex_single_float(lispobj *where, lispobj object)
+{
+ struct vector *vector;
+ int length, nwords;
+
+ vector = (struct vector *) where;
+ length = fixnum_value(vector->length);
+ nwords = CEILING(length * 2 + 2, 2);
+
+ return nwords;
+}
+
+static lispobj
+trans_vector_complex_single_float(lispobj object)
+{
+ struct vector *vector;
+ int length, nwords;
+
+ gc_assert(Pointerp(object));
+
+ vector = (struct vector *) PTR(object);
+ length = fixnum_value(vector->length);
+ nwords = CEILING(length * 2 + 2, 2);
+
+ return copy_large_unboxed_object(object, nwords);
+}
+
+static int
+size_vector_complex_single_float(lispobj *where)
+{
+ struct vector *vector;
+ int length, nwords;
+
+ vector = (struct vector *) where;
+ length = fixnum_value(vector->length);
+ nwords = CEILING(length * 2 + 2, 2);
+
+ return nwords;
+}
+#endif
+
+#ifdef type_SimpleArrayComplexDoubleFloat
+static int
+scav_vector_complex_double_float(lispobj *where, lispobj object)
+{
+ struct vector *vector;
+ int length, nwords;
+
+ vector = (struct vector *) where;
+ length = fixnum_value(vector->length);
+ nwords = CEILING(length * 4 + 2, 2);
+
+ return nwords;
+}
+
+static lispobj
+trans_vector_complex_double_float(lispobj object)
+{
+ struct vector *vector;
+ int length, nwords;
+
+ gc_assert(Pointerp(object));
+
+ vector = (struct vector *) PTR(object);
+ length = fixnum_value(vector->length);
+ nwords = CEILING(length * 4 + 2, 2);
+
+ return copy_large_unboxed_object(object, nwords);
+}
+
+static int
+size_vector_complex_double_float(lispobj *where)
+{
+ struct vector *vector;
+ int length, nwords;
+
+ vector = (struct vector *) where;
+ length = fixnum_value(vector->length);
+ nwords = CEILING(length * 4 + 2, 2);
+
+ return nwords;
+}
+#endif
+
+
+#ifdef type_SimpleArrayComplexLongFloat
+static int
+scav_vector_complex_long_float(lispobj *where, lispobj object)
+{
+ struct vector *vector;
+ int length, nwords;
+
+ vector = (struct vector *) where;
+ length = fixnum_value(vector->length);
+ nwords = CEILING(length * 6 + 2, 2);
+
+ return nwords;
+}
+
+static lispobj
+trans_vector_complex_long_float(lispobj object)
+{
+ struct vector *vector;
+ int length, nwords;
+
+ gc_assert(Pointerp(object));
+
+ vector = (struct vector *) PTR(object);
+ length = fixnum_value(vector->length);
+ nwords = CEILING(length * 6 + 2, 2);
+
+ return copy_large_unboxed_object(object, nwords);
+}
+
+static int
+size_vector_complex_long_float(lispobj *where)
+{
+ struct vector *vector;
+ int length, nwords;
+
+ vector = (struct vector *) where;
+ length = fixnum_value(vector->length);
+ nwords = CEILING(length * 6 + 2, 2);
+
+ return nwords;
+}
+#endif
+
+\f
+/*
+ * weak pointers
+ */
+
+/* XX This is a hack adapted from cgc.c. These don't work too well with the
+ * gencgc as a list of the weak pointers is maintained within the
+ * objects which causes writes to the pages. A limited attempt is made
+ * to avoid unnecessary writes, but this needs a re-think. */
+
+#define WEAK_POINTER_NWORDS \
+ CEILING((sizeof(struct weak_pointer) / sizeof(lispobj)), 2)
+
+static int
+scav_weak_pointer(lispobj *where, lispobj object)
+{
+ struct weak_pointer *wp = weak_pointers;
+ /* Push the weak pointer onto the list of weak pointers.
+ * Do I have to watch for duplicates? Originally this was
+ * part of trans_weak_pointer but that didn't work in the
+ * case where the WP was in a promoted region.
+ */
+
+ /* Check whether it's already in the list. */
+ while (wp != NULL) {
+ if (wp == (struct weak_pointer*)where) {
+ break;
+ }
+ wp = wp->next;
+ }
+ if (wp == NULL) {
+ /* Add it to the start of the list. */
+ wp = (struct weak_pointer*)where;
+ if (wp->next != weak_pointers) {
+ wp->next = weak_pointers;
+ } else {
+ /*SHOW("avoided write to weak pointer");*/
+ }
+ weak_pointers = wp;
+ }
+
+ /* Do not let GC scavenge the value slot of the weak pointer.
+ * (That is why it is a weak pointer.) */
+
+ return WEAK_POINTER_NWORDS;
+}
+
+static lispobj
+trans_weak_pointer(lispobj object)
+{
+ lispobj copy;
+ struct weak_pointer *wp;
+
+ gc_assert(Pointerp(object));
+
+#if defined(DEBUG_WEAK)
+ FSHOW((stderr, "Transporting weak pointer from 0x%08x\n", object));
+#endif
+
+ /* Need to remember where all the weak pointers are that have */
+ /* been transported so they can be fixed up in a post-GC pass. */
+
+ copy = copy_object(object, WEAK_POINTER_NWORDS);
+ /* wp = (struct weak_pointer *) PTR(copy);*/
+
+
+ /* Push the weak pointer onto the list of weak pointers. */
+ /* wp->next = weak_pointers;
+ * weak_pointers = wp;*/
+
+ return copy;
+}
+
+static int
+size_weak_pointer(lispobj *where)
+{
+ return WEAK_POINTER_NWORDS;
+}
+
+void scan_weak_pointers(void)
+{
+ struct weak_pointer *wp;
+ for (wp = weak_pointers; wp != NULL; wp = wp->next) {
+ lispobj value = wp->value;
+ lispobj first, *first_pointer;
+
+ first_pointer = (lispobj *)PTR(value);
+
+ /*
+ FSHOW((stderr, "/weak pointer at 0x%08x\n", (unsigned long) wp));
+ FSHOW((stderr, "/value: 0x%08x\n", (unsigned long) value));
+ */
+
+ if (Pointerp(value) && from_space_p(value)) {
+ /* Now, we need to check whether the object has been forwarded. If
+ * it has been, the weak pointer is still good and needs to be
+ * updated. Otherwise, the weak pointer needs to be nil'ed
+ * out. */
+ if (first_pointer[0] == 0x01) {
+ wp->value = first_pointer[1];
+ } else {
+ /* Break it. */
+ SHOW("broken");
+ wp->value = NIL;
+ wp->broken = T;
+ }
+ }
+ }
+}
+\f
+/*
+ * initialization
+ */
+
+static int
+scav_lose(lispobj *where, lispobj object)
+{
+ lose("no scavenge function for object 0x%08x", (unsigned long) object);
+ return 0; /* bogus return value to satisfy static type checking */
+}
+
+static lispobj
+trans_lose(lispobj object)
+{
+ lose("no transport function for object 0x%08x", (unsigned long) object);
+ return NIL; /* bogus return value to satisfy static type checking */
+}
+
+static int
+size_lose(lispobj *where)
+{
+ lose("no size function for object at 0x%08x", (unsigned long) where);
+ return 1; /* bogus return value to satisfy static type checking */
+}
+
+static void
+gc_init_tables(void)
+{
+ int i;
+
+ /* Set default value in all slots of scavenge table. */
+ for (i = 0; i < 256; i++) { /* FIXME: bare constant length, ick! */
+ scavtab[i] = scav_lose;
+ }
+
+ /* For each type which can be selected by the low 3 bits of the tag
+ * alone, set multiple entries in our 8-bit scavenge table (one for each
+ * possible value of the high 5 bits). */
+ for (i = 0; i < 32; i++) { /* FIXME: bare constant length, ick! */
+ scavtab[type_EvenFixnum|(i<<3)] = scav_immediate;
+ scavtab[type_FunctionPointer|(i<<3)] = scav_function_pointer;
+ /* OtherImmediate0 */
+ scavtab[type_ListPointer|(i<<3)] = scav_list_pointer;
+ scavtab[type_OddFixnum|(i<<3)] = scav_immediate;
+ scavtab[type_InstancePointer|(i<<3)] = scav_instance_pointer;
+ /* OtherImmediate1 */
+ scavtab[type_OtherPointer|(i<<3)] = scav_other_pointer;
+ }
+
+ /* Other-pointer types (those selected by all eight bits of the tag) get
+ * one entry each in the scavenge table. */
+ scavtab[type_Bignum] = scav_unboxed;
+ scavtab[type_Ratio] = scav_boxed;
+ scavtab[type_SingleFloat] = scav_unboxed;
+ scavtab[type_DoubleFloat] = scav_unboxed;
+#ifdef type_LongFloat
+ scavtab[type_LongFloat] = scav_unboxed;
+#endif
+ scavtab[type_Complex] = scav_boxed;
+#ifdef type_ComplexSingleFloat
+ scavtab[type_ComplexSingleFloat] = scav_unboxed;
+#endif
+#ifdef type_ComplexDoubleFloat
+ scavtab[type_ComplexDoubleFloat] = scav_unboxed;
+#endif
+#ifdef type_ComplexLongFloat
+ scavtab[type_ComplexLongFloat] = scav_unboxed;
+#endif
+ scavtab[type_SimpleArray] = scav_boxed;
+ scavtab[type_SimpleString] = scav_string;
+ scavtab[type_SimpleBitVector] = scav_vector_bit;
+ scavtab[type_SimpleVector] = scav_vector;
+ scavtab[type_SimpleArrayUnsignedByte2] = scav_vector_unsigned_byte_2;
+ scavtab[type_SimpleArrayUnsignedByte4] = scav_vector_unsigned_byte_4;
+ scavtab[type_SimpleArrayUnsignedByte8] = scav_vector_unsigned_byte_8;
+ scavtab[type_SimpleArrayUnsignedByte16] = scav_vector_unsigned_byte_16;
+ scavtab[type_SimpleArrayUnsignedByte32] = scav_vector_unsigned_byte_32;
+#ifdef type_SimpleArraySignedByte8
+ scavtab[type_SimpleArraySignedByte8] = scav_vector_unsigned_byte_8;
+#endif
+#ifdef type_SimpleArraySignedByte16
+ scavtab[type_SimpleArraySignedByte16] = scav_vector_unsigned_byte_16;
+#endif
+#ifdef type_SimpleArraySignedByte30
+ scavtab[type_SimpleArraySignedByte30] = scav_vector_unsigned_byte_32;
+#endif
+#ifdef type_SimpleArraySignedByte32
+ scavtab[type_SimpleArraySignedByte32] = scav_vector_unsigned_byte_32;
+#endif
+ scavtab[type_SimpleArraySingleFloat] = scav_vector_single_float;
+ scavtab[type_SimpleArrayDoubleFloat] = scav_vector_double_float;
+#ifdef type_SimpleArrayLongFloat
+ scavtab[type_SimpleArrayLongFloat] = scav_vector_long_float;
+#endif
+#ifdef type_SimpleArrayComplexSingleFloat
+ scavtab[type_SimpleArrayComplexSingleFloat] = scav_vector_complex_single_float;
+#endif
+#ifdef type_SimpleArrayComplexDoubleFloat
+ scavtab[type_SimpleArrayComplexDoubleFloat] = scav_vector_complex_double_float;
+#endif
+#ifdef type_SimpleArrayComplexLongFloat
+ scavtab[type_SimpleArrayComplexLongFloat] = scav_vector_complex_long_float;
+#endif
+ scavtab[type_ComplexString] = scav_boxed;
+ scavtab[type_ComplexBitVector] = scav_boxed;
+ scavtab[type_ComplexVector] = scav_boxed;
+ scavtab[type_ComplexArray] = scav_boxed;
+ scavtab[type_CodeHeader] = scav_code_header;
+ /*scavtab[type_FunctionHeader] = scav_function_header;*/
+ /*scavtab[type_ClosureFunctionHeader] = scav_function_header;*/
+ /*scavtab[type_ReturnPcHeader] = scav_return_pc_header;*/
+#ifdef __i386__
+ scavtab[type_ClosureHeader] = scav_closure_header;
+ scavtab[type_FuncallableInstanceHeader] = scav_closure_header;
+ scavtab[type_ByteCodeFunction] = scav_closure_header;
+ scavtab[type_ByteCodeClosure] = scav_closure_header;
+#else
+ scavtab[type_ClosureHeader] = scav_boxed;
+ scavtab[type_FuncallableInstanceHeader] = scav_boxed;
+ scavtab[type_ByteCodeFunction] = scav_boxed;
+ scavtab[type_ByteCodeClosure] = scav_boxed;
+#endif
+ scavtab[type_ValueCellHeader] = scav_boxed;
+ scavtab[type_SymbolHeader] = scav_boxed;
+ scavtab[type_BaseChar] = scav_immediate;
+ scavtab[type_Sap] = scav_unboxed;
+ scavtab[type_UnboundMarker] = scav_immediate;
+ scavtab[type_WeakPointer] = scav_weak_pointer;
+ scavtab[type_InstanceHeader] = scav_boxed;
+ scavtab[type_Fdefn] = scav_fdefn;
+
+ /* transport other table, initialized same way as scavtab */
+ for (i = 0; i < 256; i++)
+ transother[i] = trans_lose;
+ transother[type_Bignum] = trans_unboxed;
+ transother[type_Ratio] = trans_boxed;
+ transother[type_SingleFloat] = trans_unboxed;
+ transother[type_DoubleFloat] = trans_unboxed;
+#ifdef type_LongFloat
+ transother[type_LongFloat] = trans_unboxed;
+#endif
+ transother[type_Complex] = trans_boxed;
+#ifdef type_ComplexSingleFloat
+ transother[type_ComplexSingleFloat] = trans_unboxed;
+#endif
+#ifdef type_ComplexDoubleFloat
+ transother[type_ComplexDoubleFloat] = trans_unboxed;
+#endif
+#ifdef type_ComplexLongFloat
+ transother[type_ComplexLongFloat] = trans_unboxed;
+#endif
+ transother[type_SimpleArray] = trans_boxed_large;
+ transother[type_SimpleString] = trans_string;
+ transother[type_SimpleBitVector] = trans_vector_bit;
+ transother[type_SimpleVector] = trans_vector;
+ transother[type_SimpleArrayUnsignedByte2] = trans_vector_unsigned_byte_2;
+ transother[type_SimpleArrayUnsignedByte4] = trans_vector_unsigned_byte_4;
+ transother[type_SimpleArrayUnsignedByte8] = trans_vector_unsigned_byte_8;
+ transother[type_SimpleArrayUnsignedByte16] = trans_vector_unsigned_byte_16;
+ transother[type_SimpleArrayUnsignedByte32] = trans_vector_unsigned_byte_32;
+#ifdef type_SimpleArraySignedByte8
+ transother[type_SimpleArraySignedByte8] = trans_vector_unsigned_byte_8;
+#endif
+#ifdef type_SimpleArraySignedByte16
+ transother[type_SimpleArraySignedByte16] = trans_vector_unsigned_byte_16;
+#endif
+#ifdef type_SimpleArraySignedByte30
+ transother[type_SimpleArraySignedByte30] = trans_vector_unsigned_byte_32;
+#endif
+#ifdef type_SimpleArraySignedByte32
+ transother[type_SimpleArraySignedByte32] = trans_vector_unsigned_byte_32;
+#endif
+ transother[type_SimpleArraySingleFloat] = trans_vector_single_float;
+ transother[type_SimpleArrayDoubleFloat] = trans_vector_double_float;
+#ifdef type_SimpleArrayLongFloat
+ transother[type_SimpleArrayLongFloat] = trans_vector_long_float;
+#endif
+#ifdef type_SimpleArrayComplexSingleFloat
+ transother[type_SimpleArrayComplexSingleFloat] = trans_vector_complex_single_float;
+#endif
+#ifdef type_SimpleArrayComplexDoubleFloat
+ transother[type_SimpleArrayComplexDoubleFloat] = trans_vector_complex_double_float;
+#endif
+#ifdef type_SimpleArrayComplexLongFloat
+ transother[type_SimpleArrayComplexLongFloat] = trans_vector_complex_long_float;
+#endif
+ transother[type_ComplexString] = trans_boxed;
+ transother[type_ComplexBitVector] = trans_boxed;
+ transother[type_ComplexVector] = trans_boxed;
+ transother[type_ComplexArray] = trans_boxed;
+ transother[type_CodeHeader] = trans_code_header;
+ transother[type_FunctionHeader] = trans_function_header;
+ transother[type_ClosureFunctionHeader] = trans_function_header;
+ transother[type_ReturnPcHeader] = trans_return_pc_header;
+ transother[type_ClosureHeader] = trans_boxed;
+ transother[type_FuncallableInstanceHeader] = trans_boxed;
+ transother[type_ByteCodeFunction] = trans_boxed;
+ transother[type_ByteCodeClosure] = trans_boxed;
+ transother[type_ValueCellHeader] = trans_boxed;
+ transother[type_SymbolHeader] = trans_boxed;
+ transother[type_BaseChar] = trans_immediate;
+ transother[type_Sap] = trans_unboxed;
+ transother[type_UnboundMarker] = trans_immediate;
+ transother[type_WeakPointer] = trans_weak_pointer;
+ transother[type_InstanceHeader] = trans_boxed;
+ transother[type_Fdefn] = trans_boxed;
+
+ /* size table, initialized the same way as scavtab */
+ for (i = 0; i < 256; i++)
+ sizetab[i] = size_lose;
+ for (i = 0; i < 32; i++) {
+ sizetab[type_EvenFixnum|(i<<3)] = size_immediate;
+ sizetab[type_FunctionPointer|(i<<3)] = size_pointer;
+ /* OtherImmediate0 */
+ sizetab[type_ListPointer|(i<<3)] = size_pointer;
+ sizetab[type_OddFixnum|(i<<3)] = size_immediate;
+ sizetab[type_InstancePointer|(i<<3)] = size_pointer;
+ /* OtherImmediate1 */
+ sizetab[type_OtherPointer|(i<<3)] = size_pointer;
+ }
+ sizetab[type_Bignum] = size_unboxed;
+ sizetab[type_Ratio] = size_boxed;
+ sizetab[type_SingleFloat] = size_unboxed;
+ sizetab[type_DoubleFloat] = size_unboxed;
+#ifdef type_LongFloat
+ sizetab[type_LongFloat] = size_unboxed;
+#endif
+ sizetab[type_Complex] = size_boxed;
+#ifdef type_ComplexSingleFloat
+ sizetab[type_ComplexSingleFloat] = size_unboxed;
+#endif
+#ifdef type_ComplexDoubleFloat
+ sizetab[type_ComplexDoubleFloat] = size_unboxed;
+#endif
+#ifdef type_ComplexLongFloat
+ sizetab[type_ComplexLongFloat] = size_unboxed;
+#endif
+ sizetab[type_SimpleArray] = size_boxed;
+ sizetab[type_SimpleString] = size_string;
+ sizetab[type_SimpleBitVector] = size_vector_bit;
+ sizetab[type_SimpleVector] = size_vector;
+ sizetab[type_SimpleArrayUnsignedByte2] = size_vector_unsigned_byte_2;
+ sizetab[type_SimpleArrayUnsignedByte4] = size_vector_unsigned_byte_4;
+ sizetab[type_SimpleArrayUnsignedByte8] = size_vector_unsigned_byte_8;
+ sizetab[type_SimpleArrayUnsignedByte16] = size_vector_unsigned_byte_16;
+ sizetab[type_SimpleArrayUnsignedByte32] = size_vector_unsigned_byte_32;
+#ifdef type_SimpleArraySignedByte8
+ sizetab[type_SimpleArraySignedByte8] = size_vector_unsigned_byte_8;
+#endif
+#ifdef type_SimpleArraySignedByte16
+ sizetab[type_SimpleArraySignedByte16] = size_vector_unsigned_byte_16;
+#endif
+#ifdef type_SimpleArraySignedByte30
+ sizetab[type_SimpleArraySignedByte30] = size_vector_unsigned_byte_32;
+#endif
+#ifdef type_SimpleArraySignedByte32
+ sizetab[type_SimpleArraySignedByte32] = size_vector_unsigned_byte_32;
+#endif
+ sizetab[type_SimpleArraySingleFloat] = size_vector_single_float;
+ sizetab[type_SimpleArrayDoubleFloat] = size_vector_double_float;
+#ifdef type_SimpleArrayLongFloat
+ sizetab[type_SimpleArrayLongFloat] = size_vector_long_float;
+#endif
+#ifdef type_SimpleArrayComplexSingleFloat
+ sizetab[type_SimpleArrayComplexSingleFloat] = size_vector_complex_single_float;
+#endif
+#ifdef type_SimpleArrayComplexDoubleFloat
+ sizetab[type_SimpleArrayComplexDoubleFloat] = size_vector_complex_double_float;
+#endif
+#ifdef type_SimpleArrayComplexLongFloat
+ sizetab[type_SimpleArrayComplexLongFloat] = size_vector_complex_long_float;
+#endif
+ sizetab[type_ComplexString] = size_boxed;
+ sizetab[type_ComplexBitVector] = size_boxed;
+ sizetab[type_ComplexVector] = size_boxed;
+ sizetab[type_ComplexArray] = size_boxed;
+ sizetab[type_CodeHeader] = size_code_header;
+#if 0
+ /* We shouldn't see these, so just lose if it happens. */
+ sizetab[type_FunctionHeader] = size_function_header;
+ sizetab[type_ClosureFunctionHeader] = size_function_header;
+ sizetab[type_ReturnPcHeader] = size_return_pc_header;
+#endif
+ sizetab[type_ClosureHeader] = size_boxed;
+ sizetab[type_FuncallableInstanceHeader] = size_boxed;
+ sizetab[type_ValueCellHeader] = size_boxed;
+ sizetab[type_SymbolHeader] = size_boxed;
+ sizetab[type_BaseChar] = size_immediate;
+ sizetab[type_Sap] = size_unboxed;
+ sizetab[type_UnboundMarker] = size_immediate;
+ sizetab[type_WeakPointer] = size_weak_pointer;
+ sizetab[type_InstanceHeader] = size_boxed;
+ sizetab[type_Fdefn] = size_boxed;
+}
+\f
+/* Scan an area looking for an object which encloses the given pointer.
+ * Return the object start on success or NULL on failure. */
+static lispobj *
+search_space(lispobj *start, size_t words, lispobj *pointer)
+{
+ while (words > 0) {
+ size_t count = 1;
+ lispobj thing = *start;
+
+ /* If thing is an immediate then this is a cons */
+ if (Pointerp(thing)
+ || ((thing & 3) == 0) /* fixnum */
+ || (TypeOf(thing) == type_BaseChar)
+ || (TypeOf(thing) == type_UnboundMarker))
+ count = 2;
+ else
+ count = (sizetab[TypeOf(thing)])(start);
+
+ /* Check whether the pointer is within this object? */
+ if ((pointer >= start) && (pointer < (start+count))) {
+ /* found it! */
+ /*FSHOW((stderr,"/found %x in %x %x\n", pointer, start, thing));*/
+ return(start);
+ }
+
+ /* Round up the count */
+ count = CEILING(count,2);
+
+ start += count;
+ words -= count;
+ }
+ return (NULL);
+}
+
+static lispobj*
+search_read_only_space(lispobj *pointer)
+{
+ lispobj* start = (lispobj*)READ_ONLY_SPACE_START;
+ lispobj* end = (lispobj*)SymbolValue(READ_ONLY_SPACE_FREE_POINTER);
+ if ((pointer < start) || (pointer >= end))
+ return NULL;
+ return (search_space(start, (pointer+2)-start, pointer));
+}
+
+static lispobj *
+search_static_space(lispobj *pointer)
+{
+ lispobj* start = (lispobj*)static_space;
+ lispobj* end = (lispobj*)SymbolValue(STATIC_SPACE_FREE_POINTER);
+ if ((pointer < start) || (pointer >= end))
+ return NULL;
+ return (search_space(start, (pointer+2)-start, pointer));
+}
+
+/* a faster version for searching the dynamic space. This will work even
+ * if the object is in a current allocation region. */
+lispobj *
+search_dynamic_space(lispobj *pointer)
+{
+ int page_index = find_page_index(pointer);
+ lispobj *start;
+
+ /* Address may be invalid - do some checks. */
+ if ((page_index == -1) || (page_table[page_index].allocated == FREE_PAGE))
+ return NULL;
+ start = (lispobj *)((void *)page_address(page_index)
+ + page_table[page_index].first_object_offset);
+ return (search_space(start, (pointer+2)-start, pointer));
+}
+
+/* FIXME: There is a strong family resemblance between this function
+ * and the function of the same name in purify.c. Would it be possible
+ * to implement them as exactly the same function? */
+static int
+valid_dynamic_space_pointer(lispobj *pointer)
+{
+ lispobj *start_addr;
+
+ /* Find the object start address */
+ if ((start_addr = search_dynamic_space(pointer)) == NULL) {
+ return 0;
+ }
+
+ /* We need to allow raw pointers into Code objects for return
+ * addresses. This will also pickup pointers to functions in code
+ * objects. */
+ if (TypeOf(*start_addr) == type_CodeHeader) {
+ /* X Could do some further checks here. */
+ return 1;
+ }
+
+ /* If it's not a return address then it needs to be a valid Lisp
+ * pointer. */
+ if (!Pointerp((lispobj)pointer)) {
+ return 0;
+ }
+
+ /* Check that the object pointed to is consistent with the pointer
+ * low tag. */
+ switch (LowtagOf((lispobj)pointer)) {
+ case type_FunctionPointer:
+ /* Start_addr should be the enclosing code object, or a closure
+ header. */
+ switch (TypeOf(*start_addr)) {
+ case type_CodeHeader:
+ /* This case is probably caught above. */
+ break;
+ case type_ClosureHeader:
+ case type_FuncallableInstanceHeader:
+ case type_ByteCodeFunction:
+ case type_ByteCodeClosure:
+ if ((int)pointer != ((int)start_addr+type_FunctionPointer)) {
+ if (gencgc_verbose)
+ FSHOW((stderr,
+ "/Wf2: %x %x %x\n",
+ pointer, start_addr, *start_addr));
+ return 0;
+ }
+ break;
+ default:
+ if (gencgc_verbose)
+ FSHOW((stderr,
+ "/Wf3: %x %x %x\n",
+ pointer, start_addr, *start_addr));
+ return 0;
+ }
+ break;
+ case type_ListPointer:
+ if ((int)pointer != ((int)start_addr+type_ListPointer)) {
+ if (gencgc_verbose)
+ FSHOW((stderr,
+ "/Wl1: %x %x %x\n",
+ pointer, start_addr, *start_addr));
+ return 0;
+ }
+ /* Is it plausible cons? */
+ if ((Pointerp(start_addr[0])
+ || ((start_addr[0] & 3) == 0) /* fixnum */
+ || (TypeOf(start_addr[0]) == type_BaseChar)
+ || (TypeOf(start_addr[0]) == type_UnboundMarker))
+ && (Pointerp(start_addr[1])
+ || ((start_addr[1] & 3) == 0) /* fixnum */
+ || (TypeOf(start_addr[1]) == type_BaseChar)
+ || (TypeOf(start_addr[1]) == type_UnboundMarker)))
+ break;
+ else {
+ if (gencgc_verbose)
+ FSHOW((stderr,
+ "/Wl2: %x %x %x\n",
+ pointer, start_addr, *start_addr));
+ return 0;
+ }
+ case type_InstancePointer:
+ if ((int)pointer != ((int)start_addr+type_InstancePointer)) {
+ if (gencgc_verbose)
+ FSHOW((stderr,
+ "/Wi1: %x %x %x\n",
+ pointer, start_addr, *start_addr));
+ return 0;
+ }
+ if (TypeOf(start_addr[0]) != type_InstanceHeader) {
+ if (gencgc_verbose)
+ FSHOW((stderr,
+ "/Wi2: %x %x %x\n",
+ pointer, start_addr, *start_addr));
+ return 0;
+ }
+ break;
+ case type_OtherPointer:
+ if ((int)pointer != ((int)start_addr+type_OtherPointer)) {
+ if (gencgc_verbose)
+ FSHOW((stderr,
+ "/Wo1: %x %x %x\n",
+ pointer, start_addr, *start_addr));
+ return 0;
+ }
+ /* Is it plausible? Not a cons. X should check the headers. */
+ if (Pointerp(start_addr[0]) || ((start_addr[0] & 3) == 0)) {
+ if (gencgc_verbose)
+ FSHOW((stderr,
+ "/Wo2: %x %x %x\n",
+ pointer, start_addr, *start_addr));
+ return 0;
+ }
+ switch (TypeOf(start_addr[0])) {
+ case type_UnboundMarker:
+ case type_BaseChar:
+ if (gencgc_verbose)
+ FSHOW((stderr,
+ "*Wo3: %x %x %x\n",
+ pointer, start_addr, *start_addr));
+ return 0;
+
+ /* only pointed to by function pointers? */
+ case type_ClosureHeader:
+ case type_FuncallableInstanceHeader:
+ case type_ByteCodeFunction:
+ case type_ByteCodeClosure:
+ if (gencgc_verbose)
+ FSHOW((stderr,
+ "*Wo4: %x %x %x\n",
+ pointer, start_addr, *start_addr));
+ return 0;
+
+ case type_InstanceHeader:
+ if (gencgc_verbose)
+ FSHOW((stderr,
+ "*Wo5: %x %x %x\n",
+ pointer, start_addr, *start_addr));
+ return 0;
+
+ /* the valid other immediate pointer objects */
+ case type_SimpleVector:
+ case type_Ratio:
+ case type_Complex:
+#ifdef type_ComplexSingleFloat
+ case type_ComplexSingleFloat:
+#endif
+#ifdef type_ComplexDoubleFloat
+ case type_ComplexDoubleFloat:
+#endif
+#ifdef type_ComplexLongFloat
+ case type_ComplexLongFloat:
+#endif
+ case type_SimpleArray:
+ case type_ComplexString:
+ case type_ComplexBitVector:
+ case type_ComplexVector:
+ case type_ComplexArray:
+ case type_ValueCellHeader:
+ case type_SymbolHeader:
+ case type_Fdefn:
+ case type_CodeHeader:
+ case type_Bignum:
+ case type_SingleFloat:
+ case type_DoubleFloat:
+#ifdef type_LongFloat
+ case type_LongFloat:
+#endif
+ case type_SimpleString:
+ case type_SimpleBitVector:
+ case type_SimpleArrayUnsignedByte2:
+ case type_SimpleArrayUnsignedByte4:
+ case type_SimpleArrayUnsignedByte8:
+ case type_SimpleArrayUnsignedByte16:
+ case type_SimpleArrayUnsignedByte32:
+#ifdef type_SimpleArraySignedByte8
+ case type_SimpleArraySignedByte8:
+#endif
+#ifdef type_SimpleArraySignedByte16
+ case type_SimpleArraySignedByte16:
+#endif
+#ifdef type_SimpleArraySignedByte30
+ case type_SimpleArraySignedByte30:
+#endif
+#ifdef type_SimpleArraySignedByte32
+ case type_SimpleArraySignedByte32:
+#endif
+ case type_SimpleArraySingleFloat:
+ case type_SimpleArrayDoubleFloat:
+#ifdef type_SimpleArrayLongFloat
+ case type_SimpleArrayLongFloat:
+#endif
+#ifdef type_SimpleArrayComplexSingleFloat
+ case type_SimpleArrayComplexSingleFloat:
+#endif
+#ifdef type_SimpleArrayComplexDoubleFloat
+ case type_SimpleArrayComplexDoubleFloat:
+#endif
+#ifdef type_SimpleArrayComplexLongFloat
+ case type_SimpleArrayComplexLongFloat:
+#endif
+ case type_Sap:
+ case type_WeakPointer:
+ break;
+
+ default:
+ if (gencgc_verbose)
+ FSHOW((stderr,
+ "/Wo6: %x %x %x\n",
+ pointer, start_addr, *start_addr));
+ return 0;
+ }
+ break;
+ default:
+ if (gencgc_verbose)
+ FSHOW((stderr,
+ "*W?: %x %x %x\n",
+ pointer, start_addr, *start_addr));
+ return 0;
+ }
+
+ /* looks good */
+ return 1;
+}
+
+/* Adjust large bignum and vector objects. This will adjust the allocated
+ * region if the size has shrunk, and move unboxed objects into unboxed
+ * pages. The pages are not promoted here, and the promoted region is not
+ * added to the new_regions; this is really only designed to be called from
+ * preserve_pointer. Shouldn't fail if this is missed, just may delay the
+ * moving of objects to unboxed pages, and the freeing of pages. */
+static void
+maybe_adjust_large_object(lispobj *where)
+{
+ int tag;
+ lispobj *new;
+ lispobj *source, *dest;
+ int first_page;
+ int nwords;
+
+ int remaining_bytes;
+ int next_page;
+ int bytes_freed;
+ int old_bytes_used;
+
+ int boxed;
+
+ /* Check whether it's a vector or bignum object. */
+ switch (TypeOf(where[0])) {
+ case type_SimpleVector:
+ boxed = BOXED_PAGE;
+ break;
+ case type_Bignum:
+ case type_SimpleString:
+ case type_SimpleBitVector:
+ case type_SimpleArrayUnsignedByte2:
+ case type_SimpleArrayUnsignedByte4:
+ case type_SimpleArrayUnsignedByte8:
+ case type_SimpleArrayUnsignedByte16:
+ case type_SimpleArrayUnsignedByte32:
+#ifdef type_SimpleArraySignedByte8
+ case type_SimpleArraySignedByte8:
+#endif
+#ifdef type_SimpleArraySignedByte16
+ case type_SimpleArraySignedByte16:
+#endif
+#ifdef type_SimpleArraySignedByte30
+ case type_SimpleArraySignedByte30:
+#endif
+#ifdef type_SimpleArraySignedByte32
+ case type_SimpleArraySignedByte32:
+#endif
+ case type_SimpleArraySingleFloat:
+ case type_SimpleArrayDoubleFloat:
+#ifdef type_SimpleArrayLongFloat
+ case type_SimpleArrayLongFloat:
+#endif
+#ifdef type_SimpleArrayComplexSingleFloat
+ case type_SimpleArrayComplexSingleFloat:
+#endif
+#ifdef type_SimpleArrayComplexDoubleFloat
+ case type_SimpleArrayComplexDoubleFloat:
+#endif
+#ifdef type_SimpleArrayComplexLongFloat
+ case type_SimpleArrayComplexLongFloat:
+#endif
+ boxed = UNBOXED_PAGE;
+ break;
+ default:
+ return;
+ }
+
+ /* Find its current size. */
+ nwords = (sizetab[TypeOf(where[0])])(where);
+
+ first_page = find_page_index((void *)where);
+ gc_assert(first_page >= 0);
+
+ /* Note: Any page write-protection must be removed, else a later
+ * scavenge_newspace may incorrectly not scavenge these pages.
+ * This would not be necessary if they are added to the new areas,
+ * but lets do it for them all (they'll probably be written
+ * anyway?). */
+
+ gc_assert(page_table[first_page].first_object_offset == 0);
+
+ next_page = first_page;
+ remaining_bytes = nwords*4;
+ while (remaining_bytes > 4096) {
+ gc_assert(page_table[next_page].gen == from_space);
+ gc_assert((page_table[next_page].allocated == BOXED_PAGE)
+ || (page_table[next_page].allocated == UNBOXED_PAGE));
+ gc_assert(page_table[next_page].large_object);
+ gc_assert(page_table[next_page].first_object_offset ==
+ -4096*(next_page-first_page));
+ gc_assert(page_table[next_page].bytes_used == 4096);
+
+ page_table[next_page].allocated = boxed;
+
+ /* Shouldn't be write-protected at this stage. Essential that the
+ * pages aren't. */
+ gc_assert(!page_table[next_page].write_protected);
+ remaining_bytes -= 4096;
+ next_page++;
+ }
+
+ /* Now only one page remains, but the object may have shrunk so
+ * there may be more unused pages which will be freed. */
+
+ /* Object may have shrunk but shouldn't have grown - check. */
+ gc_assert(page_table[next_page].bytes_used >= remaining_bytes);
+
+ page_table[next_page].allocated = boxed;
+ gc_assert(page_table[next_page].allocated ==
+ page_table[first_page].allocated);
+
+ /* Adjust the bytes_used. */
+ old_bytes_used = page_table[next_page].bytes_used;
+ page_table[next_page].bytes_used = remaining_bytes;
+
+ bytes_freed = old_bytes_used - remaining_bytes;
+
+ /* Free any remaining pages; needs care. */
+ next_page++;
+ while ((old_bytes_used == 4096) &&
+ (page_table[next_page].gen == from_space) &&
+ ((page_table[next_page].allocated == UNBOXED_PAGE)
+ || (page_table[next_page].allocated == BOXED_PAGE)) &&
+ page_table[next_page].large_object &&
+ (page_table[next_page].first_object_offset ==
+ -(next_page - first_page)*4096)) {
+ /* It checks out OK, free the page. We don't need to both zeroing
+ * pages as this should have been done before shrinking the
+ * object. These pages shouldn't be write protected as they
+ * should be zero filled. */
+ gc_assert(page_table[next_page].write_protected == 0);
+
+ old_bytes_used = page_table[next_page].bytes_used;
+ page_table[next_page].allocated = FREE_PAGE;
+ page_table[next_page].bytes_used = 0;
+ bytes_freed += old_bytes_used;
+ next_page++;
+ }
+
+ if ((bytes_freed > 0) && gencgc_verbose)
+ FSHOW((stderr, "/adjust_large_object freed %d\n", bytes_freed));
+
+ generations[from_space].bytes_allocated -= bytes_freed;
+ bytes_allocated -= bytes_freed;
+
+ return;
+}
+
+/* Take a possible pointer to a list object and mark the page_table
+ * so that it will not need changing during a GC.
+ *
+ * This involves locating the page it points to, then backing up to
+ * the first page that has its first object start at offset 0, and
+ * then marking all pages dont_move from the first until a page that ends
+ * by being full, or having free gen.
+ *
+ * This ensures that objects spanning pages are not broken.
+ *
+ * It is assumed that all the page static flags have been cleared at
+ * the start of a GC.
+ *
+ * It is also assumed that the current gc_alloc region has been flushed and
+ * the tables updated. */
+static void
+preserve_pointer(void *addr)
+{
+ int addr_page_index = find_page_index(addr);
+ int first_page;
+ int i;
+ unsigned region_allocation;
+
+ /* Address is quite likely to have been invalid - do some checks. */
+ if ((addr_page_index == -1)
+ || (page_table[addr_page_index].allocated == FREE_PAGE)
+ || (page_table[addr_page_index].bytes_used == 0)
+ || (page_table[addr_page_index].gen != from_space)
+ /* Skip if already marked dont_move */
+ || (page_table[addr_page_index].dont_move != 0))
+ return;
+
+ region_allocation = page_table[addr_page_index].allocated;
+
+ /* Check the offset within the page */
+ if (((int)addr & 0xfff) > page_table[addr_page_index].bytes_used)
+ return;
+
+ if (enable_pointer_filter && !valid_dynamic_space_pointer(addr))
+ return;
+
+ /* Work backwards to find a page with a first_object_offset of 0.
+ * The pages should be contiguous with all bytes used in the same
+ * gen. Assumes the first_object_offset is negative or zero. */
+ first_page = addr_page_index;
+ while (page_table[first_page].first_object_offset != 0) {
+ first_page--;
+ /* Do some checks. */
+ gc_assert(page_table[first_page].bytes_used == 4096);
+ gc_assert(page_table[first_page].gen == from_space);
+ gc_assert(page_table[first_page].allocated == region_allocation);
+ }
+
+ /* Adjust any large objects before promotion as they won't be copied
+ * after promotion. */
+ if (page_table[first_page].large_object) {
+ maybe_adjust_large_object(page_address(first_page));
+ /* If a large object has shrunk then addr may now point to a free
+ * area in which case it's ignored here. Note it gets through the
+ * valid pointer test above because the tail looks like conses. */
+ if ((page_table[addr_page_index].allocated == FREE_PAGE)
+ || (page_table[addr_page_index].bytes_used == 0)
+ /* Check the offset within the page. */
+ || (((int)addr & 0xfff)
+ > page_table[addr_page_index].bytes_used)) {
+ FSHOW((stderr,
+ "weird? ignore ptr 0x%x to freed area of large object\n",
+ addr));
+ return;
+ }
+ /* It may have moved to unboxed pages. */
+ region_allocation = page_table[first_page].allocated;
+ }
+
+ /* Now work forward until the end of this contiguous area is found,
+ * marking all pages as dont_move. */
+ for (i = first_page; ;i++) {
+ gc_assert(page_table[i].allocated == region_allocation);
+
+ /* Mark the page static. */
+ page_table[i].dont_move = 1;
+
+ /* Move the page to the new_space. XX I'd rather not do this but
+ * the GC logic is not quite able to copy with the static pages
+ * remaining in the from space. This also requires the generation
+ * bytes_allocated counters be updated. */
+ page_table[i].gen = new_space;
+ generations[new_space].bytes_allocated += page_table[i].bytes_used;
+ generations[from_space].bytes_allocated -= page_table[i].bytes_used;
+
+ /* It is essential that the pages are not write protected as they
+ * may have pointers into the old-space which need scavenging. They
+ * shouldn't be write protected at this stage. */
+ gc_assert(!page_table[i].write_protected);
+
+ /* Check whether this is the last page in this contiguous block.. */
+ if ((page_table[i].bytes_used < 4096)
+ /* ..or it is 4096 and is the last in the block */
+ || (page_table[i+1].allocated == FREE_PAGE)
+ || (page_table[i+1].bytes_used == 0) /* next page free */
+ || (page_table[i+1].gen != from_space) /* diff. gen */
+ || (page_table[i+1].first_object_offset == 0))
+ break;
+ }
+
+ /* Check that the page is now static. */
+ gc_assert(page_table[addr_page_index].dont_move != 0);
+
+ return;
+}
+
+#ifdef CONTROL_STACKS
+/* Scavenge the thread stack conservative roots. */
+static void
+scavenge_thread_stacks(void)
+{
+ lispobj thread_stacks = SymbolValue(CONTROL_STACKS);
+ int type = TypeOf(thread_stacks);
+
+ if (LowtagOf(thread_stacks) == type_OtherPointer) {
+ struct vector *vector = (struct vector *) PTR(thread_stacks);
+ int length, i;
+ if (TypeOf(vector->header) != type_SimpleVector)
+ return;
+ length = fixnum_value(vector->length);
+ for (i = 0; i < length; i++) {
+ lispobj stack_obj = vector->data[i];
+ if (LowtagOf(stack_obj) == type_OtherPointer) {
+ struct vector *stack = (struct vector *) PTR(stack_obj);
+ int vector_length;
+ if (TypeOf(stack->header) !=
+ type_SimpleArrayUnsignedByte32) {
+ return;
+ }
+ vector_length = fixnum_value(stack->length);
+ if ((gencgc_verbose > 1) && (vector_length <= 0))
+ FSHOW((stderr,
+ "/weird? control stack vector length %d\n",
+ vector_length));
+ if (vector_length > 0) {
+ lispobj *stack_pointer = (lispobj*)stack->data[0];
+ if ((stack_pointer < control_stack) ||
+ (stack_pointer > control_stack_end))
+ lose("invalid stack pointer %x",
+ (unsigned)stack_pointer);
+ if ((stack_pointer > control_stack) &&
+ (stack_pointer < control_stack_end)) {
+ unsigned int length = ((int)control_stack_end -
+ (int)stack_pointer) / 4;
+ int j;
+ if (length >= vector_length) {
+ lose("invalid stack size %d >= vector length %d",
+ length,
+ vector_length);
+ }
+ if (gencgc_verbose > 1) {
+ FSHOW((stderr,
+ "scavenging %d words of control stack %d of length %d words.\n",
+ length, i, vector_length));
+ }
+ for (j = 0; j < length; j++) {
+ preserve_pointer((void *)stack->data[1+j]);
+ }
+ }
+ }
+ }
+ }
+ }
+}
+#endif
+
+\f
+/* If the given page is not write-protected, then scan it for pointers
+ * to younger generations or the top temp. generation, if no
+ * suspicious pointers are found then the page is write-protected.
+ *
+ * Care is taken to check for pointers to the current gc_alloc region
+ * if it is a younger generation or the temp. generation. This frees
+ * the caller from doing a gc_alloc_update_page_tables. Actually the
+ * gc_alloc_generation does not need to be checked as this is only
+ * called from scavenge_generation when the gc_alloc generation is
+ * younger, so it just checks if there is a pointer to the current
+ * region.
+ *
+ * We return 1 if the page was write-protected, else 0.
+ */
+static int
+update_page_write_prot(int page)
+{
+ int gen = page_table[page].gen;
+ int j;
+ int wp_it = 1;
+ void **page_addr = (void **)page_address(page);
+ int num_words = page_table[page].bytes_used / 4;
+
+ /* Shouldn't be a free page. */
+ gc_assert(page_table[page].allocated != FREE_PAGE);
+ gc_assert(page_table[page].bytes_used != 0);
+
+ /* Skip if it's already write-protected or an unboxed page. */
+ if (page_table[page].write_protected
+ || (page_table[page].allocated == UNBOXED_PAGE))
+ return (0);
+
+ /* Scan the page for pointers to younger generations or the
+ * top temp. generation. */
+
+ for (j = 0; j < num_words; j++) {
+ void *ptr = *(page_addr+j);
+ int index = find_page_index(ptr);
+
+ /* Check that it's in the dynamic space */
+ if (index != -1)
+ if (/* Does it point to a younger or the temp. generation? */
+ ((page_table[index].allocated != FREE_PAGE)
+ && (page_table[index].bytes_used != 0)
+ && ((page_table[index].gen < gen)
+ || (page_table[index].gen == NUM_GENERATIONS)))
+
+ /* Or does it point within a current gc_alloc region? */
+ || ((boxed_region.start_addr <= ptr)
+ && (ptr <= boxed_region.free_pointer))
+ || ((unboxed_region.start_addr <= ptr)
+ && (ptr <= unboxed_region.free_pointer))) {
+ wp_it = 0;
+ break;
+ }
+ }
+
+ if (wp_it == 1) {
+ /* Write-protect the page. */
+ /*FSHOW((stderr, "/write-protecting page %d gen %d\n", page, gen));*/
+
+ os_protect((void *)page_addr,
+ 4096,
+ OS_VM_PROT_READ|OS_VM_PROT_EXECUTE);
+
+ /* Note the page as protected in the page tables. */
+ page_table[page].write_protected = 1;
+ }
+
+ return (wp_it);
+}
+
+/* Scavenge a generation.
+ *
+ * This will not resolve all pointers when generation is the new
+ * space, as new objects may be added which are not check here - use
+ * scavenge_newspace generation.
+ *
+ * Write-protected pages should not have any pointers to the
+ * from_space so do need scavenging; thus write-protected pages are
+ * not always scavenged. There is some code to check that these pages
+ * are not written; but to check fully the write-protected pages need
+ * to be scavenged by disabling the code to skip them.
+ *
+ * Under the current scheme when a generation is GCed the younger
+ * generations will be empty. So, when a generation is being GCed it
+ * is only necessary to scavenge the older generations for pointers
+ * not the younger. So a page that does not have pointers to younger
+ * generations does not need to be scavenged.
+ *
+ * The write-protection can be used to note pages that don't have
+ * pointers to younger pages. But pages can be written without having
+ * pointers to younger generations. After the pages are scavenged here
+ * they can be scanned for pointers to younger generations and if
+ * there are none the page can be write-protected.
+ *
+ * One complication is when the newspace is the top temp. generation.
+ *
+ * Enabling SC_GEN_CK scavenges the write-protected pages and checks
+ * that none were written, which they shouldn't be as they should have
+ * no pointers to younger generations. This breaks down for weak
+ * pointers as the objects contain a link to the next and are written
+ * if a weak pointer is scavenged. Still it's a useful check. */
+static void
+scavenge_generation(int generation)
+{
+ int i;
+ int num_wp = 0;
+
+#define SC_GEN_CK 0
+#if SC_GEN_CK
+ /* Clear the write_protected_cleared flags on all pages. */
+ for (i = 0; i < NUM_PAGES; i++)
+ page_table[i].write_protected_cleared = 0;
+#endif
+
+ for (i = 0; i < last_free_page; i++) {
+ if ((page_table[i].allocated == BOXED_PAGE)
+ && (page_table[i].bytes_used != 0)
+ && (page_table[i].gen == generation)) {
+ int last_page;
+
+ /* This should be the start of a contiguous block. */
+ gc_assert(page_table[i].first_object_offset == 0);
+
+ /* We need to find the full extent of this contiguous
+ * block in case objects span pages. */
+
+ /* Now work forward until the end of this contiguous area
+ * is found. A small area is preferred as there is a
+ * better chance of its pages being write-protected. */
+ for (last_page = i; ;last_page++)
+ /* Check whether this is the last page in this contiguous
+ * block. */
+ if ((page_table[last_page].bytes_used < 4096)
+ /* Or it is 4096 and is the last in the block */
+ || (page_table[last_page+1].allocated != BOXED_PAGE)
+ || (page_table[last_page+1].bytes_used == 0)
+ || (page_table[last_page+1].gen != generation)
+ || (page_table[last_page+1].first_object_offset == 0))
+ break;
+
+ /* Do a limited check for write_protected pages. If all pages
+ * are write_protected then there is no need to scavenge. */
+ {
+ int j, all_wp = 1;
+ for (j = i; j <= last_page; j++)
+ if (page_table[j].write_protected == 0) {
+ all_wp = 0;
+ break;
+ }
+#if !SC_GEN_CK
+ if (all_wp == 0)
+#endif
+ {
+ scavenge(page_address(i), (page_table[last_page].bytes_used
+ + (last_page-i)*4096)/4);
+
+ /* Now scan the pages and write protect those
+ * that don't have pointers to younger
+ * generations. */
+ if (enable_page_protection) {
+ for (j = i; j <= last_page; j++) {
+ num_wp += update_page_write_prot(j);
+ }
+ }
+ }
+ }
+ i = last_page;
+ }
+ }
+
+ if ((gencgc_verbose > 1) && (num_wp != 0)) {
+ FSHOW((stderr,
+ "/write protected %d pages within generation %d\n",
+ num_wp, generation));
+ }
+
+#if SC_GEN_CK
+ /* Check that none of the write_protected pages in this generation
+ * have been written to. */
+ for (i = 0; i < NUM_PAGES; i++) {
+ if ((page_table[i].allocation ! =FREE_PAGE)
+ && (page_table[i].bytes_used != 0)
+ && (page_table[i].gen == generation)
+ && (page_table[i].write_protected_cleared != 0)) {
+ FSHOW((stderr, "/scavenge_generation %d\n", generation));
+ FSHOW((stderr,
+ "/page bytes_used=%d first_object_offset=%d dont_move=%d\n",
+ page_table[i].bytes_used,
+ page_table[i].first_object_offset,
+ page_table[i].dont_move));
+ lose("write-protected page %d written to in scavenge_generation",
+ i);
+ }
+ }
+#endif
+}
+
+\f
+/* Scavenge a newspace generation. As it is scavenged new objects may
+ * be allocated to it; these will also need to be scavenged. This
+ * repeats until there are no more objects unscavenged in the
+ * newspace generation.
+ *
+ * To help improve the efficiency, areas written are recorded by
+ * gc_alloc and only these scavenged. Sometimes a little more will be
+ * scavenged, but this causes no harm. An easy check is done that the
+ * scavenged bytes equals the number allocated in the previous
+ * scavenge.
+ *
+ * Write-protected pages are not scanned except if they are marked
+ * dont_move in which case they may have been promoted and still have
+ * pointers to the from space.
+ *
+ * Write-protected pages could potentially be written by alloc however
+ * to avoid having to handle re-scavenging of write-protected pages
+ * gc_alloc does not write to write-protected pages.
+ *
+ * New areas of objects allocated are recorded alternatively in the two
+ * new_areas arrays below. */
+static struct new_area new_areas_1[NUM_NEW_AREAS];
+static struct new_area new_areas_2[NUM_NEW_AREAS];
+
+/* Do one full scan of the new space generation. This is not enough to
+ * complete the job as new objects may be added to the generation in
+ * the process which are not scavenged. */
+static void
+scavenge_newspace_generation_one_scan(int generation)
+{
+ int i;
+
+ FSHOW((stderr,
+ "/starting one full scan of newspace generation %d\n",
+ generation));
+
+ for (i = 0; i < last_free_page; i++) {
+ if ((page_table[i].allocated == BOXED_PAGE)
+ && (page_table[i].bytes_used != 0)
+ && (page_table[i].gen == generation)
+ && ((page_table[i].write_protected == 0)
+ /* (This may be redundant as write_protected is now
+ * cleared before promotion.) */
+ || (page_table[i].dont_move == 1))) {
+ int last_page;
+
+ /* The scavenge will start at the first_object_offset of page i.
+ *
+ * We need to find the full extent of this contiguous block in case
+ * objects span pages.
+ *
+ * Now work forward until the end of this contiguous area is
+ * found. A small area is preferred as there is a better chance
+ * of its pages being write-protected. */
+ for (last_page = i; ;last_page++) {
+ /* Check whether this is the last page in this contiguous
+ * block */
+ if ((page_table[last_page].bytes_used < 4096)
+ /* Or it is 4096 and is the last in the block */
+ || (page_table[last_page+1].allocated != BOXED_PAGE)
+ || (page_table[last_page+1].bytes_used == 0)
+ || (page_table[last_page+1].gen != generation)
+ || (page_table[last_page+1].first_object_offset == 0))
+ break;
+ }
+
+ /* Do a limited check for write_protected pages. If all pages
+ * are write_protected then no need to scavenge. Except if the
+ * pages are marked dont_move. */
+ {
+ int j, all_wp = 1;
+ for (j = i; j <= last_page; j++)
+ if ((page_table[j].write_protected == 0)
+ || (page_table[j].dont_move != 0)) {
+ all_wp = 0;
+ break;
+ }
+#if !SC_NS_GEN_CK
+ if (all_wp == 0)
+#endif
+ {
+ int size;
+
+ /* Calculate the size. */
+ if (last_page == i)
+ size = (page_table[last_page].bytes_used
+ - page_table[i].first_object_offset)/4;
+ else
+ size = (page_table[last_page].bytes_used
+ + (last_page-i)*4096
+ - page_table[i].first_object_offset)/4;
+
+ {
+#if SC_NS_GEN_CK
+ int a1 = bytes_allocated;
+#endif
+ /* FSHOW((stderr,
+ "/scavenge(%x,%d)\n",
+ page_address(i)
+ + page_table[i].first_object_offset,
+ size)); */
+
+ new_areas_ignore_page = last_page;
+
+ scavenge(page_address(i)+page_table[i].first_object_offset,size);
+
+#if SC_NS_GEN_CK
+ /* Flush the alloc regions updating the tables. */
+ gc_alloc_update_page_tables(0, &boxed_region);
+ gc_alloc_update_page_tables(1, &unboxed_region);
+
+ if ((all_wp != 0) && (a1 != bytes_allocated)) {
+ FSHOW((stderr,
+ "alloc'ed over %d to %d\n",
+ i, last_page));
+ FSHOW((stderr,
+ "/page: bytes_used=%d first_object_offset=%d dont_move=%d wp=%d wpc=%d\n",
+ page_table[i].bytes_used,
+ page_table[i].first_object_offset,
+ page_table[i].dont_move,
+ page_table[i].write_protected,
+ page_table[i].write_protected_cleared));
+ }
+#endif
+ }
+ }
+ }
+
+ i = last_page;
+ }
+ }
+}
+
+/* Do a complete scavenge of the newspace generation. */
+static void
+scavenge_newspace_generation(int generation)
+{
+ int i;
+
+ /* the new_areas array currently being written to by gc_alloc */
+ struct new_area (*current_new_areas)[] = &new_areas_1;
+ int current_new_areas_index;
+ int current_new_areas_allocated;
+
+ /* the new_areas created but the previous scavenge cycle */
+ struct new_area (*previous_new_areas)[] = NULL;
+ int previous_new_areas_index;
+ int previous_new_areas_allocated;
+
+#define SC_NS_GEN_CK 0
+#if SC_NS_GEN_CK
+ /* Clear the write_protected_cleared flags on all pages. */
+ for (i = 0; i < NUM_PAGES; i++)
+ page_table[i].write_protected_cleared = 0;
+#endif
+
+ /* Flush the current regions updating the tables. */
+ gc_alloc_update_page_tables(0, &boxed_region);
+ gc_alloc_update_page_tables(1, &unboxed_region);
+
+ /* Turn on the recording of new areas by gc_alloc. */
+ new_areas = current_new_areas;
+ new_areas_index = 0;
+
+ /* Don't need to record new areas that get scavenged anyway during
+ * scavenge_newspace_generation_one_scan. */
+ record_new_objects = 1;
+
+ /* Start with a full scavenge. */
+ scavenge_newspace_generation_one_scan(generation);
+
+ /* Record all new areas now. */
+ record_new_objects = 2;
+
+ /* Flush the current regions updating the tables. */
+ gc_alloc_update_page_tables(0, &boxed_region);
+ gc_alloc_update_page_tables(1, &unboxed_region);
+
+ /* Grab new_areas_index. */
+ current_new_areas_index = new_areas_index;
+
+ /*FSHOW((stderr,
+ "The first scan is finished; current_new_areas_index=%d.\n",
+ current_new_areas_index));*/
+
+ while (current_new_areas_index > 0) {
+ /* Move the current to the previous new areas */
+ previous_new_areas = current_new_areas;
+ previous_new_areas_index = current_new_areas_index;
+
+ /* Scavenge all the areas in previous new areas. Any new areas
+ * allocated are saved in current_new_areas. */
+
+ /* Allocate an array for current_new_areas; alternating between
+ * new_areas_1 and 2 */
+ if (previous_new_areas == &new_areas_1)
+ current_new_areas = &new_areas_2;
+ else
+ current_new_areas = &new_areas_1;
+
+ /* Set up for gc_alloc. */
+ new_areas = current_new_areas;
+ new_areas_index = 0;
+
+ /* Check whether previous_new_areas had overflowed. */
+ if (previous_new_areas_index >= NUM_NEW_AREAS) {
+ /* New areas of objects allocated have been lost so need to do a
+ * full scan to be sure! If this becomes a problem try
+ * increasing NUM_NEW_AREAS. */
+ if (gencgc_verbose)
+ SHOW("new_areas overflow, doing full scavenge");
+
+ /* Don't need to record new areas that get scavenge anyway
+ * during scavenge_newspace_generation_one_scan. */
+ record_new_objects = 1;
+
+ scavenge_newspace_generation_one_scan(generation);
+
+ /* Record all new areas now. */
+ record_new_objects = 2;
+
+ /* Flush the current regions updating the tables. */
+ gc_alloc_update_page_tables(0, &boxed_region);
+ gc_alloc_update_page_tables(1, &unboxed_region);
+ } else {
+ /* Work through previous_new_areas. */
+ for (i = 0; i < previous_new_areas_index; i++) {
+ int page = (*previous_new_areas)[i].page;
+ int offset = (*previous_new_areas)[i].offset;
+ int size = (*previous_new_areas)[i].size / 4;
+ gc_assert((*previous_new_areas)[i].size % 4 == 0);
+
+ /* FIXME: All these bare *4 and /4 should be something
+ * like BYTES_PER_WORD or WBYTES. */
+
+ /*FSHOW((stderr,
+ "/S page %d offset %d size %d\n",
+ page, offset, size*4));*/
+ scavenge(page_address(page)+offset, size);
+ }
+
+ /* Flush the current regions updating the tables. */
+ gc_alloc_update_page_tables(0, &boxed_region);
+ gc_alloc_update_page_tables(1, &unboxed_region);
+ }
+
+ current_new_areas_index = new_areas_index;
+
+ /*FSHOW((stderr,
+ "The re-scan has finished; current_new_areas_index=%d.\n",
+ current_new_areas_index));*/
+ }
+
+ /* Turn off recording of areas allocated by gc_alloc. */
+ record_new_objects = 0;
+
+#if SC_NS_GEN_CK
+ /* Check that none of the write_protected pages in this generation
+ * have been written to. */
+ for (i = 0; i < NUM_PAGES; i++) {
+ if ((page_table[i].allocation != FREE_PAGE)
+ && (page_table[i].bytes_used != 0)
+ && (page_table[i].gen == generation)
+ && (page_table[i].write_protected_cleared != 0)
+ && (page_table[i].dont_move == 0)) {
+ lose("write protected page %d written to in scavenge_newspace_generation\ngeneration=%d dont_move=%d",
+ i, generation, page_table[i].dont_move);
+ }
+ }
+#endif
+}
+\f
+/* Un-write-protect all the pages in from_space. This is done at the
+ * start of a GC else there may be many page faults while scavenging
+ * the newspace (I've seen drive the system time to 99%). These pages
+ * would need to be unprotected anyway before unmapping in
+ * free_oldspace; not sure what effect this has on paging.. */
+static void
+unprotect_oldspace(void)
+{
+ int bytes_freed = 0;
+ int i;
+
+ for (i = 0; i < last_free_page; i++) {
+ if ((page_table[i].allocated != FREE_PAGE)
+ && (page_table[i].bytes_used != 0)
+ && (page_table[i].gen == from_space)) {
+ void *page_start, *addr;
+
+ page_start = (void *)page_address(i);
+
+ /* Remove any write-protection. We should be able to rely
+ * on the write-protect flag to avoid redundant calls. */
+ if (page_table[i].write_protected) {
+ os_protect(page_start, 4096, OS_VM_PROT_ALL);
+ page_table[i].write_protected = 0;
+ }
+ }
+ }
+}
+
+/* Work through all the pages and free any in from_space. This
+ * assumes that all objects have been copied or promoted to an older
+ * generation. Bytes_allocated and the generation bytes_allocated
+ * counter are updated. The number of bytes freed is returned. */
+extern void i586_bzero(void *addr, int nbytes);
+static int
+free_oldspace(void)
+{
+ int bytes_freed = 0;
+ int first_page, last_page;
+
+ first_page = 0;
+
+ do {
+ /* Find a first page for the next region of pages. */
+ while ((first_page < last_free_page)
+ && ((page_table[first_page].allocated == FREE_PAGE)
+ || (page_table[first_page].bytes_used == 0)
+ || (page_table[first_page].gen != from_space)))
+ first_page++;
+
+ if (first_page >= last_free_page)
+ break;
+
+ /* Find the last page of this region. */
+ last_page = first_page;
+
+ do {
+ /* Free the page. */
+ bytes_freed += page_table[last_page].bytes_used;
+ generations[page_table[last_page].gen].bytes_allocated -=
+ page_table[last_page].bytes_used;
+ page_table[last_page].allocated = FREE_PAGE;
+ page_table[last_page].bytes_used = 0;
+
+ /* Remove any write-protection. We should be able to rely
+ * on the write-protect flag to avoid redundant calls. */
+ {
+ void *page_start = (void *)page_address(last_page);
+
+ if (page_table[last_page].write_protected) {
+ os_protect(page_start, 4096, OS_VM_PROT_ALL);
+ page_table[last_page].write_protected = 0;
+ }
+ }
+ last_page++;
+ }
+ while ((last_page < last_free_page)
+ && (page_table[last_page].allocated != FREE_PAGE)
+ && (page_table[last_page].bytes_used != 0)
+ && (page_table[last_page].gen == from_space));
+
+ /* Zero pages from first_page to (last_page-1).
+ *
+ * FIXME: Why not use os_zero(..) function instead of
+ * hand-coding this again? (Check other gencgc_unmap_zero
+ * stuff too. */
+ if (gencgc_unmap_zero) {
+ void *page_start, *addr;
+
+ page_start = (void *)page_address(first_page);
+
+ os_invalidate(page_start, 4096*(last_page-first_page));
+ addr = os_validate(page_start, 4096*(last_page-first_page));
+ if (addr == NULL || addr != page_start) {
+ /* Is this an error condition? I couldn't really tell from
+ * the old CMU CL code, which fprintf'ed a message with
+ * an exclamation point at the end. But I've never seen the
+ * message, so it must at least be unusual..
+ *
+ * (The same condition is also tested for in gc_free_heap.)
+ *
+ * -- WHN 19991129 */
+ lose("i586_bzero: page moved, 0x%08x ==> 0x%08x",
+ page_start,
+ addr);
+ }
+ } else {
+ int *page_start;
+
+ page_start = (int *)page_address(first_page);
+ i586_bzero(page_start, 4096*(last_page-first_page));
+ }
+
+ first_page = last_page;
+
+ } while (first_page < last_free_page);
+
+ bytes_allocated -= bytes_freed;
+ return bytes_freed;
+}
+\f
+/* Print some information about a pointer at the given address. */
+static void
+print_ptr(lispobj *addr)
+{
+ /* If addr is in the dynamic space then out the page information. */
+ int pi1 = find_page_index((void*)addr);
+
+ if (pi1 != -1)
+ fprintf(stderr," %x: page %d alloc %d gen %d bytes_used %d offset %d dont_move %d\n",
+ addr,
+ pi1,
+ page_table[pi1].allocated,
+ page_table[pi1].gen,
+ page_table[pi1].bytes_used,
+ page_table[pi1].first_object_offset,
+ page_table[pi1].dont_move);
+ fprintf(stderr," %x %x %x %x (%x) %x %x %x %x\n",
+ *(addr-4),
+ *(addr-3),
+ *(addr-2),
+ *(addr-1),
+ *(addr-0),
+ *(addr+1),
+ *(addr+2),
+ *(addr+3),
+ *(addr+4));
+}
+
+extern int undefined_tramp;
+
+static void
+verify_space(lispobj*start, size_t words)
+{
+ int dynamic_space = (find_page_index((void*)start) != -1);
+ int readonly_space =
+ (READ_ONLY_SPACE_START <= (int)start &&
+ (int)start < SymbolValue(READ_ONLY_SPACE_FREE_POINTER));
+
+ while (words > 0) {
+ size_t count = 1;
+ lispobj thing = *(lispobj*)start;
+
+ if (Pointerp(thing)) {
+ int page_index = find_page_index((void*)thing);
+ int to_readonly_space =
+ (READ_ONLY_SPACE_START <= thing &&
+ thing < SymbolValue(READ_ONLY_SPACE_FREE_POINTER));
+ int to_static_space =
+ ((int)static_space <= thing &&
+ thing < SymbolValue(STATIC_SPACE_FREE_POINTER));
+
+ /* Does it point to the dynamic space? */
+ if (page_index != -1) {
+ /* If it's within the dynamic space it should point to a used
+ * page. XX Could check the offset too. */
+ if ((page_table[page_index].allocated != FREE_PAGE)
+ && (page_table[page_index].bytes_used == 0))
+ lose ("Ptr %x @ %x sees free page.", thing, start);
+ /* Check that it doesn't point to a forwarding pointer! */
+ if (*((lispobj *)PTR(thing)) == 0x01) {
+ lose("Ptr %x @ %x sees forwarding ptr.", thing, start);
+ }
+ /* Check that its not in the RO space as it would then be a
+ * pointer from the RO to the dynamic space. */
+ if (readonly_space) {
+ lose("ptr to dynamic space %x from RO space %x",
+ thing, start);
+ }
+ /* Does it point to a plausible object? This check slows
+ * it down a lot (so it's commented out).
+ *
+ * FIXME: Add a variable to enable this dynamically. */
+ /* if (!valid_dynamic_space_pointer((lispobj *)thing)) {
+ * lose("ptr %x to invalid object %x", thing, start); */
+ } else {
+ /* Verify that it points to another valid space. */
+ if (!to_readonly_space && !to_static_space
+ && (thing != (int)&undefined_tramp)) {
+ lose("Ptr %x @ %x sees junk.", thing, start);
+ }
+ }
+ } else {
+ if (thing & 0x3) { /* Skip fixnums. FIXME: There should be an
+ * is_fixnum for this. */
+
+ switch(TypeOf(*start)) {
+
+ /* boxed objects */
+ case type_SimpleVector:
+ case type_Ratio:
+ case type_Complex:
+ case type_SimpleArray:
+ case type_ComplexString:
+ case type_ComplexBitVector:
+ case type_ComplexVector:
+ case type_ComplexArray:
+ case type_ClosureHeader:
+ case type_FuncallableInstanceHeader:
+ case type_ByteCodeFunction:
+ case type_ByteCodeClosure:
+ case type_ValueCellHeader:
+ case type_SymbolHeader:
+ case type_BaseChar:
+ case type_UnboundMarker:
+ case type_InstanceHeader:
+ case type_Fdefn:
+ count = 1;
+ break;
+
+ case type_CodeHeader:
+ {
+ lispobj object = *start;
+ struct code *code;
+ int nheader_words, ncode_words, nwords;
+ lispobj fheaderl;
+ struct function *fheaderp;
+
+ code = (struct code *) start;
+
+ /* Check that it's not in the dynamic space.
+ * FIXME: Isn't is supposed to be OK for code
+ * objects to be in the dynamic space these days? */
+ if (dynamic_space
+ /* It's ok if it's byte compiled code. The trace
+ * table offset will be a fixnum if it's x86
+ * compiled code - check. */
+ && !(code->trace_table_offset & 0x3)
+ /* Only when enabled */
+ && verify_dynamic_code_check) {
+ FSHOW((stderr,
+ "/code object at %x in the dynamic space\n",
+ start));
+ }
+
+ ncode_words = fixnum_value(code->code_size);
+ nheader_words = HeaderValue(object);
+ nwords = ncode_words + nheader_words;
+ nwords = CEILING(nwords, 2);
+ /* Scavenge the boxed section of the code data block */
+ verify_space(start + 1, nheader_words - 1);
+
+ /* Scavenge the boxed section of each function object in
+ * the code data block. */
+ fheaderl = code->entry_points;
+ while (fheaderl != NIL) {
+ fheaderp = (struct function *) PTR(fheaderl);
+ gc_assert(TypeOf(fheaderp->header) == type_FunctionHeader);
+ verify_space(&fheaderp->name, 1);
+ verify_space(&fheaderp->arglist, 1);
+ verify_space(&fheaderp->type, 1);
+ fheaderl = fheaderp->next;
+ }
+ count = nwords;
+ break;
+ }
+
+ /* unboxed objects */
+ case type_Bignum:
+ case type_SingleFloat:
+ case type_DoubleFloat:
+#ifdef type_ComplexLongFloat
+ case type_LongFloat:
+#endif
+#ifdef type_ComplexSingleFloat
+ case type_ComplexSingleFloat:
+#endif
+#ifdef type_ComplexDoubleFloat
+ case type_ComplexDoubleFloat:
+#endif
+#ifdef type_ComplexLongFloat
+ case type_ComplexLongFloat:
+#endif
+ case type_SimpleString:
+ case type_SimpleBitVector:
+ case type_SimpleArrayUnsignedByte2:
+ case type_SimpleArrayUnsignedByte4:
+ case type_SimpleArrayUnsignedByte8:
+ case type_SimpleArrayUnsignedByte16:
+ case type_SimpleArrayUnsignedByte32:
+#ifdef type_SimpleArraySignedByte8
+ case type_SimpleArraySignedByte8:
+#endif
+#ifdef type_SimpleArraySignedByte16
+ case type_SimpleArraySignedByte16:
+#endif
+#ifdef type_SimpleArraySignedByte30
+ case type_SimpleArraySignedByte30:
+#endif
+#ifdef type_SimpleArraySignedByte32
+ case type_SimpleArraySignedByte32:
+#endif
+ case type_SimpleArraySingleFloat:
+ case type_SimpleArrayDoubleFloat:
+#ifdef type_SimpleArrayComplexLongFloat
+ case type_SimpleArrayLongFloat:
+#endif
+#ifdef type_SimpleArrayComplexSingleFloat
+ case type_SimpleArrayComplexSingleFloat:
+#endif
+#ifdef type_SimpleArrayComplexDoubleFloat
+ case type_SimpleArrayComplexDoubleFloat:
+#endif
+#ifdef type_SimpleArrayComplexLongFloat
+ case type_SimpleArrayComplexLongFloat:
+#endif
+ case type_Sap:
+ case type_WeakPointer:
+ count = (sizetab[TypeOf(*start)])(start);
+ break;
+
+ default:
+ gc_abort();
+ }
+ }
+ }
+ start += count;
+ words -= count;
+ }
+}
+
+static void
+verify_gc(void)
+{
+ int read_only_space_size =
+ (lispobj*)SymbolValue(READ_ONLY_SPACE_FREE_POINTER)
+ - (lispobj*)READ_ONLY_SPACE_START;
+ int static_space_size =
+ (lispobj*)SymbolValue(STATIC_SPACE_FREE_POINTER)
+ - (lispobj*)static_space;
+ int binding_stack_size =
+ (lispobj*)SymbolValue(BINDING_STACK_POINTER)
+ - (lispobj*)BINDING_STACK_START;
+
+ verify_space((lispobj*)READ_ONLY_SPACE_START, read_only_space_size);
+ verify_space((lispobj*)static_space, static_space_size);
+ verify_space((lispobj*)BINDING_STACK_START, binding_stack_size);
+}
+
+static void
+verify_generation(int generation)
+{
+ int i;
+
+ for (i = 0; i < last_free_page; i++) {
+ if ((page_table[i].allocated != FREE_PAGE)
+ && (page_table[i].bytes_used != 0)
+ && (page_table[i].gen == generation)) {
+ int last_page;
+ int region_allocation = page_table[i].allocated;
+
+ /* This should be the start of a contiguous block */
+ gc_assert(page_table[i].first_object_offset == 0);
+
+ /* Need to find the full extent of this contiguous block in case
+ objects span pages. */
+
+ /* Now work forward until the end of this contiguous area is
+ found. */
+ for (last_page = i; ;last_page++)
+ /* Check whether this is the last page in this contiguous
+ * block. */
+ if ((page_table[last_page].bytes_used < 4096)
+ /* Or it is 4096 and is the last in the block */
+ || (page_table[last_page+1].allocated != region_allocation)
+ || (page_table[last_page+1].bytes_used == 0)
+ || (page_table[last_page+1].gen != generation)
+ || (page_table[last_page+1].first_object_offset == 0))
+ break;
+
+ verify_space(page_address(i), (page_table[last_page].bytes_used
+ + (last_page-i)*4096)/4);
+ i = last_page;
+ }
+ }
+}
+
+/* Check the all the free space is zero filled. */
+static void
+verify_zero_fill(void)
+{
+ int page;
+
+ for (page = 0; page < last_free_page; page++) {
+ if (page_table[page].allocated == FREE_PAGE) {
+ /* The whole page should be zero filled. */
+ int *start_addr = (int *)page_address(page);
+ int size = 1024;
+ int i;
+ for (i = 0; i < size; i++) {
+ if (start_addr[i] != 0) {
+ lose("free page not zero at %x", start_addr + i);
+ }
+ }
+ } else {
+ int free_bytes = 4096 - page_table[page].bytes_used;
+ if (free_bytes > 0) {
+ int *start_addr = (int *)((int)page_address(page)
+ + page_table[page].bytes_used);
+ int size = free_bytes / 4;
+ int i;
+ for (i = 0; i < size; i++) {
+ if (start_addr[i] != 0) {
+ lose("free region not zero at %x", start_addr + i);
+ }
+ }
+ }
+ }
+ }
+}
+
+/* External entry point for verify_zero_fill */
+void
+gencgc_verify_zero_fill(void)
+{
+ /* Flush the alloc regions updating the tables. */
+ boxed_region.free_pointer = current_region_free_pointer;
+ gc_alloc_update_page_tables(0, &boxed_region);
+ gc_alloc_update_page_tables(1, &unboxed_region);
+ SHOW("verifying zero fill");
+ verify_zero_fill();
+ current_region_free_pointer = boxed_region.free_pointer;
+ current_region_end_addr = boxed_region.end_addr;
+}
+
+static void
+verify_dynamic_space(void)
+{
+ int i;
+
+ for (i = 0; i < NUM_GENERATIONS; i++)
+ verify_generation(i);
+
+ if (gencgc_enable_verify_zero_fill)
+ verify_zero_fill();
+}
+\f
+/* Write-protect all the dynamic boxed pages in the given generation. */
+static void
+write_protect_generation_pages(int generation)
+{
+ int i;
+
+ gc_assert(generation < NUM_GENERATIONS);
+
+ for (i = 0; i < last_free_page; i++)
+ if ((page_table[i].allocated == BOXED_PAGE)
+ && (page_table[i].bytes_used != 0)
+ && (page_table[i].gen == generation)) {
+ void *page_start;
+
+ page_start = (void *)page_address(i);
+
+ os_protect(page_start,
+ 4096,
+ OS_VM_PROT_READ | OS_VM_PROT_EXECUTE);
+
+ /* Note the page as protected in the page tables. */
+ page_table[i].write_protected = 1;
+ }
+
+ if (gencgc_verbose > 1) {
+ FSHOW((stderr,
+ "/write protected %d of %d pages in generation %d\n",
+ count_write_protect_generation_pages(generation),
+ count_generation_pages(generation),
+ generation));
+ }
+}
+
+/* Garbage collect a generation. If raise is 0 the remains of the
+ * generation are not raised to the next generation. */
+static void
+garbage_collect_generation(int generation, int raise)
+{
+ unsigned long allocated = bytes_allocated;
+ unsigned long bytes_freed;
+ unsigned long i;
+ unsigned long read_only_space_size, static_space_size;
+
+ gc_assert(generation <= (NUM_GENERATIONS-1));
+
+ /* The oldest generation can't be raised. */
+ gc_assert((generation != (NUM_GENERATIONS-1)) || (raise == 0));
+
+ /* Initialize the weak pointer list. */
+ weak_pointers = NULL;
+
+ /* When a generation is not being raised it is transported to a
+ * temporary generation (NUM_GENERATIONS), and lowered when
+ * done. Set up this new generation. There should be no pages
+ * allocated to it yet. */
+ if (!raise)
+ gc_assert(generations[NUM_GENERATIONS].bytes_allocated == 0);
+
+ /* Set the global src and dest. generations */
+ from_space = generation;
+ if (raise)
+ new_space = generation+1;
+ else
+ new_space = NUM_GENERATIONS;
+
+ /* Change to a new space for allocation, resetting the alloc_start_page */
+ gc_alloc_generation = new_space;
+ generations[new_space].alloc_start_page = 0;
+ generations[new_space].alloc_unboxed_start_page = 0;
+ generations[new_space].alloc_large_start_page = 0;
+ generations[new_space].alloc_large_unboxed_start_page = 0;
+
+ /* Before any pointers are preserved, the dont_move flags on the
+ * pages need to be cleared. */
+ for (i = 0; i < last_free_page; i++)
+ page_table[i].dont_move = 0;
+
+ /* Un-write-protect the old-space pages. This is essential for the
+ * promoted pages as they may contain pointers into the old-space
+ * which need to be scavenged. It also helps avoid unnecessary page
+ * faults as forwarding pointer are written into them. They need to
+ * be un-protected anyway before unmapping later. */
+ unprotect_oldspace();
+
+ /* Scavenge the stack's conservative roots. */
+ {
+ lispobj **ptr;
+ for (ptr = (lispobj **)CONTROL_STACK_END-1;
+ ptr > (lispobj **)&raise; ptr--)
+ preserve_pointer(*ptr);
+ }
+#ifdef CONTROL_STACKS
+ scavenge_thread_stacks();
+#endif
+
+ if (gencgc_verbose > 1) {
+ int num_dont_move_pages = count_dont_move_pages();
+ FSHOW((stderr,
+ "/non-movable pages due to conservative pointers = %d (%d bytes)\n",
+ num_dont_move_pages,
+ /* FIXME: 4096 should be symbolic constant here and
+ * prob'ly elsewhere too. */
+ num_dont_move_pages * 4096));
+ }
+
+ /* Scavenge all the rest of the roots. */
+
+ /* Scavenge the Lisp functions of the interrupt handlers, taking
+ * care to avoid SIG_DFL, SIG_IGN. */
+ for (i = 0; i < NSIG; i++) {
+ union interrupt_handler handler = interrupt_handlers[i];
+ if (!ARE_SAME_HANDLER(handler.c, SIG_IGN) &&
+ !ARE_SAME_HANDLER(handler.c, SIG_DFL)) {
+ scavenge((lispobj *)(interrupt_handlers + i), 1);
+ }
+ }
+
+ /* Scavenge the binding stack. */
+ scavenge(binding_stack,
+ (lispobj *)SymbolValue(BINDING_STACK_POINTER) - binding_stack);
+
+ if (SymbolValue(SCAVENGE_READ_ONLY_SPACE) != NIL) {
+ read_only_space_size =
+ (lispobj *)SymbolValue(READ_ONLY_SPACE_FREE_POINTER)
+ - read_only_space;
+ FSHOW((stderr,
+ "/scavenge read only space: %d bytes\n",
+ read_only_space_size * sizeof(lispobj)));
+ scavenge(read_only_space, read_only_space_size);
+ }
+
+ static_space_size = (lispobj *)SymbolValue(STATIC_SPACE_FREE_POINTER)
+ - static_space;
+ if (gencgc_verbose > 1)
+ FSHOW((stderr,
+ "/scavenge static space: %d bytes\n",
+ static_space_size * sizeof(lispobj)));
+ scavenge(static_space, static_space_size);
+
+ /* All generations but the generation being GCed need to be
+ * scavenged. The new_space generation needs special handling as
+ * objects may be moved in - it is handled separately below. */
+ for (i = 0; i < NUM_GENERATIONS; i++)
+ if ((i != generation) && (i != new_space))
+ scavenge_generation(i);
+
+ /* Finally scavenge the new_space generation. Keep going until no
+ * more objects are moved into the new generation */
+ scavenge_newspace_generation(new_space);
+
+#define RESCAN_CHECK 0
+#if RESCAN_CHECK
+ /* As a check re-scavenge the newspace once; no new objects should
+ * be found. */
+ {
+ int old_bytes_allocated = bytes_allocated;
+ int bytes_allocated;
+
+ /* Start with a full scavenge. */
+ scavenge_newspace_generation_one_scan(new_space);
+
+ /* Flush the current regions, updating the tables. */
+ gc_alloc_update_page_tables(0, &boxed_region);
+ gc_alloc_update_page_tables(1, &unboxed_region);
+
+ bytes_allocated = bytes_allocated - old_bytes_allocated;
+
+ if (bytes_allocated != 0) {
+ lose("Rescan of new_space allocated %d more bytes.",
+ bytes_allocated);
+ }
+ }
+#endif
+
+ scan_weak_pointers();
+
+ /* Flush the current regions, updating the tables. */
+ gc_alloc_update_page_tables(0, &boxed_region);
+ gc_alloc_update_page_tables(1, &unboxed_region);
+
+ /* Free the pages in oldspace, but not those marked dont_move. */
+ bytes_freed = free_oldspace();
+
+ /* If the GC is not raising the age then lower the generation back
+ * to its normal generation number */
+ if (!raise) {
+ for (i = 0; i < last_free_page; i++)
+ if ((page_table[i].bytes_used != 0)
+ && (page_table[i].gen == NUM_GENERATIONS))
+ page_table[i].gen = generation;
+ gc_assert(generations[generation].bytes_allocated == 0);
+ generations[generation].bytes_allocated =
+ generations[NUM_GENERATIONS].bytes_allocated;
+ generations[NUM_GENERATIONS].bytes_allocated = 0;
+ }
+
+ /* Reset the alloc_start_page for generation. */
+ generations[generation].alloc_start_page = 0;
+ generations[generation].alloc_unboxed_start_page = 0;
+ generations[generation].alloc_large_start_page = 0;
+ generations[generation].alloc_large_unboxed_start_page = 0;
+
+ if (generation >= verify_gens) {
+ if (gencgc_verbose)
+ SHOW("verifying");
+ verify_gc();
+ verify_dynamic_space();
+ }
+
+ /* Set the new gc trigger for the GCed generation. */
+ generations[generation].gc_trigger =
+ generations[generation].bytes_allocated
+ + generations[generation].bytes_consed_between_gc;
+
+ if (raise)
+ generations[generation].num_gc = 0;
+ else
+ ++generations[generation].num_gc;
+}
+
+/* Update last_free_page then ALLOCATION_POINTER */
+int
+update_x86_dynamic_space_free_pointer(void)
+{
+ int last_page = -1;
+ int i;
+
+ for (i = 0; i < NUM_PAGES; i++)
+ if ((page_table[i].allocated != FREE_PAGE)
+ && (page_table[i].bytes_used != 0))
+ last_page = i;
+
+ last_free_page = last_page+1;
+
+ SetSymbolValue(ALLOCATION_POINTER,
+ (lispobj)(((char *)heap_base) + last_free_page*4096));
+}
+
+/* GC all generations below last_gen, raising their objects to the
+ * next generation until all generations below last_gen are empty.
+ * Then if last_gen is due for a GC then GC it. In the special case
+ * that last_gen==NUM_GENERATIONS, the last generation is always
+ * GC'ed. The valid range for last_gen is: 0,1,...,NUM_GENERATIONS.
+ *
+ * The oldest generation to be GCed will always be
+ * gencgc_oldest_gen_to_gc, partly ignoring last_gen if necessary. */
+void
+collect_garbage(unsigned last_gen)
+{
+ int gen = 0;
+ int raise;
+ int gen_to_wp;
+ int i;
+
+ boxed_region.free_pointer = current_region_free_pointer;
+
+ FSHOW((stderr, "/entering collect_garbage(%d)\n", last_gen));
+
+ if (last_gen > NUM_GENERATIONS) {
+ FSHOW((stderr,
+ "/collect_garbage: last_gen = %d, doing a level 0 GC\n",
+ last_gen));
+ last_gen = 0;
+ }
+
+ /* Flush the alloc regions updating the tables. */
+ gc_alloc_update_page_tables(0, &boxed_region);
+ gc_alloc_update_page_tables(1, &unboxed_region);
+
+ /* Verify the new objects created by Lisp code. */
+ if (pre_verify_gen_0) {
+ SHOW((stderr, "pre-checking generation 0\n"));
+ verify_generation(0);
+ }
+
+ if (gencgc_verbose > 1)
+ print_generation_stats(0);
+
+ do {
+ /* Collect the generation. */
+
+ if (gen >= gencgc_oldest_gen_to_gc) {
+ /* Never raise the oldest generation. */
+ raise = 0;
+ } else {
+ raise =
+ (gen < last_gen)
+ || (generations[gen].num_gc >= generations[gen].trigger_age);
+ }
+
+ if (gencgc_verbose > 1) {
+ FSHOW((stderr,
+ "Starting GC of generation %d with raise=%d alloc=%d trig=%d GCs=%d\n",
+ gen,
+ raise,
+ generations[gen].bytes_allocated,
+ generations[gen].gc_trigger,
+ generations[gen].num_gc));
+ }
+
+ /* If an older generation is being filled then update its memory
+ * age. */
+ if (raise == 1) {
+ generations[gen+1].cum_sum_bytes_allocated +=
+ generations[gen+1].bytes_allocated;
+ }
+
+ garbage_collect_generation(gen, raise);
+
+ /* Reset the memory age cum_sum. */
+ generations[gen].cum_sum_bytes_allocated = 0;
+
+ if (gencgc_verbose > 1) {
+ FSHOW((stderr, "GC of generation %d finished:\n", gen));
+ print_generation_stats(0);
+ }
+
+ gen++;
+ } while ((gen <= gencgc_oldest_gen_to_gc)
+ && ((gen < last_gen)
+ || ((gen <= gencgc_oldest_gen_to_gc)
+ && raise
+ && (generations[gen].bytes_allocated
+ > generations[gen].gc_trigger)
+ && (gen_av_mem_age(gen)
+ > generations[gen].min_av_mem_age))));
+
+ /* Now if gen-1 was raised all generations before gen are empty.
+ * If it wasn't raised then all generations before gen-1 are empty.
+ *
+ * Now objects within this gen's pages cannot point to younger
+ * generations unless they are written to. This can be exploited
+ * by write-protecting the pages of gen; then when younger
+ * generations are GCed only the pages which have been written
+ * need scanning. */
+ if (raise)
+ gen_to_wp = gen;
+ else
+ gen_to_wp = gen - 1;
+
+ /* There's not much point in WPing pages in generation 0 as it is
+ * never scavenged (except promoted pages). */
+ if ((gen_to_wp > 0) && enable_page_protection) {
+ /* Check that they are all empty. */
+ for (i = 0; i < gen_to_wp; i++) {
+ if (generations[i].bytes_allocated)
+ lose("trying to write-protect gen. %d when gen. %d nonempty",
+ gen_to_wp, i);
+ }
+ write_protect_generation_pages(gen_to_wp);
+ }
+
+ /* Set gc_alloc back to generation 0. The current regions should
+ * be flushed after the above GCs */
+ gc_assert((boxed_region.free_pointer - boxed_region.start_addr) == 0);
+ gc_alloc_generation = 0;
+
+ update_x86_dynamic_space_free_pointer();
+
+ /* This is now done by Lisp SCRUB-CONTROL-STACK in Lisp SUB-GC, so we
+ * needn't do it here: */
+ /* zero_stack();*/
+
+ current_region_free_pointer = boxed_region.free_pointer;
+ current_region_end_addr = boxed_region.end_addr;
+
+ SHOW("returning from collect_garbage");
+}
+
+/* This is called by Lisp PURIFY when it is finished. All live objects
+ * will have been moved to the RO and Static heaps. The dynamic space
+ * will need a full re-initialization. We don't bother having Lisp
+ * PURIFY flush the current gc_alloc region, as the page_tables are
+ * re-initialized, and every page is zeroed to be sure. */
+void
+gc_free_heap(void)
+{
+ int page;
+
+ if (gencgc_verbose > 1)
+ SHOW("entering gc_free_heap");
+
+ for (page = 0; page < NUM_PAGES; page++) {
+ /* Skip free pages which should already be zero filled. */
+ if (page_table[page].allocated != FREE_PAGE) {
+ void *page_start, *addr;
+
+ /* Mark the page free. The other slots are assumed invalid
+ * when it is a FREE_PAGE and bytes_used is 0 and it
+ * should not be write-protected -- except that the
+ * generation is used for the current region but it sets
+ * that up. */
+ page_table[page].allocated = FREE_PAGE;
+ page_table[page].bytes_used = 0;
+
+ /* Zero the page. */
+ page_start = (void *)page_address(page);
+
+ /* First, remove any write-protection. */
+ os_protect(page_start, 4096, OS_VM_PROT_ALL);
+ page_table[page].write_protected = 0;
+
+ os_invalidate(page_start,4096);
+ addr = os_validate(page_start,4096);
+ if (addr == NULL || addr != page_start) {
+ lose("gc_free_heap: page moved, 0x%08x ==> 0x%08x",
+ page_start,
+ addr);
+ }
+ } else if (gencgc_zero_check_during_free_heap) {
+ int *page_start, i;
+
+ /* Double-check that the page is zero filled. */
+ gc_assert(page_table[page].allocated == FREE_PAGE);
+ gc_assert(page_table[page].bytes_used == 0);
+
+ page_start = (int *)page_address(i);
+
+ for (i=0; i<1024; i++) {
+ if (page_start[i] != 0) {
+ lose("free region not zero at %x", page_start + i);
+ }
+ }
+ }
+ }
+
+ bytes_allocated = 0;
+
+ /* Initialize the generations. */
+ for (page = 0; page < NUM_GENERATIONS; page++) {
+ generations[page].alloc_start_page = 0;
+ generations[page].alloc_unboxed_start_page = 0;
+ generations[page].alloc_large_start_page = 0;
+ generations[page].alloc_large_unboxed_start_page = 0;
+ generations[page].bytes_allocated = 0;
+ generations[page].gc_trigger = 2000000;
+ generations[page].num_gc = 0;
+ generations[page].cum_sum_bytes_allocated = 0;
+ }
+
+ if (gencgc_verbose > 1)
+ print_generation_stats(0);
+
+ /* Initialize gc_alloc */
+ gc_alloc_generation = 0;
+ boxed_region.first_page = 0;
+ boxed_region.last_page = -1;
+ boxed_region.start_addr = page_address(0);
+ boxed_region.free_pointer = page_address(0);
+ boxed_region.end_addr = page_address(0);
+
+ unboxed_region.first_page = 0;
+ unboxed_region.last_page = -1;
+ unboxed_region.start_addr = page_address(0);
+ unboxed_region.free_pointer = page_address(0);
+ unboxed_region.end_addr = page_address(0);
+
+#if 0 /* Lisp PURIFY is currently running on the C stack so don't do this. */
+ zero_stack();
+#endif
+
+ last_free_page = 0;
+ SetSymbolValue(ALLOCATION_POINTER, (lispobj)((char *)heap_base));
+
+ current_region_free_pointer = boxed_region.free_pointer;
+ current_region_end_addr = boxed_region.end_addr;
+
+ if (verify_after_free_heap) {
+ /* Check whether purify has left any bad pointers. */
+ if (gencgc_verbose)
+ SHOW("checking after free_heap\n");
+ verify_gc();
+ }
+}
+\f
+void
+gc_init(void)
+{
+ int i;
+
+ gc_init_tables();
+
+ heap_base = (void*)DYNAMIC_0_SPACE_START;
+
+ /* Initialize each page structure. */
+ for (i = 0; i < NUM_PAGES; i++) {
+ /* Initialize all pages as free. */
+ page_table[i].allocated = FREE_PAGE;
+ page_table[i].bytes_used = 0;
+
+ /* Pages are not write-protected at startup. */
+ page_table[i].write_protected = 0;
+ }
+
+ bytes_allocated = 0;
+
+ /* Initialize the generations. */
+ for (i = 0; i < NUM_GENERATIONS; i++) {
+ generations[i].alloc_start_page = 0;
+ generations[i].alloc_unboxed_start_page = 0;
+ generations[i].alloc_large_start_page = 0;
+ generations[i].alloc_large_unboxed_start_page = 0;
+ generations[i].bytes_allocated = 0;
+ generations[i].gc_trigger = 2000000;
+ generations[i].num_gc = 0;
+ generations[i].cum_sum_bytes_allocated = 0;
+ /* the tune-able parameters */
+ generations[i].bytes_consed_between_gc = 2000000;
+ generations[i].trigger_age = 1;
+ generations[i].min_av_mem_age = 0.75;
+ }
+
+ /* Initialize gc_alloc. */
+ gc_alloc_generation = 0;
+ boxed_region.first_page = 0;
+ boxed_region.last_page = -1;
+ boxed_region.start_addr = page_address(0);
+ boxed_region.free_pointer = page_address(0);
+ boxed_region.end_addr = page_address(0);
+
+ unboxed_region.first_page = 0;
+ unboxed_region.last_page = -1;
+ unboxed_region.start_addr = page_address(0);
+ unboxed_region.free_pointer = page_address(0);
+ unboxed_region.end_addr = page_address(0);
+
+ last_free_page = 0;
+
+ current_region_free_pointer = boxed_region.free_pointer;
+ current_region_end_addr = boxed_region.end_addr;
+}
+
+/* Pick up the dynamic space from after a core load.
+ *
+ * The ALLOCATION_POINTER points to the end of the dynamic space.
+ *
+ * XX A scan is needed to identify the closest first objects for pages. */
+void
+gencgc_pickup_dynamic(void)
+{
+ int page = 0;
+ int addr = DYNAMIC_0_SPACE_START;
+ int alloc_ptr = SymbolValue(ALLOCATION_POINTER);
+
+ /* Initialize the first region. */
+ do {
+ page_table[page].allocated = BOXED_PAGE;
+ page_table[page].gen = 0;
+ page_table[page].bytes_used = 4096;
+ page_table[page].large_object = 0;
+ page_table[page].first_object_offset =
+ (void *)DYNAMIC_0_SPACE_START - page_address(page);
+ addr += 4096;
+ page++;
+ } while (addr < alloc_ptr);
+
+ generations[0].bytes_allocated = 4096*page;
+ bytes_allocated = 4096*page;
+
+ current_region_free_pointer = boxed_region.free_pointer;
+ current_region_end_addr = boxed_region.end_addr;
+}
+\f
+/* a counter for how deep we are in alloc(..) calls */
+int alloc_entered = 0;
+
+/* alloc(..) is the external interface for memory allocation. It
+ * allocates to generation 0. It is not called from within the garbage
+ * collector as it is only external uses that need the check for heap
+ * size (GC trigger) and to disable the interrupts (interrupts are
+ * always disabled during a GC).
+ *
+ * The vops that call alloc(..) assume that the returned space is zero-filled.
+ * (E.g. the most significant word of a 2-word bignum in MOVE-FROM-UNSIGNED.)
+ *
+ * The check for a GC trigger is only performed when the current
+ * region is full, so in most cases it's not needed. Further MAYBE-GC
+ * is only called once because Lisp will remember "need to collect
+ * garbage" and get around to it when it can. */
+char *
+alloc(int nbytes)
+{
+ /* Check for alignment allocation problems. */
+ gc_assert((((unsigned)current_region_free_pointer & 0x7) == 0)
+ && ((nbytes & 0x7) == 0));
+
+ if (SymbolValue(PSEUDO_ATOMIC_ATOMIC)) {/* if already in a pseudo atomic */
+
+ void *new_free_pointer;
+
+ retry1:
+ if (alloc_entered) {
+ SHOW("alloc re-entered in already-pseudo-atomic case");
+ }
+ ++alloc_entered;
+
+ /* Check whether there is room in the current region. */
+ new_free_pointer = current_region_free_pointer + nbytes;
+
+ /* FIXME: Shouldn't we be doing some sort of lock here, to
+ * keep from getting screwed if an interrupt service routine
+ * allocates memory between the time we calculate new_free_pointer
+ * and the time we write it back to current_region_free_pointer?
+ * Perhaps I just don't understand pseudo-atomics..
+ *
+ * Perhaps I don't. It looks as though what happens is if we
+ * were interrupted any time during the pseudo-atomic
+ * interval (which includes now) we discard the allocated
+ * memory and try again. So, at least we don't return
+ * a memory area that was allocated out from underneath us
+ * by code in an ISR.
+ * Still, that doesn't seem to prevent
+ * current_region_free_pointer from getting corrupted:
+ * We read current_region_free_pointer.
+ * They read current_region_free_pointer.
+ * They write current_region_free_pointer.
+ * We write current_region_free_pointer, scribbling over
+ * whatever they wrote. */
+
+ if (new_free_pointer <= boxed_region.end_addr) {
+ /* If so then allocate from the current region. */
+ void *new_obj = current_region_free_pointer;
+ current_region_free_pointer = new_free_pointer;
+ alloc_entered--;
+ return((void *)new_obj);
+ }
+
+ if (auto_gc_trigger && bytes_allocated > auto_gc_trigger) {
+ /* Double the trigger. */
+ auto_gc_trigger *= 2;
+ alloc_entered--;
+ /* Exit the pseudo-atomic. */
+ SetSymbolValue(PSEUDO_ATOMIC_ATOMIC, make_fixnum(0));
+ if (SymbolValue(PSEUDO_ATOMIC_INTERRUPTED) != 0) {
+ /* Handle any interrupts that occurred during
+ * gc_alloc(..). */
+ do_pending_interrupt();
+ }
+ funcall0(SymbolFunction(MAYBE_GC));
+ /* Re-enter the pseudo-atomic. */
+ SetSymbolValue(PSEUDO_ATOMIC_INTERRUPTED, make_fixnum(0));
+ SetSymbolValue(PSEUDO_ATOMIC_ATOMIC, make_fixnum(1));
+ goto retry1;
+ }
+ /* Call gc_alloc. */
+ boxed_region.free_pointer = current_region_free_pointer;
+ {
+ void *new_obj = gc_alloc(nbytes);
+ current_region_free_pointer = boxed_region.free_pointer;
+ current_region_end_addr = boxed_region.end_addr;
+ alloc_entered--;
+ return (new_obj);
+ }
+ } else {
+ void *result;
+ void *new_free_pointer;
+
+ retry2:
+ /* At least wrap this allocation in a pseudo atomic to prevent
+ * gc_alloc from being re-entered. */
+ SetSymbolValue(PSEUDO_ATOMIC_INTERRUPTED, make_fixnum(0));
+ SetSymbolValue(PSEUDO_ATOMIC_ATOMIC, make_fixnum(1));
+
+ if (alloc_entered)
+ SHOW("alloc re-entered in not-already-pseudo-atomic case");
+ ++alloc_entered;
+
+ /* Check whether there is room in the current region. */
+ new_free_pointer = current_region_free_pointer + nbytes;
+
+ if (new_free_pointer <= boxed_region.end_addr) {
+ /* If so then allocate from the current region. */
+ void *new_obj = current_region_free_pointer;
+ current_region_free_pointer = new_free_pointer;
+ alloc_entered--;
+ SetSymbolValue(PSEUDO_ATOMIC_ATOMIC, make_fixnum(0));
+ if (SymbolValue(PSEUDO_ATOMIC_INTERRUPTED)) {
+ /* Handle any interrupts that occurred during
+ * gc_alloc(..). */
+ do_pending_interrupt();
+ goto retry2;
+ }
+
+ return((void *)new_obj);
+ }
+
+ /* KLUDGE: There's lots of code around here shared with the
+ * the other branch. Is there some way to factor out the
+ * duplicate code? -- WHN 19991129 */
+ if (auto_gc_trigger && bytes_allocated > auto_gc_trigger) {
+ /* Double the trigger. */
+ auto_gc_trigger *= 2;
+ alloc_entered--;
+ /* Exit the pseudo atomic. */
+ SetSymbolValue(PSEUDO_ATOMIC_ATOMIC, make_fixnum(0));
+ if (SymbolValue(PSEUDO_ATOMIC_INTERRUPTED) != 0) {
+ /* Handle any interrupts that occurred during
+ * gc_alloc(..); */
+ do_pending_interrupt();
+ }
+ funcall0(SymbolFunction(MAYBE_GC));
+ goto retry2;
+ }
+
+ /* Else call gc_alloc. */
+ boxed_region.free_pointer = current_region_free_pointer;
+ result = gc_alloc(nbytes);
+ current_region_free_pointer = boxed_region.free_pointer;
+ current_region_end_addr = boxed_region.end_addr;
+
+ alloc_entered--;
+ SetSymbolValue(PSEUDO_ATOMIC_ATOMIC, make_fixnum(0));
+ if (SymbolValue(PSEUDO_ATOMIC_INTERRUPTED) != 0) {
+ /* Handle any interrupts that occurred during
+ * gc_alloc(..). */
+ do_pending_interrupt();
+ goto retry2;
+ }
+
+ return result;
+ }
+}
+\f
+/*
+ * noise to manipulate the gc trigger stuff
+ */
+
+void
+set_auto_gc_trigger(os_vm_size_t dynamic_usage)
+{
+ auto_gc_trigger += dynamic_usage;
+}
+
+void
+clear_auto_gc_trigger(void)
+{
+ auto_gc_trigger = 0;
+}
+\f
+/* Find the code object for the given pc, or return NULL on failure. */
+lispobj*
+component_ptr_from_pc(lispobj *pc)
+{
+ lispobj *object = NULL;
+
+ if (object = search_read_only_space(pc))
+ ;
+ else if (object = search_static_space(pc))
+ ;
+ else
+ object = search_dynamic_space(pc);
+
+ if (object) /* if we found something */
+ if (TypeOf(*object) == type_CodeHeader) /* if it's a code object */
+ return(object);
+
+ return (NULL);
+}
+\f
+/*
+ * shared support for the OS-dependent signal handlers which
+ * catch GENCGC-related write-protect violations
+ */
+
+/* Depending on which OS we're running under, different signals might
+ * be raised for a violation of write protection in the heap. This
+ * function factors out the common generational GC magic which needs
+ * to invoked in this case, and should be called from whatever signal
+ * handler is appropriate for the OS we're running under.
+ *
+ * Return true if this signal is a normal generational GC thing that
+ * we were able to handle, or false if it was abnormal and control
+ * should fall through to the general SIGSEGV/SIGBUS/whatever logic. */
+int
+gencgc_handle_wp_violation(void* fault_addr)
+{
+ int page_index = find_page_index(fault_addr);
+
+#if defined QSHOW_SIGNALS
+ FSHOW((stderr, "heap WP violation? fault_addr=%x, page_index=%d\n",
+ fault_addr, page_index));
+#endif
+
+ /* Check whether the fault is within the dynamic space. */
+ if (page_index == (-1)) {
+
+ /* not within the dynamic space -- not our responsibility */
+ return 0;
+
+ } else {
+
+ /* The only acceptable reason for an signal like this from the
+ * heap is that the generational GC write-protected the page. */
+ if (page_table[page_index].write_protected != 1) {
+ lose("access failure in heap page not marked as write-protected");
+ }
+
+ /* Unprotect the page. */
+ os_protect(page_address(page_index), 4096, OS_VM_PROT_ALL);
+ page_table[page_index].write_protected = 0;
+ page_table[page_index].write_protected_cleared = 1;
+
+ /* Don't worry, we can handle it. */
+ return 1;
+ }
+}
--- /dev/null
+/*
+ * Generational Conservative Garbage Collector for SBCL x86
+ */
+
+/*
+ * This software is part of the SBCL system. See the README file for
+ * more information.
+ *
+ * This software is derived from the CMU CL system, which was
+ * written at Carnegie Mellon University and released into the
+ * public domain. The software is in the public domain and is
+ * provided with absolutely no warranty. See the COPYING and CREDITS
+ * files for more information.
+ */
+
+/*
+ * $Header$
+ */
+
+#ifndef _GENCGC_H_
+#define _GENCGC_H_
+
+void gc_free_heap(void);
+inline int find_page_index(void *);
+inline void *page_address(int);
+int gencgc_handle_wp_violation(void *);
+lispobj *search_dynamic_space(lispobj *);
+\f
+struct page {
+
+ unsigned
+ /* This is set when the page is write-protected. This should
+ * always reflect the actual write_protect status of a page.
+ * (If the page is written into, we catch the exception, make
+ * the page writable, and clear this flag.) */
+ write_protected :1,
+ /* This flag is set when the above write_protected flag is
+ * cleared by the sigbus handler. This is useful for
+ * re-scavenging pages that are written during a GC. */
+ write_protected_cleared :1,
+ /* The region the page is allocated to: 0 for a free page; 1
+ * for boxed objects; 2 for unboxed objects. If the page is
+ * free the following slots are invalid (well the bytes_used
+ * must be 0). */
+ allocated :2,
+ /* If this page should not be moved during a GC then this flag
+ * is set. It's only valid during a GC for allocated pages. */
+ dont_move :1,
+ /* If the page is part of a large object then this flag is
+ * set. No other objects should be allocated to these pages.
+ * This is only valid when the page is allocated. */
+ large_object :1;
+
+ /* the generation that this page belongs to. This should be valid
+ * for all pages that may have objects allocated, even current
+ * allocation region pages - this allows the space of an object to
+ * be easily determined. */
+ int gen;
+
+ /* the number of bytes of this page that are used. This may be less
+ * than the actual bytes used for pages within the current
+ * allocation regions. It should be 0 for all unallocated pages (not
+ * hard to achieve). */
+ int bytes_used;
+
+ /* It is important to know the offset to the first object in the
+ * page. Currently it's only important to know if an object starts
+ * at the beginning of the page in which case the offset would be 0. */
+ int first_object_offset;
+};
+
+#define FREE_PAGE 0
+#define BOXED_PAGE 1
+#define UNBOXED_PAGE 2
+\f
+/* the number of pages needed for the dynamic space - rounding up */
+#define NUM_PAGES ((DYNAMIC_SPACE_SIZE+4095)/4096)
+extern struct page page_table[NUM_PAGES];
+\f
+/* Abstract out the data for an allocation region allowing a single
+ * routine to be used for allocation and closing. */
+struct alloc_region {
+
+ /* These two are needed for quick allocation. */
+ void *free_pointer;
+ void *end_addr; /* pointer to the byte after the last usable byte */
+
+ /* needed when closing the region */
+ int first_page;
+ int last_page;
+ void *start_addr;
+};
+
+extern struct alloc_region boxed_region;
+extern struct alloc_region unboxed_region;
+\f
+void gencgc_pickup_dynamic(void);
+
+void sniff_code_object(struct code *code, unsigned displacement);
+
+int update_x86_dynamic_space_free_pointer(void);
+void gc_alloc_update_page_tables(int unboxed,
+ struct alloc_region *alloc_region);
+#endif _GENCGC_H_
--- /dev/null
+/*
+ * variables everybody needs to look at or frob on
+ */
+
+/*
+ * This software is part of the SBCL system. See the README file for
+ * more information.
+ *
+ * This software is derived from the CMU CL system, which was
+ * written at Carnegie Mellon University and released into the
+ * public domain. The software is in the public domain and is
+ * provided with absolutely no warranty. See the COPYING and CREDITS
+ * files for more information.
+ */
+
+/*
+ * $Header$
+ */
+
+#include <stdio.h>
+
+#include "runtime.h"
+#include "sbcl.h"
+#include "globals.h"
+
+int foreign_function_call_active;
+
+lispobj *current_control_stack_pointer;
+lispobj *current_control_frame_pointer;
+#ifndef BINDING_STACK_POINTER
+lispobj *current_binding_stack_pointer;
+#endif
+
+lispobj *read_only_space;
+lispobj *static_space;
+lispobj *dynamic_0_space;
+lispobj *dynamic_1_space;
+lispobj *control_stack;
+#ifdef __i386__
+lispobj *control_stack_end;
+#endif
+lispobj *binding_stack;
+
+lispobj *current_dynamic_space;
+#ifndef ALLOCATION_POINTER
+lispobj *current_dynamic_space_free_pointer;
+#endif
+#ifndef INTERNAL_GC_TRIGGER
+lispobj *current_auto_gc_trigger;
+#endif
+
+void globals_init(void)
+{
+ /* Space, stack, and free pointer vars are initialized by
+ * validate() and coreparse(). */
+
+#ifndef INTERNAL_GC_TRIGGER
+ /* no GC trigger yet */
+ current_auto_gc_trigger = NULL;
+#endif
+
+ /* Set foreign function call active. */
+ foreign_function_call_active = 1;
+
+ /* Initialize the current Lisp state. */
+#ifndef __i386__
+ current_control_stack_pointer = control_stack;
+#else
+ current_control_stack_pointer = control_stack_end;
+#endif
+
+ current_control_frame_pointer = (lispobj *)0;
+#ifndef BINDING_STACK_POINTER
+ current_binding_stack_pointer = binding_stack;
+#endif
+}
--- /dev/null
+/*
+ * This software is part of the SBCL system. See the README file for
+ * more information.
+ *
+ * This software is derived from the CMU CL system, which was
+ * written at Carnegie Mellon University and released into the
+ * public domain. The software is in the public domain and is
+ * provided with absolutely no warranty. See the COPYING and CREDITS
+ * files for more information.
+ */
+
+/*
+ * $Header$
+ */
+
+#if !defined(_INCLUDE_GLOBALS_H_)
+#define _INCLUDED_GLOBALS_H_
+
+#ifndef LANGUAGE_ASSEMBLY
+
+#include "runtime.h"
+
+extern int foreign_function_call_active;
+
+extern lispobj *current_control_stack_pointer;
+extern lispobj *current_control_frame_pointer;
+#if !defined(ibmrt) && !defined(__i386__)
+extern lispobj *current_binding_stack_pointer;
+#endif
+
+extern lispobj *read_only_space;
+extern lispobj *static_space;
+extern lispobj *dynamic_0_space;
+extern lispobj *dynamic_1_space;
+extern lispobj *control_stack;
+extern lispobj *binding_stack;
+#ifdef __i386__
+extern lispobj *control_stack_end;
+#endif
+extern lispobj *current_dynamic_space;
+#if !defined(ibmrt) && !defined(__i386__)
+extern lispobj *current_dynamic_space_free_pointer;
+extern lispobj *current_auto_gc_trigger;
+#endif
+
+extern void globals_init(void);
+
+#else LANGUAGE_ASSEMBLY
+
+/* These are needed by ./assem.s */
+
+#ifdef mips
+#define EXTERN(name,bytes) .extern name bytes
+#endif
+#ifdef sparc
+#ifdef SVR4
+#define EXTERN(name,bytes) .global name
+#else
+#define EXTERN(name,bytes) .global _ ## name
+#endif
+#endif
+#ifdef ibmrt
+#define EXTERN(name,bytes) .globl _/**/name
+#endif
+
+#ifdef __i386__
+#ifdef __linux__
+#define EXTERN(name,bytes) .globl _/**/name
+#else
+#define EXTERN(name,bytes) .global _ ## name
+#endif
+#endif
+
+EXTERN(foreign_function_call_active, 4)
+
+EXTERN(current_control_stack_pointer, 4)
+EXTERN(current_control_frame_pointer, 4)
+#if !defined(ibmrt) && !defined(__i386__)
+EXTERN(current_binding_stack_pointer, 4)
+EXTERN(current_dynamic_space_free_pointer, 4)
+#endif
+
+#ifdef mips
+EXTERN(current_flags_register, 4)
+#endif
+
+#endif LANGUAGE_ASSEMBLY
+
+#endif _INCLUDED_GLOBALS_H_
--- /dev/null
+/*
+ * stuff to handle internal errors
+ */
+
+/*
+ * This software is part of the SBCL system. See the README file for
+ * more information.
+ *
+ * This software is derived from the CMU CL system, which was
+ * written at Carnegie Mellon University and released into the
+ * public domain. The software is in the public domain and is
+ * provided with absolutely no warranty. See the COPYING and CREDITS
+ * files for more information.
+ */
+
+/*
+ * $Header$
+ */
+
+#include <stdio.h>
+#include <stdarg.h>
+
+#include "arch.h"
+#include "signal.h"
+
+#include "runtime.h"
+#include "sbcl.h"
+#include "interr.h"
+#include "print.h"
+#include "lispregs.h"
+\f
+/* the way that we shut down the system on a fatal error */
+
+static void
+default_lossage_handler(void)
+{
+ exit(1);
+}
+static void (*lossage_handler)(void) = default_lossage_handler;
+void
+set_lossage_handler(void handler(void))
+{
+ lossage_handler = handler;
+}
+
+void
+lose(char *fmt, ...)
+{
+ va_list ap;
+ fprintf(stderr, "fatal error encountered in SBCL runtime system");
+ if (fmt) {
+ fprintf(stderr, ":\n");
+ va_start(ap, fmt);
+ vfprintf(stderr, fmt, ap);
+ va_end(ap);
+ }
+ fprintf(stderr, "\n");
+ fflush(stderr);
+ lossage_handler();
+}
+\f
+/* internal error handler for when the Lisp error system doesn't exist
+ *
+ * FIXME: Shouldn't error output go to stderr instead of stdout? (Alas,
+ * this'd require changes in a number of things like brief_print(..),
+ * or I'd have changed it immediately.) */
+void
+describe_internal_error(os_context_t *context)
+{
+ unsigned char *ptr = arch_internal_error_arguments(context);
+ int len, scoffset, sc, offset, ch;
+
+ len = *ptr++;
+ printf("internal error #%d\n", *ptr++);
+ len--;
+ while (len > 0) {
+ scoffset = *ptr++;
+ len--;
+ if (scoffset == 253) {
+ scoffset = *ptr++;
+ len--;
+ }
+ else if (scoffset == 254) {
+ scoffset = ptr[0] + ptr[1]*256;
+ ptr += 2;
+ len -= 2;
+ }
+ else if (scoffset == 255) {
+ scoffset = ptr[0] + (ptr[1]<<8) + (ptr[2]<<16) + (ptr[3]<<24);
+ ptr += 4;
+ len -= 4;
+ }
+ sc = scoffset & 0x1f;
+ offset = scoffset >> 5;
+
+ printf(" SC: %d, Offset: %d", sc, offset);
+ switch (sc) {
+ case sc_AnyReg:
+ case sc_DescriptorReg:
+ putchar('\t');
+ brief_print(*os_context_register_addr(context, offset));
+ break;
+
+ case sc_BaseCharReg:
+ ch = *os_context_register_addr(context, offset);
+#ifdef __i386__
+ if (offset&1)
+ ch = ch>>8;
+ ch = ch & 0xff;
+#endif
+ switch (ch) {
+ case '\n': printf("\t'\\n'\n"); break;
+ case '\b': printf("\t'\\b'\n"); break;
+ case '\t': printf("\t'\\t'\n"); break;
+ case '\r': printf("\t'\\r'\n"); break;
+ default:
+ if (ch < 32 || ch > 127)
+ printf("\\%03o", ch);
+ else
+ printf("\t'%c'\n", ch);
+ break;
+ }
+ break;
+ case sc_SapReg:
+#ifdef sc_WordPointerReg
+ case sc_WordPointerReg:
+#endif
+ printf("\t0x%08x\n", *os_context_register_addr(context, offset));
+ break;
+ case sc_SignedReg:
+ printf("\t%d\n", *os_context_register_addr(context, offset));
+ break;
+ case sc_UnsignedReg:
+ printf("\t%u\n", *os_context_register_addr(context, offset));
+ break;
+#ifdef sc_SingleFloatReg
+ case sc_SingleFloatReg:
+ printf("\t%g\n", *(float *)&context->sc_fpregs[offset]);
+ break;
+#endif
+#ifdef sc_DoubleFloatReg
+ case sc_DoubleFloatReg:
+ printf("\t%g\n", *(double *)&context->sc_fpregs[offset]);
+ break;
+#endif
+ default:
+ printf("\t???\n");
+ break;
+ }
+ }
+}
+\f
+/* utility routines used by miscellaneous pieces of code */
+
+lispobj debug_print(lispobj string)
+{
+ fprintf(stderr, "%s\n", (char *)(((struct vector *)PTR(string))->data));
+ return NIL;
+}
--- /dev/null
+/*
+ * This software is part of the SBCL system. See the README file for
+ * more information.
+ *
+ * This software is derived from the CMU CL system, which was
+ * written at Carnegie Mellon University and released into the
+ * public domain. The software is in the public domain and is
+ * provided with absolutely no warranty. See the COPYING and CREDITS
+ * files for more information.
+ */
+
+/*
+ * $Header$
+ */
+
+#ifndef _INTERR_H_
+#define _INTERR_H_
+
+extern void lose(char *fmt, ...);
+extern void set_lossage_handler(void fun(void));
+extern void describe_internal_error(os_context_t *context);
+
+extern lispobj debug_print(lispobj string);
+
+#endif
--- /dev/null
+/*
+ * interrupt-handling magic
+ */
+
+/*
+ * This software is part of the SBCL system. See the README file for
+ * more information.
+ *
+ * This software is derived from the CMU CL system, which was
+ * written at Carnegie Mellon University and released into the
+ * public domain. The software is in the public domain and is
+ * provided with absolutely no warranty. See the COPYING and CREDITS
+ * files for more information.
+ */
+
+/*
+ * $Header$
+ */
+
+#include <stdio.h>
+
+#include <signal.h>
+#ifdef mach /* KLUDGE: #ifdef on lowercase symbols? Ick. -- WHN 19990904 */
+#ifdef mips
+#include <mips/cpu.h>
+#endif
+#endif
+
+#include "runtime.h"
+#include "arch.h"
+#include "sbcl.h"
+#include "os.h"
+#include "interrupt.h"
+#include "globals.h"
+#include "lispregs.h"
+#include "validate.h"
+#include "monitor.h"
+#include "gc.h"
+#include "alloc.h"
+#include "dynbind.h"
+#include "interr.h"
+
+void sigaddset_blockable(sigset_t *s)
+{
+ sigaddset(s, SIGHUP);
+ sigaddset(s, SIGINT);
+ sigaddset(s, SIGQUIT);
+ sigaddset(s, SIGPIPE);
+ sigaddset(s, SIGALRM);
+ sigaddset(s, SIGURG);
+ sigaddset(s, SIGTSTP);
+ sigaddset(s, SIGCHLD);
+ sigaddset(s, SIGIO);
+ sigaddset(s, SIGXCPU);
+ sigaddset(s, SIGXFSZ);
+ sigaddset(s, SIGVTALRM);
+ sigaddset(s, SIGPROF);
+ sigaddset(s, SIGWINCH);
+ sigaddset(s, SIGUSR1);
+ sigaddset(s, SIGUSR2);
+}
+
+/* When we catch an internal error, should we pass it back to Lisp to
+ * be handled in a high-level way? (Early in cold init, the answer is
+ * 'no', because Lisp is still too brain-dead to handle anything.
+ * After sufficient initialization has been completed, the answer
+ * becomes 'yes'.) */
+boolean internal_errors_enabled = 0;
+
+os_context_t *lisp_interrupt_contexts[MAX_INTERRUPTS];
+
+/* As far as I can tell, what's going on here is:
+ *
+ * In the case of most signals, when Lisp asks us to handle the
+ * signal, the outermost handler (the one actually passed to UNIX) is
+ * either interrupt_handle_now(..) or interrupt_handle_later(..).
+ * In that case, the Lisp-level handler is stored in interrupt_handlers[..]
+ * and interrupt_low_level_handlers[..] is cleared.
+ *
+ * However, some signals need special handling, e.g. the SIGSEGV (for
+ * Linux) or SIGBUS (for FreeBSD) used by the garbage collector to
+ * detect violations of write protection, because some cases of such
+ * signals are handled at C level and never passed on to Lisp. For
+ * such signals, we still store any Lisp-level handler in
+ * interrupt_handlers[..], but for the outermost handle we use the
+ * value from interrupt_low_level_handlers[..], instead of the
+ * ordinary interrupt_handle_now(..) or interrupt_handle_later(..).
+ *
+ * -- WHN 20000728 */
+void (*interrupt_low_level_handlers[NSIG]) (int, siginfo_t*, void*) = {0};
+union interrupt_handler interrupt_handlers[NSIG];
+
+/* signal number, siginfo_t, and old mask information for pending signal
+ *
+ * pending_signal=0 when there is no pending signal. */
+static int pending_signal = 0;
+static siginfo_t pending_info;
+static sigset_t pending_mask;
+
+static boolean maybe_gc_pending = 0;
+\f
+/*
+ * utility routines used by various signal handlers
+ */
+
+void
+fake_foreign_function_call(os_context_t *context)
+{
+ int context_index;
+#ifndef __i386__
+ lispobj oldcont;
+#endif
+
+ /* Get current Lisp state from context. */
+#ifdef reg_ALLOC
+ current_dynamic_space_free_pointer =
+ (lispobj *)(*os_context_register_addr(context, reg_ALLOC));
+#ifdef alpha
+ if ((long)current_dynamic_space_free_pointer & 1) {
+ lose("dead in fake_foreign_function_call, context = %x", context);
+ }
+#endif
+#endif
+#ifdef reg_BSP
+ current_binding_stack_pointer =
+ (lispobj *)(*os_context_register_addr(context, reg_BSP));
+#endif
+
+#ifndef __i386__
+ /* Build a fake stack frame. */
+ current_control_frame_pointer =
+ (lispobj *)(*os_context_register_addr(context, reg_CSP));
+ if ((lispobj *)(*os_context_register_addr(context, reg_CFP))
+ == current_control_frame_pointer) {
+ /* There is a small window during call where the callee's
+ * frame isn't built yet. */
+ if (LowtagOf(*os_context_register_addr(context, reg_CODE))
+ == type_FunctionPointer) {
+ /* We have called, but not built the new frame, so
+ * build it for them. */
+ current_control_frame_pointer[0] =
+ *os_context_register_addr(context, reg_OCFP);
+ current_control_frame_pointer[1] =
+ *os_context_register_addr(context, reg_LRA);
+ current_control_frame_pointer += 8;
+ /* Build our frame on top of it. */
+ oldcont = (lispobj)(*os_context_register_addr(context, reg_CFP));
+ }
+ else {
+ /* We haven't yet called, build our frame as if the
+ * partial frame wasn't there. */
+ oldcont = (lispobj)(*os_context_register_addr(context, reg_OCFP));
+ }
+ }
+ /* ### We can't tell if we are still in the caller if it had to
+ * reg_ALLOCate the stack frame due to stack arguments. */
+ /* ### Can anything strange happen during return? */
+ else
+ /* normal case */
+ oldcont = (lispobj)(*os_context_register_addr(context, reg_CFP));
+
+ current_control_stack_pointer = current_control_frame_pointer + 8;
+
+ current_control_frame_pointer[0] = oldcont;
+ current_control_frame_pointer[1] = NIL;
+ current_control_frame_pointer[2] =
+ (lispobj)(*os_context_register_addr(context, reg_CODE));
+#endif
+
+ /* Do dynamic binding of the active interrupt context index
+ * and save the context in the context array. */
+ context_index = SymbolValue(FREE_INTERRUPT_CONTEXT_INDEX)>>2;
+ /* FIXME: Ick! Why use abstract "make_fixnum" in some places if
+ * you're going to convert from fixnum by bare >>2 in other
+ * places? Use fixnum_value(..) here, and look for other places
+ * which do bare >> and << for fixnum_value and make_fixnum. */
+
+ if (context_index >= MAX_INTERRUPTS) {
+ lose("maximum interrupt nesting depth (%d) exceeded",
+ MAX_INTERRUPTS);
+ }
+
+ bind_variable(FREE_INTERRUPT_CONTEXT_INDEX,
+ make_fixnum(context_index + 1));
+
+ lisp_interrupt_contexts[context_index] = context;
+
+ /* no longer in Lisp now */
+ foreign_function_call_active = 1;
+}
+
+void
+undo_fake_foreign_function_call(os_context_t *context)
+{
+ /* Block all blockable signals. */
+ sigset_t block;
+ sigemptyset(&block);
+ sigaddset_blockable(&block);
+ sigprocmask(SIG_BLOCK, &block, 0);
+
+ /* going back into Lisp */
+ foreign_function_call_active = 0;
+
+ /* Undo dynamic binding. */
+ /* ### Do I really need to unbind_to_here()? */
+ /* FIXME: Is this to undo the binding of
+ * FREE_INTERRUPT_CONTEXT_INDEX? If so, we should say so. And
+ * perhaps yes, unbind_to_here() really would be clearer and less
+ * fragile.. */
+ unbind();
+
+#ifdef reg_ALLOC
+ /* Put the dynamic space free pointer back into the context. */
+ *os_context_register_addr(context, reg_ALLOC) =
+ (unsigned long) current_dynamic_space_free_pointer;
+#endif
+}
+
+/* a handler for the signal caused by execution of a trap opcode
+ * signalling an internal error */
+void
+interrupt_internal_error(int signal, siginfo_t *info, os_context_t *context,
+ boolean continuable)
+{
+ lispobj context_sap;
+
+ fake_foreign_function_call(context);
+
+ /* Allocate the SAP object while the interrupts are still
+ * disabled. */
+ if (internal_errors_enabled) {
+ context_sap = alloc_sap(context);
+ }
+
+ sigprocmask(SIG_SETMASK, os_context_sigmask_addr(context), 0);
+
+ if (internal_errors_enabled) {
+ SHOW("in interrupt_internal_error");
+#if QSHOW
+ /* Display some rudimentary debugging information about the
+ * error, so that even if the Lisp error handler gets badly
+ * confused, we have a chance to determine what's going on. */
+ describe_internal_error(context);
+#endif
+ funcall2(SymbolFunction(INTERNAL_ERROR), context_sap,
+ continuable ? T : NIL);
+ } else {
+ describe_internal_error(context);
+ /* There's no good way to recover from an internal error
+ * before the Lisp error handling mechanism is set up. */
+ lose("internal error too early in init, can't recover");
+ }
+ undo_fake_foreign_function_call(context);
+ if (continuable) {
+ arch_skip_instruction(context);
+ }
+}
+
+void
+interrupt_handle_pending(os_context_t *context)
+{
+ boolean were_in_lisp = !foreign_function_call_active;
+
+ SetSymbolValue(INTERRUPT_PENDING, NIL);
+
+ if (maybe_gc_pending) {
+ maybe_gc_pending = 0;
+#ifndef __i386__
+ if (were_in_lisp)
+#endif
+ {
+ fake_foreign_function_call(context);
+ }
+ funcall0(SymbolFunction(MAYBE_GC));
+#ifndef __i386__
+ if (were_in_lisp)
+#endif
+ {
+ undo_fake_foreign_function_call(context);
+ }
+ }
+
+ /* FIXME: How come we unconditionally copy from pending_mask into
+ * the context, and then test whether pending_signal is set? If
+ * pending_signal wasn't set, how could pending_mask be valid? */
+ memcpy(os_context_sigmask_addr(context), &pending_mask, sizeof(sigset_t));
+ sigemptyset(&pending_mask);
+ if (pending_signal) {
+ int signal = pending_signal;
+ siginfo_t info;
+ memcpy(&info, &pending_info, sizeof(siginfo_t));
+ pending_signal = 0;
+ interrupt_handle_now(signal, &info, context);
+ }
+}
+\f
+/*
+ * the two main signal handlers:
+ * interrupt_handle_now(..)
+ * maybe_now_maybe_later(..)
+ */
+
+void
+interrupt_handle_now(int signal, siginfo_t *info, void *void_context)
+{
+ os_context_t *context = (os_context_t*)void_context;
+ int were_in_lisp;
+ union interrupt_handler handler;
+
+#ifdef __linux__
+ SET_FPU_CONTROL_WORD(context->__fpregs_mem.cw);
+#endif
+
+ handler = interrupt_handlers[signal];
+
+ if (ARE_SAME_HANDLER(handler.c, SIG_IGN)) {
+ return;
+ }
+
+ were_in_lisp = !foreign_function_call_active;
+#ifndef __i386__
+ if (were_in_lisp)
+#endif
+ {
+ fake_foreign_function_call(context);
+ }
+
+#ifdef QSHOW_SIGNALS
+ FSHOW((stderr, "in interrupt_handle_now(%d, info, context)\n", signal));
+#endif
+
+ if (ARE_SAME_HANDLER(handler.c, SIG_DFL)) {
+
+ /* This can happen if someone tries to ignore or default one
+ * of the signals we need for runtime support, and the runtime
+ * support decides to pass on it. */
+ lose("no handler for signal %d in interrupt_handle_now(..)", signal);
+
+ } else if (LowtagOf(handler.lisp) == type_FunctionPointer) {
+
+ /* Allocate the SAPs while the interrupts are still disabled.
+ * (FIXME: Why? This is the way it was done in CMU CL, and it
+ * even had the comment noting that this is the way it was
+ * done, but no motivation..) */
+ lispobj context_sap = alloc_sap(context);
+ lispobj info_sap = alloc_sap(info);
+
+ /* Allow signals again. */
+ sigprocmask(SIG_SETMASK, os_context_sigmask_addr(context), 0);
+
+#ifdef QSHOW_SIGNALS
+ SHOW("calling Lisp-level handler");
+#endif
+
+ funcall3(handler.lisp,
+ make_fixnum(signal),
+ info_sap,
+ context_sap);
+ } else {
+
+#ifdef QSHOW_SIGNALS
+ SHOW("calling C-level handler");
+#endif
+
+ /* Allow signals again. */
+ sigprocmask(SIG_SETMASK, os_context_sigmask_addr(context), 0);
+
+ (*handler.c)(signal, info, void_context);
+ }
+
+#ifndef __i386__
+ if (were_in_lisp)
+#endif
+ {
+ undo_fake_foreign_function_call(context);
+ }
+}
+
+static void
+maybe_now_maybe_later(int signal, siginfo_t *info, void *void_context)
+{
+ os_context_t *context = (os_context_t*)void_context;
+
+ /* FIXME: See Debian cmucl 2.4.17, and mail from DTC on the CMU CL
+ * mailing list 23 Oct 1999, for changes in FPU handling at
+ * interrupt time which should be ported into SBCL.
+ *
+ * (Is this related to the way that it seems that if we do decide
+ * to handle the interrupt later, we've now screwed up the FPU
+ * control word?) */
+#ifdef __linux__
+ SET_FPU_CONTROL_WORD(context->__fpregs_mem.cw);
+#endif
+
+ if (SymbolValue(INTERRUPTS_ENABLED) == NIL) {
+
+ /* FIXME: This code is exactly the same as the code in the
+ * other leg of the if(..), and should be factored out into
+ * a shared function. */
+ pending_signal = signal;
+ memcpy(&pending_info, info, sizeof(siginfo_t));
+ memcpy(&pending_mask,
+ os_context_sigmask_addr(context),
+ sizeof(sigset_t));
+ sigaddset_blockable(os_context_sigmask_addr(context));
+
+ SetSymbolValue(INTERRUPT_PENDING, T);
+
+ } else if (
+#ifndef __i386__
+ (!foreign_function_call_active) &&
+#endif
+ arch_pseudo_atomic_atomic(context)) {
+
+ /* FIXME: It would probably be good to replace these bare
+ * memcpy(..) calls with calls to cpy_siginfo_t and
+ * cpy_sigset_t, so that we only have to get the sizeof
+ * expressions right in one place, and after that static type
+ * checking takes over. */
+ pending_signal = signal;
+ memcpy(&pending_info, info, sizeof(siginfo_t));
+ memcpy(&pending_mask,
+ os_context_sigmask_addr(context),
+ sizeof(sigset_t));
+ sigaddset_blockable(os_context_sigmask_addr(context));
+
+ arch_set_pseudo_atomic_interrupted(context);
+
+ } else {
+ interrupt_handle_now(signal, info, context);
+ }
+}
+\f
+/*
+ * stuff to detect and handle hitting the GC trigger
+ */
+
+#ifndef INTERNAL_GC_TRIGGER
+static boolean
+gc_trigger_hit(int signal, siginfo_t *info, os_context_t *context)
+{
+ if (current_auto_gc_trigger == NULL)
+ return 0;
+ else{
+ lispobj *badaddr=(lispobj *)arch_get_bad_addr(signal,
+ info,
+ context);
+
+ return (badaddr >= current_auto_gc_trigger &&
+ badaddr < current_dynamic_space + DYNAMIC_SPACE_SIZE);
+ }
+}
+#endif
+
+#ifndef __i386__
+boolean
+interrupt_maybe_gc(int signal, siginfo_t *info, os_context_t *context)
+{
+ if (!foreign_function_call_active
+#ifndef INTERNAL_GC_TRIGGER
+ && gc_trigger_hit(signal, info, context)
+#endif
+ ) {
+#ifndef INTERNAL_GC_TRIGGER
+ clear_auto_gc_trigger();
+#endif
+
+ if (arch_pseudo_atomic_atomic(context)) {
+ maybe_gc_pending = 1;
+ if (pending_signal == 0) {
+ /* FIXME: This copy-pending_mask-then-sigaddset_blockable
+ * idiom occurs over and over. It should be factored out
+ * into a function with a descriptive name. */
+ memcpy(&pending_mask,
+ os_context_sigmask_addr(context),
+ sizeof(sigset_t));
+ sigaddset_blockable(os_context_sigmask_addr(context));
+ }
+ arch_set_pseudo_atomic_interrupted(context);
+ }
+ else {
+ fake_foreign_function_call(context);
+ funcall0(SymbolFunction(MAYBE_GC));
+ undo_fake_foreign_function_call(context);
+ }
+
+ return 1;
+ } else {
+ return 0;
+ }
+}
+#endif
+\f
+/*
+ * noise to install handlers
+ */
+
+/* Install a special low-level handler for signal; or if handler is
+ * SIG_DFL, remove any special handling for signal. */
+void
+interrupt_install_low_level_handler (int signal,
+ void handler(int, siginfo_t*, void*))
+{
+ struct sigaction sa;
+
+ sa.sa_sigaction = handler;
+ sigemptyset(&sa.sa_mask);
+ sigaddset_blockable(&sa.sa_mask);
+ sa.sa_flags = SA_SIGINFO | SA_RESTART;
+
+ sigaction(signal, &sa, NULL);
+ interrupt_low_level_handlers[signal] =
+ (ARE_SAME_HANDLER(handler,SIG_DFL) ? 0 : handler);
+}
+
+/* This is called from Lisp. */
+unsigned long
+install_handler(int signal, void handler(int, siginfo_t*, void*))
+{
+ struct sigaction sa;
+ sigset_t old, new;
+ union interrupt_handler oldhandler;
+
+ FSHOW((stderr, "entering POSIX install_handler(%d, ..)\n", signal));
+
+ sigemptyset(&new);
+ sigaddset(&new, signal);
+ sigprocmask(SIG_BLOCK, &new, &old);
+
+ sigemptyset(&new);
+ sigaddset_blockable(&new);
+
+ FSHOW((stderr, "interrupt_low_level_handlers[signal]=%d\n",
+ interrupt_low_level_handlers[signal]));
+ if (interrupt_low_level_handlers[signal]==0) {
+ if (ARE_SAME_HANDLER(handler, SIG_DFL) ||
+ ARE_SAME_HANDLER(handler, SIG_IGN)) {
+ sa.sa_sigaction = handler;
+ } else if (sigismember(&new, signal)) {
+ sa.sa_sigaction = maybe_now_maybe_later;
+ } else {
+ sa.sa_sigaction = interrupt_handle_now;
+ }
+
+ sigemptyset(&sa.sa_mask);
+ sigaddset_blockable(&sa.sa_mask);
+ sa.sa_flags = SA_SIGINFO | SA_RESTART;
+
+ sigaction(signal, &sa, NULL);
+ }
+
+ oldhandler = interrupt_handlers[signal];
+ interrupt_handlers[signal].c = handler;
+
+ sigprocmask(SIG_SETMASK, &old, 0);
+
+ FSHOW((stderr, "leaving POSIX install_handler(%d, ..)\n", signal));
+
+ return (unsigned long)oldhandler.lisp;
+}
+
+void
+interrupt_init(void)
+{
+ int i;
+
+ for (i = 0; i < NSIG; i++) {
+ interrupt_handlers[i].c =
+ /* (The cast here blasts away the distinction between
+ * SA_SIGACTION-style three-argument handlers and
+ * signal(..)-style one-argument handlers, which is OK
+ * because it works to call the 1-argument form where the
+ * 3-argument form is expected.) */
+ (void (*)(int, siginfo_t*, void*))SIG_DFL;
+ }
+}
--- /dev/null
+/*
+ * This software is part of the SBCL system. See the README file for
+ * more information.
+ *
+ * This software is derived from the CMU CL system, which was
+ * written at Carnegie Mellon University and released into the
+ * public domain. The software is in the public domain and is
+ * provided with absolutely no warranty. See the COPYING and CREDITS
+ * files for more information.
+ */
+
+/*
+ * $Header$
+ */
+
+#if !defined(_INCLUDE_INTERRUPT_H_)
+#define _INCLUDE_INTERRUPT_H_
+
+#include <signal.h>
+
+/* maximum signal nesting depth
+ *
+ * Note: In CMU CL, this was 4096, but there was no explanation given,
+ * and it's hard to see why we'd need that many nested interrupts, so
+ * I've scaled it back to see what happens. -- WHN 20000730 */
+#define MAX_INTERRUPTS 256
+
+extern os_context_t *lisp_interrupt_contexts[MAX_INTERRUPTS];
+
+union interrupt_handler {
+ lispobj lisp;
+ void (*c)(int, siginfo_t*, void*);
+};
+
+extern void interrupt_init(void);
+extern void fake_foreign_function_call(os_context_t* context);
+extern void undo_fake_foreign_function_call(os_context_t* context);
+extern void interrupt_handle_now(int, siginfo_t*, void*);
+extern void interrupt_handle_pending(os_context_t*);
+extern void interrupt_internal_error(int, siginfo_t*, os_context_t*,
+ boolean continuable);
+extern boolean interrupt_maybe_gc(int, siginfo_t*, void*);
+extern void interrupt_install_low_level_handler (int signal,
+ void handler(int,
+ siginfo_t*,
+ void*));
+extern unsigned long install_handler(int signal,
+ void handler(int, siginfo_t*, void*));
+
+extern union interrupt_handler interrupt_handlers[NSIG];
+
+/* Set all blockable signals into *s. */
+void sigaddset_blockable(sigset_t *s);
+
+/* The void* casting here avoids having to mess with the various types
+ * of function argument lists possible for signal handlers:
+ * SA_SIGACTION handlers have one signature, and the default old-style
+ * signal(..) handlers have another, and attempting to represent them
+ * "cleanly" with union types is in fact a mess. */
+#define ARE_SAME_HANDLER(x, y) ((void*)(x) == (void*)(y))
+#endif
--- /dev/null
+#!/bin/sh
+nm -p "$@" | grep -v " [FUtdb?] "
--- /dev/null
+/*
+ * the Linux incarnation of OS-dependent routines
+ *
+ * This file (along with os.h) exports an OS-independent interface to
+ * the operating system VM facilities. Surprise surprise, this
+ * interface looks a lot like the Mach interface (but simpler in some
+ * places). For some operating systems, a subset of these functions
+ * will have to be emulated.
+ */
+
+/*
+ * This software is part of the SBCL system. See the README file for
+ * more information.
+ *
+ * This software is derived from the CMU CL system, which was
+ * written at Carnegie Mellon University and released into the
+ * public domain. The software is in the public domain and is
+ * provided with absolutely no warranty. See the COPYING and CREDITS
+ * files for more information.
+ */
+
+/*
+ * $Header$
+ */
+
+#include <stdio.h>
+#include <sys/param.h>
+#include <sys/file.h>
+#include "./signal.h"
+#include "os.h"
+#include "arch.h"
+#include "globals.h"
+#include "interrupt.h"
+#include "lispregs.h"
+#include "sbcl.h"
+#include <sys/socket.h>
+#include <sys/utsname.h>
+
+#include <sys/types.h>
+#include <signal.h>
+/* #include <sys/sysinfo.h> */
+#include <sys/time.h>
+#include <sys/stat.h>
+#include <unistd.h>
+
+#include "x86-validate.h"
+size_t os_vm_page_size;
+
+#if defined GENCGC
+#include "gencgc.h"
+#endif
+\f
+void os_init(void)
+{
+ /* Early versions of Linux don't support the mmap(..) functionality
+ * that we need. */
+ {
+ struct utsname name;
+ int major_version;
+ uname(&name);
+ major_version = atoi(name.release);
+ if (major_version < 2) {
+ lose("linux major version=%d (can't run in version < 2.0.0)",
+ major_version);
+ }
+ }
+
+ os_vm_page_size = getpagesize();
+
+ SET_FPU_CONTROL_WORD(0x1372|4|8|16|32); /* no interrupts */
+}
+
+/* KLUDGE: As of kernel 2.2.14 on Red Hat 6.2, there's code in the
+ * <sys/ucontext.h> file to define symbolic names for offsets into
+ * gregs[], but it's conditional on __USE_GNU and not defined, so
+ * we need to do this nasty absolute index magic number thing
+ * instead. */
+int *
+os_context_register_addr(os_context_t *context, int offset)
+{
+ switch(offset) {
+ case 0: return &context->uc_mcontext.gregs[11]; /* EAX */
+ case 2: return &context->uc_mcontext.gregs[10]; /* ECX */
+ case 4: return &context->uc_mcontext.gregs[9]; /* EDX */
+ case 6: return &context->uc_mcontext.gregs[8]; /* EBX */
+ case 8: return &context->uc_mcontext.gregs[7]; /* ESP */
+ case 10: return &context->uc_mcontext.gregs[6]; /* EBP */
+ case 12: return &context->uc_mcontext.gregs[5]; /* ESI */
+ case 14: return &context->uc_mcontext.gregs[4]; /* EDI */
+ default: return 0;
+ }
+}
+int *
+os_context_pc_addr(os_context_t *context)
+{
+ return &context->uc_mcontext.gregs[14];
+}
+int *
+os_context_sp_addr(os_context_t *context)
+{
+ return &context->uc_mcontext.gregs[17];
+}
+
+sigset_t *
+os_context_sigmask_addr(os_context_t *context)
+{
+ return &context->uc_sigmask;
+}
+
+/* In Debian CMU CL ca. 2.4.9, it was possible to get an infinite
+ * cascade of errors from do_mmap(..). This variable is a counter to
+ * prevent that; when it counts down to zero, an error in do_mmap
+ * causes the low-level monitor to be called. */
+int n_do_mmap_ignorable_errors = 3;
+
+/* Return 0 for success. */
+static int
+do_mmap(os_vm_address_t *addr, os_vm_size_t len, int flags)
+{
+ /* We *must* have the memory where we want it. */
+ os_vm_address_t old_addr=*addr;
+
+ *addr = mmap(*addr, len, OS_VM_PROT_ALL, flags, -1, 0);
+ if (*addr == MAP_FAILED ||
+ ((old_addr != NULL) && (*addr != old_addr))) {
+ FSHOW((stderr,
+ "error in allocating memory from the OS\n"
+ "(addr=%lx, len=%lx, flags=%lx)\n",
+ (long) addr,
+ (long) len,
+ (long) flags));
+ if (n_do_mmap_ignorable_errors > 0) {
+ --n_do_mmap_ignorable_errors;
+ } else {
+ lose("too many errors in allocating memory from the OS");
+ }
+ perror("mmap");
+ return 1;
+ }
+ return 0;
+}
+
+os_vm_address_t
+os_validate(os_vm_address_t addr, os_vm_size_t len)
+{
+ if (addr) {
+ int flags = MAP_PRIVATE | MAP_ANONYMOUS | MAP_FIXED;
+ os_vm_address_t base_addr = addr;
+ do {
+ /* KLUDGE: It looks as though this code allocates memory
+ * in chunks of size no larger than 'magic', but why? What
+ * is the significance of 0x1000000 here? Also, can it be
+ * right that if the first few 'do_mmap' calls succeed,
+ * then one fails, we leave the memory allocated by the
+ * first few in place even while we return a code for
+ * complete failure? -- WHN 19991020
+ *
+ * Peter Van Eynde writes (20000211)
+ * This was done because the kernel would only check for
+ * overcommit for every allocation seperately. So if you
+ * had 16MB of free mem+swap you could allocate 16M. And
+ * again, and again, etc.
+ * This in [Linux] 2.X could be bad as they changed the memory
+ * system. A side effect was/is (I don't really know) that
+ * programs with a lot of memory mappings run slower. But
+ * of course for 2.2.2X we now have the NO_RESERVE flag that
+ * helps...
+ *
+ * FIXME: The logic is also flaky w.r.t. failed
+ * allocations. If we make one or more successful calls to
+ * do_mmap(..) before one fails, then we've allocated
+ * memory, and we should ensure that it gets deallocated
+ * sometime somehow. If this function's response to any
+ * failed do_mmap(..) is to give up and return NULL (as in
+ * sbcl-0.6.7), then any failed do_mmap(..) after any
+ * successful do_mmap(..) causes a memory leak. */
+ int magic = 0x1000000;
+ if (len <= magic) {
+ if (do_mmap(&addr, len, flags)) {
+ return NULL;
+ }
+ len = 0;
+ } else {
+ if (do_mmap(&addr, magic, flags)) {
+ return NULL;
+ }
+ addr += magic;
+ len = len - magic;
+ }
+ } while (len > 0);
+ return base_addr;
+ } else {
+ int flags = MAP_PRIVATE | MAP_ANONYMOUS;
+ if (do_mmap(&addr, len, flags)) {
+ return NULL;
+ } else {
+ return addr;
+ }
+ }
+}
+
+void
+os_invalidate(os_vm_address_t addr, os_vm_size_t len)
+{
+ if (munmap(addr,len) == -1) {
+ perror("munmap");
+ }
+}
+
+os_vm_address_t
+os_map(int fd, int offset, os_vm_address_t addr, os_vm_size_t len)
+{
+ addr = mmap(addr, len,
+ OS_VM_PROT_ALL,
+ MAP_PRIVATE | MAP_FILE | MAP_FIXED,
+ fd, (off_t) offset);
+
+ if(addr == MAP_FAILED) {
+ perror("mmap");
+ lose("unexpected mmap(..) failure");
+ }
+
+ return addr;
+}
+
+void
+os_flush_icache(os_vm_address_t address, os_vm_size_t length)
+{
+}
+
+void
+os_protect(os_vm_address_t address, os_vm_size_t length, os_vm_prot_t prot)
+{
+ if (mprotect(address, length, prot) == -1) {
+ perror("mprotect");
+ }
+}
+\f
+static boolean
+in_range_p(os_vm_address_t a, lispobj sbeg, size_t slen)
+{
+ char* beg = (char*)sbeg;
+ char* end = (char*)sbeg + slen;
+ char* adr = (char*)a;
+ return (adr >= beg && adr < end);
+}
+
+boolean
+is_valid_lisp_addr(os_vm_address_t addr)
+{
+ return
+ in_range_p(addr, READ_ONLY_SPACE_START, READ_ONLY_SPACE_SIZE) ||
+ in_range_p(addr, STATIC_SPACE_START , STATIC_SPACE_SIZE) ||
+ in_range_p(addr, DYNAMIC_0_SPACE_START, DYNAMIC_SPACE_SIZE) ||
+ in_range_p(addr, DYNAMIC_1_SPACE_START, DYNAMIC_SPACE_SIZE) ||
+ in_range_p(addr, CONTROL_STACK_START , CONTROL_STACK_SIZE) ||
+ in_range_p(addr, BINDING_STACK_START , BINDING_STACK_SIZE);
+}
+\f
+/*
+ * any OS-dependent special low-level handling for signals
+ */
+
+#if !defined GENCGC
+
+void
+os_install_interrupt_handlers(void)
+{}
+
+#else
+
+/*
+ * The GENCGC needs to be hooked into whatever signal is raised for
+ * page fault on this OS.
+ */
+void
+sigsegv_handler(int signal, siginfo_t *info, void* void_context)
+{
+ os_context_t *context = (os_context_t*)void_context;
+ void* fault_addr = (void*)context->uc_mcontext.cr2;
+ if (!gencgc_handle_wp_violation(fault_addr)) {
+ interrupt_handle_now(signal, info, void_context);
+ }
+}
+void
+os_install_interrupt_handlers(void)
+{
+ interrupt_install_low_level_handler(SIGSEGV, sigsegv_handler);
+}
+
+#endif
--- /dev/null
+/*
+ * This software is part of the SBCL system. See the README file for
+ * more information.
+ *
+ * This software is derived from the CMU CL system, which was
+ * written at Carnegie Mellon University and released into the
+ * public domain. The software is in the public domain and is
+ * provided with absolutely no warranty. See the COPYING and CREDITS
+ * files for more information.
+ */
+
+/*
+ * $Header$
+ */
+
+#include <stdlib.h>
+#include <sys/types.h>
+#include <sys/mman.h>
+#include <sys/signal.h>
+#include <ucontext.h>
+#include <string.h>
+ /* #include <dlfcn.h> */
+#include <sys/time.h>
+#include <sys/stat.h>
+#include <unistd.h>
+#include <sys/syscall.h>
+#include <asm/unistd.h>
+#include <linux/version.h>
+
+#define linuxversion(a, b, c) (((a)<<16)+((b)<<8)+(c))
+
+typedef caddr_t os_vm_address_t;
+typedef size_t os_vm_size_t;
+typedef off_t os_vm_offset_t;
+typedef int os_vm_prot_t;
+
+typedef struct ucontext os_context_t;
+
+#define OS_VM_PROT_READ PROT_READ
+#define OS_VM_PROT_WRITE PROT_WRITE
+#define OS_VM_PROT_EXECUTE PROT_EXEC
+
+#define OS_VM_DEFAULT_PAGESIZE 4096
+
+#define SET_FPU_CONTROL_WORD(cw) asm("fldcw %0" : : "m" (cw))
--- /dev/null
+/*
+ * Linux stubs
+ *
+ * These are needed because the locations of the
+ * libraries are filled in by ld.so at runtime.
+ *
+ * $Header$
+ */
+
+/*
+ * This software is part of the SBCL system. See the README file for
+ * more information.
+ *
+ * This software is derived from the CMU CL system, which was
+ * written at Carnegie Mellon University and released into the
+ * public domain. The software is in the public domain and is
+ * provided with absolutely no warranty. See the COPYING and CREDITS
+ * files for more information.
+ */
+
+ .file "linux-stubs.S"
+ .version "01.01"
+gcc2_compiled.:
+ .text
+
+#define LDSO_STUBIFY(fct) \
+ .align 16 ;\
+.globl ldso_stub__ ## fct ;\
+ .type ldso_stub__ ## fct,@function ;\
+ldso_stub__ ## fct: ;\
+ jmp fct ;\
+.L ## fct ## e1: ;\
+ .size ldso_stub__ ## fct,.L ## fct ## e1-ldso_stub__ ## fct ;
+
+ LDSO_STUBIFY(accept)
+ LDSO_STUBIFY(access)
+ LDSO_STUBIFY(acos)
+ LDSO_STUBIFY(acosh)
+ LDSO_STUBIFY(asin)
+ LDSO_STUBIFY(asinh)
+ LDSO_STUBIFY(atanh)
+ LDSO_STUBIFY(bind)
+ LDSO_STUBIFY(cfgetispeed)
+ LDSO_STUBIFY(cfgetospeed)
+ LDSO_STUBIFY(cfsetispeed)
+ LDSO_STUBIFY(cfsetospeed)
+ LDSO_STUBIFY(chdir)
+ LDSO_STUBIFY(chmod)
+ LDSO_STUBIFY(chown)
+ LDSO_STUBIFY(close)
+ LDSO_STUBIFY(closedir)
+ LDSO_STUBIFY(connect)
+ LDSO_STUBIFY(cosh)
+ LDSO_STUBIFY(creat)
+ LDSO_STUBIFY(dlclose)
+ LDSO_STUBIFY(dlerror)
+ LDSO_STUBIFY(dlopen)
+ LDSO_STUBIFY(dlsym)
+ LDSO_STUBIFY(dup)
+ LDSO_STUBIFY(dup2)
+ LDSO_STUBIFY(execve)
+ LDSO_STUBIFY(exit)
+ LDSO_STUBIFY(fchmod)
+ LDSO_STUBIFY(fchown)
+ LDSO_STUBIFY(fcntl)
+ LDSO_STUBIFY(fork)
+ LDSO_STUBIFY(free)
+ LDSO_STUBIFY(fstat)
+ LDSO_STUBIFY(fsync)
+ LDSO_STUBIFY(ftruncate)
+ LDSO_STUBIFY(getdtablesize)
+ LDSO_STUBIFY(getegid)
+ LDSO_STUBIFY(getgid)
+ LDSO_STUBIFY(gethostid)
+ LDSO_STUBIFY(gethostbyaddr)
+ LDSO_STUBIFY(gethostbyname)
+ LDSO_STUBIFY(gethostname)
+ LDSO_STUBIFY(getitimer)
+ LDSO_STUBIFY(getpagesize)
+ LDSO_STUBIFY(getpeername)
+ LDSO_STUBIFY(getpgrp)
+ LDSO_STUBIFY(getpid)
+ LDSO_STUBIFY(getppid)
+ LDSO_STUBIFY(getrusage)
+ LDSO_STUBIFY(getsockname)
+ LDSO_STUBIFY(gettimeofday)
+ LDSO_STUBIFY(getuid)
+ LDSO_STUBIFY(getwd)
+ LDSO_STUBIFY(hypot)
+ LDSO_STUBIFY(ioctl)
+ LDSO_STUBIFY(isatty)
+ LDSO_STUBIFY(kill)
+ LDSO_STUBIFY(killpg)
+ LDSO_STUBIFY(link)
+ LDSO_STUBIFY(listen)
+ LDSO_STUBIFY(log1p)
+ LDSO_STUBIFY(lseek)
+ LDSO_STUBIFY(lstat)
+ LDSO_STUBIFY(malloc)
+ LDSO_STUBIFY(mkdir)
+ LDSO_STUBIFY(open)
+ LDSO_STUBIFY(opendir)
+ LDSO_STUBIFY(pipe)
+ LDSO_STUBIFY(pow)
+ LDSO_STUBIFY(read)
+ LDSO_STUBIFY(readdir)
+ LDSO_STUBIFY(readlink)
+ LDSO_STUBIFY(recv)
+ LDSO_STUBIFY(rename)
+ LDSO_STUBIFY(rmdir)
+ LDSO_STUBIFY(select)
+ LDSO_STUBIFY(send)
+ LDSO_STUBIFY(setitimer)
+ LDSO_STUBIFY(setpgrp)
+ LDSO_STUBIFY(setregid)
+ LDSO_STUBIFY(setreuid)
+ LDSO_STUBIFY(sigblock)
+ LDSO_STUBIFY(sigpause)
+ LDSO_STUBIFY(sigsetmask)
+ LDSO_STUBIFY(sinh)
+ LDSO_STUBIFY(socket)
+ LDSO_STUBIFY(stat)
+ LDSO_STUBIFY(symlink)
+ LDSO_STUBIFY(sync)
+ LDSO_STUBIFY(tanh)
+ LDSO_STUBIFY(tcdrain)
+ LDSO_STUBIFY(tcflow)
+ LDSO_STUBIFY(tcflush)
+ LDSO_STUBIFY(tcgetattr)
+ LDSO_STUBIFY(tcsendbreak)
+ LDSO_STUBIFY(tcsetattr)
+ LDSO_STUBIFY(truncate)
+ LDSO_STUBIFY(ttyname)
+ LDSO_STUBIFY(tzname)
+ LDSO_STUBIFY(unlink)
+ LDSO_STUBIFY(utimes)
+ LDSO_STUBIFY(wait3)
+ LDSO_STUBIFY(write)
+
+/* LDSO_STUBIFY(abort) */
+/* LDSO_STUBIFY(abs) */
+/* LDSO_STUBIFY(accept) */
+/* LDSO_STUBIFY(access) */
+/* LDSO_STUBIFY(acct) */
+/* LDSO_STUBIFY(acos) */
+/* LDSO_STUBIFY(acosh) */
+/* LDSO_STUBIFY(acoshl) */
+/* LDSO_STUBIFY(acosl) */
+/* LDSO_STUBIFY(addmntent) */
+/* LDSO_STUBIFY(adjtime) */
+/* LDSO_STUBIFY(adjtimex) */
+/* LDSO_STUBIFY(alarm) */
+/* LDSO_STUBIFY(alphasort) */
+/* LDSO_STUBIFY(altzone) */
+/* LDSO_STUBIFY(asctime) */
+/* LDSO_STUBIFY(asin) */
+/* LDSO_STUBIFY(asinh) */
+/* LDSO_STUBIFY(asinhl) */
+/* LDSO_STUBIFY(asinl) */
+/* LDSO_STUBIFY(atan) */
+/* LDSO_STUBIFY(atan2) */
+/* LDSO_STUBIFY(atan2l) */
+/* LDSO_STUBIFY(atanh) */
+/* LDSO_STUBIFY(atanhl) */
+/* LDSO_STUBIFY(atanl) */
+/* LDSO_STUBIFY(atexit) */
+/* LDSO_STUBIFY(atof) */
+/* LDSO_STUBIFY(atoi) */
+/* LDSO_STUBIFY(atol) */
+/* LDSO_STUBIFY(authdes_create) */
+/* LDSO_STUBIFY(authnone_create) */
+/* LDSO_STUBIFY(authunix_create) */
+/* LDSO_STUBIFY(authunix_create_default) */
+/* LDSO_STUBIFY(basename) */
+/* LDSO_STUBIFY(bcmp) */
+/* LDSO_STUBIFY(bcopy) */
+/* LDSO_STUBIFY(bind) */
+/* LDSO_STUBIFY(bindresvport) */
+/* LDSO_STUBIFY(brk) */
+/* LDSO_STUBIFY(bsearch) */
+/* LDSO_STUBIFY(bzero) */
+/* LDSO_STUBIFY(calloc) */
+/* LDSO_STUBIFY(callrpc) */
+/* LDSO_STUBIFY(catclose) */
+/* LDSO_STUBIFY(catgets) */
+/* LDSO_STUBIFY(catopen) */
+/* LDSO_STUBIFY(cbc_crypt) */
+/* LDSO_STUBIFY(cbrt) */
+/* LDSO_STUBIFY(cbrtl) */
+/* LDSO_STUBIFY(ceil) */
+/* LDSO_STUBIFY(ceill) */
+/* LDSO_STUBIFY(cfgetispeed) */
+/* LDSO_STUBIFY(cfgetospeed) */
+/* LDSO_STUBIFY(cfmakeraw) */
+/* LDSO_STUBIFY(cfree) */
+/* LDSO_STUBIFY(cfsetispeed) */
+/* LDSO_STUBIFY(cfsetospeed) */
+/* LDSO_STUBIFY(chdir) */
+/* LDSO_STUBIFY(chmod) */
+/* LDSO_STUBIFY(chown) */
+/* LDSO_STUBIFY(chroot) */
+/* LDSO_STUBIFY(clearerr) */
+/* LDSO_STUBIFY(clnt_broadcast) */
+/* LDSO_STUBIFY(clnt_create) */
+/* LDSO_STUBIFY(clnt_pcreateerror) */
+/* LDSO_STUBIFY(clnt_perrno) */
+/* LDSO_STUBIFY(clnt_perror) */
+/* LDSO_STUBIFY(clnt_spcreateerror) */
+/* LDSO_STUBIFY(clnt_sperrno) */
+/* LDSO_STUBIFY(clnt_sperror) */
+/* LDSO_STUBIFY(clntraw_create) */
+/* LDSO_STUBIFY(clnttcp_create) */
+/* LDSO_STUBIFY(clntudp_bufcreate) */
+/* LDSO_STUBIFY(clntudp_create) */
+/* LDSO_STUBIFY(clock) */
+/* LDSO_STUBIFY(close) */
+/* LDSO_STUBIFY(closedir) */
+/* LDSO_STUBIFY(closelog) */
+/* LDSO_STUBIFY(confstr) */
+/* LDSO_STUBIFY(connect) */
+/* LDSO_STUBIFY(copysign) */
+/* LDSO_STUBIFY(copysignl) */
+/* LDSO_STUBIFY(cos) */
+/* LDSO_STUBIFY(cosh) */
+/* LDSO_STUBIFY(coshl) */
+/* LDSO_STUBIFY(cosl) */
+/* LDSO_STUBIFY(creat) */
+/* LDSO_STUBIFY(crypt) */
+/* LDSO_STUBIFY(ctermid) */
+/* LDSO_STUBIFY(ctime) */
+/* LDSO_STUBIFY(ctime_r) */
+/* LDSO_STUBIFY(cuserid) */
+/* LDSO_STUBIFY(daylight) */
+/* LDSO_STUBIFY(des_setparity) */
+/* LDSO_STUBIFY(difftime) */
+/* LDSO_STUBIFY(dirfd) */
+/* LDSO_STUBIFY(div) */
+/* LDSO_STUBIFY(dlclose) */
+/* LDSO_STUBIFY(dlerror) */
+/* LDSO_STUBIFY(dlopen) */
+/* LDSO_STUBIFY(dlsym) */
+/* LDSO_STUBIFY(dn_comp) */
+/* LDSO_STUBIFY(dn_expand) */
+/* LDSO_STUBIFY(dn_skipname) */
+/* LDSO_STUBIFY(drand48) */
+/* LDSO_STUBIFY(drem) */
+/* LDSO_STUBIFY(dup) */
+/* LDSO_STUBIFY(dup2) */
+/* LDSO_STUBIFY(ecb_crypt) */
+/* LDSO_STUBIFY(ecvt) */
+/* LDSO_STUBIFY(encrypt) */
+/* LDSO_STUBIFY(endgrent) */
+/* LDSO_STUBIFY(endhostent) */
+/* LDSO_STUBIFY(endmntent) */
+/* LDSO_STUBIFY(endnetent) */
+/* LDSO_STUBIFY(endprotoent) */
+/* LDSO_STUBIFY(endpwent) */
+/* LDSO_STUBIFY(endrpcent) */
+/* LDSO_STUBIFY(endservent) */
+/* LDSO_STUBIFY(endsgent) */
+/* LDSO_STUBIFY(endspent) */
+/* LDSO_STUBIFY(endusershell) */
+/* LDSO_STUBIFY(endutent) */
+/* LDSO_STUBIFY(environ) */
+/* LDSO_STUBIFY(erand48) */
+/* LDSO_STUBIFY(erf) */
+/* LDSO_STUBIFY(erfc) */
+/* LDSO_STUBIFY(erfcl) */
+/* LDSO_STUBIFY(erfl) */
+/* LDSO_STUBIFY(execl) */
+/* LDSO_STUBIFY(execle) */
+/* LDSO_STUBIFY(execlp) */
+/* LDSO_STUBIFY(execv) */
+/* LDSO_STUBIFY(execve) */
+/* LDSO_STUBIFY(execvp) */
+/* LDSO_STUBIFY(exit) */
+/* LDSO_STUBIFY(exp) */
+/* LDSO_STUBIFY(expl) */
+/* LDSO_STUBIFY(expm1) */
+/* LDSO_STUBIFY(expm1l) */
+/* LDSO_STUBIFY(fabs) */
+/* LDSO_STUBIFY(fabsl) */
+/* LDSO_STUBIFY(fchdir) */
+/* LDSO_STUBIFY(fchmod) */
+/* LDSO_STUBIFY(fchown) */
+/* LDSO_STUBIFY(fclose) */
+/* LDSO_STUBIFY(fcntl) */
+/* LDSO_STUBIFY(fcvt) */
+/* LDSO_STUBIFY(fdopen) */
+/* LDSO_STUBIFY(feof) */
+/* LDSO_STUBIFY(ferror) */
+/* LDSO_STUBIFY(fflush) */
+/* LDSO_STUBIFY(ffs) */
+/* LDSO_STUBIFY(fgetc) */
+/* LDSO_STUBIFY(fgetgrent) */
+/* LDSO_STUBIFY(fgetpos) */
+/* LDSO_STUBIFY(fgetpwent) */
+/* LDSO_STUBIFY(fgets) */
+/* LDSO_STUBIFY(fgetsgent) */
+/* LDSO_STUBIFY(fgetspent) */
+/* LDSO_STUBIFY(fileno) */
+/* LDSO_STUBIFY(finite) */
+/* LDSO_STUBIFY(flock) */
+/* LDSO_STUBIFY(flockfile) */
+/* LDSO_STUBIFY(floor) */
+/* LDSO_STUBIFY(floorl) */
+/* LDSO_STUBIFY(fmod) */
+/* LDSO_STUBIFY(fmodl) */
+/* LDSO_STUBIFY(fnmatch) */
+/* LDSO_STUBIFY(fopen) */
+/* LDSO_STUBIFY(fork) */
+/* LDSO_STUBIFY(fp_nquery) */
+/* LDSO_STUBIFY(fp_query) */
+/* LDSO_STUBIFY(fp_resstat) */
+/* LDSO_STUBIFY(fpathconf) */
+/* LDSO_STUBIFY(fpclassifyd) */
+/* LDSO_STUBIFY(fpclassifyf) */
+/* LDSO_STUBIFY(fpclassifyl) */
+/* LDSO_STUBIFY(fprintf) */
+/* LDSO_STUBIFY(fputc) */
+/* LDSO_STUBIFY(fputs) */
+/* LDSO_STUBIFY(fread) */
+/* LDSO_STUBIFY(free) */
+/* LDSO_STUBIFY(freopen) */
+/* LDSO_STUBIFY(frexp) */
+/* LDSO_STUBIFY(frexpl) */
+/* LDSO_STUBIFY(fscanf) */
+/* LDSO_STUBIFY(fseek) */
+/* LDSO_STUBIFY(fsetpos) */
+/* LDSO_STUBIFY(fstat) */
+/* LDSO_STUBIFY(fstatfs) */
+/* LDSO_STUBIFY(fsync) */
+/* LDSO_STUBIFY(ftell) */
+/* LDSO_STUBIFY(ftime) */
+/* LDSO_STUBIFY(ftok) */
+/* LDSO_STUBIFY(ftruncate) */
+/* LDSO_STUBIFY(ftrylockfile) */
+/* LDSO_STUBIFY(ftw) */
+/* LDSO_STUBIFY(funlockfile) */
+/* LDSO_STUBIFY(fwrite) */
+/* LDSO_STUBIFY(gcvt) */
+/* LDSO_STUBIFY(get_current_dir_name) */
+/* LDSO_STUBIFY(get_myaddress) */
+/* LDSO_STUBIFY(getc) */
+/* LDSO_STUBIFY(getchar) */
+/* LDSO_STUBIFY(getcwd) */
+/* LDSO_STUBIFY(getdelim) */
+/* LDSO_STUBIFY(getdents) */
+/* LDSO_STUBIFY(getdirentries) */
+/* LDSO_STUBIFY(getdomainname) */
+/* LDSO_STUBIFY(getdtablesize) */
+/* LDSO_STUBIFY(getegid) */
+ LDSO_STUBIFY(getenv)
+/* LDSO_STUBIFY(geteuid) */
+/* LDSO_STUBIFY(getgid) */
+/* LDSO_STUBIFY(getgrent) */
+/* LDSO_STUBIFY(getgrgid) */
+/* LDSO_STUBIFY(getgrnam) */
+/* LDSO_STUBIFY(getgroups) */
+/* LDSO_STUBIFY(gethostbyaddr) */
+/* LDSO_STUBIFY(gethostbyname) */
+/* LDSO_STUBIFY(gethostent) */
+/* LDSO_STUBIFY(gethostid) */
+/* LDSO_STUBIFY(gethostname) */
+/* LDSO_STUBIFY(getitimer) */
+/* LDSO_STUBIFY(getlogin) */
+/* LDSO_STUBIFY(getmntent) */
+/* LDSO_STUBIFY(getnetbyaddr) */
+/* LDSO_STUBIFY(getnetbyname) */
+/* LDSO_STUBIFY(getnetent) */
+/* LDSO_STUBIFY(getopt) */
+/* LDSO_STUBIFY(getopt_long) */
+/* LDSO_STUBIFY(getopt_long_only) */
+/* LDSO_STUBIFY(getpagesize) */
+/* LDSO_STUBIFY(getpass) */
+/* LDSO_STUBIFY(getpeername) */
+/* LDSO_STUBIFY(getpgid) */
+/* LDSO_STUBIFY(getpgrp) */
+/* LDSO_STUBIFY(getpid) */
+/* LDSO_STUBIFY(getppid) */
+/* LDSO_STUBIFY(getpriority) */
+/* LDSO_STUBIFY(getprotobyname) */
+/* LDSO_STUBIFY(getprotobynumber) */
+/* LDSO_STUBIFY(getprotoent) */
+/* LDSO_STUBIFY(getpw) */
+/* LDSO_STUBIFY(getpwent) */
+/* LDSO_STUBIFY(getpwnam) */
+/* LDSO_STUBIFY(getpwuid) */
+/* LDSO_STUBIFY(getrlimit) */
+/* LDSO_STUBIFY(getrpcbyname) */
+/* LDSO_STUBIFY(getrpcbynumber) */
+/* LDSO_STUBIFY(getrpcent) */
+/* LDSO_STUBIFY(getrpcport) */
+/* LDSO_STUBIFY(getrusage) */
+/* LDSO_STUBIFY(gets) */
+/* LDSO_STUBIFY(getservbyname) */
+/* LDSO_STUBIFY(getservbyport) */
+/* LDSO_STUBIFY(getservent) */
+/* LDSO_STUBIFY(getsgent) */
+/* LDSO_STUBIFY(getsgnam) */
+/* LDSO_STUBIFY(getsid) */
+/* LDSO_STUBIFY(getsockname) */
+/* LDSO_STUBIFY(getsockopt) */
+/* LDSO_STUBIFY(getspent) */
+/* LDSO_STUBIFY(getspnam) */
+/* LDSO_STUBIFY(gettimeofday) */
+/* LDSO_STUBIFY(getuid) */
+/* LDSO_STUBIFY(getusershell) */
+/* LDSO_STUBIFY(getutent) */
+/* LDSO_STUBIFY(getutid) */
+/* LDSO_STUBIFY(getutline) */
+/* LDSO_STUBIFY(getw) */
+/* LDSO_STUBIFY(getwd) */
+/* LDSO_STUBIFY(glob) */
+/* LDSO_STUBIFY(globfree) */
+/* LDSO_STUBIFY(gmtime) */
+/* LDSO_STUBIFY(gmtime_r) */
+/* LDSO_STUBIFY(gsignal) */
+/* LDSO_STUBIFY(hasmntopt) */
+/* LDSO_STUBIFY(hcreate) */
+/* LDSO_STUBIFY(hdestroy) */
+/* LDSO_STUBIFY(herror) */
+/* LDSO_STUBIFY(hostalias) */
+/* LDSO_STUBIFY(hsearch) */
+/* LDSO_STUBIFY(htonl) */
+/* LDSO_STUBIFY(htons) */
+/* LDSO_STUBIFY(hypot) */
+/* LDSO_STUBIFY(hypotl) */
+/* LDSO_STUBIFY(idle) */
+/* LDSO_STUBIFY(index) */
+/* LDSO_STUBIFY(inet_addr) */
+/* LDSO_STUBIFY(inet_aton) */
+/* LDSO_STUBIFY(inet_lnaof) */
+/* LDSO_STUBIFY(inet_makeaddr) */
+/* LDSO_STUBIFY(inet_netof) */
+/* LDSO_STUBIFY(inet_network) */
+/* LDSO_STUBIFY(inet_nsap_addr) */
+/* LDSO_STUBIFY(inet_nsap_ntoa) */
+/* LDSO_STUBIFY(inet_ntoa) */
+/* LDSO_STUBIFY(infnan) */
+/* LDSO_STUBIFY(init_des) */
+/* LDSO_STUBIFY(initgroups) */
+/* LDSO_STUBIFY(initstate) */
+/* LDSO_STUBIFY(insque) */
+/* LDSO_STUBIFY(ioctl) */
+/* LDSO_STUBIFY(ioperm) */
+/* LDSO_STUBIFY(iopl) */
+/* LDSO_STUBIFY(ipc) */
+/* LDSO_STUBIFY(isalnum) */
+/* LDSO_STUBIFY(isalpha) */
+/* LDSO_STUBIFY(isascii) */
+/* LDSO_STUBIFY(isatty) */
+/* LDSO_STUBIFY(isblank) */
+/* LDSO_STUBIFY(iscntrl) */
+/* LDSO_STUBIFY(isdigit) */
+/* LDSO_STUBIFY(isgraph) */
+/* LDSO_STUBIFY(isinf) */
+/* LDSO_STUBIFY(isinfl) */
+/* LDSO_STUBIFY(islower) */
+/* LDSO_STUBIFY(isnan) */
+/* LDSO_STUBIFY(isnanl) */
+/* LDSO_STUBIFY(isprint) */
+/* LDSO_STUBIFY(ispunct) */
+/* LDSO_STUBIFY(isspace) */
+/* LDSO_STUBIFY(isupper) */
+/* LDSO_STUBIFY(isxdigit) */
+/* LDSO_STUBIFY(j0) */
+/* LDSO_STUBIFY(j0l) */
+/* LDSO_STUBIFY(j1) */
+/* LDSO_STUBIFY(j1l) */
+/* LDSO_STUBIFY(jn) */
+/* LDSO_STUBIFY(jnl) */
+/* LDSO_STUBIFY(jrand48) */
+/* LDSO_STUBIFY(kill) */
+/* LDSO_STUBIFY(killpg) */
+/* LDSO_STUBIFY(labs) */
+/* LDSO_STUBIFY(lckpwdf) */
+/* LDSO_STUBIFY(lcong48) */
+/* LDSO_STUBIFY(ldexp) */
+/* LDSO_STUBIFY(ldexpl) */
+/* LDSO_STUBIFY(ldiv) */
+/* LDSO_STUBIFY(lfind) */
+/* LDSO_STUBIFY(lgamma) */
+/* LDSO_STUBIFY(lgammal) */
+/* LDSO_STUBIFY(libc_nls_init) */
+/* LDSO_STUBIFY(link) */
+/* LDSO_STUBIFY(listen) */
+/* LDSO_STUBIFY(llseek) */
+/* LDSO_STUBIFY(localeconv) */
+/* LDSO_STUBIFY(localtime) */
+/* LDSO_STUBIFY(localtime_r) */
+/* LDSO_STUBIFY(lockf) */
+/* LDSO_STUBIFY(log) */
+/* LDSO_STUBIFY(log10) */
+/* LDSO_STUBIFY(log10l) */
+/* LDSO_STUBIFY(log1p) */
+/* LDSO_STUBIFY(log1pl) */
+/* LDSO_STUBIFY(log2l) */
+/* LDSO_STUBIFY(logl) */
+/* LDSO_STUBIFY(longjmp) */
+/* LDSO_STUBIFY(lrand48) */
+/* LDSO_STUBIFY(lsearch) */
+/* LDSO_STUBIFY(lseek) */
+/* LDSO_STUBIFY(lstat) */
+/* LDSO_STUBIFY(mallinfo) */
+/* LDSO_STUBIFY(malloc) */
+/* LDSO_STUBIFY(malloc_stats) */
+/* LDSO_STUBIFY(malloc_trim) */
+/* LDSO_STUBIFY(malloc_usable_size) */
+/* LDSO_STUBIFY(mallopt) */
+/* LDSO_STUBIFY(mblen) */
+/* LDSO_STUBIFY(mbstowcs) */
+/* LDSO_STUBIFY(mbtowc) */
+/* LDSO_STUBIFY(memalign) */
+/* LDSO_STUBIFY(memccpy) */
+/* LDSO_STUBIFY(memchr) */
+/* LDSO_STUBIFY(memcmp) */
+/* LDSO_STUBIFY(memcpy) */
+/* LDSO_STUBIFY(memfrob) */
+/* LDSO_STUBIFY(memmem) */
+/* LDSO_STUBIFY(memmove) */
+/* LDSO_STUBIFY(memset) */
+/* LDSO_STUBIFY(mkdir) */
+/* LDSO_STUBIFY(mkfifo) */
+/* LDSO_STUBIFY(mknod) */
+/* LDSO_STUBIFY(mkstemp) */
+/* LDSO_STUBIFY(mktemp) */
+/* LDSO_STUBIFY(mktime) */
+/* LDSO_STUBIFY(mlock) */
+/* LDSO_STUBIFY(mlockall) */
+/* LDSO_STUBIFY(mmap) */
+/* LDSO_STUBIFY(modf) */
+/* LDSO_STUBIFY(modfl) */
+/* LDSO_STUBIFY(mount) */
+/* LDSO_STUBIFY(mprotect) */
+/* LDSO_STUBIFY(mrand48) */
+/* LDSO_STUBIFY(mremap) */
+/* LDSO_STUBIFY(msgctl) */
+/* LDSO_STUBIFY(msgget) */
+/* LDSO_STUBIFY(msgrcv) */
+/* LDSO_STUBIFY(msgsnd) */
+/* LDSO_STUBIFY(msync) */
+/* LDSO_STUBIFY(munlock) */
+/* LDSO_STUBIFY(munlockall) */
+/* LDSO_STUBIFY(munmap) */
+/* LDSO_STUBIFY(nice) */
+/* LDSO_STUBIFY(nl_langinfo) */
+/* LDSO_STUBIFY(nrand48) */
+/* LDSO_STUBIFY(ntohl) */
+/* LDSO_STUBIFY(ntohs) */
+/* LDSO_STUBIFY(obstack_free) */
+/* LDSO_STUBIFY(on_exit) */
+/* LDSO_STUBIFY(open) */
+/* LDSO_STUBIFY(opendir) */
+/* LDSO_STUBIFY(openlog) */
+/* LDSO_STUBIFY(optarg) */
+/* LDSO_STUBIFY(opterr) */
+/* LDSO_STUBIFY(optind) */
+/* LDSO_STUBIFY(optopt) */
+/* LDSO_STUBIFY(p_cdname) */
+/* LDSO_STUBIFY(p_cdnname) */
+/* LDSO_STUBIFY(p_class) */
+/* LDSO_STUBIFY(p_fqname) */
+/* LDSO_STUBIFY(p_option) */
+/* LDSO_STUBIFY(p_query) */
+/* LDSO_STUBIFY(p_rr) */
+/* LDSO_STUBIFY(p_time) */
+/* LDSO_STUBIFY(p_type) */
+/* LDSO_STUBIFY(parse_printf_format) */
+/* LDSO_STUBIFY(pathconf) */
+/* LDSO_STUBIFY(pause) */
+/* LDSO_STUBIFY(pclose) */
+/* LDSO_STUBIFY(perror) */
+/* LDSO_STUBIFY(pipe) */
+/* LDSO_STUBIFY(pmap_getmaps) */
+/* LDSO_STUBIFY(pmap_getport) */
+/* LDSO_STUBIFY(pmap_rmtcall) */
+/* LDSO_STUBIFY(pmap_set) */
+/* LDSO_STUBIFY(pmap_unset) */
+/* LDSO_STUBIFY(popen) */
+/* LDSO_STUBIFY(pow) */
+/* LDSO_STUBIFY(pow10) */
+/* LDSO_STUBIFY(pow10l) */
+/* LDSO_STUBIFY(pow2) */
+/* LDSO_STUBIFY(pow2l) */
+/* LDSO_STUBIFY(powl) */
+/* LDSO_STUBIFY(prev_fstat) */
+/* LDSO_STUBIFY(prev_lstat) */
+/* LDSO_STUBIFY(prev_mknod) */
+/* LDSO_STUBIFY(prev_stat) */
+/* LDSO_STUBIFY(prev_ustat) */
+/* LDSO_STUBIFY(printf) */
+/* LDSO_STUBIFY(psignal) */
+/* LDSO_STUBIFY(pthread_cond_signal) */
+/* LDSO_STUBIFY(pthread_cond_wait) */
+/* LDSO_STUBIFY(pthread_mutex_lock) */
+/* LDSO_STUBIFY(pthread_mutex_unlock) */
+/* LDSO_STUBIFY(pthread_once) */
+/* LDSO_STUBIFY(pthread_yield) */
+/* LDSO_STUBIFY(ptrace) */
+/* LDSO_STUBIFY(putc) */
+/* LDSO_STUBIFY(putchar) */
+/* LDSO_STUBIFY(putenv) */
+/* LDSO_STUBIFY(putlong) */
+/* LDSO_STUBIFY(putpwent) */
+/* LDSO_STUBIFY(puts) */
+/* LDSO_STUBIFY(putsgent) */
+/* LDSO_STUBIFY(putshort) */
+/* LDSO_STUBIFY(putspent) */
+/* LDSO_STUBIFY(pututline) */
+/* LDSO_STUBIFY(putw) */
+/* LDSO_STUBIFY(qsort) */
+/* LDSO_STUBIFY(raise) */
+/* LDSO_STUBIFY(rand) */
+/* LDSO_STUBIFY(random) */
+/* LDSO_STUBIFY(rcmd) */
+/* LDSO_STUBIFY(re_comp) */
+/* LDSO_STUBIFY(re_compile_fastmap) */
+/* LDSO_STUBIFY(re_compile_pattern) */
+/* LDSO_STUBIFY(re_error_msg) */
+/* LDSO_STUBIFY(re_exec) */
+/* LDSO_STUBIFY(re_match) */
+/* LDSO_STUBIFY(re_match_2) */
+/* LDSO_STUBIFY(re_search) */
+/* LDSO_STUBIFY(re_search_2) */
+/* LDSO_STUBIFY(re_set_registers) */
+/* LDSO_STUBIFY(re_set_syntax) */
+/* LDSO_STUBIFY(re_syntax_options) */
+/* LDSO_STUBIFY(read) */
+/* LDSO_STUBIFY(readdir) */
+/* LDSO_STUBIFY(readdir_r) */
+/* LDSO_STUBIFY(readlink) */
+/* LDSO_STUBIFY(readv) */
+/* LDSO_STUBIFY(realloc) */
+/* LDSO_STUBIFY(realpath) */
+/* LDSO_STUBIFY(reboot) */
+/* LDSO_STUBIFY(recv) */
+/* LDSO_STUBIFY(recvfrom) */
+/* LDSO_STUBIFY(recvmsg) */
+/* LDSO_STUBIFY(regcomp) */
+/* LDSO_STUBIFY(regerror) */
+/* LDSO_STUBIFY(regexec) */
+/* LDSO_STUBIFY(regfree) */
+/* LDSO_STUBIFY(register_printf_function) */
+/* LDSO_STUBIFY(remove) */
+/* LDSO_STUBIFY(remque) */
+/* LDSO_STUBIFY(rename) */
+/* LDSO_STUBIFY(res_init) */
+/* LDSO_STUBIFY(res_isourserver) */
+/* LDSO_STUBIFY(res_mkquery) */
+/* LDSO_STUBIFY(res_nameinquery) */
+/* LDSO_STUBIFY(res_queriesmatch) */
+/* LDSO_STUBIFY(res_query) */
+/* LDSO_STUBIFY(res_querydomain) */
+/* LDSO_STUBIFY(res_randomid) */
+/* LDSO_STUBIFY(res_search) */
+/* LDSO_STUBIFY(res_send) */
+/* LDSO_STUBIFY(rewind) */
+/* LDSO_STUBIFY(rewinddir) */
+/* LDSO_STUBIFY(rexec) */
+/* LDSO_STUBIFY(rindex) */
+/* LDSO_STUBIFY(rint) */
+/* LDSO_STUBIFY(rmdir) */
+/* LDSO_STUBIFY(rpc_createerr) */
+/* LDSO_STUBIFY(rresvport) */
+/* LDSO_STUBIFY(rtime) */
+/* LDSO_STUBIFY(ruserok) */
+/* LDSO_STUBIFY(rx_cache_bound) */
+/* LDSO_STUBIFY(rx_id_instruction_table) */
+/* LDSO_STUBIFY(rx_id_translation) */
+/* LDSO_STUBIFY(rx_slowmap) */
+/* LDSO_STUBIFY(rx_version_string) */
+/* LDSO_STUBIFY(sbrk) */
+/* LDSO_STUBIFY(scandir) */
+/* LDSO_STUBIFY(scanf) */
+/* LDSO_STUBIFY(seed48) */
+/* LDSO_STUBIFY(seekdir) */
+/* LDSO_STUBIFY(select) */
+/* LDSO_STUBIFY(semctl) */
+/* LDSO_STUBIFY(semget) */
+/* LDSO_STUBIFY(semop) */
+/* LDSO_STUBIFY(send) */
+/* LDSO_STUBIFY(sendmsg) */
+/* LDSO_STUBIFY(sendto) */
+/* LDSO_STUBIFY(set_new_handler) */
+/* LDSO_STUBIFY(setbuf) */
+/* LDSO_STUBIFY(setbuffer) */
+/* LDSO_STUBIFY(setdomainname) */
+/* LDSO_STUBIFY(setegid) */
+/* LDSO_STUBIFY(setenv) */
+/* LDSO_STUBIFY(seteuid) */
+/* LDSO_STUBIFY(setfsgid) */
+/* LDSO_STUBIFY(setfsuid) */
+/* LDSO_STUBIFY(setgid) */
+/* LDSO_STUBIFY(setgrent) */
+/* LDSO_STUBIFY(setgroups) */
+/* LDSO_STUBIFY(sethostent) */
+/* LDSO_STUBIFY(sethostid) */
+/* LDSO_STUBIFY(sethostname) */
+/* LDSO_STUBIFY(setitimer) */
+/* LDSO_STUBIFY(setkey) */
+/* LDSO_STUBIFY(setlinebuf) */
+/* LDSO_STUBIFY(setlocale) */
+/* LDSO_STUBIFY(setlogmask) */
+/* LDSO_STUBIFY(setmntent) */
+/* LDSO_STUBIFY(setnetent) */
+/* LDSO_STUBIFY(setpgid) */
+/* LDSO_STUBIFY(setpgrp) */
+/* LDSO_STUBIFY(setpriority) */
+/* LDSO_STUBIFY(setprotoent) */
+/* LDSO_STUBIFY(setpwent) */
+/* LDSO_STUBIFY(setregid) */
+/* LDSO_STUBIFY(setreuid) */
+/* LDSO_STUBIFY(setrlimit) */
+/* LDSO_STUBIFY(setrpcent) */
+/* LDSO_STUBIFY(setservent) */
+/* LDSO_STUBIFY(setsgent) */
+/* LDSO_STUBIFY(setsid) */
+/* LDSO_STUBIFY(setsockopt) */
+/* LDSO_STUBIFY(setspent) */
+/* LDSO_STUBIFY(setstate) */
+/* LDSO_STUBIFY(settimeofday) */
+/* LDSO_STUBIFY(setuid) */
+/* LDSO_STUBIFY(setusershell) */
+/* LDSO_STUBIFY(setutent) */
+/* LDSO_STUBIFY(setvbuf) */
+/* LDSO_STUBIFY(sgetsgent) */
+/* LDSO_STUBIFY(sgetspent) */
+/* LDSO_STUBIFY(shmat) */
+/* LDSO_STUBIFY(shmctl) */
+/* LDSO_STUBIFY(shmdt) */
+/* LDSO_STUBIFY(shmget) */
+/* LDSO_STUBIFY(shutdown) */
+/* LDSO_STUBIFY(sigaction) */
+/* LDSO_STUBIFY(sigaddset) */
+/* LDSO_STUBIFY(sigblock) */
+/* LDSO_STUBIFY(sigdelset) */
+/* LDSO_STUBIFY(sigemptyset) */
+/* LDSO_STUBIFY(sigfillset) */
+/* LDSO_STUBIFY(siggetmask) */
+/* LDSO_STUBIFY(siginterrupt) */
+/* LDSO_STUBIFY(sigismember) */
+/* LDSO_STUBIFY(siglongjmp) */
+/* LDSO_STUBIFY(signal) */
+/* LDSO_STUBIFY(signgam) */
+/* LDSO_STUBIFY(signgaml) */
+/* LDSO_STUBIFY(sigpause) */
+/* LDSO_STUBIFY(sigpending) */
+/* LDSO_STUBIFY(sigprocmask) */
+/* LDSO_STUBIFY(sigreturn) */
+/* LDSO_STUBIFY(sigsetmask) */
+/* LDSO_STUBIFY(sigsuspend) */
+/* LDSO_STUBIFY(sin) */
+/* LDSO_STUBIFY(sinh) */
+/* LDSO_STUBIFY(sinhl) */
+/* LDSO_STUBIFY(sinl) */
+/* LDSO_STUBIFY(sleep) */
+/* LDSO_STUBIFY(snprintf) */
+/* LDSO_STUBIFY(socket) */
+/* LDSO_STUBIFY(socketcall) */
+/* LDSO_STUBIFY(socketpair) */
+/* LDSO_STUBIFY(sprintf) */
+/* LDSO_STUBIFY(sqrt) */
+/* LDSO_STUBIFY(sqrtl) */
+/* LDSO_STUBIFY(srand) */
+/* LDSO_STUBIFY(srand48) */
+/* LDSO_STUBIFY(srandom) */
+/* LDSO_STUBIFY(sscanf) */
+/* LDSO_STUBIFY(ssignal) */
+/* LDSO_STUBIFY(stat) */
+/* LDSO_STUBIFY(statfs) */
+/* LDSO_STUBIFY(stderr) */
+/* LDSO_STUBIFY(stdin) */
+/* LDSO_STUBIFY(stdout) */
+/* LDSO_STUBIFY(stime) */
+/* LDSO_STUBIFY(stpcpy) */
+/* LDSO_STUBIFY(stpncpy) */
+/* LDSO_STUBIFY(strcasecmp) */
+/* LDSO_STUBIFY(strcat) */
+/* LDSO_STUBIFY(strchr) */
+/* LDSO_STUBIFY(strcmp) */
+/* LDSO_STUBIFY(strcoll) */
+/* LDSO_STUBIFY(strcpy) */
+/* LDSO_STUBIFY(strcspn) */
+/* LDSO_STUBIFY(strdup) */
+/* LDSO_STUBIFY(strerror) */
+/* LDSO_STUBIFY(strfry) */
+/* LDSO_STUBIFY(strftime) */
+/* LDSO_STUBIFY(strlen) */
+/* LDSO_STUBIFY(strncasecmp) */
+/* LDSO_STUBIFY(strncat) */
+/* LDSO_STUBIFY(strncmp) */
+/* LDSO_STUBIFY(strncpy) */
+/* LDSO_STUBIFY(strpbrk) */
+/* LDSO_STUBIFY(strptime) */
+/* LDSO_STUBIFY(strrchr) */
+/* LDSO_STUBIFY(strsep) */
+/* LDSO_STUBIFY(strsignal) */
+/* LDSO_STUBIFY(strspn) */
+/* LDSO_STUBIFY(strstr) */
+/* LDSO_STUBIFY(strtod) */
+/* LDSO_STUBIFY(strtof) */
+/* LDSO_STUBIFY(strtok) */
+/* LDSO_STUBIFY(strtol) */
+/* LDSO_STUBIFY(strtold) */
+/* LDSO_STUBIFY(strtoq) */
+/* LDSO_STUBIFY(strtoul) */
+/* LDSO_STUBIFY(strtouq) */
+/* LDSO_STUBIFY(strxfrm) */
+/* LDSO_STUBIFY(svc_exit) */
+/* LDSO_STUBIFY(svc_fdset) */
+/* LDSO_STUBIFY(svc_getreq) */
+/* LDSO_STUBIFY(svc_getreqset) */
+/* LDSO_STUBIFY(svc_register) */
+/* LDSO_STUBIFY(svc_run) */
+/* LDSO_STUBIFY(svc_sendreply) */
+/* LDSO_STUBIFY(svc_unregister) */
+/* LDSO_STUBIFY(svcerr_auth) */
+/* LDSO_STUBIFY(svcerr_decode) */
+/* LDSO_STUBIFY(svcerr_noproc) */
+/* LDSO_STUBIFY(svcerr_noprog) */
+/* LDSO_STUBIFY(svcerr_progvers) */
+/* LDSO_STUBIFY(svcerr_systemerr) */
+/* LDSO_STUBIFY(svcerr_weakauth) */
+/* LDSO_STUBIFY(svcraw_create) */
+/* LDSO_STUBIFY(svctcp_create) */
+/* LDSO_STUBIFY(svcudp_bufcreate) */
+/* LDSO_STUBIFY(svcudp_create) */
+/* LDSO_STUBIFY(swab) */
+/* LDSO_STUBIFY(swapoff) */
+/* LDSO_STUBIFY(swapon) */
+/* LDSO_STUBIFY(symlink) */
+/* LDSO_STUBIFY(sync) */
+/* LDSO_STUBIFY(sys_errlist) */
+/* LDSO_STUBIFY(sys_nerr) */
+/* LDSO_STUBIFY(sys_siglist) */
+/* LDSO_STUBIFY(syscall) */
+/* LDSO_STUBIFY(syscall_flock) */
+/* LDSO_STUBIFY(syscall_readv) */
+/* LDSO_STUBIFY(syscall_writev) */
+/* LDSO_STUBIFY(sysconf) */
+/* LDSO_STUBIFY(sysinfo) */
+/* LDSO_STUBIFY(syslog) */
+/* LDSO_STUBIFY(system) */
+/* LDSO_STUBIFY(tan) */
+/* LDSO_STUBIFY(tanh) */
+/* LDSO_STUBIFY(tanhl) */
+/* LDSO_STUBIFY(tanl) */
+/* LDSO_STUBIFY(tcdrain) */
+/* LDSO_STUBIFY(tcflow) */
+/* LDSO_STUBIFY(tcflush) */
+/* LDSO_STUBIFY(tcgetattr) */
+/* LDSO_STUBIFY(tcgetpgrp) */
+/* LDSO_STUBIFY(tcsendbreak) */
+/* LDSO_STUBIFY(tcsetattr) */
+/* LDSO_STUBIFY(tcsetpgrp) */
+/* LDSO_STUBIFY(tdelete) */
+/* LDSO_STUBIFY(tell) */
+/* LDSO_STUBIFY(telldir) */
+/* LDSO_STUBIFY(tempnam) */
+/* LDSO_STUBIFY(tfind) */
+/* LDSO_STUBIFY(time) */
+/* LDSO_STUBIFY(timegm) */
+/* LDSO_STUBIFY(times) */
+/* LDSO_STUBIFY(timezone) */
+/* LDSO_STUBIFY(tmpfile) */
+/* LDSO_STUBIFY(tmpnam) */
+/* LDSO_STUBIFY(toascii) */
+/* LDSO_STUBIFY(tolower) */
+/* LDSO_STUBIFY(toupper) */
+/* LDSO_STUBIFY(truncate) */
+/* LDSO_STUBIFY(tsearch) */
+/* LDSO_STUBIFY(ttyname) */
+/* LDSO_STUBIFY(ttyname_r) */
+/* LDSO_STUBIFY(twalk) */
+/* LDSO_STUBIFY(tzname) */
+/* LDSO_STUBIFY(tzset) */
+/* LDSO_STUBIFY(ulckpwdf) */
+/* LDSO_STUBIFY(ulimit) */
+/* LDSO_STUBIFY(umask) */
+/* LDSO_STUBIFY(umount) */
+/* LDSO_STUBIFY(uname) */
+/* LDSO_STUBIFY(ungetc) */
+/* LDSO_STUBIFY(unlink) */
+/* LDSO_STUBIFY(unsetenv) */
+/* LDSO_STUBIFY(uselib) */
+/* LDSO_STUBIFY(usleep) */
+/* LDSO_STUBIFY(ustat) */
+/* LDSO_STUBIFY(utime) */
+/* LDSO_STUBIFY(utimes) */
+/* LDSO_STUBIFY(utmpname) */
+/* LDSO_STUBIFY(valloc) */
+/* LDSO_STUBIFY(vasprintf) */
+/* LDSO_STUBIFY(vfork) */
+/* LDSO_STUBIFY(vfprintf) */
+/* LDSO_STUBIFY(vfscanf) */
+/* LDSO_STUBIFY(vhangup) */
+/* LDSO_STUBIFY(vm86) */
+/* LDSO_STUBIFY(vprintf) */
+/* LDSO_STUBIFY(vscanf) */
+/* LDSO_STUBIFY(vsnprintf) */
+/* LDSO_STUBIFY(vsprintf) */
+/* LDSO_STUBIFY(vsscanf) */
+/* LDSO_STUBIFY(vsyslog) */
+/* LDSO_STUBIFY(wait) */
+/* LDSO_STUBIFY(wait3) */
+/* LDSO_STUBIFY(wait4) */
+/* LDSO_STUBIFY(waitpid) */
+/* LDSO_STUBIFY(wctomb) */
+/* LDSO_STUBIFY(write) */
+/* LDSO_STUBIFY(writev) */
+/* LDSO_STUBIFY(y0) */
+/* LDSO_STUBIFY(y0l) */
+/* LDSO_STUBIFY(y1) */
+/* LDSO_STUBIFY(y1l) */
+/* LDSO_STUBIFY(yn) */
+/* LDSO_STUBIFY(ynl) */
+/* LDSO_STUBIFY(yp_all) */
+/* LDSO_STUBIFY(yp_bind) */
+/* LDSO_STUBIFY(yp_first) */
+/* LDSO_STUBIFY(yp_get_default_domain) */
+/* LDSO_STUBIFY(yp_maplist) */
+/* LDSO_STUBIFY(yp_master) */
+/* LDSO_STUBIFY(yp_match) */
+/* LDSO_STUBIFY(yp_next) */
+/* LDSO_STUBIFY(yp_order) */
+/* LDSO_STUBIFY(yp_unbind) */
+/* LDSO_STUBIFY(yperr_string) */
+/* LDSO_STUBIFY(ypprot_err) */
--- /dev/null
+/*
+ * This software is part of the SBCL system. See the README file for
+ * more information.
+ *
+ * This software is derived from the CMU CL system, which was
+ * written at Carnegie Mellon University and released into the
+ * public domain. The software is in the public domain and is
+ * provided with absolutely no warranty. See the COPYING and CREDITS
+ * files for more information.
+ */
+
+/*
+ * $Header$
+ */
+
+#if defined(mips) || defined(irix)
+#include "mips-lispregs.h"
+#endif
+
+#ifdef sparc
+#include "sparc-lispregs.h"
+#endif
+
+#ifdef ibmrt
+#include "rt-lispregs.h"
+#endif
+
+#ifdef __i386__
+#include "x86-lispregs.h"
+#endif
+
+#ifdef parisc
+#include "hppa-lispregs.h"
+#endif
+
+#ifdef alpha
+#include "alpha-lispregs.h"
+#endif
+
+#ifndef LANGUAGE_ASSEMBLY
+extern char *lisp_register_names[];
+#endif
--- /dev/null
+/*
+ * This software is part of the SBCL system. See the README file for
+ * more information.
+ *
+ * This software is derived from the CMU CL system, which was
+ * written at Carnegie Mellon University and released into the
+ * public domain. The software is in the public domain and is
+ * provided with absolutely no warranty. See the COPYING and CREDITS
+ * files for more information.
+ */
+
+/*
+ * $Header$
+ */
+
+#include <stdio.h>
+#include <sys/types.h>
+#include <stdlib.h>
+#include <setjmp.h>
+#include <sys/time.h>
+#include <sys/resource.h>
+#include <signal.h>
+
+#include "runtime.h"
+#include "sbcl.h"
+#include "globals.h"
+#include "vars.h"
+#include "parse.h"
+#include "os.h"
+#include "interrupt.h"
+#include "lispregs.h"
+#include "monitor.h"
+#include "print.h"
+#include "arch.h"
+#include "gc.h"
+#include "search.h"
+#include "purify.h"
+
+extern boolean isatty(int fd);
+
+typedef void cmd(char **ptr);
+
+static cmd call_cmd, dump_cmd, print_cmd, quit, help;
+static cmd flush_cmd, search_cmd, regs_cmd, exit_cmd;
+static cmd print_context_cmd;
+static cmd backtrace_cmd, purify_cmd, catchers_cmd;
+static cmd grab_sigs_cmd;
+
+static struct cmd {
+ char *cmd, *help;
+ void (*fn)(char **ptr);
+} Cmds[] = {
+ {"help", "Display this help information.", help},
+ {"?", "help", help},
+ {"backtrace", "Backtrace up to N frames.", backtrace_cmd},
+ {"call", "Call FUNCTION with ARG1, ARG2, ...", call_cmd},
+ {"catchers", "Print a list of all the active catchers.", catchers_cmd},
+ {"context", "Print interrupt context number I.", print_context_cmd},
+ {"dump", "Dump memory starting at ADDRESS for COUNT words.", dump_cmd},
+ {"d", "dump", dump_cmd},
+ {"exit", "Exit this instance of the monitor.", exit_cmd},
+ {"flush", "Flush all temp variables.", flush_cmd},
+ /* (Classic CMU CL had a "gc" command here, which seems like a
+ * reasonable idea, but the code was stale (incompatible with
+ * gencgc) so I just flushed it. -- WHN 20000814 */
+ {"grab-signals", "Set the signal handlers to call LDB.", grab_sigs_cmd},
+ {"purify", "Purify. (Caveat purifier!)", purify_cmd},
+ {"print", "Print object at ADDRESS.", print_cmd},
+ {"p", "print", print_cmd},
+ {"quit", "Quit.", quit},
+ {"regs", "Display current Lisp regs.", regs_cmd},
+ {"search", "Search for TYPE starting at ADDRESS for a max of COUNT words.", search_cmd},
+ {"s", "search", search_cmd},
+ {NULL, NULL, NULL}
+};
+
+static jmp_buf curbuf;
+
+static int visible(unsigned char c)
+{
+ if (c < ' ' || c > '~')
+ return ' ';
+ else
+ return c;
+}
+
+static void dump_cmd(char **ptr)
+{
+ static char *lastaddr = 0;
+ static int lastcount = 20;
+
+ char *addr = lastaddr;
+ int count = lastcount, displacement;
+
+ if (more_p(ptr)) {
+ addr = parse_addr(ptr);
+
+ if (more_p(ptr))
+ count = parse_number(ptr);
+ }
+
+ if (count == 0) {
+ printf("COUNT must be non-zero.\n");
+ return;
+ }
+
+ lastcount = count;
+
+ if (count > 0)
+ displacement = 4;
+ else {
+ displacement = -4;
+ count = -count;
+ }
+
+ while (count-- > 0) {
+#ifndef alpha
+ printf("0x%08lX: ", (unsigned long) addr);
+#else
+ printf("0x%08X: ", (u32) addr);
+#endif
+ if (is_valid_lisp_addr((os_vm_address_t)addr)) {
+#ifndef alpha
+ unsigned long *lptr = (unsigned long *)addr;
+#else
+ u32 *lptr = (unsigned long *)addr;
+#endif
+ unsigned short *sptr = (unsigned short *)addr;
+ unsigned char *cptr = (unsigned char *)addr;
+
+ printf("0x%08lx 0x%04x 0x%04x 0x%02x 0x%02x 0x%02x 0x%02x %c%c%c%c\n", lptr[0], sptr[0], sptr[1], cptr[0], cptr[1], cptr[2], cptr[3], visible(cptr[0]), visible(cptr[1]), visible(cptr[2]), visible(cptr[3]));
+ }
+ else
+ printf("invalid Lisp-level address\n");
+
+ addr += displacement;
+ }
+
+ lastaddr = addr;
+}
+
+static void print_cmd(char **ptr)
+{
+ lispobj obj = parse_lispobj(ptr);
+
+ print(obj);
+}
+
+static void regs_cmd(char **ptr)
+{
+ printf("CSP\t=\t0x%08lX\n", (unsigned long)current_control_stack_pointer);
+ printf("FP\t=\t0x%08lX\n", (unsigned long)current_control_frame_pointer);
+#if !defined(ibmrt) && !defined(__i386__)
+ printf("BSP\t=\t0x%08X\n", (unsigned long)current_binding_stack_pointer);
+#endif
+#ifdef __i386__
+ printf("BSP\t=\t0x%08X\n", SymbolValue(BINDING_STACK_POINTER));
+#endif
+
+ printf("DYNAMIC\t=\t0x%08lX\n", (unsigned long)current_dynamic_space);
+#if defined(ibmrt) || defined(__i386__)
+ printf("ALLOC\t=\t0x%08lX\n", SymbolValue(ALLOCATION_POINTER));
+ printf("TRIGGER\t=\t0x%08lX\n", SymbolValue(INTERNAL_GC_TRIGGER));
+#else
+ printf("ALLOC\t=\t0x%08X\n",
+ (unsigned long)current_dynamic_space_free_pointer);
+ printf("TRIGGER\t=\t0x%08X\n", (unsigned long)current_auto_gc_trigger);
+#endif
+ printf("STATIC\t=\t0x%08lX\n", SymbolValue(STATIC_SPACE_FREE_POINTER));
+ printf("RDONLY\t=\t0x%08lX\n", SymbolValue(READ_ONLY_SPACE_FREE_POINTER));
+
+#ifdef MIPS
+ printf("FLAGS\t=\t0x%08x\n", current_flags_register);
+#endif
+}
+
+static void search_cmd(char **ptr)
+{
+ static int lastval = 0, lastcount = 0;
+ static lispobj *start = 0, *end = 0;
+ int val, count;
+ lispobj *addr, obj;
+
+ if (more_p(ptr)) {
+ val = parse_number(ptr);
+ if (val < 0 || val > 0xff) {
+ printf("Can only search for single bytes.\n");
+ return;
+ }
+ if (more_p(ptr)) {
+ addr = (lispobj *)PTR((long)parse_addr(ptr));
+ if (more_p(ptr)) {
+ count = parse_number(ptr);
+ }
+ else {
+ /* Speced value and address, but no count. Only one. */
+ count = -1;
+ }
+ }
+ else {
+ /* Speced a value, but no address, so search same range. */
+ addr = start;
+ count = lastcount;
+ }
+ }
+ else {
+ /* Speced nothing, search again for val. */
+ val = lastval;
+ addr = end;
+ count = lastcount;
+ }
+
+ lastval = val;
+ start = end = addr;
+ lastcount = count;
+
+ printf("searching for 0x%x at 0x%08lX\n", val, (unsigned long)end);
+
+ while (search_for_type(val, &end, &count)) {
+ printf("found 0x%x at 0x%08lX:\n", val, (unsigned long)end);
+ obj = *end;
+ addr = end;
+ end += 2;
+ if (TypeOf(obj) == type_FunctionHeader)
+ print((long)addr | type_FunctionPointer);
+ else if (LowtagOf(obj) == type_OtherImmediate0 || LowtagOf(obj) == type_OtherImmediate1)
+ print((lispobj)addr | type_OtherPointer);
+ else
+ print((lispobj)addr);
+ if (count == -1)
+ return;
+ }
+}
+
+static void call_cmd(char **ptr)
+{
+ lispobj thing = parse_lispobj(ptr), function, result, cons, args[3];
+ int numargs;
+
+ if (LowtagOf(thing) == type_OtherPointer) {
+ switch (TypeOf(*(lispobj *)(thing-type_OtherPointer))) {
+ case type_SymbolHeader:
+ for (cons = SymbolValue(INITIAL_FDEFN_OBJECTS);
+ cons != NIL;
+ cons = CONS(cons)->cdr) {
+ if (FDEFN(CONS(cons)->car)->name == thing) {
+ thing = CONS(cons)->car;
+ goto fdefn;
+ }
+ }
+ printf("symbol 0x%08lx is undefined.\n", thing);
+ return;
+
+ case type_Fdefn:
+ fdefn:
+ function = FDEFN(thing)->function;
+ if (function == NIL) {
+ printf("fdefn 0x%08lx is undefined.\n", thing);
+ return;
+ }
+ break;
+ default:
+ printf(
+ "0x%08lx is not a function pointer, symbol, or fdefn object.\n",
+ thing);
+ return;
+ }
+ }
+ else if (LowtagOf(thing) != type_FunctionPointer) {
+ printf("0x%08lx is not a function pointer, symbol, or fdefn object.\n",
+ thing);
+ return;
+ }
+ else
+ function = thing;
+
+ numargs = 0;
+ while (more_p(ptr)) {
+ if (numargs >= 3) {
+ printf("Too many arguments. (3 at most)\n");
+ return;
+ }
+ args[numargs++] = parse_lispobj(ptr);
+ }
+
+ switch (numargs) {
+ case 0:
+ result = funcall0(function);
+ break;
+ case 1:
+ result = funcall1(function, args[0]);
+ break;
+ case 2:
+ result = funcall2(function, args[0], args[1]);
+ break;
+ case 3:
+ result = funcall3(function, args[0], args[1], args[2]);
+ break;
+ }
+
+ print(result);
+}
+
+static void flush_cmd(char **ptr)
+{
+ flush_vars();
+}
+
+static void quit(char **ptr)
+{
+ char buf[10];
+
+ printf("Really quit? [y] ");
+ fflush(stdout);
+ fgets(buf, sizeof(buf), stdin);
+ if (buf[0] == 'y' || buf[0] == 'Y' || buf[0] == '\n')
+ exit(0);
+}
+
+static void help(char **ptr)
+{
+ struct cmd *cmd;
+
+ for (cmd = Cmds; cmd->cmd != NULL; cmd++)
+ if (cmd->help != NULL)
+ printf("%s\t%s\n", cmd->cmd, cmd->help);
+}
+
+static int done;
+
+static void exit_cmd(char **ptr)
+{
+ done = 1;
+}
+
+static void purify_cmd(char **ptr)
+{
+ purify(NIL, NIL);
+}
+
+static void print_context(os_context_t *context)
+{
+ int i;
+
+ for (i = 0; i < NREGS; i++) {
+ printf("%s:\t", lisp_register_names[i]);
+#ifdef __i386__
+ brief_print((lispobj)(*os_context_register_addr(context,
+ i*2)));
+#else
+ brief_print((lispobj)(*os_context_register_addr(context,
+ i)));
+#endif
+ }
+ printf("PC:\t\t 0x%08lx\n", *os_context_pc_addr(context));
+}
+
+static void print_context_cmd(char **ptr)
+{
+ int free;
+
+ free = SymbolValue(FREE_INTERRUPT_CONTEXT_INDEX)>>2;
+
+ if (more_p(ptr)) {
+ int index;
+
+ index = parse_number(ptr);
+
+ if ((index >= 0) && (index < free)) {
+ printf("There are %d interrupt contexts.\n", free);
+ printf("Printing context %d\n", index);
+ print_context(lisp_interrupt_contexts[index]);
+ } else {
+ printf("There aren't that many/few contexts.\n");
+ printf("There are %d interrupt contexts.\n", free);
+ }
+ } else {
+ if (free == 0)
+ printf("There are no interrupt contexts!\n");
+ else {
+ printf("There are %d interrupt contexts.\n", free);
+ printf("Printing context %d\n", free - 1);
+ print_context(lisp_interrupt_contexts[free - 1]);
+ }
+ }
+}
+
+static void backtrace_cmd(char **ptr)
+{
+ void backtrace(int frames);
+ int n;
+
+ if (more_p(ptr))
+ n = parse_number(ptr);
+ else
+ n = 100;
+
+ printf("Backtrace:\n");
+ backtrace(n);
+}
+
+static void catchers_cmd(char **ptr)
+{
+ struct catch_block *catch;
+
+ catch = (struct catch_block *)SymbolValue(CURRENT_CATCH_BLOCK);
+
+ if (catch == NULL)
+ printf("There are no active catchers!\n");
+ else {
+ while (catch != NULL) {
+#ifndef __i386__
+ printf("0x%08lX:\n\tuwp: 0x%08lX\n\tfp: 0x%08lX\n\tcode: 0x%08lx\n\tentry: 0x%08lx\n\ttag: ",
+ (unsigned long)catch, (unsigned long)(catch->current_uwp),
+ (unsigned long)(catch->current_cont),
+ catch->current_code,
+ catch->entry_pc);
+#else
+ printf("0x%08lX:\n\tuwp: 0x%08lX\n\tfp: 0x%08lX\n\tcode: 0x%08lx\n\tentry: 0x%08lx\n\ttag: ",
+ (unsigned long)catch, (unsigned long)(catch->current_uwp),
+ (unsigned long)(catch->current_cont),
+ component_ptr_from_pc(catch->entry_pc) + type_OtherPointer,
+ catch->entry_pc);
+#endif
+ brief_print((lispobj)catch->tag);
+ catch = catch->previous_catch;
+ }
+ }
+}
+
+static void grab_sigs_cmd(char **ptr)
+{
+ extern void sigint_init(void);
+
+ printf("Grabbing signals.\n");
+ sigint_init();
+}
+
+static void sub_monitor(void)
+{
+ struct cmd *cmd, *found;
+ char buf[256];
+ char *line, *ptr, *token;
+ int ambig;
+
+ while (!done) {
+ printf("ldb> ");
+ fflush(stdout);
+ line = fgets(buf, sizeof(buf), stdin);
+ if (line == NULL) {
+ if (isatty(0)) {
+ putchar('\n');
+ continue;
+ }
+ else {
+ fprintf(stderr, "\nEOF on something other than a tty.\n");
+ exit(0);
+ }
+ }
+ ptr = line;
+ if ((token = parse_token(&ptr)) == NULL)
+ continue;
+ ambig = 0;
+ found = NULL;
+ for (cmd = Cmds; cmd->cmd != NULL; cmd++) {
+ if (strcmp(token, cmd->cmd) == 0) {
+ found = cmd;
+ ambig = 0;
+ break;
+ }
+ else if (strncmp(token, cmd->cmd, strlen(token)) == 0) {
+ if (found)
+ ambig = 1;
+ else
+ found = cmd;
+ }
+ }
+ if (ambig)
+ printf("``%s'' is ambiguous.\n", token);
+ else if (found == NULL)
+ printf("unknown command: ``%s''\n", token);
+ else {
+ reset_printer();
+ (*found->fn)(&ptr);
+ }
+ }
+}
+
+void ldb_monitor()
+{
+ jmp_buf oldbuf;
+
+ bcopy(curbuf, oldbuf, sizeof(oldbuf));
+
+ printf("LDB monitor\n");
+
+ setjmp(curbuf);
+
+ sub_monitor();
+
+ done = 0;
+
+ bcopy(oldbuf, curbuf, sizeof(curbuf));
+}
+
+void throw_to_monitor()
+{
+ longjmp(curbuf, 1);
+}
--- /dev/null
+/*
+ * This software is part of the SBCL system. See the README file for
+ * more information.
+ *
+ * This software is derived from the CMU CL system, which was
+ * written at Carnegie Mellon University and released into the
+ * public domain. The software is in the public domain and is
+ * provided with absolutely no warranty. See the COPYING and CREDITS
+ * files for more information.
+ */
+
+/*
+ * $Header$
+ */
+
+extern void ldb_monitor(void);
+extern void throw_to_monitor(void);
--- /dev/null
+/*
+ * This software is part of the SBCL system. See the README file for
+ * more information.
+ *
+ * This software is derived from the CMU CL system, which was
+ * written at Carnegie Mellon University and released into the
+ * public domain. The software is in the public domain and is
+ * provided with absolutely no warranty. See the COPYING and CREDITS
+ * files for more information.
+ */
+
+/*
+ * $Header$
+ */
+
+#include <stdio.h>
+#include <errno.h>
+
+#include "os.h"
+
+/* Except for os_zero, these routines are only called by Lisp code.
+ * These routines may also be replaced by os-dependent versions
+ * instead. See hpux-os.c for some useful restrictions on actual
+ * usage. */
+
+void
+os_zero(os_vm_address_t addr, os_vm_size_t length)
+{
+ os_vm_address_t block_start;
+ os_vm_size_t block_size;
+
+#ifdef DEBUG
+ fprintf(stderr,";;; os_zero: addr: 0x%08x, len: 0x%08x\n",addr,length);
+#endif
+
+ block_start = os_round_up_to_page(addr);
+
+ length -= block_start-addr;
+ block_size = os_trunc_size_to_page(length);
+
+ if (block_start > addr)
+ bzero((char *)addr, block_start-addr);
+ if (block_size < length)
+ bzero((char *)block_start+block_size, length-block_size);
+
+ if (block_size != 0) {
+ /* Now deallocate and allocate the block so that it faults in
+ * zero-filled. */
+
+ os_invalidate(block_start, block_size);
+ addr = os_validate(block_start, block_size);
+
+ if(addr == NULL || addr != block_start)
+ lose("os_zero: block moved! 0x%08x ==> 0x%08x",
+ block_start,
+ addr);
+ }
+}
+
+os_vm_address_t
+os_allocate(os_vm_size_t len)
+{
+ return os_validate((os_vm_address_t)NULL, len);
+}
+
+os_vm_address_t
+os_allocate_at(os_vm_address_t addr, os_vm_size_t len)
+{
+ return os_validate(addr, len);
+}
+
+void
+os_deallocate(os_vm_address_t addr, os_vm_size_t len)
+{
+ os_invalidate(addr,len);
+}
+
+/* (This function once tried to grow the chunk by asking os_validate
+ * whether the space was available, but that really only works under
+ * Mach.) */
+os_vm_address_t
+os_reallocate(os_vm_address_t addr, os_vm_size_t old_len, os_vm_size_t len)
+{
+ addr=os_trunc_to_page(addr);
+ len=os_round_up_size_to_page(len);
+ old_len=os_round_up_size_to_page(old_len);
+
+ if(addr==NULL)
+ return os_allocate(len);
+ else{
+ long len_diff=len-old_len;
+
+ if(len_diff<0)
+ os_invalidate(addr+len,-len_diff);
+ else{
+ if(len_diff!=0){
+ os_vm_address_t new=os_allocate(len);
+
+ if(new!=NULL){
+ bcopy(addr,new,old_len);
+ os_invalidate(addr,old_len);
+ }
+
+ addr=new;
+ }
+ }
+ return addr;
+ }
+}
+
+int
+os_get_errno(void)
+{
+ return errno;
+}
--- /dev/null
+/*
+ * common interface for OS-dependent functions
+ */
+
+/*
+ * This software is part of the SBCL system. See the README file for
+ * more information.
+ *
+ * This software is derived from the CMU CL system, which was
+ * written at Carnegie Mellon University and released into the
+ * public domain. The software is in the public domain and is
+ * provided with absolutely no warranty. See the COPYING and CREDITS
+ * files for more information.
+ */
+
+/*
+ * $Header$
+ */
+
+#if !defined(_OS_H_INCLUDED_)
+
+#define _OS_H_INCLUDED_
+
+#include "runtime.h"
+
+/* Some standard preprocessor definitions and typedefs are needed from
+ * the OS-specific #include files. This is an attempt to document
+ * them on 20000729, by WHN the impatient reverse engineer.
+ *
+ * OS_VM_PROT_READ, OS_VM_PROT_WRITE, OS_VM_PROT_EXECUTE
+ * flags for mmap, mprotect, etc. controlling memory protection
+ * os_vm_prot_t
+ * type used for flags for mmap, mprotect, etc.
+ *
+ * OS_VM_DEFAULT_PAGESIZE
+ * used by core dumping and loading logic (but dunno its exact
+ * definition, in particular why we can't just use getpagesize()
+ * instead)
+ *
+ * os_vm_address_t
+ * the type used to represent addresses? (dunno why not just void*)
+ * os_vm_size_t, os_vm_off_t
+ * corresponding to standard (POSIX?) types size_t, off_t
+ * os_context_t
+ * the type used to represent context in a POSIX sigaction SA_SIGACTION
+ * handler, i.e. the actual type of the thing pointed to by the
+ * void* third argument of a handler */
+#if defined __FreeBSD__
+#include "bsd-os.h"
+#elif defined __OpenBSD__
+#include "bsd-os.h"
+#elif defined __linux__
+#include "linux-os.h"
+#else
+#error unsupported OS
+#endif
+
+#define OS_VM_PROT_ALL \
+ (OS_VM_PROT_READ | OS_VM_PROT_WRITE | OS_VM_PROT_EXECUTE)
+
+extern os_vm_size_t os_vm_page_size;
+
+/* Do anything we need to do when starting up the runtime environment
+ * in this OS. */
+extern void os_init(void);
+
+/* Install any OS-dependent low-level signal handlers which are needed
+ * by the runtime environment. E.g. the signals raised by a violation
+ * of the gencgc write barrier need to be caught at a low level, and
+ * they may be SIGSEGV on one OS and SIGBUS on another, so we install
+ * them in an OS-dependent way. */
+extern void os_install_interrupt_handlers(void);
+
+/* Clear a possibly-huge region of memory using any tricks available to
+ * do it efficiently, e.g. possibly unmapping it and then remapping it.
+ *
+ * FIXME: For the x86 Linux/OpenBSD/FreeBSD ports, I'd be somewhat
+ * surprised if bzero() wasn't substantially as efficient as
+ * any tricks like this. It might make sense to benchmark it
+ * and simplify if the difference isn't too large. */
+extern void os_zero(os_vm_address_t addr, os_vm_size_t length);
+
+/* It looks as though this function allocates 'len' bytes at 'addr',
+ * or at an OS-chosen address if 'addr' is zero.
+ *
+ * FIXME: There was some documentation for these functions in
+ * "hp-ux.c" in the old CMU CL code. Perhaps move/merge it in here. */
+extern os_vm_address_t os_validate(os_vm_address_t addr, os_vm_size_t len);
+
+/* This function seems to undo the effect of os_validate(..). */
+extern void os_invalidate(os_vm_address_t addr, os_vm_size_t len);
+
+/* This maps a file into memory, or calls lose(..) for various
+ * failures. */
+extern os_vm_address_t os_map(int fd,
+ int offset,
+ os_vm_address_t addr,
+ os_vm_size_t len);
+
+/* This presumably flushes the instruction cache, if that can be done
+ * explicitly. (It doesn't seem to be an issue for the i386 port,
+ * which is all that exists for SBCL. It might be important for some
+ * other architecture which CMU CL has been ported to, though. */
+extern void os_flush_icache(os_vm_address_t addr, os_vm_size_t len);
+
+/* This sets access rights for an area of memory, e.g.
+ * write-protecting a page so that the garbage collector can find out
+ * whether it's modified by handling the signal. */
+extern void os_protect(os_vm_address_t addr,
+ os_vm_size_t len,
+ os_vm_prot_t protection);
+
+/* This returns true for an address which makes sense at the Lisp level. */
+extern boolean is_valid_lisp_addr(os_vm_address_t test);
+
+/* Given a signal context, return the address for storage of the
+ * register, of the specified offset, for that context. The offset is
+ * defined in the storage class (SC) defined in the Lisp virtual
+ * machine (i.e. the file "vm.lisp" for the appropriate architecture). */
+int *os_context_register_addr(os_context_t *context, int offset);
+
+/* Given a signal context, return the address for storage of the
+ * program counter for that context. */
+int *os_context_pc_addr(os_context_t *context);
+
+/* Given a signal context, return the address for storage of the
+ * system stack pointer for that context. */
+int *os_context_sp_addr(os_context_t *context);
+
+/* Given a signal context, return the address for storage of the
+ * signal mask for that context. */
+sigset_t *os_context_sigmask_addr(os_context_t *context);
+
+/* (Note that there may be other accessors for os_context_t which
+ * depend not only on the OS, but also on the architecture, e.g.
+ * getting at EFL/EFLAGS on the x86. Such things are defined in the
+ * architecture-dependence files, not the OS-dependence files.) */
+
+/* These are not architecture-specific functions, but are instead
+ * general utilities defined in terms of the architecture-specific
+ * function os_validate(..) and os_invalidate(..).
+ *
+ * FIXME: os_reallocate(..) is complicated and seems no longer to be
+ * used for anything. Perhaps we could delete it? */
+extern os_vm_address_t os_allocate(os_vm_size_t len);
+extern os_vm_address_t os_allocate_at(os_vm_address_t addr, os_vm_size_t len);
+extern os_vm_address_t os_reallocate(os_vm_address_t addr,
+ os_vm_size_t old_len,
+ os_vm_size_t len);
+extern void os_deallocate(os_vm_address_t addr, os_vm_size_t len);
+
+
+/* FIXME: The os_trunc_foo(..) and os_round_foo(..) macros here could
+ * be functions. */
+
+#define os_trunc_to_page(addr) \
+ (os_vm_address_t)(((long)(addr))&~(os_vm_page_size-1))
+#define os_round_up_to_page(addr) \
+ os_trunc_to_page((addr)+(os_vm_page_size-1))
+
+#define os_trunc_size_to_page(size) \
+ (os_vm_size_t)(((long)(size))&~(os_vm_page_size-1))
+#define os_round_up_size_to_page(size) \
+ os_trunc_size_to_page((size)+(os_vm_page_size-1))
+
+/* KLUDGE: The errno error reporting system is an ugly nonreentrant
+ * botch which nonetheless wasn't too painful in the old days.
+ * However, it's obviously not good for multithreaded programs, and n
+ * order to accommodate multithreading while retaining the C-level
+ * syntax of the old UNIX interface, errno has now been changed from a
+ * true variable to a preprocessor definition which is too hairy for
+ * us to try to unscrew in Lisp code. Instead, Lisp code calls this
+ * service routine to do whatever hackery is necessary in C code, and
+ * to return the value in a way that Lisp can understand. */
+int os_get_errno(void);
+
+#endif
--- /dev/null
+/*
+ * This software is part of the SBCL system. See the README file for
+ * more information.
+ *
+ * This software is derived from the CMU CL system, which was
+ * written at Carnegie Mellon University and released into the
+ * public domain. The software is in the public domain and is
+ * provided with absolutely no warranty. See the COPYING and CREDITS
+ * files for more information.
+ */
+
+/*
+ * $Header$
+ */
+
+#include <stdio.h>
+#include <ctype.h>
+#include <signal.h>
+
+#include "runtime.h"
+#include "sbcl.h"
+#include "globals.h"
+#include "vars.h"
+#include "parse.h"
+#include "os.h"
+#include "interrupt.h"
+#include "lispregs.h"
+#include "monitor.h"
+#include "arch.h"
+#include "search.h"
+
+static void skip_ws(char **ptr)
+{
+ while (**ptr <= ' ' && **ptr != '\0')
+ (*ptr)++;
+}
+
+static boolean string_to_long(char *token, long *value)
+{
+ int base, digit;
+ long num;
+ char *ptr;
+
+ if (token == 0)
+ return 0;
+
+ if (token[0] == '0')
+ if (token[1] == 'x') {
+ base = 16;
+ token += 2;
+ }
+ else {
+ base = 8;
+ token++;
+ }
+ else if (token[0] == '#') {
+ switch (token[1]) {
+ case 'x':
+ case 'X':
+ base = 16;
+ token += 2;
+ break;
+ case 'o':
+ case 'O':
+ base = 8;
+ token += 2;
+ break;
+ default:
+ return 0;
+ }
+ }
+ else
+ base = 10;
+
+ num = 0;
+ ptr = token;
+ while (*ptr != '\0') {
+ if (*ptr >= 'a' && *ptr <= 'f')
+ digit = *ptr + 10 - 'a';
+ else if (*ptr >= 'A' && *ptr <= 'F')
+ digit = *ptr + 10 - 'A';
+ else if (*ptr >= '0' && *ptr <= '9')
+ digit = *ptr - '0';
+ else
+ return 0;
+ if (digit < 0 || digit >= base)
+ return 0;
+
+ ptr++;
+ num = num * base + digit;
+ }
+
+ *value = num;
+ return 1;
+}
+
+static boolean lookup_variable(char *name, lispobj *result)
+{
+ struct var *var = lookup_by_name(name);
+
+ if (var == NULL)
+ return 0;
+ else {
+ *result = var_value(var);
+ return 1;
+ }
+}
+
+
+boolean more_p(ptr)
+char **ptr;
+{
+ skip_ws(ptr);
+
+ if (**ptr == '\0')
+ return 0;
+ else
+ return 1;
+}
+
+char *parse_token(ptr)
+char **ptr;
+{
+ char *token;
+
+ skip_ws(ptr);
+
+ if (**ptr == '\0')
+ return NULL;
+
+ token = *ptr;
+
+ while (**ptr > ' ')
+ (*ptr)++;
+
+ if (**ptr != '\0') {
+ **ptr = '\0';
+ (*ptr)++;
+ }
+
+ return token;
+}
+
+#if 0
+static boolean number_p(token)
+char *token;
+{
+ char *okay;
+
+ if (token == NULL)
+ return 0;
+
+ okay = "abcdefABCDEF987654321d0";
+
+ if (token[0] == '0')
+ if (token[1] == 'x' || token[1] == 'X')
+ token += 2;
+ else {
+ token++;
+ okay += 14;
+ }
+ else if (token[0] == '#') {
+ switch (token[1]) {
+ case 'x':
+ case 'X':
+ break;
+ case 'o':
+ case 'O':
+ okay += 14;
+ break;
+ default:
+ return 0;
+ }
+ }
+ else
+ okay += 12;
+
+ while (*token != '\0')
+ if (index(okay, *token++) == NULL)
+ return 0;
+ return 1;
+}
+#endif
+
+long parse_number(ptr)
+char **ptr;
+{
+ char *token = parse_token(ptr);
+ long result;
+
+ if (token == NULL) {
+ printf("expected a number\n");
+ throw_to_monitor();
+ }
+ else if (string_to_long(token, &result))
+ return result;
+ else {
+ printf("invalid number: ``%s''\n", token);
+ throw_to_monitor();
+ }
+ return 0;
+}
+
+char *parse_addr(ptr)
+char **ptr;
+{
+ char *token = parse_token(ptr);
+ long result;
+
+ if (token == NULL) {
+ printf("expected an address\n");
+ throw_to_monitor();
+ }
+ else if (token[0] == '$') {
+ if (!lookup_variable(token+1, (lispobj *)&result)) {
+ printf("unknown variable: ``%s''\n", token);
+ throw_to_monitor();
+ }
+ result &= ~7;
+ }
+ else {
+ if (!string_to_long(token, &result)) {
+ printf("invalid number: ``%s''\n", token);
+ throw_to_monitor();
+ }
+ result &= ~3;
+ }
+
+ if (!is_valid_lisp_addr((os_vm_address_t)result)) {
+ printf("invalid Lisp-level address: 0x%lx\n", result);
+ throw_to_monitor();
+ }
+
+ return (char *)result;
+}
+
+static boolean lookup_symbol(char *name, lispobj *result)
+{
+ int count;
+ lispobj *headerptr;
+
+ /* Search static space. */
+ headerptr = static_space;
+ count = ((lispobj *) SymbolValue(STATIC_SPACE_FREE_POINTER) -
+ static_space);
+ if (search_for_symbol(name, &headerptr, &count)) {
+ *result = (lispobj)headerptr | type_OtherPointer;
+ return 1;
+ }
+
+ /* Search dynamic space. */
+ headerptr = current_dynamic_space;
+#if !defined(ibmrt) && !defined(__i386__)
+ count = current_dynamic_space_free_pointer - current_dynamic_space;
+#else
+ count = (lispobj *)SymbolValue(ALLOCATION_POINTER) - current_dynamic_space;
+#endif
+ if (search_for_symbol(name, &headerptr, &count)) {
+ *result = (lispobj)headerptr | type_OtherPointer;
+ return 1;
+ }
+
+ return 0;
+}
+
+static int
+parse_regnum(char *s)
+{
+ if ((s[1] == 'R') || (s[1] == 'r')) {
+ int regnum;
+
+ if (s[2] == '\0')
+ return -1;
+
+ /* skip the $R part and call atoi on the number */
+ regnum = atoi(s + 2);
+ if ((regnum >= 0) && (regnum < NREGS))
+ return regnum;
+ else
+ return -1;
+ } else {
+ int i;
+
+ for (i = 0; i < NREGS ; i++)
+ if (strcasecmp(s + 1, lisp_register_names[i]) == 0)
+#ifdef __i386__
+ return i*2;
+#else
+ return i;
+#endif
+
+ return -1;
+ }
+}
+
+lispobj parse_lispobj(ptr)
+char **ptr;
+{
+ char *token = parse_token(ptr);
+ long pointer;
+ lispobj result;
+
+ if (token == NULL) {
+ printf("expected an object\n");
+ throw_to_monitor();
+ } else if (token[0] == '$') {
+ if (isalpha(token[1])) {
+ int free;
+ int regnum;
+ os_context_t *context;
+
+ free = SymbolValue(FREE_INTERRUPT_CONTEXT_INDEX)>>2;
+
+ if (free == 0) {
+ printf("Variable ``%s'' is not valid -- there is no current interrupt context.\n", token);
+ throw_to_monitor();
+ }
+
+ context = lisp_interrupt_contexts[free - 1];
+
+ regnum = parse_regnum(token);
+ if (regnum < 0) {
+ printf("bogus register: ``%s''\n", token);
+ throw_to_monitor();
+ }
+
+ result = *os_context_register_addr(context, regnum);
+ } else if (!lookup_variable(token+1, &result)) {
+ printf("unknown variable: ``%s''\n", token);
+ throw_to_monitor();
+ }
+ } else if (token[0] == '@') {
+ if (string_to_long(token+1, &pointer)) {
+ pointer &= ~3;
+ if (is_valid_lisp_addr((os_vm_address_t)pointer))
+ result = *(lispobj *)pointer;
+ else {
+ printf("invalid Lisp-level address: ``%s''\n", token+1);
+ throw_to_monitor();
+ }
+ }
+ else {
+ printf("invalid address: ``%s''\n", token+1);
+ throw_to_monitor();
+ }
+ }
+ else if (string_to_long(token, (long *)&result))
+ ;
+ else if (lookup_symbol(token, &result))
+ ;
+ else {
+ printf("invalid Lisp object: ``%s''\n", token);
+ throw_to_monitor();
+ }
+
+ return result;
+}
--- /dev/null
+/*
+ * This software is part of the SBCL system. See the README file for
+ * more information.
+ *
+ * This software is derived from the CMU CL system, which was
+ * written at Carnegie Mellon University and released into the
+ * public domain. The software is in the public domain and is
+ * provided with absolutely no warranty. See the COPYING and CREDITS
+ * files for more information.
+ */
+
+/*
+ * $Header$
+ */
+
+/* All parse routines take a char ** as their only argument */
+extern boolean more_p(char **ptr);
+extern char *parse_token(char **ptr);
+extern lispobj parse_lispobj(char **ptr);
+extern char *parse_addr(char **ptr);
+extern long parse_number(char **ptr);
--- /dev/null
+/* code for low-level debugging output */
+
+/*
+ * This software is part of the SBCL system. See the README file for
+ * more information.
+ *
+ * This software is derived from the CMU CL system, which was
+ * written at Carnegie Mellon University and released into the
+ * public domain. The software is in the public domain and is
+ * provided with absolutely no warranty. See the COPYING and CREDITS
+ * files for more information.
+ */
+
+/*
+ * $Header$
+ */
+
+/*
+ * FIXME:
+ * 1. Ordinary users won't get much out of this code, so it shouldn't
+ * be compiled into the ordinary build of the system. Probably it
+ * should be made conditional on the SB-SHOW target feature.
+ * 2. Some of the code in here (subtype_Names[] and the various
+ * foo_slots[], at least) is deeply broken, depending on fixed
+ * (and already out-of-date) values in sbcl.h.
+ */
+
+#include <stdio.h>
+
+#include "print.h"
+#include "runtime.h"
+#include "sbcl.h"
+#include "monitor.h"
+#include "vars.h"
+#include "os.h"
+
+static int max_lines = 20, cur_lines = 0;
+static int max_depth = 5, brief_depth = 2, cur_depth = 0;
+static int max_length = 5;
+static boolean dont_descend = 0, skip_newline = 0;
+static cur_clock = 0;
+
+static void print_obj(char *prefix, lispobj obj);
+
+#define NEWLINE if (continue_p(1)) newline(NULL); else return;
+
+char *lowtag_Names[] = {
+ "even fixnum",
+ "function pointer",
+ "other immediate [0]",
+ "list pointer",
+ "odd fixnum",
+ "instance pointer",
+ "other immediate [1]",
+ "other pointer"
+};
+
+/* FIXME: Yikes! This table implicitly depends on the values in sbcl.h,
+ * but doesn't actually depend on them, so if they change, it gets
+ * all broken. We should either get rid of it or
+ * rewrite the code so that it's cleanly initialized by gc_init_tables[]
+ * in a way which varies correctly with the values in sbcl.h. */
+char *subtype_Names[] = {
+ "unused 0",
+ "unused 1",
+ "bignum",
+ "ratio",
+ "single float",
+ "double float",
+#ifdef type_LongFloat
+ "long float",
+#endif
+ "complex",
+#ifdef type_ComplexSingleFloat
+ "complex single float",
+#endif
+#ifdef type_ComplexDoubleFloat
+ "complex double float",
+#endif
+#ifdef type_ComplexLongFloat
+ "complex long float",
+#endif
+ "simple-array",
+ "simple-string",
+ "simple-bit-vector",
+ "simple-vector",
+ "(simple-array (unsigned-byte 2) (*))",
+ "(simple-array (unsigned-byte 4) (*))",
+ "(simple-array (unsigned-byte 8) (*))",
+ "(simple-array (unsigned-byte 16) (*))",
+ "(simple-array (unsigned-byte 32) (*))",
+#ifdef type_SimpleArraySignedByte8
+ "(simple-array (signed-byte 8) (*))",
+#endif
+#ifdef type_SimpleArraySignedByte16
+ "(simple-array (signed-byte 16) (*))",
+#endif
+#ifdef type_SimpleArraySignedByte30
+ "(simple-array fixnum (*))",
+#endif
+#ifdef type_SimpleArraySignedByte32
+ "(simple-array (signed-byte 32) (*))",
+#endif
+ "(simple-array single-float (*))",
+ "(simple-array double-float (*))",
+#ifdef type_SimpleArrayLongFloat
+ "(simple-array long-float (*))",
+#endif
+#ifdef type_SimpleArrayComplexSingleFloat
+ "(simple-array (complex single-float) (*))",
+#endif
+#ifdef type_SimpleArrayComplexDoubleFloat
+ "(simple-array (complex double-float) (*))",
+#endif
+#ifdef type_SimpleArrayComplexLongFloat
+ "(simple-array (complex long-float) (*))",
+#endif
+ "complex-string",
+ "complex-bit-vector",
+ "(array * (*))",
+ "array",
+ "code header",
+ "function header",
+ "closure header",
+ "funcallable-instance header",
+ "unused function header 1",
+ "unused function header 2",
+ "unused function header 3",
+ "closure function header",
+ "return PC header",
+ "value cell header",
+ "symbol header",
+ "character",
+ "SAP",
+ "unbound marker",
+ "weak pointer",
+ "instance header",
+ "fdefn"
+};
+
+static void indent(int in)
+{
+ static char *spaces = " ";
+
+ while (in > 64) {
+ fputs(spaces, stdout);
+ in -= 64;
+ }
+ if (in != 0)
+ fputs(spaces + 64 - in, stdout);
+}
+
+static boolean continue_p(boolean newline)
+{
+ char buffer[256];
+
+ if (cur_depth >= max_depth || dont_descend)
+ return 0;
+
+ if (newline) {
+ if (skip_newline)
+ skip_newline = 0;
+ else
+ putchar('\n');
+
+ if (cur_lines >= max_lines) {
+ printf("More? [y] ");
+ fflush(stdout);
+
+ fgets(buffer, sizeof(buffer), stdin);
+
+ if (buffer[0] == 'n' || buffer[0] == 'N')
+ throw_to_monitor();
+ else
+ cur_lines = 0;
+ }
+ }
+
+ return 1;
+}
+
+static void newline(char *label)
+{
+ cur_lines++;
+ if (label != NULL)
+ fputs(label, stdout);
+ putchar('\t');
+ indent(cur_depth * 2);
+}
+
+
+static void brief_fixnum(lispobj obj)
+{
+#ifndef alpha
+ printf("%ld", ((long)obj)>>2);
+#else
+ printf("%d", ((s32)obj)>>2);
+#endif
+}
+
+static void print_fixnum(lispobj obj)
+{
+#ifndef alpha
+ printf(": %ld", ((long)obj)>>2);
+#else
+ printf(": %d", ((s32)obj)>>2);
+#endif
+}
+
+static void brief_otherimm(lispobj obj)
+{
+ int type, c, idx;
+ char buffer[10];
+
+ type = TypeOf(obj);
+ switch (type) {
+ case type_BaseChar:
+ c = (obj>>8)&0xff;
+ switch (c) {
+ case '\0':
+ printf("#\\Null");
+ break;
+ case '\n':
+ printf("#\\Newline");
+ break;
+ case '\b':
+ printf("#\\Backspace");
+ break;
+ case '\177':
+ printf("#\\Delete");
+ break;
+ default:
+ strcpy(buffer, "#\\");
+ if (c >= 128) {
+ strcat(buffer, "m-");
+ c -= 128;
+ }
+ if (c < 32) {
+ strcat(buffer, "c-");
+ c += '@';
+ }
+ printf("%s%c", buffer, c);
+ break;
+ }
+ break;
+
+ case type_UnboundMarker:
+ printf("<unbound marker>");
+ break;
+
+ default:
+ idx = type >> 2;
+ if (idx < (sizeof(subtype_Names) / sizeof(char *)))
+ printf("%s", subtype_Names[idx]);
+ else
+ printf("unknown type (0x%0x)", type);
+ break;
+ }
+}
+
+static void print_otherimm(lispobj obj)
+{
+ int type, idx;
+
+ type = TypeOf(obj);
+ idx = type >> 2;
+
+ if (idx < (sizeof(subtype_Names) / sizeof(char *)))
+ printf(", %s", subtype_Names[idx]);
+ else
+ printf(", unknown type (0x%0x)", type);
+
+ switch (TypeOf(obj)) {
+ case type_BaseChar:
+ printf(": ");
+ brief_otherimm(obj);
+ break;
+
+ case type_Sap:
+ case type_UnboundMarker:
+ break;
+
+ default:
+ printf(": data=%ld", (obj>>8)&0xffffff);
+ break;
+ }
+}
+
+static void brief_list(lispobj obj)
+{
+ int space = 0;
+ int length = 0;
+
+ if (!is_valid_lisp_addr((os_vm_address_t)obj))
+ printf("(invalid Lisp-level address)");
+ else if (obj == NIL)
+ printf("NIL");
+ else {
+ putchar('(');
+ while (LowtagOf(obj) == type_ListPointer) {
+ struct cons *cons = (struct cons *)PTR(obj);
+
+ if (space)
+ putchar(' ');
+ if (++length >= max_length) {
+ printf("...");
+ obj = NIL;
+ break;
+ }
+ print_obj(NULL, cons->car);
+ obj = cons->cdr;
+ space = 1;
+ if (obj == NIL)
+ break;
+ }
+ if (obj != NIL) {
+ printf(" . ");
+ print_obj(NULL, obj);
+ }
+ putchar(')');
+ }
+}
+
+static void print_list(lispobj obj)
+{
+ if (!is_valid_lisp_addr((os_vm_address_t)obj)) {
+ printf("(invalid address)");
+ } else if (obj == NIL) {
+ printf(" (NIL)");
+ } else {
+ struct cons *cons = (struct cons *)PTR(obj);
+
+ print_obj("car: ", cons->car);
+ print_obj("cdr: ", cons->cdr);
+ }
+}
+
+static void brief_struct(lispobj obj)
+{
+ printf("#<ptr to 0x%08lx instance>",
+ ((struct instance *)PTR(obj))->slots[0]);
+}
+
+static void print_struct(lispobj obj)
+{
+ struct instance *instance = (struct instance *)PTR(obj);
+ int i;
+ char buffer[16];
+ print_obj("type: ", ((struct instance *)PTR(obj))->slots[0]);
+ for (i = 1; i < HeaderValue(instance->header); i++) {
+ sprintf(buffer, "slot %d: ", i);
+ print_obj(buffer, instance->slots[i]);
+ }
+}
+
+static void brief_otherptr(lispobj obj)
+{
+ lispobj *ptr, header;
+ int type;
+ struct symbol *symbol;
+ struct vector *vector;
+ char *charptr;
+
+ ptr = (lispobj *) PTR(obj);
+
+ if (!is_valid_lisp_addr((os_vm_address_t)obj)) {
+ printf("(invalid address)");
+ return;
+ }
+
+ header = *ptr;
+ type = TypeOf(header);
+ switch (type) {
+ case type_SymbolHeader:
+ symbol = (struct symbol *)ptr;
+ vector = (struct vector *)PTR(symbol->name);
+ for (charptr = (char *)vector->data; *charptr != '\0'; charptr++) {
+ if (*charptr == '"')
+ putchar('\\');
+ putchar(*charptr);
+ }
+ break;
+
+ case type_SimpleString:
+ vector = (struct vector *)ptr;
+ putchar('"');
+ for (charptr = (char *)vector->data; *charptr != '\0'; charptr++) {
+ if (*charptr == '"')
+ putchar('\\');
+ putchar(*charptr);
+ }
+ putchar('"');
+ break;
+
+ default:
+ printf("#<ptr to ");
+ brief_otherimm(header);
+ putchar('>');
+ }
+}
+
+static void print_slots(char **slots, int count, lispobj *ptr)
+{
+ while (count-- > 0) {
+ if (*slots) {
+ print_obj(*slots++, *ptr++);
+ } else {
+ print_obj("???: ", *ptr++);
+ }
+ }
+}
+
+/* FIXME: Yikes again! This, like subtype_Names[], needs to depend
+ * on the values in sbcl.h. */
+static char *symbol_slots[] = {"value: ", "unused: ",
+ "plist: ", "name: ", "package: ", NULL};
+static char *ratio_slots[] = {"numer: ", "denom: ", NULL};
+static char *complex_slots[] = {"real: ", "imag: ", NULL};
+static char *code_slots[] = {"words: ", "entry: ", "debug: ", NULL};
+static char *fn_slots[] = {"self: ", "next: ", "name: ", "arglist: ", "type: ", NULL};
+static char *closure_slots[] = {"fn: ", NULL};
+static char *funcallable_instance_slots[] = {"fn: ", "lexenv: ", "layout: ", NULL};
+static char *weak_pointer_slots[] = {"value: ", NULL};
+static char *fdefn_slots[] = {"name: ", "function: ", "raw_addr: ", NULL};
+static char *value_cell_slots[] = {"value: ", NULL};
+
+static void print_otherptr(lispobj obj)
+{
+ if (!is_valid_lisp_addr((os_vm_address_t)obj)) {
+ printf("(invalid address)");
+ } else {
+#ifndef alpha
+ lispobj *ptr;
+ unsigned long header;
+ unsigned long length;
+#else
+ u32 *ptr;
+ u32 header;
+ u32 length;
+#endif
+ int count, type, index;
+ char *cptr, buffer[16];
+
+ ptr = (lispobj*) PTR(obj);
+ if (ptr == NULL) {
+ printf(" (NULL Pointer)");
+ return;
+ }
+
+ header = *ptr++;
+ length = (*ptr) >> 2;
+ count = header>>8;
+ type = TypeOf(header);
+
+ print_obj("header: ", header);
+ if (LowtagOf(header) != type_OtherImmediate0 && LowtagOf(header) != type_OtherImmediate1) {
+ NEWLINE;
+ printf("(invalid header object)");
+ return;
+ }
+
+ switch (type) {
+ case type_Bignum:
+ ptr += count;
+ NEWLINE;
+ printf("0x");
+ while (count-- > 0)
+ printf("%08lx", *--ptr);
+ break;
+
+ case type_Ratio:
+ print_slots(ratio_slots, count, ptr);
+ break;
+
+ case type_Complex:
+ print_slots(complex_slots, count, ptr);
+ break;
+
+ case type_SymbolHeader:
+ print_slots(symbol_slots, count, ptr);
+ break;
+
+ case type_SingleFloat:
+ NEWLINE;
+ printf("%g", ((struct single_float *)PTR(obj))->value);
+ break;
+
+ case type_DoubleFloat:
+ NEWLINE;
+ printf("%g", ((struct double_float *)PTR(obj))->value);
+ break;
+
+#ifdef type_LongFloat
+ case type_LongFloat:
+ NEWLINE;
+ printf("%Lg", ((struct long_float *)PTR(obj))->value);
+ break;
+#endif
+
+#ifdef type_ComplexSingleFloat
+ case type_ComplexSingleFloat:
+ NEWLINE;
+ printf("%g", ((struct complex_single_float *)PTR(obj))->real);
+ NEWLINE;
+ printf("%g", ((struct complex_single_float *)PTR(obj))->imag);
+ break;
+#endif
+
+#ifdef type_ComplexDoubleFloat
+ case type_ComplexDoubleFloat:
+ NEWLINE;
+ printf("%g", ((struct complex_double_float *)PTR(obj))->real);
+ NEWLINE;
+ printf("%g", ((struct complex_double_float *)PTR(obj))->imag);
+ break;
+#endif
+
+#ifdef type_ComplexLongFloat
+ case type_ComplexLongFloat:
+ NEWLINE;
+ printf("%Lg", ((struct complex_long_float *)PTR(obj))->real);
+ NEWLINE;
+ printf("%Lg", ((struct complex_long_float *)PTR(obj))->imag);
+ break;
+#endif
+
+ case type_SimpleString:
+ NEWLINE;
+ cptr = (char *)(ptr+1);
+ putchar('"');
+ while (length-- > 0)
+ putchar(*cptr++);
+ putchar('"');
+ break;
+
+ case type_SimpleVector:
+ case type_InstanceHeader:
+ NEWLINE;
+ printf("length = %ld", length);
+ ptr++;
+ index = 0;
+ while (length-- > 0) {
+ sprintf(buffer, "%d: ", index++);
+ print_obj(buffer, *ptr++);
+ }
+ break;
+
+ case type_SimpleArray:
+ case type_SimpleBitVector:
+ case type_SimpleArrayUnsignedByte2:
+ case type_SimpleArrayUnsignedByte4:
+ case type_SimpleArrayUnsignedByte8:
+ case type_SimpleArrayUnsignedByte16:
+ case type_SimpleArrayUnsignedByte32:
+#ifdef type_SimpleArraySignedByte8
+ case type_SimpleArraySignedByte8:
+#endif
+#ifdef type_SimpleArraySignedByte16
+ case type_SimpleArraySignedByte16:
+#endif
+#ifdef type_SimpleArraySignedByte30
+ case type_SimpleArraySignedByte30:
+#endif
+#ifdef type_SimpleArraySignedByte32
+ case type_SimpleArraySignedByte32:
+#endif
+ case type_SimpleArraySingleFloat:
+ case type_SimpleArrayDoubleFloat:
+#ifdef type_SimpleArrayLongFloat
+ case type_SimpleArrayLongFloat:
+#endif
+#ifdef type_SimpleArrayComplexSingleFloat
+ case type_SimpleArrayComplexSingleFloat:
+#endif
+#ifdef type_SimpleArrayComplexDoubleFloat
+ case type_SimpleArrayComplexDoubleFloat:
+#endif
+#ifdef type_SimpleArrayComplexLongFloat
+ case type_SimpleArrayComplexLongFloat:
+#endif
+ case type_ComplexString:
+ case type_ComplexBitVector:
+ case type_ComplexVector:
+ case type_ComplexArray:
+ break;
+
+ case type_CodeHeader:
+ print_slots(code_slots, count-1, ptr);
+ break;
+
+ case type_FunctionHeader:
+ case type_ClosureFunctionHeader:
+ print_slots(fn_slots, 5, ptr);
+ break;
+
+ case type_ReturnPcHeader:
+ print_obj("code: ", obj - (count * 4));
+ break;
+
+ case type_ClosureHeader:
+ print_slots(closure_slots, count, ptr);
+ break;
+
+ case type_FuncallableInstanceHeader:
+ print_slots(funcallable_instance_slots, count, ptr);
+ break;
+
+ case type_ValueCellHeader:
+ print_slots(value_cell_slots, 1, ptr);
+ break;
+
+ case type_Sap:
+ NEWLINE;
+#ifndef alpha
+ printf("0x%08lx", *ptr);
+#else
+ printf("0x%016lx", *(long*)(ptr+1));
+#endif
+ break;
+
+ case type_WeakPointer:
+ print_slots(weak_pointer_slots, 1, ptr);
+ break;
+
+ case type_BaseChar:
+ case type_UnboundMarker:
+ NEWLINE;
+ printf("pointer to an immediate?");
+ break;
+
+ case type_Fdefn:
+ print_slots(fdefn_slots, count, ptr);
+ break;
+
+ default:
+ NEWLINE;
+ printf("Unknown header object?");
+ break;
+ }
+ }
+}
+
+static void print_obj(char *prefix, lispobj obj)
+{
+ static void (*verbose_fns[])(lispobj obj)
+ = {print_fixnum, print_otherptr, print_otherimm, print_list,
+ print_fixnum, print_struct, print_otherimm, print_otherptr};
+ static void (*brief_fns[])(lispobj obj)
+ = {brief_fixnum, brief_otherptr, brief_otherimm, brief_list,
+ brief_fixnum, brief_struct, brief_otherimm, brief_otherptr};
+ int type = LowtagOf(obj);
+ struct var *var = lookup_by_obj(obj);
+ char buffer[256];
+ boolean verbose = cur_depth < brief_depth;
+
+
+ if (!continue_p(verbose))
+ return;
+
+ if (var != NULL && var_clock(var) == cur_clock)
+ dont_descend = 1;
+
+ if (var == NULL && (obj & type_FunctionPointer & type_ListPointer & type_InstancePointer & type_OtherPointer) != 0)
+ var = define_var(NULL, obj, 0);
+
+ if (var != NULL)
+ var_setclock(var, cur_clock);
+
+ cur_depth++;
+ if (verbose) {
+ if (var != NULL) {
+ sprintf(buffer, "$%s=", var_name(var));
+ newline(buffer);
+ }
+ else
+ newline(NULL);
+ printf("%s0x%08lx: ", prefix, obj);
+ if (cur_depth < brief_depth) {
+ fputs(lowtag_Names[type], stdout);
+ (*verbose_fns[type])(obj);
+ }
+ else
+ (*brief_fns[type])(obj);
+ }
+ else {
+ if (dont_descend)
+ printf("$%s", var_name(var));
+ else {
+ if (var != NULL)
+ printf("$%s=", var_name(var));
+ (*brief_fns[type])(obj);
+ }
+ }
+ cur_depth--;
+ dont_descend = 0;
+}
+
+void reset_printer()
+{
+ cur_clock++;
+ cur_lines = 0;
+ dont_descend = 0;
+}
+
+void print(lispobj obj)
+{
+ skip_newline = 1;
+ cur_depth = 0;
+ max_depth = 5;
+ max_lines = 20;
+
+ print_obj("", obj);
+
+ putchar('\n');
+}
+
+void brief_print(lispobj obj)
+{
+ skip_newline = 1;
+ cur_depth = 0;
+ max_depth = 1;
+ max_lines = 5000;
+
+ print_obj("", obj);
+ putchar('\n');
+}
--- /dev/null
+/*
+ * This software is part of the SBCL system. See the README file for
+ * more information.
+ *
+ * This software is derived from the CMU CL system, which was
+ * written at Carnegie Mellon University and released into the
+ * public domain. The software is in the public domain and is
+ * provided with absolutely no warranty. See the COPYING and CREDITS
+ * files for more information.
+ */
+
+/*
+ * $Header$
+ */
+
+#ifndef _PRINT_H_
+#define _PRINT_H_
+
+#include "runtime.h"
+
+extern char *lowtag_Names[], *subtype_Names[];
+
+extern void print(lispobj obj);
+extern void brief_print(lispobj obj);
+extern void reset_printer(void);
+
+#endif
--- /dev/null
+/*
+ * C-level stuff to implement Lisp-level PURIFY
+ */
+
+/*
+ * This software is part of the SBCL system. See the README file for
+ * more information.
+ *
+ * This software is derived from the CMU CL system, which was
+ * written at Carnegie Mellon University and released into the
+ * public domain. The software is in the public domain and is
+ * provided with absolutely no warranty. See the COPYING and CREDITS
+ * files for more information.
+ */
+
+/*
+ * $Header$
+ */
+
+#include <stdio.h>
+#include <sys/types.h>
+#include <stdlib.h>
+
+#include "runtime.h"
+#include "os.h"
+#include "sbcl.h"
+#include "globals.h"
+#include "validate.h"
+#include "interrupt.h"
+#include "purify.h"
+#include "interr.h"
+#ifdef GENCGC
+#include "gencgc.h"
+#endif
+
+#undef PRINTNOISE
+
+#if defined(ibmrt) || defined(__i386__)
+static lispobj *current_dynamic_space_free_pointer;
+#endif
+
+#define gc_abort() \
+ lose("GC invariant lost, file \"%s\", line %d", __FILE__, __LINE__)
+
+#if 1
+#define gc_assert(ex) do { \
+ if (!(ex)) gc_abort(); \
+} while (0)
+#else
+#define gc_assert(ex)
+#endif
+
+\f
+/* These hold the original end of the read_only and static spaces so
+ * we can tell what are forwarding pointers. */
+
+static lispobj *read_only_end, *static_end;
+
+static lispobj *read_only_free, *static_free;
+
+static lispobj *pscav(lispobj *addr, int nwords, boolean constant);
+
+#define LATERBLOCKSIZE 1020
+#define LATERMAXCOUNT 10
+
+static struct later {
+ struct later *next;
+ union {
+ lispobj *ptr;
+ int count;
+ } u[LATERBLOCKSIZE];
+} *later_blocks = NULL;
+static int later_count = 0;
+
+#define CEILING(x,y) (((x) + ((y) - 1)) & (~((y) - 1)))
+#define NWORDS(x,y) (CEILING((x),(y)) / (y))
+
+#ifdef sparc
+#define RAW_ADDR_OFFSET 0
+#else
+#define RAW_ADDR_OFFSET (6*sizeof(lispobj) - type_FunctionPointer)
+#endif
+\f
+static boolean
+forwarding_pointer_p(lispobj obj)
+{
+ lispobj *ptr;
+
+ ptr = (lispobj *)obj;
+
+ return ((static_end <= ptr && ptr <= static_free) ||
+ (read_only_end <= ptr && ptr <= read_only_free));
+}
+
+static boolean
+dynamic_pointer_p(lispobj ptr)
+{
+#ifndef __i386__
+ return (ptr >= (lispobj)dynamic_0_space);
+#else
+ /* Be more conservative, and remember, this is a maybe. */
+ return (ptr >= (lispobj)current_dynamic_space
+ &&
+ ptr < (lispobj)current_dynamic_space_free_pointer);
+#endif
+}
+
+\f
+#ifdef __i386__
+
+#ifdef WANT_CGC
+/* original x86/CGC stack scavenging code by Paul Werkowski */
+
+static int
+maybe_can_move_p(lispobj thing)
+{
+ lispobj *thingp,header;
+ if (dynamic_pointer_p(thing)) { /* in dynamic space */
+ thingp = (lispobj*)PTR(thing);
+ header = *thingp;
+ if(Pointerp(header) && forwarding_pointer_p(header))
+ return -1; /* must change it */
+ if(LowtagOf(thing) == type_ListPointer)
+ return type_ListPointer; /* can we check this somehow */
+ else if (thing & 3) { /* not fixnum */
+ int kind = TypeOf(header);
+ /* printf(" %x %x",header,kind); */
+ switch (kind) { /* something with a header */
+ case type_Bignum:
+ case type_SingleFloat:
+ case type_DoubleFloat:
+#ifdef type_LongFloat
+ case type_LongFloat:
+#endif
+ case type_Sap:
+ case type_SimpleVector:
+ case type_SimpleString:
+ case type_SimpleBitVector:
+ case type_SimpleArrayUnsignedByte2:
+ case type_SimpleArrayUnsignedByte4:
+ case type_SimpleArrayUnsignedByte8:
+ case type_SimpleArrayUnsignedByte16:
+ case type_SimpleArrayUnsignedByte32:
+#ifdef type_SimpleArraySignedByte8
+ case type_SimpleArraySignedByte8:
+#endif
+#ifdef type_SimpleArraySignedByte16
+ case type_SimpleArraySignedByte16:
+#endif
+#ifdef type_SimpleArraySignedByte30
+ case type_SimpleArraySignedByte30:
+#endif
+#ifdef type_SimpleArraySignedByte32
+ case type_SimpleArraySignedByte32:
+#endif
+ case type_SimpleArraySingleFloat:
+ case type_SimpleArrayDoubleFloat:
+#ifdef type_SimpleArrayLongFloat
+ case type_SimpleArrayLongFloat:
+#endif
+#ifdef type_SimpleArrayComplexSingleFloat
+ case type_SimpleArrayComplexSingleFloat:
+#endif
+#ifdef type_SimpleArrayComplexDoubleFloat
+ case type_SimpleArrayComplexDoubleFloat:
+#endif
+#ifdef type_SimpleArrayComplexLongFloat
+ case type_SimpleArrayComplexLongFloat:
+#endif
+ case type_CodeHeader:
+ case type_FunctionHeader:
+ case type_ClosureFunctionHeader:
+ case type_ReturnPcHeader:
+ case type_ClosureHeader:
+ case type_FuncallableInstanceHeader:
+ case type_InstanceHeader:
+ case type_ValueCellHeader:
+ case type_ByteCodeFunction:
+ case type_ByteCodeClosure:
+ case type_WeakPointer:
+ case type_Fdefn:
+ return kind;
+ break;
+ default:
+ return 0;
+ }}}
+ return 0;
+}
+
+static int pverbose=0;
+#define PVERBOSE pverbose
+static void
+carefully_pscav_stack(lispobj*lowaddr, lispobj*base)
+{
+ lispobj*sp = lowaddr;
+ while (sp < base)
+ { int k;
+ lispobj thing = *sp;
+ if((unsigned)thing & 0x3) /* may be pointer */
+ {
+ /* need to check for valid float/double? */
+ k = maybe_can_move_p(thing);
+ if(PVERBOSE)printf("%8x %8x %d\n",sp, thing, k);
+ if(k)
+ pscav(sp, 1, 0);
+ }
+ sp++;
+ }
+}
+#endif
+
+#ifdef GENCGC
+/*
+ * Enhanced x86/GENCGC stack scavenging by Douglas Crosher.
+ *
+ * Scavenging the stack on the i386 is problematic due to conservative
+ * roots and raw return addresses. Here it is handled in two passes:
+ * the first pass runs before any objects are moved and tries to
+ * identify valid pointers and return address on the stack, the second
+ * pass scavenges these.
+ */
+
+static unsigned pointer_filter_verbose = 0;
+
+static int
+valid_dynamic_space_pointer(lispobj *pointer, lispobj *start_addr)
+{
+ /* If it's not a return address then it needs to be a valid Lisp
+ * pointer. */
+ if (!Pointerp((lispobj)pointer))
+ return 0;
+
+ /* Check that the object pointed to is consistent with the pointer
+ * low tag. */
+ switch (LowtagOf((lispobj)pointer)) {
+ case type_FunctionPointer:
+ /* Start_addr should be the enclosing code object, or a closure
+ * header. */
+ switch (TypeOf(*start_addr)) {
+ case type_CodeHeader:
+ /* This case is probably caught above. */
+ break;
+ case type_ClosureHeader:
+ case type_FuncallableInstanceHeader:
+ case type_ByteCodeFunction:
+ case type_ByteCodeClosure:
+ if ((int)pointer != ((int)start_addr+type_FunctionPointer)) {
+ if (pointer_filter_verbose) {
+ fprintf(stderr,"*Wf2: %x %x %x\n", pointer, start_addr, *start_addr);
+ }
+ return 0;
+ }
+ break;
+ default:
+ if (pointer_filter_verbose) {
+ fprintf(stderr,"*Wf3: %x %x %x\n", pointer, start_addr, *start_addr);
+ }
+ return 0;
+ }
+ break;
+ case type_ListPointer:
+ if ((int)pointer != ((int)start_addr+type_ListPointer)) {
+ if (pointer_filter_verbose)
+ fprintf(stderr,"*Wl1: %x %x %x\n", pointer, start_addr, *start_addr);
+ return 0;
+ }
+ /* Is it plausible cons? */
+ if((Pointerp(start_addr[0])
+ || ((start_addr[0] & 3) == 0) /* fixnum */
+ || (TypeOf(start_addr[0]) == type_BaseChar)
+ || (TypeOf(start_addr[0]) == type_UnboundMarker))
+ && (Pointerp(start_addr[1])
+ || ((start_addr[1] & 3) == 0) /* fixnum */
+ || (TypeOf(start_addr[1]) == type_BaseChar)
+ || (TypeOf(start_addr[1]) == type_UnboundMarker))) {
+ break;
+ } else {
+ if (pointer_filter_verbose) {
+ fprintf(stderr,"*Wl2: %x %x %x\n", pointer, start_addr, *start_addr);
+ }
+ return 0;
+ }
+ case type_InstancePointer:
+ if ((int)pointer != ((int)start_addr+type_InstancePointer)) {
+ if (pointer_filter_verbose) {
+ fprintf(stderr,"*Wi1: %x %x %x\n", pointer, start_addr, *start_addr);
+ }
+ return 0;
+ }
+ if (TypeOf(start_addr[0]) != type_InstanceHeader) {
+ if (pointer_filter_verbose) {
+ fprintf(stderr,"*Wi2: %x %x %x\n", pointer, start_addr, *start_addr);
+ }
+ return 0;
+ }
+ break;
+ case type_OtherPointer:
+ if ((int)pointer != ((int)start_addr+type_OtherPointer)) {
+ if (pointer_filter_verbose) {
+ fprintf(stderr,"*Wo1: %x %x %x\n", pointer, start_addr, *start_addr);
+ }
+ return 0;
+ }
+ /* Is it plausible? Not a cons. X should check the headers. */
+ if(Pointerp(start_addr[0]) || ((start_addr[0] & 3) == 0)) {
+ if (pointer_filter_verbose) {
+ fprintf(stderr,"*Wo2: %x %x %x\n", pointer, start_addr, *start_addr);
+ }
+ return 0;
+ }
+ switch (TypeOf(start_addr[0])) {
+ case type_UnboundMarker:
+ case type_BaseChar:
+ if (pointer_filter_verbose) {
+ fprintf(stderr,"*Wo3: %x %x %x\n", pointer, start_addr, *start_addr);
+ }
+ return 0;
+
+ /* only pointed to by function pointers? */
+ case type_ClosureHeader:
+ case type_FuncallableInstanceHeader:
+ case type_ByteCodeFunction:
+ case type_ByteCodeClosure:
+ if (pointer_filter_verbose) {
+ fprintf(stderr,"*Wo4: %x %x %x\n", pointer, start_addr, *start_addr);
+ }
+ return 0;
+
+ case type_InstanceHeader:
+ if (pointer_filter_verbose) {
+ fprintf(stderr,"*Wo5: %x %x %x\n", pointer, start_addr, *start_addr);
+ }
+ return 0;
+
+ /* the valid other immediate pointer objects */
+ case type_SimpleVector:
+ case type_Ratio:
+ case type_Complex:
+#ifdef type_ComplexSingleFloat
+ case type_ComplexSingleFloat:
+#endif
+#ifdef type_ComplexDoubleFloat
+ case type_ComplexDoubleFloat:
+#endif
+#ifdef type_ComplexLongFloat
+ case type_ComplexLongFloat:
+#endif
+ case type_SimpleArray:
+ case type_ComplexString:
+ case type_ComplexBitVector:
+ case type_ComplexVector:
+ case type_ComplexArray:
+ case type_ValueCellHeader:
+ case type_SymbolHeader:
+ case type_Fdefn:
+ case type_CodeHeader:
+ case type_Bignum:
+ case type_SingleFloat:
+ case type_DoubleFloat:
+#ifdef type_LongFloat
+ case type_LongFloat:
+#endif
+ case type_SimpleString:
+ case type_SimpleBitVector:
+ case type_SimpleArrayUnsignedByte2:
+ case type_SimpleArrayUnsignedByte4:
+ case type_SimpleArrayUnsignedByte8:
+ case type_SimpleArrayUnsignedByte16:
+ case type_SimpleArrayUnsignedByte32:
+#ifdef type_SimpleArraySignedByte8
+ case type_SimpleArraySignedByte8:
+#endif
+#ifdef type_SimpleArraySignedByte16
+ case type_SimpleArraySignedByte16:
+#endif
+#ifdef type_SimpleArraySignedByte30
+ case type_SimpleArraySignedByte30:
+#endif
+#ifdef type_SimpleArraySignedByte32
+ case type_SimpleArraySignedByte32:
+#endif
+ case type_SimpleArraySingleFloat:
+ case type_SimpleArrayDoubleFloat:
+#ifdef type_SimpleArrayLongFloat
+ case type_SimpleArrayLongFloat:
+#endif
+#ifdef type_SimpleArrayComplexSingleFloat
+ case type_SimpleArrayComplexSingleFloat:
+#endif
+#ifdef type_SimpleArrayComplexDoubleFloat
+ case type_SimpleArrayComplexDoubleFloat:
+#endif
+#ifdef type_SimpleArrayComplexLongFloat
+ case type_SimpleArrayComplexLongFloat:
+#endif
+ case type_Sap:
+ case type_WeakPointer:
+ break;
+
+ default:
+ if (pointer_filter_verbose) {
+ fprintf(stderr,"*Wo6: %x %x %x\n", pointer, start_addr, *start_addr);
+ }
+ return 0;
+ }
+ break;
+ default:
+ if (pointer_filter_verbose) {
+ fprintf(stderr,"*W?: %x %x %x\n", pointer, start_addr, *start_addr);
+ }
+ return 0;
+ }
+
+ /* looks good */
+ return 1;
+}
+
+#define MAX_STACK_POINTERS 256
+lispobj *valid_stack_locations[MAX_STACK_POINTERS];
+unsigned int num_valid_stack_locations;
+
+#define MAX_STACK_RETURN_ADDRESSES 128
+lispobj *valid_stack_ra_locations[MAX_STACK_RETURN_ADDRESSES];
+lispobj *valid_stack_ra_code_objects[MAX_STACK_RETURN_ADDRESSES];
+unsigned int num_valid_stack_ra_locations;
+
+/* Identify valid stack slots. */
+static void
+setup_i386_stack_scav(lispobj *lowaddr, lispobj *base)
+{
+ lispobj *sp = lowaddr;
+ num_valid_stack_locations = 0;
+ num_valid_stack_ra_locations = 0;
+ for (sp = lowaddr; sp < base; sp++) {
+ lispobj thing = *sp;
+ /* Find the object start address */
+ lispobj *start_addr = search_dynamic_space((void *)thing);
+ if (start_addr) {
+ /* We need to allow raw pointers into Code objects for return
+ * addresses. This will also pick up pointers to functions in code
+ * objects. */
+ if (TypeOf(*start_addr) == type_CodeHeader) {
+ gc_assert(num_valid_stack_ra_locations < MAX_STACK_RETURN_ADDRESSES);
+ valid_stack_ra_locations[num_valid_stack_ra_locations] = sp;
+ valid_stack_ra_code_objects[num_valid_stack_ra_locations++] =
+ (lispobj *)((int)start_addr + type_OtherPointer);
+ } else {
+ if (valid_dynamic_space_pointer((void *)thing, start_addr)) {
+ gc_assert(num_valid_stack_locations < MAX_STACK_POINTERS);
+ valid_stack_locations[num_valid_stack_locations++] = sp;
+ }
+ }
+ }
+ }
+ if (pointer_filter_verbose) {
+ fprintf(stderr, "number of valid stack pointers = %d\n",
+ num_valid_stack_locations);
+ fprintf(stderr, "number of stack return addresses = %d\n",
+ num_valid_stack_ra_locations);
+ }
+}
+
+static void
+pscav_i386_stack(void)
+{
+ int i;
+
+ for (i = 0; i < num_valid_stack_locations; i++)
+ pscav(valid_stack_locations[i], 1, 0);
+
+ for (i = 0; i < num_valid_stack_ra_locations; i++) {
+ lispobj code_obj = (lispobj)valid_stack_ra_code_objects[i];
+ pscav(&code_obj, 1, 0);
+ if (pointer_filter_verbose) {
+ fprintf(stderr,"*C moved RA %x to %x; for code object %x to %x\n",
+ *valid_stack_ra_locations[i],
+ (int)(*valid_stack_ra_locations[i])
+ - ((int)valid_stack_ra_code_objects[i] - (int)code_obj),
+ valid_stack_ra_code_objects[i], code_obj);
+ }
+ *valid_stack_ra_locations[i] =
+ ((int)(*valid_stack_ra_locations[i])
+ - ((int)valid_stack_ra_code_objects[i] - (int)code_obj));
+ }
+}
+#endif
+#endif
+
+\f
+static void
+pscav_later(lispobj *where, int count)
+{
+ struct later *new;
+
+ if (count > LATERMAXCOUNT) {
+ while (count > LATERMAXCOUNT) {
+ pscav_later(where, LATERMAXCOUNT);
+ count -= LATERMAXCOUNT;
+ where += LATERMAXCOUNT;
+ }
+ }
+ else {
+ if (later_blocks == NULL || later_count == LATERBLOCKSIZE ||
+ (later_count == LATERBLOCKSIZE-1 && count > 1)) {
+ new = (struct later *)malloc(sizeof(struct later));
+ new->next = later_blocks;
+ if (later_blocks && later_count < LATERBLOCKSIZE)
+ later_blocks->u[later_count].ptr = NULL;
+ later_blocks = new;
+ later_count = 0;
+ }
+
+ if (count != 1)
+ later_blocks->u[later_count++].count = count;
+ later_blocks->u[later_count++].ptr = where;
+ }
+}
+
+static lispobj ptrans_boxed(lispobj thing, lispobj header, boolean constant)
+{
+ int nwords;
+ lispobj result, *new, *old;
+
+ nwords = 1 + HeaderValue(header);
+
+ /* Allocate it */
+ old = (lispobj *)PTR(thing);
+ if (constant) {
+ new = read_only_free;
+ read_only_free += CEILING(nwords, 2);
+ }
+ else {
+ new = static_free;
+ static_free += CEILING(nwords, 2);
+ }
+
+ /* Copy it. */
+ bcopy(old, new, nwords * sizeof(lispobj));
+
+ /* Deposit forwarding pointer. */
+ result = (lispobj)new | LowtagOf(thing);
+ *old = result;
+
+ /* Scavenge it. */
+ pscav(new, nwords, constant);
+
+ return result;
+}
+
+/* We need to look at the layout to see whether it is a pure structure
+ * class, and only then can we transport as constant. If it is pure, we can
+ * ALWAYS transport as a constant. */
+static lispobj ptrans_instance(lispobj thing, lispobj header, boolean constant)
+{
+ lispobj layout = ((struct instance *)PTR(thing))->slots[0];
+ lispobj pure = ((struct instance *)PTR(layout))->slots[15];
+
+ switch (pure) {
+ case T:
+ return (ptrans_boxed(thing, header, 1));
+ case NIL:
+ return (ptrans_boxed(thing, header, 0));
+ case 0:
+ {
+ /* Substructure: special case for the compact-info-envs, where
+ * the instance may have a point to the dynamic space placed
+ * into it (e.g. the cache-name slot), but the lists and arrays
+ * at the time of a purify can be moved to the RO space. */
+ int nwords;
+ lispobj result, *new, *old;
+
+ nwords = 1 + HeaderValue(header);
+
+ /* Allocate it */
+ old = (lispobj *)PTR(thing);
+ new = static_free;
+ static_free += CEILING(nwords, 2);
+
+ /* Copy it. */
+ bcopy(old, new, nwords * sizeof(lispobj));
+
+ /* Deposit forwarding pointer. */
+ result = (lispobj)new | LowtagOf(thing);
+ *old = result;
+
+ /* Scavenge it. */
+ pscav(new, nwords, 1);
+
+ return result;
+ }
+ default:
+ gc_abort();
+ }
+}
+
+static lispobj ptrans_fdefn(lispobj thing, lispobj header)
+{
+ int nwords;
+ lispobj result, *new, *old, oldfn;
+ struct fdefn *fdefn;
+
+ nwords = 1 + HeaderValue(header);
+
+ /* Allocate it */
+ old = (lispobj *)PTR(thing);
+ new = static_free;
+ static_free += CEILING(nwords, 2);
+
+ /* Copy it. */
+ bcopy(old, new, nwords * sizeof(lispobj));
+
+ /* Deposit forwarding pointer. */
+ result = (lispobj)new | LowtagOf(thing);
+ *old = result;
+
+ /* Scavenge the function. */
+ fdefn = (struct fdefn *)new;
+ oldfn = fdefn->function;
+ pscav(&fdefn->function, 1, 0);
+ if ((char *)oldfn + RAW_ADDR_OFFSET == fdefn->raw_addr)
+ fdefn->raw_addr = (char *)fdefn->function + RAW_ADDR_OFFSET;
+
+ return result;
+}
+
+static lispobj ptrans_unboxed(lispobj thing, lispobj header)
+{
+ int nwords;
+ lispobj result, *new, *old;
+
+ nwords = 1 + HeaderValue(header);
+
+ /* Allocate it */
+ old = (lispobj *)PTR(thing);
+ new = read_only_free;
+ read_only_free += CEILING(nwords, 2);
+
+ /* Copy it. */
+ bcopy(old, new, nwords * sizeof(lispobj));
+
+ /* Deposit forwarding pointer. */
+ result = (lispobj)new | LowtagOf(thing);
+ *old = result;
+
+ return result;
+}
+
+static lispobj ptrans_vector(lispobj thing, int bits, int extra,
+ boolean boxed, boolean constant)
+{
+ struct vector *vector;
+ int nwords;
+ lispobj result, *new;
+
+ vector = (struct vector *)PTR(thing);
+ nwords = 2 + (CEILING((fixnum_value(vector->length)+extra)*bits,32)>>5);
+
+ if (boxed && !constant) {
+ new = static_free;
+ static_free += CEILING(nwords, 2);
+ }
+ else {
+ new = read_only_free;
+ read_only_free += CEILING(nwords, 2);
+ }
+
+ bcopy(vector, new, nwords * sizeof(lispobj));
+
+ result = (lispobj)new | LowtagOf(thing);
+ vector->header = result;
+
+ if (boxed)
+ pscav(new, nwords, constant);
+
+ return result;
+}
+
+#ifdef __i386__
+static void
+apply_code_fixups_during_purify(struct code *old_code, struct code *new_code)
+{
+ int nheader_words, ncode_words, nwords;
+ void *constants_start_addr, *constants_end_addr;
+ void *code_start_addr, *code_end_addr;
+ lispobj p;
+ lispobj fixups = NIL;
+ unsigned displacement = (unsigned)new_code - (unsigned)old_code;
+ struct vector *fixups_vector;
+
+ /* Byte compiled code has no fixups. The trace table offset will be
+ * a fixnum if it's x86 compiled code - check. */
+ if (new_code->trace_table_offset & 0x3)
+ return;
+
+ /* Else it's x86 machine code. */
+ ncode_words = fixnum_value(new_code->code_size);
+ nheader_words = HeaderValue(*(lispobj *)new_code);
+ nwords = ncode_words + nheader_words;
+
+ constants_start_addr = (void *)new_code + 5*4;
+ constants_end_addr = (void *)new_code + nheader_words*4;
+ code_start_addr = (void *)new_code + nheader_words*4;
+ code_end_addr = (void *)new_code + nwords*4;
+
+ /* The first constant should be a pointer to the fixups for this
+ * code objects. Check. */
+ fixups = new_code->constants[0];
+
+ /* It will be 0 or the unbound-marker if there are no fixups, and
+ * will be an other-pointer to a vector if it is valid. */
+ if ((fixups==0) || (fixups==type_UnboundMarker) || !Pointerp(fixups)) {
+#ifdef GENCGC
+ /* Check for a possible errors. */
+ sniff_code_object(new_code,displacement);
+#endif
+ return;
+ }
+
+ fixups_vector = (struct vector *)PTR(fixups);
+
+ /* Could be pointing to a forwarding pointer. */
+ if (Pointerp(fixups) && (dynamic_pointer_p(fixups))
+ && forwarding_pointer_p(*(lispobj *)fixups_vector)) {
+ /* If so then follow it. */
+ fixups_vector = (struct vector *)PTR(*(lispobj *)fixups_vector);
+ }
+
+ if (TypeOf(fixups_vector->header) == type_SimpleArrayUnsignedByte32) {
+ /* We got the fixups for the code block. Now work through the vector,
+ * and apply a fixup at each address. */
+ int length = fixnum_value(fixups_vector->length);
+ int i;
+ for (i=0; i<length; i++) {
+ unsigned offset = fixups_vector->data[i];
+ /* Now check the current value of offset. */
+ unsigned old_value = *(unsigned *)((unsigned)code_start_addr + offset);
+
+ /* If it's within the old_code object then it must be an
+ * absolute fixup (relative ones are not saved) */
+ if ((old_value>=(unsigned)old_code)
+ && (old_value<((unsigned)old_code + nwords*4)))
+ /* So add the dispacement. */
+ *(unsigned *)((unsigned)code_start_addr + offset) = old_value
+ + displacement;
+ else
+ /* It is outside the old code object so it must be a relative
+ * fixup (absolute fixups are not saved). So subtract the
+ * displacement. */
+ *(unsigned *)((unsigned)code_start_addr + offset) = old_value
+ - displacement;
+ }
+ }
+
+ /* No longer need the fixups. */
+ new_code->constants[0] = 0;
+
+#ifdef GENCGC
+ /* Check for possible errors. */
+ sniff_code_object(new_code,displacement);
+#endif
+}
+#endif
+
+static lispobj ptrans_code(lispobj thing)
+{
+ struct code *code, *new;
+ int nwords;
+ lispobj func, result;
+
+ code = (struct code *)PTR(thing);
+ nwords = HeaderValue(code->header) + fixnum_value(code->code_size);
+
+ new = (struct code *)read_only_free;
+ read_only_free += CEILING(nwords, 2);
+
+ bcopy(code, new, nwords * sizeof(lispobj));
+
+#ifdef __i386__
+ apply_code_fixups_during_purify(code,new);
+#endif
+
+ result = (lispobj)new | type_OtherPointer;
+
+ /* Stick in a forwarding pointer for the code object. */
+ *(lispobj *)code = result;
+
+ /* Put in forwarding pointers for all the functions. */
+ for (func = code->entry_points;
+ func != NIL;
+ func = ((struct function *)PTR(func))->next) {
+
+ gc_assert(LowtagOf(func) == type_FunctionPointer);
+
+ *(lispobj *)PTR(func) = result + (func - thing);
+ }
+
+ /* Arrange to scavenge the debug info later. */
+ pscav_later(&new->debug_info, 1);
+
+ if(new->trace_table_offset & 0x3)
+#if 0
+ pscav(&new->trace_table_offset, 1, 0);
+#else
+ new->trace_table_offset = NIL; /* limit lifetime */
+#endif
+
+ /* Scavenge the constants. */
+ pscav(new->constants, HeaderValue(new->header)-5, 1);
+
+ /* Scavenge all the functions. */
+ pscav(&new->entry_points, 1, 1);
+ for (func = new->entry_points;
+ func != NIL;
+ func = ((struct function *)PTR(func))->next) {
+ gc_assert(LowtagOf(func) == type_FunctionPointer);
+ gc_assert(!dynamic_pointer_p(func));
+
+#ifdef __i386__
+ /* Temporarly convert the self pointer to a real function
+ pointer. */
+ ((struct function *)PTR(func))->self -= RAW_ADDR_OFFSET;
+#endif
+ pscav(&((struct function *)PTR(func))->self, 2, 1);
+#ifdef __i386__
+ ((struct function *)PTR(func))->self += RAW_ADDR_OFFSET;
+#endif
+ pscav_later(&((struct function *)PTR(func))->name, 3);
+ }
+
+ return result;
+}
+
+static lispobj ptrans_func(lispobj thing, lispobj header)
+{
+ int nwords;
+ lispobj code, *new, *old, result;
+ struct function *function;
+
+ /* Thing can either be a function header, a closure function
+ * header, a closure, or a funcallable-instance. If it's a closure
+ * or a funcallable-instance, we do the same as ptrans_boxed.
+ * Otherwise we have to do something strange, 'cause it is buried
+ * inside a code object. */
+
+ if (TypeOf(header) == type_FunctionHeader ||
+ TypeOf(header) == type_ClosureFunctionHeader) {
+
+ /* We can only end up here if the code object has not been
+ * scavenged, because if it had been scavenged, forwarding pointers
+ * would have been left behind for all the entry points. */
+
+ function = (struct function *)PTR(thing);
+ code = (PTR(thing)-(HeaderValue(function->header)*sizeof(lispobj))) |
+ type_OtherPointer;
+
+ /* This will cause the function's header to be replaced with a
+ * forwarding pointer. */
+ ptrans_code(code);
+
+ /* So we can just return that. */
+ return function->header;
+ }
+ else {
+ /* It's some kind of closure-like thing. */
+ nwords = 1 + HeaderValue(header);
+ old = (lispobj *)PTR(thing);
+
+ /* Allocate the new one. */
+ if (TypeOf(header) == type_FuncallableInstanceHeader) {
+ /* FINs *must* not go in read_only space. */
+ new = static_free;
+ static_free += CEILING(nwords, 2);
+ }
+ else {
+ /* Closures can always go in read-only space, 'cause they
+ * never change. */
+
+ new = read_only_free;
+ read_only_free += CEILING(nwords, 2);
+ }
+ /* Copy it. */
+ bcopy(old, new, nwords * sizeof(lispobj));
+
+ /* Deposit forwarding pointer. */
+ result = (lispobj)new | LowtagOf(thing);
+ *old = result;
+
+ /* Scavenge it. */
+ pscav(new, nwords, 0);
+
+ return result;
+ }
+}
+
+static lispobj ptrans_returnpc(lispobj thing, lispobj header)
+{
+ lispobj code, new;
+
+ /* Find the corresponding code object. */
+ code = thing - HeaderValue(header)*sizeof(lispobj);
+
+ /* Make sure it's been transported. */
+ new = *(lispobj *)PTR(code);
+ if (!forwarding_pointer_p(new))
+ new = ptrans_code(code);
+
+ /* Maintain the offset: */
+ return new + (thing - code);
+}
+
+#define WORDS_PER_CONS CEILING(sizeof(struct cons) / sizeof(lispobj), 2)
+
+static lispobj ptrans_list(lispobj thing, boolean constant)
+{
+ struct cons *old, *new, *orig;
+ int length;
+
+ if (constant)
+ orig = (struct cons *)read_only_free;
+ else
+ orig = (struct cons *)static_free;
+ length = 0;
+
+ do {
+ /* Allocate a new cons cell. */
+ old = (struct cons *)PTR(thing);
+ if (constant) {
+ new = (struct cons *)read_only_free;
+ read_only_free += WORDS_PER_CONS;
+ }
+ else {
+ new = (struct cons *)static_free;
+ static_free += WORDS_PER_CONS;
+ }
+
+ /* Copy the cons cell and keep a pointer to the cdr. */
+ new->car = old->car;
+ thing = new->cdr = old->cdr;
+
+ /* Set up the forwarding pointer. */
+ *(lispobj *)old = ((lispobj)new) | type_ListPointer;
+
+ /* And count this cell. */
+ length++;
+ } while (LowtagOf(thing) == type_ListPointer &&
+ dynamic_pointer_p(thing) &&
+ !(forwarding_pointer_p(*(lispobj *)PTR(thing))));
+
+ /* Scavenge the list we just copied. */
+ pscav((lispobj *)orig, length * WORDS_PER_CONS, constant);
+
+ return ((lispobj)orig) | type_ListPointer;
+}
+
+static lispobj ptrans_otherptr(lispobj thing, lispobj header, boolean constant)
+{
+ switch (TypeOf(header)) {
+ case type_Bignum:
+ case type_SingleFloat:
+ case type_DoubleFloat:
+#ifdef type_LongFloat
+ case type_LongFloat:
+#endif
+#ifdef type_ComplexSingleFloat
+ case type_ComplexSingleFloat:
+#endif
+#ifdef type_ComplexDoubleFloat
+ case type_ComplexDoubleFloat:
+#endif
+#ifdef type_ComplexLongFloat
+ case type_ComplexLongFloat:
+#endif
+ case type_Sap:
+ return ptrans_unboxed(thing, header);
+
+ case type_Ratio:
+ case type_Complex:
+ case type_SimpleArray:
+ case type_ComplexString:
+ case type_ComplexVector:
+ case type_ComplexArray:
+ return ptrans_boxed(thing, header, constant);
+
+ case type_ValueCellHeader:
+ case type_WeakPointer:
+ return ptrans_boxed(thing, header, 0);
+
+ case type_SymbolHeader:
+ return ptrans_boxed(thing, header, 0);
+
+ case type_SimpleString:
+ return ptrans_vector(thing, 8, 1, 0, constant);
+
+ case type_SimpleBitVector:
+ return ptrans_vector(thing, 1, 0, 0, constant);
+
+ case type_SimpleVector:
+ return ptrans_vector(thing, 32, 0, 1, constant);
+
+ case type_SimpleArrayUnsignedByte2:
+ return ptrans_vector(thing, 2, 0, 0, constant);
+
+ case type_SimpleArrayUnsignedByte4:
+ return ptrans_vector(thing, 4, 0, 0, constant);
+
+ case type_SimpleArrayUnsignedByte8:
+#ifdef type_SimpleArraySignedByte8
+ case type_SimpleArraySignedByte8:
+#endif
+ return ptrans_vector(thing, 8, 0, 0, constant);
+
+ case type_SimpleArrayUnsignedByte16:
+#ifdef type_SimpleArraySignedByte16
+ case type_SimpleArraySignedByte16:
+#endif
+ return ptrans_vector(thing, 16, 0, 0, constant);
+
+ case type_SimpleArrayUnsignedByte32:
+#ifdef type_SimpleArraySignedByte30
+ case type_SimpleArraySignedByte30:
+#endif
+#ifdef type_SimpleArraySignedByte32
+ case type_SimpleArraySignedByte32:
+#endif
+ return ptrans_vector(thing, 32, 0, 0, constant);
+
+ case type_SimpleArraySingleFloat:
+ return ptrans_vector(thing, 32, 0, 0, constant);
+
+ case type_SimpleArrayDoubleFloat:
+ return ptrans_vector(thing, 64, 0, 0, constant);
+
+#ifdef type_SimpleArrayLongFloat
+ case type_SimpleArrayLongFloat:
+#ifdef __i386__
+ return ptrans_vector(thing, 96, 0, 0, constant);
+#endif
+#ifdef sparc
+ return ptrans_vector(thing, 128, 0, 0, constant);
+#endif
+#endif
+
+#ifdef type_SimpleArrayComplexSingleFloat
+ case type_SimpleArrayComplexSingleFloat:
+ return ptrans_vector(thing, 64, 0, 0, constant);
+#endif
+
+#ifdef type_SimpleArrayComplexDoubleFloat
+ case type_SimpleArrayComplexDoubleFloat:
+ return ptrans_vector(thing, 128, 0, 0, constant);
+#endif
+
+#ifdef type_SimpleArrayComplexLongFloat
+ case type_SimpleArrayComplexLongFloat:
+#ifdef __i386__
+ return ptrans_vector(thing, 192, 0, 0, constant);
+#endif
+#ifdef sparc
+ return ptrans_vector(thing, 256, 0, 0, constant);
+#endif
+#endif
+
+ case type_CodeHeader:
+ return ptrans_code(thing);
+
+ case type_ReturnPcHeader:
+ return ptrans_returnpc(thing, header);
+
+ case type_Fdefn:
+ return ptrans_fdefn(thing, header);
+
+ default:
+ /* Should only come across other pointers to the above stuff. */
+ gc_abort();
+ return NIL;
+ }
+}
+
+static int pscav_fdefn(struct fdefn *fdefn)
+{
+ boolean fix_func;
+
+ fix_func = ((char *)(fdefn->function+RAW_ADDR_OFFSET) == fdefn->raw_addr);
+ pscav(&fdefn->name, 1, 1);
+ pscav(&fdefn->function, 1, 0);
+ if (fix_func)
+ fdefn->raw_addr = (char *)(fdefn->function + RAW_ADDR_OFFSET);
+ return sizeof(struct fdefn) / sizeof(lispobj);
+}
+
+#ifdef __i386__
+/* now putting code objects in static space */
+static int
+pscav_code(struct code*code)
+{
+ int nwords;
+ lispobj func;
+ nwords = HeaderValue(code->header) + fixnum_value(code->code_size);
+
+ /* pw--The trace_table_offset slot can contain a list pointer. This
+ * occurs when the code object is a top level form that initializes
+ * a byte-compiled function. The fact that PURIFY was ignoring this
+ * slot may be a bug unrelated to the x86 port, except that TLF's
+ * normally become unreachable after the loader calls them and
+ * won't be seen by PURIFY at all!! */
+ if(code->trace_table_offset & 0x3)
+#if 0
+ pscav(&code->trace_table_offset, 1, 0);
+#else
+ code->trace_table_offset = NIL; /* limit lifetime */
+#endif
+
+ /* Arrange to scavenge the debug info later. */
+ pscav_later(&code->debug_info, 1);
+
+ /* Scavenge the constants. */
+ pscav(code->constants, HeaderValue(code->header)-5, 1);
+
+ /* Scavenge all the functions. */
+ pscav(&code->entry_points, 1, 1);
+ for (func = code->entry_points;
+ func != NIL;
+ func = ((struct function *)PTR(func))->next) {
+ gc_assert(LowtagOf(func) == type_FunctionPointer);
+ gc_assert(!dynamic_pointer_p(func));
+
+#ifdef __i386__
+ /* Temporarly convert the self pointer to a real function
+ * pointer. */
+ ((struct function *)PTR(func))->self -= RAW_ADDR_OFFSET;
+#endif
+ pscav(&((struct function *)PTR(func))->self, 2, 1);
+#ifdef __i386__
+ ((struct function *)PTR(func))->self += RAW_ADDR_OFFSET;
+#endif
+ pscav_later(&((struct function *)PTR(func))->name, 3);
+ }
+
+ return CEILING(nwords,2);
+}
+#endif
+
+static lispobj *pscav(lispobj *addr, int nwords, boolean constant)
+{
+ lispobj thing, *thingp, header;
+ int count;
+ struct vector *vector;
+
+ while (nwords > 0) {
+ thing = *addr;
+ if (Pointerp(thing)) {
+ /* It's a pointer. Is it something we might have to move? */
+ if (dynamic_pointer_p(thing)) {
+ /* Maybe. Have we already moved it? */
+ thingp = (lispobj *)PTR(thing);
+ header = *thingp;
+ if (Pointerp(header) && forwarding_pointer_p(header))
+ /* Yep, so just copy the forwarding pointer. */
+ thing = header;
+ else {
+ /* Nope, copy the object. */
+ switch (LowtagOf(thing)) {
+ case type_FunctionPointer:
+ thing = ptrans_func(thing, header);
+ break;
+
+ case type_ListPointer:
+ thing = ptrans_list(thing, constant);
+ break;
+
+ case type_InstancePointer:
+ thing = ptrans_instance(thing, header, constant);
+ break;
+
+ case type_OtherPointer:
+ thing = ptrans_otherptr(thing, header, constant);
+ break;
+
+ default:
+ /* It was a pointer, but not one of them? */
+ gc_abort();
+ }
+ }
+ *addr = thing;
+ }
+ count = 1;
+ }
+ else if (thing & 3) {
+ /* It's an other immediate. Maybe the header for an unboxed */
+ /* object. */
+ switch (TypeOf(thing)) {
+ case type_Bignum:
+ case type_SingleFloat:
+ case type_DoubleFloat:
+#ifdef type_LongFloat
+ case type_LongFloat:
+#endif
+ case type_Sap:
+ /* It's an unboxed simple object. */
+ count = HeaderValue(thing)+1;
+ break;
+
+ case type_SimpleVector:
+ if (HeaderValue(thing) == subtype_VectorValidHashing)
+ *addr = (subtype_VectorMustRehash<<type_Bits) |
+ type_SimpleVector;
+ count = 1;
+ break;
+
+ case type_SimpleString:
+ vector = (struct vector *)addr;
+ count = CEILING(NWORDS(fixnum_value(vector->length)+1,4)+2,2);
+ break;
+
+ case type_SimpleBitVector:
+ vector = (struct vector *)addr;
+ count = CEILING(NWORDS(fixnum_value(vector->length),32)+2,2);
+ break;
+
+ case type_SimpleArrayUnsignedByte2:
+ vector = (struct vector *)addr;
+ count = CEILING(NWORDS(fixnum_value(vector->length),16)+2,2);
+ break;
+
+ case type_SimpleArrayUnsignedByte4:
+ vector = (struct vector *)addr;
+ count = CEILING(NWORDS(fixnum_value(vector->length),8)+2,2);
+ break;
+
+ case type_SimpleArrayUnsignedByte8:
+#ifdef type_SimpleArraySignedByte8
+ case type_SimpleArraySignedByte8:
+#endif
+ vector = (struct vector *)addr;
+ count = CEILING(NWORDS(fixnum_value(vector->length),4)+2,2);
+ break;
+
+ case type_SimpleArrayUnsignedByte16:
+#ifdef type_SimpleArraySignedByte16
+ case type_SimpleArraySignedByte16:
+#endif
+ vector = (struct vector *)addr;
+ count = CEILING(NWORDS(fixnum_value(vector->length),2)+2,2);
+ break;
+
+ case type_SimpleArrayUnsignedByte32:
+#ifdef type_SimpleArraySignedByte30
+ case type_SimpleArraySignedByte30:
+#endif
+#ifdef type_SimpleArraySignedByte32
+ case type_SimpleArraySignedByte32:
+#endif
+ vector = (struct vector *)addr;
+ count = CEILING(fixnum_value(vector->length)+2,2);
+ break;
+
+ case type_SimpleArraySingleFloat:
+ vector = (struct vector *)addr;
+ count = CEILING(fixnum_value(vector->length)+2,2);
+ break;
+
+ case type_SimpleArrayDoubleFloat:
+#ifdef type_SimpleArrayComplexSingleFloat
+ case type_SimpleArrayComplexSingleFloat:
+#endif
+ vector = (struct vector *)addr;
+ count = fixnum_value(vector->length)*2+2;
+ break;
+
+#ifdef type_SimpleArrayLongFloat
+ case type_SimpleArrayLongFloat:
+ vector = (struct vector *)addr;
+#ifdef __i386__
+ count = fixnum_value(vector->length)*3+2;
+#endif
+#ifdef sparc
+ count = fixnum_value(vector->length)*4+2;
+#endif
+ break;
+#endif
+
+#ifdef type_SimpleArrayComplexDoubleFloat
+ case type_SimpleArrayComplexDoubleFloat:
+ vector = (struct vector *)addr;
+ count = fixnum_value(vector->length)*4+2;
+ break;
+#endif
+
+#ifdef type_SimpleArrayComplexLongFloat
+ case type_SimpleArrayComplexLongFloat:
+ vector = (struct vector *)addr;
+#ifdef __i386__
+ count = fixnum_value(vector->length)*6+2;
+#endif
+#ifdef sparc
+ count = fixnum_value(vector->length)*8+2;
+#endif
+ break;
+#endif
+
+ case type_CodeHeader:
+#ifndef __i386__
+ gc_abort(); /* no code headers in static space */
+#else
+ count = pscav_code((struct code*)addr);
+#endif
+ break;
+
+ case type_FunctionHeader:
+ case type_ClosureFunctionHeader:
+ case type_ReturnPcHeader:
+ /* We should never hit any of these, 'cause they occur
+ * buried in the middle of code objects. */
+ gc_abort();
+ break;
+
+#ifdef __i386__
+ case type_ClosureHeader:
+ case type_FuncallableInstanceHeader:
+ case type_ByteCodeFunction:
+ case type_ByteCodeClosure:
+ /* The function self pointer needs special care on the
+ * x86 because it is the real entry point. */
+ {
+ lispobj fun = ((struct closure *)addr)->function
+ - RAW_ADDR_OFFSET;
+ pscav(&fun, 1, constant);
+ ((struct closure *)addr)->function = fun + RAW_ADDR_OFFSET;
+ }
+ count = 2;
+ break;
+#endif
+
+ case type_WeakPointer:
+ /* Weak pointers get preserved during purify, 'cause I
+ * don't feel like figuring out how to break them. */
+ pscav(addr+1, 2, constant);
+ count = 4;
+ break;
+
+ case type_Fdefn:
+ /* We have to handle fdefn objects specially, so we
+ * can fix up the raw function address. */
+ count = pscav_fdefn((struct fdefn *)addr);
+ break;
+
+ default:
+ count = 1;
+ break;
+ }
+ }
+ else {
+ /* It's a fixnum. */
+ count = 1;
+ }
+
+ addr += count;
+ nwords -= count;
+ }
+
+ return addr;
+}
+
+int purify(lispobj static_roots, lispobj read_only_roots)
+{
+ lispobj *clean;
+ int count, i;
+ struct later *laters, *next;
+
+#ifdef PRINTNOISE
+ printf("[doing purification:");
+ fflush(stdout);
+#endif
+
+ if (fixnum_value(SymbolValue(FREE_INTERRUPT_CONTEXT_INDEX)) != 0) {
+ /* FIXME: 1. What does this mean? 2. It shouldn't be reporting
+ * its error simply by a. printing a string b. to stdout instead
+ * of stderr. */
+ printf(" Ack! Can't purify interrupt contexts. ");
+ fflush(stdout);
+ return 0;
+ }
+
+#if defined(ibmrt) || defined(__i386__)
+ current_dynamic_space_free_pointer =
+ (lispobj*)SymbolValue(ALLOCATION_POINTER);
+#endif
+
+ read_only_end = read_only_free =
+ (lispobj *)SymbolValue(READ_ONLY_SPACE_FREE_POINTER);
+ static_end = static_free =
+ (lispobj *)SymbolValue(STATIC_SPACE_FREE_POINTER);
+
+#ifdef PRINTNOISE
+ printf(" roots");
+ fflush(stdout);
+#endif
+
+#ifdef GENCGC
+ gc_assert(control_stack_end > ((&read_only_roots)+1));
+ setup_i386_stack_scav(((&static_roots)-2), control_stack_end);
+#endif
+
+ pscav(&static_roots, 1, 0);
+ pscav(&read_only_roots, 1, 1);
+
+#ifdef PRINTNOISE
+ printf(" handlers");
+ fflush(stdout);
+#endif
+ pscav((lispobj *) interrupt_handlers,
+ sizeof(interrupt_handlers) / sizeof(lispobj),
+ 0);
+
+#ifdef PRINTNOISE
+ printf(" stack");
+ fflush(stdout);
+#endif
+#ifndef __i386__
+ pscav(control_stack, current_control_stack_pointer - control_stack, 0);
+#else
+#ifdef GENCGC
+ pscav_i386_stack();
+#endif
+#ifdef WANT_CGC
+ gc_assert(control_stack_end > ((&read_only_roots)+1));
+ carefully_pscav_stack(((&read_only_roots)+1), control_stack_end);
+#endif
+#endif
+
+#ifdef PRINTNOISE
+ printf(" bindings");
+ fflush(stdout);
+#endif
+#if !defined(ibmrt) && !defined(__i386__)
+ pscav(binding_stack, current_binding_stack_pointer - binding_stack, 0);
+#else
+ pscav(binding_stack, (lispobj *)SymbolValue(BINDING_STACK_POINTER) - binding_stack, 0);
+#endif
+
+#ifdef SCAVENGE_READ_ONLY_SPACE
+ if (SymbolValue(SCAVENGE_READ_ONLY_SPACE) != type_UnboundMarker
+ && SymbolValue(SCAVENGE_READ_ONLY_SPACE) != NIL) {
+ unsigned read_only_space_size =
+ (lispobj *)SymbolValue(READ_ONLY_SPACE_FREE_POINTER) - read_only_space;
+ fprintf(stderr,
+ "scavenging read only space: %d bytes\n",
+ read_only_space_size * sizeof(lispobj));
+ pscav(read_only_space, read_only_space_size, 0);
+ }
+#endif
+
+#ifdef PRINTNOISE
+ printf(" static");
+ fflush(stdout);
+#endif
+ clean = static_space;
+ do {
+ while (clean != static_free)
+ clean = pscav(clean, static_free - clean, 0);
+ laters = later_blocks;
+ count = later_count;
+ later_blocks = NULL;
+ later_count = 0;
+ while (laters != NULL) {
+ for (i = 0; i < count; i++) {
+ if (laters->u[i].count == 0) {
+ ;
+ } else if (laters->u[i].count <= LATERMAXCOUNT) {
+ pscav(laters->u[i+1].ptr, laters->u[i].count, 1);
+ i++;
+ } else {
+ pscav(laters->u[i].ptr, 1, 1);
+ }
+ }
+ next = laters->next;
+ free(laters);
+ laters = next;
+ count = LATERBLOCKSIZE;
+ }
+ } while (clean != static_free || later_blocks != NULL);
+
+#ifdef PRINTNOISE
+ printf(" cleanup");
+ fflush(stdout);
+#endif
+
+#if defined(WANT_CGC) && defined(X86_CGC_ACTIVE_P)
+ if(SymbolValue(X86_CGC_ACTIVE_P) != T)
+ os_zero((os_vm_address_t) current_dynamic_space,
+ (os_vm_size_t) DYNAMIC_SPACE_SIZE);
+#else
+ os_zero((os_vm_address_t) current_dynamic_space,
+ (os_vm_size_t) DYNAMIC_SPACE_SIZE);
+#endif
+
+ /* Zero the stack. Note that the stack is also zeroed by SUB-GC
+ * calling SCRUB-CONTROL-STACK - this zeros the stack on the x86. */
+#ifndef __i386__
+ os_zero((os_vm_address_t) current_control_stack_pointer,
+ (os_vm_size_t) (CONTROL_STACK_SIZE -
+ ((current_control_stack_pointer - control_stack) *
+ sizeof(lispobj))));
+#endif
+
+#if defined(WANT_CGC) && defined(STATIC_BLUE_BAG)
+ {
+ lispobj bag = SymbolValue(STATIC_BLUE_BAG);
+ struct cons*cons = (struct cons*)static_free;
+ struct cons*pair = cons + 1;
+ static_free += 2*WORDS_PER_CONS;
+ if(bag == type_UnboundMarker)
+ bag = NIL;
+ cons->cdr = bag;
+ cons->car = (lispobj)pair | type_ListPointer;
+ pair->car = (lispobj)static_end;
+ pair->cdr = (lispobj)static_free;
+ bag = (lispobj)cons | type_ListPointer;
+ SetSymbolValue(STATIC_BLUE_BAG, bag);
+ }
+#endif
+
+ /* It helps to update the heap free pointers so that free_heap can
+ * verify after it's done. */
+ SetSymbolValue(READ_ONLY_SPACE_FREE_POINTER, (lispobj)read_only_free);
+ SetSymbolValue(STATIC_SPACE_FREE_POINTER, (lispobj)static_free);
+
+#if !defined(ibmrt) && !defined(__i386__)
+ current_dynamic_space_free_pointer = current_dynamic_space;
+#else
+#if defined(WANT_CGC) && defined(X86_CGC_ACTIVE_P)
+ /* X86 using CGC */
+ if(SymbolValue(X86_CGC_ACTIVE_P) != T)
+ SetSymbolValue(ALLOCATION_POINTER, (lispobj)current_dynamic_space);
+ else
+ cgc_free_heap();
+#else
+#if defined GENCGC
+ gc_free_heap();
+#else
+ /* ibmrt using GC */
+ SetSymbolValue(ALLOCATION_POINTER, (lispobj)current_dynamic_space);
+#endif
+#endif
+#endif
+
+#ifdef PRINTNOISE
+ printf(" done]\n");
+ fflush(stdout);
+#endif
+
+ return 0;
+}
--- /dev/null
+/*
+ * This software is part of the SBCL system. See the README file for
+ * more information.
+ *
+ * This software is derived from the CMU CL system, which was
+ * written at Carnegie Mellon University and released into the
+ * public domain. The software is in the public domain and is
+ * provided with absolutely no warranty. See the COPYING and CREDITS
+ * files for more information.
+ */
+
+/*
+ * $Header$
+ */
+
+#if !defined(_PURIFY_H_)
+#define _PURIFY_H_
+
+extern int purify(lispobj static_roots, lispobj read_only_roots);
+
+#endif
--- /dev/null
+/*
+ * This software is part of the SBCL system. See the README file for
+ * more information.
+ *
+ * This software is derived from the CMU CL system, which was
+ * written at Carnegie Mellon University and released into the
+ * public domain. The software is in the public domain and is
+ * provided with absolutely no warranty. See the COPYING and CREDITS
+ * files for more information.
+ */
+
+/*
+ * $Header$
+ */
+
+#include "lispregs.h"
+
+char *lisp_register_names[] = { REGNAMES, 0 };
--- /dev/null
+/*
+ * main() entry point for a stand-alone SBCL image
+ */
+
+/*
+ * This software is part of the SBCL system. See the README file for
+ * more information.
+ *
+ * This software is derived from the CMU CL system, which was
+ * written at Carnegie Mellon University and released into the
+ * public domain. The software is in the public domain and is
+ * provided with absolutely no warranty. See the COPYING and CREDITS
+ * files for more information.
+ */
+
+/*
+ * $Header$
+ */
+
+#include <stdio.h>
+#include <sys/types.h>
+#include <stdlib.h>
+#include <unistd.h>
+#include <sys/file.h>
+#include <sys/param.h>
+#include <sys/stat.h>
+
+#include "signal.h"
+
+#include "runtime.h"
+#include "sbcl.h"
+#include "alloc.h"
+#include "vars.h"
+#include "globals.h"
+#include "os.h"
+#include "interrupt.h"
+#include "arch.h"
+#include "gc.h"
+#include "monitor.h"
+#include "validate.h"
+#if defined GENCGC
+#include "gencgc.h"
+#endif
+#include "core.h"
+#include "save.h"
+#include "lispregs.h"
+
+#ifdef irix
+#include <string.h>
+#include "interr.h"
+#endif
+\f
+/* SIGINT handler that invokes the monitor (for when Lisp isn't up to it) */
+
+static void sigint_handler(int signal, siginfo_t *info, void *void_context)
+{
+ printf("\nSIGINT hit at 0x%08lX\n", *os_context_pc_addr(void_context));
+ ldb_monitor();
+}
+
+/* (This is not static, because we want to be able to call it from
+ * Lisp land.) */
+void sigint_init(void)
+{
+ install_handler(SIGINT, sigint_handler);
+}
+\f
+/*
+ * helper functions for dealing with command line args
+ */
+
+void *
+successful_malloc(size_t size)
+{
+ void* result = malloc(size);
+ if (0 == result) {
+ lose("malloc failure");
+ } else {
+ return result;
+ }
+}
+
+char *
+copied_string(char *string)
+{
+ return strcpy(successful_malloc(1+strlen(string)), string);
+}
+
+char *
+copied_existing_filename_or_null(char *filename)
+{
+ struct stat filename_stat;
+ if (stat(filename, &filename_stat)) { /* if failure */
+ return 0;
+ } else {
+ return copied_string(filename);
+ }
+}
+
+/* Convert a null-terminated array of null-terminated strings (e.g.
+ * argv or envp) into a Lisp list of Lisp strings. */
+static lispobj
+alloc_string_list(char *array_ptr[])
+{
+ if (*array_ptr) {
+ return alloc_cons(alloc_string(*array_ptr),
+ alloc_string_list(1 + array_ptr));
+ } else {
+ return NIL;
+ }
+}
+\f
+int
+main(int argc, char *argv[], char *envp[])
+{
+ /* the name of the core file we're to execute. Note that this is
+ * a malloc'ed string which must be freed eventually. */
+ char *core = 0;
+
+ /* other command line options */
+ boolean noinform = 0;
+ boolean end_runtime_options = 0;
+
+ lispobj initial_function;
+
+ os_init();
+ gc_init();
+ validate();
+
+ /* Parse our part of the command line (aka "runtime options"),
+ * stripping out those options that we handle. */
+ {
+ int argi = 1;
+ while (argi < argc) {
+ char *arg = argv[argi];
+ if (0 == strcmp(arg, "--noinform")) {
+ noinform = 1;
+ ++argi;
+ } else if (0 == strcmp(arg, "--core")) {
+ if (core) {
+ lose("more than one core file specified");
+ } else {
+ ++argi;
+ core = copied_string(argv[argi]);
+ if (argi >= argc) {
+ lose("missing filename for --core argument");
+ }
+ ++argi;
+ }
+ } else if (0 == strcmp(arg, "--end-runtime-options")) {
+ end_runtime_options = 1;
+ ++argi;
+ break;
+ } else {
+ /* This option was unrecognized as a runtime option,
+ * so it must be a toplevel option or a user option,
+ * so we must be past the end of the runtime option
+ * section. */
+ break;
+ }
+ }
+ /* This is where we strip out those options that we handle. We
+ * also take this opportunity to make sure that we don't find
+ * an out-of-place "--end-runtime-options" option. */
+ {
+ char *argi0 = argv[argi];
+ int argj = 1;
+ while (argi < argc) {
+ char *arg = argv[argi++];
+ /* If we encounter --end-runtime-options for the first
+ * time after the point where we had to give up on
+ * runtime options, then the point where we had to
+ * give up on runtime options must've been a user
+ * error. */
+ if (!end_runtime_options &&
+ 0 == strcmp(arg, "--end-runtime-options")) {
+ lose("bad runtime option \"%s\"", argi0);
+ }
+ argv[argj++] = arg;
+ }
+ argv[argj] = 0;
+ argc = argj;
+ }
+ }
+
+ /* If no core file was specified, look for one. */
+ if (!core) {
+ char *sbcl_home = getenv("SBCL_HOME");
+ if (sbcl_home) {
+ char *lookhere;
+ asprintf(&lookhere, "%s/sbcl.core", sbcl_home);
+ core = copied_existing_filename_or_null(lookhere);
+ free(lookhere);
+ } else {
+ core = copied_existing_filename_or_null("/usr/lib/sbcl.core");
+ if (!core) {
+ core = copied_existing_filename_or_null("/usr/local/lib/sbcl.core");
+ }
+ }
+ if (!core) {
+ lose("can't find core file");
+ }
+ }
+
+ if (!noinform) {
+ printf(
+"This is SBCL " SBCL_VERSION_STRING ", an implementation of ANSI Common Lisp.
+
+SBCL is derived from the CMU CL system created at Carnegie Mellon University.
+Besides material created at Carnegie Mellon University, and material
+contributed by volunteers since its release into the public domain, CMU CL
+contained, and SBCL contains, material copyrighted by
+ Massachusetts Institute of Technology, 1986;
+ Symbolics, Inc., 1989, 1990, 1991, 1992; and
+ Xerox Corporation, 1985, 1986, 1987, 1988, 1989, 1990.
+More information about the origin of SBCL is available in the CREDITS file
+in the distribution.
+
+SBCL is a free software system, provided as is, with absolutely no warranty.
+It is mostly public domain software, but also includes some software from
+MIT, Symbolics, and Xerox, used under BSD-style licenses which allow copying
+only under certain conditions. More information about copying SBCL is
+available in the COPYING file in the distribution.
+
+More information on SBCL is available at <http://sbcl.sourceforge.net/>.
+");
+ fflush(stdout);
+ }
+
+#ifdef MACH
+ mach_init();
+#endif
+#if defined(SVR4) || defined(__linux__)
+ tzset();
+#endif
+
+ define_var("nil", NIL, 1);
+ define_var("t", T, 1);
+
+ set_lossage_handler(ldb_monitor);
+
+#if 0
+ os_init();
+ gc_init();
+ validate();
+#endif
+ globals_init();
+
+ initial_function = load_core_file(core);
+ if (initial_function == NIL) {
+ lose("couldn't find initial function");
+ }
+ free(core);
+
+#if defined GENCGC
+ gencgc_pickup_dynamic();
+#else
+#if defined WANT_CGC && defined X86_CGC_ACTIVE_P
+ {
+ extern int use_cgc_p;
+ lispobj x = SymbolValue(X86_CGC_ACTIVE_P);
+ if (x != type_UnboundMarker && x != NIL) {
+ /* Enable allocator. */
+ use_cgc_p = 1;
+ }
+ }
+#endif
+#endif
+
+#ifdef BINDING_STACK_POINTER
+ SetSymbolValue(BINDING_STACK_POINTER, (lispobj)binding_stack);
+#endif
+#if defined INTERNAL_GC_TRIGGER && !defined __i386__
+ SetSymbolValue(INTERNAL_GC_TRIGGER, make_fixnum(-1));
+#endif
+
+ interrupt_init();
+
+ arch_install_interrupt_handlers();
+ os_install_interrupt_handlers();
+
+#ifdef PSEUDO_ATOMIC_ATOMIC
+ /* Turn on pseudo atomic for when we call into Lisp. */
+ SetSymbolValue(PSEUDO_ATOMIC_ATOMIC, make_fixnum(1));
+ SetSymbolValue(PSEUDO_ATOMIC_INTERRUPTED, make_fixnum(0));
+#endif
+
+ /* Convert remaining argv values to something that Lisp can grok. */
+ SetSymbolValue(POSIX_ARGV, alloc_string_list(argv));
+
+ /* Install a handler to pick off SIGINT until the Lisp system gets
+ * far enough along to install its own handler. */
+ sigint_init();
+
+ funcall0(initial_function);
+
+ /* initial_function() is not supposed to return. */
+ lose("Lisp initial_function gave up control.");
+}
--- /dev/null
+/*
+ * This software is part of the SBCL system. See the README file for
+ * more information.
+ *
+ * This software is derived from the CMU CL system, which was
+ * written at Carnegie Mellon University and released into the
+ * public domain. The software is in the public domain and is
+ * provided with absolutely no warranty. See the COPYING and CREDITS
+ * files for more information.
+ */
+
+/*
+ * $Header$
+ */
+
+/* FIXME: Aren't symbols with underscore prefixes supposed to be
+ * reserved for system libraries? Perhaps rename stuff like this
+ * to names like INCLUDED_SBCL_RUNTIME_H. */
+#ifndef _SBCL_RUNTIME_H_
+#define _SBCL_RUNTIME_H_
+
+#define QSHOW 0 /* Enable low-level debugging output? */
+#if QSHOW
+#define FSHOW(args) fprintf args
+#define SHOW(string) FSHOW((stderr, "/%s\n", string))
+#else
+#define FSHOW(args)
+#define SHOW(string)
+#endif
+
+/* Enable extra-verbose low-level debugging output for signals? (You
+ * probably don't want this unless you're trying to debug very early
+ * cold boot on a new machine, or one where you've just messed up
+ * signal handling.)
+ *
+ * Note: It may be that doing this is fundamentally unsound, since it
+ * causes output from signal handlers, the i/o libraries aren't
+ * necessarily reentrant. But it can still be very convenient for
+ * figuring out what's going on when you have a signal handling
+ * problem.. */
+#define QSHOW_SIGNALS 0
+
+/* FIXME: There seems to be no reason that LowtagOf can't be defined
+ * as a (possibly inline) function instead of a macro. It would also
+ * be reasonable to rename the constants in ALL CAPS. */
+
+#define lowtag_Bits 3
+#define lowtag_Mask ((1<<lowtag_Bits)-1)
+#define LowtagOf(obj) ((obj)&lowtag_Mask)
+#define type_Bits 8
+#define type_Mask ((1<<type_Bits)-1)
+
+/* FIXME: There seems to be no reason that TypeOf, HeaderValue,
+ * Pointerp, PTR, CONS, SYMBOL, and FDEFN can't be defined
+ * as (possibly inline) functions instead of macros. */
+
+#define TypeOf(obj) ((obj)&type_Mask)
+#define HeaderValue(obj) ((unsigned long) ((obj)>>type_Bits))
+
+#define Pointerp(obj) ((obj) & 0x01)
+#define PTR(obj) ((obj)&~lowtag_Mask)
+
+#define CONS(obj) ((struct cons *)((obj)-type_ListPointer))
+#define SYMBOL(obj) ((struct symbol *)((obj)-type_OtherPointer))
+#define FDEFN(obj) ((struct fdefn *)((obj)-type_OtherPointer))
+
+/* KLUDGE: These are in theory machine-dependent and OS-dependent, but
+ * in practice the "foo int" definitions work for all the machines
+ * that SBCL runs on as of 0.6.7. If we port to the Alpha or some
+ * other non-32-bit machine we'll probably need real machine-dependent
+ * and OS-dependent definitions again. */
+#if defined alpha
+/* We need definitions of u32 and s32. */
+#error Alpha code is stale.
+#else
+typedef unsigned int u32;
+typedef signed int s32;
+#endif
+
+typedef u32 lispobj;
+
+/* FIXME: There seems to be no reason that make_fixnum and fixnum_value
+ * can't be implemented as (possibly inline) functions. */
+#define make_fixnum(n) ((lispobj)((n)<<2))
+#define fixnum_value(n) (((long)n)>>2)
+
+/* Too bad ANSI C doesn't define "bool" as C++ does.. */
+typedef int boolean;
+
+/* FIXME: There seems to be no reason that SymbolValue, SetSymbolValue,
+ * and SymbolFunction can't be defined as (possibly inline) functions
+ * instead of macros. */
+
+#define SymbolValue(sym) \
+ (((struct symbol *)((sym)-type_OtherPointer))->value)
+#define SetSymbolValue(sym,val) \
+ (((struct symbol *)((sym)-type_OtherPointer))->value = (val))
+
+/* This only works for static symbols. */
+/* FIXME: should be called StaticSymbolFunction, right? */
+#define SymbolFunction(sym) \
+ (((struct fdefn *)(SymbolValue(sym)-type_OtherPointer))->function)
+
+#endif /* _SBCL_RUNTIME_H_ */
--- /dev/null
+/*
+ * This software is part of the SBCL system. See the README file for
+ * more information.
+ *
+ * This software is derived from the CMU CL system, which was
+ * written at Carnegie Mellon University and released into the
+ * public domain. The software is in the public domain and is
+ * provided with absolutely no warranty. See the COPYING and CREDITS
+ * files for more information.
+ */
+
+/*
+ * $Header$
+ */
+
+#include <stdio.h>
+#include <signal.h>
+#include <sys/file.h>
+
+#include "runtime.h"
+#include "os.h"
+#include "sbcl.h"
+#include "core.h"
+#include "globals.h"
+#include "save.h"
+#include "lispregs.h"
+#include "validate.h"
+
+#ifdef GENCGC
+#include "gencgc.h"
+#endif
+
+static long
+write_bytes(FILE *file, char *addr, long bytes)
+{
+ long count, here, data;
+
+ bytes = (bytes+CORE_PAGESIZE-1)&~(CORE_PAGESIZE-1);
+
+ fflush(file);
+ here = ftell(file);
+ fseek(file, 0, 2);
+ data = (ftell(file)+CORE_PAGESIZE-1)&~(CORE_PAGESIZE-1);
+ fseek(file, data, 0);
+
+ while (bytes > 0) {
+ count = fwrite(addr, 1, bytes, file);
+ if (count > 0) {
+ bytes -= count;
+ addr += count;
+ }
+ else {
+ perror("error writing to save file");
+ bytes = 0;
+ }
+ }
+ fflush(file);
+ fseek(file, here, 0);
+ return data/CORE_PAGESIZE - 1;
+}
+
+static void
+output_space(FILE *file, int id, lispobj *addr, lispobj *end)
+{
+ int words, bytes, data;
+ static char *names[] = {NULL, "dynamic", "static", "read-only"};
+
+ putw(id, file);
+ words = end - addr;
+ putw(words, file);
+
+ bytes = words * sizeof(lispobj);
+
+ printf("writing %d bytes from the %s space at 0x%08X\n",
+ bytes, names[id], (unsigned long)addr);
+
+ data = write_bytes(file, (char *)addr, bytes);
+
+ putw(data, file);
+ putw((long)addr / CORE_PAGESIZE, file);
+ putw((bytes + CORE_PAGESIZE - 1) / CORE_PAGESIZE, file);
+}
+
+boolean
+save(char *filename, lispobj init_function)
+{
+ FILE *file;
+#if defined WANT_CGC
+ volatile lispobj*func_ptr = &init_function;
+ char sbuf[128];
+ strcpy(sbuf,filename);
+ filename=sbuf;
+ /* Get rid of remnant stuff. This is a MUST so that
+ * the memory manager can get started correctly when
+ * we restart after this save. Purify is going to
+ * maybe move the args so we need to consider them volatile,
+ * especially if the gcc optimizer is working!!
+ */
+ purify(NIL,NIL);
+
+ init_function = *func_ptr;
+ /* Set dynamic space pointer to base value so we don't write out
+ * MBs of just cleared heap.
+ */
+ if(SymbolValue(X86_CGC_ACTIVE_P) != NIL)
+ SetSymbolValue(ALLOCATION_POINTER,DYNAMIC_0_SPACE_START);
+#endif
+ /* Open the file: */
+ unlink(filename);
+ file = fopen(filename, "w");
+ if (file == NULL) {
+ perror(filename);
+ return 1;
+ }
+ printf("[undoing binding stack... ");
+ fflush(stdout);
+ unbind_to_here((lispobj *)BINDING_STACK_START);
+ SetSymbolValue(CURRENT_CATCH_BLOCK, 0);
+ SetSymbolValue(CURRENT_UNWIND_PROTECT_BLOCK, 0);
+ SetSymbolValue(EVAL_STACK_TOP, 0);
+ printf("done]\n");
+#if defined WANT_CGC && defined X86_CGC_ACTIVE_P
+ SetSymbolValue(X86_CGC_ACTIVE_P, T);
+#endif
+ printf("[saving current Lisp image into %s:\n", filename);
+
+ putw(CORE_MAGIC, file);
+
+ putw(CORE_VERSION, file);
+ putw(3, file);
+ putw(SBCL_CORE_VERSION_INTEGER, file);
+
+ putw(CORE_NDIRECTORY, file);
+ putw((5*3)+2, file);
+
+ output_space(file, READ_ONLY_SPACE_ID, read_only_space,
+ (lispobj *)SymbolValue(READ_ONLY_SPACE_FREE_POINTER));
+ output_space(file, STATIC_SPACE_ID, static_space,
+ (lispobj *)SymbolValue(STATIC_SPACE_FREE_POINTER));
+#ifdef reg_ALLOC
+ output_space(file, DYNAMIC_SPACE_ID, current_dynamic_space,
+ current_dynamic_space_free_pointer);
+#else
+#ifdef GENCGC
+ /* Flush the current_region updating the tables. */
+ gc_alloc_update_page_tables(0,&boxed_region);
+ gc_alloc_update_page_tables(1,&unboxed_region);
+ update_x86_dynamic_space_free_pointer();
+#endif
+ output_space(file, DYNAMIC_SPACE_ID, current_dynamic_space,
+ (lispobj *)SymbolValue(ALLOCATION_POINTER));
+#endif
+
+ putw(CORE_INITIAL_FUNCTION, file);
+ putw(3, file);
+ putw(init_function, file);
+
+ putw(CORE_END, file);
+ fclose(file);
+
+ printf("done]\n");
+
+ exit(0);
+}
--- /dev/null
+/*
+ * This software is part of the SBCL system. See the README file for
+ * more information.
+ *
+ * This software is derived from the CMU CL system, which was
+ * written at Carnegie Mellon University and released into the
+ * public domain. The software is in the public domain and is
+ * provided with absolutely no warranty. See the COPYING and CREDITS
+ * files for more information.
+ */
+
+/*
+ * $Header$
+ */
+
+#ifndef _SAVE_H_
+#define _SAVE_H_
+
+#include "core.h"
+
+extern boolean save(char *filename, lispobj initfun);
+
+#endif
--- /dev/null
+/*
+ * This software is part of the SBCL system. See the README file for
+ * more information.
+ *
+ * This software is derived from the CMU CL system, which was
+ * written at Carnegie Mellon University and released into the
+ * public domain. The software is in the public domain and is
+ * provided with absolutely no warranty. See the COPYING and CREDITS
+ * files for more information.
+ */
+
+/*
+ * $Header$
+ */
+
+#include "runtime.h"
+#include "sbcl.h"
+#include "os.h"
+#include "search.h"
+
+boolean search_for_type(int type, lispobj **start, int *count)
+{
+ lispobj obj, *addr;
+
+ while ((*count == -1 || (*count > 0)) &&
+ is_valid_lisp_addr((os_vm_address_t)*start)) {
+ obj = **start;
+ addr = *start;
+ if (*count != -1)
+ *count -= 2;
+
+ if (TypeOf(obj) == type)
+ return 1;
+
+ (*start) += 2;
+ }
+ return 0;
+}
+
+boolean search_for_symbol(char *name, lispobj **start, int *count)
+{
+ struct symbol *symbol;
+ struct vector *symbol_name;
+
+ while (search_for_type(type_SymbolHeader, start, count)) {
+ symbol = (struct symbol *)PTR((lispobj)*start);
+ if (LowtagOf(symbol->name) == type_OtherPointer) {
+ symbol_name = (struct vector *)PTR(symbol->name);
+ if (is_valid_lisp_addr((os_vm_address_t)symbol_name) &&
+ TypeOf(symbol_name->header) == type_SimpleString &&
+ strcmp((char *)symbol_name->data, name) == 0)
+ return 1;
+ }
+ (*start) += 2;
+ }
+ return 0;
+}
--- /dev/null
+/*
+ * This software is part of the SBCL system. See the README file for
+ * more information.
+ *
+ * This software is derived from the CMU CL system, which was
+ * written at Carnegie Mellon University and released into the
+ * public domain. The software is in the public domain and is
+ * provided with absolutely no warranty. See the COPYING and CREDITS
+ * files for more information.
+ */
+
+/*
+ * $Header$
+ */
+
+#ifndef _SEARCH_H_
+#define _SEARCH_H_
+
+extern boolean search_for_type(int type, lispobj **start, int *count);
+extern boolean search_for_symbol(char *name, lispobj **start, int *count);
+
+#endif
--- /dev/null
+/*
+ * time support routines that are easier to do in C than in Lisp
+ */
+
+/*
+ * This software is part of the SBCL system. See the README file for
+ * more information.
+ *
+ * This software is derived from the CMU CL system, which was
+ * written at Carnegie Mellon University and released into the
+ * public domain. The software is in the public domain and is
+ * provided with absolutely no warranty. See the COPYING and CREDITS
+ * files for more information.
+ */
+
+/*
+ * $Header$
+ */
+
+#include <stdio.h>
+#include <time.h>
+#include "runtime.h"
+
+void get_timezone(time_t when, int *minwest, boolean *dst)
+{
+ struct tm ltm, gtm;
+ int mw;
+
+ ltm = *localtime(&when);
+ gtm = *gmtime(&when);
+
+ mw = ((gtm.tm_hour*60)+gtm.tm_min) - ((ltm.tm_hour*60)+ltm.tm_min);
+ if ((gtm.tm_wday + 1) % 7 == ltm.tm_wday)
+ mw -= 24*60;
+ else if (gtm.tm_wday == (ltm.tm_wday + 1) % 7)
+ mw += 24*60;
+ *minwest = mw;
+ *dst = ltm.tm_isdst;
+}
--- /dev/null
+/*
+ * routines that must be linked into the core for Lisp to work
+ */
+
+/*
+ * This software is part of the SBCL system. See the README file for
+ * more information.
+ *
+ * This software is derived from the CMU CL system, which was
+ * written at Carnegie Mellon University and released into the
+ * public domain. The software is in the public domain and is
+ * provided with absolutely no warranty. See the COPYING and CREDITS
+ * files for more information.
+ */
+
+/*
+ * $Header$
+ */
+
+#ifdef sun
+#ifndef MACH
+#if !defined(SUNOS) && !defined(SOLARIS)
+#define SUNOS
+#endif
+#endif
+#endif
+
+typedef int func();
+
+extern func
+#define F(x) x,
+#if !(defined(irix) || defined(SOLARIS))
+/* XXXfixme next line probably wrong; was previous behavior */
+#define D(x) x,
+#else
+#define D(x)
+#endif
+#include "undefineds.h"
+#undef F
+#undef D
+exit; /* just some function known to exist */
+
+#if defined(SOLARIS) || defined(irix)
+
+#ifdef irix
+int errno; /* hack to be sure works with newer libc without having to redump */
+ /* causes libc to be relocated to match cmucl rather than vice
+ * versa */
+#endif
+
+extern int
+#define F(x)
+#define D(x) x,
+#include "undefineds.h"
+#undef F
+#undef D
+errno; /* a variable known to exist */
+
+int reference_random_symbols(void) {
+ int a;
+#define F(x) x();
+#define D(x) a+=x;
+#include "undefineds.h"
+#undef F
+#undef D
+ return a;
+ }
+
+#else
+
+func *reference_random_symbols[] = {
+#define F(x) x,
+ /* XXXfixme Next line is probably wrong but was previous behavior. */
+#define D(x) x,
+#include "undefineds.h"
+#undef F
+#undef D
+ exit /* a function known to exist */
+};
+
+#endif
--- /dev/null
+/*
+ * routines that must be linked into the core for Lisp to work
+ */
+
+/*
+ * This software is part of the SBCL system. See the README file for
+ * more information.
+ *
+ * This software is derived from the CMU CL system, which was
+ * written at Carnegie Mellon University and released into the
+ * public domain. The software is in the public domain and is
+ * provided with absolutely no warranty. See the COPYING and CREDITS
+ * files for more information.
+ */
+
+/*
+ * $Header$
+ */
+
+/* Pick up all the syscalls. */
+F(accept)
+F(access)
+F(acct)
+#ifndef hpux
+F(adjtime)
+#endif
+F(bind)
+F(brk)
+#if defined(hpux) \
+ || defined(SVR4) \
+ || defined(__FreeBSD__) \
+ || defined(__OpenBSD__)
+F(cfgetospeed)
+F(cfsetospeed)
+F(cfgetispeed)
+F(cfsetispeed)
+#endif
+F(chdir)
+F(chmod)
+F(chown)
+F(chroot)
+F(close)
+F(connect)
+F(creat)
+F(dup)
+F(dup2)
+F(execve)
+F(exit)
+F(fchmod)
+F(fchown)
+F(fcntl)
+#if !defined(hpux) && !defined(SVR4)
+F(flock)
+#endif
+F(fork)
+F(fstat)
+F(fsync)
+F(ftruncate)
+#if !defined(hpux) && !defined(SVR4) || defined(SOLARIS25) || defined(irix)
+F(getdtablesize)
+#endif
+F(getegid)
+F(geteuid)
+F(getgid)
+F(getgroups)
+#if !defined (SOLARIS) || defined(SOLARIS25)
+F(gethostid)
+#endif
+F(gethostname)
+F(getitimer)
+#if !defined(hpux) && !defined(SVR4) || defined(SOLARIS25)
+F(getpagesize)
+#endif
+F(getpeername)
+F(getpgrp)
+F(getpid)
+F(getppid)
+#if !defined(SVR4) || defined(SOLARIS25)
+F(getpriority)
+#endif
+F(getrlimit)
+#if !defined(SOLARIS) || defined(SOLARIS25)
+F(getrusage)
+#endif
+F(getsockname)
+F(getsockopt)
+F(gettimeofday)
+F(getuid)
+F(ioctl)
+F(kill)
+#if !defined(SOLARIS) || defined(SOLARIS25)
+F(killpg)
+#endif
+F(link)
+F(listen)
+F(lseek)
+F(lstat)
+F(mkdir)
+F(mknod)
+F(mmap)
+F(mount)
+F(munmap)
+F(open)
+F(pipe)
+F(profil)
+F(ptrace)
+#ifdef mach
+F(quota)
+#endif
+F(read)
+F(readlink)
+F(readv)
+#ifndef SVR4
+F(reboot)
+#endif
+F(recv)
+F(recvfrom)
+F(recvmsg)
+F(rename)
+F(rmdir)
+F(sbrk)
+F(select)
+F(send)
+F(sendmsg)
+F(sendto)
+F(setgroups)
+#if !defined(SUNOS) && !(defined(SOLARIS) || defined(SOLARIS25))
+F(sethostid)
+#endif
+#if !defined(SVR4) || defined(SOLARIS25)
+F(sethostname)
+#endif
+F(setitimer)
+F(setpgrp)
+#if !defined(SVR4) || defined(SOLARIS25)
+F(setpriority)
+#endif
+#if !defined(mach) \
+ && !defined(SOLARIS) \
+ && !defined(__FreeBSD__) \
+ && !defined(__OpenBSD__) \
+ && !defined(SUNOS) \
+ && !defined(osf1) \
+ && !defined(irix) \
+ && !defined(hpux)
+F(setquota)
+#endif
+#if !defined(hpux) && !defined(SVR4) || defined(SOLARIS25)
+F(setregid)
+F(setreuid)
+#endif
+F(setrlimit)
+F(setsockopt)
+F(settimeofday)
+F(shutdown)
+#ifndef SVR4
+F(sigblock)
+#endif
+F(sigpause)
+#if !defined(ibmrt) && !defined(hpux) && !defined(SVR4) && !defined(__i386__)
+F(sigreturn)
+#endif
+#if !defined(SVR4) && !defined(__FreeBSD__) && !defined(__OpenBSD__)
+F(sigsetmask)
+F(sigstack)
+F(sigvec)
+#endif
+F(socket)
+F(socketpair)
+F(stat)
+#ifndef SVR4
+F(swapon)
+#endif
+F(symlink)
+F(sync)
+F(syscall)
+#if defined(hpux) || defined(SVR4)
+F(closedir)
+F(opendir)
+F(readdir)
+#endif
+#if defined(hpux) \
+ || defined(SVR4) \
+ || defined(__FreeBSD__) \
+ || defined(__OpenBSD__) \
+ || defined(__linux__)
+F(tcgetattr)
+F(tcsetattr)
+F(tcsendbreak)
+F(tcdrain)
+F(tcflush)
+F(tcflow)
+#endif
+#if defined(SOLARIS)
+F(times)
+#endif
+F(truncate)
+F(umask)
+#if !defined(SUNOS) \
+ && !defined(parisc) \
+ && !defined(SOLARIS) \
+ && !defined(__OpenBSD__) \
+ && !defined(__FreeBSD__)
+F(umount)
+#endif
+F(unlink)
+#ifndef hpux
+F(utimes)
+#endif
+#ifndef irix
+F(vfork)
+#endif
+#if !defined(osf1) && !defined(__FreeBSD__) && !defined(__OpenBSD__)
+F(vhangup)
+#endif
+F(wait)
+#if !defined(SOLARIS) || defined(SOLARIS25)
+F(wait3)
+#endif
+F(write)
+F(writev)
+
+/* Math routines. */
+F(cos)
+F(sin)
+F(tan)
+F(acos)
+F(asin)
+F(atan)
+F(atan2)
+F(sinh)
+F(cosh)
+F(tanh)
+F(asinh)
+F(acosh)
+F(atanh)
+F(exp)
+#ifndef hpux
+F(expm1)
+#endif
+F(log)
+F(log10)
+#ifndef hpux
+F(log1p)
+#endif
+F(pow)
+#ifndef hpux
+F(cbrt)
+#endif
+#ifndef __i386__
+F(sqrt)
+#endif
+F(hypot)
+
+/* Network support. */
+F(gethostbyname)
+F(gethostbyaddr)
+
+/* Other miscellaneous things. */
+#if defined(SVR4)
+F(setpgid)
+F(getpgid)
+D(timezone)
+D(altzone)
+D(daylight)
+D(tzname)
+F(dlopen)
+F(dlsym)
+F(dlclose)
+F(dlerror)
+#endif
+#if !defined (SOLARIS) || defined(SOLARIS25)
+F(getwd)
+#endif
+F(ttyname)
+
+#ifdef irix
+F(_getpty)
+#endif
--- /dev/null
+/*
+ * memory validation
+ */
+
+/*
+ * This software is part of the SBCL system. See the README file for
+ * more information.
+ *
+ * This software is derived from the CMU CL system, which was
+ * written at Carnegie Mellon University and released into the
+ * public domain. The software is in the public domain and is
+ * provided with absolutely no warranty. See the COPYING and CREDITS
+ * files for more information.
+ */
+
+/*
+ * $Header$
+ */
+
+#include <stdio.h>
+#include "runtime.h"
+#include "os.h"
+#include "globals.h"
+#include "validate.h"
+
+static void ensure_space(lispobj *start, unsigned long size)
+{
+ if (os_validate((os_vm_address_t)start,(os_vm_size_t)size)==NULL) {
+ fprintf(stderr,
+ "ensure_space: failed to validate %ld bytes at 0x%08X\n",
+ size,
+ (unsigned long)start);
+ exit(1);
+ }
+}
+
+#ifdef HOLES
+
+static os_vm_address_t holes[] = HOLES;
+
+static void make_holes(void)
+{
+ int i;
+
+ for (i = 0; i < sizeof(holes)/sizeof(holes[0]); i++) {
+ if (os_validate(holes[i], HOLE_SIZE) == NULL) {
+ fprintf(stderr,
+ "make_holes: failed to validate %ld bytes at 0x%08X\n",
+ HOLE_SIZE,
+ (unsigned long)holes[i]);
+ exit(1);
+ }
+ os_protect(holes[i], HOLE_SIZE, 0);
+ }
+}
+#endif
+
+void validate(void)
+{
+#ifdef PRINTNOISE
+ printf("validating memory ...");
+ fflush(stdout);
+#endif
+
+ /* Read-Only Space */
+ read_only_space = (lispobj *) READ_ONLY_SPACE_START;
+ ensure_space(read_only_space, READ_ONLY_SPACE_SIZE);
+
+ /* Static Space */
+ static_space = (lispobj *) STATIC_SPACE_START;
+ ensure_space(static_space, STATIC_SPACE_SIZE);
+
+ /* Dynamic-0 Space */
+ dynamic_0_space = (lispobj *) DYNAMIC_0_SPACE_START;
+ ensure_space(dynamic_0_space, DYNAMIC_SPACE_SIZE);
+
+ current_dynamic_space = dynamic_0_space;
+
+ /* Dynamic-1 Space */
+ dynamic_1_space = (lispobj *) DYNAMIC_1_SPACE_START;
+#ifndef GENCGC
+ ensure_space(dynamic_1_space, DYNAMIC_SPACE_SIZE);
+#endif
+
+ /* Control Stack */
+ control_stack = (lispobj *) CONTROL_STACK_START;
+#ifdef __i386__
+ control_stack_end = (lispobj *) (CONTROL_STACK_START
+ + CONTROL_STACK_SIZE);
+#endif
+ ensure_space(control_stack, CONTROL_STACK_SIZE);
+
+ /* Binding Stack */
+ binding_stack = (lispobj *) BINDING_STACK_START;
+ ensure_space(binding_stack, BINDING_STACK_SIZE);
+
+#ifdef HOLES
+ make_holes();
+#endif
+
+#ifdef PRINTNOISE
+ printf(" done.\n");
+#endif
+}
--- /dev/null
+/*
+ * This software is part of the SBCL system. See the README file for
+ * more information.
+ *
+ * This software is derived from the CMU CL system, which was
+ * written at Carnegie Mellon University and released into the
+ * public domain. The software is in the public domain and is
+ * provided with absolutely no warranty. See the COPYING and CREDITS
+ * files for more information.
+ */
+
+/*
+ * $Header$
+ */
+
+#if !defined(_INCLUDE_VALIDATE_H_)
+#define _INCLUDE_VALIDATE_H_
+
+#ifdef parisc
+#include "hppa-validate.h"
+#endif parisc
+
+#ifdef mips
+#include "mips-validate.h"
+#endif
+
+#ifdef ibmrt
+#include "rt-validate.h"
+#endif
+
+#ifdef sparc
+#include "sparc-validate.h"
+#endif
+
+#ifdef __i386__
+#include "x86-validate.h"
+#endif
+
+#ifdef alpha
+#include "alpha-validate.h"
+#endif
+
+extern void validate(void);
+
+#endif
--- /dev/null
+/*
+ * This software is part of the SBCL system. See the README file for
+ * more information.
+ *
+ * This software is derived from the CMU CL system, which was
+ * written at Carnegie Mellon University and released into the
+ * public domain. The software is in the public domain and is
+ * provided with absolutely no warranty. See the COPYING and CREDITS
+ * files for more information.
+ */
+
+/*
+ * $Header$
+ */
+
+#include <stdio.h>
+#include <sys/types.h>
+#include <stdlib.h>
+
+#include "runtime.h"
+#include "vars.h"
+#include "os.h"
+
+#define NAME_BUCKETS 31
+#define OBJ_BUCKETS 31
+
+static struct var *NameHash[NAME_BUCKETS], *ObjHash[OBJ_BUCKETS];
+static int tempcntr = 1;
+
+struct var {
+ lispobj obj;
+ lispobj (*update_fn)(struct var *var);
+ char *name;
+ long clock;
+ boolean map_back, permanent;
+
+ struct var *nnext; /* Next in name list */
+ struct var *onext; /* Next in object list */
+};
+
+static int hash_name(char *name)
+{
+ unsigned long value = 0;
+
+ while (*name != '\0') {
+ value = (value << 1) ^ *(unsigned char *)(name++);
+ value = (value & (1-(1<<24))) ^ (value >> 24);
+ }
+
+ return value % NAME_BUCKETS;
+}
+
+static int hash_obj(lispobj obj)
+{
+ return (unsigned long)obj % OBJ_BUCKETS;
+}
+
+void flush_vars()
+{
+ int index;
+ struct var *var, *next, *perm = NULL;
+
+ /* Note: all vars in the object hash table also appear in the name hash
+ * table, so if we free everything in the name hash table, we free
+ * everything in the object hash table. */
+
+ for (index = 0; index < NAME_BUCKETS; index++)
+ for (var = NameHash[index]; var != NULL; var = next) {
+ next = var->nnext;
+ if (var->permanent) {
+ var->nnext = perm;
+ perm = var;
+ }
+ else {
+ free(var->name);
+ free(var);
+ }
+ }
+ bzero(NameHash, sizeof(NameHash));
+ bzero(ObjHash, sizeof(ObjHash));
+ tempcntr = 1;
+
+ for (var = perm; var != NULL; var = next) {
+ next = var->nnext;
+ index = hash_name(var->name);
+ var->nnext = NameHash[index];
+ NameHash[index] = var;
+ if (var->map_back) {
+ index = hash_obj(var->obj);
+ var->onext = ObjHash[index];
+ ObjHash[index] = var;
+ }
+ }
+}
+
+struct var *lookup_by_name(name)
+char *name;
+{
+ struct var *var;
+
+ for (var = NameHash[hash_name(name)]; var != NULL; var = var->nnext)
+ if (strcmp(var->name, name) == 0)
+ return var;
+ return NULL;
+}
+
+struct var *lookup_by_obj(obj)
+lispobj obj;
+{
+ struct var *var;
+
+ for (var = ObjHash[hash_obj(obj)]; var != NULL; var = var->onext)
+ if (var->obj == obj)
+ return var;
+ return NULL;
+}
+
+static struct var *make_var(char *name, boolean perm)
+{
+ struct var *var = (struct var *)malloc(sizeof(struct var));
+ char buffer[256];
+ int index;
+
+ if (name == NULL) {
+ sprintf(buffer, "%d", tempcntr++);
+ name = buffer;
+ }
+ var->name = (char *)malloc(strlen(name)+1);
+ strcpy(var->name, name);
+ var->clock = 0;
+ var->permanent = perm;
+ var->map_back = 0;
+
+ index = hash_name(name);
+ var->nnext = NameHash[index];
+ NameHash[index] = var;
+
+ return var;
+}
+
+struct var *define_var(char *name, lispobj obj, boolean perm)
+{
+ struct var *var = make_var(name, perm);
+ int index;
+
+ var->obj = obj;
+ var->update_fn = NULL;
+
+ if (lookup_by_obj(obj) == NULL) {
+ var->map_back = 1;
+ index = hash_obj(obj);
+ var->onext = ObjHash[index];
+ ObjHash[index] = var;
+ }
+
+ return var;
+}
+
+struct var *define_dynamic_var(char *name, lispobj updatefn(struct var *),
+ boolean perm)
+{
+ struct var *var = make_var(name, perm);
+
+ var->update_fn = updatefn;
+
+ return var;
+}
+
+char *var_name(struct var *var)
+{
+ return var->name;
+}
+
+lispobj var_value(struct var *var)
+{
+ if (var->update_fn != NULL)
+ var->obj = (*var->update_fn)(var);
+ return var->obj;
+}
+
+long var_clock(struct var *var)
+{
+ return var->clock;
+}
+
+void var_setclock(struct var *var, long val)
+{
+ var->clock = val;
+}
--- /dev/null
+/*
+ * This software is part of the SBCL system. See the README file for
+ * more information.
+ *
+ * This software is derived from the CMU CL system, which was
+ * written at Carnegie Mellon University and released into the
+ * public domain. The software is in the public domain and is
+ * provided with absolutely no warranty. See the COPYING and CREDITS
+ * files for more information.
+ */
+
+/*
+ * $Header$
+ */
+
+/* FIXME: I wonder what this stuff is for. A comment or two would be
+ * nice.. */
+
+extern void flush_vars(void);
+extern struct var *lookup_by_name(char *name);
+extern struct var *lookup_by_obj(lispobj obj);
+extern struct var *define_var(char *name, lispobj obj, boolean perm);
+extern struct var *define_dynamic_var(char *name,
+ lispobj update_fn(struct var *var),
+ boolean perm);
+
+extern char *var_name(struct var *var);
+extern lispobj var_value(struct var *var);
+extern long var_clock(struct var *var);
+extern void var_setclock(struct var *var, long value);
--- /dev/null
+/*
+ * This software is part of the SBCL system. See the README file for
+ * more information.
+ *
+ * This software is derived from the CMU CL system, which was
+ * written at Carnegie Mellon University and released into the
+ * public domain. The software is in the public domain and is
+ * provided with absolutely no warranty. See the COPYING and CREDITS
+ * files for more information.
+ */
+
+/*
+ * $Header$
+ */
+
+#include <stdio.h>
+
+#include "runtime.h"
+#include "globals.h"
+#include "validate.h"
+#include "os.h"
+#include "sbcl.h"
+#include "arch.h"
+#include "lispregs.h"
+#include "signal.h"
+#include "alloc.h"
+#include "interrupt.h"
+#include "interr.h"
+#include "breakpoint.h"
+
+#define BREAKPOINT_INST 0xcc /* INT3 */
+
+unsigned long fast_random_state = 1;
+
+void arch_init(void)
+{}
+\f
+/*
+ * hacking signal contexts
+ *
+ * (This depends both on architecture, which determines what we might
+ * want to get to, and on OS, which determines how we get to it.)
+ */
+
+int *
+context_eflags_addr(os_context_t *context)
+{
+#if defined __linux__
+ /* KLUDGE: As of kernel 2.2.14 on Red Hat 6.2, there's code in the
+ * <sys/ucontext.h> file to define symbolic names for offsets into
+ * gregs[], but it's conditional on __USE_GNU and not defined, so
+ * we need to do this nasty absolute index magic number thing
+ * instead. */
+ return &context->uc_mcontext.gregs[16];
+#elif defined __FreeBSD__
+ return &context->uc_mcontext.mc_eflags;
+#elif defined __OpenBSD__
+ return &context->sc_eflags;
+#else
+#error unsupported OS
+#endif
+}
+\f
+void arch_skip_instruction(os_context_t *context)
+{
+ /* Assuming we get here via an INT3 xxx instruction, the PC now
+ * points to the interrupt code (a Lisp value) so we just move
+ * past it. Skip the code; after that, if the code is an
+ * error-trap or cerror-trap then skip the data bytes that follow. */
+
+ int vlen;
+ int code;
+
+ FSHOW((stderr, "[arch_skip_inst at %x]\n", *os_context_pc_addr(context)));
+
+ /* Get and skip the Lisp interrupt code. */
+ code = *(char*)(*os_context_pc_addr(context))++;
+ switch (code)
+ {
+ case trap_Error:
+ case trap_Cerror:
+ /* Lisp error arg vector length */
+ vlen = *(char*)(*os_context_pc_addr(context))++;
+ /* Skip Lisp error arg data bytes. */
+ while (vlen-- > 0) {
+ (char*)(*os_context_pc_addr(context))++;
+ }
+ break;
+
+ case trap_Breakpoint: /* not tested */
+ case trap_FunctionEndBreakpoint: /* not tested */
+ break;
+
+ case trap_PendingInterrupt:
+ case trap_Halt:
+ /* only needed to skip the Code */
+ break;
+
+ default:
+ fprintf(stderr,"[arch_skip_inst invalid code %d\n]\n",code);
+ break;
+ }
+
+ FSHOW((stderr,
+ "[arch_skip_inst resuming at %x]\n",
+ *os_context_pc_addr(context)));
+}
+
+unsigned char *
+arch_internal_error_arguments(os_context_t *context)
+{
+ return 1 + (unsigned char *)(*os_context_pc_addr(context));
+}
+
+boolean
+arch_pseudo_atomic_atomic(os_context_t *context)
+{
+ return SymbolValue(PSEUDO_ATOMIC_ATOMIC);
+}
+
+void
+arch_set_pseudo_atomic_interrupted(os_context_t *context)
+{
+ SetSymbolValue(PSEUDO_ATOMIC_INTERRUPTED, make_fixnum(1));
+}
+\f
+/*
+ * This stuff seems to get called for TRACE and debug activity.
+ */
+
+unsigned long
+arch_install_breakpoint(void *pc)
+{
+ unsigned long result = *(unsigned long*)pc;
+
+ *(char*)pc = BREAKPOINT_INST; /* x86 INT3 */
+ *((char*)pc+1) = trap_Breakpoint; /* Lisp trap code */
+
+ return result;
+}
+
+void
+arch_remove_breakpoint(void *pc, unsigned long orig_inst)
+{
+ *((char *)pc) = orig_inst & 0xff;
+ *((char *)pc + 1) = (orig_inst & 0xff00) >> 8;
+}
+\f
+/* When single stepping, single_stepping holds the original instruction
+ * PC location. */
+unsigned int *single_stepping=NULL;
+#ifndef __linux__
+unsigned int single_step_save1;
+unsigned int single_step_save2;
+unsigned int single_step_save3;
+#endif
+
+void
+arch_do_displaced_inst(os_context_t *context, unsigned long orig_inst)
+{
+ unsigned int *pc = (unsigned int*)(*os_context_pc_addr(context));
+
+ /* Put the original instruction back. */
+ *((char *)pc) = orig_inst & 0xff;
+ *((char *)pc + 1) = (orig_inst & 0xff00) >> 8;
+
+#ifdef __linux__
+ *context_eflags_addr(context) |= 0x100;
+#else
+ /* Install helper instructions for the single step:
+ * pushf; or [esp],0x100; popf. */
+ single_step_save1 = *(pc-3);
+ single_step_save2 = *(pc-2);
+ single_step_save3 = *(pc-1);
+ *(pc-3) = 0x9c909090;
+ *(pc-2) = 0x00240c81;
+ *(pc-1) = 0x9d000001;
+#endif
+
+ single_stepping = (unsigned int*)pc;
+
+#ifndef __linux__
+ *os_context_pc_addr(context) = (char *)pc - 9;
+#endif
+}
+\f
+void
+sigtrap_handler(int signal, siginfo_t *info, void *void_context)
+{
+ int code = info->si_code;
+ os_context_t *context = (os_context_t*)void_context;
+ unsigned int trap;
+
+ SHOW("entering sigtrap_handler(..)"); /* REMOVEME */
+
+ if (single_stepping && (signal==SIGTRAP))
+ {
+ /* fprintf(stderr,"* single step trap %x\n", single_stepping); */
+
+#ifndef __linux__
+ /* Un-install single step helper instructions. */
+ *(single_stepping-3) = single_step_save1;
+ *(single_stepping-2) = single_step_save2;
+ *(single_stepping-1) = single_step_save3;
+#else
+ *context_eflags_addr(context) ^= 0x100;
+#endif
+ /* Re-install the breakpoint if possible. */
+ if (*os_context_pc_addr(context) == (int)single_stepping + 1) {
+ fprintf(stderr, "warning: couldn't reinstall breakpoint\n");
+ } else {
+ char *ptr = (char*)single_stepping;
+ *((char *)single_stepping) = BREAKPOINT_INST; /* x86 INT3 */
+ *((char *)single_stepping+1) = trap_Breakpoint;
+ }
+
+ single_stepping = NULL;
+ return;
+ }
+
+ /* This is just for info in case the monitor wants to print an
+ * approximation. */
+ current_control_stack_pointer =
+ (lispobj*)*os_context_sp_addr(context);
+
+ /* On entry %eip points just after the INT3 byte and aims at the
+ * 'kind' value (eg trap_Cerror). For error-trap and Cerror-trap a
+ * number of bytes will follow, the first is the length of the byte
+ * arguments to follow. */
+ trap = *(unsigned char *)(*os_context_pc_addr(context));
+ switch (trap) {
+
+ case trap_PendingInterrupt:
+ FSHOW((stderr, "<trap pending interrupt>\n"));
+ arch_skip_instruction(context);
+ interrupt_handle_pending(context);
+ break;
+
+ case trap_Halt:
+ /* Note: the old CMU CL code tried to save FPU state
+ * here, and restore it after we do our thing, but there
+ * seems to be no point in doing that, since we're just
+ * going to lose(..) anyway. */
+ SHOW("in trap_Halt case of sigtrap_handler(..)"); /* REMOVEME */
+ fake_foreign_function_call(context);
+ lose("%%primitive halt called; the party is over.");
+
+ case trap_Error:
+ case trap_Cerror:
+ FSHOW((stderr, "<trap error/cerror %d>\n", code));
+ interrupt_internal_error(signal, info, context, code==trap_Cerror);
+ break;
+
+ case trap_Breakpoint:
+ (char*)(*os_context_pc_addr(context)) -= 1;
+ handle_breakpoint(signal, info, context);
+ break;
+
+ case trap_FunctionEndBreakpoint:
+ (char*)(*os_context_pc_addr(context)) -= 1;
+ *os_context_pc_addr(context) =
+ (int)handle_function_end_breakpoint(signal, info, context);
+ break;
+
+ default:
+ FSHOW((stderr,"[C--trap default %d %d %x]\n",
+ signal, code, context));
+ interrupt_handle_now(signal, info, context);
+ break;
+ }
+ SHOW("leaving sigtrap_handler(..)"); /* REMOVEME */
+}
+
+void
+arch_install_interrupt_handlers()
+{
+ interrupt_install_low_level_handler(SIGILL , sigtrap_handler);
+ interrupt_install_low_level_handler(SIGTRAP, sigtrap_handler);
+}
+\f
+/* This is implemented in assembly language and called from C: */
+extern lispobj
+call_into_lisp(lispobj fun, lispobj *args, int nargs);
+
+/* These functions are an interface to the Lisp call-in facility.
+ * Since this is C we can know nothing about the calling environment.
+ * The control stack might be the C stack if called from the monitor
+ * or the Lisp stack if called as a result of an interrupt or maybe
+ * even a separate stack. The args are most likely on that stack but
+ * could be in registers depending on what the compiler likes. So we
+ * copy the args into a portable vector and let the assembly language
+ * call-in function figure it out. */
+lispobj
+funcall0(lispobj function)
+{
+ lispobj *args = NULL;
+
+ return call_into_lisp(function, args, 0);
+}
+lispobj
+funcall1(lispobj function, lispobj arg0)
+{
+ lispobj args[1];
+ args[0] = arg0;
+ return call_into_lisp(function, args, 1);
+}
+lispobj
+funcall2(lispobj function, lispobj arg0, lispobj arg1)
+{
+ lispobj args[2];
+ args[0] = arg0;
+ args[1] = arg1;
+ return call_into_lisp(function, args, 2);
+}
+lispobj
+funcall3(lispobj function, lispobj arg0, lispobj arg1, lispobj arg2)
+{
+ lispobj args[3];
+ args[0] = arg0;
+ args[1] = arg1;
+ args[2] = arg2;
+ return call_into_lisp(function, args, 3);
+}
--- /dev/null
+/*
+ * very-low-level utilities for runtime support
+ *
+ * $Header$
+ */
+
+/*
+ * This software is part of the SBCL system. See the README file for
+ * more information.
+ *
+ * This software is derived from the CMU CL system, which was
+ * written at Carnegie Mellon University and released into the
+ * public domain. The software is in the public domain and is
+ * provided with absolutely no warranty. See the COPYING and CREDITS
+ * files for more information.
+ */
+\f
+#include "x86-validate.h"
+
+#define LANGUAGE_ASSEMBLY
+#include "sbcl.h"
+
+/* Minimize conditionalization for different OS naming schemes. */
+#if defined __linux__ || defined __FreeBSD__ /* (but *not* OpenBSD) */
+#define GNAME(var) var
+#else
+#define GNAME(var) _##var
+#endif
+
+/* Get the right type of alignment. Linux and FreeBSD (but not OpenBSD)
+ * want alignment in bytes. */
+#if defined(__linux__) || defined(__FreeBSD__)
+#define align_4byte 4
+#define align_8byte 8
+#define align_16byte 16
+#else
+#define align_4byte 2
+#define align_8byte 3
+#define align_16byte 4
+#endif
+
+ .text
+ .global GNAME(foreign_function_call_active)
+
+\f
+/*
+ * A call to call_into_c preserves esi, edi, and ebp.
+ * (The C function will preserve ebx, esi, edi, and ebp across its
+ * function call, but we trash ebx ourselves by using it to save the
+ * return Lisp address.)
+ *
+ * Return values are in eax and maybe edx for quads, or st(0) for
+ * floats.
+ *
+ * This should work for Lisp calls C calls Lisp calls C..
+ */
+ .text
+ .align align_16byte,0x90
+ .global GNAME(call_into_c)
+ .type GNAME(call_into_c),@function
+GNAME(call_into_c):
+ movl $1,GNAME(foreign_function_call_active)
+
+/* Save the return Lisp address in ebx. */
+ popl %ebx
+
+/* Setup the NPX for C */
+ fstp %st(0)
+ fstp %st(0)
+ fstp %st(0)
+ fstp %st(0)
+ fstp %st(0)
+ fstp %st(0)
+ fstp %st(0)
+ fstp %st(0)
+
+ call *%eax # normal callout using Lisp stack
+
+ movl %eax,%ecx # remember integer return value
+
+/* Check for a return FP value. */
+ fxam
+ fnstsw %eax
+ andl $0x4500,%eax
+ cmpl $0x4100,%eax
+ jne Lfp_rtn_value
+
+/* The return value is in eax, or eax,edx? */
+/* Set up the NPX stack for Lisp. */
+ fldz # Ensure no regs are empty.
+ fldz
+ fldz
+ fldz
+ fldz
+ fldz
+ fldz
+ fldz
+
+/* Restore the return value. */
+ movl %ecx,%eax # maybe return value
+
+ movl $0,GNAME(foreign_function_call_active)
+/* Return. */
+ jmp *%ebx
+
+Lfp_rtn_value:
+/* The return result is in st(0). */
+/* Set up the NPX stack for Lisp, placing the result in st(0). */
+ fldz # Ensure no regs are empty.
+ fldz
+ fldz
+ fldz
+ fldz
+ fldz
+ fldz
+ fxch %st(7) # Move the result back to st(0).
+
+/* We don't need to restore eax, because the result is in st(0). */
+
+ movl $0,GNAME(foreign_function_call_active)
+/* Return. */
+ jmp *%ebx
+
+ .size GNAME(call_into_c), . - GNAME(call_into_c)
+
+\f
+ .text
+ .global GNAME(call_into_lisp)
+ .type GNAME(call_into_lisp),@function
+
+/* The C conventions require that ebx, esi, edi, and ebp be preserved
+ * across function calls. */
+/* The *ALIEN-STACK* pointer is set up on the first call_into_lisp when
+ * the stack changes. */
+
+ .align align_16byte,0x90
+GNAME(call_into_lisp):
+ pushl %ebp # Save old frame pointer.
+ movl %esp,%ebp # Establish new frame.
+
+/* Save the NPX state */
+ fwait # Catch any pending NPX exceptions.
+ subl $108,%esp # Make room for the NPX state.
+ fnsave (%esp) # resets NPX
+
+ movl (%esp),%eax # Load NPX control word.
+ andl $0xfffff3ff,%eax # Set rounding mode to nearest.
+ orl $0x00000300,%eax # Set precision to 64 bits.
+ pushl %eax
+ fldcw (%esp) # Recover modes.
+ popl %eax
+
+ fldz # Ensure no FP regs are empty.
+ fldz
+ fldz
+ fldz
+ fldz
+ fldz
+ fldz
+ fldz
+
+/* Save C regs: ebx esi edi. */
+ pushl %ebx
+ pushl %esi
+ pushl %edi
+
+/* Clear descriptor regs. */
+ xorl %eax,%eax # lexenv
+ xorl %ebx,%ebx # available
+ xorl %ecx,%ecx # arg count
+ xorl %edx,%edx # first arg
+ xorl %edi,%edi # second arg
+ xorl %esi,%esi # third arg
+
+/* no longer in function call */
+ movl %eax, GNAME(foreign_function_call_active)
+
+ movl %esp,%ebx # remember current stack
+ cmpl $CONTROL_STACK_START,%esp
+ jbe ChangeToLispStack
+ cmpl $CONTROL_STACK_END,%esp
+ jbe OnLispStack
+ChangeToLispStack:
+ /* Setup the *alien-stack* pointer */
+ movl %esp,ALIEN_STACK + SYMBOL_VALUE_OFFSET
+ movl $CONTROL_STACK_END,%esp # new stack
+OnLispStack:
+ pushl %ebx # Save entry stack on (maybe) new stack.
+
+ /* Establish Lisp args. */
+ movl 8(%ebp),%eax # lexenv?
+ movl 12(%ebp),%ebx # address of arg vec
+ movl 16(%ebp),%ecx # num args
+ shll $2,%ecx # Make num args into fixnum.
+ cmpl $0,%ecx
+ je Ldone
+ movl (%ebx),%edx # arg0
+ cmpl $4,%ecx
+ je Ldone
+ movl 4(%ebx),%edi # arg1
+ cmpl $8,%ecx
+ je Ldone
+ movl 8(%ebx),%esi # arg2
+Ldone:
+ /* Registers eax, ecx, edx, edi, and esi are now live. */
+
+ /* Alloc new frame. */
+ mov %esp,%ebx # The current sp marks start of new frame.
+ push %ebp # fp in save location S0
+ sub $8,%esp # Ensure 3 slots are allocated, one above.
+ mov %ebx,%ebp # Switch to new frame.
+
+ /* Indirect the closure. */
+ call *CLOSURE_FUNCTION_OFFSET(%eax)
+
+ /* Multi-value return; blow off any extra values. */
+ mov %ebx, %esp
+ /* single value return */
+
+/* Restore the stack, in case there was a stack change. */
+ popl %esp # c-sp
+
+/* Restore C regs: ebx esi edi. */
+ popl %edi
+ popl %esi
+ popl %ebx
+
+/* Restore the NPX state. */
+ frstor (%esp)
+ addl $108, %esp
+
+ popl %ebp # c-sp
+ movl %edx,%eax # c-val
+ ret
+ .size GNAME(call_into_lisp), . - GNAME(call_into_lisp)
+\f
+/* support for saving and restoring the NPX state from C */
+ .text
+ .global GNAME(fpu_save)
+ .type GNAME(fpu_save),@function
+ .align 2,0x90
+GNAME(fpu_save):
+ movl 4(%esp),%eax
+ fnsave (%eax) # Save the NPX state. (resets NPX)
+ ret
+ .size GNAME(fpu_save),.-GNAME(fpu_save)
+
+ .global GNAME(fpu_restore)
+ .type GNAME(fpu_restore),@function
+ .align 2,0x90
+GNAME(fpu_restore):
+ movl 4(%esp),%eax
+ frstor (%eax) # Restore the NPX state.
+ ret
+ .size GNAME(fpu_restore),.-GNAME(fpu_restore)
+\f
+/*
+ * the undefined-function trampoline
+ */
+ .text
+ .align align_4byte,0x90
+ .global GNAME(undefined_tramp)
+ .type GNAME(undefined_tramp),@function
+GNAME(undefined_tramp):
+ int3
+ .byte trap_Error
+ .byte 2
+#ifdef type_LongFloat
+ .byte 24
+#else
+ .byte 23
+#endif
+ .byte sc_DescriptorReg # eax in the Descriptor-reg SC
+ ret
+ .size GNAME(undefined_tramp), .-GNAME(undefined_tramp)
+
+/*
+ * the closure trampoline
+ */
+ .text
+ .align align_4byte,0x90
+ .global GNAME(closure_tramp)
+ .type GNAME(closure_tramp),@function
+GNAME(closure_tramp):
+ movl FDEFN_FUNCTION_OFFSET(%eax),%eax
+ /* FIXME: The '*' after "jmp" in the next line is from PVE's
+ * patch posted to the CMU CL mailing list Oct 6, 1999. It looks
+ * reasonable, and it certainly seems as though if CMU CL needs it,
+ * SBCL needs it too, but I haven't actually verified that it's
+ * right. It would be good to find a way to force the flow of
+ * control through here to test it. */
+ jmp *CLOSURE_FUNCTION_OFFSET(%eax)
+ .size GNAME(closure_tramp), .-GNAME(closure_tramp)
+
+/*
+ * function-end breakpoint magic
+ */
+ .text
+ .global GNAME(function_end_breakpoint_guts)
+ .align align_4byte
+GNAME(function_end_breakpoint_guts):
+ /* Multiple Value return */
+ jmp multiple_value_return
+ /* Single value return: The eventual return will now use the
+ multiple values return convention but with a return values
+ count of one. */
+ movl %esp,%ebx # Setup ebx - the ofp.
+ subl $4,%esp # Allocate one stack slot for the return value
+ movl $4,%ecx # Setup ecx for one return value.
+ movl $NIL,%edi # default second value
+ movl $NIL,%esi # default third value
+
+multiple_value_return:
+
+ .global GNAME(function_end_breakpoint_trap)
+GNAME(function_end_breakpoint_trap):
+ int3
+ .byte trap_FunctionEndBreakpoint
+ hlt # We should never return here.
+
+ .global GNAME(function_end_breakpoint_end)
+GNAME(function_end_breakpoint_end):
+
+\f
+ .global GNAME(do_pending_interrupt)
+ .type GNAME(do_pending_interrupt),@function
+ .align align_4byte,0x90
+GNAME(do_pending_interrupt):
+ int3
+ .byte trap_PendingInterrupt
+ ret
+ .size GNAME(do_pending_interrupt),.-GNAME(do_pending_interrupt)
+\f
+#ifdef WANT_CGC
+/* This is a copy function which is optimized for the Pentium and
+ * works OK on 486 as well. This assumes (does not check) that the
+ * input byte count is a multiple of 8 bytes (one Lisp object).
+ * This code takes advantage of pairing in the Pentium as well
+ * as the 128-bit cache line.
+ */
+ .global GNAME(fastcopy16)
+ .type GNAME(fastcopy16),@function
+ .align align_4byte,0x90
+GNAME(fastcopy16):
+ pushl %ebp
+ movl %esp,%ebp
+ movl 8(%ebp), %edx # dst
+ movl 12(%ebp),%eax # src
+ movl 16(%ebp),%ecx # bytes
+ pushl %ebx
+ pushl %esi
+ pushl %edi
+ movl %edx,%edi
+ movl %eax,%esi
+ sarl $3,%ecx # number 8-byte units
+ testl $1,%ecx # odd?
+ jz Lquad
+ movl (%esi),%eax
+ movl 4(%esi),%ebx
+ movl %eax,(%edi)
+ movl %ebx,4(%edi)
+ leal 8(%esi),%esi
+ leal 8(%edi),%edi
+Lquad: sarl $1,%ecx # count 16-byte units
+ jz Lend
+ movl %ecx,%ebp # use ebp for loop counter
+ .align align_16byte,0x90
+Ltop:
+ movl (%edi),%eax # prefetch! MAJOR Pentium win..
+ movl (%esi),%eax
+ movl 4(%esi),%ebx
+ movl 8(%esi),%ecx
+ movl 12(%esi),%edx
+ movl %eax, (%edi)
+ movl %ebx, 4(%edi)
+ movl %ecx, 8(%edi)
+ movl %edx,12(%edi)
+ leal 16(%esi),%esi
+ leal 16(%edi),%edi
+ decl %ebp
+ jnz Ltop # non-prefixed jump saves cycles
+Lend:
+ popl %edi
+ popl %esi
+ popl %ebx
+ popl %ebp
+ ret
+ .size GNAME(fastcopy16),.-GNAME(fastcopy16)
+#endif
+\f
+#ifdef GENCGC
+/* This is a fast bzero using the FPU. The first argument is the start
+ * address which needs to be aligned on an 8 byte boundary, the second
+ * argument is the number of bytes, which must be a nonzero multiple
+ * of 8 bytes. */
+ .text
+ .globl GNAME(i586_bzero)
+ .type GNAME(i586_bzero),@function
+ .align align_4byte,0x90
+GNAME(i586_bzero):
+ movl 4(%esp),%edx # Load the start address.
+ movl 8(%esp),%eax # Load the number of bytes.
+ fldz
+l1: fstl 0(%edx)
+ addl $8,%edx
+ subl $8,%eax
+ jnz l1
+ fstp %st(0)
+ ret
+ .size GNAME(i586_bzero),.-GNAME(i586_bzero)
+#endif
+\f
+
+/*
+ * Allocate bytes and return the start of the allocated space
+ * in the specified destination register.
+ *
+ * In the general case the size will be in the destination register.
+ *
+ * All registers must be preserved except the destination.
+ * The C conventions will preserve ebx, esi, edi, and ebp.
+ * So only eax, ecx, and edx need special care here.
+ */
+
+ .globl GNAME(alloc_to_eax)
+ .type GNAME(alloc_to_eax),@function
+ .align align_4byte,0x90
+GNAME(alloc_to_eax):
+ pushl %ecx # Save ecx and edx as C could destroy them.
+ pushl %edx
+ pushl %eax # Push the size.
+ call GNAME(alloc)
+ addl $4,%esp # Pop the size arg.
+ popl %edx # Restore ecx and edx.
+ popl %ecx
+ ret
+ .size GNAME(alloc_to_eax),.-GNAME(alloc_to_eax)
+
+ .globl GNAME(alloc_8_to_eax)
+ .type GNAME(alloc_8_to_eax),@function
+ .align align_4byte,0x90
+GNAME(alloc_8_to_eax):
+ pushl %ecx # Save ecx and edx as C could destroy them.
+ pushl %edx
+ pushl $8 # Push the size.
+ call GNAME(alloc)
+ addl $4,%esp # Pop the size arg.
+ popl %edx # Restore ecx and edx.
+ popl %ecx
+ ret
+ .size GNAME(alloc_8_to_eax),.-GNAME(alloc_8_to_eax)
+
+ .globl GNAME(alloc_8_to_eax)
+ .type GNAME(alloc_8_to_eax),@function
+ .align align_4byte,0x90
+
+ .globl GNAME(alloc_16_to_eax)
+ .type GNAME(alloc_16_to_eax),@function
+ .align align_4byte,0x90
+GNAME(alloc_16_to_eax):
+ pushl %ecx # Save ecx and edx as C could destroy them.
+ pushl %edx
+ pushl $16 # Push the size.
+ call GNAME(alloc)
+ addl $4,%esp # Pop the size arg.
+ popl %edx # Restore ecx and edx.
+ popl %ecx
+ ret
+ .size GNAME(alloc_16_to_eax),.-GNAME(alloc_16_to_eax)
+
+ .globl GNAME(alloc_to_ecx)
+ .type GNAME(alloc_to_ecx),@function
+ .align align_4byte,0x90
+GNAME(alloc_to_ecx):
+ pushl %eax # Save eax and edx as C could destroy them.
+ pushl %edx
+ pushl %ecx # Push the size.
+ call GNAME(alloc)
+ addl $4,%esp # Pop the size arg.
+ movl %eax,%ecx # Set up the destination.
+ popl %edx # Restore eax and edx.
+ popl %eax
+ ret
+ .size GNAME(alloc_to_ecx),.-GNAME(alloc_to_ecx)
+
+ .globl GNAME(alloc_8_to_ecx)
+ .type GNAME(alloc_8_to_ecx),@function
+ .align align_4byte,0x90
+GNAME(alloc_8_to_ecx):
+ pushl %eax # Save eax and edx as C could destroy them.
+ pushl %edx
+ pushl $8 # Push the size.
+ call GNAME(alloc)
+ addl $4,%esp # Pop the size arg.
+ movl %eax,%ecx # Set up the destination.
+ popl %edx # Restore eax and edx.
+ popl %eax
+ ret
+ .size GNAME(alloc_8_to_ecx),.-GNAME(alloc_8_to_ecx)
+
+ .globl GNAME(alloc_16_to_ecx)
+ .type GNAME(alloc_16_to_ecx),@function
+ .align align_4byte,0x90
+GNAME(alloc_16_to_ecx):
+ pushl %eax # Save eax and edx as C could destroy them.
+ pushl %edx
+ pushl $16 # Push the size.
+ call GNAME(alloc)
+ addl $4,%esp # Pop the size arg.
+ movl %eax,%ecx # Set up the destination.
+ popl %edx # Restore eax and edx.
+ popl %eax
+ ret
+ .size GNAME(alloc_16_to_ecx),.-GNAME(alloc_16_to_ecx)
+
+
+ .globl GNAME(alloc_to_edx)
+ .type GNAME(alloc_to_edx),@function
+ .align align_4byte,0x90
+GNAME(alloc_to_edx):
+ pushl %eax # Save eax and ecx as C could destroy them.
+ pushl %ecx
+ pushl %edx # Push the size.
+ call GNAME(alloc)
+ addl $4,%esp # Pop the size arg.
+ movl %eax,%edx # Set up the destination.
+ popl %ecx # Restore eax and ecx.
+ popl %eax
+ ret
+ .size GNAME(alloc_to_edx),.-GNAME(alloc_to_edx)
+
+ .globl GNAME(alloc_8_to_edx)
+ .type GNAME(alloc_8_to_edx),@function
+ .align align_4byte,0x90
+GNAME(alloc_8_to_edx):
+ pushl %eax # Save eax and ecx as C could destroy them.
+ pushl %ecx
+ pushl $8 # Push the size.
+ call GNAME(alloc)
+ addl $4,%esp # Pop the size arg.
+ movl %eax,%edx # Set up the destination.
+ popl %ecx # Restore eax and ecx.
+ popl %eax
+ ret
+ .size GNAME(alloc_8_to_edx),.-GNAME(alloc_8_to_edx)
+
+ .globl GNAME(alloc_16_to_edx)
+ .type GNAME(alloc_16_to_edx),@function
+ .align align_4byte,0x90
+GNAME(alloc_16_to_edx):
+ pushl %eax # Save eax and ecx as C could destroy them.
+ pushl %ecx
+ pushl $16 # Push the size.
+ call GNAME(alloc)
+ addl $4,%esp # Pop the size arg.
+ movl %eax,%edx # Set up the destination.
+ popl %ecx # Restore eax and ecx.
+ popl %eax
+ ret
+ .size GNAME(alloc_16_to_edx),.-GNAME(alloc_16_to_edx)
+
+
+
+ .globl GNAME(alloc_to_ebx)
+ .type GNAME(alloc_to_ebx),@function
+ .align align_4byte,0x90
+GNAME(alloc_to_ebx):
+ pushl %eax # Save eax, ecx, and edx as C could destroy them.
+ pushl %ecx
+ pushl %edx
+ pushl %ebx # Push the size.
+ call GNAME(alloc)
+ addl $4,%esp # Pop the size arg.
+ movl %eax,%ebx # Set up the destination.
+ popl %edx # Restore eax, ecx and edx.
+ popl %ecx
+ popl %eax
+ ret
+ .size GNAME(alloc_to_ebx),.-GNAME(alloc_to_ebx)
+
+ .globl GNAME(alloc_8_to_ebx)
+ .type GNAME(alloc_8_to_ebx),@function
+ .align align_4byte,0x90
+GNAME(alloc_8_to_ebx):
+ pushl %eax # Save eax, ecx, and edx as C could destroy them.
+ pushl %ecx
+ pushl %edx
+ pushl $8 # Push the size.
+ call GNAME(alloc)
+ addl $4,%esp # Pop the size arg.
+ movl %eax,%ebx # Set up the destination.
+ popl %edx # Restore eax, ecx and edx.
+ popl %ecx
+ popl %eax
+ ret
+ .size GNAME(alloc_8_to_ebx),.-GNAME(alloc_8_to_ebx)
+
+ .globl GNAME(alloc_16_to_ebx)
+ .type GNAME(alloc_16_to_ebx),@function
+ .align align_4byte,0x90
+GNAME(alloc_16_to_ebx):
+ pushl %eax # Save eax, ecx, and edx as C could destroy them.
+ pushl %ecx
+ pushl %edx
+ pushl $16 # Push the size
+ call GNAME(alloc)
+ addl $4,%esp # pop the size arg.
+ movl %eax,%ebx # setup the destination.
+ popl %edx # Restore eax, ecx and edx.
+ popl %ecx
+ popl %eax
+ ret
+ .size GNAME(alloc_16_to_ebx),.-GNAME(alloc_16_to_ebx)
+
+
+
+ .globl GNAME(alloc_to_esi)
+ .type GNAME(alloc_to_esi),@function
+ .align align_4byte,0x90
+GNAME(alloc_to_esi):
+ pushl %eax # Save eax, ecx, and edx as C could destroy them.
+ pushl %ecx
+ pushl %edx
+ pushl %esi # Push the size
+ call GNAME(alloc)
+ addl $4,%esp # pop the size arg.
+ movl %eax,%esi # setup the destination.
+ popl %edx # Restore eax, ecx and edx.
+ popl %ecx
+ popl %eax
+ ret
+ .size GNAME(alloc_to_esi),.-GNAME(alloc_to_esi)
+
+ .globl GNAME(alloc_8_to_esi)
+ .type GNAME(alloc_8_to_esi),@function
+ .align align_4byte,0x90
+GNAME(alloc_8_to_esi):
+ pushl %eax # Save eax, ecx, and edx as C could destroy them.
+ pushl %ecx
+ pushl %edx
+ pushl $8 # Push the size
+ call GNAME(alloc)
+ addl $4,%esp # pop the size arg.
+ movl %eax,%esi # setup the destination.
+ popl %edx # Restore eax, ecx and edx.
+ popl %ecx
+ popl %eax
+ ret
+ .size GNAME(alloc_8_to_esi),.-GNAME(alloc_8_to_esi)
+
+ .globl GNAME(alloc_16_to_esi)
+ .type GNAME(alloc_16_to_esi),@function
+ .align align_4byte,0x90
+GNAME(alloc_16_to_esi):
+ pushl %eax # Save eax, ecx, and edx as C could destroy them.
+ pushl %ecx
+ pushl %edx
+ pushl $16 # Push the size
+ call GNAME(alloc)
+ addl $4,%esp # pop the size arg.
+ movl %eax,%esi # setup the destination.
+ popl %edx # Restore eax, ecx and edx.
+ popl %ecx
+ popl %eax
+ ret
+ .size GNAME(alloc_16_to_esi),.-GNAME(alloc_16_to_esi)
+
+
+ .globl GNAME(alloc_to_edi)
+ .type GNAME(alloc_to_edi),@function
+ .align align_4byte,0x90
+GNAME(alloc_to_edi):
+ pushl %eax # Save eax, ecx, and edx as C could destroy them.
+ pushl %ecx
+ pushl %edx
+ pushl %edi # Push the size
+ call GNAME(alloc)
+ addl $4,%esp # pop the size arg.
+ movl %eax,%edi # setup the destination.
+ popl %edx # Restore eax, ecx and edx.
+ popl %ecx
+ popl %eax
+ ret
+ .size GNAME(alloc_to_edi),.-GNAME(alloc_to_edi)
+
+ .globl GNAME(alloc_8_to_edi)
+ .type GNAME(alloc_8_to_edi),@function
+ .align align_4byte,0x90
+GNAME(alloc_8_to_edi):
+ pushl %eax # Save eax, ecx, and edx as C could destroy them.
+ pushl %ecx
+ pushl %edx
+ pushl $8 # Push the size
+ call GNAME(alloc)
+ addl $4,%esp # pop the size arg.
+ movl %eax,%edi # setup the destination.
+ popl %edx # Restore eax, ecx and edx.
+ popl %ecx
+ popl %eax
+ ret
+ .size GNAME(alloc_8_to_edi),.-GNAME(alloc_8_to_edi)
+
+ .globl GNAME(alloc_16_to_edi)
+ .type GNAME(alloc_16_to_edi),@function
+ .align align_4byte,0x90
+GNAME(alloc_16_to_edi):
+ pushl %eax # Save eax, ecx, and edx as C could destroy them.
+ pushl %ecx
+ pushl %edx
+ pushl $16 # Push the size
+ call GNAME(alloc)
+ addl $4,%esp # pop the size arg.
+ movl %eax,%edi # setup the destination.
+ popl %edx # Restore eax, ecx and edx.
+ popl %ecx
+ popl %eax
+ ret
+ .size GNAME(alloc_16_to_edi),.-GNAME(alloc_16_to_edi)
+
+
+\f
+#ifdef GENCGC
+
+/* These routines are called from Lisp when an inline allocation
+ * overflows. Every register except the result needs to be preserved.
+ * We depend on C to preserve ebx, esi, edi, and ebp.
+ * But where necessary must save eax, ecx, edx. */
+
+/* This routine handles an overflow with eax=crfp+size. So the
+ * size=eax-crfp. */
+ .align align_4byte
+ .globl GNAME(alloc_overflow_eax)
+ .type GNAME(alloc_overflow_eax),@function
+GNAME(alloc_overflow_eax):
+ pushl %ecx # Save ecx
+ pushl %edx # Save edx
+ /* Calculate the size for the allocation. */
+ subl GNAME(current_region_free_pointer),%eax
+ pushl %eax # Push the size
+ call GNAME(alloc)
+ addl $4,%esp # pop the size arg.
+ popl %edx # Restore edx.
+ popl %ecx # Restore ecx.
+ addl $6,(%esp) # Adjust the return address to skip the next inst.
+ ret
+ .size GNAME(alloc_overflow_eax),.-GNAME(alloc_overflow_eax)
+
+/* This routine handles an overflow with ecx=crfp+size. So the
+ * size=ecx-crfp. */
+ .align align_4byte
+ .globl GNAME(alloc_overflow_ecx)
+ .type GNAME(alloc_overflow_ecx),@function
+GNAME(alloc_overflow_ecx):
+ pushl %eax # Save eax
+ pushl %edx # Save edx
+ /* Calculate the size for the allocation. */
+ subl GNAME(current_region_free_pointer),%ecx
+ pushl %ecx # Push the size
+ call GNAME(alloc)
+ addl $4,%esp # pop the size arg.
+ movl %eax,%ecx # setup the destination.
+ popl %edx # Restore edx.
+ popl %eax # Restore eax.
+ addl $6,(%esp) # Adjust the return address to skip the next inst.
+ ret
+ .size GNAME(alloc_overflow_ecx),.-GNAME(alloc_overflow_ecx)
+
+/* This routine handles an overflow with edx=crfp+size. So the
+ * size=edx-crfp. */
+ .align align_4byte
+ .globl GNAME(alloc_overflow_edx)
+ .type GNAME(alloc_overflow_edx),@function
+GNAME(alloc_overflow_edx):
+ pushl %eax # Save eax
+ pushl %ecx # Save ecx
+ /* Calculate the size for the allocation. */
+ subl GNAME(current_region_free_pointer),%edx
+ pushl %edx # Push the size
+ call GNAME(alloc)
+ addl $4,%esp # pop the size arg.
+ movl %eax,%edx # setup the destination.
+ popl %ecx # Restore ecx.
+ popl %eax # Restore eax.
+ addl $6,(%esp) # Adjust the return address to skip the next inst.
+ ret
+ .size GNAME(alloc_overflow_edx),.-GNAME(alloc_overflow_edx)
+
+/* This routine handles an overflow with ebx=crfp+size. So the
+ * size=ebx-crfp. */
+ .align align_4byte
+ .globl GNAME(alloc_overflow_ebx)
+ .type GNAME(alloc_overflow_ebx),@function
+GNAME(alloc_overflow_ebx):
+ pushl %eax # Save eax
+ pushl %ecx # Save ecx
+ pushl %edx # Save edx
+ /* Calculate the size for the allocation. */
+ subl GNAME(current_region_free_pointer),%ebx
+ pushl %ebx # Push the size
+ call GNAME(alloc)
+ addl $4,%esp # pop the size arg.
+ movl %eax,%ebx # setup the destination.
+ popl %edx # Restore edx.
+ popl %ecx # Restore ecx.
+ popl %eax # Restore eax.
+ addl $6,(%esp) # Adjust the return address to skip the next inst.
+ ret
+ .size GNAME(alloc_overflow_ebx),.-GNAME(alloc_overflow_ebx)
+
+/* This routine handles an overflow with esi=crfp+size. So the
+ * size=esi-crfp. */
+ .align align_4byte
+ .globl GNAME(alloc_overflow_esi)
+ .type GNAME(alloc_overflow_esi),@function
+GNAME(alloc_overflow_esi):
+ pushl %eax # Save eax
+ pushl %ecx # Save ecx
+ pushl %edx # Save edx
+ /* Calculate the size for the allocation. */
+ subl GNAME(current_region_free_pointer),%esi
+ pushl %esi # Push the size
+ call GNAME(alloc)
+ addl $4,%esp # pop the size arg.
+ movl %eax,%esi # setup the destination.
+ popl %edx # Restore edx.
+ popl %ecx # Restore ecx.
+ popl %eax # Restore eax.
+ addl $6,(%esp) # Adjust the return address to skip the next inst.
+ ret
+ .size GNAME(alloc_overflow_esi),.-GNAME(alloc_overflow_esi)
+
+/* This routine handles an overflow with edi=crfp+size. So the
+ * size=edi-crfp. */
+ .align align_4byte
+ .globl GNAME(alloc_overflow_edi)
+ .type GNAME(alloc_overflow_edi),@function
+GNAME(alloc_overflow_edi):
+ pushl %eax # Save eax
+ pushl %ecx # Save ecx
+ pushl %edx # Save edx
+ /* Calculate the size for the allocation. */
+ subl GNAME(current_region_free_pointer),%edi
+ pushl %edi # Push the size
+ call GNAME(alloc)
+ addl $4,%esp # pop the size arg.
+ movl %eax,%edi # setup the destination.
+ popl %edx # Restore edx.
+ popl %ecx # Restore ecx.
+ popl %eax # Restore eax.
+ addl $6,(%esp) # Adjust the return address to skip the next inst.
+ ret
+ .size GNAME(alloc_overflow_edi),.-GNAME(alloc_overflow_edi)
+
+#endif
+
+ .end
--- /dev/null
+/*
+ * These register names and offsets correspond to definitions in
+ * compiler/x86/vm.lisp. They map into accessors in the OS-dependent
+ * POSIX signal context structure os_context_t via the
+ * os_context_register_addr(..) OS-dependent function.
+ */
+
+/*
+ * This software is part of the SBCL system. See the README file for
+ * more information.
+ *
+ * This software is derived from the CMU CL system, which was
+ * written at Carnegie Mellon University and released into the
+ * public domain. The software is in the public domain and is
+ * provided with absolutely no warranty. See the COPYING and CREDITS
+ * files for more information.
+ */
+
+/*
+ * $Header$
+ */
+
+/* the number of registers visible as registers in the virtual machine
+ * (excludes stuff like segment registers) */
+#define NREGS (8)
+
+#ifdef LANGUAGE_ASSEMBLY
+#define REG(num) $ ## num
+#else
+#define REG(num) num
+#endif
+
+#define reg_EAX REG( 0)
+#define reg_ECX REG( 2)
+#define reg_EDX REG( 4)
+#define reg_EBX REG( 6)
+#define reg_ESP REG( 8)
+#define reg_EBP REG(10)
+#define reg_ESI REG(12)
+#define reg_EDI REG(14)
+
+#define REGNAMES "EAX", "ECX", "EDX", "EBX", "ESP", "EBP", "ESI", "EDI"
+
+/* classification of registers
+ *
+ * reg_SP = the register used by Lisp as stack pointer
+ * reg_FP = the register used by Lisp as frame pointer
+ * BOXED_REGISTERS =
+ * the registers which may contain Lisp object pointers */
+#define reg_SP reg_ESP
+#define reg_FP reg_EBP
+#define BOXED_REGISTERS {\
+ reg_EAX, reg_ECX, reg_EDX, reg_EBX, reg_ESI, reg_EDI \
+ }
--- /dev/null
+/*
+ * This software is part of the SBCL system. See the README file for
+ * more information.
+ *
+ * This software is derived from the CMU CL system, which was
+ * written at Carnegie Mellon University and released into the
+ * public domain. The software is in the public domain and is
+ * provided with absolutely no warranty. See the COPYING and CREDITS
+ * files for more information.
+ */
+
+/*
+ * $Header$
+ */
+\f
+/*
+ * Address map:
+ *
+ * FreeBSD:
+ * 0x00000000->0x0E000000 224M C program and memory allocation.
+ * 0x0E000000->0x10000000 32M Foreign segment.
+ * 0x10000000->0x20000000 256M Read-Only Space.
+ * 0x20000000->0x28000000 128M Reserved for shared libraries.
+ * 0x28000000->0x38000000 256M Static Space.
+ * 0x38000000->0x40000000 128M Binding stack growing up.
+ * 0x40000000->0x48000000 128M Control stack growing down.
+ * 0x48000000->0xC8000000 2GB Dynamic Space.
+ * 0xE0000000-> 256M C stack - Alien stack.
+ *
+ * Linux: Note that this map has some problems and requires some further
+ * development so is not implemented below.
+ * 0x00000000->0x08000000 128M Unused.
+ * 0x08000000->0x10000000 128M C program and memory allocation.
+ * 0x10000000->0x20000000 256M Read-Only Space.
+ * 0x20000000->0x28000000 128M Binding stack growing up.
+ * 0x28000000->0x38000000 256M Static Space.
+ * 0x38000000->0x40000000 128M Control stack growing down.
+ * 0x40000000->0x48000000 128M Reserved for shared libraries.
+ * 0x48000000->0xB8000000 1.75G Dynamic Space.
+ *
+ * FIXME: There's something wrong with addressing maps which are so
+ * brittle that they can be commented as fixed addresses. Try to
+ * parameterize these so they can be set at build time. */
+
+#if defined(__FreeBSD__) || defined(__OpenBSD__)
+#define READ_ONLY_SPACE_START (0x10000000)
+#define READ_ONLY_SPACE_SIZE (0x0ffff000) /* 256MB - 1 page */
+
+#define STATIC_SPACE_START (0x28000000)
+#define STATIC_SPACE_SIZE (0x0ffff000) /* 256MB - 1 page */
+
+#define BINDING_STACK_START (0x38000000)
+#define BINDING_STACK_SIZE (0x07fff000) /* 128MB - 1 page */
+
+#define CONTROL_STACK_START (0x40000000)
+#define CONTROL_STACK_SIZE (0x08000000) /* 128MB */
+
+#define DYNAMIC_0_SPACE_START (0x48000000)
+#ifdef GENCGC
+#define DYNAMIC_SPACE_SIZE (0x40000000) /* May be up to 2GB */
+#else
+#define DYNAMIC_SPACE_SIZE (0x04000000) /* 64MB */
+#endif
+#endif
+
+/* FIXME: It's gross to have numbers like 0x50000000 wired into the
+ * code in multiple places like this. (Not only does this file know
+ * about it, but Lisp code knows about it, because Lisp code is able
+ * to generate absolute addresses for all the static symbols even
+ * before it's read the map file.) I don't know whether I should
+ * actually *fix* this, but I should at least document it some with a
+ * KLUDGE marker. And it might even be fixable, by putting all this
+ * memory space arbitrariness into an architecture-dependent Lisp
+ * file. If so, perhaps I should write somewhere in a "design
+ * principles" or "coding principles" file that information like this
+ * always flows from Lisp code to C code, through sbcl.h. */
+#ifdef __linux__
+#define READ_ONLY_SPACE_START (0x01000000)
+#define READ_ONLY_SPACE_SIZE (0x02800000) /* 40MB */
+
+#define STATIC_SPACE_START (0x05000000)
+#define STATIC_SPACE_SIZE (0x02fff000) /* 48MB - 1 page */
+
+#define BINDING_STACK_START (0x60000000)
+#define BINDING_STACK_SIZE (0x07fff000) /* 128MB - 1 page */
+
+#define CONTROL_STACK_START (0x50000000)
+#define CONTROL_STACK_SIZE (0x07fff000) /* 128MB - 1 page */
+
+#define DYNAMIC_0_SPACE_START (0x09000000)
+#ifdef GENCGC
+#define DYNAMIC_SPACE_SIZE (0x20000000) /* 512MB */
+#else
+#define DYNAMIC_SPACE_SIZE (0x04000000) /* 64MB */
+#endif
+#endif
+
+#define CONTROL_STACK_END (CONTROL_STACK_START + CONTROL_STACK_SIZE)
+
+/* Note that GENCGC only uses dynamic_space 0. */
+#define DYNAMIC_1_SPACE_START (DYNAMIC_0_SPACE_START + DYNAMIC_SPACE_SIZE)
--- /dev/null
+;;;; build order
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+;;; This is a linear ordering of system sources which works both to
+;;; compile/load the cross-compiler under the host Common Lisp and to
+;;; cross-compile the compiler into the under-construction target
+;;; Common Lisp.
+;;;
+;;; Of course, it'd be very nice to have this be a dependency DAG
+;;; instead, so that we could do automated incremental recompilation.
+;;; But the dependencies are varied and subtle, and it'd be extremely
+;;; difficult to extract them automatically, and it'd be extremely
+;;; tedious and error-prone to extract them manually, so we don't
+;;; extract them. (It would be nice to fix this someday. The most
+;;; feasible approach that I can think of would be to make the
+;;; dependencies work on a package level, not an individual file
+;;; level. Doing it at the package level would make the granularity
+;;; coarse enough that it would probably be pretty easy to maintain
+;;; the dependency information manually, and the brittleness of the
+;;; package system would help make most violations of the declared
+;;; dependencies obvious at build time. -- WHN 20000803
+;;;
+;;; FIXME: Perhaps now that a significant number of files are built
+;;; in warm load instead of cold load, this file should now be called
+;;; cold-stems-and-flags.lisp-expr? Also, perhaps this file should move
+;;; into the src/cold/ directory?
+(
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ;;; miscellaneous
+
+ ;; This comes early because it's useful for debugging everywhere.
+ ("code/show")
+
+ ;; This comes early because the cross-compilation host's backquote logic
+ ;; expand into something which can't be executed on the target Lisp (e.g.
+ ;; in CMU CL where it expands into internal functions like BACKQ-LIST), and
+ ;; by replacing the host backquote logic with our own as early as possible,
+ ;; we minimize the chance of any forms referring to host Lisp internal
+ ;; functions leaking into target Lisp code.
+ ("code/backq")
+
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ;; various DEFSETFs and/or other DEFMACROish things, defined as early as
+ ;; possible so we don't need to fiddle with any subtleties of defining them
+ ;; before any possible use
+
+ ;; KLUDGE: It would be nice to reimplement most or all of these as
+ ;; functions (possibly inlined functions) so that we wouldn't need to
+ ;; worry so much about forcing them all to be defined before any possible
+ ;; use. It might be pretty tedious, though, working through any
+ ;; transforms and translators and optimizers and so forth to make sure
+ ;; that they can handle the change. -- WHN 19990919
+ ("code/defsetfs")
+
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ;;; cross-compiler-only replacements for stuff which in target Lisp would be
+ ;;; supplied by basic machinery
+
+ ("code/cross-misc" :not-target)
+ ("code/cross-float" :not-target)
+ ("code/cross-io" :not-target)
+ ("code/cross-sap" :not-target)
+
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ;;; stuff needed early both in cross-compilation host and in target Lisp
+
+ ("code/uncross")
+ ("code/early-defbangmethod")
+
+ ("code/parse-body") ; on host for PARSE-BODY
+ ("code/parse-defmacro") ; on host for PARSE-DEFMACRO
+ ("code/early-defboot") ; on host for FILE-COMMENT, DO-ANONYMOUS, etc.
+ ("code/boot-extensions") ; on host for COLLECT etc.
+ ("code/early-extensions") ; on host for SYMBOLICATE etc.
+ ("code/late-extensions") ; FIXME: maybe no longer needed on host now that
+ ; we are no longer doing PRINT-HERALD stuff
+ ("compiler/deftype") ; on host for SB!XC:DEFTYPE
+ ("code/early-alieneval") ; for vars needed both at build time and at runtime
+
+ ("code/specializable-array")
+
+ ;; for various constants e.g. SB!VM:*TARGET-MOST-POSITIVE-FIXNUM* and
+ ;; SB!VM:LOWTAG-BITS, needed by "early-objdef" and others
+ ("compiler/generic/early-vm")
+ ("compiler/generic/early-vm-macs")
+ ("compiler/generic/early-objdef")
+ ("compiler/target/parms")
+ ("code/early-array") ; needs "early-vm" numbers
+ ("code/early-cl")
+ ("code/early-load")
+
+ ;; mostly needed by stuff from comcom, but also used by "x86-vm"
+ ("code/debug-var-io")
+
+ ("code/cold-init-helper-macros")
+
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ;;; basic machinery for the target Lisp. Note that although most of these
+ ;;; files are flagged :NOT-HOST, a few might not be.
+
+ ("code/target-defbangmethod" :not-host)
+
+ ("code/early-print" :not-host)
+ ("code/early-pprint" :not-host)
+ ("code/early-impl" :not-host)
+
+ ("code/target-extensions" :not-host)
+
+ ("code/early-defstructs" :not-host) ; gotta-be-first DEFSTRUCTs
+
+ ("code/defbangstruct")
+
+ ;; This needs DEF!STRUCT, and is itself needed early so that structure
+ ;; accessors and inline functions defined here can be compiled inline
+ ;; later. (Avoiding full calls not only increases efficiency, but also
+ ;; avoids some cold init issues involving full calls to structure
+ ;; accessors.)
+ ("code/type-class")
+
+ ("code/lisp-stream" :not-host)
+
+ ("code/sysmacs" :not-host)
+
+ ;; "assembly/assemfile" was here in the sequence inherited from
+ ;; CMU CL worldcom.lisp, but also appears later in the sequence
+ ;; inherited from CMU CL comcom.lisp. We shouldn't need two versions,
+ ;; so I've deleted the one here. -- WHN 19990620
+
+ ;; FIXME: There are lots of "maybe" notes in this file, e.g.
+ ;; "maybe should be :BYTE-COMPILE T". Once the system is stable,
+ ;; look into them.
+
+ ("code/early-target-error" :not-host) ; maybe should be :BYTE-COMPILE T
+ ;; FIXME: maybe should be called "target-error", with "late-target-error"
+ ;; called "condition"
+
+ ;; a comment from classic CMU CL:
+ ;; "These guys can supposedly come in any order, but not really.
+ ;; Some are put at the end so that macros don't run interpreted
+ ;; and stuff."
+ ;; Dunno exactly what this meant or whether it still holds. -- WHN 19990803
+ ;; FIXME: more informative and up-to-date comment?
+ ("code/globals" :not-host)
+ ("code/kernel" :not-host)
+ ("code/toplevel" :not-host)
+ ("code/cold-error" :not-host)
+ ("code/fdefinition" :not-host)
+ ;; FIXME: Figure out some way to make the compiler macro for INFO
+ ;; available for compilation of "code/fdefinition".
+
+ ;; In classic CMU CL, code/type was here. I've since split that into
+ ;; lots of smaller pieces, some of which are here and some of which
+ ;; are handled later in the sequence, when the cross-compiler is
+ ;; built. -- WHN 19990620
+ ("code/target-type" :not-host)
+
+ ("code/pred" :not-host)
+
+ ("code/target-alieneval" :not-host)
+ ("code/target-c-call" :not-host)
+ ("code/target-sap" :not-host)
+
+ ("code/array" :not-host)
+ ("code/target-sxhash" :not-host)
+
+ ("code/list" :not-host)
+ ("code/seq" :not-host) ; "code/seq" should come after "code/list".
+ ("code/coerce" :not-host)
+
+ ("code/string" :not-host)
+ ("code/mipsstrops" :not-host)
+
+ ("code/unix" :not-host)
+
+ #!+mach ("code/mach" :not-host)
+ #!+mach ("code/mach-os" :not-host)
+ #!+sunos ("code/sunos-os" :not-host)
+ #!+hpux ("code/hpux-os" :not-host)
+ #!+osf1 ("code/osf1-os" :not-host)
+ #!+irix ("code/irix-os" :not-host)
+ #!+bsd ("code/bsd-os" :not-host)
+ #!+linux ("code/linux-os" :not-host)
+
+ ;; KLUDGE: I'd prefer to have this done with a "code/target" softlink
+ ;; instead of a bunch of reader macros. -- WHN 19990308
+ #!+pmax ("code/pmax-vm" :not-host)
+ #!+(and sparc svr4) ("code/sparc-svr4-vm" :not-host)
+ #!+(and sparc (not svr4)) ("code/sparc-vm" :not-host)
+ #!+rt ("code/rt-vm" :not-host)
+ #!+hppa ("code/hppa-vm" :not-host)
+ #!+x86 ("code/x86-vm" :not-host)
+ #!+alpha ("code/alpha-vm" :not-host)
+ #!+sgi ("code/sgi-vm" :not-host)
+
+ ("code/target-signal" :not-host) ; needs OS-CONTEXT-T from x86-vm
+
+ ("code/symbol" :not-host)
+ ("code/bignum" :not-host)
+ ("code/target-numbers" :not-host)
+ ("code/float-trap" :not-host)
+ ("code/float" :not-host)
+ ("code/irrat" :not-host)
+
+ ("code/char" :not-host)
+ ("code/target-misc" :not-host)
+ ("code/misc")
+
+ #!-gengc ("code/room" :not-host)
+ #!-gengc ("code/gc" :not-host)
+ #!-gengc ("code/purify" :not-host)
+
+ #!+gengc ("code/gengc" :not-host)
+
+ ("code/stream" :not-host)
+ ("code/print" :not-host)
+ ("code/pprint" :not-host) ; maybe should be :BYTE-COMPILE T
+ ("code/early-format")
+ ("code/target-format" :not-host) ; maybe should be :BYTE-COMPILE T
+ ("code/defpackage" :not-host)
+ ("code/pp-backq" :not-host) ; maybe should be :BYTE-COMPILE T
+
+ ("code/error-error" :not-host) ; needs WITH-STANDARD-IO-SYNTAX macro
+
+ ("code/serve-event" :not-host)
+ ("code/fd-stream" :not-host)
+
+ ("code/module" :not-host) ; maybe should be :BYTE-COMPILE T
+
+ #!+sb-interpreter
+ ("code/eval")
+
+ ("code/target-eval" :not-host) ; FIXME: uses INFO, wants compiler macro
+
+ ("code/interr" :not-host)
+
+ ("code/query" :not-host) ; maybe should be :BYTE-COMPILE T
+
+ ("code/sort" :not-host)
+ ("code/time" :not-host)
+ ("code/weak" :not-host)
+ ("code/final" :not-host)
+
+ #!+mp ("code/multi-proc" :not-host)
+
+ ("code/setf-funs" :not-host)
+
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ;;; compiler (and a few miscellaneous :NOT-HOST files whose
+ ;;; dependencies make it convenient to stick them here)
+
+; replaced with defbangtype.lisp in sbcl-0.6.2
+; ;; There are some things (e.g. the type SB!KERNEL:INDEX) which are
+; ;; used early in the compiler in both host and target forms (i.e.
+; ;; SB!KERNEL:INDEX defined to cross-compilation host and
+; ;; SB!KERNEL:INDEX defined to cross-compiler itself).
+; ("code/early-ugly-duplicates")
+
+ ("code/defbangtype")
+
+ ("compiler/early-c")
+ ("code/numbers")
+
+ ("code/typedefs")
+
+ ("code/defbangmacro")
+
+ ("compiler/macros")
+ ("compiler/generic/vm-macs")
+
+ ;; needed by "compiler/vop"
+ ("compiler/sset")
+
+ ;; for e.g. BLOCK-ANNOTATION, needed by "compiler/vop"
+ ("compiler/node")
+
+ ;; for e.g. PRIMITIVE-TYPE, needed by "vmdef"
+ ("compiler/vop")
+
+ ;; needed by "vm" and "primtype"
+ ("compiler/backend")
+
+ ;; for e.g. MAX-VOP-TN-REFS, needed by "meta-vmdef"
+ ("compiler/vmdef")
+
+ ;; needs "backend"
+ ("compiler/target/backend-parms")
+
+ ;; for INFO and SB!XC:MACRO-FUNCTION, needed by defmacro.lisp
+ ("compiler/globaldb")
+ ("compiler/info-functions")
+
+ ("code/defmacro")
+ ("code/force-delayed-defbangmacros")
+
+ ("compiler/late-macros")
+
+ ;; for e.g. DEF-PRIMITIVE-TYPE, needed by primtype.lisp, and
+ ;; DEFINE-STORAGE-CLASS, needed by target/vm.lisp
+ ("compiler/meta-vmdef")
+
+ ;; for e.g. DESCRIPTOR-REG, needed by primtype.lisp
+ ("compiler/target/vm")
+
+ ;; for e.g. SPECIFIER-TYPE, needed by primtype.lisp
+ ("code/early-type")
+
+ ;; FIXME: Classic CMU CL had SAFETY 2 DEBUG 2 set around the compilation
+ ;; of "code/class". Why?
+ ("code/class")
+
+ ;; The definitions for CONDITION and CONDITION-CLASS depend on
+ ;; SLOT-CLASS, defined in classes.lisp.
+ ("code/late-target-error" :not-host) ; FIXME: maybe should be :BYTE-COMPILE T
+
+ ("compiler/generic/primtype")
+
+ ;; the implementation of the compiler-affecting part of forms like
+ ;; DEFMACRO and DEFTYPE; must be loaded before we can start
+ ;; defining types
+ ("compiler/parse-lambda-list")
+
+ ;; for DEFSTRUCT ALIEN-TYPE, needed by host-type.lisp
+ ("code/host-alieneval")
+
+ ;; can't be done until definition of e.g. DEF-ALIEN-TYPE-CLASS in
+ ;; host-alieneval.lisp
+ ("code/host-c-call")
+
+ ;; SB!XC:DEFTYPE is needed in order to compile late-target-type
+ ;; in the host Common Lisp, and in order to run, it needs
+ ;; %COMPILER-DEFTYPE.
+ ("compiler/compiler-deftype")
+
+ ;; These appear here in the build sequence because they require
+ ;; * the macro INFO, defined in globaldb.lisp, and
+ ;; * the function PARSE-DEFMACRO, defined in parse-defmacro.lisp,
+ ;; and because they define
+ ;; * the function SPECIFIER-TYPE, which is used in fndb.lisp.
+ ("code/late-type")
+ ("code/deftypes-for-target")
+
+ ;; The inline definition of TYPEP-TO-LAYOUT here needs inline
+ ;; functions defined in classes.lisp, and is needed in turn by
+ ;; the target version of "code/defstruct".
+ ("code/target-defstruct" :not-host)
+
+ ;; stuff needed by "code/defstruct"
+ ("code/cross-type" :not-target)
+ ("compiler/generic/vm-type")
+
+ ;; The DEFSTRUCT machinery needs SB!XC:SUBTYPEP, defined in
+ ;; "code/late-type", and SB!XC:TYPEP, defined in "code/cross-type",
+ ;; and SPECIALIZE-ARRAY-TYPE, defined in "compiler/generic/vm-type".
+ ("code/defstruct")
+
+ ;; ALIEN-VALUE has to be defined as a class (done by DEFSTRUCT
+ ;; machinery) before we can set its superclasses here.
+ ("code/alien-type")
+
+ ("compiler/knownfun")
+
+ ;; needs IR1-ATTRIBUTES macro, defined in knownfun.lisp
+ ("compiler/proclaim")
+
+ ;; This needs not just the SB!XC:DEFSTRUCT machinery, but also
+ ;; the TYPE= stuff defined in late-type.lisp, and the
+ ;; CHECK-FUNCTION-NAME defined in proclaim.lisp.
+ ("code/force-delayed-defbangstructs")
+
+ ("code/typep")
+
+ ("compiler/compiler-error")
+
+ ("code/type-init")
+
+ ;; These define target types needed by fndb.lisp.
+ ("code/package")
+ ("code/random")
+ ("code/hash-table")
+ ("code/readtable")
+ ("code/pathname")
+ ("compiler/lexenv")
+
+ ;; KLUDGE: Much stuff above here is the type system and/or the INFO
+ ;; system, not really the compiler proper. It might be easier to
+ ;; understand the system if those things were split off into packages
+ ;; SB-TYPE and SB-INFO and built in their own sections. -- WHN 20000124
+
+ ;; In classic CMU CL (re)build order, these were done later, but
+ ;; in building from scratch, these must be loaded before
+ ;; "compiler/generic/objdef" in order to allow forms like
+ ;; (DEFINE-PRIMITIVE-OBJECT (..) (CAR ..) ..) to work.
+ ("compiler/fndb")
+ ("compiler/generic/vm-fndb")
+
+ ("compiler/generic/objdef")
+
+ ("compiler/generic/interr")
+
+ ("compiler/bit-util")
+
+ ("compiler/early-assem") ; has ASSEMBLY-UNIT-related stuff needed by core.lisp
+
+ ;; core.lisp contains DEFSTRUCT CORE-OBJECT, and "compiler/main.lisp"
+ ;; does lots of (TYPEP FOO 'CORE-OBJECT), so it's nice to compile this
+ ;; before "compiler/main.lisp" so that those can be coded efficiently
+ ;; (and so that they don't cause lots of annoying compiler warnings
+ ;; about undefined types).
+ ("compiler/generic/core")
+
+ ("code/load")
+
+ ("code/fop") ; needs macros from code/host-load.lisp
+
+ ("compiler/ctype")
+ ("compiler/disassem")
+ ("compiler/assem")
+
+ ("compiler/trace-table") ; needs EMIT-LABEL macro from compiler/assem.lisp
+
+ ;; Compiling this file requires fop definitions from code/fop.lisp
+ ;; and trace table definitions from compiler/trace-table.lisp.
+ ("compiler/dump")
+
+ ("compiler/main") ; needs DEFSTRUCT FASL-FILE from compiler/dump.lisp
+ ("compiler/target-main" :not-host)
+ ("compiler/ir1tran")
+ ("compiler/ir1util")
+ ("compiler/ir1opt")
+
+ ;; Compiling this file requires the macros SB!ASSEM:EMIT-LABEL and
+ ;; SB!ASSEM:EMIT-POST-IT, defined in assem.lisp.
+ ("compiler/late-vmdef")
+
+ ("compiler/ir1final")
+ ("compiler/array-tran")
+ ("compiler/seqtran")
+ ("compiler/typetran")
+ ("compiler/generic/vm-typetran")
+ ("compiler/float-tran")
+ ("compiler/saptran")
+ ("compiler/srctran")
+ ("compiler/locall")
+ ("compiler/dfo")
+ ("compiler/checkgen")
+ ("compiler/constraint")
+ ("compiler/envanal")
+
+ ("compiler/tn")
+ ("compiler/life")
+
+ ("code/debug-info")
+
+ ("compiler/debug-dump")
+ ("compiler/generic/utils")
+ ("assembly/assemfile")
+
+ ("compiler/fixup") ; for DEFSTRUCT FIXUP, used by insts.lisp
+
+ ("compiler/target/insts")
+ ("compiler/target/macros")
+
+ ("assembly/target/support")
+
+ ("compiler/target/move")
+ ("compiler/target/float")
+ ("compiler/target/sap")
+ ("compiler/target/system")
+ ("compiler/target/char")
+ ("compiler/target/memory")
+ ("compiler/target/static-fn")
+ ("compiler/target/arith")
+ ("compiler/target/subprim")
+
+ ("compiler/target/debug")
+ ("compiler/target/c-call")
+ ("compiler/target/cell")
+ ("compiler/target/values")
+ ("compiler/target/alloc")
+ ("compiler/target/call")
+ ("compiler/target/nlx")
+ ("compiler/target/show")
+ ("compiler/target/array"
+ ;; KLUDGE: Compiling this file raises alarming warnings of the form
+ ;; Argument FOO to VOP CHECK-BOUND has SC restriction
+ ;; DESCRIPTOR-REG which is not allowed by the operand type:
+ ;; (:OR POSITIVE-FIXNUM)
+ ;; This seems not to be something that I broke, but rather a "feature"
+ ;; inherited from classic CMU CL. (Debian cmucl_2.4.8.deb compiling
+ ;; Debian cmucl_2.4.8.tar.gz raises the same warning). Thus, even though
+ ;; these warnings are severe enough that they would ordinarily abort
+ ;; compilation, for now we blithely ignore them and press on to more
+ ;; pressing problems. Someday, though, it would be nice to figure out
+ ;; what the problem is and fix it.. -- WHN 19990323
+ ;; FIXME: This problem doesn't seem to occur in the cross-compiler.
+ ;; Check whether it occurs when compiling with the final target SBCL.
+ ;; If it doesn't, we can punt the KLUDGE message.
+ :ignore-failure-p)
+ ("compiler/target/pred")
+ ("compiler/target/type-vops")
+
+ ("assembly/target/assem-rtns" :assem)
+ ("assembly/target/array" :assem)
+ ("assembly/target/arith" :assem)
+ ("assembly/target/alloc" :assem)
+
+ ("compiler/pseudo-vops")
+
+ ("compiler/aliencomp")
+
+ ("compiler/ltv")
+ ("compiler/gtn")
+ ("compiler/ltn")
+ ("compiler/stack")
+ ("compiler/control")
+ ("compiler/entry")
+ ("compiler/ir2tran")
+
+ ;; KLUDGE: This has #!+GENGC things in it which are intended to
+ ;; overwrite code in ir2tran.lisp, so it has to come after ir2tran.lisp.
+ ;;
+ ;; FIXME: Those things should probably be ir2tran.lisp instead, and the
+ ;; things they now overwrite should instead be #!-GENGC so they're never
+ ;; generated in the first place.
+ ("compiler/generic/vm-ir2tran")
+
+ ("compiler/copyprop")
+ ("compiler/represent")
+ ("compiler/generic/vm-tran")
+ ("compiler/pack")
+ ("compiler/codegen")
+ ("compiler/debug")
+
+ #!+sb-dyncount ("compiler/dyncount")
+ #!+sb-dyncount ("code/dyncount")
+
+ ;; needed by OPEN-FASL-FILE, which is called by COMPILE-FILE
+ ("code/format-time")
+
+ ;; needed by various unhappy-path cases in the cross-compiler
+ ("code/error")
+
+ ;; This wasn't in classic CMU CL "comcom.lisp", but it has some stuff
+ ;; that Python-as-cross-compiler has turned out to need.
+ ("code/macroexpand")
+
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ;; files which are only needed in the target system, and/or which are
+ ;; only possible in the target system, and which depend in some way
+ ;; (directly or indirectly) on stuff compiled as part of the compiler
+
+ ("compiler/generic/target-core" :not-host) ; uses stuff from
+ ; "compiler/generic/core"
+
+ ("code/target-package" :not-host) ; needs "code/package"
+ ("code/target-random" :not-host) ; needs "code/random"
+ ("code/target-hash-table" :not-host) ; needs "code/hash-table"
+ ("code/reader" :not-host) ; needs "code/readtable"
+ ("code/target-pathname" :not-host) ; needs "code/pathname", maybe
+ ; should be :BYTE-COMPILE T
+ ("code/filesys" :not-host) ; needs HOST from "code/pathname",
+ ; maybe should be :BYTE-COMPILE T
+ ("code/save" :not-host) ; uses the definition of PATHNAME
+ ; from "code/pathname"
+ ("code/sharpm" :not-host) ; uses stuff from "code/reader"
+
+ ;; stuff for byte compilation. This works only in the target system,
+ ;; because fundamental BYTE-FUNCTION-OR-CLOSURE types are implemented
+ ;; as nonportable FUNCALLABLE-INSTANCEs.
+ ("code/byte-types" :not-host)
+ ("compiler/byte-comp")
+ ("compiler/target-byte-comp" :not-host)
+ ;; FIXME: Could byte-interp be moved here? It'd be logical..
+
+ ;; defines SB!DI:DO-DEBUG-FUNCTION-BLOCKS, needed by target-disassem.lisp
+ ("code/debug-int" :not-host)
+
+ ;; target-only assemblerish stuff
+ ("compiler/target-disassem" :not-host)
+ ("compiler/target/target-insts" :not-host)
+
+ ;; the IR1 interpreter (as opposed to the byte code interpreter)
+ #!+sb-interpreter ("compiler/eval-comp" :not-host)
+ #!+sb-interpreter ("compiler/eval" :not-host)
+
+ ("code/debug" :not-host) ; maybe should be :BYTE-COMPILE T
+ ;; FIXME: This has been moved to warm init, and should be deleted here.
+ #+nil ("code/ntrace" :not-host) ; maybe should be :BYTE-COMPILE T
+
+ ;; These can't be compiled until CONDITION and DEFINE-CONDITION
+ ;; are defined, and they also use SB-DEBUG:*STACK-TOP-HINT*.
+ ("code/parse-defmacro-errors" :not-host)
+
+ ("code/bit-bash" :not-host) ; needs %NEGATE from assembly/target/arith
+
+ ("code/byte-interp" :not-host) ; needs *SYSTEM-CONSTANT-CODES* from byte-comp
+
+ ("code/target-load" :not-host) ; needs specials from code/load.lisp
+
+ ;; FIXME: Does this really need stuff from compiler/dump.lisp?
+ ("compiler/target-dump" :not-host) ; needs stuff from compiler/dump.lisp
+
+ ("code/cold-init" :not-host) ; needs (SETF EXTERN-ALIEN) macroexpansion
+
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ;; target macros and DECLAIMs installed at build-the-cross-compiler time
+
+ ;; Declare all target special variables defined by ANSI now, so that
+ ;; we don't have to worry about any of them being bound incorrectly
+ ;; when the compiler processes code which appears before the appropriate
+ ;; DEFVAR or DEFPARAMETER.
+ ("code/cl-specials")
+
+ ;; fundamental target macros (e.g. CL:DO and CL:DEFUN) and support
+ ;; for them
+ ;;
+ ;; FIXME: Since a lot of this code is just macros, perhaps it should be
+ ;; byte compiled?
+ ("code/defboot")
+ ("code/destructuring-bind")
+ ("code/early-setf")
+ ("code/macros")
+ ("code/loop")
+ ("code/late-setf")
+
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+ ;; other target-code-building stuff which can't be processed until
+ ;; machinery like SB!XC:DEFMACRO exists
+
+ ("code/late-format") ; needs SB!XC:DEFMACRO
+ ("code/sxhash") ; needs SB!XC:DEFINE-MODIFY-MACRO
+ ("code/signal")
+ ("code/late-defbangmethod"))
--- /dev/null
+#!/bin/sh
+
+etags `find $PWD/src -name '*.lisp' -o -name '*.c' -o -name '*.h'`
--- /dev/null
+;;;; some stuff to check that bignum operations are returning correct
+;;;; results
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!BIGNUM")
+
+(file-comment
+ "$Header$")
+
+(defvar *in-bignum-wrapper* nil)
+
+(defmacro def-bignum-wrapper (name lambda-list &body body)
+ (let ((var-name (sb!int:symbolicate "*OLD-" name "*"))
+ (wrap-name (sb!int:symbolicate "WRAP-" name))
+ (args (mapcar #'(lambda (x)
+ (if (listp x) (car x) x))
+ (remove-if #'(lambda (x)
+ (member x lambda-list-keywords))
+ lambda-list))))
+ `(progn
+ (defvar ,var-name (fdefinition ',name))
+ (defun ,wrap-name ,lambda-list
+ (if *in-bignum-wrapper*
+ (funcall ,var-name ,@args)
+ (let ((*in-bignum-wrapper* t))
+ ,@body)))
+ (setf (fdefinition ',name) #',wrap-name))))
+
+(defun big= (x y)
+ (= (if (typep x 'bignum)
+ (%normalize-bignum x (%bignum-length x))
+ x)
+ (if (typep y 'bignum)
+ (%normalize-bignum y (%bignum-length y))
+ y)))
+
+(def-bignum-wrapper add-bignums (x y)
+ (let ((res (funcall *old-add-bignums* x y)))
+ (assert (big= (- res y) x))
+ res))
+
+(def-bignum-wrapper multiply-bignums (x y)
+ (let ((res (funcall *old-multiply-bignums* x y)))
+ (if (zerop x)
+ (assert (zerop res))
+ (multiple-value-bind (q r) (truncate res x)
+ (assert (and (zerop r) (big= q y)))))
+ res))
+
+(def-bignum-wrapper negate-bignum (x &optional (fully-normalized t))
+ (let ((res (funcall *old-negate-bignum* x fully-normalized)))
+ (assert (big= (- res) x))
+ res))
+
+(def-bignum-wrapper subtract-bignum (x y)
+ (let ((res (funcall *old-subtract-bignum* x y)))
+ (assert (big= (+ res y) x))
+ res))
+
+(def-bignum-wrapper multiply-bignum-and-fixnum (x y)
+ (let ((res (funcall *old-multiply-bignum-and-fixnum* x y)))
+ (if (zerop x)
+ (assert (zerop res))
+ (multiple-value-bind (q r) (truncate res x)
+ (assert (and (zerop r) (big= q y)))))
+ res))
+
+(def-bignum-wrapper multiply-fixnums (x y)
+ (let ((res (funcall *old-multiply-fixnums* x y)))
+ (if (zerop x)
+ (assert (zerop res))
+ (multiple-value-bind (q r) (truncate res x)
+ (assert (and (zerop r) (big= q y)))))
+ res))
+
+(def-bignum-wrapper bignum-ashift-right (x shift)
+ (let ((res (funcall *old-bignum-ashift-right* x shift)))
+ (assert (big= (ash res shift) (logand x (ash -1 shift))))
+ res))
+
+(def-bignum-wrapper bignum-ashift-left (x shift)
+ (let ((res (funcall *old-bignum-ashift-left* x shift)))
+ (assert (big= (ash res (- shift)) x))
+ res))
+
+(def-bignum-wrapper bignum-truncate (x y)
+ (multiple-value-bind (q r) (funcall *old-bignum-truncate* x y)
+ (assert (big= (+ (* q y) r) x))
+ (values q r)))
+
+(def-bignum-wrapper bignum-compare (x y)
+ (let ((res (funcall *old-bignum-compare* x y)))
+ (assert (big= (signum (- x y)) res))
+ res))
--- /dev/null
+(defpackage "FOO"
+ (:use "CL"))
+(in-package "FOO")
+\f
+;;;; It should be possible to do DEFGENERIC and DEFMETHOD referring to
+;;;; structure types defined earlier in the file.
+
+(defstruct struct-a x y)
+(defstruct struct-b x y z)
+
+(defmethod wiggle ((a struct-a))
+ (+ (struct-a-x a)
+ (struct-a-y a)))
+(defgeneric jiggle ((arg t)))
+(defmethod jiggle ((a struct-a))
+ (- (struct-a-x a)
+ (struct-a-y a)))
+(defmethod jiggle ((b struct-b))
+ (- (struct-b-x b)
+ (struct-b-y b)
+ (struct-b-z b)))
+
+(assert (= (wiggle (make-struct-a :x 6 :y 5))
+ (jiggle (make-struct-b :x 19 :y 6 :z 2))))
+\f
+;;; Compiling DEFGENERIC should prevent "undefined function" style warnings
+;;; from code within the same file.
+
+(defgeneric gf-defined-in-this-file ((x number) (y number)))
+(defun function-using-gf-defined-in-this-file (x y n)
+ (unless (minusp n)
+ (gf-defined-in-this-file x y)))
--- /dev/null
+;;;; Process files named by standard input, requiring success.
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The 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")
+
+(loop
+ (let ((filename (read nil)))
+
+ (unless filename
+ (return))
+
+ ;; The file should work compiled.
+ (load (compile-file filename))
+
+ ;; The file should work interpreted too.
+ (load filename)))
--- /dev/null
+#!/bin/sh
+
+# Run the regression tests in this directory.
+
+# how we invoke SBCL
+sbcl=${1:-sbcl --noprint --noprogrammer}
+
+# *.pure.lisp files are ordinary Lisp code with no side effects,
+# and we can run them all in a single Lisp process.
+(for f in *.pure.lisp; do echo \"$f\"; done) | $sbcl < pure.lisp
+
+# *.impure.lisp files are Lisp code with side effects (e.g. doing DEFSTRUCT
+# or DEFTYPE or DEFVAR). Each one needs to be run as a separate
+# invocation of Lisp.
+for f in *.impure.lisp; do
+ echo $f | $sbcl < pure.lisp
+done
+
+# *.test.sh files are scripts to test stuff. A file foo.test.sh
+# may be associated with other files foo*, e.g. foo.lisp, foo-1.lisp,
+# or foo.pl.
+for f in *.test.sh; do
+ sh $f
+done
--- /dev/null
+;;;; a stress test for the garbage collector
+
+;;;; TO DO:
+;;;; * Add conses:
+;;;; ** Make REPR-CONS.
+;;;; ** Some generations should be lists, not vectors.
+;;;; * Make it so that ASSIGN-GENERATION on an existing generation
+;;;; only overwrites some of the elements (randomly), not all.
+;;;; * Review the GC code to look for other stuff I should test.
+
+(in-package :cl-user)
+
+(declaim (optimize (safety 3) (speed 2)))
+
+;;; a table of functions REPR-FOO which bear a vague correspondence
+;;; to the types of memory representations used by SBCL (with each
+;;; typically trying to exercise that type of representation)
+(defvar *reprs*)
+(declaim (type simple-vector *reprs*))
+
+(defun repr (i)
+ (declare (type fixnum i))
+ (let ((result (svref *reprs* (mod i (length *reprs*)))))
+ #+nil (/show "REPRESENT" i result)
+ result))
+
+(defun stress-gc (n-passes &optional (size 3000))
+ (format t "~&beginning STRESS-GC N-PASSES=~D SIZE=~D~%" n-passes size)
+ (let ((generations (make-array (isqrt size) :initial-element nil))
+ ;; We allocate on the order of MOST-POSITIVE-FIXNUM things
+ ;; before doing a full GC.
+ (max-passes-to-full-gc (floor most-positive-fixnum size))
+ (remaining-passes-to-full-gc 0))
+ (dotimes (j-pass n-passes)
+ #+nil (/show j-pass)
+ (if (plusp remaining-passes-to-full-gc)
+ (decf remaining-passes-to-full-gc)
+ (progn
+ #+nil (/show "doing GC :FULL T")
+ (gc :full t)
+ (setf remaining-passes-to-full-gc (random max-passes-to-full-gc))))
+ (let* (;; (The (ISQRT (RANDOM (EXPT .. 2))) distribution here is
+ ;; intended to give a distribution of lifetimes of memory
+ ;; usage, with low-indexed generations tending to live
+ ;; for a long time.)
+ (i-generation (isqrt (random (expt (length generations) 2))))
+ (generation-i (aref generations i-generation)))
+ #+nil (/show i-generation generation-i)
+ (when generation-i
+ (assert-generation i-generation generation-i))
+ (when (or (null generation-i)
+ (plusp (random 3)))
+ #+nil (/show "allocating or reallocating" i-generation)
+ (setf generation-i
+ (make-array (random (1+ size)))))
+ (assign-generation i-generation generation-i)
+ (when (plusp (random 3))
+ (assert-generation i-generation generation-i))
+ (setf (aref generations i-generation)
+ generation-i))))
+ (format t "~&done with STRESS-GC N-PASSES=~D SIZE=~D~%" n-passes size))
+
+(defvar *expected*)
+(defvar *got*)
+(defun assert-generation (index-of-generation generation)
+ (dotimes (index-within-generation (length generation))
+ #+nil (/show "assert-generation" index-of-generation index-within-generation)
+ (let ((element-of-generation (aref generation index-within-generation))
+ (repr (repr (+ index-within-generation index-of-generation))))
+ (unless (funcall repr index-within-generation element-of-generation)
+ ;; KLUDGE: We bind these to special variables for the
+ ;; convenience of the debugger, which ca. SBCL 0.6.6 is too
+ ;; wimpy to inspect lexical variables.
+ (let ((*expected* (funcall repr index-within-generation))
+ (*got* element-of-generation))
+ (error "bad element #~D in generation #~D:~% expected ~S~% from ~S,~% got ~S"
+ index-within-generation
+ index-of-generation
+ *expected*
+ repr
+ *got*))))))
+
+(defun assign-generation (index-of-generation generation)
+ (dotimes (index-within-generation (length generation))
+ #+nil (/show "assert-generation" index-of-generation index-within-generation)
+ (setf (aref generation index-within-generation)
+ (funcall (repr (+ index-within-generation index-of-generation))
+ index-within-generation))))
+
+(defun repr-fixnum (index &optional (value nil value-p))
+ (let ((fixnum (the fixnum (+ index 101))))
+ (if value-p
+ (eql fixnum value)
+ fixnum)))
+
+(defun repr-function (index &optional (value nil value-p))
+ (let ((fixnum (mod (+ index 2) 3)))
+ (if value-p
+ (eql fixnum (funcall value))
+ (ecase fixnum
+ (0 #'repr-fixnum-zero)
+ (1 #'repr-fixnum-one)
+ (2 #'repr-fixnum-two)))))
+(defun repr-fixnum-zero () 0)
+(defun repr-fixnum-one () 1)
+(defun repr-fixnum-two () 2)
+
+(defstruct repr-instance slot)
+(defun repr-instance (index &optional (value nil value-p))
+ (let ((fixnum (mod (* index 3) 4)))
+ (if value-p
+ (and (typep value 'repr-instance)
+ (eql (repr-instance-slot value) fixnum))
+ (make-repr-instance :slot fixnum))))
+
+(defun repr-eql-hash-table (index &optional (value nil value-p))
+ (let ((first-fixnum (mod (* index 31) 9))
+ (n-fixnums 5))
+ (if value-p
+ (and (hash-table-p value)
+ (= (hash-table-count value) n-fixnums)
+ (dotimes (i n-fixnums t)
+ (unless (= (gethash (+ i first-fixnum) value) i)
+ (return nil)))
+ #|
+ (repr-bignum index (gethash 'bignum value))
+ (repr-ratio index (gethash 'ratio value))
+ |#)
+ (let ((hash-table (make-hash-table :test 'eql)))
+ (dotimes (i n-fixnums)
+ (setf (gethash (+ first-fixnum i) hash-table) i))
+ #|
+ (setf (gethash 'bignum hash-table) (repr-bignum index)
+ (gethash 'ratio hash-table) (repr-ratio index))
+ |#
+ hash-table))))
+
+(defun repr-bignum (index &optional (value nil value-p))
+ (let ((bignum (+ index 10000300020)))
+ (if value-p
+ (eql value bignum)
+ bignum)))
+
+(defun repr-ratio (index &optional (value nil value-p))
+ (let ((ratio (/ index (1+ index))))
+ (if value-p
+ (eql value ratio)
+ ratio)))
+
+(defun repr-single-float (index &optional (value nil value-p))
+ (let ((single-float (* 0.25 (float index) (1+ (float index)))))
+ (if value-p
+ (eql value single-float)
+ single-float)))
+
+(defun repr-double-float (index &optional (value nil value-p))
+ (let ((double-float (+ 0.25d0 (1- index) (1+ (float index)))))
+ (if value-p
+ (eql value double-float)
+ double-float)))
+
+(defun repr-simple-string (index &optional (value nil value-p))
+ (let ((length (mod index 14)))
+ (if value-p
+ (and (stringp value)
+ (typep value 'simple-array)
+ (= (length value) length))
+ (make-string length))))
+
+(defun repr-simple-vector (index &optional (value nil value-p))
+ (let ((length (mod (1+ index) 16)))
+ (if value-p
+ (and (simple-vector-p value)
+ (= (array-dimension value 0) length))
+ (make-array length))))
+
+(defun repr-complex-vector (index &optional (value nil value-p))
+ (let* ((size (mod (* 5 index) 13))
+ (length (floor size 3)))
+ (if value-p
+ (and (vectorp value)
+ (not (typep value 'simple-array))
+ (= (array-dimension value 0) size)
+ (= (length value) length))
+ (make-array size :fill-pointer length))))
+
+(defun repr-symbol (index &optional (value nil value-p))
+ (let* ((symbols #(zero one two three four))
+ (symbol (aref symbols (mod index (length symbols)))))
+ (if value-p
+ (eq value symbol)
+ symbol)))
+
+(defun repr-base-char (index &optional (value nil value-p))
+ (let* ((base-chars #(#\z #\o #\t #\t #\f #\f #\s #\s #\e))
+ (base-char (aref base-chars (mod index (length base-chars)))))
+ (if value-p
+ (eql value base-char)
+ base-char)))
+
+(setf *reprs*
+ (vector #'repr-fixnum
+ #'repr-function
+ #'repr-instance
+ #'repr-eql-hash-table
+#|
+ #'repr-equal-hash-table
+ #'repr-equalp-hash-table
+|#
+ #'repr-bignum
+ #'repr-ratio
+ #'repr-single-float
+ #'repr-double-float
+#|
+ #'repr-complex-single-float
+ #'repr-complex-double-float
+ #'repr-simple-array
+|#
+ #'repr-simple-string
+#|
+ #'repr-simple-bit-vector
+|#
+ #'repr-simple-vector
+#|
+ #'repr-simple-array-u2
+ #'repr-simple-array-u4
+ #'repr-simple-array-u8
+ #'repr-simple-array-u16
+ #'repr-simple-array-u32
+ #'repr-simple-array-single-float
+ #'repr-simple-array-double-float
+ #'repr-complex-string
+ #'repr-complex-bit-vector
+|#
+ #'repr-complex-vector
+#|
+ #'repr-complex-array
+ ;; TO DO: #'repr-funcallable-instance
+ ;; TO DO: #'repr-byte-code-function
+ ;; TO DO: #'repr-byte-code-closure
+|#
+ #'repr-symbol
+ #'repr-base-char
+ ;; TO DO: #'repr-sap
+ ;; TO DO? #'repr-unbound-marker
+ ;; TO DO? #'repr-weak-pointer
+ ;; TO DO? #'repr-instance-header
+ ;; TO DO? #'repr-fdefn
+ ))
+
\ No newline at end of file
--- /dev/null
+#!/bin/sh
+
+sbcl <<EOF
+ (compile-file "WHN/stress-gc.lisp")
+ (load *)
+ (time (stress-gc ${1:-100000} ${2:-3000}))
+ (format t "~&test completed successfully~%")
+EOF
--- /dev/null
+(in-package :cl-user)
+
+(defun vector-tests ()
+ (let ((simple-t (make-array 35))
+ (simple-u32 (make-array 50 :element-type '(unsigned-byte 32)))
+ (simple-character (make-string 44))
+ (complex-t (make-array 35 :fill-pointer 3))
+ (complex-u32 (make-array 88 :element-type '(unsigned-byte 32)))
+ (complex-character (make-array 14
+ :element-type 'character
+ :fill-pointer t)))
+ (assert (= (length simple-t) 35))))
--- /dev/null
+;;; This is the master value for LISP-IMPLEMENTATION-VERSION. It's
+;;; separated into its own file here so that it's easy for
+;;; text-munging make-ish or cvs-ish scripts to find and tweak it. For
+;;; the convenience of such scripts, only a trivial subset of Lisp
+;;; reader syntax should be used here: semicolon-delimited comments,
+;;; possible blank lines or other whitespace, and a single
+;;; double-quoted string value alone on its own line.
+;;;
+;;; ANSI says LISP-IMPLEMENTATION-VERSION can be NIL "if no
+;;; appropriate and relevant result can be produced", but as long as
+;;; we control the build, we can always assign an appropriate and
+;;; relevant result, so this must be a string, not NIL.
+;;;
+;;; Conventionally a string a la "0.6.6" is used for released
+;;; versions, and a string a la "0.6.5.12" is used for versions which
+;;; aren't released but correspond only to CVS tags.
+
+"0.6.7.1"
--- /dev/null
+#!/bin/sh
+
+# How big is this project anyway? Crudely estimate non-comment source lines..
+
+echo -n "approximate Lisp source lines: "
+find . -name "*.lisp" -print | xargs egrep -hs '^[ ]*[^ ;]' | wc -l
+echo -n "approximate Lisp source non-whitespace chars: "
+find . -name "*.lisp" -print | xargs egrep -hs '^[ ]*[^ ;]' \
+ | perl -ne 's/\s//g ; print' | wc -c
+# some errors in Lisp counting above:
+# * doesn't catch #| .. |#
+# * doesn't catch #+NIL convention for commenting out forms
+# * doesn't catch stale source files which are no longer used
+
+echo -n "approximate C source lines: "
+find . -name "*.[ch]" -print | xargs egrep -s '^[ ]*[^ /*]' | wc -l
+# errors:
+# * only crudely approximates "/*"-style commenting (using the assumption
+# that all lines beginning with "/" or "*" are beginning of comments or
+# continuation of comments respectively)
+# * doesn't catch #if 0 convention for commenting out blocks
+# * doesn't catch stale source files which are no longer used
+
+# There are assembler source lines, too, but there seem to be less than
+# 1000 for each machine type. (Hardly worth considering!:-)
projects / sbcl.git / commitdiff